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

..

Browse Source 
original commit: b376ca1e36f018af4dc85fc09e170f87021e3212
This commit is contained in:
Robby Findler 2002-05-05 03:35:43 +00:00
parent deab97f184
commit 1e52885bdb
2 changed files with 51 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
collects/framework/specs.ss
View File

@ -166,30 +166,44 @@
(syntax-case stx ()
[(_) (raise-syntax-error '-> "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 ...)))]
[(arg-x ...) (generate-temporaries (syntax (dom ...)))]
[arity (length (syntax->list (syntax (dom ...))))])
(let ([->add-outer-check
(lambda (body)
(with-syntax ([body body])
(syntax
(let ([dom-x dom] ...
[rng-x rng])
(unless (contract-p? dom-x)
(error '-> "expected contract as argument, got ~e" dom-x)) ...
(unless (contract-p? rng-x)
(error '-> "expected contract as argument, got: ~e" rng-x))
body))))]
[->body (syntax (->* (dom-x ...) (rng-x)))])
(let-values ([(->*add-outer-check ->*make-inner-check ->*make-body) (->*/h ->body)])
(values
(lambda (x) (->add-outer-check (->*add-outer-check x)))
(lambda (args)
(->*make-inner-check args))
(lambda (args)
(->*make-body args)))))))]))
(let* ([rng-normal (car (last-pair (syntax->list (syntax (ct ...)))))]
[ignore-range-checking?
(syntax-case rng-normal (any)
[any #t]
[_ #f])])
(with-syntax ([(dom ...) (all-but-last (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 ...)))]
[(arg-x ...) (generate-temporaries (syntax (dom ...)))]
[arity (length (syntax->list (syntax (dom ...))))])
(let ([->add-outer-check
(lambda (body)
(with-syntax ([body body])
(syntax
(let ([dom-x dom] ...
[rng-x rng])
(unless (contract-p? dom-x)
(error '-> "expected contract as argument, got ~e" dom-x)) ...
(unless (contract-p? rng-x)
(error '-> "expected contract as argument, got: ~e" rng-x))
body))))]
[->body (syntax (->* (dom-x ...) (rng-x)))])
(let-values ([(->*add-outer-check ->*make-inner-check ->*make-body) (->*/h ->body)])
(values
(lambda (body) (->add-outer-check (->*add-outer-check body)))
(lambda (stx) (->*make-inner-check stx))
(if ignore-range-checking?
(lambda (stx)
(with-syntax ([(val pos-blame neg-blame src-info) stx])
(syntax
((arg-x ...)
(val
(check-contract dom-x arg-x neg-blame pos-blame src-info)
...)))))
(lambda (stx)
(->*make-body stx)))))))))]))
;; ->*/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
(define (->*/h stx)

13
collects/tests/framework/spec-test.ss
View File

@ -197,6 +197,19 @@
"pos")
(test/spec-passed
'contract-arrow-any1
'(contract (integer? . -> . any) (lambda (x) x) 'pos 'neg))
(test/spec-failed
'contract-arrow-any2
'(contract (integer? . -> . any) (lambda (x y) x) 'pos 'neg)
"pos")
(test/spec-failed
'contract-arrow-any3
'((contract (integer? . -> . any) (lambda (x) #f) 'pos 'neg) #t)
"neg")
(test/spec-passed
'contract-arrow-star-d1