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

misc repairs

Browse Source
This commit is contained in:
Matthew Flatt 2010-07-13 08:34:35 -06:00
parent 88f75dbc13
commit 4bfed6d797
19 changed files with 76 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/mred/private/kernel.rkt
View File

@ -33,4 +33,5 @@
main-eventspace?
eventspace-handler-thread
queue-callback
middle-queue-key)
middle-queue-key
get-top-level-windows)

7
collects/mred/private/wx/cocoa/button.rkt
View File

@ -103,6 +103,13 @@
(tellv button-cocoa setAction: #:type _SEL (selector clicked:))
(define/override (get-cocoa-control) button-cocoa)
(define/override (set-label label)
(cond
[(string? label)
(tellv cocoa setTitleWithMnemonic: #:type _NSString label)]
[else
(tellv cocoa setImage: (bitmap->image label))]))
(define callback cb)
(define/public (clicked)

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

@ -217,8 +217,9 @@
(define/override (call-pre-on-char w e)
(pre-on-char w e))
(define/public (on-menu-click) (void))
(def/public-unimplemented on-toolbar-click)
(def/public-unimplemented on-menu-click)
(def/public-unimplemented on-menu-command)
(def/public-unimplemented on-mdi-activate)
(def/public-unimplemented on-close)

7
collects/mred/private/wx/cocoa/image.rkt
View File

@ -57,12 +57,11 @@
[h (send bm get-height)]
[str (make-bytes (* w h 4) 255)])
(send bm get-argb-pixels 0 0 w h str #f)
(let ([mask-bm (send bm get-loaded-mask)])
(when mask-bm
(send mask-bm get-argb-pixels 0 0 w h str #t)))
(when (send bm get-loaded-mask)
(send bm get-argb-pixels 0 0 w h str #t))
(as-entry
(lambda ()
(let ([rgba (scheme_make_sized_byte_string (malloc (* w h 4)) (* w h 4) 1)])
(let ([rgba (scheme_make_sized_byte_string (malloc (* w h 4) 'raw) (* w h 4) 0)])
(memcpy rgba str (sub1 (* w h 4)))
(let* ([cs (CGColorSpaceCreateDeviceRGB)]
[provider (CGDataProviderCreateWithData #f rgba (* w h 4) free-it)]

13
collects/mred/private/wx/cocoa/menu.rkt
View File

@ -125,13 +125,14 @@
(define/public (checked? item)
(send item get-checked))
(def/public-unimplemented delete-by-position)
(define/public (delete-by-position pos)
(let ([mitem (list-ref items pos)])
(set! items (append (take items pos)
(drop items (add1 pos))))
(when cocoa-menu
(tellv cocoa-menu removeItemAtIndex: #:type _NSInteger pos))))
(define/public (delete item)
(let ([pos (find-pos item)])
(when pos
(let ([mitem (list-ref items pos)])
(set! items (append (take items pos)
(drop items (add1 pos))))
(when cocoa-menu
(tellv cocoa-menu removeItemAtIndex: #:type _NSInteger pos)))))))
(delete-by-position pos)))))

1
collects/mred/private/wx/cocoa/platform.rkt
View File

@ -93,7 +93,6 @@
shortcut-visible-in-label?
unregister-collecting-blit
register-collecting-blit
get-top-level-windows
find-graphical-system-path
check-for-break
play-sound

2
collects/mred/private/wx/cocoa/procs.rkt
View File

@ -21,7 +21,6 @@
play-sound
check-for-break
find-graphical-system-path
get-top-level-windows
register-collecting-blit
unregister-collecting-blit
shortcut-visible-in-label?
@ -73,7 +72,6 @@
(define-unimplemented play-sound)
(define-unimplemented check-for-break)
(define-unimplemented find-graphical-system-path)
(define-unimplemented get-top-level-windows)
(define (register-collecting-blit . args) (void))
(define (unregister-collecting-blit . args) (void))
(define (shortcut-visible-in-label? [x #f]) #f)

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

@ -29,16 +29,18 @@
;; Out of atomic mode:
(let ([k (unbox b)])
(when k
(call-with-continuation-prompt
k
freeze-tag)))
(call-with-continuation-prompt ; to catch aborts
(lambda ()
(call-with-continuation-prompt
k
freeze-tag)))))
(void))))
;; FIXME: waiting 200msec is not a good enough rule.
(define (constrained-reply es thunk default [should-give-up?
(let ([now (current-inexact-milliseconds)])
(lambda ()
((current-inexact-milliseconds) . > . 200)))])
((current-inexact-milliseconds) . > . (+ now 200))))])
(unless (freezer-box)
(log-error "internal error: constrained-reply not within an unfreeze point"))
(if (eq? (current-thread) (eventspace-handler-thread es))

12
collects/mred/private/wx/common/queue.rkt
View File

@ -34,6 +34,7 @@
remove-timer-callback
register-frame-shown
get-top-level-windows
queue-quit-event)
@ -101,7 +102,7 @@
;; ------------------------------------------------------------
;; Eventspaces
(define-struct eventspace (handler-thread queue-proc done-evt)
(define-struct eventspace (handler-thread queue-proc frames-hash done-evt)
#:property prop:evt (lambda (v)
(wrap-evt (eventspace-done-evt v)
(lambda (_) v))))
@ -126,7 +127,8 @@
[else 1]))))
(define (make-eventspace* th)
(let ([done-sema (make-semaphore 1)])
(let ([done-sema (make-semaphore 1)]
[frames (make-hasheq)])
(make-eventspace th
(let ([count 0])
(let ([lo (mcons #f #f)]
@ -134,7 +136,6 @@
[hi (mcons #f #f)]
[timer (box '())]
[timer-counter 0]
[frames (make-hasheq)]
[newly-posted-sema (make-semaphore)])
(let* ([check-done
(lambda ()
@ -234,6 +235,7 @@
never-evt))])
(end-atomic)
e))]))))
frames
(semaphore-peek-evt done-sema))))
(define main-eventspace (make-eventspace* (current-thread)))
@ -317,5 +319,9 @@
'frame-add
'frame-remove)))
(define (get-top-level-windows)
(hash-map (eventspace-frames-hash (current-eventspace))
(lambda (k v) k)))
(define (queue-quit-event)
(queue-event main-eventspace (application-quit-handler) 'med))

15
collects/mred/private/wx/gtk/button.rkt
View File

@ -20,6 +20,10 @@
(define-gtk gtk_button_new_with_mnemonic (_fun _string -> _GtkWidget))
(define-gtk gtk_button_new (_fun -> _GtkWidget))
(define-gtk gtk_window_set_default (_fun _GtkWidget (_or-null _GtkWidget) -> _void))
(define-gtk gtk_button_set_label (_fun _GtkWidget _string -> _void))
(define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void))
(define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget))
(define-signal-handler connect-clicked "clicked"
(_fun _GtkWidget -> _void)
@ -71,6 +75,17 @@
;; Called from event-handling thread
(queue-window-event this (lambda () (clicked))))
(define/override (set-label s)
(cond
[(string? s)
(gtk_button_set_label gtk (mnemonic-string s))]
[else
(let ([image-gtk (gtk_image_new_from_pixbuf
(bitmap->pixbuf s))])
(gtk_container_remove gtk (gtk_bin_get_child gtk))
(gtk_container_add gtk image-gtk)
(gtk_widget_show image-gtk))]))
(define/public (set-border on?)
(gtk_window_set_default (get-window-gtk) (if on? gtk #f))))

34
collects/mred/private/wx/gtk/pixbuf.rkt
View File

@ -2,6 +2,7 @@
(require racket/class
ffi/unsafe
racket/draw
"../../lock.rkt"
"../common/bstr.rkt"
"utils.rkt"
"types.rkt"
@ -35,19 +36,20 @@
[h (send bm get-height)]
[str (make-bytes (* w h 4) 255)])
(send bm get-argb-pixels 0 0 w h str #f)
(let ([mask-bm (send bm get-loaded-mask)])
(when mask-bm
(send mask-bm get-argb-pixels 0 0 w h str #t)))
(let ([rgba (scheme_make_sized_byte_string (malloc (* w h 4) 'raw) (* w h 4) 1)])
(memcpy rgba (ptr-add str 1) (sub1 (* w h 4)))
(for ([i (in-range 0 (* w h 4) 4)])
(bytes-set! rgba (+ i 3) (bytes-ref str i)))
(gdk_pixbuf_new_from_data rgba
0
#t
8
w
h
(* w 4)
free-it
#f))))
(when (send bm get-loaded-mask)
(send bm get-argb-pixels 0 0 w h str #t))
(as-entry
(lambda ()
(let ([rgba (scheme_make_sized_byte_string (malloc (* w h 4) 'raw) (* w h 4) 0)])
(memcpy rgba (ptr-add str 1) (sub1 (* w h 4)))
(for ([i (in-range 0 (* w h 4) 4)])
(bytes-set! rgba (+ i 3) (bytes-ref str i)))
(gdk_pixbuf_new_from_data rgba
0
#t
8
w
h
(* w 4)
free-it
#f))))))

1
collects/mred/private/wx/gtk/platform.rkt
View File

@ -93,7 +93,6 @@
shortcut-visible-in-label?
unregister-collecting-blit
register-collecting-blit
get-top-level-windows
find-graphical-system-path
check-for-break
play-sound

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

@ -21,7 +21,6 @@
play-sound
check-for-break
find-graphical-system-path
get-top-level-windows
register-collecting-blit
unregister-collecting-blit
shortcut-visible-in-label?
@ -71,7 +70,6 @@
(define-unimplemented play-sound)
(define-unimplemented check-for-break)
(define-unimplemented find-graphical-system-path)
(define (get-top-level-windows) null)
(define (register-collecting-blit . args) (void))
(define (unregister-collecting-blit . args) (void))
(define (shortcut-visible-in-label? [mbar? #f]) #t)

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

@ -99,7 +99,11 @@
(as-entry
(lambda ()
(set! no-clicked? #t)
(gtk_toggle_button_set_active (list-ref radio-gtks i) #t)
(if (= i -1)
(let ([i (get-selection)])
(unless (= i -1)
(gtk_toggle_button_set_active (list-ref radio-gtks i) #f)))
(gtk_toggle_button_set_active (list-ref radio-gtks i) #t))
(set! no-clicked? #f))))
(define/public (get-selection)

1
collects/mred/private/wx/platform.rkt
View File

@ -71,7 +71,6 @@
shortcut-visible-in-label?
unregister-collecting-blit
register-collecting-blit
get-top-level-windows
find-graphical-system-path
check-for-break
play-sound

1
collects/mred/private/wx/win32/platform.rkt
View File

@ -92,7 +92,6 @@
shortcut-visible-in-label?
unregister-collecting-blit
register-collecting-blit
get-top-level-windows
find-graphical-system-path
check-for-break
play-sound

2
collects/mred/private/wx/win32/procs.rkt
View File

@ -14,7 +14,6 @@
play-sound
check-for-break
find-graphical-system-path
get-top-level-windows
register-collecting-blit
unregister-collecting-blit
shortcut-visible-in-label?
@ -68,7 +67,6 @@
(define-unimplemented play-sound)
(define-unimplemented check-for-break)
(define-unimplemented find-graphical-system-path)
(define-unimplemented get-top-level-windows)
(define-unimplemented register-collecting-blit)
(define-unimplemented unregister-collecting-blit)
(define-unimplemented shortcut-visible-in-label?)

1
collects/mrlib/bitmap-label.rkt
View File

@ -96,6 +96,7 @@
outside-margin
(- (/ new-height 2) (/ img-height 2)))
(send bitmap-dc set-bitmap #f)
new-bitmap)))
(define (bitmap-label-maker text filename-or-bitmap)

2
collects/racket/draw/lock.rkt
View File

@ -84,7 +84,7 @@
(lambda (t) (t))))]))
(define (as-exit f)
;; (unless (eq? monitor-owner (current-thread)) (error 'monitor-exit "not in monitored area for ~e" f))
(unless (eq? monitor-owner (current-thread)) (error 'monitor-exit "not in monitored area for ~e" f))
(let ([paramz old-paramz]
[break-paramz old-break-paramz])
(with-continuation-mark