diff --git a/collects/mred/private/mrpanel.rkt b/collects/mred/private/mrpanel.rkt index 34c494af..4c42d08c 100644 --- a/collects/mred/private/mrpanel.rkt +++ b/collects/mred/private/mrpanel.rkt @@ -10,9 +10,7 @@ "kw.ss" "wxpanel.ss" "mrwindow.ss" - "mrcontainer.ss" - "mrtabgroup.ss" - "mrgroupbox.ss") + "mrcontainer.ss") (provide pane% vertical-pane% diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 202e45fb..190766c2 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -95,7 +95,8 @@ (tell (tell MyWindow alloc) initWithContentRect: #:type _NSRect (let-values ([(x y) (init-pos x y)]) (make-NSRect (make-NSPoint x y) - (make-NSSize w h))) + (make-NSSize (max 30 w) + (max 0 h)))) styleMask: #:type _int (if (memq 'no-caption style) NSBorderlessWindowMask (bitwise-ior diff --git a/collects/mred/private/wx/common/freeze.rkt b/collects/mred/private/wx/common/freeze.rkt index b2a4dce6..0d1a7965 100644 --- a/collects/mred/private/wx/common/freeze.rkt +++ b/collects/mred/private/wx/common/freeze.rkt @@ -39,26 +39,28 @@ (define (internal-error str) (log-error (apply string-append - (format "internal error: ~s" str) - (for/list ([c (continuation-mark-set->context (current-continuation-marks))]) - (let ([name (car c)] - [loc (cdr c)]) - (cond - [loc - (string-append - "\n" - (cond - [(srcloc-line loc) - (format "~a:~a:~a" - (srcloc-source loc) - (srcloc-line loc) - (srcloc-column loc))] - [else - (format "~a::~a" - (srcloc-source loc) - (srcloc-position loc))]) - (if name (format " ~a" name) ""))] - [else (format "\n ~a" name)])))))) + (format "internal error: ~a" str) + (append + (for/list ([c (continuation-mark-set->context (current-continuation-marks))]) + (let ([name (car c)] + [loc (cdr c)]) + (cond + [loc + (string-append + "\n" + (cond + [(srcloc-line loc) + (format "~a:~a:~a" + (srcloc-source loc) + (srcloc-line loc) + (srcloc-column loc))] + [else + (format "~a::~a" + (srcloc-source loc) + (srcloc-position loc))]) + (if name (format " ~a" name) ""))] + [else (format "\n ~a" name)]))) + '("\n"))))) ;; FIXME: waiting 200msec is not a good enough rule. (define (constrained-reply es thunk default [should-give-up? @@ -66,42 +68,46 @@ (lambda () ((current-inexact-milliseconds) . > . (+ now 200))))]) (let ([b (freezer-box)]) - (unless b - (internal-error "constrained-reply not within an unfreeze point")) - (if (eq? (current-thread) (eventspace-handler-thread es)) - (if (pair? (unbox b)) - ;; already suspended, so push this work completely: - (set-box! b (cons thunk (unbox b))) - ;; try to do some work: - (let* ([prev #f] - [ready? #f] - [handler (lambda () - (when (and ready? (should-give-up?)) - (scheme_call_with_composable_no_dws - (lambda (proc) - (set-box! b (cons proc (unbox b))) - (scheme_restore_on_atomic_timeout prev) - (scheme_abort_continuation_no_dws - freeze-tag - (lambda () default))) - freeze-tag) - (void)))]) - (with-holding - handler - (call-with-continuation-prompt ; to catch aborts - (lambda () - (call-with-continuation-prompt ; for composable continuation + (cond + [(not b) + (internal-error (format "constrained-reply not within an unfreeze point for ~s" + thunk)) + default] + [(not (eq? (current-thread) (eventspace-handler-thread es))) + (internal-error "wrong eventspace for constrained event handling\n") + default] + [(pair? (unbox b)) + ;; already suspended, so push this work completely: + (set-box! b (cons thunk (unbox b))) + default] + [else + ;; try to do some work: + (let* ([prev #f] + [ready? #f] + [handler (lambda () + (when (and ready? (should-give-up?)) + (scheme_call_with_composable_no_dws + (lambda (proc) + (set-box! b (cons proc (unbox b))) + (scheme_restore_on_atomic_timeout prev) + (scheme_abort_continuation_no_dws + freeze-tag + (lambda () default))) + freeze-tag) + (void)))]) + (with-holding + handler + (call-with-continuation-prompt ; to catch aborts + (lambda () + (call-with-continuation-prompt ; for composable continuation + (lambda () + (set! prev (scheme_set_on_atomic_timeout handler)) + (set! ready? #t) + (dynamic-wind + void (lambda () - (set! prev (scheme_set_on_atomic_timeout handler)) - (set! ready? #t) - (dynamic-wind - void - (lambda () - (parameterize ([freezer-box #f]) - (thunk))) - (lambda () - (scheme_restore_on_atomic_timeout prev)))) - freeze-tag)))))) - (begin - (internal-error "wrong eventspace for constrained event handling\n") - default)))) + (parameterize ([freezer-box #f]) + (thunk))) + (lambda () + (scheme_restore_on_atomic_timeout prev)))) + freeze-tag)))))]))) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 2cd0c3c5..4ee321b1 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -22,7 +22,6 @@ (define-gtk gtk_widget_queue_draw (_fun _GtkWidget -> _void)) -(define-gtk gtk_hbox_new (_fun _gboolean _int -> _GtkWidget)) (define-gtk gtk_hscrollbar_new (_fun _pointer -> _GtkWidget)) (define-gtk gtk_vscrollbar_new (_fun _pointer -> _GtkWidget)) @@ -205,9 +204,11 @@ (gtk_widget_queue_draw client-gtk)) (define/public (reset-child-dcs) - (send dc reset-dc)) + (when (dc . is-a? . dc%) + (send dc reset-dc))) (define/override (maybe-register-as-child parent on?) - (register-as-child parent on?)) + (register-as-child parent on?) + (when on? (reset-child-dcs))) (define/override (internal-on-client-size w h) (send dc reset-dc)) diff --git a/collects/mred/private/wx/gtk/group-panel.rkt b/collects/mred/private/wx/gtk/group-panel.rkt index b22859db..2550a2c0 100644 --- a/collects/mred/private/wx/gtk/group-panel.rkt +++ b/collects/mred/private/wx/gtk/group-panel.rkt @@ -25,7 +25,7 @@ style label) - (inherit set-size set-auto-size get-gtk) + (inherit set-size set-auto-size get-gtk get-height) (define gtk (gtk_frame_new label)) (define client-gtk (gtk_fixed_new)) @@ -40,6 +40,15 @@ (set-auto-size) + ;; The delta between the group box height and its + ;; client height can go bad if the label is set. + ;; Avoid the problem by effectively using the + ;; original delta. + (define orig-h (get-height)) + (define/override (get-client-size xb yb) + (super get-client-size xb yb) + (set-box! yb (- (get-height) orig-h))) + (define/public (set-label s) (gtk_frame_set_label gtk s)) diff --git a/collects/mred/private/wx/gtk/panel.rkt b/collects/mred/private/wx/gtk/panel.rkt index 5cee2fcc..0fd06faa 100644 --- a/collects/mred/private/wx/gtk/panel.rkt +++ b/collects/mred/private/wx/gtk/panel.rkt @@ -37,8 +37,9 @@ (reset-child-dcs)) (define/override (maybe-register-as-child parent on?) - (register-as-child parent on?)) - + (register-as-child parent on?) + (when on? (reset-child-dcs))) + (define/override (register-child child on?) (let ([now-on? (and (memq child children) #t)]) (unless (eq? on? now-on?) diff --git a/collects/mred/private/wx/gtk/radio-box.rkt b/collects/mred/private/wx/gtk/radio-box.rkt index dc91cd37..d113b269 100644 --- a/collects/mred/private/wx/gtk/radio-box.rkt +++ b/collects/mred/private/wx/gtk/radio-box.rkt @@ -43,7 +43,9 @@ (inherit set-auto-size on-set-focus) - (define gtk (gtk_vbox_new #f 0)) + (define gtk (if (memq 'horizontal style) + (gtk_hbox_new #f 0) + (gtk_vbox_new #f 0))) (define radio-gtks (for/list ([lbl (in-list labels)]) (let ([radio-gtk (cond [(string? lbl) diff --git a/collects/mred/private/wx/gtk/tab-panel.rkt b/collects/mred/private/wx/gtk/tab-panel.rkt index a190e4c4..5ff4a204 100644 --- a/collects/mred/private/wx/gtk/tab-panel.rkt +++ b/collects/mred/private/wx/gtk/tab-panel.rkt @@ -16,7 +16,6 @@ (define-gtk gtk_notebook_new (_fun -> _GtkWidget)) (define-gtk gtk_fixed_new (_fun -> _GtkWidget)) -(define-gtk gtk_hbox_new (_fun _gboolean _int -> _GtkWidget)) (define-gtk gtk_notebook_append_page (_fun _GtkWidget _GtkWidget (_or-null _GtkWidget) -> _void)) (define-gtk gtk_notebook_remove_page (_fun _GtkWidget _int -> _void)) diff --git a/collects/mred/private/wx/gtk/widget.rkt b/collects/mred/private/wx/gtk/widget.rkt index cc3cf704..bb1d602b 100644 --- a/collects/mred/private/wx/gtk/widget.rkt +++ b/collects/mred/private/wx/gtk/widget.rkt @@ -14,6 +14,7 @@ gtk_widget_hide gtk_vbox_new + gtk_hbox_new gtk_box_pack_start gtk_box_pack_end) @@ -21,6 +22,7 @@ (define-gtk gtk_widget_hide (_fun _GtkWidget -> _void)) (define-gtk gtk_vbox_new (_fun _gboolean _int -> _GtkWidget)) +(define-gtk gtk_hbox_new (_fun _gboolean _int -> _GtkWidget)) (define-gtk gtk_box_pack_start (_fun _GtkWidget _GtkWidget _gboolean _gboolean _uint -> _void)) (define-gtk gtk_box_pack_end (_fun _GtkWidget _GtkWidget _gboolean _gboolean _uint -> _void)) (define-gtk gtk_widget_get_parent (_fun _GtkWidget -> (_or-null _GtkWidget))) diff --git a/collects/tests/gracket/item.rkt b/collects/tests/gracket/item.rkt index 40be32ba..225394a2 100644 --- a/collects/tests/gracket/item.rkt +++ b/collects/tests/gracket/item.rkt @@ -2214,7 +2214,7 @@ (let loop ([l radios]) (let* ([c (car l)] [rest (cdr l)] - [n (send c number)] + [n (send c get-number)] [v (send c get-selection)]) (if (< v (sub1 n)) (send c set-selection (add1 v))