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

.

Browse Source 
original commit: dd1ae6969091319c290c26c8d44239a118f5283e
This commit is contained in:
Robby Findler 2003-03-26 18:58:49 +00:00
parent b3ba8e8899
commit a42d30f299
1 changed files with 14 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
collects/mzlib/contract.ss
View File

@ -55,18 +55,13 @@
[(_ name contract-expr expr)
(identifier? (syntax name))
(with-syntax ([pos-blame-stx (datum->syntax-object define-stx 'here)]
[contract-id (datum->syntax-object
#f
(string->symbol
(format
"define/contract-contract-id-~a"
(syntax-object->datum (syntax name)))))]
[id (datum->syntax-object
define-stx
(string->symbol
(format
"define/contract-id-~a"
(syntax-object->datum (syntax name)))))])
[contract-id
(a:mangle-id define-stx
"define/contract-contract-id"
(syntax name))]
[id (a:mangle-id define-stx
"define/contract-id"
(syntax name))])
(syntax/loc define-stx
(begin
(define contract-id contract-expr)
@ -217,7 +212,8 @@
;; first arg is the original syntax object, for source locations
(define (build-struct-code stx struct-name field-names field-contracts)
(let* ([field-contract-ids (map (lambda (field-name)
(mangle-id "provide/contract-field-contract"
(a:mangle-id provide-stx
"provide/contract-field-contract"
field-name
struct-name))
field-names)]
@ -344,9 +340,9 @@
;; builds a begin expression for the entire contract and provide
;; the first syntax object is used for source locations
(define (code-for-one-id stx id ctrct)
(with-syntax ([id-rename (mangle-id "provide/contract-id" id)]
[contract-id (mangle-id "provide/contract-contract-id" id)]
[pos-module-source (mangle-id "provide/contract-pos-module-source" id)]
(with-syntax ([id-rename (a:mangle-id provide-stx "provide/contract-id" id)]
[contract-id (a:mangle-id provide-stx "provide/contract-contract-id" id)]
[pos-module-source (a:mangle-id provide-stx "provide/contract-pos-module-source" id)]
[pos-stx (datum->syntax-object provide-stx 'here)]
[id id]
[ctrct ctrct])
@ -386,25 +382,6 @@
(module-source-as-symbol #'neg-stx)
(quote-syntax _)))])))))))))
;; mangle-id : string syntax ... -> syntax
;; constructs a mangled name of an identifier from an identifier
;; the name isn't fresh, so `id' combined with `ids' must already be unique.
(define (mangle-id prefix id . ids)
(datum->syntax-object
(syntax-local-introduce provide-stx)
(string->symbol
(string-append
prefix
(format
"-~a~a"
(syntax-object->datum id)
(apply
string-append
(map
(lambda (id)
(format "-~a" (syntax-object->datum id)))
ids)))))))
(with-syntax ([(bodies ...) (code-for-each-clause (syntax->list (syntax (p/c-ele ...))))])
(syntax
(begin