suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Lots of bad TAB eliminations.

Browse Source 
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 2012-11-07 10:42:42 -05:00
parent ab6d9e0762
commit 5b1e17cc7c
11 changed files with 336 additions and 336 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mred/private/moredialogs.rkt
View File

@ -329,7 +329,7 @@
(send blue get-value)))] (send blue get-value)))]
[install-color [install-color
(lambda (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 green set-value (send color green))
(send blue set-value (send color blue)) (send blue set-value (send color blue))
(send canvas refresh))]) (send canvas refresh))])

7
collects/mred/private/mrcanvas.rkt
View File

@ -19,9 +19,10 @@
(define canvas-default-size 20) ; a default size for canvases tht fits borders without losing client sizes (define canvas-default-size 20) ; a default size for canvases tht fits borders without losing client sizes
(define canvas-scroll-size 10) (define canvas-scroll-size 10)
(define canvas-control-border-extra (case (system-type) (define canvas-control-border-extra
[(windows) 2] (case (system-type)
[else 0])) [(windows) 2]
[else 0]))
(define canvas<%> (define canvas<%>
(interface (subwindow<%>) (interface (subwindow<%>)

22
collects/mred/private/wx/gtk/types.rkt
View File

@ -8,8 +8,8 @@
_GdkScreen _GdkScreen
_gpointer _gpointer
_GType _GType
_GdkEventType _GdkEventType
_GdkAtom _GdkAtom
_fnpointer _fnpointer
_gboolean _gboolean
@ -31,9 +31,9 @@
(struct-out GdkEventExpose) (struct-out GdkEventExpose)
_GdkEventFocus _GdkEventFocus-pointer _GdkEventFocus _GdkEventFocus-pointer
(struct-out GdkEventFocus) (struct-out GdkEventFocus)
_GdkEventSelection _GdkEventSelection-pointer _GdkEventSelection _GdkEventSelection-pointer
(struct-out GdkEventSelection) (struct-out GdkEventSelection)
_GdkRectangle _GdkRectangle-pointer _GdkRectangle _GdkRectangle-pointer
(struct-out GdkRectangle) (struct-out GdkRectangle)
_GdkColor _GdkColor-pointer _GdkColor _GdkColor-pointer
(struct-out GdkColor))) (struct-out GdkColor)))
@ -135,11 +135,11 @@
(define-cstruct _GdkEventSelection ([type _GdkEventType] (define-cstruct _GdkEventSelection ([type _GdkEventType]
[window _GdkWindow] [window _GdkWindow]
[send_event _byte] [send_event _byte]
[selection _GdkAtom] [selection _GdkAtom]
[target _GdkAtom] [target _GdkAtom]
[property _GdkAtom] [property _GdkAtom]
[time _uint32] [time _uint32]
[requestor _pointer])) [requestor _pointer]))
(define-cstruct _GdkRectangle ([x _int] (define-cstruct _GdkRectangle ([x _int]
[y _int] [y _int]
@ -155,8 +155,8 @@
(define-cstruct _GdkEventFocus ([type _GdkEventType] (define-cstruct _GdkEventFocus ([type _GdkEventType]
[window _GdkWindow] [window _GdkWindow]
[send_event _byte] [send_event _byte]
[in _short])) [in _short]))
(define-cstruct _GdkColor ([pixel _uint32] (define-cstruct _GdkColor ([pixel _uint32]
[red _uint16] [red _uint16]

264
collects/mred/private/wx/gtk/window.rkt
View File

@ -1,7 +1,7 @@
#lang racket/base #lang racket/base
(require ffi/unsafe (require ffi/unsafe
racket/class racket/class
net/uri-codec net/uri-codec
ffi/unsafe/atomic ffi/unsafe/atomic
"../../syntax.rkt" "../../syntax.rkt"
"../../lock.rkt" "../../lock.rkt"
@ -18,7 +18,7 @@
"const.rkt" "const.rkt"
"types.rkt" "types.rkt"
"widget.rkt" "widget.rkt"
"clipboard.rkt") "clipboard.rkt")
(provide (provide
(protect-out window% (protect-out window%
@ -35,7 +35,7 @@
connect-focus connect-focus
connect-key-and-mouse connect-key-and-mouse
connect-enter-and-leave connect-enter-and-leave
do-button-event do-button-event
(struct-out GtkRequisition) _GtkRequisition-pointer (struct-out GtkRequisition) _GtkRequisition-pointer
@ -54,9 +54,9 @@
request-flush-delay request-flush-delay
cancel-flush-delay cancel-flush-delay
win-box-valid? win-box-valid?
window->win-box window->win-box
unrealize-win-box) unrealize-win-box)
gtk->wx gtk->wx
gtk_widget_show gtk_widget_show
gtk_widget_hide) gtk_widget_hide)
@ -92,15 +92,15 @@
(define the-accelerator-group (gtk_accel_group_new)) (define the-accelerator-group (gtk_accel_group_new))
(define-cstruct _GtkWidgetT ([obj _GtkObject] (define-cstruct _GtkWidgetT ([obj _GtkObject]
[private_flags _uint16] [private_flags _uint16]
[state _byte] [state _byte]
[saved_state _byte] [saved_state _byte]
[name _pointer] [name _pointer]
[style _pointer] [style _pointer]
[req _GtkRequisition] [req _GtkRequisition]
[alloc _GtkAllocation] [alloc _GtkAllocation]
[window _GdkWindow] [window _GdkWindow]
[parent _GtkWidget])) [parent _GtkWidget]))
(define (widget-window gtk) (define (widget-window gtk)
(GtkWidgetT-window (cast gtk _GtkWidget _GtkWidgetT-pointer))) (GtkWidgetT-window (cast gtk _GtkWidget _GtkWidgetT-pointer)))
@ -123,20 +123,20 @@
(lambda (gtk context x y data info time) (lambda (gtk context x y data info time)
(let ([wx (gtk->wx gtk)]) (let ([wx (gtk->wx gtk)])
(when wx (when wx
(let ([bstr (scheme_make_sized_byte_string (let ([bstr (scheme_make_sized_byte_string
(gtk_selection_data_get_data data) (gtk_selection_data_get_data data)
(gtk_selection_data_get_length data) (gtk_selection_data_get_length data)
1)]) 1)])
(cond (cond
[(regexp-match #rx#"^file://(.*)\r\n$" bstr) [(regexp-match #rx#"^file://(.*)\r\n$" bstr)
=> (lambda (m) => (lambda (m)
(queue-window-event wx (queue-window-event wx
(lambda () (lambda ()
(let ([path (let ([path
(string->path (string->path
(uri-decode (uri-decode
(bytes->string/utf-8 (cadr m))))]) (bytes->string/utf-8 (cadr m))))])
(send wx on-drop-file path)))))])))))) (send wx on-drop-file path)))))]))))))
;; ---------------------------------------- ;; ----------------------------------------
@ -147,7 +147,7 @@
(when wx (when wx
(send wx focus-change #t) (send wx focus-change #t)
(when (send wx on-focus? #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))) #f)))
(define-signal-handler connect-focus-out "focus-out-event" (define-signal-handler connect-focus-out "focus-out-event"
(_fun _GtkWidget _GdkEventFocus-pointer -> _gboolean) (_fun _GtkWidget _GdkEventFocus-pointer -> _gboolean)
@ -195,72 +195,72 @@
(and (and
wx wx
(let ([im-str (if scroll? (let ([im-str (if scroll?
'none 'none
;; Result from `filter-key-event' is one of ;; Result from `filter-key-event' is one of
;; - #f => drop the event ;; - #f => drop the event
;; - 'none => no replacement; handle as usual ;; - 'none => no replacement; handle as usual
;; - a string => use as the keycode ;; - a string => use as the keycode
(send wx filter-key-event event))]) (send wx filter-key-event event))])
(when im-str (when im-str
(let* ([modifiers (if scroll? (let* ([modifiers (if scroll?
(GdkEventScroll-state event) (GdkEventScroll-state event)
(GdkEventKey-state event))] (GdkEventKey-state event))]
[bit? (lambda (m v) (positive? (bitwise-and m v)))] [bit? (lambda (m v) (positive? (bitwise-and m v)))]
[keyval->code (lambda (kv) [keyval->code (lambda (kv)
(or (or
(map-key-code kv) (map-key-code kv)
(integer->char (gdk_keyval_to_unicode kv))))] (integer->char (gdk_keyval_to_unicode kv))))]
[key-code (if scroll? [key-code (if scroll?
(let ([dir (GdkEventScroll-direction event)]) (let ([dir (GdkEventScroll-direction event)])
(cond (cond
[(= dir GDK_SCROLL_UP) 'wheel-up] [(= dir GDK_SCROLL_UP) 'wheel-up]
[(= dir GDK_SCROLL_DOWN) 'wheel-down] [(= dir GDK_SCROLL_DOWN) 'wheel-down]
[(= dir GDK_SCROLL_LEFT) 'wheel-left] [(= dir GDK_SCROLL_LEFT) 'wheel-left]
[(= dir GDK_SCROLL_RIGHT) 'wheel-right])) [(= dir GDK_SCROLL_RIGHT) 'wheel-right]))
(keyval->code (GdkEventKey-keyval event)))] (keyval->code (GdkEventKey-keyval event)))]
[k (new key-event% [k (new key-event%
[key-code (if (and (string? im-str) [key-code (if (and (string? im-str)
(= 1 (string-length im-str))) (= 1 (string-length im-str)))
(string-ref im-str 0) (string-ref im-str 0)
key-code)] key-code)]
[shift-down (bit? modifiers GDK_SHIFT_MASK)] [shift-down (bit? modifiers GDK_SHIFT_MASK)]
[control-down (bit? modifiers GDK_CONTROL_MASK)] [control-down (bit? modifiers GDK_CONTROL_MASK)]
[meta-down (bit? modifiers GDK_MOD1_MASK)] [meta-down (bit? modifiers GDK_MOD1_MASK)]
[alt-down (bit? modifiers GDK_META_MASK)] [alt-down (bit? modifiers GDK_META_MASK)]
[x 0] [x 0]
[y 0] [y 0]
[time-stamp (if scroll? [time-stamp (if scroll?
(GdkEventScroll-time event) (GdkEventScroll-time event)
(GdkEventKey-time event))] (GdkEventKey-time event))]
[caps-down (bit? modifiers GDK_LOCK_MASK)])]) [caps-down (bit? modifiers GDK_LOCK_MASK)])])
(when (or (and (not scroll?) (when (or (and (not scroll?)
(let-values ([(s ag sag cl) (get-alts event)] (let-values ([(s ag sag cl) (get-alts event)]
[(keyval->code*) (lambda (v) [(keyval->code*) (lambda (v)
(and v (and v
(let ([c (keyval->code v)]) (let ([c (keyval->code v)])
(and (not (equal? #\u0000 c)) (and (not (equal? #\u0000 c))
c))))]) c))))])
(let ([s (keyval->code* s)] (let ([s (keyval->code* s)]
[ag (keyval->code* ag)] [ag (keyval->code* ag)]
[sag (keyval->code* sag)] [sag (keyval->code* sag)]
[cl (keyval->code* cl)]) [cl (keyval->code* cl)])
(when s (send k set-other-shift-key-code s)) (when s (send k set-other-shift-key-code s))
(when ag (send k set-other-altgr-key-code ag)) (when ag (send k set-other-altgr-key-code ag))
(when sag (send k set-other-shift-altgr-key-code sag)) (when sag (send k set-other-shift-altgr-key-code sag))
(when cl (send k set-other-caps-key-code cl)) (when cl (send k set-other-caps-key-code cl))
(or s ag sag cl)))) (or s ag sag cl))))
(not (equal? #\u0000 key-code))) (not (equal? #\u0000 key-code)))
(unless (or scroll? down?) (unless (or scroll? down?)
;; swap altenate with main ;; swap altenate with main
(send k set-key-release-code (send k get-key-code)) (send k set-key-release-code (send k get-key-code))
(send k set-key-code 'release)) (send k set-key-code 'release))
(if (send wx handles-events? gtk) (if (send wx handles-events? gtk)
(begin (begin
(queue-window-event wx (lambda () (send wx dispatch-on-char k #f))) (queue-window-event wx (lambda () (send wx dispatch-on-char k #f)))
#t) #t)
(constrained-reply (send wx get-eventspace) (constrained-reply (send wx get-eventspace)
(lambda () (send wx dispatch-on-char k #t)) (lambda () (send wx dispatch-on-char k #t))
#t))))))))) #t)))))))))
(define-signal-handler connect-button-press "button-press-event" (define-signal-handler connect-button-press "button-press-event"
(_fun _GtkWidget _GdkEventButton-pointer -> _gboolean) (_fun _GtkWidget _GdkEventButton-pointer -> _gboolean)
@ -317,11 +317,11 @@
(and (and
wx wx
(if (or (= type GDK_2BUTTON_PRESS) (if (or (= type GDK_2BUTTON_PRESS)
(= type GDK_3BUTTON_PRESS) (= type GDK_3BUTTON_PRESS)
(and (or (= type GDK_ENTER_NOTIFY) (and (or (= type GDK_ENTER_NOTIFY)
(= type GDK_LEAVE_NOTIFY)) (= type GDK_LEAVE_NOTIFY))
(send wx skip-enter-leave-events))) (send wx skip-enter-leave-events)))
#t #t
(let* ([modifiers (if motion? (let* ([modifiers (if motion?
(GdkEventMotion-state event) (GdkEventMotion-state event)
(if crossing? (if crossing?
@ -345,7 +345,7 @@
[(1) 'left-up] [(1) 'left-up]
[(3) 'right-up] [(3) 'right-up]
[else 'middle-up])])] [else 'middle-up])])]
[m (let-values ([(x y) (send wx [m (let-values ([(x y) (send wx
adjust-event-position adjust-event-position
(->long ((if motion? (->long ((if motion?
GdkEventMotion-x GdkEventMotion-x
@ -378,24 +378,24 @@
(if crossing? GdkEventCrossing-time GdkEventButton-time)) (if crossing? GdkEventCrossing-time GdkEventButton-time))
event)] event)]
[caps-down (bit? modifiers GDK_LOCK_MASK)]))]) [caps-down (bit? modifiers GDK_LOCK_MASK)]))])
(if (send wx handles-events? gtk) (if (send wx handles-events? gtk)
(begin (begin
(queue-window-event wx (lambda () (queue-window-event wx (lambda ()
(send wx dispatch-on-event m #f))) (send wx dispatch-on-event m #f)))
#t) #t)
(constrained-reply (send wx get-eventspace) (constrained-reply (send wx get-eventspace)
(lambda () (or (send wx dispatch-on-event m #t) (lambda () (or (send wx dispatch-on-event m #t)
(send wx internal-pre-on-event gtk m))) (send wx internal-pre-on-event gtk m)))
#t #t
#:fail-result #:fail-result
;; an enter event is synthesized when a button is ;; an enter event is synthesized when a button is
;; enabled and the mouse is over the button, and the ;; enabled and the mouse is over the button, and the
;; event is not dispatched via the eventspace; leave ;; event is not dispatched via the eventspace; leave
;; events are perhaps similarly synthesized, so allow ;; events are perhaps similarly synthesized, so allow
;; them, too ;; them, too
(if (or (eq? type 'enter) (eq? type 'leave)) (if (or (eq? type 'enter) (eq? type 'leave))
#f #f
#t))))))))) #t)))))))))
;; ---------------------------------------- ;; ----------------------------------------
@ -592,13 +592,13 @@
(define drag-connected? #f) (define drag-connected? #f)
(define/public (drag-accept-files on?) (define/public (drag-accept-files on?)
(if on? (if on?
(begin (begin
(unless drag-connected? (unless drag-connected?
(connect-drag-data-received gtk) (connect-drag-data-received gtk)
(set! drag-connected? #t)) (set! drag-connected? #t))
(gtk_drag_dest_set gtk GTK_DEST_DEFAULT_ALL GDK_ACTION_COPY) (gtk_drag_dest_set gtk GTK_DEST_DEFAULT_ALL GDK_ACTION_COPY)
(gtk_drag_dest_add_uri_targets gtk)) (gtk_drag_dest_add_uri_targets gtk))
(gtk_drag_dest_unset gtk))) (gtk_drag_dest_unset gtk)))
(define/public (set-focus) (define/public (set-focus)
(gtk_widget_grab_focus (get-client-gtk))) (gtk_widget_grab_focus (get-client-gtk)))
@ -761,7 +761,7 @@
(when win (when win
(set-mcar! win-box #f) (set-mcar! win-box #f)
(for ([i (in-range (mcdr win-box))]) (for ([i (in-range (mcdr win-box))])
(gdk_window_thaw_updates win))))) (gdk_window_thaw_updates win)))))
(define (request-flush-delay win-box) (define (request-flush-delay win-box)
(do-request-flush-delay (do-request-flush-delay
@ -769,15 +769,15 @@
(lambda (win-box) (lambda (win-box)
(let ([win (mcar win-box)]) (let ([win (mcar win-box)])
(and win (and win
;; The freeze/thaw state is actually with the window's ;; The freeze/thaw state is actually with the window's
;; implementation, so force a native implementation of the ;; implementation, so force a native implementation of the
;; window to try to avoid it changing out from underneath ;; window to try to avoid it changing out from underneath
;; us between the freeze and thaw actions. ;; us between the freeze and thaw actions.
(gdk_window_ensure_native win) (gdk_window_ensure_native win)
(begin (begin
(gdk_window_freeze_updates win) (gdk_window_freeze_updates win)
(set-mcdr! win-box (add1 (mcdr win-box))) (set-mcdr! win-box (add1 (mcdr win-box)))
#t)))) #t))))
(lambda (win-box) (lambda (win-box)
(let ([win (mcar win-box)]) (let ([win (mcar win-box)])
(when win (when win
@ -791,5 +791,5 @@
(lambda (win-box) (lambda (win-box)
(let ([win (mcar win-box)]) (let ([win (mcar win-box)])
(when win (when win
(gdk_window_thaw_updates win) (gdk_window_thaw_updates win)
(set-mcdr! win-box (sub1 (mcdr win-box))))))))) (set-mcdr! win-box (sub1 (mcdr win-box)))))))))

40
collects/mred/private/wx/win32/types.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base #lang racket/base
(require ffi/unsafe (require ffi/unsafe
ffi/winapi) ffi/winapi)
(provide (provide
(protect-out _wfun (protect-out _wfun
@ -95,35 +95,35 @@
(define _permanent-string/utf-16 (define _permanent-string/utf-16
(make-ctype _pointer (make-ctype _pointer
(lambda (s) (lambda (s)
(and s (and s
(let ([v (malloc _gcpointer)]) (let ([v (malloc _gcpointer)])
(ptr-set! v _string/utf-16 s) (ptr-set! v _string/utf-16 s)
(let ([p (ptr-ref v _gcpointer)]) (let ([p (ptr-ref v _gcpointer)])
(let ([len (+ 1 (utf-16-length s))]) (let ([len (+ 1 (utf-16-length s))])
(let ([c (malloc len _uint16 'raw)]) (let ([c (malloc len _uint16 'raw)])
(memcpy c p len _uint16) (memcpy c p len _uint16)
c)))))) c))))))
(lambda (p) p))) (lambda (p) p)))
(define _LONG _long) (define _LONG _long)
(define _ULONG _ulong) (define _ULONG _ulong)
(define _SHORT _short) (define _SHORT _short)
(define-cstruct _POINT ([x _LONG] (define-cstruct _POINT ([x _LONG]
[y _LONG])) [y _LONG]))
(define-cstruct _RECT ([left _LONG] (define-cstruct _RECT ([left _LONG]
[top _LONG] [top _LONG]
[right _LONG] [right _LONG]
[bottom _LONG])) [bottom _LONG]))
(define-cstruct _MSG ([hwnd _HWND] (define-cstruct _MSG ([hwnd _HWND]
[message _UINT] [message _UINT]
[wParam _WPARAM] [wParam _WPARAM]
[lParam _LPARAM] [lParam _LPARAM]
[time _DWORD] [time _DWORD]
[pt _POINT])) [pt _POINT]))
(define (short v) (define (short v)
(if (zero? (bitwise-and #x8000 v)) (if (zero? (bitwise-and #x8000 v))

309
collects/tests/gracket/mem.rkt
View File

@ -21,8 +21,8 @@
(define allocated '()) (define allocated '())
(define (remember tag v) (define (remember tag v)
(set! allocated (set! allocated
(cons (cons tag (make-weak-box v)) (cons (cons tag (make-weak-box v))
allocated)) allocated))
v) v)
(define sub-collect-frame (define sub-collect-frame
@ -71,163 +71,163 @@
(unless (zero? n) (unless (zero? n)
(let ([tag (cons id n)]) (let ([tag (cons id n)])
(let* ([edit (remember tag (make-object text%))] (let* ([edit (remember tag (make-object text%))]
[ef (let ([f (make-object frame% "Editor Frame")]) [ef (let ([f (make-object frame% "Editor Frame")])
(send (make-object editor-canvas% f) set-editor edit) (send (make-object editor-canvas% f) set-editor edit)
(remember tag f))] (remember tag f))]
[c (make-custodian)] [c (make-custodian)]
[es (parameterize ([current-custodian c]) [es (parameterize ([current-custodian c])
(make-eventspace))]) (make-eventspace))])
(when edit? (when edit?
(send ef show #t) (send ef show #t)
(sleep 0.1)) (sleep 0.1))
(parameterize ([current-eventspace es]) (parameterize ([current-eventspace es])
(send (remember (send (remember
tag tag
(make-object (make-object
(class timer% (class timer%
(init-rest args) (init-rest args)
(override* [notify (lambda () (void))]) (override* [notify (lambda () (void))])
(apply super-make-object args)))) (apply super-make-object args))))
start 100)) start 100))
(when frame? (when frame?
(let* ([f (remember tag (let* ([f (remember tag
(make-object (if (even? n) (make-object (if (even? n)
frame% frame%
dialog%) dialog%)
"Tester" #f 200 200))] "Tester" #f 200 200))]
[cb (lambda (x y) f)] [cb (lambda (x y) f)]
[p (remember tag (make-object (get-pane% n) f))]) [p (remember tag (make-object (get-pane% n) f))])
(remember tag (make-object canvas% f)) (remember tag (make-object canvas% f))
(when (zero? (modulo n 3)) (when (zero? (modulo n 3))
(thread (lambda () (send f show #t))) (thread (lambda () (send f show #t)))
(let loop () (sleep) (unless (send f is-shown?) (loop)))) (let loop () (sleep) (unless (send f is-shown?) (loop))))
(remember tag (make-object button% "one" p cb)) (remember tag (make-object button% "one" p cb))
(let ([class check-box%]) (let ([class check-box%])
(let loop ([m 10]) (let loop ([m 10])
(unless (zero? m) (unless (zero? m)
(remember (cons tag m) (remember (cons tag m)
(make-object class "another" p cb)) (make-object class "another" p cb))
(loop (sub1 m))))) (loop (sub1 m)))))
(remember tag (make-object check-box% "check" p cb)) (remember tag (make-object check-box% "check" p cb))
(remember tag (make-object choice% "choice" '("a" "b" "c") p cb)) (remember tag (make-object choice% "choice" '("a" "b" "c") p cb))
(remember tag (make-object list-box% "list" '("apple" "banana" "coconut") (remember tag (make-object list-box% "list" '("apple" "banana" "coconut")
p cb)) p cb))
(remember tag (make-object button% "two" p cb)) (remember tag (make-object button% "two" p cb))
(send f show #f))) (send f show #f)))
(when subwindows? (when subwindows?
(let ([p (make-object (get-panel% n) sub-collect-frame)] (let ([p (make-object (get-panel% n) sub-collect-frame)]
[cv (make-object canvas% sub-collect-frame)] [cv (make-object canvas% sub-collect-frame)]
[add-objects [add-objects
(lambda (p tag hide?) (lambda (p tag hide?)
(let ([b (let* ([x #f] (let ([b (let* ([x #f]
[bcb (lambda (a b) x)]) [bcb (lambda (a b) x)])
(set! x (make-object button% "one" p bcb)) (set! x (make-object button% "one" p bcb))
x)] x)]
[c (make-object check-box% "check" p void)] [c (make-object check-box% "check" p void)]
[co (make-object choice% "choice" '("a" "b" "c") p void)] [co (make-object choice% "choice" '("a" "b" "c") p void)]
[cv (make-object canvas% p)] [cv (make-object canvas% p)]
[lb (make-object list-box% "list" '("apple" "banana" "coconut") p void)]) [lb (make-object list-box% "list" '("apple" "banana" "coconut") p void)])
(when hide? (when hide?
(send p delete-child b) (send p delete-child b)
(send p delete-child c) (send p delete-child c)
(send p delete-child cv) (send p delete-child cv)
(send p delete-child co) (send p delete-child co)
(send p delete-child lb)) (send p delete-child lb))
(remember tag b) (remember tag b)
(remember tag c) (remember tag c)
(remember tag cv) (remember tag cv)
(remember tag co) (remember tag co)
(remember tag lb)))]) (remember tag lb)))])
(add-objects sub-collect-panel (cons 'sc1 tag) #t) (add-objects sub-collect-panel (cons 'sc1 tag) #t)
(add-objects p (cons 'sc2 tag) #f) (add-objects p (cons 'sc2 tag) #f)
(remember (cons 'sc0 tag) p) (remember (cons 'sc0 tag) p)
(remember (cons 'sc0 tag) cv) (remember (cons 'sc0 tag) cv)
(send sub-collect-frame delete-child p) (send sub-collect-frame delete-child p)
(send sub-collect-frame delete-child cv))) (send sub-collect-frame delete-child cv)))
(when (and edit? insert?) (when (and edit? insert?)
(let ([e edit]) (let ([e edit])
(send e begin-edit-sequence) (send e begin-edit-sequence)
(when load-file? (when load-file?
(send e load-file (build-path source-dir "mem.rkt"))) (send e load-file (build-path source-dir "mem.rkt")))
(let loop ([i 20]) (let loop ([i 20])
(send e insert (number->string i)) (send e insert (number->string i))
(unless (zero? i) (unless (zero? i)
(loop (sub1 i)))) (loop (sub1 i))))
(let ([s (make-object editor-snip%)]) (let ([s (make-object editor-snip%)])
(send (send s get-editor) insert "Hello!") (send (send s get-editor) insert "Hello!")
(send e insert s)) (send e insert s))
(send e insert #\newline) (send e insert #\newline)
(send e insert "done") (send e insert "done")
(send e set-modified #f) (send e set-modified #f)
(send e end-edit-sequence))) (send e end-edit-sequence)))
(when menus? (when menus?
(let ([f (remember tag (make-object frame% "MB Frame 0"))]) (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))))) (remember tag (make-object menu% "TM1" (remember (cons 'q tag) (make-object menu-bar% f)))))
(let* ([mb (remember tag (make-object menu-bar% ef))] (let* ([mb (remember tag (make-object menu-bar% ef))]
[m (remember tag (make-object menu% "Ok" mb))]) [m (remember tag (make-object menu% "Ok" mb))])
(remember tag (make-object menu-item% "Hi" m void)) (remember tag (make-object menu-item% "Hi" m void))
(remember tag (make-object menu-item% "There" m void #\t)) (remember tag (make-object menu-item% "There" m void #\t))
(remember tag (remember tag
(make-object checkable-menu-item% (make-object checkable-menu-item%
"Checkable" "Checkable"
(remember tag (make-object menu% "Hello" m)) (remember tag (make-object menu% "Hello" m))
void)) void))
(let ([i (remember tag (make-object menu-item% "Delete Me" m void))]) (let ([i (remember tag (make-object menu-item% "Delete Me" m void))])
(send i delete))) (send i delete)))
(when subwindows? (when subwindows?
(unless permanent-ready? (unless permanent-ready?
(semaphore-wait mb-lock) (semaphore-wait mb-lock)
(unless (send sub-collect-frame get-menu-bar) (unless (send sub-collect-frame get-menu-bar)
(let ([mb (make-object menu-bar% sub-collect-frame)]) (let ([mb (make-object menu-bar% sub-collect-frame)])
(make-object menu% "Permanent" mb))) (make-object menu% "Permanent" mb)))
(set! permanent-ready? #t) (set! permanent-ready? #t)
(semaphore-post mb-lock)) (semaphore-post mb-lock))
(let* ([mb (send sub-collect-frame get-menu-bar)] (let* ([mb (send sub-collect-frame get-menu-bar)]
[mm (car (send mb get-items))]) [mm (car (send mb get-items))])
(send (remember (cons 'm tag) (make-object menu-item% "Delete Me" mm void)) delete) (send (remember (cons 'm tag) (make-object menu-item% "Delete Me" mm void)) delete)
(let ([m (remember tag (make-object menu% "Temporary" mb))]) (let ([m (remember tag (make-object menu% "Temporary" mb))])
(remember (cons 't tag) (make-object menu-item% "Temp Hi" m void)) (remember (cons 't tag) (make-object menu-item% "Temp Hi" m void))
(send m delete))))) (send m delete)))))
(when atomic? (when atomic?
(let loop ([m 8]) (let loop ([m 8])
(unless (zero? m) (unless (zero? m)
(remember (cons tag m) (make-object point% n m)) (remember (cons tag m) (make-object point% n m))
(let ([br (make-object brush%)]) (let ([br (make-object brush%)])
(remember (cons tag m) br) (remember (cons tag m) br)
(hash-set! htw br 'ok)) (hash-set! htw br 'ok))
(remember (cons tag m) (make-object pen%)) (remember (cons tag m) (make-object pen%))
(loop (sub1 m))))) (loop (sub1 m)))))
(when offscreen? (when offscreen?
(let ([m (remember tag (make-object bitmap-dc%))] (let ([m (remember tag (make-object bitmap-dc%))]
[b0 (remember (cons tag 'f) (make-object bitmap% (get-image n)))] [b0 (remember (cons tag 'f) (make-object bitmap% (get-image n)))]
[b (remember (cons tag 'u) (make-object bitmap% 100 100))] [b (remember (cons tag 'u) (make-object bitmap% 100 100))]
[b2 (remember (cons tag 'x) (make-object bitmap% 100 100))]) [b2 (remember (cons tag 'x) (make-object bitmap% 100 100))])
(unless (send b0 ok?) (unless (send b0 ok?)
(error "bitmap load error")) (error "bitmap load error"))
(send m set-bitmap b))) (send m set-bitmap b)))
(when edit? (when edit?
(send ef show #f)) (send ef show #f))
(custodian-shutdown-all c) (custodian-shutdown-all c)
(collect-garbage) (collect-garbage)
(maker id (sub1 n)))))) (maker id (sub1 n))))))
(define (still) (define (still)
(map (lambda (x) (map (lambda (x)
(let ([v (weak-box-value (cdr x))]) (let ([v (weak-box-value (cdr x))])
(when v (when v
(printf "~s ~s\n" (car x) v)))) (printf "~s ~s\n" (car x) v))))
allocated) allocated)
(void)) (void))
@ -241,29 +241,29 @@
(define (breakable t) (define (breakable t)
(if #f (if #f
(thread (lambda () (thread (lambda ()
(read) (read)
(printf "breaking\n") (printf "breaking\n")
(break-thread t) (break-thread t)
(thread-wait t) (thread-wait t)
(printf "done\n"))) (printf "done\n")))
(void))) (void)))
(define (do-test) (define (do-test)
(let ([sema (make-semaphore)]) (let ([sema (make-semaphore)])
(let loop ([n num-threads]) (let loop ([n num-threads])
(unless (zero? n) (unless (zero? n)
(breakable (breakable
(thread (lambda () (thread (lambda ()
(stw (current-thread) n) (stw (current-thread) n)
(dynamic-wind (dynamic-wind
void void
(lambda () (maker n num-times)) (lambda () (maker n num-times))
(lambda () (semaphore-post sema)))))) (lambda () (semaphore-post sema))))))
(loop (sub1 n)))) (loop (sub1 n))))
(let loop ([n num-threads]) (let loop ([n num-threads])
(unless (zero? n) (unless (zero? n)
(yield sema) (yield sema)
(loop (sub1 n))))) (loop (sub1 n)))))
(collect-garbage) (collect-garbage)
(collect-garbage) (collect-garbage)
@ -280,4 +280,3 @@
(still))) (still)))
(do-test) (do-test)