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

lift a few fewer negative parties

Browse Source
This commit is contained in:
Robby Findler 2015-08-25 05:08:24 -05:00
parent 3d452fdba6
commit a1e6c94fda
1 changed files with 6 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
racket/collects/racket/contract/private/provide.rkt
View File

@ -92,9 +92,10 @@
(define (contract-neg-party-property stx)
(syntax-property stx neg-party-key))
(define global-saved-id-table (make-hasheq))
(struct provide/contract-arrow-transformer provide/contract-info
(saved-id-table
saved-ho-id-table
(saved-ho-id-table
partially-applied-id
extra-neg-party-argument-fn
valid-argument-lists)
@ -102,7 +103,6 @@
prop:set!-transformer
(λ (self stx)
(let ([partially-applied-id (provide/contract-arrow-transformer-partially-applied-id self)]
[saved-id-table (provide/contract-arrow-transformer-saved-id-table self)]
[saved-ho-id-table (provide/contract-arrow-transformer-saved-ho-id-table self)]
[extra-neg-party-argument-fn
(provide/contract-arrow-transformer-extra-neg-party-argument-fn self)]
@ -115,12 +115,12 @@
(let* ([key (syntax-local-lift-context)]
;; Already lifted in this lifting context?
[lifted-neg-party
(or (hash-ref saved-id-table key #f)
(or (hash-ref global-saved-id-table key #f)
;; No: lift the neg name creation
(syntax-local-introduce
(syntax-local-lift-expression
#'(quote-module-name))))])
(when key (hash-set! saved-id-table key lifted-neg-party))
(when key (hash-set! global-saved-id-table key lifted-neg-party))
;; Expand to a use of the lifted expression:
(define (adjust-location new-stx)
(datum->syntax new-stx (syntax-e new-stx) stx new-stx))
@ -161,7 +161,6 @@
;; expressions:
(quasisyntax/loc stx (#%expression #,stx)))))))
(struct provide/contract-transformer provide/contract-info (saved-id-table partially-applied-id)
#:property
prop:set!-transformer
@ -222,7 +221,7 @@
(define (make-provide/contract-arrow-transformer rename-id contract-id id pai enpfn val)
(provide/contract-arrow-transformer rename-id
contract-id id
(make-hasheq) (make-hasheq)
(make-hasheq)
pai enpfn val)))