mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 14:50:19 +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) (define-module (language elisp bindings)
#:export (make-bindings #:export (make-bindings
mark-fluid-needed! map-fluids-needed mark-global-needed! map-globals-needed
with-lexical-bindings with-dynamic-bindings with-lexical-bindings with-dynamic-bindings
get-lexical-binding)) get-lexical-binding))
; This module defines routines to handle analysis of symbol bindings used ; This module defines routines to handle analysis of symbol bindings used
; during elisp compilation. This data allows to collect the symbols, for ; 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. ; for each module they are needed in.
; The lexical bindings of symbols are stored in a hash-table that associates ; The lexical bindings of symbols are stored in a hash-table that associates
@ -42,7 +42,7 @@
(define bindings-type (define bindings-type
(make-record-type 'bindings (make-record-type 'bindings
'(needed-fluids lexical-bindings))) '(needed-globals lexical-bindings)))
; Construct an 'empty' instance of the bindings data structure to be used ; Construct an 'empty' instance of the bindings data structure to be used
@ -52,23 +52,23 @@
((record-constructor bindings-type) '() (make-hash-table))) ((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) (define (mark-global-needed! bindings sym module)
(let* ((old-needed ((record-accessor bindings-type 'needed-fluids) bindings)) (let* ((old-needed ((record-accessor bindings-type 'needed-globals) bindings))
(old-in-module (or (assoc-ref old-needed module) '())) (old-in-module (or (assoc-ref old-needed module) '()))
(new-in-module (if (memq sym old-in-module) (new-in-module (if (memq sym old-in-module)
old-in-module old-in-module
(cons sym old-in-module))) (cons sym old-in-module)))
(new-needed (assoc-set! old-needed module new-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. ; creation or some other analysis.
(define (map-fluids-needed bindings proc) (define (map-globals-needed bindings proc)
(let ((needed ((record-accessor bindings-type 'needed-fluids) bindings))) (let ((needed ((record-accessor bindings-type 'needed-globals) bindings)))
(let iterate-modules ((mod-tail needed) (let iterate-modules ((mod-tail needed)
(mod-result '())) (mod-result '()))
(if (null? mod-tail) (if (null? mod-tail)

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

@ -104,12 +104,12 @@
(cons (make-const loc msg) args))) (cons (make-const loc msg) args)))
; Generate code to ensure a fluid is there for further use of a given symbol. ; Generate code to ensure a global symbol is there for further use of a given
; In general during the compilation, fluids needed are only tracked with the ; symbol. In general during the compilation, those needed are only tracked with
; bindings data structure. Afterwards, however, for all those needed symbols ; the bindings data structure. Afterwards, however, for all those needed
; the fluids are really generated with this routine. ; 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) (make-application loc (make-module-ref loc runtime 'ensure-fluid! #t)
(list (make-const loc module) (list (make-const loc module)
(make-const loc sym)))) (make-const loc sym))))
@ -126,6 +126,21 @@
(not (memq sym disabled)))))) (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 ; Handle access to a variable (reference/setting) correctly depending on
; whether it is currently lexically or dynamically bound. ; whether it is currently lexically or dynamically bound.
; lexical access is done only for references to the value-slot module! ; lexical access is done only for references to the value-slot module!
@ -146,7 +161,7 @@
(lambda (lexical) (lambda (lexical)
(make-lexical-ref loc lexical lexical)) (make-lexical-ref loc lexical lexical))
(lambda () (lambda ()
(mark-fluid-needed! (fluid-ref bindings-data) sym module) (mark-global-needed! (fluid-ref bindings-data) sym module)
(call-primitive loc 'fluid-ref (call-primitive loc 'fluid-ref
(make-module-ref loc module sym #t))))) (make-module-ref loc module sym #t)))))
@ -175,7 +190,7 @@
(lambda (lexical) (lambda (lexical)
(make-lexical-set loc lexical lexical value)) (make-lexical-set loc lexical lexical value))
(lambda () (lambda ()
(mark-fluid-needed! (fluid-ref bindings-data) sym module) (mark-global-needed! (fluid-ref bindings-data) sym module)
(call-primitive loc 'fluid-set! (call-primitive loc 'fluid-set!
(make-module-ref loc module sym #t) (make-module-ref loc module sym #t)
value)))) value))))
@ -226,13 +241,13 @@
; and flet/flet*, just with a different bindings module. ; and flet/flet*, just with a different bindings module.
; ;
; A special module value 'lexical means that we're doing a lexical-let instead ; 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. ; 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 ; 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 ; 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. ; variables to bind dynamically.
(define (generate-let loc module bindings body) (define (generate-let loc module bindings body)
(let ((bind (process-let-bindings loc bindings))) (let ((bind (process-let-bindings loc bindings)))
@ -241,24 +256,17 @@
(split-let-bindings bind module)) (split-let-bindings bind module))
(lambda (lexical dynamic) (lambda (lexical dynamic)
(for-each (lambda (sym) (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)) (map car dynamic))
(let ((fluids (make-application loc (make-primitive-ref loc 'list) (let ((make-values (lambda (for)
(map (lambda (el)
(make-module-ref loc module (car el) #t))
dynamic)))
(make-values (lambda (for)
(map (lambda (el) (map (lambda (el)
(compile-expr (cdr el))) (compile-expr (cdr el)))
for))) for)))
(make-body (lambda () (make-body (lambda ()
(make-sequence loc (map compile-expr body))))) (make-sequence loc (map compile-expr body)))))
(if (null? lexical) (if (null? lexical)
(call-primitive loc 'with-fluids* (let-dynamic loc (map car dynamic) module
fluids (make-values dynamic) (make-body))
(make-application loc (make-primitive-ref loc 'list)
(make-values dynamic))
(make-lambda loc '() '() '() (make-body)))
(let* ((lexical-syms (map (lambda (el) (gensym)) lexical)) (let* ((lexical-syms (map (lambda (el) (gensym)) lexical))
(dynamic-syms (map (lambda (el) (gensym)) dynamic)) (dynamic-syms (map (lambda (el) (gensym)) dynamic))
(all-syms (append lexical-syms dynamic-syms)) (all-syms (append lexical-syms dynamic-syms))
@ -269,12 +277,11 @@
(lambda () (lambda ()
(if (null? dynamic) (if (null? dynamic)
(make-body) (make-body)
(call-primitive loc 'with-fluids* (let-dynamic loc (map car dynamic) module
fluids (map (lambda (sym)
(make-application loc (make-primitive-ref loc 'list) (make-lexical-ref loc sym sym))
(map (lambda (sym) (make-lexical-ref loc sym sym)) dynamic-syms)
dynamic-syms)) (make-body)))))))))))))
(make-lambda loc '() '() '() (make-body))))))))))))))
; Let* is compiled to a cascaded set of "small lets" for each binding in turn ; Let* is compiled to a cascaded set of "small lets" for each binding in turn
@ -284,7 +291,7 @@
(begin (begin
(for-each (lambda (sym) (for-each (lambda (sym)
(if (not (bind-lexically? sym module)) (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)) (map car bind))
(let iterate ((tail bind)) (let iterate ((tail bind))
(if (null? tail) (if (null? tail)
@ -298,9 +305,9 @@
`(,sym) `(,target) `(,sym) `(,target)
(lambda () (lambda ()
(iterate (cdr tail)))))) (iterate (cdr tail))))))
(call-primitive loc 'with-fluid* (let-dynamic loc
(make-module-ref loc module (caar tail) #t) value `(,(caar tail)) module `(,value)
(make-lambda loc '() '() '() (iterate (cdr tail))))))))))) (iterate (cdr tail))))))))))
; Split the argument list of a lambda expression into required, optional and ; 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 ; 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. ; 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 ; 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 ; register a lexical binding for them (the lexical target variable is already
; there, namely the real lambda argument from TreeIL). ; there, namely the real lambda argument from TreeIL).
; For optional arguments that are lexically bound we need to create the lexical ; 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 (all-lex-pairs (append required-lex-pairs optional-lex-pairs
rest-pair))) rest-pair)))
(for-each (lambda (sym) (for-each (lambda (sym)
(mark-fluid-needed! (fluid-ref bindings-data) (mark-global-needed! (fluid-ref bindings-data)
sym value-slot)) sym value-slot))
dynamic) dynamic)
(with-dynamic-bindings (fluid-ref bindings-data) dynamic (with-dynamic-bindings (fluid-ref bindings-data) dynamic
(lambda () (lambda ()
@ -450,10 +457,7 @@
(lambda () (lambda ()
(make-lambda loc (make-lambda loc
arg-names real-args '() arg-names real-args '()
(let* ((fluids (map (lambda (sym) (let* ((init-req (map (lambda (name-sym)
(make-module-ref loc value-slot sym #t))
dynamic))
(init-req (map (lambda (name-sym)
(make-lexical-ref loc (car name-sym) (make-lexical-ref loc (car name-sym)
(cdr name-sym))) (cdr name-sym)))
(find-required-pairs dynamic))) (find-required-pairs dynamic)))
@ -468,18 +472,9 @@
,(process-rest loc rest ,(process-rest loc rest
rest-name rest-sym) rest-name rest-sym)
,@(map compile-expr body)))) ,@(map compile-expr body))))
(with-fluids-call (call-primitive loc 'with-fluids* (dynlet (let-dynamic loc dynamic value-slot
(make-application loc init func-body))
(make-primitive-ref loc 'list) (full-body (if (null? dynamic) func-body dynlet)))
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)))
(if (null? optional-sym) (if (null? optional-sym)
full-body full-body
(make-let loc (make-let loc
@ -871,8 +866,8 @@
; Entry point for compilation to TreeIL. ; Entry point for compilation to TreeIL.
; This creates the bindings data structure, and after compiling the main ; This creates the bindings data structure, and after compiling the main
; expression we need to make sure all fluids for symbols used during the ; expression we need to make sure all globals for symbols used during the
; compilation are created using the generate-ensure-fluid function. ; compilation are created using the generate-ensure-global function.
(define (compile-tree-il expr env opts) (define (compile-tree-il expr env opts)
(values (values
@ -883,9 +878,9 @@
(let ((loc (location expr)) (let ((loc (location expr))
(compiled (compile-expr expr))) (compiled (compile-expr expr)))
(make-sequence loc (make-sequence loc
`(,@(map-fluids-needed (fluid-ref bindings-data) `(,@(map-globals-needed (fluid-ref bindings-data)
(lambda (mod sym) (lambda (mod sym)
(generate-ensure-fluid loc sym mod))) (generate-ensure-global loc sym mod)))
,compiled)))) ,compiled))))
env env
env)) env))