more error-message conversions and repairs
This commit is contained in:
Matthew Flatt
parent
6eeb8fccbd
commit
a137459b65
|
|
@ -17,7 +17,7 @@
|
|||
|
||||
(define (convert-modes who guards)
|
||||
(unless (list? guards)
|
||||
(raise-type-error who "list of symbols" guards))
|
||||
(raise-argument-error who "(listof symbol?)" guards))
|
||||
(let ([read? 0]
|
||||
[write? 0]
|
||||
[execute? 0]
|
||||
|
|
@ -30,18 +30,19 @@
|
|||
((execute) (set! execute? SCHEME_GUARD_FILE_EXECUTE))
|
||||
((delete) (set! delete? SCHEME_GUARD_FILE_DELETE))
|
||||
((exists) (set! exists? SCHEME_GUARD_FILE_EXISTS))
|
||||
(else (error who "bad permission symbol: ~e" guard))))
|
||||
(else (raise-argument-error who "bad permission symbol" "symbol" guard))))
|
||||
guards)
|
||||
(when (and (positive? exists?)
|
||||
(positive? (+ read? write? execute? delete?)))
|
||||
(error who "permission 'exists must occur alone: ~e" guards))
|
||||
(raise-argument-error who "permission 'exists must occur alone"
|
||||
"permissions" guards))
|
||||
(+ read? write? execute? delete? exists?)))
|
||||
|
||||
(define (security-guard-check-file who path modes)
|
||||
(unless (symbol? who)
|
||||
(raise-type-error 'security-guard-check-file "symbol" 0 who path modes))
|
||||
(raise-argument-error 'security-guard-check-file "symbol?" 0 who path modes))
|
||||
(unless (or (path? path) (path-string? path))
|
||||
(raise-type-error 'security-guard-check-file "path or path string" 1 who path modes))
|
||||
(raise-argument-error 'security-guard-check-file "path-string?" 1 who path modes))
|
||||
(let ([cp (cleanse-path (path->complete-path path))]
|
||||
[mode (convert-modes 'security-guard-check-file modes)])
|
||||
(scheme_security_check_file who cp mode)))
|
||||
|
|
@ -49,7 +50,7 @@
|
|||
(define (_file/guard modes [who '_file/guard])
|
||||
(let ([mode (convert-modes '_file/guard modes)])
|
||||
(unless (symbol? who)
|
||||
(raise-type-error '_file/guard "symbol" who))
|
||||
(raise-argument-error '_file/guard "symbol?" who))
|
||||
(make-ctype
|
||||
_path
|
||||
(lambda (p)
|
||||
|
|
|
|||
|
|
@ -109,7 +109,7 @@
|
|||
(cond
|
||||
[(not name) (ffi-lib name)] ; #f => NULL => open this executable
|
||||
[(not (or (string? name) (path? name)))
|
||||
(raise-type-error 'ffi-lib "library-name" name)]
|
||||
(raise-argument-error 'ffi-lib "(or/c string? path?)" name)]
|
||||
[else
|
||||
;; A possible way that this might be misleading: say that there is a
|
||||
;; "foo.so" file in the current directory, which refers to some
|
||||
|
|
@ -247,7 +247,7 @@
|
|||
(cond [(bytes? objname) objname]
|
||||
[(symbol? objname) (get-ffi-obj-name who (symbol->string objname))]
|
||||
[(string? objname) (string->bytes/utf-8 objname)]
|
||||
[else (raise-type-error who "object-name" objname)]))
|
||||
[else (raise-argument-error who "(or/c bytes? symbol? string?)" objname)]))
|
||||
|
||||
;; This table keeps references to values that are set in foreign libraries, to
|
||||
;; avoid them being GCed. See set-ffi-obj! above.
|
||||
|
|
@ -422,9 +422,9 @@
|
|||
(unless (or (and (procedure? xformer)
|
||||
(procedure-arity-includes? xformer 1))
|
||||
set!-trans?)
|
||||
(raise-type-error 'define-fun-syntax
|
||||
"procedure (arity 1) or set!-transformer"
|
||||
xformer))
|
||||
(raise-argument-error 'define-fun-syntax
|
||||
"(or/c (procedure-arity-includes/c 1) set!-transformer?)"
|
||||
xformer))
|
||||
(let ([f (make-fun-syntax (if set!-trans?
|
||||
(set!-transformer-procedure xformer)
|
||||
xformer)
|
||||
|
|
@ -682,11 +682,11 @@
|
|||
(define (function-ptr p fun-ctype)
|
||||
(if (or (cpointer? p) (procedure? p))
|
||||
(if (eq? (ctype->layout fun-ctype) 'fpointer)
|
||||
(if (procedure? p)
|
||||
((ctype-scheme->c fun-ctype) p)
|
||||
((ctype-c->scheme fun-ctype) p))
|
||||
(raise-type-error 'function-ptr "function ctype" fun-ctype))
|
||||
(raise-type-error 'function-ptr "cpointer" p)))
|
||||
(if (procedure? p)
|
||||
((ctype-scheme->c fun-ctype) p)
|
||||
((ctype-c->scheme fun-ctype) p))
|
||||
(raise-argument-error 'function-ptr "(and ctype? (lambda (ct) (eq? 'fpointer (ctype->layout ct))))" fun-ctype))
|
||||
(raise-argument-error 'function-ptr "(or/c cpointer? procedure?)" p)))
|
||||
|
||||
;; ----------------------------------------------------------------------------
|
||||
;; String types
|
||||
|
|
@ -791,7 +791,8 @@
|
|||
(let ([a (assq x sym->int)])
|
||||
(if a
|
||||
(cdr a)
|
||||
(raise-type-error s->c (format "~a" (or name "enum")) x))))
|
||||
(raise-arguments-error s->c (format "argument does not fit ~a" (or name "enum"))
|
||||
"argument" x))))
|
||||
(lambda (x)
|
||||
(cond [(assq x int->sym) => cdr]
|
||||
[(eq? unknown _enum)
|
||||
|
|
@ -836,8 +837,8 @@
|
|||
(cond [(null? xs) n]
|
||||
[(assq (car xs) symbols->integers) =>
|
||||
(lambda (x) (loop (cdr xs) (bitwise-ior (cadr x) n)))]
|
||||
[else (raise-type-error s->c (format "~a" (or name "bitmask"))
|
||||
symbols)]))))
|
||||
[else (raise-arguments-error s->c (format "argument does not fit ~a" (or name "bitmask"))
|
||||
"argument" symbols)]))))
|
||||
(lambda (n)
|
||||
(if (zero? n) ; probably common
|
||||
'()
|
||||
|
|
@ -1000,7 +1001,7 @@
|
|||
(define len (array-length a))
|
||||
(if (< -1 i len)
|
||||
(ptr-ref (array-ptr a) (array-type a) i)
|
||||
(raise-mismatch-error 'array-ref "index out of bounds: " i))]
|
||||
(raise-range-error 'array-ref "array" "" i a 0 (sub1 len)))]
|
||||
[(a . is)
|
||||
(let loop ([a a] [is is])
|
||||
(if (null? is)
|
||||
|
|
@ -1012,7 +1013,7 @@
|
|||
(define len (array-length a))
|
||||
(if (< -1 i len)
|
||||
(ptr-set! (array-ptr a) (array-type a) i v)
|
||||
(raise-mismatch-error 'array-ref "index out of bounds: " i))]
|
||||
(raise-range-error 'array-set! "array" "" i a 0 (sub1 len)))]
|
||||
[(a i i1 . is+v)
|
||||
(let ([is+v (reverse (list* i i1 is+v))])
|
||||
(define v (car is+v))
|
||||
|
|
@ -1100,9 +1101,9 @@
|
|||
[(tag ptr-type) ((cpointer-maker nullable?) tag ptr-type #f #f)]
|
||||
[(tag ptr-type scheme->c c->scheme)
|
||||
(let* ([tag->C (string->symbol (format "~a->C" tag))]
|
||||
[error-str (format "~a`~a' pointer"
|
||||
[error-str (format "argument is not ~a`~a' pointer"
|
||||
(if nullable? "" "non-null ") tag)]
|
||||
[error* (lambda (p) (raise-type-error tag->C error-str p))])
|
||||
[error* (lambda (p) (raise-arguments-error tag->C error-str "argument" p))])
|
||||
(define-syntax-rule (tag-or-error ptr t)
|
||||
(let ([p ptr])
|
||||
(if (cpointer? p)
|
||||
|
|
@ -1149,15 +1150,15 @@
|
|||
|
||||
(define (cast p from-type to-type)
|
||||
(unless (ctype? from-type)
|
||||
(raise-type-error 'cast "ctype" from-type))
|
||||
(raise-argument-error 'cast "ctype?" from-type))
|
||||
(unless (ctype? to-type)
|
||||
(raise-type-error 'cast "ctype" to-type))
|
||||
(raise-argument-error 'cast "ctype?" to-type))
|
||||
(unless (= (ctype-sizeof to-type)
|
||||
(ctype-sizeof from-type))
|
||||
(raise-mismatch-error 'cast
|
||||
(format "representation sizes of from and to types differ: ~e and "
|
||||
(ctype-sizeof from-type))
|
||||
(ctype-sizeof to-type)))
|
||||
(raise-arguments-error 'cast
|
||||
"representation sizes of from and to types differ"
|
||||
"size of from type" (ctype-sizeof from-type)
|
||||
"size of to size" (ctype-sizeof to-type)))
|
||||
(let ([p2 (malloc from-type)])
|
||||
(ptr-set! p2 from-type p)
|
||||
(ptr-ref p2 to-type)))
|
||||
|
|
@ -1165,7 +1166,7 @@
|
|||
(define* (_or-null ctype)
|
||||
(let ([coretype (ctype-coretype ctype)])
|
||||
(unless (memq coretype '(pointer gcpointer fpointer))
|
||||
(raise-type-error '_or-null "ctype buit on pointer, gcpointer, or fpointer" ctype))
|
||||
(raise-argument-error '_or-null "(and/c ctype? (lambda (ct) (memq (ctype-coretype ct) '(pointer gcpointer fpointer))))" ctype))
|
||||
(make-ctype
|
||||
(case coretype
|
||||
[(pointer) _pointer]
|
||||
|
|
@ -1176,7 +1177,7 @@
|
|||
|
||||
(define* (_gcable ctype)
|
||||
(unless (memq (ctype-coretype ctype) '(pointer gcpointer))
|
||||
(raise-type-error '_or-null "pointer ctype" ctype))
|
||||
(raise-argument-error '_or-null "(and/c ctype? (lambda (ct) (memq (ctype-coretype ct) '(pointer gcpointer))))" ctype))
|
||||
(let loop ([ctype ctype])
|
||||
(if (eq? ctype 'pointer)
|
||||
_gcpointer
|
||||
|
|
@ -1248,8 +1249,13 @@
|
|||
[len (length types)])
|
||||
(make-ctype stype
|
||||
(lambda (vals)
|
||||
(unless (and (list vals) (= len (length vals)))
|
||||
(raise-type-error 'list-struct (format "list of ~a items" len) vals))
|
||||
(unless (list? vals)
|
||||
(raise-argument-error 'list-struct "list?" vals))
|
||||
(unless (= len (length vals))
|
||||
(raise-arguments-error 'list-struct "bad list length"
|
||||
"expected length" len
|
||||
"list length" (length vals)
|
||||
"list" vals))
|
||||
(let ([block (malloc stype)])
|
||||
(for-each (lambda (type ofs val) (ptr-set! block type 'abs ofs val))
|
||||
types offsets vals)
|
||||
|
|
@ -1299,7 +1305,7 @@
|
|||
(and (identifier? x) (identifier? y) (free-identifier=? x y)))
|
||||
(with-syntax
|
||||
([has-super? has-super?]
|
||||
[struct-string (format "struct:~a" name)]
|
||||
[struct-string (format "~a?" name)]
|
||||
[(slot ...) slot-names-stx]
|
||||
[(slot-type ...) slot-types-stx]
|
||||
[TYPE (id name)]
|
||||
|
|
@ -1397,12 +1403,12 @@
|
|||
(values types offsets)))
|
||||
(define (TYPE-SLOT x)
|
||||
(unless (TYPE? x)
|
||||
(raise-type-error 'TYPE-SLOT struct-string x))
|
||||
(raise-argument-error 'TYPE-SLOT struct-string x))
|
||||
(ptr-ref x stype 'abs offset))
|
||||
...
|
||||
(define (set-TYPE-SLOT! x slot)
|
||||
(unless (TYPE? x)
|
||||
(raise-type-error 'set-TYPE-SLOT! struct-string 0 x slot))
|
||||
(raise-argument-error 'set-TYPE-SLOT! struct-string 0 x slot))
|
||||
(ptr-set! x stype 'abs offset slot))
|
||||
...
|
||||
(define make-TYPE
|
||||
|
|
@ -1448,12 +1454,12 @@
|
|||
(length all-types) (length vals) vals)]))
|
||||
(define (TYPE->list x)
|
||||
(unless (TYPE? x)
|
||||
(raise-type-error 'TYPE-list struct-string x))
|
||||
(raise-argument-error 'TYPE-list struct-string x))
|
||||
(map (lambda (type ofs) (ptr-ref x type 'abs ofs))
|
||||
all-types all-offsets))
|
||||
(define (TYPE->list* x)
|
||||
(unless (TYPE? x)
|
||||
(raise-type-error 'TYPE-list struct-string x))
|
||||
(raise-argument-error 'TYPE-list struct-string x))
|
||||
(map (lambda (type ofs)
|
||||
(let-values
|
||||
([(v) (ptr-ref x type 'abs ofs)]
|
||||
|
|
|
|||
|
|
@ -236,7 +236,7 @@
|
|||
|
||||
(define (namespace-defined? n)
|
||||
(unless (symbol? n)
|
||||
(raise-type-error 'namespace-defined? "symbol" n))
|
||||
(raise-argument-error 'namespace-defined? "symbol?" n))
|
||||
(not (eq? (namespace-variable-value n #t (lambda () ns-undefined))
|
||||
ns-undefined)))
|
||||
|
||||
|
|
|
|||
|
|
@ -19,9 +19,9 @@
|
|||
(lambda (s info)
|
||||
(if (symbol? s)
|
||||
(void)
|
||||
(raise-type-error '|prop:print-convert-constructor-name guard|
|
||||
"symbol"
|
||||
s))
|
||||
(raise-argument-error '|prop:print-convert-constructor-name guard|
|
||||
"symbol?"
|
||||
s))
|
||||
s)))
|
||||
|
||||
(define-values (prop:print-converter
|
||||
|
|
@ -33,7 +33,7 @@
|
|||
(procedure-arity-includes? p 2)
|
||||
#f)
|
||||
(void)
|
||||
(raise-type-error '|prop:print-converter|
|
||||
"procedure (arity 2)"
|
||||
p))
|
||||
(raise-argument-error '|prop:print-converter|
|
||||
"(procedure-arity-includes/c 2)"
|
||||
p))
|
||||
p))))
|
||||
|
|
|
|||
|
|
@ -65,19 +65,19 @@
|
|||
(make-parameter (let ([original-build-share-name-hook (lambda (e) #f)]) original-build-share-name-hook)
|
||||
(lambda (f)
|
||||
(unless (procedure-arity-includes? f 1)
|
||||
(raise-type-error 'current-build-share-name-hook "procedure of arity 1" f))
|
||||
(raise-argument-error 'current-build-share-name-hook "(procedure-arity-includes/c 1)" f))
|
||||
f)))
|
||||
(define current-build-share-hook
|
||||
(make-parameter (lambda (e base sub) (base e))
|
||||
(lambda (f)
|
||||
(unless (procedure-arity-includes? f 3)
|
||||
(raise-type-error 'current-build-share-hook "procedure of arity 3" f))
|
||||
(raise-argument-error 'current-build-share-hook "(procedure-arity-includes/c 3)" f))
|
||||
f)))
|
||||
(define current-print-convert-hook
|
||||
(make-parameter (lambda (e base sub) (base e))
|
||||
(lambda (f)
|
||||
(unless (procedure-arity-includes? f 3)
|
||||
(raise-type-error 'current--hook "procedure of arity 3" f))
|
||||
(raise-argument-error 'current--hook "(procedure-arity-includes/c 3)" f))
|
||||
f)))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
|
|||
|
|
@ -34,12 +34,12 @@
|
|||
[(a b) (merge-input a b 4096)]
|
||||
[(a b limit)
|
||||
(or (input-port? a)
|
||||
(raise-type-error 'merge-input "input-port" a))
|
||||
(raise-argument-error 'merge-input "input-port?" a))
|
||||
(or (input-port? b)
|
||||
(raise-type-error 'merge-input "input-port" b))
|
||||
(raise-argument-error 'merge-input "input-port?" b))
|
||||
(or (not limit)
|
||||
(and (number? limit) (positive? limit) (exact? limit) (integer? limit))
|
||||
(raise-type-error 'merge-input "positive exact integer or #f" limit))
|
||||
(raise-argument-error 'merge-input "(or/c exact-positive-integer #f)" limit))
|
||||
(let-values ([(rd wt) (make-pipe-with-specials limit)]
|
||||
[(other-done?) #f]
|
||||
[(sema) (make-semaphore 1)])
|
||||
|
|
@ -898,10 +898,10 @@
|
|||
(define special-filter-input-port
|
||||
(lambda (p filter [close? #t])
|
||||
(unless (input-port? p)
|
||||
(raise-type-error 'special-filter-input-port "input port" p))
|
||||
(raise-argument-error 'special-filter-input-port "input-port?" p))
|
||||
(unless (and (procedure? filter)
|
||||
(procedure-arity-includes? filter 2))
|
||||
(raise-type-error 'special-filter-input-port "procedure (arity 2)" filter))
|
||||
(raise-argument-error 'special-filter-input-port "(any/c bytes? . -> . any/c)" filter))
|
||||
(make-input-port
|
||||
(object-name p)
|
||||
(lambda (s)
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@
|
|||
[(string? pattern) (pregexp pattern)]
|
||||
[(regexp? pattern) pattern]
|
||||
[(byte-regexp? pattern) pattern]
|
||||
[else (raise-type-error who "regexp, byte-regexp, string, or byte string"
|
||||
[else (raise-argument-error who "(or/c regexp? byte-regexp? string? bytes?)"
|
||||
pattern)]))
|
||||
|
||||
(define/kw (pregexp-match pattern input #:optional [start-k 0] [end-k #f] [output-port #f])
|
||||
|
|
|
|||
|
|
@ -35,7 +35,7 @@
|
|||
|
||||
(define (check-exe who exe)
|
||||
(unless (path-string? exe)
|
||||
(raise-type-error who "path or string" exe))
|
||||
(raise-argument-error who "path-string?" exe))
|
||||
exe)
|
||||
|
||||
(define (path-or-ok-string? s)
|
||||
|
|
@ -75,14 +75,21 @@
|
|||
(for ([s (in-list args)])
|
||||
(unless (or (path-or-ok-string? s)
|
||||
(bytes-no-nuls? s))
|
||||
(raise-type-error who "path, string, or byte string (without nuls)"
|
||||
s)))])
|
||||
(raise-argument-error
|
||||
who
|
||||
(string-append "(or/c path-string?\n"
|
||||
" (and/c bytes? (lambda (bs) (not (memv 0 (bytes->list bs))))))")
|
||||
s)))])
|
||||
args)
|
||||
|
||||
(define (check-command who str)
|
||||
(unless (or (string-no-nuls? str)
|
||||
(bytes-no-nuls? str))
|
||||
(raise-type-error who "string or byte string (without nuls)" str)))
|
||||
(raise-argument-error
|
||||
who
|
||||
(string-append "(or/c (and/c string? (lambda (s) (not (memv #\\nul (string->list s)))))\n"
|
||||
" (and/c bytes? (lambda (bs) (not (memv 0 (bytes->list bs))))))")
|
||||
str)))
|
||||
|
||||
;; Old-style functions: ----------------------------------------
|
||||
|
||||
|
|
@ -131,9 +138,9 @@
|
|||
(twait se))]
|
||||
[(interrupt) (subprocess-kill subp #f)]
|
||||
[(kill) (subprocess-kill subp #t)]
|
||||
[else (raise-type-error
|
||||
[else (raise-argument-error
|
||||
'control-process
|
||||
"'status, 'exit-code, 'wait, 'interrupt, or 'kill" m)]))
|
||||
"(or/c 'status 'exit-code 'wait 'interrupt 'kill)" m)]))
|
||||
(list (aport so)
|
||||
(aport si)
|
||||
(subprocess-pid subp)
|
||||
|
|
|
|||
|
|
@ -352,9 +352,9 @@
|
|||
TLSv1_server_method)]
|
||||
[else (escape-atomic
|
||||
(lambda ()
|
||||
(raise-type-error
|
||||
(raise-argument-error
|
||||
who
|
||||
(string-append also-expect "'sslv2-or-v3, 'sslv2, 'sslv3, or 'tls")
|
||||
(format "(or/c ~a'sslv2-or-v3 'sslv2 'sslv3 'tls)" also-expect)
|
||||
e)))])))
|
||||
|
||||
(define (make-context who protocol-symbol also-expected client?)
|
||||
|
|
@ -376,7 +376,7 @@
|
|||
(define (get-context who context-or-encrypt-method client?)
|
||||
(if (ssl-context? context-or-encrypt-method)
|
||||
(ssl-context-ctx context-or-encrypt-method)
|
||||
(let ([ctx (SSL_CTX_new (encrypt->method who "context" context-or-encrypt-method client?))])
|
||||
(let ([ctx (SSL_CTX_new (encrypt->method who "ssl-context? " context-or-encrypt-method client?))])
|
||||
(SSL_CTX_set_mode ctx SSL_MODE_ENABLE_PARTIAL_WRITE)
|
||||
ctx)))
|
||||
|
||||
|
|
@ -388,18 +388,18 @@
|
|||
(ssl-context-ctx (ssl-listener-mzctx ssl-context-or-listener))]
|
||||
[else
|
||||
(if fail?
|
||||
(raise-type-error who
|
||||
"SSL context or listener"
|
||||
ssl-context-or-listener)
|
||||
(raise-argument-error who
|
||||
"(or/c ssl-context? ssl-listener?)"
|
||||
ssl-context-or-listener)
|
||||
#f)]))
|
||||
|
||||
(define (ssl-load-... who load-it ssl-context-or-listener pathname)
|
||||
(let ([ctx (get-context/listener 'ssl-load-certificate-chain!
|
||||
ssl-context-or-listener)])
|
||||
(unless (path-string? pathname)
|
||||
(raise-type-error 'ssl-load-certificate-chain!
|
||||
"path or string"
|
||||
pathname))
|
||||
(raise-argument-error 'ssl-load-certificate-chain!
|
||||
"path-string?"
|
||||
pathname))
|
||||
(let ([path (path->bytes
|
||||
(path->complete-path (cleanse-path pathname)
|
||||
(current-directory)))])
|
||||
|
|
@ -470,7 +470,7 @@
|
|||
SSL_VERIFY_NONE)
|
||||
#f))]
|
||||
[else
|
||||
(let-values ([(mzssl input?) (lookup who "SSL context, listener, or port"
|
||||
(let-values ([(mzssl input?) (lookup who "(or/c ssl-context? ssl-listener? ssl-port?)"
|
||||
ssl-context-or-listener-or-port)])
|
||||
(SSL_set_verify (mzssl-ssl mzssl)
|
||||
(if on?
|
||||
|
|
@ -954,8 +954,8 @@
|
|||
[else
|
||||
(escape-atomic
|
||||
(lambda ()
|
||||
(raise-type-error who "'connect or 'accept"
|
||||
connect/accept)))])]
|
||||
(raise-argument-error who "(or/c 'connect 'accept)"
|
||||
connect/accept)))])]
|
||||
[r-bio (BIO_new (BIO_s_mem))]
|
||||
[w-bio (BIO_new (BIO_s_mem))]
|
||||
[free-bio? #t])
|
||||
|
|
@ -997,9 +997,9 @@
|
|||
|
||||
(define (wrap-ports who i o context-or-encrypt-method connect/accept close? shutdown-on-close? error/ssl)
|
||||
(unless (input-port? i)
|
||||
(raise-type-error who "input port" i))
|
||||
(raise-argument-error who "input-port?" i))
|
||||
(unless (output-port? o)
|
||||
(raise-type-error who "output port" o))
|
||||
(raise-argument-error who "output-port?" o))
|
||||
;; Create the SSL connection:
|
||||
(let-values ([(ssl cancel r-bio w-bio connect?)
|
||||
(create-ssl who context-or-encrypt-method connect/accept error/ssl)])
|
||||
|
|
@ -1052,31 +1052,31 @@
|
|||
(define (lookup who what port)
|
||||
(let ([v (hash-ref ssl-ports port #f)])
|
||||
(unless v
|
||||
(raise-type-error who what port))
|
||||
(raise-argument-error who what port))
|
||||
(let ([p (ephemeron-value v)])
|
||||
(values (car p) (cdr p)))))
|
||||
|
||||
(define (ssl-addresses p [port-numbers? #f])
|
||||
(let-values ([(mzssl input?) (lookup 'ssl-addresses "SSL port or listener" p)])
|
||||
(let-values ([(mzssl input?) (lookup 'ssl-addresses "(or/c ssl-port? ssl-listener?)" p)])
|
||||
(tcp-addresses (if (eq? 'listener input?)
|
||||
(ssl-listener-l mzssl)
|
||||
(if input? (mzssl-i mzssl) (mzssl-o mzssl)))
|
||||
port-numbers?)))
|
||||
|
||||
(define (ssl-abandon-port p)
|
||||
(let-values ([(mzssl input?) (lookup 'ssl-abandon-port "SSL output port" p)])
|
||||
(let-values ([(mzssl input?) (lookup 'ssl-abandon-port "(and/c ssl-port? output-port?)" p)])
|
||||
(when input?
|
||||
(raise-type-error 'ssl-abandon-port "SSL output port" p))
|
||||
(raise-argument-error 'ssl-abandon-port "(and/c ssl-port? output-port?)" p))
|
||||
(set-mzssl-shutdown-on-close?! mzssl #f)))
|
||||
|
||||
(define (ssl-peer-verified? p)
|
||||
(let-values ([(mzssl input?) (lookup 'ssl-peer-verified? "SSL port" p)])
|
||||
(let-values ([(mzssl input?) (lookup 'ssl-peer-verified? "ssl-port?" p)])
|
||||
(and (eq? X509_V_OK (SSL_get_verify_result (mzssl-ssl mzssl)))
|
||||
(SSL_get_peer_certificate (mzssl-ssl mzssl))
|
||||
#t)))
|
||||
|
||||
(define (ssl-peer-subject-name p)
|
||||
(let-values ([(mzssl input?) (lookup 'ssl-peer-subject-name "SSL port" p)])
|
||||
(let-values ([(mzssl input?) (lookup 'ssl-peer-subject-name "ssl-port?" p)])
|
||||
(let ([cert (SSL_get_peer_certificate (mzssl-ssl mzssl))])
|
||||
(if cert
|
||||
(let ([bytes (make-bytes 1024 0)])
|
||||
|
|
@ -1084,7 +1084,7 @@
|
|||
#f))))
|
||||
|
||||
(define (ssl-peer-issuer-name p)
|
||||
(let-values ([(mzssl input?) (lookup 'ssl-peer-subject-name "SSL port" p)])
|
||||
(let-values ([(mzssl input?) (lookup 'ssl-peer-subject-name "ssl-port?" p)])
|
||||
(let ([cert (SSL_get_peer_certificate (mzssl-ssl mzssl))])
|
||||
(if cert
|
||||
(let ([bytes (make-bytes 1024 0)])
|
||||
|
|
@ -1110,7 +1110,7 @@
|
|||
|
||||
(define (ssl-close l)
|
||||
(unless (ssl-listener? l)
|
||||
(raise-type-error 'ssl-close "SSL listener" l))
|
||||
(raise-argument-error 'ssl-close "ssl-listener?" l))
|
||||
(tcp-close (ssl-listener-l l)))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
|
|||
|
|
@ -294,9 +294,9 @@
|
|||
longest-match-length)))))))))))))
|
||||
(lambda (ip)
|
||||
(unless (input-port? ip)
|
||||
(raise-type-error
|
||||
(raise-argument-error
|
||||
'lexer
|
||||
"input-port"
|
||||
"input-port?"
|
||||
0
|
||||
ip))
|
||||
(lexer ip))))
|
||||
|
|
|
|||
|
|
@ -224,10 +224,10 @@
|
|||
(values tok #f v1 v2))
|
||||
((token? tok)
|
||||
(values (real-token-name tok) (real-token-value tok) v1 v2))
|
||||
(else (raise-type-error 'parser
|
||||
"symbol or struct:token"
|
||||
0
|
||||
tok))))
|
||||
(else (raise-argument-error 'parser
|
||||
"(or/c symbol? token?)"
|
||||
0
|
||||
tok))))
|
||||
|
||||
;; extract-src-pos : position-token -> symbol any any any
|
||||
(define (extract-src-pos ip)
|
||||
|
|
@ -237,10 +237,10 @@
|
|||
(position-token-start-pos ip)
|
||||
(position-token-end-pos ip)))
|
||||
(else
|
||||
(raise-type-error 'parser
|
||||
"struct:position-token"
|
||||
0
|
||||
ip))))
|
||||
(raise-argument-error 'parser
|
||||
"position-token?"
|
||||
0
|
||||
ip))))
|
||||
|
||||
;; extract-no-src-pos : (symbol or make-token) -> symbol any any any
|
||||
(define (extract-no-src-pos ip)
|
||||
|
|
|
|||
|
|
@ -4277,10 +4277,11 @@ An example
|
|||
#:intf-name (interface-name intf)))
|
||||
(lambda (obj)
|
||||
(unless (is-a? obj intf)
|
||||
(raise-type-error
|
||||
(string->symbol (format "generic:~a~a" name (for-intf (interface-name intf))))
|
||||
(format "instance~a" (for-intf (interface-name intf)))
|
||||
obj))
|
||||
(obj-error
|
||||
(string->symbol (format "generic:~a" name))
|
||||
"target is not an instance of the generic's interface"
|
||||
"target" obj
|
||||
#:intf-name (interface-name intf)))
|
||||
(find-method/who 'make-generic obj name)))
|
||||
(let* ([pos (hash-ref (class-method-ht class) name
|
||||
(lambda ()
|
||||
|
|
@ -4291,10 +4292,11 @@ An example
|
|||
[dynamic-generic
|
||||
(lambda (obj)
|
||||
(unless (instance? obj)
|
||||
(raise-type-error
|
||||
(string->symbol (format "generic:~a~a" name (for-class (class-name class))))
|
||||
(format "instance~a" (for-class (class-name class)))
|
||||
obj))
|
||||
(obj-error
|
||||
(string->symbol (format "generic:~a" name))
|
||||
"target is not an instance of the generic's class"
|
||||
"target" obj
|
||||
#:class-name (class-name class)))
|
||||
(vector-ref (class-methods (object-ref obj)) pos))])
|
||||
(if (eq? 'final (vector-ref (class-meth-flags class) pos))
|
||||
(let ([method (vector-ref (class-methods class) pos)])
|
||||
|
|
|
|||
|
|
@ -111,12 +111,12 @@
|
|||
[(hash? d) (hash-set! d key val)]
|
||||
[(vector? d) (vector-set! d key val)]
|
||||
[(assoc? d)
|
||||
(raise-type-error 'dict-set! "mutable-dict?" 0 d key val)]
|
||||
(raise-argument-error 'dict-set! "mutable-dict?" 0 d key val)]
|
||||
[(dict? d)
|
||||
(let ([s! (hash-ref (dict-def-table d) 'dict-set! #f)])
|
||||
(if s!
|
||||
(dict-set! d key val)
|
||||
(raise-type-error 'dict-set! "mutable-dict?" 0 d key val)))]
|
||||
(raise-argument-error 'dict-set! "mutable-dict?" 0 d key val)))]
|
||||
[else
|
||||
(raise-argument-error 'dict-set! "dict?" 0 d key val)]))
|
||||
|
||||
|
|
@ -146,7 +146,7 @@
|
|||
(let ([s (hash-ref (dict-def-table d) 'dict-set #f)])
|
||||
(if s
|
||||
(dict-set d key val)
|
||||
(raise-type-error 'dict-set "functional-update-dict?" 0 d key val)))]
|
||||
(raise-argument-error 'dict-set "functional-update-dict?" 0 d key val)))]
|
||||
[else
|
||||
(raise-argument-error 'dict-set "dict?" 0 d key val)]))
|
||||
|
||||
|
|
@ -180,12 +180,12 @@
|
|||
[(vector? d)
|
||||
(raise-argument-error 'dict-remove! "dict-with-removeable-keys?" 0 d key)]
|
||||
[(assoc? d)
|
||||
(raise-type-error 'dict-remove! "mutable-dict?" 0 d key)]
|
||||
(raise-argument-error 'dict-remove! "mutable-dict?" 0 d key)]
|
||||
[(dict? d)
|
||||
(let ([r! (hash-ref (dict-def-table d) 'dict-remove! #f)])
|
||||
(if r!
|
||||
(dict-remove! d key)
|
||||
(raise-type-error 'dict-remove! "mutable-dict-with-removable-keys?" 0 d key)))]
|
||||
(raise-argument-error 'dict-remove! "mutable-dict-with-removable-keys?" 0 d key)))]
|
||||
[else
|
||||
(raise-argument-error 'dict-remove! "dict?" 0 d key)]))
|
||||
|
||||
|
|
@ -207,7 +207,7 @@
|
|||
(let ([s (hash-ref (dict-def-table d) 'dict-remove #f)])
|
||||
(if s
|
||||
(dict-remove d key)
|
||||
(raise-type-error 'dict-remove "dict-with-functionally-removeable-keys?" 0 d key)))]
|
||||
(raise-argument-error 'dict-remove "dict-with-functionally-removeable-keys?" 0 d key)))]
|
||||
[else
|
||||
(raise-argument-error 'dict-remove "dict?" 0 d key)]))
|
||||
|
||||
|
|
|
|||
|
|
@ -23,9 +23,12 @@
|
|||
(procedure? (vector-ref v 2))
|
||||
(procedure-arity-includes? (vector-ref v 2) 2))
|
||||
v
|
||||
(raise-type-error 'guard-for-prop:gen:equal+hash
|
||||
"vector of three procedures (arities 3, 2, 2)"
|
||||
v)))
|
||||
(raise-argument-error 'guard-for-prop:gen:equal+hash
|
||||
(string-append
|
||||
"(vector/c (procedure-arity-includes/c 3)\n"
|
||||
" (procedure-arity-includes/c 2)\n"
|
||||
" (procedure-arity-includes/c 2))")
|
||||
v)))
|
||||
(list (cons prop:equal+hash vector->list))))
|
||||
|
||||
(define-syntax gen:equal+hash
|
||||
|
|
@ -44,9 +47,9 @@
|
|||
(procedure? (vector-ref v 0))
|
||||
(procedure-arity-includes? (vector-ref v 0) 3))
|
||||
v
|
||||
(raise-type-error 'guard-for-prop:gen:custom-write
|
||||
"vector of one procedure (arity 3)"
|
||||
v)))
|
||||
(raise-argument-error 'guard-for-prop:gen:custom-write
|
||||
"(vector/c (procedure-arity-includes/c 3))"
|
||||
v)))
|
||||
(list (cons prop:custom-write (lambda (v) (vector-ref v 0))))))
|
||||
|
||||
(define-syntax gen:custom-write
|
||||
|
|
|
|||
|
|
@ -35,7 +35,7 @@
|
|||
(let* ([idxs (for/list ([i (in-naturals 0)]
|
||||
[_ (syntax->list #'(generic ...))])
|
||||
i)]
|
||||
[name-str (symbol->string (syntax-e #'name))]
|
||||
[name-str (symbol->string (syntax-e #'name?))]
|
||||
[generics (syntax->list #'(generic ...))]
|
||||
[prop-defined-already? (syntax-e #'defined-already?)])
|
||||
(with-syntax ([name-str name-str]
|
||||
|
|
@ -131,7 +131,7 @@
|
|||
;; whether the given method is implemented
|
||||
(define (defined-table this)
|
||||
(unless (name? this)
|
||||
(raise-type-error 'defined-table name-str this))
|
||||
(raise-argument-error 'defined-table name-str this))
|
||||
(for/hash ([name (in-list '(#,@(map syntax->datum generics)))]
|
||||
[gen (in-vector (get-generics this))])
|
||||
(values name (not (not gen)))))
|
||||
|
|
@ -145,7 +145,7 @@
|
|||
(if m
|
||||
(keyword-apply m kws kws-args given-args)
|
||||
(error 'generic "not implemented for ~e" this)))
|
||||
(raise-type-error 'generic name-str this)))
|
||||
(raise-argument-error 'generic name-str this)))
|
||||
; XXX (non-this ... this . rst)
|
||||
(lambda given-args
|
||||
(define this (list-ref given-args generic-this-idx))
|
||||
|
|
@ -154,5 +154,5 @@
|
|||
(if m
|
||||
(apply m given-args)
|
||||
(error 'generic "not implemented for ~e" this)))
|
||||
(raise-type-error 'generic name-str this))))))
|
||||
(raise-argument-error 'generic name-str this))))))
|
||||
...)))]))
|
||||
|
|
|
|||
|
|
@ -228,12 +228,13 @@
|
|||
(unless (list? kw-vals)
|
||||
(type-error "list?" 2))
|
||||
(unless (= (length kws) (length kw-vals))
|
||||
(raise-mismatch-error
|
||||
(raise-arguments-error
|
||||
'keyword-apply
|
||||
(format
|
||||
"keyword list: ~e; does not match the length of the value list: "
|
||||
kws)
|
||||
kw-vals))
|
||||
"keyword list length does not match value list length"
|
||||
"keyword list length" (length kws)
|
||||
"value list length" (length kw-vals)
|
||||
"keyword list" kws
|
||||
"value list" kw-vals))
|
||||
|
||||
(let ([normal-args
|
||||
(let loop ([normal-argss (cons normal-args normal-argss)][pos 3])
|
||||
|
|
@ -1338,9 +1339,10 @@
|
|||
(raise-argument-error 'procedure-reduce-keyword-arity "(or/c (and/c (listof? keyword?) sorted? distinct?) #f)"
|
||||
3 proc arity req-kw allowed-kw))
|
||||
(unless (subset? req-kw allowed-kw)
|
||||
(raise-mismatch-error 'procedure-reduce-keyword-arity
|
||||
"allowed-keyword list does not include all required keywords: "
|
||||
allowed-kw)))
|
||||
(raise-arguments-error 'procedure-reduce-keyword-arity
|
||||
"allowed-keyword list does not include all required keywords"
|
||||
"allowed-keyword list" allowed-kw
|
||||
"required keywords" req-kw)))
|
||||
(let ([old-req (if (keyword-procedure? proc)
|
||||
(keyword-procedure-required proc)
|
||||
null)]
|
||||
|
|
@ -1348,19 +1350,22 @@
|
|||
(keyword-procedure-allowed proc)
|
||||
null)])
|
||||
(unless (subset? old-req req-kw)
|
||||
(raise-mismatch-error 'procedure-reduce-keyword-arity
|
||||
"cannot reduce required keyword set: "
|
||||
old-req))
|
||||
(raise-arguments-error 'procedure-reduce-keyword-arity
|
||||
"cannot reduce required keyword set"
|
||||
"required keywords" old-req
|
||||
"requested required keywords" req-kw))
|
||||
(when old-allowed
|
||||
(unless (subset? req-kw old-allowed)
|
||||
(raise-mismatch-error 'procedure-reduce-keyword-arity
|
||||
"cannot require keywords not in original allowed set: "
|
||||
old-allowed))
|
||||
(raise-arguments-error 'procedure-reduce-keyword-arity
|
||||
"cannot require keywords not in original allowed set"
|
||||
"original allowed keywords" old-allowed
|
||||
"requested required keywords" req-kw))
|
||||
(unless (or (not allowed-kw)
|
||||
(subset? allowed-kw old-allowed))
|
||||
(raise-mismatch-error 'procedure-reduce-keyword-arity
|
||||
"cannot allow keywords not in original allowed set: "
|
||||
old-allowed))))
|
||||
(raise-arguments-error 'procedure-reduce-keyword-arity
|
||||
"cannot allow keywords not in original allowed set"
|
||||
"original allowed keywords" old-allowed
|
||||
"requested allowed keywords" allowed-kw))))
|
||||
(if (null? allowed-kw)
|
||||
plain-proc
|
||||
(let* ([inc-arity (lambda (arity delta)
|
||||
|
|
@ -1408,9 +1413,9 @@
|
|||
(keyword-procedure? proc)
|
||||
(not (okp? proc))
|
||||
(not (null? arity)))
|
||||
(raise-mismatch-error 'procedure-reduce-arity
|
||||
"procedure has required keyword arguments: "
|
||||
proc)
|
||||
(raise-arguments-error 'procedure-reduce-arity
|
||||
"procedure has required keyword arguments"
|
||||
"procedure" proc)
|
||||
(procedure-reduce-arity proc arity)))])
|
||||
procedure-reduce-arity))
|
||||
|
||||
|
|
@ -1517,21 +1522,19 @@
|
|||
;; Let core report error:
|
||||
(apply chaperone-procedure proc wrap-proc props))
|
||||
(unless (subset? b-req a-req)
|
||||
(raise-mismatch-error
|
||||
(raise-arguments-error
|
||||
name
|
||||
(format
|
||||
"~a procedure requires more keywords than original procedure: "
|
||||
(if is-impersonator? "impersonating" "chaperoning"))
|
||||
proc))
|
||||
"wrapper procedure requires more keywords than original procedure"
|
||||
"wrapper procedure" wrap-proc
|
||||
"original procedure" proc))
|
||||
(unless (or (not b-allow)
|
||||
(and a-allow
|
||||
(subset? a-allow b-allow)))
|
||||
(raise-mismatch-error
|
||||
(raise-arguments-error
|
||||
name
|
||||
(format
|
||||
"~a procedure does not accept all keywords of original procedure: "
|
||||
(if is-impersonator? "impersonating" "chaperoning"))
|
||||
proc))
|
||||
"wrapper procedure does not accept all keywords of original procedure"
|
||||
"wrapper procedure" wrap-proc
|
||||
"original procedure" proc))
|
||||
(let* ([kw-chaperone
|
||||
(let ([p (keyword-procedure-proc wrap-proc)])
|
||||
(case-lambda
|
||||
|
|
@ -1541,36 +1544,37 @@
|
|||
(let ([len (length results)]
|
||||
[alen (length rest)])
|
||||
(unless (<= (+ alen 1) len (+ alen 2))
|
||||
(raise-mismatch-error
|
||||
(raise-arguments-error
|
||||
'|keyword procedure chaperone|
|
||||
(format
|
||||
"expected ~a or ~a results, received ~a results from chaperoning procedure: "
|
||||
(+ alen 1)
|
||||
(+ alen 2)
|
||||
len)
|
||||
wrap-proc))
|
||||
"wrong number of results from wrapper procedure"
|
||||
"expected minimum number of results" (+ alen 1)
|
||||
"expected maximum number of results" (+ alen 2)
|
||||
"received number of results" len
|
||||
"wrapper procedure" wrap-proc))
|
||||
(let ([extra? (= len (+ alen 2))])
|
||||
(let ([new-args ((if extra? cadr car) results)])
|
||||
(unless (and (list? new-args)
|
||||
(= (length new-args) (length args)))
|
||||
(raise-mismatch-error
|
||||
(raise-arguments-error
|
||||
'|keyword procedure chaperone|
|
||||
(format
|
||||
"expected a list of keyword-argument values as first result~a from chaperoning procedure: "
|
||||
"expected a list of keyword-argument values as first result~a from wrapper procedure"
|
||||
(if (= len alen)
|
||||
""
|
||||
" (after the result chaperoning procedure)"))
|
||||
wrap-proc))
|
||||
" (after the result-wrapper procedure)"))
|
||||
"first result" new-args
|
||||
"wrapper procedure" wrap-proc))
|
||||
(for-each
|
||||
(lambda (kw new-arg arg)
|
||||
(unless is-impersonator?
|
||||
(unless (chaperone-of? new-arg arg)
|
||||
(raise-mismatch-error
|
||||
(raise-arguments-error
|
||||
'|keyword procedure chaperone|
|
||||
(format
|
||||
"~a keyword result is not a chaperone of original argument from chaperoning procedure: "
|
||||
"~a keyword result is not a chaperone of original argument from chaperoning procedure"
|
||||
kw)
|
||||
wrap-proc))))
|
||||
"result" new-arg
|
||||
"wrapper procedure" wrap-proc))))
|
||||
kws
|
||||
new-args
|
||||
args))
|
||||
|
|
|
|||
|
|
@ -60,7 +60,7 @@
|
|||
[(string? s) (make-style s null)]
|
||||
[(symbol? s) (make-style #f (list s))]
|
||||
[(and (list? s) (andmap symbol? s)) (make-style #f s)]
|
||||
[else (raise-type-error who "style, string, symbol, list of symbols, or #f" s)]))
|
||||
[else (raise-argument-error who "(or/c style? string? symbol? (listof symbol?) #f)" s)]))
|
||||
|
||||
(define (title #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style plain]
|
||||
#:version [version #f] #:date [date #f]
|
||||
|
|
|
|||
|
|
@ -178,19 +178,19 @@
|
|||
(define (make-eval-results contents out err)
|
||||
(unless (and (list? contents)
|
||||
(andmap content? contents))
|
||||
(raise-type-error 'eval:results "list of content" contents))
|
||||
(raise-argument-error 'eval:results "(listof content?)" contents))
|
||||
(unless (string? out)
|
||||
(raise-type-error 'eval:results "string" out))
|
||||
(raise-argument-error 'eval:results "string?" out))
|
||||
(unless (string? err)
|
||||
(raise-type-error 'eval:results "string" err))
|
||||
(raise-argument-error 'eval:results "string?" err))
|
||||
(eval-results contents out err))
|
||||
(define (make-eval-result content out err)
|
||||
(unless (content? content)
|
||||
(raise-type-error 'eval:result "content" content))
|
||||
(raise-argument-error 'eval:result "content?" content))
|
||||
(unless (string? out)
|
||||
(raise-type-error 'eval:result "string" out))
|
||||
(raise-argument-error 'eval:result "string?" out))
|
||||
(unless (string? err)
|
||||
(raise-type-error 'eval:result "string" err))
|
||||
(raise-argument-error 'eval:result "string?" err))
|
||||
(eval-results (list content) out err))
|
||||
|
||||
(define (extract-to-evaluate s)
|
||||
|
|
|
|||
|
|
@ -106,12 +106,16 @@
|
|||
[(module-path? src)
|
||||
(loop (module-path-index-join src #f))]
|
||||
[else
|
||||
(raise-type-error 'xref-binding-definition->tag
|
||||
"list starting with module path or module path index"
|
||||
src)]))]
|
||||
[else (raise-type-error 'xref-binding-definition->tag
|
||||
"identifier, 2-element list, or 7-element list"
|
||||
id/binding)]))]))
|
||||
(raise-argument-error 'xref-binding-definition->tag
|
||||
"(list/c (or/c module-path? module-path-index?) any/c)"
|
||||
src)]))]
|
||||
[else (raise-argument-error 'xref-binding-definition->tag
|
||||
(string-append
|
||||
"(or/c identifier? (lambda (l)\n"
|
||||
" (and (list? l)\n"
|
||||
" (or (= (length l) 2)\n"
|
||||
" (= (length l) 7)))))")
|
||||
id/binding)]))]))
|
||||
|
||||
(define (xref-binding->definition-tag xrefs id/binding mode)
|
||||
(let-values ([(tag form?) (xref-binding-tag xrefs id/binding mode)])
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
(module gl-vectors mzscheme
|
||||
(require mzlib/foreign
|
||||
(only racket/base for/list in-list in-naturals)
|
||||
"gl-types.rkt")
|
||||
|
||||
(define-syntax gl-vector-binop
|
||||
|
|
@ -8,7 +9,7 @@
|
|||
(case-lambda
|
||||
((v)
|
||||
(unless (gl-vector? v)
|
||||
(raise-type-error name "gl-vector" v))
|
||||
(raise-argument-error name "gl-vector?" v))
|
||||
(let* ((l (cvector-length v))
|
||||
(res (make-res l)))
|
||||
(let loop ((i 0))
|
||||
|
|
@ -18,12 +19,14 @@
|
|||
res)))
|
||||
((v1 v2)
|
||||
(unless (gl-vector? v1)
|
||||
(raise-type-error name "gl-vector" 0 v1 v2))
|
||||
(raise-argument-error name "gl-vector?" 0 v1 v2))
|
||||
(unless (gl-vector? v2)
|
||||
(raise-type-error name "gl-vector" 1 v1 v2))
|
||||
(raise-argument-error name "gl-vector?" 1 v1 v2))
|
||||
(unless (= (cvector-length v1) (cvector-length v2))
|
||||
(error name "given gl-vector arguments of unequal lengths: ~a"
|
||||
(list (cvector-length v1) (cvector-length v2))))
|
||||
(raise-arguments-error name
|
||||
"given gl-vector arguments of unequal lengths"
|
||||
"first argument length" (cvector-length v1)
|
||||
"second argument length" (cvector-length v2)))
|
||||
(let* ((l (cvector-length v1))
|
||||
(t (cvector-type v1))
|
||||
(res (make-res l)))
|
||||
|
|
@ -39,12 +42,18 @@
|
|||
(to-check all-v))
|
||||
(unless (null? to-check)
|
||||
(unless (gl-vector? (car to-check))
|
||||
(apply raise-type-error (list* name "gl-vector" i all-v)))
|
||||
(apply raise-argument-error (list* name "gl-vector?" i all-v)))
|
||||
(loop (add1 i) (cdr to-check)))))
|
||||
(let ((l (cvector-length v)))
|
||||
(unless (andmap (lambda (x) (= l (cvector-length x))) vs)
|
||||
(error name "given gl-vector arguments of unequal lengths: ~a"
|
||||
(map cvector-length all-v)))
|
||||
(apply raise-arguments-error name
|
||||
"given gl-vector arguments of unequal lengths"
|
||||
(apply
|
||||
append
|
||||
(for/list ([v (in-list all-v)]
|
||||
[i (in-naturals 1)])
|
||||
(list (format "argument ~a" i)
|
||||
v)))))
|
||||
(let ((res (make-res l)))
|
||||
(let loop ((i 0))
|
||||
(when (< i l)
|
||||
|
|
@ -80,7 +89,7 @@
|
|||
(apply cvector (cons gl-type args)))
|
||||
(define (vector->v v)
|
||||
(unless (vector? v)
|
||||
(raise-type-error 'vector->v "vector" v))
|
||||
(raise-argument-error 'vector->v "vector?" v))
|
||||
(list->cvector (vector->list v) gl-type))
|
||||
(define (list->v l)
|
||||
(list->cvector l gl-type))
|
||||
|
|
@ -88,9 +97,9 @@
|
|||
(define v- (gl-vector-binop - 'v- make-v))
|
||||
(define (v* n v)
|
||||
(unless (real? n)
|
||||
(raise-type-error 'gl-vector* "real number" 0 n v))
|
||||
(raise-argument-error 'gl-vector* "real?" 0 n v))
|
||||
(unless (gl-vector? v)
|
||||
(raise-type-error 'gl-vector* "gl-vector" 1 n v))
|
||||
(raise-argument-error 'gl-vector* "gl-vector?" 1 n v))
|
||||
(let* ((l (cvector-length v))
|
||||
(t (cvector-type v))
|
||||
(res (make-v l)))
|
||||
|
|
@ -122,7 +131,7 @@
|
|||
(define gl-vector? cvector?)
|
||||
(define (gl-vector-norm v)
|
||||
(unless (gl-vector? v)
|
||||
(raise-type-error 'gl-vector-norm "gl-vector" v))
|
||||
(raise-argument-error 'gl-vector-norm "gl-vector?" v))
|
||||
(let ((l (gl-vector-length v)))
|
||||
(let loop ((i 0)
|
||||
(res 0))
|
||||
|
|
|
|||
|
|
@ -34,6 +34,15 @@
|
|||
(syntax->list #'(x ...)))
|
||||
#'(provide x ...))]))
|
||||
|
||||
(define (combine-syms strs)
|
||||
(string-append "(or/c"
|
||||
(apply
|
||||
string-append
|
||||
(map (lambda (s)
|
||||
(format " '~s" s))
|
||||
strs))
|
||||
")"))
|
||||
|
||||
(define-syntax-set (multi-arg multi-type-v)
|
||||
|
||||
(define (iota n)
|
||||
|
|
@ -43,21 +52,25 @@
|
|||
(combine-str
|
||||
(map (lambda (t)
|
||||
(case t
|
||||
[(iv) "gl-int-vector"]
|
||||
[(sv) "gl-short-vector"]
|
||||
[(bv) "gl-byte-vector"]
|
||||
[(uiv) "gl-uint-vector"]
|
||||
[(usv) "gl-ushort-vector"]
|
||||
[(ubv) "gl-ubyte-vector"]
|
||||
[(dv) "gl-double-vector"]
|
||||
[(fv) "gl-float-vector"]
|
||||
[else (error (format "~a" t))]))
|
||||
[(iv) "gl-int-vector?"]
|
||||
[(sv) "gl-short-vector?"]
|
||||
[(bv) "gl-byte-vector?"]
|
||||
[(uiv) "gl-uint-vector?"]
|
||||
[(usv) "gl-ushort-vector?"]
|
||||
[(ubv) "gl-ubyte-vector?"]
|
||||
[(dv) "gl-double-vector?"]
|
||||
[(fv) "gl-float-vector?"]
|
||||
[else (error (format "~a?" t))]))
|
||||
ts)))
|
||||
|
||||
(define (combine-str strs)
|
||||
(cond [(null? strs) ""]
|
||||
[(null? (cdr strs)) (string-append "or " (car strs))]
|
||||
[else (string-append (car strs) ", " (combine-str (cdr strs)))]))
|
||||
(string-append "(or/c"
|
||||
(apply
|
||||
string-append
|
||||
(map (lambda (s)
|
||||
(string-append " " s))
|
||||
strs))
|
||||
")"))
|
||||
|
||||
(define (multi-arg/proc stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -78,8 +91,8 @@
|
|||
#`((pre-arg-name ... arg ...)
|
||||
(if (and (real? arg) ...)
|
||||
(gl-name pre-arg ... arg ...)
|
||||
(raise-type-error
|
||||
'name "real numbers" (list arg ...))))))])
|
||||
(raise-argument-error
|
||||
'name "(listof real?)" (list arg ...))))))])
|
||||
(with-syntax ([(clauses ...)
|
||||
(map build-clause
|
||||
(syntax-object->datum #'(num-arg ...)))])
|
||||
|
|
@ -134,7 +147,7 @@
|
|||
(cond
|
||||
clause ...
|
||||
[else
|
||||
(raise-type-error 'name
|
||||
(raise-argument-error 'name
|
||||
#,(get-possible-types-v types)
|
||||
arg)])))))])))
|
||||
|
||||
|
|
@ -158,9 +171,9 @@
|
|||
(lambda (enum-sym name)
|
||||
(let ([v (assq enum-sym l)])
|
||||
(unless v
|
||||
(raise-type-error name
|
||||
(format "symbol in ~a" '(sym ...))
|
||||
enum-sym))
|
||||
(raise-argument-error name
|
||||
(combine-syms '(sym ...))
|
||||
enum-sym))
|
||||
(cdr v))))))
|
||||
(quasisyntax/loc stx
|
||||
(define name
|
||||
|
|
@ -171,9 +184,9 @@
|
|||
(lambda (enum-sym name)
|
||||
(let ([v (hash-table-get ht enum-sym (lambda () #f))])
|
||||
(unless v
|
||||
(raise-type-error name
|
||||
(format "symbol in ~a" '(sym ...))
|
||||
enum-sym))
|
||||
(raise-argument-error name
|
||||
(combine-syms '(sym ...))
|
||||
enum-sym))
|
||||
v)))))))]))
|
||||
|
||||
(define-syntax (make-inv-enum-table stx)
|
||||
|
|
@ -373,9 +386,9 @@
|
|||
(let ([f (cond [(gl-int-vector? v) glTexGeniv]
|
||||
[(gl-float-vector? v) glTexGenfv]
|
||||
[(gl-double-vector? v) glTexGendv]
|
||||
[else (raise-type-error
|
||||
[else (raise-argument-error
|
||||
'tex-gen-v
|
||||
"gl-int-vector, gl-float-vector, or gl-double-vector"
|
||||
"(or/c gl-int-vector? gl-float-vector? gl-double-vector?)"
|
||||
2 c p v)])])
|
||||
(check-length 'tex-gen-v v 4)
|
||||
(f cv pv v))))
|
||||
|
|
@ -388,7 +401,7 @@
|
|||
(define (clip-plane p eqn)
|
||||
(let ([v (clip-plane-table p 'clip-plane)])
|
||||
(unless (gl-double-vector? eqn)
|
||||
(raise-type-error 'clip-plane "gl-double-vector" 1 p eqn))
|
||||
(raise-argument-error 'clip-plane "gl-double-vector?" 1 p eqn))
|
||||
(check-length 'clip-plane eqn 4)
|
||||
(glClipPlane v eqn)))
|
||||
|
||||
|
|
@ -416,12 +429,12 @@
|
|||
(define (get-f v iv fv name a1 a2)
|
||||
(cond [(gl-int-vector? v) iv]
|
||||
[(gl-float-vector? v) fv]
|
||||
[else (raise-type-error name
|
||||
"gl-int-vector or gl-float-vector"
|
||||
2 a1 a2 v)]))
|
||||
[else (raise-argument-error name
|
||||
"(or/c gl-int-vector? gl-float-vector?)"
|
||||
2 a1 a2 v)]))
|
||||
(define (do-f n v0 v1 i f name a0 a1)
|
||||
(unless (real? n)
|
||||
(raise-type-error name "real number" 2 a0 a1 n))
|
||||
(raise-argument-error name "real?" 2 a0 a1 n))
|
||||
(if (exact-integer? n)
|
||||
(i v0 v1 n)
|
||||
(f v0 v1 n)))
|
||||
|
|
@ -485,7 +498,7 @@
|
|||
(when (= GL_LIGHT_MODEL_AMBIENT v)
|
||||
(error 'light-model "does not accept ~a, use light-model-v instead" pname))
|
||||
(unless (real? param)
|
||||
(raise-type-error 'light-model "real number" 1 pname param))
|
||||
(raise-argument-error 'light-model "real?" 1 pname param))
|
||||
(if (exact-integer? param)
|
||||
(glLightModeli v param)
|
||||
(glLightModelf v param))))
|
||||
|
|
@ -494,9 +507,9 @@
|
|||
(let ([v (light-model-table pname 'light-model-v)]
|
||||
[f (cond [(gl-int-vector? params) glLightModeliv]
|
||||
[(gl-float-vector? params) glLightModelfv]
|
||||
[else (raise-type-error 'light-model-v
|
||||
"gl-int-vector or gl-float-vector"
|
||||
1 pname params)])])
|
||||
[else (raise-argument-error 'light-model-v
|
||||
"(or/c gl-int-vector? gl-float-vector?)"
|
||||
1 pname params)])])
|
||||
(check-length 'light-model-v params
|
||||
(if (= GL_LIGHT_MODEL_AMBIENT v) 4 1)
|
||||
pname)
|
||||
|
|
@ -530,7 +543,7 @@
|
|||
(error 'point-parameter
|
||||
"does not accept ~a, use point-parameter-v instead" pname))
|
||||
(unless (real? param)
|
||||
(raise-type-error 'point-parameter "real number" 1 pname param))
|
||||
(raise-argument-error 'point-parameter "real?" 1 pname param))
|
||||
(if (exact-integer? param)
|
||||
(glPointParameteri v param)
|
||||
(glPointParameterf v param))))
|
||||
|
|
@ -538,9 +551,9 @@
|
|||
(let ([v (point-parameter-table pname 'point-parameter)]
|
||||
[f (cond [(gl-int-vector? params) glPointParameteriv]
|
||||
[(gl-float-vector? params) glPointParameterfv]
|
||||
[else (raise-type-error 'point-parameter-v
|
||||
"gl-int-vector or gl-float-vector"
|
||||
1 pname params)])])
|
||||
[else (raise-argument-error 'point-parameter-v
|
||||
"(or/c gl-int-vector? gl-float-vector?)"
|
||||
1 pname params)])])
|
||||
(check-length 'point-parameter-v
|
||||
(if (= GL_POINT_DISTANCE_ATTENUATION v) 3 1)
|
||||
pname)
|
||||
|
|
@ -580,7 +593,7 @@
|
|||
(define (pixel-store pname param)
|
||||
(let ([v (pixel-store-table pname 'pixel-store)])
|
||||
(unless (real? param)
|
||||
(raise-type-error 'pixel-store "real number" 1 pname param))
|
||||
(raise-argument-error 'pixel-store "real?" 1 pname param))
|
||||
(if (exact-integer? param)
|
||||
(glPixelStorei v param)
|
||||
(glPixelStoref v param))))
|
||||
|
|
@ -841,9 +854,9 @@
|
|||
pick-matrix)
|
||||
(define (pick-matrix a b c d v)
|
||||
(unless (gl-int-vector? v)
|
||||
(raise-type-error 'pick-matrix
|
||||
"gl-int-vector"
|
||||
4 a b c d v))
|
||||
(raise-argument-error 'pick-matrix
|
||||
"gl-int-vector?"
|
||||
4 a b c d v))
|
||||
(check-length 'pick-matrix v 4)
|
||||
(gluPickMatrix a b c d v))
|
||||
|
||||
|
|
@ -851,11 +864,11 @@
|
|||
(_provide project un-project un-project4)
|
||||
(define (project a b c d e f)
|
||||
(unless (gl-double-vector? d)
|
||||
(raise-type-error 'project "gl-double-vector" 3 a b c d e f))
|
||||
(raise-argument-error 'project "gl-double-vector?" 3 a b c d e f))
|
||||
(unless (gl-double-vector? e)
|
||||
(raise-type-error 'project "gl-double-vector" 4 a b c d e f))
|
||||
(raise-argument-error 'project "gl-double-vector?" 4 a b c d e f))
|
||||
(unless (gl-int-vector? f)
|
||||
(raise-type-error 'project "gl-double-vector" 5 a b c d e f))
|
||||
(raise-argument-error 'project "gl-double-vector?" 5 a b c d e f))
|
||||
(check-length 'project d 16)
|
||||
(check-length 'project e 16)
|
||||
(check-length 'project f 4)
|
||||
|
|
@ -863,11 +876,11 @@
|
|||
|
||||
(define (un-project a b c d e f)
|
||||
(unless (gl-double-vector? d)
|
||||
(raise-type-error 'un-project "gl-double-vector" 3 a b c d e f))
|
||||
(raise-argument-error 'un-project "gl-double-vector?" 3 a b c d e f))
|
||||
(unless (gl-double-vector? e)
|
||||
(raise-type-error 'un-project "gl-double-vector" 4 a b c d e f))
|
||||
(raise-argument-error 'un-project "gl-double-vector?" 4 a b c d e f))
|
||||
(unless (gl-int-vector? f)
|
||||
(raise-type-error 'un-project "gl-double-vector" 5 a b c d e f))
|
||||
(raise-argument-error 'un-project "gl-double-vector?" 5 a b c d e f))
|
||||
(check-length 'un-project d 16)
|
||||
(check-length 'un-project e 16)
|
||||
(check-length 'un-project f 4)
|
||||
|
|
@ -875,11 +888,11 @@
|
|||
|
||||
(define (un-project4 a b c d e f g h i)
|
||||
(unless (gl-double-vector? e)
|
||||
(raise-type-error 'un-project "gl-double-vector" 4 a b c d e f g h i))
|
||||
(raise-argument-error 'un-project "gl-double-vector?" 4 a b c d e f g h i))
|
||||
(unless (gl-double-vector? f)
|
||||
(raise-type-error 'un-project "gl-double-vector" 5 a b c d e f g h i))
|
||||
(raise-argument-error 'un-project "gl-double-vector?" 5 a b c d e f g h i))
|
||||
(unless (gl-int-vector? g)
|
||||
(raise-type-error 'un-project "gl-double-vector" 6 a b c d e f g h i))
|
||||
(raise-argument-error 'un-project "gl-double-vector?" 6 a b c d e f g h i))
|
||||
(check-length 'un-project4 e 16)
|
||||
(check-length 'un-project4 f 16)
|
||||
(check-length 'un-project4 g 4)
|
||||
|
|
@ -932,7 +945,7 @@
|
|||
;; process-selection : gl-uint-vector int -> (listof selection-record)
|
||||
(define (process-selection v hits)
|
||||
(unless (gl-uint-vector? v)
|
||||
(raise-type-error 'process-selection "gl-uint-vector" 0 v hits))
|
||||
(raise-argument-error 'process-selection "gl-uint-vector?" 0 v hits))
|
||||
(let ([index 0])
|
||||
(let loop ([hit 0])
|
||||
(if (>= hit hits)
|
||||
|
|
|
|||
|
|
@ -80,7 +80,7 @@
|
|||
(integer? x)
|
||||
(exact? x)
|
||||
(positive? x))
|
||||
(raise-type-error 'current-font-size "exact non-negative integer" x))
|
||||
(raise-argument-error 'current-font-size "nonnegative-exact-integer?" x))
|
||||
x)))
|
||||
|
||||
(define current-title-color (make-parameter
|
||||
|
|
@ -88,9 +88,9 @@
|
|||
(lambda (x)
|
||||
(unless (or (string? x)
|
||||
(x . is-a? . color%))
|
||||
(raise-type-error 'current-title-color
|
||||
"string or color% object"
|
||||
x))
|
||||
(raise-argument-error 'current-title-color
|
||||
"(or/c string? (is-a?/c color%))"
|
||||
x))
|
||||
x)))
|
||||
|
||||
(define (t s) (text s (current-main-font) (current-font-size)))
|
||||
|
|
@ -166,19 +166,19 @@
|
|||
(make-object font% 10 'default 'normal 'normal)
|
||||
(lambda (f)
|
||||
(unless (f . is-a? . font%)
|
||||
(raise-type-error 'current-page-number-font "font%" f))
|
||||
(raise-argument-error 'current-page-number-font "(is-a?/c font%)" f))
|
||||
f)))
|
||||
(define current-page-number-color
|
||||
(make-parameter (make-object color% "black")
|
||||
(lambda (s)
|
||||
(unless (s . is-a? . color%)
|
||||
(raise-type-error 'current-page-number-color "color%" s))
|
||||
(raise-argument-error 'current-page-number-color "(is-a?/c color%)" s))
|
||||
s)))
|
||||
(define current-page-number-adjust (make-parameter
|
||||
(λ (n s) s)
|
||||
(lambda (f)
|
||||
(unless (procedure-arity-includes? f 2)
|
||||
(raise-type-error 'current-page-number-adjust "procedure that accepts 2 arguments" f))
|
||||
(raise-argument-error 'current-page-number-adjust "(procedure-arity-includes/c 2)" f))
|
||||
f)))
|
||||
|
||||
(define page-number 1)
|
||||
|
|
@ -540,7 +540,7 @@
|
|||
(define re-slide
|
||||
(lambda (s [addition #f])
|
||||
(unless (sliderec? s)
|
||||
(raise-type-error 're-slide "slide" s))
|
||||
(raise-argument-error 're-slide "slide?" s))
|
||||
(viewer:add-talk-slide!
|
||||
(make-sliderec
|
||||
(let ([orig (sliderec-drawer s)]
|
||||
|
|
@ -563,7 +563,7 @@
|
|||
|
||||
(define (slide->pict s)
|
||||
(unless (sliderec? s)
|
||||
(raise-type-error 'slide->pict "slide" s))
|
||||
(raise-argument-error 'slide->pict "slide?" s))
|
||||
(let ([orig (sliderec-drawer s)])
|
||||
(dc orig client-w client-h)))
|
||||
|
||||
|
|
|
|||
|
|
@ -3022,11 +3022,11 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati
|
|||
|
||||
if (!is_subarity(orig, naya))
|
||||
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
|
||||
"%s: arity of %s procedure does not cover arity of original procedure",
|
||||
" %s procedure: %V\n"
|
||||
" original procedure: %V",
|
||||
name, whating,
|
||||
whating, argv[1],
|
||||
"%s: arity of wrapper procedure does not cover arity of original procedure\n"
|
||||
" wrapper: %V\n"
|
||||
" original: %V",
|
||||
name,
|
||||
argv[1],
|
||||
argv[0]);
|
||||
|
||||
props = scheme_parse_chaperone_props(name, 2, argc, argv);
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user