original commit: bdf5291eb92dca83329a357db68f712a80993af7
This commit is contained in:
Matthew Flatt 1999-08-30 23:44:47 +00:00
parent f041b7e137
commit ad5e0e4195
2 changed files with 22 additions and 2 deletions

View File

@ -575,7 +575,9 @@
(send (get-dc) set-origin 0 0)
(let ([dc (if ps?
(let ([dc (make-object post-script-dc%)])
(let ([dc (if (eq? ps? 'print)
(make-object printer-dc%)
(make-object post-script-dc%))])
(and (send dc ok?) dc))
(if (and use-bitmap?)
(begin
@ -701,9 +703,12 @@
(set! use-bad? (< 2 (send self get-selection)))
(send canvas on-paint))
'(horizontal))
(make-object button% "PostScript" hp
(make-object button% "PS" hp
(lambda (self event)
(send canvas on-paint #t)))
(make-object button% "Print" hp
(lambda (self event)
(send canvas on-paint 'print)))
(make-object check-box% "*2" hp
(lambda (self event)
(send canvas set-scale (if (send self get-value) 2 1))))

View File

@ -2,6 +2,21 @@
(when (not (defined? 'test))
(load-relative "testing.ss"))
; These message boxes mustn't survive
(let ([c (make-custodian)])
(parameterize ([current-custodian c])
(parameterize ([current-eventspace (make-eventspace)])
(queue-callback
(lambda ()
(queue-callback
(lambda ()
(sleep/yield 0.1)
(queue-callback
(lambda ()
(custodian-shutdown-all c)))
(message-box "w" "q")))
(message-box "x" "y"))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Windowing Tests ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;