/[guile]/guile/guile-core/ice-9/syncase.scm
ViewVC logotype

Diff of /guile/guile-core/ice-9/syncase.scm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.28 by mdj, Wed Jan 15 20:35:25 2003 UTC revision 1.29 by mdj, Thu Jan 16 11:48:14 2003 UTC
# Line 75  Line 75 
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)
# Line 130  Line 131 
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    

Legend:
Removed from v.1.28  
changed lines
  Added in v.1.29

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26