Lots of bad TAB eliminations.
I started from tabs that are not on the beginning of lines, and in several places I did further cleanings. If you're worried about knowing who wrote some code, for example, if you get to this commit in "git blame", then note that you can use the "-w" flag in many git commands to ignore whitespaces. For example, to see per-line authors, use "git blame -w <file>". Another example: to see the (*much* smaller) non-whitespace changes in this (or any other) commit, use "git log -p -w -1 <sha1>". original commit: 672910f27b856549ad08d38832b6714edf226c8e
This commit is contained in:
Eli Barzilay
parent
ab6d9e0762
commit
5b1e17cc7c
|
|
@ -739,7 +739,7 @@
|
|||
(send edit on-char event)
|
||||
(loop (sub1 n)))))
|
||||
(λ ()
|
||||
(send edit end-edit-sequence)))))))
|
||||
(send edit end-edit-sequence)))))))
|
||||
#t))
|
||||
(send km set-break-sequence-callback done)
|
||||
#t))]
|
||||
|
|
@ -823,7 +823,7 @@
|
|||
(λ (edit event)
|
||||
(when building-macro
|
||||
(set! current-macro (reverse building-macro))
|
||||
(set! build-protect? #f)
|
||||
(set! build-protect? #f)
|
||||
(send build-macro-km break-sequence))
|
||||
#t)]
|
||||
[delete-key
|
||||
|
|
|
|||
|
|
@ -538,7 +538,7 @@
|
|||
#f)]
|
||||
[last-para (and last
|
||||
(position-paragraph last))])
|
||||
(letrec
|
||||
(letrec
|
||||
([find-offset
|
||||
(λ (start-pos)
|
||||
(define tab-char? #f)
|
||||
|
|
|
|||
|
|
@ -321,7 +321,7 @@
|
|||
[else
|
||||
(update-control ctrl)
|
||||
(send ctrl command event)
|
||||
(void)]))))))
|
||||
(void)]))))))
|
||||
|
||||
;;
|
||||
;; BUTTON
|
||||
|
|
|
|||
|
|
@ -329,7 +329,7 @@
|
|||
(send blue get-value)))]
|
||||
[install-color
|
||||
(lambda (color)
|
||||
(send red set-value (send color red))
|
||||
(send red set-value (send color red))
|
||||
(send green set-value (send color green))
|
||||
(send blue set-value (send color blue))
|
||||
(send canvas refresh))])
|
||||
|
|
|
|||
|
|
@ -19,9 +19,10 @@
|
|||
|
||||
(define canvas-default-size 20) ; a default size for canvases tht fits borders without losing client sizes
|
||||
(define canvas-scroll-size 10)
|
||||
(define canvas-control-border-extra (case (system-type)
|
||||
[(windows) 2]
|
||||
[else 0]))
|
||||
(define canvas-control-border-extra
|
||||
(case (system-type)
|
||||
[(windows) 2]
|
||||
[else 0]))
|
||||
|
||||
(define canvas<%>
|
||||
(interface (subwindow<%>)
|
||||
|
|
|
|||
|
|
@ -8,8 +8,8 @@
|
|||
_GdkScreen
|
||||
_gpointer
|
||||
_GType
|
||||
_GdkEventType
|
||||
_GdkAtom
|
||||
_GdkEventType
|
||||
_GdkAtom
|
||||
|
||||
_fnpointer
|
||||
_gboolean
|
||||
|
|
@ -31,9 +31,9 @@
|
|||
(struct-out GdkEventExpose)
|
||||
_GdkEventFocus _GdkEventFocus-pointer
|
||||
(struct-out GdkEventFocus)
|
||||
_GdkEventSelection _GdkEventSelection-pointer
|
||||
_GdkEventSelection _GdkEventSelection-pointer
|
||||
(struct-out GdkEventSelection)
|
||||
_GdkRectangle _GdkRectangle-pointer
|
||||
_GdkRectangle _GdkRectangle-pointer
|
||||
(struct-out GdkRectangle)
|
||||
_GdkColor _GdkColor-pointer
|
||||
(struct-out GdkColor)))
|
||||
|
|
@ -135,11 +135,11 @@
|
|||
(define-cstruct _GdkEventSelection ([type _GdkEventType]
|
||||
[window _GdkWindow]
|
||||
[send_event _byte]
|
||||
[selection _GdkAtom]
|
||||
[target _GdkAtom]
|
||||
[property _GdkAtom]
|
||||
[time _uint32]
|
||||
[requestor _pointer]))
|
||||
[selection _GdkAtom]
|
||||
[target _GdkAtom]
|
||||
[property _GdkAtom]
|
||||
[time _uint32]
|
||||
[requestor _pointer]))
|
||||
|
||||
(define-cstruct _GdkRectangle ([x _int]
|
||||
[y _int]
|
||||
|
|
@ -155,8 +155,8 @@
|
|||
|
||||
(define-cstruct _GdkEventFocus ([type _GdkEventType]
|
||||
[window _GdkWindow]
|
||||
[send_event _byte]
|
||||
[in _short]))
|
||||
[send_event _byte]
|
||||
[in _short]))
|
||||
|
||||
(define-cstruct _GdkColor ([pixel _uint32]
|
||||
[red _uint16]
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
#lang racket/base
|
||||
(require ffi/unsafe
|
||||
racket/class
|
||||
net/uri-codec
|
||||
net/uri-codec
|
||||
ffi/unsafe/atomic
|
||||
"../../syntax.rkt"
|
||||
"../../lock.rkt"
|
||||
|
|
@ -18,7 +18,7 @@
|
|||
"const.rkt"
|
||||
"types.rkt"
|
||||
"widget.rkt"
|
||||
"clipboard.rkt")
|
||||
"clipboard.rkt")
|
||||
|
||||
(provide
|
||||
(protect-out window%
|
||||
|
|
@ -35,7 +35,7 @@
|
|||
|
||||
connect-focus
|
||||
connect-key-and-mouse
|
||||
connect-enter-and-leave
|
||||
connect-enter-and-leave
|
||||
do-button-event
|
||||
|
||||
(struct-out GtkRequisition) _GtkRequisition-pointer
|
||||
|
|
@ -54,9 +54,9 @@
|
|||
|
||||
request-flush-delay
|
||||
cancel-flush-delay
|
||||
win-box-valid?
|
||||
window->win-box
|
||||
unrealize-win-box)
|
||||
win-box-valid?
|
||||
window->win-box
|
||||
unrealize-win-box)
|
||||
gtk->wx
|
||||
gtk_widget_show
|
||||
gtk_widget_hide)
|
||||
|
|
@ -92,15 +92,15 @@
|
|||
(define the-accelerator-group (gtk_accel_group_new))
|
||||
|
||||
(define-cstruct _GtkWidgetT ([obj _GtkObject]
|
||||
[private_flags _uint16]
|
||||
[state _byte]
|
||||
[saved_state _byte]
|
||||
[name _pointer]
|
||||
[style _pointer]
|
||||
[req _GtkRequisition]
|
||||
[alloc _GtkAllocation]
|
||||
[window _GdkWindow]
|
||||
[parent _GtkWidget]))
|
||||
[private_flags _uint16]
|
||||
[state _byte]
|
||||
[saved_state _byte]
|
||||
[name _pointer]
|
||||
[style _pointer]
|
||||
[req _GtkRequisition]
|
||||
[alloc _GtkAllocation]
|
||||
[window _GdkWindow]
|
||||
[parent _GtkWidget]))
|
||||
|
||||
(define (widget-window gtk)
|
||||
(GtkWidgetT-window (cast gtk _GtkWidget _GtkWidgetT-pointer)))
|
||||
|
|
@ -123,20 +123,20 @@
|
|||
(lambda (gtk context x y data info time)
|
||||
(let ([wx (gtk->wx gtk)])
|
||||
(when wx
|
||||
(let ([bstr (scheme_make_sized_byte_string
|
||||
(gtk_selection_data_get_data data)
|
||||
(gtk_selection_data_get_length data)
|
||||
1)])
|
||||
(cond
|
||||
[(regexp-match #rx#"^file://(.*)\r\n$" bstr)
|
||||
=> (lambda (m)
|
||||
(queue-window-event wx
|
||||
(lambda ()
|
||||
(let ([path
|
||||
(string->path
|
||||
(uri-decode
|
||||
(bytes->string/utf-8 (cadr m))))])
|
||||
(send wx on-drop-file path)))))]))))))
|
||||
(let ([bstr (scheme_make_sized_byte_string
|
||||
(gtk_selection_data_get_data data)
|
||||
(gtk_selection_data_get_length data)
|
||||
1)])
|
||||
(cond
|
||||
[(regexp-match #rx#"^file://(.*)\r\n$" bstr)
|
||||
=> (lambda (m)
|
||||
(queue-window-event wx
|
||||
(lambda ()
|
||||
(let ([path
|
||||
(string->path
|
||||
(uri-decode
|
||||
(bytes->string/utf-8 (cadr m))))])
|
||||
(send wx on-drop-file path)))))]))))))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
|
@ -147,7 +147,7 @@
|
|||
(when wx
|
||||
(send wx focus-change #t)
|
||||
(when (send wx on-focus? #t)
|
||||
(queue-window-event wx (lambda () (send wx on-set-focus)))))
|
||||
(queue-window-event wx (lambda () (send wx on-set-focus)))))
|
||||
#f)))
|
||||
(define-signal-handler connect-focus-out "focus-out-event"
|
||||
(_fun _GtkWidget _GdkEventFocus-pointer -> _gboolean)
|
||||
|
|
@ -195,72 +195,72 @@
|
|||
(and
|
||||
wx
|
||||
(let ([im-str (if scroll?
|
||||
'none
|
||||
;; Result from `filter-key-event' is one of
|
||||
;; - #f => drop the event
|
||||
;; - 'none => no replacement; handle as usual
|
||||
;; - a string => use as the keycode
|
||||
(send wx filter-key-event event))])
|
||||
'none
|
||||
;; Result from `filter-key-event' is one of
|
||||
;; - #f => drop the event
|
||||
;; - 'none => no replacement; handle as usual
|
||||
;; - a string => use as the keycode
|
||||
(send wx filter-key-event event))])
|
||||
(when im-str
|
||||
(let* ([modifiers (if scroll?
|
||||
(GdkEventScroll-state event)
|
||||
(GdkEventKey-state event))]
|
||||
[bit? (lambda (m v) (positive? (bitwise-and m v)))]
|
||||
[keyval->code (lambda (kv)
|
||||
(or
|
||||
(map-key-code kv)
|
||||
(integer->char (gdk_keyval_to_unicode kv))))]
|
||||
[key-code (if scroll?
|
||||
(let ([dir (GdkEventScroll-direction event)])
|
||||
(let* ([modifiers (if scroll?
|
||||
(GdkEventScroll-state event)
|
||||
(GdkEventKey-state event))]
|
||||
[bit? (lambda (m v) (positive? (bitwise-and m v)))]
|
||||
[keyval->code (lambda (kv)
|
||||
(or
|
||||
(map-key-code kv)
|
||||
(integer->char (gdk_keyval_to_unicode kv))))]
|
||||
[key-code (if scroll?
|
||||
(let ([dir (GdkEventScroll-direction event)])
|
||||
(cond
|
||||
[(= dir GDK_SCROLL_UP) 'wheel-up]
|
||||
[(= dir GDK_SCROLL_DOWN) 'wheel-down]
|
||||
[(= dir GDK_SCROLL_LEFT) 'wheel-left]
|
||||
[(= dir GDK_SCROLL_RIGHT) 'wheel-right]))
|
||||
(keyval->code (GdkEventKey-keyval event)))]
|
||||
[k (new key-event%
|
||||
[key-code (if (and (string? im-str)
|
||||
(= 1 (string-length im-str)))
|
||||
(string-ref im-str 0)
|
||||
key-code)]
|
||||
[shift-down (bit? modifiers GDK_SHIFT_MASK)]
|
||||
[control-down (bit? modifiers GDK_CONTROL_MASK)]
|
||||
[meta-down (bit? modifiers GDK_MOD1_MASK)]
|
||||
[alt-down (bit? modifiers GDK_META_MASK)]
|
||||
[x 0]
|
||||
[y 0]
|
||||
[time-stamp (if scroll?
|
||||
(GdkEventScroll-time event)
|
||||
(GdkEventKey-time event))]
|
||||
[caps-down (bit? modifiers GDK_LOCK_MASK)])])
|
||||
(when (or (and (not scroll?)
|
||||
(let-values ([(s ag sag cl) (get-alts event)]
|
||||
[(keyval->code*) (lambda (v)
|
||||
(and v
|
||||
(let ([c (keyval->code v)])
|
||||
(and (not (equal? #\u0000 c))
|
||||
c))))])
|
||||
(let ([s (keyval->code* s)]
|
||||
[ag (keyval->code* ag)]
|
||||
[sag (keyval->code* sag)]
|
||||
[cl (keyval->code* cl)])
|
||||
(when s (send k set-other-shift-key-code s))
|
||||
(when ag (send k set-other-altgr-key-code ag))
|
||||
(when sag (send k set-other-shift-altgr-key-code sag))
|
||||
(when cl (send k set-other-caps-key-code cl))
|
||||
(or s ag sag cl))))
|
||||
(not (equal? #\u0000 key-code)))
|
||||
(unless (or scroll? down?)
|
||||
;; swap altenate with main
|
||||
(send k set-key-release-code (send k get-key-code))
|
||||
(send k set-key-code 'release))
|
||||
(if (send wx handles-events? gtk)
|
||||
(begin
|
||||
(queue-window-event wx (lambda () (send wx dispatch-on-char k #f)))
|
||||
#t)
|
||||
(constrained-reply (send wx get-eventspace)
|
||||
(lambda () (send wx dispatch-on-char k #t))
|
||||
#t)))))))))
|
||||
(keyval->code (GdkEventKey-keyval event)))]
|
||||
[k (new key-event%
|
||||
[key-code (if (and (string? im-str)
|
||||
(= 1 (string-length im-str)))
|
||||
(string-ref im-str 0)
|
||||
key-code)]
|
||||
[shift-down (bit? modifiers GDK_SHIFT_MASK)]
|
||||
[control-down (bit? modifiers GDK_CONTROL_MASK)]
|
||||
[meta-down (bit? modifiers GDK_MOD1_MASK)]
|
||||
[alt-down (bit? modifiers GDK_META_MASK)]
|
||||
[x 0]
|
||||
[y 0]
|
||||
[time-stamp (if scroll?
|
||||
(GdkEventScroll-time event)
|
||||
(GdkEventKey-time event))]
|
||||
[caps-down (bit? modifiers GDK_LOCK_MASK)])])
|
||||
(when (or (and (not scroll?)
|
||||
(let-values ([(s ag sag cl) (get-alts event)]
|
||||
[(keyval->code*) (lambda (v)
|
||||
(and v
|
||||
(let ([c (keyval->code v)])
|
||||
(and (not (equal? #\u0000 c))
|
||||
c))))])
|
||||
(let ([s (keyval->code* s)]
|
||||
[ag (keyval->code* ag)]
|
||||
[sag (keyval->code* sag)]
|
||||
[cl (keyval->code* cl)])
|
||||
(when s (send k set-other-shift-key-code s))
|
||||
(when ag (send k set-other-altgr-key-code ag))
|
||||
(when sag (send k set-other-shift-altgr-key-code sag))
|
||||
(when cl (send k set-other-caps-key-code cl))
|
||||
(or s ag sag cl))))
|
||||
(not (equal? #\u0000 key-code)))
|
||||
(unless (or scroll? down?)
|
||||
;; swap altenate with main
|
||||
(send k set-key-release-code (send k get-key-code))
|
||||
(send k set-key-code 'release))
|
||||
(if (send wx handles-events? gtk)
|
||||
(begin
|
||||
(queue-window-event wx (lambda () (send wx dispatch-on-char k #f)))
|
||||
#t)
|
||||
(constrained-reply (send wx get-eventspace)
|
||||
(lambda () (send wx dispatch-on-char k #t))
|
||||
#t)))))))))
|
||||
|
||||
(define-signal-handler connect-button-press "button-press-event"
|
||||
(_fun _GtkWidget _GdkEventButton-pointer -> _gboolean)
|
||||
|
|
@ -317,11 +317,11 @@
|
|||
(and
|
||||
wx
|
||||
(if (or (= type GDK_2BUTTON_PRESS)
|
||||
(= type GDK_3BUTTON_PRESS)
|
||||
(and (or (= type GDK_ENTER_NOTIFY)
|
||||
(= type GDK_LEAVE_NOTIFY))
|
||||
(send wx skip-enter-leave-events)))
|
||||
#t
|
||||
(= type GDK_3BUTTON_PRESS)
|
||||
(and (or (= type GDK_ENTER_NOTIFY)
|
||||
(= type GDK_LEAVE_NOTIFY))
|
||||
(send wx skip-enter-leave-events)))
|
||||
#t
|
||||
(let* ([modifiers (if motion?
|
||||
(GdkEventMotion-state event)
|
||||
(if crossing?
|
||||
|
|
@ -345,7 +345,7 @@
|
|||
[(1) 'left-up]
|
||||
[(3) 'right-up]
|
||||
[else 'middle-up])])]
|
||||
[m (let-values ([(x y) (send wx
|
||||
[m (let-values ([(x y) (send wx
|
||||
adjust-event-position
|
||||
(->long ((if motion?
|
||||
GdkEventMotion-x
|
||||
|
|
@ -378,24 +378,24 @@
|
|||
(if crossing? GdkEventCrossing-time GdkEventButton-time))
|
||||
event)]
|
||||
[caps-down (bit? modifiers GDK_LOCK_MASK)]))])
|
||||
(if (send wx handles-events? gtk)
|
||||
(begin
|
||||
(queue-window-event wx (lambda ()
|
||||
(send wx dispatch-on-event m #f)))
|
||||
#t)
|
||||
(constrained-reply (send wx get-eventspace)
|
||||
(lambda () (or (send wx dispatch-on-event m #t)
|
||||
(send wx internal-pre-on-event gtk m)))
|
||||
#t
|
||||
#:fail-result
|
||||
;; an enter event is synthesized when a button is
|
||||
;; enabled and the mouse is over the button, and the
|
||||
;; event is not dispatched via the eventspace; leave
|
||||
;; events are perhaps similarly synthesized, so allow
|
||||
;; them, too
|
||||
(if (or (eq? type 'enter) (eq? type 'leave))
|
||||
#f
|
||||
#t)))))))))
|
||||
(if (send wx handles-events? gtk)
|
||||
(begin
|
||||
(queue-window-event wx (lambda ()
|
||||
(send wx dispatch-on-event m #f)))
|
||||
#t)
|
||||
(constrained-reply (send wx get-eventspace)
|
||||
(lambda () (or (send wx dispatch-on-event m #t)
|
||||
(send wx internal-pre-on-event gtk m)))
|
||||
#t
|
||||
#:fail-result
|
||||
;; an enter event is synthesized when a button is
|
||||
;; enabled and the mouse is over the button, and the
|
||||
;; event is not dispatched via the eventspace; leave
|
||||
;; events are perhaps similarly synthesized, so allow
|
||||
;; them, too
|
||||
(if (or (eq? type 'enter) (eq? type 'leave))
|
||||
#f
|
||||
#t)))))))))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
|
@ -592,13 +592,13 @@
|
|||
(define drag-connected? #f)
|
||||
(define/public (drag-accept-files on?)
|
||||
(if on?
|
||||
(begin
|
||||
(unless drag-connected?
|
||||
(connect-drag-data-received gtk)
|
||||
(set! drag-connected? #t))
|
||||
(gtk_drag_dest_set gtk GTK_DEST_DEFAULT_ALL GDK_ACTION_COPY)
|
||||
(gtk_drag_dest_add_uri_targets gtk))
|
||||
(gtk_drag_dest_unset gtk)))
|
||||
(begin
|
||||
(unless drag-connected?
|
||||
(connect-drag-data-received gtk)
|
||||
(set! drag-connected? #t))
|
||||
(gtk_drag_dest_set gtk GTK_DEST_DEFAULT_ALL GDK_ACTION_COPY)
|
||||
(gtk_drag_dest_add_uri_targets gtk))
|
||||
(gtk_drag_dest_unset gtk)))
|
||||
|
||||
(define/public (set-focus)
|
||||
(gtk_widget_grab_focus (get-client-gtk)))
|
||||
|
|
@ -761,7 +761,7 @@
|
|||
(when win
|
||||
(set-mcar! win-box #f)
|
||||
(for ([i (in-range (mcdr win-box))])
|
||||
(gdk_window_thaw_updates win)))))
|
||||
(gdk_window_thaw_updates win)))))
|
||||
|
||||
(define (request-flush-delay win-box)
|
||||
(do-request-flush-delay
|
||||
|
|
@ -769,15 +769,15 @@
|
|||
(lambda (win-box)
|
||||
(let ([win (mcar win-box)])
|
||||
(and win
|
||||
;; The freeze/thaw state is actually with the window's
|
||||
;; implementation, so force a native implementation of the
|
||||
;; window to try to avoid it changing out from underneath
|
||||
;; us between the freeze and thaw actions.
|
||||
(gdk_window_ensure_native win)
|
||||
(begin
|
||||
(gdk_window_freeze_updates win)
|
||||
(set-mcdr! win-box (add1 (mcdr win-box)))
|
||||
#t))))
|
||||
;; The freeze/thaw state is actually with the window's
|
||||
;; implementation, so force a native implementation of the
|
||||
;; window to try to avoid it changing out from underneath
|
||||
;; us between the freeze and thaw actions.
|
||||
(gdk_window_ensure_native win)
|
||||
(begin
|
||||
(gdk_window_freeze_updates win)
|
||||
(set-mcdr! win-box (add1 (mcdr win-box)))
|
||||
#t))))
|
||||
(lambda (win-box)
|
||||
(let ([win (mcar win-box)])
|
||||
(when win
|
||||
|
|
@ -791,5 +791,5 @@
|
|||
(lambda (win-box)
|
||||
(let ([win (mcar win-box)])
|
||||
(when win
|
||||
(gdk_window_thaw_updates win)
|
||||
(gdk_window_thaw_updates win)
|
||||
(set-mcdr! win-box (sub1 (mcdr win-box)))))))))
|
||||
|
|
|
|||
|
|
@ -1,13 +1,13 @@
|
|||
#lang racket/base
|
||||
(require ffi/unsafe
|
||||
ffi/winapi)
|
||||
ffi/winapi)
|
||||
|
||||
(provide
|
||||
(protect-out _wfun
|
||||
|
||||
_WORD
|
||||
_DWORD
|
||||
_UDWORD
|
||||
_WORD
|
||||
_DWORD
|
||||
_UDWORD
|
||||
_ATOM
|
||||
_WPARAM
|
||||
_LPARAM
|
||||
|
|
@ -95,35 +95,35 @@
|
|||
|
||||
(define _permanent-string/utf-16
|
||||
(make-ctype _pointer
|
||||
(lambda (s)
|
||||
(and s
|
||||
(let ([v (malloc _gcpointer)])
|
||||
(ptr-set! v _string/utf-16 s)
|
||||
(let ([p (ptr-ref v _gcpointer)])
|
||||
(let ([len (+ 1 (utf-16-length s))])
|
||||
(let ([c (malloc len _uint16 'raw)])
|
||||
(memcpy c p len _uint16)
|
||||
c))))))
|
||||
(lambda (p) p)))
|
||||
(lambda (s)
|
||||
(and s
|
||||
(let ([v (malloc _gcpointer)])
|
||||
(ptr-set! v _string/utf-16 s)
|
||||
(let ([p (ptr-ref v _gcpointer)])
|
||||
(let ([len (+ 1 (utf-16-length s))])
|
||||
(let ([c (malloc len _uint16 'raw)])
|
||||
(memcpy c p len _uint16)
|
||||
c))))))
|
||||
(lambda (p) p)))
|
||||
|
||||
(define _LONG _long)
|
||||
(define _ULONG _ulong)
|
||||
(define _SHORT _short)
|
||||
|
||||
(define-cstruct _POINT ([x _LONG]
|
||||
[y _LONG]))
|
||||
[y _LONG]))
|
||||
|
||||
(define-cstruct _RECT ([left _LONG]
|
||||
[top _LONG]
|
||||
[right _LONG]
|
||||
[bottom _LONG]))
|
||||
[top _LONG]
|
||||
[right _LONG]
|
||||
[bottom _LONG]))
|
||||
|
||||
(define-cstruct _MSG ([hwnd _HWND]
|
||||
[message _UINT]
|
||||
[wParam _WPARAM]
|
||||
[lParam _LPARAM]
|
||||
[time _DWORD]
|
||||
[pt _POINT]))
|
||||
[message _UINT]
|
||||
[wParam _WPARAM]
|
||||
[lParam _LPARAM]
|
||||
[time _DWORD]
|
||||
[pt _POINT]))
|
||||
|
||||
(define (short v)
|
||||
(if (zero? (bitwise-and #x8000 v))
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@
|
|||
@defconstructor/auto-super[([label string?]
|
||||
[callback (-> (is-a?/c switchable-button%) any/c)]
|
||||
[bitmap (is-a?/c bitmap%)]
|
||||
[alternate-bitmap (is-a?/c bitmap%) bitmap]
|
||||
[alternate-bitmap (is-a?/c bitmap%) bitmap]
|
||||
[vertical-tight? boolean? #f])]{
|
||||
The @racket[callback] is called when the button
|
||||
is pressed. The @racket[string] and @racket[bitmap] are
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ that number to control the gauge along the bottom of the splash screen.
|
|||
[splash-title string?]
|
||||
[width-default exact-nonnegative-integer?]
|
||||
[#:allow-funny? allow-funny? boolean? #f]
|
||||
[#:frame-icon
|
||||
[#:frame-icon
|
||||
frame-icon
|
||||
(or/c #f
|
||||
(is-a?/c bitmap%)
|
||||
|
|
|
|||
|
|
@ -21,8 +21,8 @@
|
|||
(define allocated '())
|
||||
(define (remember tag v)
|
||||
(set! allocated
|
||||
(cons (cons tag (make-weak-box v))
|
||||
allocated))
|
||||
(cons (cons tag (make-weak-box v))
|
||||
allocated))
|
||||
v)
|
||||
|
||||
(define sub-collect-frame
|
||||
|
|
@ -71,163 +71,163 @@
|
|||
(unless (zero? n)
|
||||
(let ([tag (cons id n)])
|
||||
(let* ([edit (remember tag (make-object text%))]
|
||||
[ef (let ([f (make-object frame% "Editor Frame")])
|
||||
(send (make-object editor-canvas% f) set-editor edit)
|
||||
(remember tag f))]
|
||||
[c (make-custodian)]
|
||||
[es (parameterize ([current-custodian c])
|
||||
(make-eventspace))])
|
||||
[ef (let ([f (make-object frame% "Editor Frame")])
|
||||
(send (make-object editor-canvas% f) set-editor edit)
|
||||
(remember tag f))]
|
||||
[c (make-custodian)]
|
||||
[es (parameterize ([current-custodian c])
|
||||
(make-eventspace))])
|
||||
|
||||
(when edit?
|
||||
(send ef show #t)
|
||||
(sleep 0.1))
|
||||
(when edit?
|
||||
(send ef show #t)
|
||||
(sleep 0.1))
|
||||
|
||||
(parameterize ([current-eventspace es])
|
||||
(send (remember
|
||||
tag
|
||||
(make-object
|
||||
(class timer%
|
||||
(parameterize ([current-eventspace es])
|
||||
(send (remember
|
||||
tag
|
||||
(make-object
|
||||
(class timer%
|
||||
(init-rest args)
|
||||
(override* [notify (lambda () (void))])
|
||||
(override* [notify (lambda () (void))])
|
||||
(apply super-make-object args))))
|
||||
start 100))
|
||||
start 100))
|
||||
|
||||
(when frame?
|
||||
(let* ([f (remember tag
|
||||
(make-object (if (even? n)
|
||||
frame%
|
||||
dialog%)
|
||||
"Tester" #f 200 200))]
|
||||
[cb (lambda (x y) f)]
|
||||
[p (remember tag (make-object (get-pane% n) f))])
|
||||
(remember tag (make-object canvas% f))
|
||||
(when (zero? (modulo n 3))
|
||||
(thread (lambda () (send f show #t)))
|
||||
(let loop () (sleep) (unless (send f is-shown?) (loop))))
|
||||
(remember tag (make-object button% "one" p cb))
|
||||
(let ([class check-box%])
|
||||
(let loop ([m 10])
|
||||
(unless (zero? m)
|
||||
(remember (cons tag m)
|
||||
(make-object class "another" p cb))
|
||||
(loop (sub1 m)))))
|
||||
(remember tag (make-object check-box% "check" p cb))
|
||||
(remember tag (make-object choice% "choice" '("a" "b" "c") p cb))
|
||||
(remember tag (make-object list-box% "list" '("apple" "banana" "coconut")
|
||||
p cb))
|
||||
(remember tag (make-object button% "two" p cb))
|
||||
(send f show #f)))
|
||||
(when frame?
|
||||
(let* ([f (remember tag
|
||||
(make-object (if (even? n)
|
||||
frame%
|
||||
dialog%)
|
||||
"Tester" #f 200 200))]
|
||||
[cb (lambda (x y) f)]
|
||||
[p (remember tag (make-object (get-pane% n) f))])
|
||||
(remember tag (make-object canvas% f))
|
||||
(when (zero? (modulo n 3))
|
||||
(thread (lambda () (send f show #t)))
|
||||
(let loop () (sleep) (unless (send f is-shown?) (loop))))
|
||||
(remember tag (make-object button% "one" p cb))
|
||||
(let ([class check-box%])
|
||||
(let loop ([m 10])
|
||||
(unless (zero? m)
|
||||
(remember (cons tag m)
|
||||
(make-object class "another" p cb))
|
||||
(loop (sub1 m)))))
|
||||
(remember tag (make-object check-box% "check" p cb))
|
||||
(remember tag (make-object choice% "choice" '("a" "b" "c") p cb))
|
||||
(remember tag (make-object list-box% "list" '("apple" "banana" "coconut")
|
||||
p cb))
|
||||
(remember tag (make-object button% "two" p cb))
|
||||
(send f show #f)))
|
||||
|
||||
(when subwindows?
|
||||
(let ([p (make-object (get-panel% n) sub-collect-frame)]
|
||||
[cv (make-object canvas% sub-collect-frame)]
|
||||
[add-objects
|
||||
(lambda (p tag hide?)
|
||||
(let ([b (let* ([x #f]
|
||||
[bcb (lambda (a b) x)])
|
||||
(set! x (make-object button% "one" p bcb))
|
||||
x)]
|
||||
[c (make-object check-box% "check" p void)]
|
||||
[co (make-object choice% "choice" '("a" "b" "c") p void)]
|
||||
[cv (make-object canvas% p)]
|
||||
[lb (make-object list-box% "list" '("apple" "banana" "coconut") p void)])
|
||||
(when hide?
|
||||
(send p delete-child b)
|
||||
(send p delete-child c)
|
||||
(send p delete-child cv)
|
||||
(send p delete-child co)
|
||||
(send p delete-child lb))
|
||||
(remember tag b)
|
||||
(remember tag c)
|
||||
(remember tag cv)
|
||||
(remember tag co)
|
||||
(remember tag lb)))])
|
||||
(add-objects sub-collect-panel (cons 'sc1 tag) #t)
|
||||
(add-objects p (cons 'sc2 tag) #f)
|
||||
(remember (cons 'sc0 tag) p)
|
||||
(remember (cons 'sc0 tag) cv)
|
||||
(send sub-collect-frame delete-child p)
|
||||
(send sub-collect-frame delete-child cv)))
|
||||
(when subwindows?
|
||||
(let ([p (make-object (get-panel% n) sub-collect-frame)]
|
||||
[cv (make-object canvas% sub-collect-frame)]
|
||||
[add-objects
|
||||
(lambda (p tag hide?)
|
||||
(let ([b (let* ([x #f]
|
||||
[bcb (lambda (a b) x)])
|
||||
(set! x (make-object button% "one" p bcb))
|
||||
x)]
|
||||
[c (make-object check-box% "check" p void)]
|
||||
[co (make-object choice% "choice" '("a" "b" "c") p void)]
|
||||
[cv (make-object canvas% p)]
|
||||
[lb (make-object list-box% "list" '("apple" "banana" "coconut") p void)])
|
||||
(when hide?
|
||||
(send p delete-child b)
|
||||
(send p delete-child c)
|
||||
(send p delete-child cv)
|
||||
(send p delete-child co)
|
||||
(send p delete-child lb))
|
||||
(remember tag b)
|
||||
(remember tag c)
|
||||
(remember tag cv)
|
||||
(remember tag co)
|
||||
(remember tag lb)))])
|
||||
(add-objects sub-collect-panel (cons 'sc1 tag) #t)
|
||||
(add-objects p (cons 'sc2 tag) #f)
|
||||
(remember (cons 'sc0 tag) p)
|
||||
(remember (cons 'sc0 tag) cv)
|
||||
(send sub-collect-frame delete-child p)
|
||||
(send sub-collect-frame delete-child cv)))
|
||||
|
||||
(when (and edit? insert?)
|
||||
(let ([e edit])
|
||||
(when (and edit? insert?)
|
||||
(let ([e edit])
|
||||
(send e begin-edit-sequence)
|
||||
(when load-file?
|
||||
(send e load-file (build-path source-dir "mem.rkt")))
|
||||
(let loop ([i 20])
|
||||
(send e insert (number->string i))
|
||||
(unless (zero? i)
|
||||
(loop (sub1 i))))
|
||||
(let ([s (make-object editor-snip%)])
|
||||
(send (send s get-editor) insert "Hello!")
|
||||
(send e insert s))
|
||||
(send e insert #\newline)
|
||||
(send e insert "done")
|
||||
(send e set-modified #f)
|
||||
(when load-file?
|
||||
(send e load-file (build-path source-dir "mem.rkt")))
|
||||
(let loop ([i 20])
|
||||
(send e insert (number->string i))
|
||||
(unless (zero? i)
|
||||
(loop (sub1 i))))
|
||||
(let ([s (make-object editor-snip%)])
|
||||
(send (send s get-editor) insert "Hello!")
|
||||
(send e insert s))
|
||||
(send e insert #\newline)
|
||||
(send e insert "done")
|
||||
(send e set-modified #f)
|
||||
(send e end-edit-sequence)))
|
||||
|
||||
(when menus?
|
||||
(let ([f (remember tag (make-object frame% "MB Frame 0"))])
|
||||
(remember tag (make-object menu% "TM1" (remember (cons 'q tag) (make-object menu-bar% f)))))
|
||||
(let* ([mb (remember tag (make-object menu-bar% ef))]
|
||||
[m (remember tag (make-object menu% "Ok" mb))])
|
||||
(remember tag (make-object menu-item% "Hi" m void))
|
||||
(remember tag (make-object menu-item% "There" m void #\t))
|
||||
(remember tag
|
||||
(make-object checkable-menu-item%
|
||||
"Checkable"
|
||||
(remember tag (make-object menu% "Hello" m))
|
||||
void))
|
||||
(let ([i (remember tag (make-object menu-item% "Delete Me" m void))])
|
||||
(send i delete)))
|
||||
|
||||
(when menus?
|
||||
(let ([f (remember tag (make-object frame% "MB Frame 0"))])
|
||||
(remember tag (make-object menu% "TM1" (remember (cons 'q tag) (make-object menu-bar% f)))))
|
||||
(let* ([mb (remember tag (make-object menu-bar% ef))]
|
||||
[m (remember tag (make-object menu% "Ok" mb))])
|
||||
(remember tag (make-object menu-item% "Hi" m void))
|
||||
(remember tag (make-object menu-item% "There" m void #\t))
|
||||
(remember tag
|
||||
(make-object checkable-menu-item%
|
||||
"Checkable"
|
||||
(remember tag (make-object menu% "Hello" m))
|
||||
void))
|
||||
(let ([i (remember tag (make-object menu-item% "Delete Me" m void))])
|
||||
(send i delete)))
|
||||
|
||||
(when subwindows?
|
||||
(unless permanent-ready?
|
||||
(semaphore-wait mb-lock)
|
||||
(unless (send sub-collect-frame get-menu-bar)
|
||||
(let ([mb (make-object menu-bar% sub-collect-frame)])
|
||||
(make-object menu% "Permanent" mb)))
|
||||
(set! permanent-ready? #t)
|
||||
(semaphore-post mb-lock))
|
||||
(let* ([mb (send sub-collect-frame get-menu-bar)]
|
||||
[mm (car (send mb get-items))])
|
||||
(send (remember (cons 'm tag) (make-object menu-item% "Delete Me" mm void)) delete)
|
||||
(let ([m (remember tag (make-object menu% "Temporary" mb))])
|
||||
(remember (cons 't tag) (make-object menu-item% "Temp Hi" m void))
|
||||
(send m delete)))))
|
||||
|
||||
(when atomic?
|
||||
(let loop ([m 8])
|
||||
(unless (zero? m)
|
||||
(remember (cons tag m) (make-object point% n m))
|
||||
(let ([br (make-object brush%)])
|
||||
(remember (cons tag m) br)
|
||||
(hash-set! htw br 'ok))
|
||||
(remember (cons tag m) (make-object pen%))
|
||||
(loop (sub1 m)))))
|
||||
|
||||
(when offscreen?
|
||||
(let ([m (remember tag (make-object bitmap-dc%))]
|
||||
[b0 (remember (cons tag 'f) (make-object bitmap% (get-image n)))]
|
||||
[b (remember (cons tag 'u) (make-object bitmap% 100 100))]
|
||||
[b2 (remember (cons tag 'x) (make-object bitmap% 100 100))])
|
||||
(unless (send b0 ok?)
|
||||
(error "bitmap load error"))
|
||||
(send m set-bitmap b)))
|
||||
|
||||
(when edit?
|
||||
(send ef show #f))
|
||||
|
||||
(custodian-shutdown-all c)
|
||||
(when subwindows?
|
||||
(unless permanent-ready?
|
||||
(semaphore-wait mb-lock)
|
||||
(unless (send sub-collect-frame get-menu-bar)
|
||||
(let ([mb (make-object menu-bar% sub-collect-frame)])
|
||||
(make-object menu% "Permanent" mb)))
|
||||
(set! permanent-ready? #t)
|
||||
(semaphore-post mb-lock))
|
||||
(let* ([mb (send sub-collect-frame get-menu-bar)]
|
||||
[mm (car (send mb get-items))])
|
||||
(send (remember (cons 'm tag) (make-object menu-item% "Delete Me" mm void)) delete)
|
||||
(let ([m (remember tag (make-object menu% "Temporary" mb))])
|
||||
(remember (cons 't tag) (make-object menu-item% "Temp Hi" m void))
|
||||
(send m delete)))))
|
||||
|
||||
(collect-garbage)
|
||||
(when atomic?
|
||||
(let loop ([m 8])
|
||||
(unless (zero? m)
|
||||
(remember (cons tag m) (make-object point% n m))
|
||||
(let ([br (make-object brush%)])
|
||||
(remember (cons tag m) br)
|
||||
(hash-set! htw br 'ok))
|
||||
(remember (cons tag m) (make-object pen%))
|
||||
(loop (sub1 m)))))
|
||||
|
||||
(when offscreen?
|
||||
(let ([m (remember tag (make-object bitmap-dc%))]
|
||||
[b0 (remember (cons tag 'f) (make-object bitmap% (get-image n)))]
|
||||
[b (remember (cons tag 'u) (make-object bitmap% 100 100))]
|
||||
[b2 (remember (cons tag 'x) (make-object bitmap% 100 100))])
|
||||
(unless (send b0 ok?)
|
||||
(error "bitmap load error"))
|
||||
(send m set-bitmap b)))
|
||||
|
||||
(when edit?
|
||||
(send ef show #f))
|
||||
|
||||
(custodian-shutdown-all c)
|
||||
|
||||
(maker id (sub1 n))))))
|
||||
(collect-garbage)
|
||||
|
||||
(maker id (sub1 n))))))
|
||||
|
||||
(define (still)
|
||||
(map (lambda (x)
|
||||
(let ([v (weak-box-value (cdr x))])
|
||||
(when v
|
||||
(let ([v (weak-box-value (cdr x))])
|
||||
(when v
|
||||
(printf "~s ~s\n" (car x) v))))
|
||||
allocated)
|
||||
(void))
|
||||
|
|
@ -241,29 +241,29 @@
|
|||
(define (breakable t)
|
||||
(if #f
|
||||
(thread (lambda ()
|
||||
(read)
|
||||
(printf "breaking\n")
|
||||
(break-thread t)
|
||||
(thread-wait t)
|
||||
(printf "done\n")))
|
||||
(read)
|
||||
(printf "breaking\n")
|
||||
(break-thread t)
|
||||
(thread-wait t)
|
||||
(printf "done\n")))
|
||||
(void)))
|
||||
|
||||
(define (do-test)
|
||||
(let ([sema (make-semaphore)])
|
||||
(let loop ([n num-threads])
|
||||
(unless (zero? n)
|
||||
(breakable
|
||||
(thread (lambda ()
|
||||
(stw (current-thread) n)
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda () (maker n num-times))
|
||||
(lambda () (semaphore-post sema))))))
|
||||
(loop (sub1 n))))
|
||||
(breakable
|
||||
(thread (lambda ()
|
||||
(stw (current-thread) n)
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda () (maker n num-times))
|
||||
(lambda () (semaphore-post sema))))))
|
||||
(loop (sub1 n))))
|
||||
(let loop ([n num-threads])
|
||||
(unless (zero? n)
|
||||
(yield sema)
|
||||
(loop (sub1 n)))))
|
||||
(yield sema)
|
||||
(loop (sub1 n)))))
|
||||
|
||||
(collect-garbage)
|
||||
(collect-garbage)
|
||||
|
|
@ -280,4 +280,3 @@
|
|||
(still)))
|
||||
|
||||
(do-test)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user