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

.

Browse Source 
original commit: 38a535fe718f1bf8c60c064e8bcd2dc34559bed1
This commit is contained in:
Matthew Flatt 1998-08-16 21:18:21 +00:00
parent e4969989ea
commit cda35099a4
1 changed files with 22 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -653,6 +653,7 @@
(define (make-top-level-window-glue% %) ; implies make-window-glue% (define (make-top-level-window-glue% %) ; implies make-window-glue%
(class (make-window-glue% %) (mred proxy . args) (class (make-window-glue% %) (mred proxy . args)
(rename [super-on-activate on-activate]) (rename [super-on-activate on-activate])
(public [act-date/seconds 0] [act-date/milliseconds 0] [act-on? #f])
(override (override
[on-close (lambda () [on-close (lambda ()
(if mred (if mred
@ -663,7 +664,11 @@
#f) #f)
#t))] #t))]
[on-activate (lambda (on?) [on-activate (lambda (on?)
(set! active-frame this) (set! act-on? on?)
(when on?
(set! act-date/seconds (current-seconds))
(set! act-date/milliseconds (current-milliseconds))
(set! active-frame this))
(super-on-activate on?) (super-on-activate on?)
(send mred on-activate on?))]) (send mred on-activate on?))])
(sequence (apply super-init mred proxy args)))) (sequence (apply super-init mred proxy args))))
@ -2072,6 +2077,22 @@
(define (get-top-level-windows) (define (get-top-level-windows)
(map wx->mred (wx:get-top-level-windows))) (map wx->mred (wx:get-top-level-windows)))
(define (get-top-level-focus-window)
(ormap (lambda (f) (and (ivar f act-on?) (wx->mred f))) (wx:get-top-level-windows)))
(define (get-top-level-edit-target-window)
(let loop ([l (wx:get-top-level-windows)][f #f][s 0][ms 0])
(if (null? l)
(and f (wx->mred f))
(let* ([f2 (car l)]
[s2 (ivar f2 act-date/seconds)]
[ms2 (ivar f2 act-date/milliseconds)])
(if (or (not f)
(> s2 s)
(and (= s2 s) (> ms2 ms)))
(loop (cdr l) f2 s2 ms2)
(loop (cdr l) f s ms))))))
(define message% (define message%
(class basic-control% (label parent [style null]) (class basic-control% (label parent [style null])
(sequence (sequence