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

.

Browse Source 
original commit: 775a9c0af7a3ef80cfe8d944a239df3d94263026
This commit is contained in:
Matthew Flatt 2001-07-10 19:11:16 +00:00
parent c51217d798
commit 10c3f16281
2 changed files with 16 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
collects/mred/mred.ss
View File

@ -3752,15 +3752,16 @@
(define default-paint-cb (lambda (canvas dc) (void))) (define default-paint-cb (lambda (canvas dc) (void)))
(define canvas% (define canvas%
(class100 basic-canvas% (parent [style null] [paint-callback default-paint-cb]) (class100 basic-canvas% (parent [style null] [paint-callback default-paint-cb] [label #f])
(private-field [paint-cb paint-callback]) (private-field [paint-cb paint-callback])
(inherit get-client-size get-dc) (inherit get-client-size get-dc set-label)
(rename [super-on-paint on-paint]) (rename [super-on-paint on-paint])
(sequence (sequence
(let ([cwho '(constructor canvas)]) (let ([cwho '(constructor canvas)])
(check-container-parent cwho parent) (check-container-parent cwho parent)
(check-style cwho #f '(border hscroll vscroll gl) style) (check-style cwho #f '(border hscroll vscroll gl) style)
(check-callback cwho paint-callback) (check-callback cwho paint-callback)
(check-string/false cwho label)
(check-container-ready cwho parent) (check-container-ready cwho parent)
(when (memq 'gl style) (when (memq 'gl style)
(unless (eq? (system-type) 'windows) (unless (eq? (system-type) 'windows)
@ -3855,17 +3856,21 @@
style))) style)))
wx) wx)
parent) parent)
(when label
(set-label label))
(send parent after-new-child this)))) (send parent after-new-child this))))
(define editor-canvas% (define editor-canvas%
(class100 basic-canvas% (parent [buffer #f] [style null] [scrolls-per-page 100]) (class100 basic-canvas% (parent [buffer #f] [style null] [scrolls-per-page 100] [label #f])
(sequence (sequence
(let ([cwho '(constructor editor-canvas)]) (let ([cwho '(constructor editor-canvas)])
(check-container-parent cwho parent) (check-container-parent cwho parent)
(check-instance cwho internal-editor<%> "text% or pasteboard%" #t buffer) (check-instance cwho internal-editor<%> "text% or pasteboard%" #t buffer)
(check-style cwho #f '(hide-vscroll hide-hscroll no-vscroll no-hscroll) style) (check-style cwho #f '(hide-vscroll hide-hscroll no-vscroll no-hscroll) style)
(check-gauge-integer cwho scrolls-per-page) (check-gauge-integer cwho scrolls-per-page)
(check-string/false cwho label)
(check-container-ready cwho parent))) (check-container-ready cwho parent)))
(inherit set-label)
(private-field (private-field
[force-focus? #f] [force-focus? #f]
[scroll-to-last? #f] [scroll-to-last? #f]
@ -3932,6 +3937,8 @@
#f style scrolls-per-page #f)) #f style scrolls-per-page #f))
wx)) wx))
parent) parent)
(when label
(set-label label))
(when buffer (when buffer
(set-editor buffer)) (set-editor buffer))
(send parent after-new-child this)))) (send parent after-new-child this))))
@ -4425,17 +4432,17 @@
(check-callback1 cwho demand-callback))) (check-callback1 cwho demand-callback)))
(define menu-item% (define menu-item%
(class100 basic-selectable-menu-item% (label menu callback [shortcut #f] [help-string #f] [demand-callback void]) (class100 basic-selectable-menu-item% (label parent callback [shortcut #f] [help-string #f] [demand-callback void])
(sequence (sequence
(check-shortcut-args 'menu-item label menu callback shortcut help-string demand-callback) (check-shortcut-args 'menu-item label parent callback shortcut help-string demand-callback)
(super-init label #f menu callback shortcut help-string (lambda (x) x) demand-callback)))) (super-init label #f parent callback shortcut help-string (lambda (x) x) demand-callback))))
(define checkable-menu-item% (define checkable-menu-item%
(class100 basic-selectable-menu-item% (label menu callback [shortcut #f] [help-string #f] [demand-callback void]) (class100 basic-selectable-menu-item% (label parent callback [shortcut #f] [help-string #f] [demand-callback void])
(sequence (sequence
(check-shortcut-args 'checkable-menu-item label menu callback shortcut help-string demand-callback)) (check-shortcut-args 'checkable-menu-item label parent callback shortcut help-string demand-callback))
(private-field (private-field
[mnu menu] [mnu parent]
[wx #f]) [wx #f])
(public (public
[check (entry-point (lambda (on?) (send (send (mred->wx mnu) get-container) check (send wx id) on?)))] [check (entry-point (lambda (on?) (send (send (mred->wx mnu) get-container) check (send wx id) on?)))]

0
src/mzscheme/gc/makefile.depend
View File