mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-15 10:10:21 +02:00
Code Activity

Support loading of compiled syncase macros

Browse source 
* ice-9/syncase.scm (current-eval-closure): New procedure.
  (env->eval-closure): Don't default to the root module: if we have no
  environment, we default to the current module via the logic in
  current-eval-closure. This is because psyntax's compilation mode
  doesn't know about guile modules, and thus won't dump the code to
  twiddle the current eval closure.
  (putprop, getprop, guile-macro): Use `current-eval-closure'.
  At the end, leave the expansion-eval-closure set to #f.
This commit is contained in:
Andy Wingo 2008-05-19 12:19:28 +02:00
parent 2b70bf0eb3
commit 6b1a13744b
1 changed files with 8 additions and 7 deletions
Download patch file Download diff file Expand all files Collapse all files

15
ice-9/syncase.scm
View file

@ -35,11 +35,12 @@
(define expansion-eval-closure (make-fluid)) (define expansion-eval-closure (make-fluid))
(define (current-eval-closure)
(or (fluid-ref expansion-eval-closure)
(module-eval-closure (current-module))))
(define (env->eval-closure env) (define (env->eval-closure env)
(or (and env (and env (car (last-pair env))))
(car (last-pair env)))
(module-eval-closure the-root-module)))
(define sc-macro (define sc-macro
(procedure->memoizing-macro (procedure->memoizing-macro
@ -107,7 +108,7 @@
(fluid-set! expansion-eval-closure the-syncase-eval-closure) (fluid-set! expansion-eval-closure the-syncase-eval-closure)
(define (putprop symbol key binding) (define (putprop symbol key binding)
(let* ((eval-closure (fluid-ref expansion-eval-closure)) (let* ((eval-closure (current-eval-closure))
;; Why not simply do (eval-closure symbol #t)? ;; Why not simply do (eval-closure symbol #t)?
;; Answer: That would overwrite imported bindings ;; Answer: That would overwrite imported bindings
(v (or (eval-closure symbol #f) ;lookup (v (or (eval-closure symbol #f) ;lookup
@ -122,7 +123,7 @@
(set-object-property! v key binding))) (set-object-property! v key binding)))
(define (getprop symbol key) (define (getprop symbol key)
(let* ((v ((fluid-ref expansion-eval-closure) symbol #f))) (let* ((v ((current-eval-closure) symbol #f)))
(and v (and v
(or (object-property v key) (or (object-property v key)
(and (variable-bound? v) (and (variable-bound? v)
@ -137,7 +138,7 @@
(if (symbol? e) (if (symbol? e)
;; pass the expression through ;; pass the expression through
e e
(let* ((eval-closure (fluid-ref expansion-eval-closure)) (let* ((eval-closure (current-eval-closure))
(m (variable-ref (eval-closure (car e) #f)))) (m (variable-ref (eval-closure (car e) #f))))
(if (eq? (macro-type m) 'syntax) (if (eq? (macro-type m) 'syntax)
;; pass the expression through ;; pass the expression through
@ -244,4 +245,4 @@
;(eval-case ((load-toplevel) (export-syntax name))) ;(eval-case ((load-toplevel) (export-syntax name)))
(define-syntax name rules ...))))) (define-syntax name rules ...)))))
(fluid-set! expansion-eval-closure (env->eval-closure #f)) (fluid-set! expansion-eval-closure #f)