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

..

Browse Source 
original commit: b126ca20564a9ca3d676ec0032a7074ec2b7f42e
This commit is contained in:
Robby Findler 2002-12-03 23:20:09 +00:00
parent 77896eab3f
commit bc512e0a8f
1 changed files with 477 additions and 452 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

929
collects/mzlib/contracts.ss
View File

@ -14,11 +14,14 @@
(require-for-syntax mzscheme (require-for-syntax mzscheme
(lib "list.ss") (lib "list.ss")
(lib "match.ss")
(lib "pretty.ss") (lib "pretty.ss")
(lib "name.ss" "syntax") (lib "name.ss" "syntax")
(lib "stx.ss" "syntax")) (lib "stx.ss" "syntax"))
(require (lib "class.ss")) (require (lib "class.ss")
(lib "etc.ss"))
(require (lib "contract-helpers.scm" "mzlib" "private")) (require (lib "contract-helpers.scm" "mzlib" "private"))
(require-for-syntax (prefix a: (lib "contract-helpers.scm" "mzlib" "private"))) (require-for-syntax (prefix a: (lib "contract-helpers.scm" "mzlib" "private")))
@ -590,216 +593,271 @@
; ;
(define-syntaxes (-> ->* ->d ->d* case->) (define-syntax-set (-> ->* ->d ->d* case-> class-contract)
(let ()
;; Each of the /h functions builds three pieces of syntax: ;; ->/proc : syntax -> syntax
;; - code that does error checking for the contract specs ;; the transformer for the -> macro
;; (were the arguments all contracts?) (define (->/proc stx) (make-/proc ->/h stx))
;; - code that does error checking on the contract'd value
;; (is a function of the right arity?) ;; ->*/proc : syntax -> syntax
;; - a piece of syntax that has the arguments to the wrapper ;; the transformer for the ->* macro
;; and the body of the wrapper. (define (->*/proc stx) (make-/proc ->*/h stx))
;; They are combined into a lambda for the -> ->* ->d ->d* macros,
;; and combined into a case-lambda for the case-> macro. ;; ->d/proc : syntax -> syntax
;; the transformer for the ->d macro
;; ->/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) (define (->d/proc stx) (make-/proc ->d/h stx))
(define (->/h stx)
(syntax-case stx () ;; ->d*/proc : syntax -> syntax
[(_) (raise-syntax-error '-> "expected at least one argument" stx)] ;; the transformer for the ->d* macro
[(_ ct ...) (define (->d*/proc stx) (make-/proc ->d*/h stx))
(let* ([rng-normal (car (last-pair (syntax->list (syntax (ct ...)))))]
[ignore-range-checking? ;; case->/proc : syntax -> syntax
(syntax-case rng-normal (any) ;; the transformer for the case-> macro
[any #t] (define (case->/proc stx)
[_ #f])]) (syntax-case stx ()
(with-syntax ([(dom ...) (all-but-last (syntax->list (syntax (ct ...))))] [(_ case ...)
[rng (if ignore-range-checking? (let-values ([(add-outer-check make-inner-check make-bodies)
(syntax any?) ;; hack to simplify life... (case->/h stx (syntax->list (syntax (case ...))))])
rng-normal)]) (let ([outer-args (syntax (val pos-blame neg-blame src-info))])
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] (with-syntax ([outer-args outer-args]
[(arg-x ...) (generate-temporaries (syntax (dom ...)))] [(inner-check ...) (make-inner-check outer-args)]
[arity (length (syntax->list (syntax (dom ...))))]) [(body ...) (make-bodies outer-args)])
(let ([->add-outer-check (with-syntax ([inner-lambda
(lambda (body) (set-inferred-name-from
(with-syntax ([body body]) stx
(syntax (syntax (case-lambda body ...)))])
(let ([dom-x dom] ... (add-outer-check
[rng-x rng]) (syntax
(unless (-contract? dom-x) (make-contract
(error '-> "expected contract as argument, given: ~e" dom-x)) ... (lambda outer-args
(unless (-contract? rng-x) inner-check ...
(error '-> "expected contract as argument, given: ~e" rng-x)) inner-lambda))))))))]))
body))))]
[->body (syntax (->* (dom-x ...) (rng-x)))]) (define (class-contract/proc stx)
(let-values ([(->*add-outer-check ->*make-inner-check ->*make-body) (->*/h ->body)]) (syntax-case stx ()
(values [(_ (meth-name meth-contract) ...)
(lambda (body) (->add-outer-check (->*add-outer-check body))) (andmap identifier? (syntax->list (syntax (meth-name ...))))
(lambda (stx) (->*make-inner-check stx)) (match-let ([(`(,make-outer-checks ,xxx ,build-pieces) ...)
(if ignore-range-checking? (map (lambda (meth-contract-stx)
(lambda (stx) (let ([/h (select/h meth-contract-stx 'class-contract stx)])
(with-syntax ([(val pos-blame neg-blame src-info) stx]) (let-values ([(make-outer-check xxx build-pieces) (/h meth-contract-stx)])
(syntax (list make-outer-check xxx build-pieces))))
((arg-x ...) (syntax->list (syntax (meth-contract ...))))])
(val (let ([outer-args (syntax (val pos neg src-info))])
(check-contract dom-x arg-x neg-blame pos-blame src-info #f) (with-syntax ([outer-args outer-args]
...))))) [(super-meth-name ...) (map prefix-super (syntax->list (syntax (meth-name ...))))])
(lambda (stx) (foldr
(->*make-body stx)))))))))])) (lambda (f stx) (f stx))
(syntax
(make-contract
(lambda outer-args
(unless (class? val)
(raise-contract-error src-info pos neg "expected a class, got: ~e" val))
(let ([class-i (class->interface val)])
(void)
(unless (method-in-interface? 'meth-name class-i)
(raise-contract-error src-info
pos neg
"expected class to have method ~a, got: ~e"
'meth-name
val))
...)
(class val
(rename [super-meth-name meth-name] ...)
(define/override meth-name
(lambda x (super-meth-name . x)))
...
(super-instantiate ())))))
make-outer-checks))))]
[(_ (meth-name meth-contract) ...)
(for-each (lambda (name)
(unless (identifier? name)
(raise-syntax-error 'class-contract "expected name" stx name)))
(syntax->list (syntax (meth-name ...))))]
[(_ clz ...)
(for-each (lambda (clz)
(syntax-case clz ()
[(a b) (void)]
[else (raise-syntax-error 'class-contract "bad method/contract clause" stx clz)]))
(syntax->list (syntax (clz ...))))]))
;; ->*/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
(define (->*/h stx) ;; prefix-super : syntax[identifier] -> syntax[identifier]
(syntax-case stx () ;; adds super- to the front of the identifier
[(_ (dom ...) (rng ...)) (define (prefix-super stx)
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] (datum->syntax-object
[(arg-x ...) (generate-temporaries (syntax (dom ...)))] #'here
[(rng-x ...) (generate-temporaries (syntax (rng ...)))] (string->symbol
[(res-x ...) (generate-temporaries (syntax (rng ...)))] (format
[arity (length (syntax->list (syntax (dom ...))))]) "super-~a"
(values (syntax-object->datum
(lambda (body) stx)))))
(with-syntax ([body body])
(syntax ;; Each of the /h functions builds three pieces of syntax:
(let ([dom-x dom] ... ;; - code that binds the contract values to names and
[rng-x rng] ...) ;; does error checking for the contract specs
(unless (-contract? dom-x) ;; (were the arguments all contracts?)
(error '->* "expected contract as argument, given: ~e" dom-x)) ... ;; - code that does error checking on the contract'd value itself
(unless (-contract? rng-x) ;; (is a function of the right arity?)
(error '->* "expected contract as argument, given: ~e" rng-x)) ... ;; - a piece of syntax that has the arguments to the wrapper
body)))) ;; and the body of the wrapper.
(lambda (stx) ;; the first functions accepts `body' and it wraps
(with-syntax ([(val pos-blame neg-blame src-info) stx]) ;; the second and third function's input syntax should be four
(syntax ;; names: val, pos-blame, neg-blame, src-info.
(unless (and (procedure? val) ;; They are combined into a lambda for the -> ->* ->d ->d* macros,
(procedure-arity-includes? val arity)) ;; and combined into a case-lambda for the case-> macro.
(raise-contract-error
src-info ;; ->/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
pos-blame (define (->/h stx)
neg-blame (syntax-case stx ()
"expected a procedure that accepts ~a arguments, given: ~e" [(_) (raise-syntax-error '-> "expected at least one argument" stx)]
arity [(_ ct ...)
val))))) (let* ([rng-normal (car (last-pair (syntax->list (syntax (ct ...)))))]
(lambda (stx) [ignore-range-checking?
(with-syntax ([(val pos-blame neg-blame src-info) stx]) (syntax-case rng-normal (any)
(syntax [any #t]
((arg-x ...) [_ #f])])
(let-values ([(res-x ...)
(val
(check-contract dom-x arg-x neg-blame pos-blame src-info #f)
...)])
(values (check-contract
rng-x
res-x
pos-blame
neg-blame
src-info
#f)
...))))))))]
[(_ (dom ...) rest (rng ...))
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
[(arg-x ...) (generate-temporaries (syntax (dom ...)))]
[(rng-x ...) (generate-temporaries (syntax (rng ...)))]
[(res-x ...) (generate-temporaries (syntax (rng ...)))]
[arity (length (syntax->list (syntax (dom ...))))])
(values
(lambda (body)
(with-syntax ([body body])
(syntax
(let ([dom-x dom] ...
[dom-rest-x rest]
[rng-x rng] ...)
(unless (-contract? dom-x)
(error '->* "expected contract for domain position, given: ~e" dom-x)) ...
(unless (-contract? dom-rest-x)
(error '->* "expected contract for rest position, given: ~e" dom-rest-x))
(unless (-contract? rng-x)
(error '->* "expected contract for range position, given: ~e" rng-x)) ...
body))))
(lambda (stx)
(with-syntax ([(val pos-blame neg-blame src-info) stx])
(syntax
(unless (procedure? val)
(raise-contract-error
src-info
pos-blame
neg-blame
"expected a procedure that accepts ~a arguments, given: ~e"
arity
val)))))
(lambda (stx)
(with-syntax ([(val pos-blame neg-blame src-info) stx])
(syntax
((arg-x ... . rest-arg-x)
(let-values ([(res-x ...)
(apply
val
(check-contract dom-x arg-x neg-blame pos-blame src-info #f)
...
(check-contract dom-rest-x rest-arg-x neg-blame pos-blame src-info #f))])
(values (check-contract
rng-x
res-x
pos-blame
neg-blame
src-info
#f)
...))))))))]))
;; ->d/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
(define (->d/h stx)
(syntax-case stx ()
[(_) (raise-syntax-error '->d "expected at least one argument" stx)]
[(_ ct ...)
(with-syntax ([(dom ...) (all-but-last (syntax->list (syntax (ct ...))))] (with-syntax ([(dom ...) (all-but-last (syntax->list (syntax (ct ...))))]
[rng (car (last-pair (syntax->list (syntax (ct ...)))))]) [rng (if ignore-range-checking?
(syntax any?) ;; hack to simplify life...
rng-normal)])
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
[(arg-x ...) (generate-temporaries (syntax (dom ...)))] [(arg-x ...) (generate-temporaries (syntax (dom ...)))]
[arity (length (syntax->list (syntax (dom ...))))]) [arity (length (syntax->list (syntax (dom ...))))])
(values (let ([->add-outer-check
(lambda (body) (lambda (body)
(with-syntax ([body body]) (with-syntax ([body body])
(syntax (syntax
(let ([dom-x dom] ... (let ([dom-x dom] ...
[rng-x rng]) [rng-x rng])
(unless (-contract? dom-x) (unless (-contract? dom-x)
(error '->d "expected contract as argument, given: ~e" dom-x)) ... (error '-> "expected contract as argument, given: ~e" dom-x)) ...
(unless (and (procedure? rng-x) (unless (-contract? rng-x)
(procedure-arity-includes? rng-x arity)) (error '-> "expected contract as argument, given: ~e" rng-x))
(error '->d "expected range portion to be a function that takes ~a arguments, given: ~e" body))))]
arity [->body (syntax (->* (dom-x ...) (rng-x)))])
rng-x)) (let-values ([(->*add-outer-check ->*make-inner-check ->*make-body) (->*/h ->body)])
body)))) (values
(lambda (stx) (lambda (body) (->add-outer-check (->*add-outer-check body)))
(with-syntax ([(val pos-blame neg-blame src-info) stx]) (lambda (stx) (->*make-inner-check stx))
(syntax (if ignore-range-checking?
(unless (and (procedure? val) (lambda (stx)
(procedure-arity-includes? val arity)) (with-syntax ([(val pos-blame neg-blame src-info) stx])
(raise-contract-error (syntax
src-info ((arg-x ...)
pos-blame (val
neg-blame (check-contract dom-x arg-x neg-blame pos-blame src-info #f)
"expected a procedure that accepts ~a arguments, given: ~e" ...)))))
arity (lambda (stx)
val))))) (->*make-body stx)))))))))]))
(lambda (stx)
(with-syntax ([(val pos-blame neg-blame src-info) stx]) ;; ->*/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
(syntax (define (->*/h stx)
((arg-x ...) (syntax-case stx ()
(let ([rng-contract (rng-x arg-x ...)]) [(_ (dom ...) (rng ...))
(unless (-contract? rng-contract) (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
(error '->d "expected range portion to return a contract, given: ~e" [(arg-x ...) (generate-temporaries (syntax (dom ...)))]
rng-contract)) [(rng-x ...) (generate-temporaries (syntax (rng ...)))]
(check-contract [(res-x ...) (generate-temporaries (syntax (rng ...)))]
rng-contract [arity (length (syntax->list (syntax (dom ...))))])
(val (check-contract dom-x arg-x neg-blame pos-blame src-info #f) ...) (values
pos-blame (lambda (body)
neg-blame (with-syntax ([body body])
src-info (syntax
#f)))))))))])) (let ([dom-x dom] ...
[rng-x rng] ...)
;; ->d*/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) (unless (-contract? dom-x)
(define (->d*/h stx) (error '->* "expected contract as argument, given: ~e" dom-x)) ...
(syntax-case stx () (unless (-contract? rng-x)
[(_ (dom ...) rng-mk) (error '->* "expected contract as argument, given: ~e" rng-x)) ...
body))))
(lambda (stx)
(with-syntax ([(val pos-blame neg-blame src-info) stx])
(syntax
(unless (and (procedure? val)
(procedure-arity-includes? val arity))
(raise-contract-error
src-info
pos-blame
neg-blame
"expected a procedure that accepts ~a arguments, given: ~e"
arity
val)))))
(lambda (stx)
(with-syntax ([(val pos-blame neg-blame src-info) stx])
(syntax
((arg-x ...)
(let-values ([(res-x ...)
(val
(check-contract dom-x arg-x neg-blame pos-blame src-info #f)
...)])
(values (check-contract
rng-x
res-x
pos-blame
neg-blame
src-info
#f)
...))))))))]
[(_ (dom ...) rest (rng ...))
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
[(arg-x ...) (generate-temporaries (syntax (dom ...)))]
[(rng-x ...) (generate-temporaries (syntax (rng ...)))]
[(res-x ...) (generate-temporaries (syntax (rng ...)))]
[arity (length (syntax->list (syntax (dom ...))))])
(values
(lambda (body)
(with-syntax ([body body])
(syntax
(let ([dom-x dom] ...
[dom-rest-x rest]
[rng-x rng] ...)
(unless (-contract? dom-x)
(error '->* "expected contract for domain position, given: ~e" dom-x)) ...
(unless (-contract? dom-rest-x)
(error '->* "expected contract for rest position, given: ~e" dom-rest-x))
(unless (-contract? rng-x)
(error '->* "expected contract for range position, given: ~e" rng-x)) ...
body))))
(lambda (stx)
(with-syntax ([(val pos-blame neg-blame src-info) stx])
(syntax
(unless (procedure? val)
(raise-contract-error
src-info
pos-blame
neg-blame
"expected a procedure that accepts ~a arguments, given: ~e"
arity
val)))))
(lambda (stx)
(with-syntax ([(val pos-blame neg-blame src-info) stx])
(syntax
((arg-x ... . rest-arg-x)
(let-values ([(res-x ...)
(apply
val
(check-contract dom-x arg-x neg-blame pos-blame src-info #f)
...
(check-contract dom-rest-x rest-arg-x neg-blame pos-blame src-info #f))])
(values (check-contract
rng-x
res-x
pos-blame
neg-blame
src-info
#f)
...))))))))]))
;; ->d/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
(define (->d/h stx)
(syntax-case stx ()
[(_) (raise-syntax-error '->d "expected at least one argument" stx)]
[(_ ct ...)
(with-syntax ([(dom ...) (all-but-last (syntax->list (syntax (ct ...))))]
[rng (car (last-pair (syntax->list (syntax (ct ...)))))])
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
[(arg-x ...) (generate-temporaries (syntax (dom ...)))] [(arg-x ...) (generate-temporaries (syntax (dom ...)))]
[arity (length (syntax->list (syntax (dom ...))))]) [arity (length (syntax->list (syntax (dom ...))))])
@ -808,13 +866,14 @@
(with-syntax ([body body]) (with-syntax ([body body])
(syntax (syntax
(let ([dom-x dom] ... (let ([dom-x dom] ...
[rng-mk-x rng-mk]) [rng-x rng])
(unless (-contract? dom-x) (unless (-contract? dom-x)
(error '->*d "expected contract as argument, given: ~e" dom-x)) ... (error '->d "expected contract as argument, given: ~e" dom-x)) ...
(unless (and (procedure? rng-mk-x) (unless (and (procedure? rng-x)
(procedure-arity-includes? rng-mk-x arity)) (procedure-arity-includes? rng-x arity))
(error '->*d "expected range position to be a procedure that accepts ~a arguments, given: ~e" (error '->d "expected range portion to be a function that takes ~a arguments, given: ~e"
arity rng-mk-x)) arity
rng-x))
body)))) body))))
(lambda (stx) (lambda (stx)
(with-syntax ([(val pos-blame neg-blame src-info) stx]) (with-syntax ([(val pos-blame neg-blame src-info) stx])
@ -824,7 +883,7 @@
(raise-contract-error (raise-contract-error
src-info src-info
pos-blame pos-blame
neg-blame neg-blame
"expected a procedure that accepts ~a arguments, given: ~e" "expected a procedure that accepts ~a arguments, given: ~e"
arity arity
val))))) val)))))
@ -832,195 +891,212 @@
(with-syntax ([(val pos-blame neg-blame src-info) stx]) (with-syntax ([(val pos-blame neg-blame src-info) stx])
(syntax (syntax
((arg-x ...) ((arg-x ...)
(call-with-values (let ([rng-contract (rng-x arg-x ...)])
(lambda () (unless (-contract? rng-contract)
(rng-mk-x arg-x ...)) (error '->d "expected range portion to return a contract, given: ~e"
(lambda rng-contracts rng-contract))
(call-with-values (check-contract
(lambda () rng-contract
(val (val (check-contract dom-x arg-x neg-blame pos-blame src-info #f) ...)
(check-contract dom-x arg-x neg-blame pos-blame src-info #f) pos-blame
...)) neg-blame
(lambda results src-info
(unless (= (length results) (length rng-contracts)) #f)))))))))]))
(error '->d*
"expected range contract contructor and function to have the same number of values, given: ~a and ~a respectively" ;; ->d*/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
(length results) (length rng-contracts))) (define (->d*/h stx)
(apply (syntax-case stx ()
values [(_ (dom ...) rng-mk)
(map (lambda (rng-contract result) (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
(check-contract [(arg-x ...) (generate-temporaries (syntax (dom ...)))]
rng-contract [arity (length (syntax->list (syntax (dom ...))))])
result (values
pos-blame (lambda (body)
neg-blame (with-syntax ([body body])
src-info (syntax
#f)) (let ([dom-x dom] ...
rng-contracts [rng-mk-x rng-mk])
results))))))))))))] (unless (-contract? dom-x)
[(_ (dom ...) rest rng-mk) (error '->*d "expected contract as argument, given: ~e" dom-x)) ...
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] (unless (and (procedure? rng-mk-x)
[(arg-x ...) (generate-temporaries (syntax (dom ...)))] (procedure-arity-includes? rng-mk-x arity))
[arity (length (syntax->list (syntax (dom ...))))]) (error '->*d "expected range position to be a procedure that accepts ~a arguments, given: ~e"
(values arity rng-mk-x))
(lambda (body) body))))
(with-syntax ([body body]) (lambda (stx)
(syntax (with-syntax ([(val pos-blame neg-blame src-info) stx])
(let ([dom-x dom] ... (syntax
[dom-rest-x rest] (unless (and (procedure? val)
[rng-mk-x rng-mk]) (procedure-arity-includes? val arity))
(unless (-contract? dom-x) (raise-contract-error
(error '->*d "expected contract as argument, given: ~e" dom-x)) ... src-info
(unless (-contract? dom-rest-x) pos-blame
(error '->*d "expected contract for rest argument, given: ~e" dom-rest-x)) neg-blame
(unless (procedure? rng-mk-x) "expected a procedure that accepts ~a arguments, given: ~e"
(error '->*d "expected range position to be a procedure that accepts ~a arguments, given: ~e" arity
arity rng-mk-x)) val)))))
body)))) (lambda (stx)
(lambda (stx) (with-syntax ([(val pos-blame neg-blame src-info) stx])
(with-syntax ([(val pos-blame neg-blame src-info) stx]) (syntax
(syntax ((arg-x ...)
(unless (procedure? val) (call-with-values
(raise-contract-error (lambda ()
src-info (rng-mk-x arg-x ...))
pos-blame (lambda rng-contracts
neg-blame (call-with-values
"expected a procedure that accepts ~a arguments, given: ~e" (lambda ()
arity (val
val))))) (check-contract dom-x arg-x neg-blame pos-blame src-info #f)
(lambda (stx) ...))
(with-syntax ([(val pos-blame neg-blame src-info) stx]) (lambda results
(syntax (unless (= (length results) (length rng-contracts))
((arg-x ... . rest-arg-x) (error '->d*
(call-with-values "expected range contract contructor and function to have the same number of values, given: ~a and ~a respectively"
(lambda () (length results) (length rng-contracts)))
(apply rng-mk-x arg-x ... rest-arg-x)) (apply
(lambda rng-contracts values
(call-with-values (map (lambda (rng-contract result)
(lambda () (check-contract
(apply rng-contract
val result
(check-contract dom-x arg-x neg-blame pos-blame src-info #f) pos-blame
... neg-blame
(check-contract dom-rest-x rest-arg-x neg-blame pos-blame src-info #f))) src-info
(lambda results #f))
(unless (= (length results) (length rng-contracts)) rng-contracts
(error '->d* results))))))))))))]
"expected range contract contructor and function to have the same number of values, given: ~a and ~a respectively" [(_ (dom ...) rest rng-mk)
(length results) (length rng-contracts))) (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
(apply [(arg-x ...) (generate-temporaries (syntax (dom ...)))]
values [arity (length (syntax->list (syntax (dom ...))))])
(map (lambda (rng-contract result) (values
(check-contract (lambda (body)
rng-contract (with-syntax ([body body])
result (syntax
pos-blame (let ([dom-x dom] ...
neg-blame [dom-rest-x rest]
src-info [rng-mk-x rng-mk])
#f)) (unless (-contract? dom-x)
rng-contracts (error '->*d "expected contract as argument, given: ~e" dom-x)) ...
results))))))))))))])) (unless (-contract? dom-rest-x)
(error '->*d "expected contract for rest argument, given: ~e" dom-rest-x))
;; make-/f : (syntax -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))) (unless (procedure? rng-mk-x)
;; -> (syntax -> syntax) (error '->*d "expected range position to be a procedure that accepts ~a arguments, given: ~e"
(define (make-/f /h) arity rng-mk-x))
(lambda (stx) body))))
(let-values ([(add-outer-check make-inner-check make-main) (/h stx)]) (lambda (stx)
(let ([outer-args (syntax (val pos-blame neg-blame src-info))]) (with-syntax ([(val pos-blame neg-blame src-info) stx])
(with-syntax ([outer-args outer-args] (syntax
[inner-check (make-inner-check outer-args)] (unless (procedure? val)
[(inner-args body) (make-main outer-args)]) (raise-contract-error
(with-syntax ([inner-lambda src-info
(set-inferred-name-from pos-blame
stx neg-blame
(syntax (lambda inner-args body)))]) "expected a procedure that accepts ~a arguments, given: ~e"
(add-outer-check arity
(syntax val)))))
(make-contract (lambda (stx)
(lambda outer-args (with-syntax ([(val pos-blame neg-blame src-info) stx])
inner-check (syntax
inner-lambda)))))))))) ((arg-x ... . rest-arg-x)
(call-with-values
;; set-inferred-name-from : syntax syntax -> syntax (lambda ()
(define (set-inferred-name-from with-name to-be-named) (apply rng-mk-x arg-x ... rest-arg-x))
(let ([name (syntax-local-infer-name with-name)]) (lambda rng-contracts
(if name (call-with-values
(syntax-property to-be-named 'inferred-name name) (lambda ()
to-be-named))) (apply
val
;; ->/f : syntax -> syntax (check-contract dom-x arg-x neg-blame pos-blame src-info #f)
;; the transformer for the -> macro ...
(define ->/f (make-/f ->/h)) (check-contract dom-rest-x rest-arg-x neg-blame pos-blame src-info #f)))
(lambda results
;; ->*/f : syntax -> syntax (unless (= (length results) (length rng-contracts))
;; the transformer for the ->* macro (error '->d*
(define ->*/f (make-/f ->*/h)) "expected range contract contructor and function to have the same number of values, given: ~a and ~a respectively"
(length results) (length rng-contracts)))
;; ->d/f : syntax -> syntax (apply
;; the transformer for the ->d macro values
(define ->d/f (make-/f ->d/h)) (map (lambda (rng-contract result)
(check-contract
;; ->d*/f : syntax -> syntax rng-contract
;; the transformer for the ->d* macro result
(define ->d*/f (make-/f ->d*/h)) pos-blame
neg-blame
;; case->/f : syntax -> syntax src-info
;; the transformer for the case-> macro #f))
(define (case->/f stx) rng-contracts
(syntax-case stx () results))))))))))))]))
[(_ case ...)
(let-values ([(add-outer-check make-inner-check make-bodies) ;; make-/proc : (syntax -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)))
(case->/h (syntax->list (syntax (case ...))))]) ;; -> (syntax -> syntax)
(let ([outer-args (syntax (val pos-blame neg-blame src-info))]) (define (make-/proc /h stx)
(with-syntax ([outer-args outer-args] (let-values ([(add-outer-check make-inner-check make-main) (/h stx)])
[(inner-check ...) (make-inner-check outer-args)] (let ([outer-args (syntax (val pos-blame neg-blame src-info))])
[(body ...) (make-bodies outer-args)]) (with-syntax ([outer-args outer-args]
(with-syntax ([inner-lambda [inner-check (make-inner-check outer-args)]
(set-inferred-name-from [(inner-args body) (make-main outer-args)])
stx (with-syntax ([inner-lambda
(syntax (case-lambda body ...)))]) (set-inferred-name-from
(add-outer-check stx
(syntax (syntax (lambda inner-args body)))])
(make-contract (add-outer-check
(lambda outer-args (syntax
inner-check ... (make-contract
inner-lambda))))))))])) (lambda outer-args
inner-check
;; case->/h : (listof syntax) -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) inner-lambda)))))))))
;; like the other /h functions, but composes the wrapper functions
;; together and combines the cases of the case-lambda into a single list. ;; case->/h : syntax (listof syntax) -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
(define (case->/h cases) ;; like the other /h functions, but composes the wrapper functions
(let loop ([cases cases]) ;; together and combines the cases of the case-lambda into a single list.
(cond (define (case->/h orig-stx cases)
[(null? cases) (values (lambda (x) x) (let loop ([cases cases])
(lambda (args) (syntax ()))
(lambda (args) (syntax ())))]
[else
(let ([/h (syntax-case (car cases) (-> ->* ->d ->d*)
[(-> . args) ->/h]
[(->* . args) ->*/h]
[(->d . args) ->d/h]
[(->d* . args) ->d*/h])])
(let-values ([(add-outer-checks make-inner-checks make-bodies) (loop (cdr cases))]
[(add-outer-check make-inner-check make-body) (/h (car cases))])
(values
(lambda (x) (add-outer-check (add-outer-checks x)))
(lambda (args)
(with-syntax ([checks (make-inner-checks args)]
[check (make-inner-check args)])
(syntax (check . checks))))
(lambda (args)
(with-syntax ([case (make-body args)]
[cases (make-bodies args)])
(syntax (case . cases)))))))])))
(define (all-but-last l)
(cond (cond
[(null? l) (error 'all-but-last "bad input")] [(null? cases) (values (lambda (x) x)
[(null? (cdr l)) null] (lambda (args) (syntax ()))
[else (cons (car l) (all-but-last (cdr l)))])) (lambda (args) (syntax ())))]
[else
(values ->/f ->*/f ->d/f ->d*/f case->/f))) (let ([/h (select/h (car cases) 'case-> orig-stx)])
(let-values ([(add-outer-checks make-inner-checks make-bodies) (loop (cdr cases))]
[(add-outer-check make-inner-check make-body) (/h (car cases))])
(values
(lambda (x) (add-outer-check (add-outer-checks x)))
(lambda (args)
(with-syntax ([checks (make-inner-checks args)]
[check (make-inner-check args)])
(syntax (check . checks))))
(lambda (args)
(with-syntax ([case (make-body args)]
[cases (make-bodies args)])
(syntax (case . cases)))))))])))
;; select/h : syntax -> /h-function
(define (select/h stx err-name ctxt-stx)
(syntax-case stx (-> ->* ->d ->d*)
[(-> . args) ->/h]
[(->* . args) ->*/h]
[(->d . args) ->d/h]
[(->d* . args) ->d*/h]
[(xxx . args) (raise-syntax-error err-name "unknown arrow constructor" ctxt-stx (syntax xxx))]
[_ (raise-syntax-error err-name "malformed arrow clause" ctxt-stx stx)]))
;; set-inferred-name-from : syntax syntax -> syntax
(define (set-inferred-name-from with-name to-be-named)
(let ([name (syntax-local-infer-name with-name)])
(if name
(syntax-property to-be-named 'inferred-name name)
to-be-named)))
;; (cons X (listof X)) -> (listof X)
;; returns the elements of `l', minus the last
;; element
(define (all-but-last l)
(cond
[(null? l) (error 'all-but-last "bad input")]
[(null? (cdr l)) null]
[else (cons (car l) (all-but-last (cdr l)))])))
(define-syntax (opt-> stx) (define-syntax (opt-> stx)
(syntax-case stx () (syntax-case stx ()
@ -1051,57 +1127,6 @@
[opt-vs opts] ...) [opt-vs opts] ...)
(case-> (->* (case-doms ...) (double-res-vs ...)) ...)))))])) (case-> (->* (case-doms ...) (double-res-vs ...)) ...)))))]))
;
;
;
; ;
; ;
; ; ; ;
; ;;; ; ;;; ;;; ;;; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;; ;;;
; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; ;
; ; ; ; ;; ;; ; ; ; ; ; ; ; ; ; ; ;;
; ; ; ;;;; ;; ;; ; ; ; ; ; ; ; ;;;; ; ; ;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;;; ; ;;;;; ;;; ;;; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;; ;;;
;
;
;;
;
; (define-syntax (class-contract stx)
; (syntax-case stx ()
; [(_ (meth-name meth-contract) ...)
; (andmap identifier? (syntax->list (syntax (meth-name ...))))
; (let ()
; (define (expand-contract x y)
; (syntax 1))
; (with-syntax ([(((doms ...) (rngs ...)) ...)
; (map expand-contract
; (syntax->list (syntax (meth-name ...)))
; (syntax->list (syntax (meth-contract ...))))])
; (syntax
; (make-contract
; (lambda (val pos neg src-info)
; (unless (class? val)
; (raise-contract-error src-info pos neg "expected a class, got: ~e" val))
; (let ([class-i (class->interface val)])
; (void)
; (unless (method-in-interface? 'meth-name class-i)
; (raise-contract-error src-info
; pos neg
; "expected class to have method ~a, got: ~e"
; 'meth-name
; val))
; ...)
; (class val
; (define/override (meth-name
; val)))))]
; [(_ (meth-name meth-contract) ...)
; (for-each (lambda (name)
; (unless (identifier? name)
; (raise-syntax-error 'class-contract "expected name" stx name)))
; (syntax->list (syntax (meth-name ...))))]))
; ;
; ;