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

.

Browse Source 
original commit: 47523e73274c0e2f2997e067e34eb3f51e2641d6
This commit is contained in:
Matthew Flatt 1998-10-16 18:19:41 +00:00
parent ec0a6f6593
commit f2c75b22e0
1 changed files with 10 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1620,8 +1620,8 @@
(unless (and (list? children-info) (unless (and (list? children-info)
(andmap (lambda (x) (and (list? x) (andmap (lambda (x) (and (list? x)
(= 4 (length x)) (= 4 (length x))
(number? (car x)) (not (negative? (car x))) (integer? (car x)) (exact? (car x)) (integer? (car x)) (not (negative? (car x))) (exact? (car x))
(number? (cadr x)) (not (negative? (cadr x))) (integer? (cadr x)) (exact? (cadr x)))) (integer? (cadr x)) (not (negative? (cadr x))) (exact? (cadr x))))
children-info)) children-info))
(raise-type-error (who->name '(method area-container-window<%> place-children)) (raise-type-error (who->name '(method area-container-window<%> place-children))
"list of (list of non-negative-integer non-negative-integer boolean boolean)" "list of (list of non-negative-integer non-negative-integer boolean boolean)"
@ -1674,7 +1674,7 @@
(= (length l) (length children-info)) (= (length l) (length children-info))
(andmap (lambda (x) (and (list? x) (andmap (lambda (x) (and (list? x)
(= 4 (length x)) (= 4 (length x))
(andmap (lambda (x) (and (number? x) (integer? x) (exact? x))) x))) (andmap (lambda (x) (and (integer? x) (exact? x))) x)))
l)) l))
(raise-mismatch-error 'container-redraw (raise-mismatch-error 'container-redraw
"result from place-children is not a list of 4-integer lists with the correct length: " "result from place-children is not a list of 4-integer lists with the correct length: "
@ -2263,8 +2263,8 @@
(andmap (andmap
(lambda (l) (lambda (l)
(and (list? l) (= (length l) 4) (and (list? l) (= (length l) 4)
(exact? (car l)) (integer? (car l)) (<= 0 (car l) 10000) (integer? (car l)) (exact? (car l)) (<= 0 (car l) 10000)
(exact? (cadr l)) (integer? (cadr l)) (<= 0 (cadr l) 10000))) (integer? (cadr l)) (exact? (cadr l)) (<= 0 (cadr l) 10000)))
l)) l))
(raise-type-error (who->name '(method area-container<%> container-size)) (raise-type-error (who->name '(method area-container<%> container-size))
"list of lists containing two exact integers in [0, 10000] and two booleans" "list of lists containing two exact integers in [0, 10000] and two booleans"
@ -3887,7 +3887,7 @@
[() (get-color-from-user #f #f #f null)] [() (get-color-from-user #f #f #f null)]
[(message) (get-color-from-user message #f #f null)] [(message) (get-color-from-user message #f #f null)]
[(message parent) (get-color-from-user message parent #f null)] [(message parent) (get-color-from-user message parent #f null)]
[(message parent color) (get-color-from-user message parent #f null)] [(message parent color) (get-color-from-user message parent color null)]
[(message parent color style) [(message parent color style)
(check-string/false 'get-color-from-user message) (check-string/false 'get-color-from-user message)
(check-top-level-parent/false 'get-color-from-user parent) (check-top-level-parent/false 'get-color-from-user parent)
@ -3924,11 +3924,11 @@
[() (get-font-from-user #f #f #f null)] [() (get-font-from-user #f #f #f null)]
[(message) (get-font-from-user message #f #f null)] [(message) (get-font-from-user message #f #f null)]
[(message parent) (get-font-from-user message parent #f null)] [(message parent) (get-font-from-user message parent #f null)]
[(message parent font) (get-font-from-user message parent #f null)] [(message parent font) (get-font-from-user message parent font null)]
[(message parent font style) [(message parent font style)
(check-string/false 'get-font-from-user message) (check-string/false 'get-font-from-user message)
(check-top-level-parent/false 'get-font-from-user parent) (check-top-level-parent/false 'get-font-from-user parent)
(check-instance 'get-color-from-user wx:font% 'font% #t font) (check-instance 'get-font-from-user wx:font% 'font% #t font)
(check-style 'get-font-from-user #f null style) (check-style 'get-font-from-user #f null style)
(letrec ([ok? #f] (letrec ([ok? #f]
[f (make-object dialog% "Choose Font" parent 500 300)] [f (make-object dialog% "Choose Font" parent 500 300)]
@ -4180,7 +4180,7 @@
(define (check-bounded-integer min max) (define (check-bounded-integer min max)
(lambda (who range) (lambda (who range)
(unless (and (number? range) (integer? range) (exact? range) (<= min range max)) (unless (and (integer? range) (exact? range) (<= min range max))
(raise-type-error (who->name who) (raise-type-error (who->name who)
(format "exact integer in [~a, ~a]" min max) (format "exact integer in [~a, ~a]" min max)
range)))) range))))
@ -4194,7 +4194,7 @@
(define check-gauge-integer (check-bounded-integer 1 10000)) (define check-gauge-integer (check-bounded-integer 1 10000))
(define (check-non-negative-integer who i) (define (check-non-negative-integer who i)
(unless (and (number? i) (integer? i) (exact? i) (not (negative? i))) (unless (and (integer? i) (exact? i) (not (negative? i)))
(raise-type-error (who->name who) "non-negative exact integer" i))) (raise-type-error (who->name who) "non-negative exact integer" i)))
(define (check-dimension who d) (define (check-dimension who d)