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

fix problem with lifting contract applications by delaying expansion to an expression context

Browse Source 
svn: r7434
This commit is contained in:
Matthew Flatt 2007-10-05 19:57:05 +00:00
parent 7f78f8e61d
commit 4ebccec087
1 changed files with 30 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
collects/mzlib/private/contract.ss
View File

@ -84,28 +84,36 @@ improve method arity mismatch contract violation error messages?
(make-set!-transformer
(let ([saved-id-table (make-hash-table)])
(λ (stx)
(let ([key (syntax-local-lift-context)])
(unless (hash-table-get saved-id-table key #f)
(with-syntax ([contract-id contract-id]
[id id]
[name (datum->syntax-object #f (syntax-object->datum id) id)]
[pos-module-source pos-module-source])
(hash-table-put!
saved-id-table
key
(syntax-local-introduce
(syntax-local-lift-expression
#'(-contract contract-id
id
pos-module-source
(module-source-as-symbol #'name)
(quote-syntax name)))))))
(with-syntax ([saved-id (syntax-local-introduce (hash-table-get saved-id-table key))])
(syntax-case stx (set!)
[(name arg ...) (syntax/loc stx (saved-id arg ...))]
[name
(identifier? (syntax name))
(syntax saved-id)])))))))
(if (eq? 'expression (syntax-local-context))
;; In an expression context:
(let ([key (syntax-local-lift-context)])
;; Already lifted in this lifting context?
(unless (hash-table-get saved-id-table key #f)
;; No: lift the contract creation:
(with-syntax ([contract-id contract-id]
[id id]
[name (datum->syntax-object #f (syntax-object->datum id) id)]
[pos-module-source pos-module-source])
(hash-table-put!
saved-id-table
key
(syntax-local-introduce
(syntax-local-lift-expression
#'(-contract contract-id
id
pos-module-source
(module-source-as-symbol #'name)
(quote-syntax name)))))))
;; Expand to a use of the lifted expression:
(with-syntax ([saved-id (syntax-local-introduce (hash-table-get saved-id-table key))])
(syntax-case stx (set!)
[(name arg ...) (syntax/loc stx (saved-id arg ...))]
[name
(identifier? (syntax name))
(syntax saved-id)])))
;; In case of partial expansion for module-level and internal-defn contexts,
;; delay expansion until it's a good time to lift expressions:
(quasisyntax/loc stx (#%expression #,stx)))))))
;; (define/contract id contract expr)
;; defines `id' with `contract'; initially binding