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

..

Browse Source 
original commit: af853d3f74cd131ef89f650b7a190e8be711f59f
This commit is contained in:
Robby Findler 2003-11-10 01:07:27 +00:00
parent bbf5fc4811
commit c97809efad
2 changed files with 39 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
collects/mzlib/contract.ss
View File

@ -2072,6 +2072,7 @@ add structu contracts for immutable structs?
(provide any?
anaphoric-contracts
flat-rec-contract
flat-murec-contract
union
and/c
not/f
@ -2111,6 +2112,38 @@ add structu contracts for immutable structs?
[(_ name ctc ...)
(raise-syntax-error 'flat-rec-contract "expected first argument to be an identifier" stx (syntax name))]))
(define-syntax (flat-murec-contract stx)
(syntax-case stx ()
[(_ ([name ctc ...] ...) body1 body ...)
(andmap identifier? (syntax->list (syntax (name ...))))
(with-syntax ([((ctc-id ...) ...) (map generate-temporaries
(syntax->list (syntax ((ctc ...) ...))))]
[(pred-id ...) (generate-temporaries (syntax (name ...)))]
[((pred-arm-id ...) ...) (map generate-temporaries
(syntax->list (syntax ((ctc ...) ...))))])
(syntax
(let* ([pred-id (lambda (x) (error 'flat-murec-contract "applied too soon"))] ...
[name (flat-contract (let ([name (lambda (x) (pred-id x))]) name))] ...)
(let-values ([(ctc-id ...) (values (coerce-contract flat-rec-contract ctc) ...)] ...)
(begin
(void)
(unless (flat-contract? ctc-id)
(error 'flat-rec-contract "expected flat contracts as arguments, got ~e" ctc-id))
...) ...
(set! pred-id
(let ([pred-arm-id (flat-contract-predicate ctc-id)] ...)
(lambda (x)
(or (pred-arm-id x) ...)))) ...
body1
body ...))))]
[(_ ([name ctc ...] ...) body1 body ...)
(for-each (lambda (name)
(unless (identifier? name)
(raise-syntax-error 'flat-rec-contract
"expected an identifier" stx name))))]
[(_ ([name ctc ...] ...))
(raise-syntax-error 'flat-rec-contract "expected at least one body expression" stx)]))
(define anaphoric-contracts
(case-lambda

5
collects/tests/mzscheme/contract-test.ss
View File

@ -1938,6 +1938,11 @@
(test-flat-contract '(box/p (flat-contract boolean?)) (box #t) #f)
(test-flat-contract '(flat-rec-contract sexp (cons/p sexp sexp) number?) '(1 2 . 3) '(1 . #f))
(test-flat-contract '(flat-murec-contract ([even1 (union null? (cons/p number? even2))]
[even2 (cons/p number? even1)])
even1)
'(1 2 3 4)
'(1 2 3))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;