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

misc repairs

Browse Source 
original commit: 626ceef11b1280486c4788198fba2ef54389a073
This commit is contained in:
Matthew Flatt 2010-07-30 07:51:14 -06:00
parent cba60dd8a7
commit 317bf373fd
10 changed files with 90 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/mred/private/mrpanel.rkt
View File

@ -10,9 +10,7 @@
"kw.ss"
"wxpanel.ss"
"mrwindow.ss"
"mrcontainer.ss"
"mrtabgroup.ss"
"mrgroupbox.ss")
"mrcontainer.ss")
(provide pane%
vertical-pane%

3
collects/mred/private/wx/cocoa/frame.rkt
View File

@ -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

122
collects/mred/private/wx/common/freeze.rkt
View File

@ -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)))))])))

7
collects/mred/private/wx/gtk/canvas.rkt
View File

@ -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))

11
collects/mred/private/wx/gtk/group-panel.rkt
View File

@ -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))

5
collects/mred/private/wx/gtk/panel.rkt
View File

@ -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?)

4
collects/mred/private/wx/gtk/radio-box.rkt
View File

@ -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)

1
collects/mred/private/wx/gtk/tab-panel.rkt
View File

@ -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))

2
collects/mred/private/wx/gtk/widget.rkt
View File

@ -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)))

2
collects/tests/gracket/item.rkt
View File

@ -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))