mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 06:20:23 +02:00
Code Activity

Abstracted dynamic binding a little off the fluids.

Browse source 
* module/language/elisp/compile-tree-il.scm: Move dynamic binding to one place
  and changed names that refer to `fluids' for dynamic binding.
* module/language/elisp/bindings.scm: Changed names referring to `fluids'.
This commit is contained in:
Daniel Kraft 2009-08-04 09:23:02 +02:00
parent f4dc86f137
commit 1b1195f29b
2 changed files with 61 additions and 66 deletions
Download patch file Download diff file Expand all files Collapse all files

22
module/language/elisp/bindings.scm
View file

@ -21,15 +21,15 @@
(define-module (language elisp bindings)
#:export (make-bindings
mark-fluid-needed! map-fluids-needed
mark-global-needed! map-globals-needed
with-lexical-bindings with-dynamic-bindings
get-lexical-binding))
; This module defines routines to handle analysis of symbol bindings used
; during elisp compilation. This data allows to collect the symbols, for
; which fluids need to be created, or mark certain symbols as lexically bound.
; which globals need to be created, or mark certain symbols as lexically bound.
; Needed fluids are stored in an association-list that stores a list of fluids
; Needed globals are stored in an association-list that stores a list of symbols
; for each module they are needed in.
; The lexical bindings of symbols are stored in a hash-table that associates
@ -42,7 +42,7 @@
(define bindings-type
(make-record-type 'bindings
'(needed-fluids lexical-bindings)))
'(needed-globals lexical-bindings)))
; Construct an 'empty' instance of the bindings data structure to be used
@ -52,23 +52,23 @@
((record-constructor bindings-type) '() (make-hash-table)))
; Mark that a given symbol is needed as fluid in the specified slot-module.
; Mark that a given symbol is needed as global in the specified slot-module.
(define (mark-fluid-needed! bindings sym module)
(let* ((old-needed ((record-accessor bindings-type 'needed-fluids) bindings))
(define (mark-global-needed! bindings sym module)
(let* ((old-needed ((record-accessor bindings-type 'needed-globals) bindings))
(old-in-module (or (assoc-ref old-needed module) '()))
(new-in-module (if (memq sym old-in-module)
old-in-module
(cons sym old-in-module)))
(new-needed (assoc-set! old-needed module new-in-module)))
((record-modifier bindings-type 'needed-fluids) bindings new-needed)))
((record-modifier bindings-type 'needed-globals) bindings new-needed)))
; Cycle through all fluids needed in order to generate the code for their
; Cycle through all globals needed in order to generate the code for their
; creation or some other analysis.
(define (map-fluids-needed bindings proc)
(let ((needed ((record-accessor bindings-type 'needed-fluids) bindings)))
(define (map-globals-needed bindings proc)
(let ((needed ((record-accessor bindings-type 'needed-globals) bindings)))
(let iterate-modules ((mod-tail needed)
(mod-result '()))
(if (null? mod-tail)

105
module/language/elisp/compile-tree-il.scm
View file

@ -104,12 +104,12 @@
(cons (make-const loc msg) args)))
; Generate code to ensure a fluid is there for further use of a given symbol.
; In general during the compilation, fluids needed are only tracked with the
; bindings data structure. Afterwards, however, for all those needed symbols
; the fluids are really generated with this routine.
; Generate code to ensure a global symbol is there for further use of a given
; symbol. In general during the compilation, those needed are only tracked with
; the bindings data structure. Afterwards, however, for all those needed
; symbols the globals are really generated with this routine.
(define (generate-ensure-fluid loc sym module)
(define (generate-ensure-global loc sym module)
(make-application loc (make-module-ref loc runtime 'ensure-fluid! #t)
(list (make-const loc module)
(make-const loc sym))))
@ -126,6 +126,21 @@
(not (memq sym disabled))))))
; Build a construct that establishes dynamic bindings for certain variables.
; We may want to choose between binding with fluids and with-fluids* and
; using just ordinary module symbols and setting/reverting their values with
; a dynamic-wind.
(define (let-dynamic loc syms module vals body)
(call-primitive loc 'with-fluids*
(make-application loc (make-primitive-ref loc 'list)
(map (lambda (sym)
(make-module-ref loc module sym #t))
syms))
(make-application loc (make-primitive-ref loc 'list) vals)
(make-lambda loc '() '() '() body)))
; Handle access to a variable (reference/setting) correctly depending on
; whether it is currently lexically or dynamically bound.
; lexical access is done only for references to the value-slot module!
@ -146,7 +161,7 @@
(lambda (lexical)
(make-lexical-ref loc lexical lexical))
(lambda ()
(mark-fluid-needed! (fluid-ref bindings-data) sym module)
(mark-global-needed! (fluid-ref bindings-data) sym module)
(call-primitive loc 'fluid-ref
(make-module-ref loc module sym #t)))))
@ -175,7 +190,7 @@
(lambda (lexical)
(make-lexical-set loc lexical lexical value))
(lambda ()
(mark-fluid-needed! (fluid-ref bindings-data) sym module)
(mark-global-needed! (fluid-ref bindings-data) sym module)
(call-primitive loc 'fluid-set!
(make-module-ref loc module sym #t)
value))))
@ -226,13 +241,13 @@
; and flet/flet*, just with a different bindings module.
;
; A special module value 'lexical means that we're doing a lexical-let instead
; and the bindings should not be safed to fluids at all but be done with the
; and the bindings should not be saved to globals at all but be done with the
; lexical framework instead.
; Let is done with a single call to with-fluids* binding them locally to new
; Let is done with a single call to let-dynamic binding them locally to new
; values all "at once". If there is at least one variable to bind lexically
; among the bindings, we first do a let for all of them to evaluate all
; values before any bindings take place, and then call with-fluids* for the
; values before any bindings take place, and then call let-dynamic for the
; variables to bind dynamically.
(define (generate-let loc module bindings body)
(let ((bind (process-let-bindings loc bindings)))
@ -241,24 +256,17 @@
(split-let-bindings bind module))
(lambda (lexical dynamic)
(for-each (lambda (sym)
(mark-fluid-needed! (fluid-ref bindings-data) sym module))
(mark-global-needed! (fluid-ref bindings-data) sym module))
(map car dynamic))
(let ((fluids (make-application loc (make-primitive-ref loc 'list)
(map (lambda (el)
(make-module-ref loc module (car el) #t))
dynamic)))
(make-values (lambda (for)
(let ((make-values (lambda (for)
(map (lambda (el)
(compile-expr (cdr el)))
for)))
(make-body (lambda ()
(make-sequence loc (map compile-expr body)))))
(if (null? lexical)
(call-primitive loc 'with-fluids*
fluids
(make-application loc (make-primitive-ref loc 'list)
(make-values dynamic))
(make-lambda loc '() '() '() (make-body)))
(let-dynamic loc (map car dynamic) module
(make-values dynamic) (make-body))
(let* ((lexical-syms (map (lambda (el) (gensym)) lexical))
(dynamic-syms (map (lambda (el) (gensym)) dynamic))
(all-syms (append lexical-syms dynamic-syms))
@ -269,12 +277,11 @@
(lambda ()
(if (null? dynamic)
(make-body)
(call-primitive loc 'with-fluids*
fluids
(make-application loc (make-primitive-ref loc 'list)
(map (lambda (sym) (make-lexical-ref loc sym sym))
dynamic-syms))
(make-lambda loc '() '() '() (make-body))))))))))))))
(let-dynamic loc (map car dynamic) module
(map (lambda (sym)
(make-lexical-ref loc sym sym))
dynamic-syms)
(make-body)))))))))))))
; Let* is compiled to a cascaded set of "small lets" for each binding in turn
@ -284,7 +291,7 @@
(begin
(for-each (lambda (sym)
(if (not (bind-lexically? sym module))
(mark-fluid-needed! (fluid-ref bindings-data) sym module)))
(mark-global-needed! (fluid-ref bindings-data) sym module)))
(map car bind))
(let iterate ((tail bind))
(if (null? tail)
@ -298,9 +305,9 @@
`(,sym) `(,target)
(lambda ()
(iterate (cdr tail))))))
(call-primitive loc 'with-fluid*
(make-module-ref loc module (caar tail) #t) value
(make-lambda loc '() '() '() (iterate (cdr tail)))))))))))
(let-dynamic loc
`(,(caar tail)) module `(,value)
(iterate (cdr tail))))))))))
; Split the argument list of a lambda expression into required, optional and
@ -399,7 +406,7 @@
; Another thing we have to be aware of is that lambda arguments are usually
; dynamically bound, even when a lexical binding is in tact for a symbol.
; For symbols that are marked as 'always lexical' however, we bind them here
; lexically, too -- and thus we get them out of the with-fluids* call and
; lexically, too -- and thus we get them out of the let-dynamic call and
; register a lexical binding for them (the lexical target variable is already
; there, namely the real lambda argument from TreeIL).
; For optional arguments that are lexically bound we need to create the lexical
@ -439,8 +446,8 @@
(all-lex-pairs (append required-lex-pairs optional-lex-pairs
rest-pair)))
(for-each (lambda (sym)
(mark-fluid-needed! (fluid-ref bindings-data)
sym value-slot))
(mark-global-needed! (fluid-ref bindings-data)
sym value-slot))
dynamic)
(with-dynamic-bindings (fluid-ref bindings-data) dynamic
(lambda ()
@ -450,10 +457,7 @@
(lambda ()
(make-lambda loc
arg-names real-args '()
(let* ((fluids (map (lambda (sym)
(make-module-ref loc value-slot sym #t))
dynamic))
(init-req (map (lambda (name-sym)
(let* ((init-req (map (lambda (name-sym)
(make-lexical-ref loc (car name-sym)
(cdr name-sym)))
(find-required-pairs dynamic)))
@ -468,18 +472,9 @@
,(process-rest loc rest
rest-name rest-sym)
,@(map compile-expr body))))
(with-fluids-call (call-primitive loc 'with-fluids*
(make-application loc
(make-primitive-ref loc 'list)
fluids)
(make-application loc
(make-primitive-ref loc 'list)
init)
(make-lambda loc '() '() '()
func-body)))
(full-body (if (null? dynamic)
func-body
with-fluids-call)))
(dynlet (let-dynamic loc dynamic value-slot
init func-body))
(full-body (if (null? dynamic) func-body dynlet)))
(if (null? optional-sym)
full-body
(make-let loc
@ -871,8 +866,8 @@
; Entry point for compilation to TreeIL.
; This creates the bindings data structure, and after compiling the main
; expression we need to make sure all fluids for symbols used during the
; compilation are created using the generate-ensure-fluid function.
; expression we need to make sure all globals for symbols used during the
; compilation are created using the generate-ensure-global function.
(define (compile-tree-il expr env opts)
(values
@ -883,9 +878,9 @@
(let ((loc (location expr))
(compiled (compile-expr expr)))
(make-sequence loc
`(,@(map-fluids-needed (fluid-ref bindings-data)
(lambda (mod sym)
(generate-ensure-fluid loc sym mod)))
`(,@(map-globals-needed (fluid-ref bindings-data)
(lambda (mod sym)
(generate-ensure-global loc sym mod)))
,compiled))))
env
env))