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

51
collects/mzlib/contract.ss
View File

@ -55,18 +55,13 @@
[(_ name contract-expr expr) [(_ name contract-expr expr)
(identifier? (syntax name)) (identifier? (syntax name))
(with-syntax ([pos-blame-stx (datum->syntax-object define-stx 'here)] (with-syntax ([pos-blame-stx (datum->syntax-object define-stx 'here)]
[contract-id (datum->syntax-object [contract-id
#f (a:mangle-id define-stx
(string->symbol "define/contract-contract-id"
(format (syntax name))]
"define/contract-contract-id-~a" [id (a:mangle-id define-stx
(syntax-object->datum (syntax name)))))] "define/contract-id"
[id (datum->syntax-object (syntax name))])
define-stx
(string->symbol
(format
"define/contract-id-~a"
(syntax-object->datum (syntax name)))))])
(syntax/loc define-stx (syntax/loc define-stx
(begin (begin
(define contract-id contract-expr) (define contract-id contract-expr)
@ -217,9 +212,10 @@
;; first arg is the original syntax object, for source locations ;; first arg is the original syntax object, for source locations
(define (build-struct-code stx struct-name field-names field-contracts) (define (build-struct-code stx struct-name field-names field-contracts)
(let* ([field-contract-ids (map (lambda (field-name) (let* ([field-contract-ids (map (lambda (field-name)
(mangle-id "provide/contract-field-contract" (a:mangle-id provide-stx
field-name "provide/contract-field-contract"
struct-name)) field-name
struct-name))
field-names)] field-names)]
[selector-ids (map (lambda (field-name) [selector-ids (map (lambda (field-name)
(build-selector-id struct-name field-name)) (build-selector-id struct-name field-name))
@ -344,9 +340,9 @@
;; builds a begin expression for the entire contract and provide ;; builds a begin expression for the entire contract and provide
;; the first syntax object is used for source locations ;; the first syntax object is used for source locations
(define (code-for-one-id stx id ctrct) (define (code-for-one-id stx id ctrct)
(with-syntax ([id-rename (mangle-id "provide/contract-id" id)] (with-syntax ([id-rename (a:mangle-id provide-stx "provide/contract-id" id)]
[contract-id (mangle-id "provide/contract-contract-id" id)] [contract-id (a:mangle-id provide-stx "provide/contract-contract-id" id)]
[pos-module-source (mangle-id "provide/contract-pos-module-source" id)] [pos-module-source (a:mangle-id provide-stx "provide/contract-pos-module-source" id)]
[pos-stx (datum->syntax-object provide-stx 'here)] [pos-stx (datum->syntax-object provide-stx 'here)]
[id id] [id id]
[ctrct ctrct]) [ctrct ctrct])
@ -386,25 +382,6 @@
(module-source-as-symbol #'neg-stx) (module-source-as-symbol #'neg-stx)
(quote-syntax _)))]))))))))) (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 ...))))]) (with-syntax ([(bodies ...) (code-for-each-clause (syntax->list (syntax (p/c-ele ...))))])
(syntax (syntax
(begin (begin