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

18
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-syntax-set (-> ->* ->d ->d* ->r case-> object-contract opt-> opt->*)
(define (->/proc stx) (make-/proc #f ->/h stx)) (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)]) (with-syntax ([proj-code (build-proj outer-args inner-lambda-w/err-check)])
(arguments-check (arguments-check
outer-args outer-args
(set-inferred-name-from
stx
(syntax/loc stx (syntax/loc stx
(make-contract (make-contract
name-id name-id
(lambda (pos-blame neg-blame src-info orig-str) (lambda (pos-blame neg-blame src-info orig-str)
proj-code)))))))))))) proj-code)))))))))))
(define (make-case->/proc method-proc? stx) (define (make-case->/proc method-proc? stx)
(syntax-case 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)]) (with-syntax ([proj-code (build-projs outer-args inner-lambda-w/err-check)])
(arguments-check (arguments-check
outer-args outer-args
(set-inferred-name-from
stx
(syntax/loc stx (syntax/loc stx
(make-contract (make-contract
(apply build-compound-type-name 'case-> name-id) (apply build-compound-type-name 'case-> name-id)
(lambda (pos-blame neg-blame src-info orig-str) (lambda (pos-blame neg-blame src-info orig-str)
proj-code)))))))))))])) proj-code))))))))))]))
(define (make-opt->/proc method-proc? stx) (define (make-opt->/proc method-proc? stx)
(syntax-case stx (any) (syntax-case stx (any)
@ -2144,9 +2142,13 @@ add struct contracts for immutable structs?
(let ([name (syntax-local-infer-name with-name)]) (let ([name (syntax-local-infer-name with-name)])
(cond (cond
[(identifier? name) [(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) [(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]))) [else to-be-named])))
;; (cons X (listof X)) -> (listof X) ;; (cons X (listof X)) -> (listof X)