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

.

Browse Source 
original commit: fcf11fece465cfb911fc8db16aa87839031d90e8
This commit is contained in:
Matthew Flatt 1999-05-17 18:49:16 +00:00
parent 8601b15e62
commit b2a7f8490e
1 changed files with 103 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2509,9 +2509,9 @@
(define (constructor-name who) (define (constructor-name who)
(string->symbol (format "initialization for ~a%" who))) (string->symbol (format "initialization for ~a%" who)))
(define (check-container-parent who p) (define (check-container-parent cwho p)
(unless (is-a? p internal-container<%>) (unless (is-a? p internal-container<%>)
(raise-type-error (constructor-name who) "built-in container<%> object" p))) (raise-type-error cwho "built-in container<%> object" p)))
(define (check-top-level-parent/false who p) (define (check-top-level-parent/false who p)
(unless (or (not p) (is-a? p frame%) (is-a? p dialog%)) (unless (or (not p) (is-a? p frame%) (is-a? p dialog%))
@ -2521,8 +2521,16 @@
(unless (or (not p) (is-a? p frame%)) (unless (or (not p) (is-a? p frame%))
(raise-type-error (who->name who) "frame% object or #f" p))) (raise-type-error (who->name who) "frame% object or #f" p)))
(define (check-orientation who l) (define (check-orientation cwho l)
(check-style `(constructor-name ,who) '(vertical horizontal) null l)) (check-style cwho '(vertical horizontal) null l))
(define (check-container-ready cwho p)
(when p
(let ([wx (mred->wx p)])
(unless wx
(raise-mismatch-error (who->name cwho)
"container is not yet fully initialized: "
p)))))
(define double-boxed (define double-boxed
(lambda (x y f) (lambda (x y f)
@ -2889,7 +2897,9 @@
(when (memq 'mdi-parent style) (when (memq 'mdi-parent style)
(raise-type-error (who->name cwho) (raise-type-error (who->name cwho)
"style list, 'mdi-child and 'mdi-parent are mutually exclusive" "style list, 'mdi-child and 'mdi-parent are mutually exclusive"
style)) style)))
(check-container-ready cwho parent)
(when (memq 'mdi-child style)
(let ([pwx (and parent (mred->wx parent))]) (let ([pwx (and parent (mred->wx parent))])
(unless (and pwx (ivar pwx is-mdi-parent?)) (unless (and pwx (ivar pwx is-mdi-parent?))
(raise-mismatch-error (who->name cwho) "parent for 'mdi-child frame is not an 'mdi-parent frame: " parent)))))) (raise-mismatch-error (who->name cwho) "parent for 'mdi-child frame is not an 'mdi-parent frame: " parent))))))
@ -2938,7 +2948,8 @@
(check-string cwho label) (check-string cwho label)
(check-top-level-parent/false cwho parent) (check-top-level-parent/false cwho parent)
(for-each (lambda (x) (check-dimension cwho x)) (list width height x y)) (for-each (lambda (x) (check-dimension cwho x)) (list width height x y))
(check-style cwho #f '(no-caption) style))) (check-style cwho #f '(no-caption) style)
(check-container-ready cwho parent)))
(rename [super-on-subwindow-char on-subwindow-char]) (rename [super-on-subwindow-char on-subwindow-char])
(private [wx #f]) (private [wx #f])
(override (override
@ -2979,9 +2990,11 @@
(define message% (define message%
(class basic-control% (label parent [style null]) (class basic-control% (label parent [style null])
(sequence (sequence
(check-string-or-bitmap '(constructor message) label) (let ([cwho '(constructor message)])
(check-container-parent 'message parent) (check-string-or-bitmap cwho label)
(check-style '(constructor message) #f null style) (check-container-parent cwho parent)
(check-style cwho #f null style)
(check-container-ready cwho parent))
(as-entry (as-entry
(lambda () (lambda ()
(super-init (lambda () (make-object wx-message% this this (super-init (lambda () (make-object wx-message% this this
@ -2992,10 +3005,12 @@
(define button% (define button%
(class basic-control% (label parent callback [style null]) (class basic-control% (label parent callback [style null])
(sequence (sequence
(check-string-or-bitmap '(constructor button) label) (let ([cwho '(constructor button)])
(check-container-parent 'button parent) (check-string-or-bitmap cwho label)
(check-callback '(constructor button) callback) (check-container-parent cwho parent)
(check-style '(constructor button) #f '(border) style) (check-callback cwho callback)
(check-style cwho #f '(border) style)
(check-container-ready cwho parent))
(as-entry (as-entry
(lambda () (lambda ()
(super-init (lambda () (make-object wx-button% this this (super-init (lambda () (make-object wx-button% this this
@ -3006,10 +3021,12 @@
(define check-box% (define check-box%
(class basic-control% (label parent callback [style null]) (class basic-control% (label parent callback [style null])
(sequence (sequence
(check-string-or-bitmap '(constructor check-box) label) (let ([cwho '(constructor check-box)])
(check-container-parent 'check-box parent) (check-string-or-bitmap cwho label)
(check-callback '(constructor check-box) callback) (check-container-parent cwho parent)
(check-style '(constructor check-box) #f null style)) (check-callback cwho callback)
(check-style cwho #f null style)
(check-container-ready cwho parent)))
(private (private
[wx #f]) [wx #f])
(public (public
@ -3028,14 +3045,16 @@
(define radio-box% (define radio-box%
(class basic-control% (label choices parent callback [style '(vertical)]) (class basic-control% (label choices parent callback [style '(vertical)])
(sequence (sequence
(check-string/false '(constructor radio-box) label) (let ([cwho '(constructor radio-box)])
(unless (and (list? choices) (pair? choices) (check-string/false cwho label)
(or (andmap string? choices) (unless (and (list? choices) (pair? choices)
(andmap (lambda (x) (is-a? x wx:bitmap%)) choices))) (or (andmap string? choices)
(raise-type-error (constructor-name 'radio-box) "non-empty list of strings or bitmap% objects" choices)) (andmap (lambda (x) (is-a? x wx:bitmap%)) choices)))
(check-container-parent 'radio-box parent) (raise-type-error (who->name cwho) "non-empty list of strings or bitmap% objects" choices))
(check-callback '(constructor radio-box) callback) (check-container-parent cwho parent)
(check-orientation 'radio-box style)) (check-callback cwho callback)
(check-orientation cwho style)
(check-container-ready cwho parent)))
(private (private
[wx #f] [wx #f]
[check-button [check-button
@ -3081,13 +3100,15 @@
(define slider% (define slider%
(class basic-control% (label min-val max-val parent callback [value min-val] [style '(horizontal)]) (class basic-control% (label min-val max-val parent callback [value min-val] [style '(horizontal)])
(sequence (sequence
(check-string/false '(constructor slider) label) (let ([cwho '(constructor slider)])
(check-slider-integer '(constructor slider) min-val) (check-string/false cwho label)
(check-slider-integer '(constructor slider) max-val) (check-slider-integer cwho min-val)
(check-container-parent 'slider parent) (check-slider-integer cwho max-val)
(check-callback '(constructor slider) callback) (check-container-parent cwho parent)
(check-slider-integer '(constructor slider) value) (check-callback cwho callback)
(check-style '(constructor slider) '(vertical horizontal) '(plain) style)) (check-slider-integer cwho value)
(check-style cwho '(vertical horizontal) '(plain) style)
(check-container-ready cwho parent)))
(private (private
[wx #f]) [wx #f])
(public (public
@ -3114,10 +3135,12 @@
(define gauge% (define gauge%
(class basic-control% (label range parent [style '(horizontal)]) (class basic-control% (label range parent [style '(horizontal)])
(sequence (sequence
(check-string/false '(constructor gauge) label) (let ([cwho '(constructor gauge)])
(check-container-parent 'gauge parent) (check-string/false cwho label)
(check-gauge-integer '(constructor gauge) range) (check-container-parent cwho parent)
(check-orientation 'gauge style)) (check-gauge-integer cwho range)
(check-orientation cwho style)
(check-container-ready cwho parent)))
(private (private
[wx #f]) [wx #f])
(public (public
@ -3191,19 +3214,20 @@
(lambda () (lambda ()
(super-init (lambda () (set! wx (mk-wx)) wx) label parent #f)))))) (super-init (lambda () (set! wx (mk-wx)) wx) label parent #f))))))
(define (check-list-control-args who label choices parent callback) (define (check-list-control-args cwho label choices parent callback)
(let ([cwho `(constructor-name ,who)]) (check-string/false cwho label)
(check-string/false cwho label) (unless (and (list? choices) (andmap string? choices))
(unless (and (list? choices) (andmap string? choices)) (raise-type-error (who->name cwho) "list of strings" choices))
(raise-type-error (who->name cwho) "list of strings" choices)) (check-container-parent cwho parent)
(check-container-parent who parent) (check-callback cwho callback))
(check-callback cwho callback)))
(define choice% (define choice%
(class basic-list-control% (label choices parent callback [style null]) (class basic-list-control% (label choices parent callback [style null])
(sequence (sequence
(check-list-control-args 'choice label choices parent callback) (let ([cwho '(constructor choice)])
(check-style '(constructor choice) #f null style) (check-list-control-args cwho label choices parent callback)
(check-style cwho #f null style)
(check-container-ready cwho parent))
(super-init (lambda () (make-object wx-choice% this this (super-init (lambda () (make-object wx-choice% this this
(mred->wx-container parent) (wrap-callback callback) (mred->wx-container parent) (wrap-callback callback)
label -1 -1 -1 -1 choices style)) label -1 -1 -1 -1 choices style))
@ -3212,8 +3236,10 @@
(define list-box% (define list-box%
(class basic-list-control% (label choices parent callback [style '(single)]) (class basic-list-control% (label choices parent callback [style '(single)])
(sequence (sequence
(check-list-control-args 'list-box label choices parent callback) (let ([cwho '(constructor list-box)])
(check-style '(constructor list-box) '(single multiple extended) null style)) (check-list-control-args cwho label choices parent callback)
(check-style cwho '(single multiple extended) null style)
(check-container-ready cwho parent)))
(rename [super-append append]) (rename [super-append append])
(override (override
[append (entry-point-1-2 [append (entry-point-1-2
@ -3273,12 +3299,13 @@
(define text-field% (define text-field%
(class* basic-control% () (label parent callback [init-val ""] [style '(single)]) (class* basic-control% () (label parent callback [init-val ""] [style '(single)])
(sequence (sequence
(let ([cwho '(constructor-name text-field)]) (let ([cwho '(constructor text-field)])
(check-string/false cwho label) (check-string/false cwho label)
(check-container-parent 'text-field parent) (check-container-parent cwho parent)
(check-callback cwho callback) (check-callback cwho callback)
(check-string cwho init-val) (check-string cwho init-val)
(check-style cwho '(single multiple) '(hscroll) style))) (check-style cwho '(single multiple) '(hscroll) style)
(check-container-ready cwho parent)))
(private (private
[wx #f]) [wx #f])
(public (public
@ -3338,8 +3365,10 @@
(class basic-canvas% (parent [style null]) (class basic-canvas% (parent [style null])
(inherit get-client-size) (inherit get-client-size)
(sequence (sequence
(check-container-parent 'canvas parent) (let ([cwho '(constructor canvas)])
(check-style '(constructor canvas) #f '(border hscroll vscroll) style)) (check-container-parent cwho parent)
(check-style cwho #f '(border hscroll vscroll) style)
(check-container-ready cwho parent)))
(public (public
[accept-tab-focus (entry-point-0-1 [accept-tab-focus (entry-point-0-1
(case-lambda (case-lambda
@ -3421,10 +3450,12 @@
(define editor-canvas% (define editor-canvas%
(class basic-canvas% (parent [buffer #f] [style null] [scrolls-per-page 100]) (class basic-canvas% (parent [buffer #f] [style null] [scrolls-per-page 100])
(sequence (sequence
(check-container-parent 'editor-canvas parent) (let ([cwho '(constructor editor-canvas)])
(check-instance '(constructor editor-canvas) internal-editor<%> "text% or pasteboard%" #t buffer) (check-container-parent cwho parent)
(check-style '(constructor editor-canvas) #f '(hide-vscroll hide-hscroll no-vscroll no-hscroll) style) (check-instance cwho internal-editor<%> "text% or pasteboard%" #t buffer)
(check-gauge-integer '(constructor editor-canvas) scrolls-per-page)) (check-style cwho #f '(hide-vscroll hide-hscroll no-vscroll no-hscroll) style)
(check-gauge-integer cwho scrolls-per-page)
(check-container-ready cwho parent)))
(private (private
[force-focus? #f] [force-focus? #f]
[scroll-to-last? #f] [scroll-to-last? #f]
@ -3496,12 +3527,14 @@
(class (make-subarea% (make-container% area%)) (parent) (class (make-subarea% (make-container% area%)) (parent)
(private [wx #f]) (private [wx #f])
(sequence (sequence
(let ([who (cond ; yuck! - we do this to make h-p and v-p subclasses of p (let* ([who (cond ; yuck! - we do this to make h-p and v-p subclasses of p
[(is-a? this vertical-pane%) 'vertical-pane] [(is-a? this vertical-pane%) 'vertical-pane]
[(is-a? this horizontal-pane%) 'horizontal-pane] [(is-a? this horizontal-pane%) 'horizontal-pane]
[(is-a? this grow-box-spacer-pane%) 'grow-box-spacer-pane] [(is-a? this grow-box-spacer-pane%) 'grow-box-spacer-pane]
[else 'pane])]) [else 'pane])]
(check-container-parent who parent) [cwho `(constructor ,who)])
(check-container-parent cwho parent)
(check-container-ready cwho parent)
(as-entry (as-entry
(lambda () (lambda ()
(super-init (lambda () (set! wx (make-object (case who (super-init (lambda () (set! wx (make-object (case who
@ -3522,12 +3555,14 @@
(class* (make-area-container-window% (make-window% #f (make-subarea% (make-container% area%)))) (subwindow<%>) (parent [style null]) (class* (make-area-container-window% (make-window% #f (make-subarea% (make-container% area%)))) (subwindow<%>) (parent [style null])
(private [wx #f]) (private [wx #f])
(sequence (sequence
(let ([who (cond ; yuck! - we do this to make h-p and v-p subclasses of p (let* ([who (cond ; yuck! - we do this to make h-p and v-p subclasses of p
[(is-a? this vertical-panel%) 'vertical-panel] [(is-a? this vertical-panel%) 'vertical-panel]
[(is-a? this horizontal-panel%) 'horizontal-panel] [(is-a? this horizontal-panel%) 'horizontal-panel]
[else 'panel])]) [else 'panel])]
(check-container-parent who parent) [cwho `(constructor ,who)])
(check-style `(constructor ,who) #f '(border) style) (check-container-parent cwho parent)
(check-style cwho #f '(border) style)
(check-container-ready cwho parent)
(as-entry (as-entry
(lambda () (lambda ()
(super-init (lambda () (set! wx (make-object (case who (super-init (lambda () (set! wx (make-object (case who