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

.

Browse Source 
original commit: e1c37c9df3bb4af7669969105d0e258467e4f137
This commit is contained in:
Matthew Flatt 1999-07-22 12:11:57 +00:00
parent f614cbb3a9
commit f065341b02
1 changed files with 31 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
src/mred/wrap/mred.ss
View File

@ -2803,7 +2803,7 @@
(define top-level-window<%> (define top-level-window<%>
(interface (area-container-window<%>) (interface (area-container-window<%>)
get-eventspace get-eventspace
on-activate on-traverse-char on-activate on-traverse-char on-system-menu-char
can-close? on-close can-close? on-close
can-exit? on-exit can-exit? on-exit
get-focus-window get-edit-target-window get-focus-window get-edit-target-window
@ -2829,8 +2829,17 @@
(public (public
[on-traverse-char (entry-point-1 [on-traverse-char (entry-point-1
(lambda (e) (lambda (e)
(check-instance '(method top-level-window<%> on-traverse-char) wx:key-event% 'key-event% #f e) (check-instance '(method top-level-window<%> on-traverse-char)
wx:key-event% 'key-event% #f e)
(send wx handle-traverse-key e)))] (send wx handle-traverse-key e)))]
[on-system-menu-char (entry-point-1
(lambda (e)
(check-instance '(method top-level-window<%> on-system-menu-char)
wx:key-event% 'key-event% #f e)
(and (eq? #\space (send e get-key-code))
(send e get-meta-down)
(eq? 'windows (system-type))
(send wx system-menu) #t)))]
[get-eventspace (entry-point (lambda () (ivar wx eventspace)))] [get-eventspace (entry-point (lambda () (ivar wx eventspace)))]
[can-close? (lambda () #t)] [can-close? (lambda () #t)]
[can-exit? (lambda () (can-close?))] [can-exit? (lambda () (can-close?))]
@ -2907,7 +2916,7 @@
(define frame% (define frame%
(class basic-top-level-window% (label [parent #f] [width #f] [height #f] [x #f] [y #f] [style null]) (class basic-top-level-window% (label [parent #f] [width #f] [height #f] [x #f] [y #f] [style null])
(inherit on-traverse-char) (inherit on-traverse-char on-system-menu-char)
(sequence (sequence
(let ([cwho '(constructor frame)]) (let ([cwho '(constructor frame)])
(check-string cwho label) (check-string cwho label)
@ -2933,6 +2942,7 @@
[on-subwindow-char (lambda (w event) [on-subwindow-char (lambda (w event)
(super-on-subwindow-char w event) (super-on-subwindow-char w event)
(or (on-menu-char event) (or (on-menu-char event)
(on-system-menu-char event)
(on-traverse-char event)))]) (on-traverse-char event)))])
(public (public
[on-menu-char (entry-point-1 [on-menu-char (entry-point-1
@ -2967,7 +2977,7 @@
(define dialog% (define dialog%
(class basic-top-level-window% (label [parent #f] [width #f] [height #f] [x #f] [y #f] [style null]) (class basic-top-level-window% (label [parent #f] [width #f] [height #f] [x #f] [y #f] [style null])
(inherit on-traverse-char) (inherit on-traverse-char on-system-menu-char)
(sequence (sequence
(let ([cwho '(constructor dialog)]) (let ([cwho '(constructor dialog)])
(check-string cwho label) (check-string cwho label)
@ -2980,7 +2990,8 @@
(override (override
[on-subwindow-char (lambda (w event) [on-subwindow-char (lambda (w event)
(super-on-subwindow-char w event) (super-on-subwindow-char w event)
(on-traverse-char event))]) (or (on-system-menu-char event)
(on-traverse-char event)))])
(sequence (sequence
(as-entry (as-entry
(lambda () (lambda ()
@ -3653,7 +3664,7 @@
(define wx-menu-bar% (define wx-menu-bar%
(class* wx:menu-bar% (wx<%>) (mred) (class* wx:menu-bar% (wx<%>) (mred)
(inherit delete select-system) (inherit delete)
(rename [super-append append] (rename [super-append append]
[super-enable-top enable-top]) [super-enable-top enable-top])
(private (private
@ -3671,24 +3682,20 @@
(send event get-meta-down) (send event get-meta-down)
(char? (send event get-key-code)) (char? (send event get-key-code))
(let ([c (send event get-key-code)]) (let ([c (send event get-key-code)])
(or (and (char=? #\space c) (and (or (char-alphabetic? c)
(eq? 'windows (system-type)) (char-numeric? c))
(select-system) (let ([re (key-regexp c)])
#t) (ormap
(and (or (char-alphabetic? c) (lambda (i)
(char-numeric? c)) (let* ([data (send (mred->wx i) get-menu-data)]
(let ([re (key-regexp c)]) [label (car data)]
(ormap [menu (cdr data)])
(lambda (i) (if (regexp-match re label)
(let* ([data (send (mred->wx i) get-menu-data)] (begin
[label (car data)] (send menu select)
[menu (cdr data)]) #t)
(if (regexp-match re label) #f)))
(begin items)))))))))]
(send menu select)
#t)
#f)))
items))))))))))]
[get-mred (lambda () mred)] [get-mred (lambda () mred)]
[get-items (lambda () items)] [get-items (lambda () items)]
[append-item (lambda (item menu title) [append-item (lambda (item menu title)