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

..

Browse Source 
original commit: a99a660bbeec784eb36a4101bb1dd12053679ad1
This commit is contained in:
Robby Findler 2003-10-15 13:21:05 +00:00
parent ebee792a0c
commit ead2460310
2 changed files with 29 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
collects/mzlib/contract.ss
View File

@ -1806,6 +1806,7 @@
(provide any? (provide any?
flat-rec-contract
union union
and/c and/c
not/f not/f
@ -1824,6 +1825,31 @@
box-immutable/c box/p box-immutable/c box/p
mixin-contract make-mixin-contract) mixin-contract make-mixin-contract)
(define-syntax (flat-rec-contract stx)
(syntax-case stx ()
[(_ name ctc ...)
(identifier? (syntax name))
(with-syntax ([(ctc-id ...) (generate-temporaries (syntax (ctc ...)))]
[(pred-id ...) (generate-temporaries (syntax (ctc ...)))])
(syntax
(let* ([pred (lambda (x) (error 'flat-rec-contract "applied too soon"))]
[name (flat-contract (let ([name (lambda (x) (pred x))]) name))])
(let ([ctc-id (coerce-contract flat-rec-contract ctc)] ...)
(begin
(void) ;; ensure begin has at least one arg.
(unless (flat-contract? ctc-id)
(error 'flat-rec-contract "expected flat contracts as arguments, got ~e" ctc-id))
...)
(set! pred
(let ([pred-id (flat-contract-predicate ctc-id)] ...)
(lambda (x)
(or (pred-id x) ...))))
name))))]
[(_ name ctc ...)
(raise-syntax-error 'flat-rec-contract "expected first argument to be an identifier" stx (syntax name))]))
;; tidy contracts
(define (union . args) (define (union . args)
(for-each (for-each
(lambda (x) (lambda (x)

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

@ -1302,6 +1302,8 @@
(test-flat-contract '(box/p boolean?) (box #f) (box 1)) (test-flat-contract '(box/p boolean?) (box #f) (box 1))
(test-flat-contract '(box/p (flat-contract boolean?)) (box #t) #f) (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))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;; ;; ;;
;; case-> arity checking tests ;; ;; case-> arity checking tests ;;
@ -1418,6 +1420,7 @@
(test-name "(box/p boolean?)" (box/p boolean?)) (test-name "(box/p boolean?)" (box/p boolean?))
(test-name "(box/p boolean?)" (box/p (flat-contract boolean?))) (test-name "(box/p boolean?)" (box/p (flat-contract boolean?)))
(test-name "the-name" (flat-rec-contract the-name))
)) ))
(report-errs) (report-errs)