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

.

Browse Source 
original commit: c4c18f7c3760988b07816e88d543ed80ec10052a
This commit is contained in:
Robby Findler 2005-01-22 02:06:34 +00:00
parent 7da0f13976
commit 4478596ed2
1 changed files with 18 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
collects/mzlib/contract.ss
View File

@ -704,6 +704,8 @@ add struct contracts for immutable structs?
;
(define (print-me x) (printf "pm: ~s\n" x))
(define-syntax-set (-> ->* ->d ->d* ->r case-> object-contract opt-> opt->*)
(define (->/proc stx) (make-/proc #f ->/h stx))
@ -748,13 +750,11 @@ add struct contracts for immutable structs?
(with-syntax ([proj-code (build-proj outer-args inner-lambda-w/err-check)])
(arguments-check
outer-args
(set-inferred-name-from
stx
(syntax/loc stx
(make-contract
name-id
(lambda (pos-blame neg-blame src-info orig-str)
proj-code))))))))))))
(syntax/loc stx
(make-contract
name-id
(lambda (pos-blame neg-blame src-info orig-str)
proj-code)))))))))))
(define (make-case->/proc method-proc? stx)
(syntax-case stx ()
@ -777,13 +777,11 @@ add struct contracts for immutable structs?
(with-syntax ([proj-code (build-projs outer-args inner-lambda-w/err-check)])
(arguments-check
outer-args
(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)))))))))))]))
(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)
@ -2144,9 +2142,13 @@ add struct contracts for immutable structs?
(let ([name (syntax-local-infer-name with-name)])
(cond
[(identifier? name)
(syntax-property to-be-named 'inferred-name (syntax-e name))]
(with-syntax ([rhs (syntax-property to-be-named 'inferred-name (syntax-e name))]
[name (syntax-e name)])
(syntax (let ([name rhs]) name)))]
[(symbol? name)
(syntax-property to-be-named 'inferred-name name)]
(with-syntax ([rhs (syntax-property to-be-named 'inferred-name name)]
[name name])
(syntax (let ([name rhs]) name)))]
[else to-be-named])))
;; (cons X (listof X)) -> (listof X)