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

..

Browse Source 
original commit: c90ed312584fd4807ba037ff6ff8c8e9cd8c3c57
This commit is contained in:
Robby Findler 2003-12-04 18:26:57 +00:00
parent a52d7de5ca
commit 2eaf875b8d
2 changed files with 44 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
collects/mzlib/contract.ss
View File

@ -3,7 +3,7 @@
improve method arity mismatch contract violation error messages?
(abstract out -> and friends even more?)
add structu contracts for immutable structs?
add struct contracts for immutable structs?
|#
@ -698,12 +698,33 @@ add structu contracts for immutable structs?
proj-code))))))))))]))
(define (make-opt->/proc method-proc? stx)
(syntax-case stx ()
(syntax-case stx (any)
[(_ (reqs ...) (opts ...) res)
(make-opt->*/proc method-proc? (syntax (opt->* (reqs ...) (opts ...) (res))))]))
(define (make-opt->*/proc method-proc? stx)
(syntax-case stx ()
(syntax-case stx (any)
[(_ (reqs ...) (opts ...) any)
(let* ([req-vs (generate-temporaries (syntax->list (syntax (reqs ...))))]
[opt-vs (generate-temporaries (syntax->list (syntax (opts ...))))]
[cses
(reverse
(let loop ([opt-vs (reverse opt-vs)])
(cond
[(null? opt-vs) (list req-vs)]
[else (cons (append req-vs (reverse opt-vs))
(loop (cdr opt-vs)))])))])
(with-syntax ([(req-vs ...) req-vs]
[(opt-vs ...) opt-vs]
[((case-doms ...) ...) cses])
(with-syntax ([expanded-case->
(make-case->/proc
method-proc?
(syntax (case-> (-> case-doms ... any) ...)))])
(syntax/loc stx
(let ([req-vs reqs] ...
[opt-vs opts] ...)
expanded-case->)))))]
[(_ (reqs ...) (opts ...) (ress ...))
(let* ([res-vs (generate-temporaries (syntax->list (syntax (ress ...))))]
[req-vs (generate-temporaries (syntax->list (syntax (reqs ...))))]
@ -900,6 +921,11 @@ add structu contracts for immutable structs?
(obj-opt->*/proc (syntax (opt->* (any? req-contracts ...) (opt-contracts ...) (res-contracts ...))))
(generate-opt->vars (syntax (req-contracts ...))
(syntax (opt-contracts ...))))]
[(opt->* (req-contracts ...) (opt-contracts ...) any)
(values
(obj-opt->*/proc (syntax (opt->* (any? req-contracts ...) (opt-contracts ...) any)))
(generate-opt->vars (syntax (req-contracts ...))
(syntax (opt-contracts ...))))]
[(opt-> (req-contracts ...) (opt-contracts ...) res-contract)
(values
(obj-opt->/proc (syntax (opt-> (any? req-contracts ...) (opt-contracts ...) res-contract)))
@ -2440,7 +2466,7 @@ add structu contracts for immutable structs?
(define vector-immutableof
(*-immutableof (lambda (x) (and (vector? x) (immutable? x)))
(lambda (f v) (vector->immutable-vector (list->vector (map f (vector->list v)))))
(lambda (f v) (apply vector-immutable (map f (vector->list v))))
immutable-vector
vector-immutableof))

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

@ -121,6 +121,8 @@
(test/no-error '(opt-> ((flat-contract integer?)) ((flat-contract integer?)) (flat-contract integer?)))
(test/no-error '(opt->* (integer?) (integer?) (integer?)))
(test/no-error '(opt->* ((flat-contract integer?)) ((flat-contract integer?)) ((flat-contract integer?))))
(test/no-error '(opt->* (integer?) (integer?) any))
(test/no-error '(opt->* ((flat-contract integer?)) ((flat-contract integer?)) any))
(test/no-error '(listof any?))
(test/no-error '(listof (lambda (x) #t)))
@ -1219,7 +1221,6 @@
'z
#f))
(test/pos-blame
'object-contract->*1
'(contract (object-contract (m (->* (integer?) (boolean?))))
@ -2083,6 +2084,18 @@
(-> integer? boolean? symbol?) ~
(-> integer? boolean? number? symbol?))))")
(object-contract (m (opt->* (integer?) (boolean? number?) (symbol?)))))
(test-name
(format
"(object-contract (m (case-> (-> integer? symbol?) ~
(-> integer? boolean? symbol?) ~
(-> integer? boolean? number? symbol?))))")
(object-contract (m (opt-> (integer?) (boolean? number?) symbol?))))
(test-name
(format
"(object-contract (m (case-> (-> integer? any) ~
(-> integer? boolean? any) ~
(-> integer? boolean? number? any))))")
(object-contract (m (opt->* (integer?) (boolean? number?) any))))
(test-name
(format
"(object-contract (m (case-> (-> integer? (values symbol? boolean?)) ~