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

.

Browse Source 
original commit: 669a564cbf8273ff11d16525c7d9f5122e175a43
This commit is contained in:
Matthew Flatt 1998-08-26 16:25:04 +00:00
parent e06d6226eb
commit b62cc903de
1 changed files with 33 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1708,7 +1708,7 @@
(alignment 'left 'top) (alignment 'left 'top)
(unless horiz? (send p alignment 'left 'top)) (unless horiz? (send p alignment 'left 'top))
(unless multi? (stretchable-in-y #f)) (unless multi? (stretchable-in-y #f))
(send e auto-wrap multi?) (send e auto-wrap (and multi? (not (memq 'hscroll style))))
(let ([f (get-control-font)] (let ([f (get-control-font)]
[s (send (send e get-style-list) find-named-style "Standard")]) [s (send (send e get-style-list) find-named-style "Standard")])
(send s set-delta (font->delta f))) (send s set-delta (font->delta f)))
@ -2190,17 +2190,19 @@
(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) (check-string/false '(constructor slider) label)
(check-range-integer '(constructor slider) min-val) (check-slider-integer '(constructor slider) min-val)
(check-range-integer '(constructor slider) max-val) (check-slider-integer '(constructor slider) max-val)
(check-container-parent 'slider parent) (check-container-parent 'slider parent)
(check-callback '(constructor slider) callback) (check-callback '(constructor slider) callback)
(check-range-integer '(constructor slider) value) (check-slider-integer '(constructor slider) value)
(check-orientation 'slider style)) (check-orientation 'slider style))
(private (private
[wx #f]) [wx #f])
(public (public
[get-value (lambda () (send wx get-value))] [get-value (lambda () (send wx get-value))]
[set-value (lambda (v) (send wx set-value v))]) [set-value (lambda (v)
(check-slider-integer '(method slider% set-value) v)
(send wx set-value v))])
(sequence (sequence
(super-init (lambda () (super-init (lambda ()
(set! wx (make-object wx-slider% this this (set! wx (make-object wx-slider% this this
@ -2210,7 +2212,7 @@
label parent #f)))) label parent #f))))
(define gauge% (define gauge%
(class basic-control% (label parent range [style '(horizontal)]) (class basic-control% (label range parent [style '(horizontal)])
(sequence (sequence
(check-string/false '(constructor gauge) label) (check-string/false '(constructor gauge) label)
(check-container-parent 'gauge parent) (check-container-parent 'gauge parent)
@ -2220,7 +2222,13 @@
[wx #f]) [wx #f])
(public (public
[get-value (lambda () (send wx get-value))] [get-value (lambda () (send wx get-value))]
[set-value (lambda (v) (send wx set-value v))]) [set-value (lambda (v)
(check-range-integer '(method gauge% set-value) v)
(send wx set-value v))]
[get-range (lambda () (send wx get-range))]
[set-range (lambda (v)
(check-range-integer '(method gauge% set-range) v)
(send wx set-range v))])
(sequence (sequence
(super-init (lambda () (super-init (lambda ()
(set! wx (make-object wx-gauge% this this (set! wx (make-object wx-gauge% this this
@ -2296,7 +2304,7 @@
[set-string (lambda (n d) (send wx set-string n d))] [set-string (lambda (n d) (send wx set-string n d))]
[set-data (lambda (n d) (send wx set-data n d))] [set-data (lambda (n d) (send wx set-data n d))]
[get-first-visible (lambda () (send wx get-first-item))] [get-first-visible (lambda () (send wx get-first-item))]
[set-first-visible (lambda () (send wx set-first-item))] [set-first-visible (lambda (n) (send wx set-first-item n))]
[select (case-lambda [select (case-lambda
[(n) (send wx set-selection n)] [(n) (send wx set-selection n)]
[(n on?) (send wx set-selection n on?)])]) [(n on?) (send wx set-selection n on?)])])
@ -2379,12 +2387,12 @@
(check-container-parent 'canvas parent) (check-container-parent 'canvas parent)
(check-style '(constructor canvas) #f '(border hscroll vscroll) style)) (check-style '(constructor canvas) #f '(border hscroll vscroll) style))
(public (public
[virtual-size (lambda () (double-boxed [get-virtual-size (lambda () (double-boxed
0 0 0 0
(lambda (x y) (send wx get-virtual-size))))] (lambda (x y) (send wx get-virtual-size x y))))]
[view-start (lambda () (double-boxed [get-view-start (lambda () (double-boxed
0 0 0 0
(lambda (x y) (send wx get-view-start))))] (lambda (x y) (send wx get-view-start x y))))]
[scroll (lambda (x y) (send wx scroll x y))] [scroll (lambda (x y) (send wx scroll x y))]
@ -2392,12 +2400,12 @@
(send wx set-scrollbars (send wx set-scrollbars
h-pixels v-pixels x-len y-len x-page y-page x-val y-val man?))] h-pixels v-pixels x-len y-len x-page y-page x-val y-val man?))]
[get-scroll-pos (lambda () (send wx get-scroll-pos))] [get-scroll-pos (lambda (d) (send wx get-scroll-pos d))]
[set-scroll-pos (lambda (v) (send wx set-scroll-pos v))] [set-scroll-pos (lambda (d v) (send wx set-scroll-pos d v))]
[get-scroll-range (lambda () (send wx get-scroll-range))] [get-scroll-range (lambda (d) (send wx get-scroll-range d))]
[set-scroll-range (lambda (v) (send wx set-scroll-range v))] [set-scroll-range (lambda (d v) (send wx set-scroll-range d v))]
[get-scroll-page (lambda () (send wx get-scroll-page))] [get-scroll-page (lambda (d) (send wx get-scroll-page d))]
[set-scroll-page (lambda (v) (send wx set-scroll-page v))]) [set-scroll-page (lambda (d v) (send wx set-scroll-page d v))])
(private (private
[wx #f]) [wx #f])
(sequence (sequence
@ -2668,7 +2676,7 @@
[get-plain-label (lambda () plain-label)] [get-plain-label (lambda () plain-label)]
[get-help-string (lambda () help-string)] [get-help-string (lambda () help-string)]
[set-help-string (lambda (s) [set-help-string (lambda (s)
(check-string/false '(method labelled-menu-item<%> set-help-string)) (check-string/false '(method labelled-menu-item<%> set-help-string) s)
(set! help-string s) (set! help-string s)
(send wx-parent set-help-string (send wx id) s))] (send wx-parent set-help-string (send wx id) s))]
[enable (lambda (on?) (do-enable on?))] [enable (lambda (on?) (do-enable on?))]
@ -3615,6 +3623,10 @@
(unless (and (number? range) (integer? range) (<= 0 range 10000)) (unless (and (number? range) (integer? range) (<= 0 range 10000))
(raise-type-error (who->name who) "integer in [0, 10000]" range))) (raise-type-error (who->name who) "integer in [0, 10000]" range)))
(define (check-slider-integer who range)
(unless (and (number? range) (integer? range) (<= -10000 range 10000))
(raise-type-error (who->name who) "integer in [-10000, 10000]" range)))
(define (check-dimension who d) (define (check-dimension who d)
(when d (check-range-integer who d))) (when d (check-range-integer who d)))