.
original commit: ebcb81ce7419824a540b50a86742538e225cff6c
This commit is contained in:
parent
1a90e665b5
commit
f90ee6c074
23
collects/mzlib/private/unitidmap.ss
Normal file
23
collects/mzlib/private/unitidmap.ss
Normal file
|
@ -0,0 +1,23 @@
|
|||
|
||||
(module unitidmap mzscheme
|
||||
|
||||
(define (make-id-mapper unbox-stx)
|
||||
(let ([set!-stx (datum->syntax 'set! #f unbox-stx)])
|
||||
(set!-expander
|
||||
(lambda (sstx)
|
||||
(cond
|
||||
[(identifier? sstx) unbox-stx]
|
||||
[(module-identifier=? set!-stx (car (syntax-e sstx)))
|
||||
(raise-syntax-error
|
||||
'unit
|
||||
"cannot set! imported or exported variables"
|
||||
sstx)]
|
||||
[else
|
||||
(datum->syntax
|
||||
(cons unbox-stx (cdr (syntax-e sstx)))
|
||||
sstx
|
||||
set!-stx)])))))
|
||||
|
||||
(export make-id-mapper))
|
||||
|
||||
|
|
@ -2,7 +2,8 @@
|
|||
;; Unit system
|
||||
|
||||
(module unit mzscheme
|
||||
(import-for-syntax (lib "kerncase.ss" "syntax"))
|
||||
(import-for-syntax (lib "kerncase.ss" "syntax")
|
||||
"private/unitidmap.ss")
|
||||
|
||||
(define undefined (letrec ([x x]) x))
|
||||
|
||||
|
@ -233,28 +234,7 @@
|
|||
(lambda (varloc)
|
||||
(with-syntax ([(var loc) varloc])
|
||||
(syntax
|
||||
[var
|
||||
(set!-expander
|
||||
(lambda (sstx)
|
||||
;; Avoiding syntax-case and other complex macros
|
||||
;; here is a useful optimization, because
|
||||
;; the expression below is expanded for every
|
||||
;; imported and exported identifier.
|
||||
(cond
|
||||
[(identifier? sstx) (quote-syntax (unbox loc))]
|
||||
[(module-identifier=?
|
||||
(quote-syntax set!)
|
||||
(car (syntax-e sstx)))
|
||||
(raise-syntax-error
|
||||
'unit
|
||||
"cannot set! imported or exported variables"
|
||||
sstx)]
|
||||
[else
|
||||
(datum->syntax
|
||||
(cons (quote-syntax (unbox loc))
|
||||
(cdr (syntax-e sstx)))
|
||||
sstx
|
||||
(quote-syntax here))])))])))
|
||||
[var (make-id-mapper (quote-syntax (unbox loc)))])))
|
||||
(syntax->list
|
||||
(syntax ((ivar iloc) ... (expname eloc) ...))))]
|
||||
[num-imports (datum->syntax
|
||||
|
|
Loading…
Reference in New Issue
Block a user