mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 21:40:33 +02:00
Code Activity

use srfi-9 for elisp bindings records

Browse source 
* module/language/elisp/bindings.scm: Use `(srfi srfi-9)'.
  (bindings-type): Remove low-level record type definition and replace
  with...
  (bindings): ...this, an SRFI-9 record type. All uses changed.
  (mark-global-needed!): Rename to...
  (mark-global!): ...this. All callers changed.
  (map-globals-needed): Rename to...
  (map-globals): ...this. All callers changed.
This commit is contained in:
BT Templeton 2011-07-07 19:30:38 -04:00
parent d5ac6923c3
commit d5da7661c8
2 changed files with 47 additions and 50 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -19,9 +19,10 @@
;;; Code: ;;; Code:
(define-module (language elisp bindings) (define-module (language elisp bindings)
#:use-module (srfi srfi-9)
#:export (make-bindings #:export (make-bindings
mark-global-needed! mark-global!
map-globals-needed map-globals
with-lexical-bindings with-lexical-bindings
with-dynamic-bindings with-dynamic-bindings
get-lexical-binding)) get-lexical-binding))
@ -41,59 +42,56 @@
;;; Record type used to hold the data necessary. ;;; Record type used to hold the data necessary.
(define bindings-type (define-record-type bindings
(make-record-type 'bindings '(needed-globals lexical-bindings))) (%make-bindings globals lexical-bindings)
bindings?
(globals globals set-globals!)
(lexical-bindings lexical-bindings set-lexical-bindings!))
;;; Construct an 'empty' instance of the bindings data structure to be ;;; Construct an 'empty' instance of the bindings data structure to be
;;; used at the start of a fresh compilation. ;;; used at the start of a fresh compilation.
(define (make-bindings) (define (make-bindings)
((record-constructor bindings-type) '() (make-hash-table))) (%make-bindings '() (make-hash-table)))
;;; Mark that a given symbol is needed as global in the specified ;;; Mark that a given symbol is needed as global in the specified
;;; slot-module. ;;; slot-module.
(define (mark-global-needed! bindings sym module) (define (mark-global! bindings sym module)
(let* ((old-needed ((record-accessor bindings-type 'needed-globals) (let* ((old-globals (globals bindings))
bindings)) (old-in-module (or (assoc-ref old-globals 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-globals (assoc-set! old-globals module new-in-module)))
((record-modifier bindings-type 'needed-globals) (set-globals! bindings new-globals)))
bindings
new-needed)))
;;; Cycle through all globals needed in order to generate the code for ;;; Cycle through all globals needed in order to generate the code for
;;; their creation or some other analysis. ;;; their creation or some other analysis.
(define (map-globals-needed bindings proc) (define (map-globals bindings proc)
(let ((needed ((record-accessor bindings-type 'needed-globals) (let iterate-modules ((mod-tail (globals bindings))
bindings))) (mod-result '()))
(let iterate-modules ((mod-tail needed) (if (null? mod-tail)
(mod-result '())) mod-result
(if (null? mod-tail) (iterate-modules
mod-result (cdr mod-tail)
(iterate-modules (let* ((aentry (car mod-tail))
(cdr mod-tail) (module (car aentry))
(let* ((aentry (car mod-tail)) (symbols (cdr aentry)))
(module (car aentry)) (let iterate-symbols ((sym-tail symbols)
(symbols (cdr aentry))) (sym-result mod-result))
(let iterate-symbols ((sym-tail symbols) (if (null? sym-tail)
(sym-result mod-result)) sym-result
(if (null? sym-tail) (iterate-symbols (cdr sym-tail)
sym-result (cons (proc module (car sym-tail))
(iterate-symbols (cdr sym-tail) sym-result)))))))))
(cons (proc module (car sym-tail))
sym-result))))))))))
;;; Get the current lexical binding (gensym it should refer to in the ;;; Get the current lexical binding (gensym it should refer to in the
;;; current scope) for a symbol or #f if it is dynamically bound. ;;; current scope) for a symbol or #f if it is dynamically bound.
(define (get-lexical-binding bindings sym) (define (get-lexical-binding bindings sym)
(let* ((lex ((record-accessor bindings-type 'lexical-bindings) (let* ((lex (lexical-bindings bindings))
bindings))
(slot (hash-ref lex sym #f))) (slot (hash-ref lex sym #f)))
(if slot (if slot
(fluid-ref slot) (fluid-ref slot)
@ -106,8 +104,7 @@
(if (or (not (list? syms)) (if (or (not (list? syms))
(not (and-map symbol? syms))) (not (and-map symbol? syms)))
(error "can't bind non-symbols" syms)) (error "can't bind non-symbols" syms))
(let ((lex ((record-accessor bindings-type 'lexical-bindings) (let ((lex (lexical-bindings bindings)))
bindings)))
(for-each (lambda (sym) (for-each (lambda (sym)
(if (not (hash-ref lex sym)) (if (not (hash-ref lex sym))
(hash-set! lex sym (make-fluid)))) (hash-set! lex sym (make-fluid))))

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

@ -133,9 +133,9 @@
(define (ensuring-globals loc bindings body) (define (ensuring-globals loc bindings body)
(make-sequence (make-sequence
loc loc
`(,@(map-globals-needed (fluid-ref bindings) `(,@(map-globals (fluid-ref bindings)
(lambda (mod sym) (lambda (mod sym)
(generate-ensure-global loc sym mod))) (generate-ensure-global loc sym mod)))
,body))) ,body)))
;;; Build a construct that establishes dynamic bindings for certain ;;; Build a construct that establishes dynamic bindings for certain
@ -185,7 +185,7 @@
(lambda () (make-module-ref loc module sym #t)) (lambda () (make-module-ref loc module sym #t))
(lambda (lexical) (make-lexical-ref loc lexical lexical)) (lambda (lexical) (make-lexical-ref loc lexical lexical))
(lambda () (lambda ()
(mark-global-needed! (fluid-ref bindings-data) sym module) (mark-global! (fluid-ref bindings-data) sym module)
(call-primitive loc (call-primitive loc
'fluid-ref 'fluid-ref
(make-module-ref loc module sym #t))))) (make-module-ref loc module sym #t)))))
@ -206,7 +206,7 @@
(list (make-const loc module) (make-const loc sym) value))) (list (make-const loc module) (make-const loc sym) value)))
(lambda (lexical) (make-lexical-set loc lexical lexical value)) (lambda (lexical) (make-lexical-set loc lexical lexical value))
(lambda () (lambda ()
(mark-global-needed! (fluid-ref bindings-data) sym module) (mark-global! (fluid-ref bindings-data) sym module)
(call-primitive loc (call-primitive loc
'fluid-set! 'fluid-set!
(make-module-ref loc module sym #t) (make-module-ref loc module sym #t)
@ -276,9 +276,9 @@
(lambda () (split-let-bindings bind module)) (lambda () (split-let-bindings bind module))
(lambda (lexical dynamic) (lambda (lexical dynamic)
(for-each (lambda (sym) (for-each (lambda (sym)
(mark-global-needed! (fluid-ref bindings-data) (mark-global! (fluid-ref bindings-data)
sym sym
module)) module))
(map car dynamic)) (map car dynamic))
(let ((make-values (lambda (for) (let ((make-values (lambda (for)
(map (lambda (el) (compile-expr (cdr el))) (map (lambda (el) (compile-expr (cdr el)))
@ -321,9 +321,9 @@
(begin (begin
(for-each (lambda (sym) (for-each (lambda (sym)
(if (not (bind-lexically? sym module)) (if (not (bind-lexically? sym module))
(mark-global-needed! (fluid-ref bindings-data) (mark-global! (fluid-ref bindings-data)
sym sym
module))) module)))
(map car bind)) (map car bind))
(let iterate ((tail bind)) (let iterate ((tail bind))
(if (null? tail) (if (null? tail)
@ -470,9 +470,9 @@
optional-dyn-pairs optional-dyn-pairs
rest-dyn-pairs))) rest-dyn-pairs)))
(for-each (lambda (sym) (for-each (lambda (sym)
(mark-global-needed! (fluid-ref bindings-data) (mark-global! (fluid-ref bindings-data)
sym sym
value-slot)) value-slot))
dynamic) dynamic)
(with-dynamic-bindings (with-dynamic-bindings
(fluid-ref bindings-data) (fluid-ref bindings-data)