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

.

Browse Source 
original commit: 9e8133b7a9c0bc886d4e9d44bf2dc7671402ac01
This commit is contained in:
Robby Findler 2005-01-21 23:24:29 +00:00
parent d9abc93bbf
commit 7da0f13976
2 changed files with 40 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
collects/mzlib/contract.ss
View File

@ -777,11 +777,13 @@ add struct contracts for immutable structs?
(with-syntax ([proj-code (build-projs outer-args inner-lambda-w/err-check)])
(arguments-check
outer-args
(syntax/loc stx
(make-contract
(apply build-compound-type-name 'case-> name-id)
(lambda (pos-blame neg-blame src-info orig-str)
proj-code))))))))))]))
(set-inferred-name-from
stx
(syntax/loc stx
(make-contract
(apply build-compound-type-name 'case-> name-id)
(lambda (pos-blame neg-blame src-info orig-str)
proj-code)))))))))))]))
(define (make-opt->/proc method-proc? stx)
(syntax-case stx (any)
@ -840,11 +842,16 @@ add struct contracts for immutable structs?
(make-case->/proc
method-proc?
(syntax (case-> (-> case-doms ... single-case-result) ...)))])
(syntax/loc stx
(let ([res-vs ress] ...
[req-vs reqs] ...
[opt-vs opts] ...)
expanded-case->))))))]))
(set-inferred-name-from
stx
(syntax/loc stx
(let ([res-vs ress]
...
[req-vs reqs]
...
[opt-vs opts]
...)
expanded-case->)))))))]))
;; exactract-argument-lists : syntax -> (listof syntax)
(define (extract-argument-lists stx)

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

@ -2591,9 +2591,31 @@
(require (lib "contract.ss"))
(define contract-inferred-name-test-contract (-> integer? any))
(define (contract-inferred-name-test x) #t)
(provide/contract (contract-inferred-name-test contract-inferred-name-test-contract))))
(provide/contract (contract-inferred-name-test contract-inferred-name-test-contract))
(define (contract-inferred-name-test2 x) x)
(provide/contract (contract-inferred-name-test2 (-> number? number?)))
(define (contract-inferred-name-test3 x) x)
(provide/contract (contract-inferred-name-test3 (->* (number?) (number?))))
(define (contract-inferred-name-test4 x) x)
(provide/contract (contract-inferred-name-test4 (case-> (->* (number?) (number?)))))
(define contract-inferred-name-test5 (case-lambda [(x) x] [(x y) x]))
(provide/contract (contract-inferred-name-test5 (case-> (-> number? number?)
(-> number? number? number?))))
(define contract-inferred-name-test6 (case-lambda [(x) x]
[(x y) y]))
(provide/contract (contract-inferred-name-test6 (opt-> (number?) (number?) number?)))))
(eval '(require contract-test-suite-inferred-name1))
(eval '(test 'contract-inferred-name-test object-name contract-inferred-name-test))
(eval '(test 'contract-inferred-name-test2 object-name contract-inferred-name-test2))
(eval '(test 'contract-inferred-name-test3 object-name contract-inferred-name-test3))
(eval '(test 'contract-inferred-name-test4 object-name contract-inferred-name-test4))
(eval '(test 'contract-inferred-name-test5 object-name contract-inferred-name-test5))
(eval '(test 'contract-inferred-name-test6 object-name contract-inferred-name-test6))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;