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

.

Browse Source 
original commit: 405cb4839a3bc22112b9f96d29b0f1be52327799
This commit is contained in:
Robby Findler 2004-03-12 00:05:36 +00:00
parent 13106dfbd1
commit b0266fa590
2 changed files with 90 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
collects/mzlib/contract.ss
View File

@ -8,11 +8,16 @@ add struct contracts for immutable structs?
|#
(module contract mzscheme
;; no bytes in v206
; (define (bytes? x) #f)
(provide (rename -contract contract)
->
->d
->*
->d*
->r
case->
opt->
opt->*
@ -646,6 +651,50 @@ add struct contracts for immutable structs?
;
;
(define-syntax (->r stx)
(syntax-case stx ()
[(-> ([x dom] ...) rng)
(and (andmap identifier? (syntax->list (syntax (x ...))))
(not (check-duplicate-identifier (syntax->list (syntax (x ...))))))
(with-syntax ([(dom-id ...) (generate-temporaries (syntax (x ...)))]
[arity-count (length (syntax->list (syntax (x ...))))])
(syntax
(make-contract
"name"
(lambda (pos-blame neg-blame src-info orig-str)
(lambda (v)
(unless (procedure? v)
(raise-contract-error src-info
pos-blame
neg-blame
orig-str
"expected a procedure, got ~e"
v))
(unless (procedure-arity-includes? v arity-count)
(raise-contract-error src-info
pos-blame
neg-blame
orig-str
"expected a procedure of arity ~a, got ~e"
arity-count
v))
(lambda (x ...)
(let ([dom-id ((coerce/select-contract ->r dom) pos-blame neg-blame src-info orig-str)]
...
[rng-id ((coerce/select-contract ->r rng) pos-blame neg-blame src-info orig-str)])
(rng-id (v (dom-id x) ...)))))))))]
[(-> ([x dom] ...) rng)
(andmap identifier? (syntax->list (syntax (x ...))))
(raise-syntax-error
'->r
"duplicate identifier"
stx
(check-duplicate-identifier (syntax->list (syntax (x ...)))))]
[(-> ([x dom] ...) rng)
(for-each (lambda (x) (unless (identifier? x) (raise-syntax-error '->r "expected identifier" stx x)))
(syntax->list (syntax (x ...))))]
[(-> x dom rng)
(raise-syntax-error '->r "expected list of identifiers and expression pairs" stx (syntax x))]))
(define-syntax-set (-> ->* ->d ->d* case-> object-contract opt-> opt->*)

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

@ -596,7 +596,47 @@
'pos
'neg)
(lambda () (set! x 2)))))
(test/spec-passed
'->r1
'((contract (->r () number?) (lambda () 1) 'pos 'neg)))
(test/spec-passed
'->r2
'((contract (->r ([x number?]) number?) (lambda (x) (+ x 1)) 'pos 'neg) 1))
(test/pos-blame
'->r3
'((contract (->r () number?) 1 'pos 'neg)))
(test/pos-blame
'->r4
'((contract (->r () number?) (lambda (x) x) 'pos 'neg)))
(test/neg-blame
'->r5
'((contract (->r ([x number?]) (<=/c x)) (lambda (x) (+ x 1)) 'pos 'neg) #f))
(test/pos-blame
'->r6
'((contract (->r ([x number?]) (<=/c x)) (lambda (x) (+ x 1)) 'pos 'neg) 1))
(test/spec-passed
'->r7
'((contract (->r ([x number?][y (<=/c x)]) (<=/c x)) (lambda (x y) (- x 1)) 'pos 'neg) 1 0))
(test/neg-blame
'->r8
'((contract (->r ([x number?][y (<=/c x)]) (<=/c x)) (lambda (x y) (+ x 1)) 'pos 'neg) 1 2))
(test/spec-passed
'->r9
'((contract (->r ([y (<=/c x)][x number?]) (<=/c x)) (lambda (y x) (- x 1)) 'pos 'neg) 1 2))
(test/neg-blame
'->r10
'((contract (->r ([y (<=/c x)][x number?]) (<=/c x)) (lambda (y x) (+ x 1)) 'pos 'neg) 1 0))
#;
(test/neg-blame
'combo1