75 |
|
|
76 |
(define sc-expand #f) |
(define sc-expand #f) |
77 |
(define sc-expand3 #f) |
(define sc-expand3 #f) |
78 |
|
(define sc-chi #f) |
79 |
(define install-global-transformer #f) |
(define install-global-transformer #f) |
80 |
(define syntax-dispatch #f) |
(define syntax-dispatch #f) |
81 |
(define syntax-error #f) |
(define syntax-error #f) |
131 |
(fluid-set! expansion-eval-closure the-syncase-eval-closure) |
(fluid-set! expansion-eval-closure the-syncase-eval-closure) |
132 |
|
|
133 |
(define (putprop symbol key binding) |
(define (putprop symbol key binding) |
134 |
(let* ((v ((fluid-ref expansion-eval-closure) symbol #t))) |
(let* ((eval-closure (fluid-ref expansion-eval-closure)) |
135 |
(if (symbol-property symbol 'primitive-syntax) |
;; Why not simply do (eval-closure symbol #t)? |
136 |
(if (eq? (fluid-ref expansion-eval-closure) the-syncase-eval-closure) |
;; Answer: That would overwrite imported bindings |
137 |
(set-object-property! (module-variable the-root-module symbol) |
(v (or (eval-closure symbol #f) ;lookup |
138 |
key |
(eval-closure symbol #t) ;create it locally |
139 |
binding)) |
))) |
140 |
|
;; Don't destroy Guile macros corresponding to |
141 |
|
;; primitive syntax when syncase boots. |
142 |
|
(if (not (and (symbol-property symbol 'primitive-syntax) |
143 |
|
(eq? eval-closure the-syncase-eval-closure))) |
144 |
(variable-set! v sc-macro)) |
(variable-set! v sc-macro)) |
145 |
|
;; Properties are tied to variable objects |
146 |
(set-object-property! v key binding))) |
(set-object-property! v key binding))) |
147 |
|
|
148 |
(define (getprop symbol key) |
(define (getprop symbol key) |
149 |
(let* ((v ((fluid-ref expansion-eval-closure) symbol #f))) |
(let* ((v ((fluid-ref expansion-eval-closure) symbol #f))) |
150 |
(and v (or (object-property v key) |
(and v |
151 |
(let ((root-v (module-local-variable the-root-module symbol))) |
(or (object-property v key) |
152 |
(and (equal? root-v v) |
(and (variable-bound? v) |
153 |
(object-property root-v key))))))) |
(macro? (variable-ref v)) |
154 |
|
(macro-transformer (variable-ref v)) ;non-primitive |
155 |
|
guile-macro))))) |
156 |
|
|
157 |
|
(define guile-macro |
158 |
|
(cons 'external-macro |
159 |
|
(lambda (e r w s) |
160 |
|
(if (symbol? e) |
161 |
|
;; pass the expression through |
162 |
|
e |
163 |
|
(let* ((eval-closure (fluid-ref expansion-eval-closure)) |
164 |
|
(m (variable-ref (eval-closure (car e) #f)))) |
165 |
|
(if (eq? (macro-type m) 'syntax) |
166 |
|
;; pass the expression through |
167 |
|
e |
168 |
|
;; perform Guile macro transform |
169 |
|
(let ((e ((macro-transformer m) |
170 |
|
e |
171 |
|
(append r (list eval-closure))))) |
172 |
|
(if (null? r) |
173 |
|
(sc-expand e) |
174 |
|
(sc-chi e r w))))))))) |
175 |
|
|
176 |
(define generated-symbols (make-weak-key-hash-table 1019)) |
(define generated-symbols (make-weak-key-hash-table 1019)) |
177 |
|
|