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

.

Browse Source 
original commit: 1f2d2723f99f23eaea665fd5d3ceca1d9e5d4619
This commit is contained in:
Matthew Flatt 1999-09-09 13:58:10 +00:00
parent e4016b5f3c
commit f559fe21ae
2 changed files with 11 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/tests/mred/windowing.ss
View File

@ -139,13 +139,22 @@
(st #f f get-cursor) (st #f f get-cursor)
(stv f set-cursor c))) (stv f set-cursor c)))
(define (show-tests f)
(unless (is-a? f dialog%)
(printf "Show ~a~n" f)
(let ([on? (send f is-shown?)])
(stv f show #f)
(when on?
(stv f show #t)))))
(define (window-tests f sw? sh? parent top m) (define (window-tests f sw? sh? parent top m)
(st parent f get-parent) (st parent f get-parent)
(st top f get-top-level-window) (st top f get-top-level-window)
(enable-tests f) (enable-tests f)
(drop-file-tests f) (drop-file-tests f)
(client->screen-tests f) (client->screen-tests f)
(cursor-tests f)) (cursor-tests f)
(show-tests f))
(define (containee-window-tests f sw? sh? parent top m) (define (containee-window-tests f sw? sh? parent top m)
(window-tests f sw? sh? parent top m) (window-tests f sw? sh? parent top m)

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

@ -2792,7 +2792,7 @@
[show (entry-point-1 (lambda (on?) [show (entry-point-1 (lambda (on?)
(when on? (when on?
(unless top? (unless top?
(unless (memq wx (ivar (send wx get-parent) children)) (unless (memq wx (ivar (send wx area-parent) children))
(raise-mismatch-error (raise-mismatch-error
(who->name '(method window<%> show)) (who->name '(method window<%> show))
"cannot show a subwindow that is not active in its parent: " "cannot show a subwindow that is not active in its parent: "