blob: 51cab91cb8f50ce06647c188472c986eb4d69936 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
;;; Guile Emacs Lisp
;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU Lesser General Public License as
;;; published by the Free Software Foundation; either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;;; 02110-1301 USA
;;; Code:
(define-module (language elisp bindings)
#:export (make-bindings
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 globals need to be created, or mark certain
;;; symbols as lexically bound.
;;;
;;; 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 symbols to fluids; those fluids are used in the
;;; with-lexical-binding and with-dynamic-binding routines to associate
;;; symbols to different bindings over a dynamic extent.
;;; Record type used to hold the data necessary.
(define bindings-type
(make-record-type 'bindings '(needed-globals lexical-bindings)))
;;; Construct an 'empty' instance of the bindings data structure to be
;;; used at the start of a fresh compilation.
(define (make-bindings)
((record-constructor bindings-type) '() (make-hash-table)))
;;; Mark that a given symbol is needed as global in the specified
;;; slot-module.
(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-globals)
bindings
new-needed)))
;;; Cycle through all globals needed in order to generate the code for
;;; their creation or some other analysis.
(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)
mod-result
(iterate-modules
(cdr mod-tail)
(let* ((aentry (car mod-tail))
(module (car aentry))
(symbols (cdr aentry)))
(let iterate-symbols ((sym-tail symbols)
(sym-result mod-result))
(if (null? sym-tail)
sym-result
(iterate-symbols (cdr sym-tail)
(cons (proc module (car sym-tail))
sym-result))))))))))
;;; Get the current lexical binding (gensym it should refer to in the
;;; current scope) for a symbol or #f if it is dynamically bound.
(define (get-lexical-binding bindings sym)
(let* ((lex ((record-accessor bindings-type 'lexical-bindings)
bindings))
(slot (hash-ref lex sym #f)))
(if slot
(fluid-ref slot)
#f)))
;;; Establish a binding or mark a symbol as dynamically bound for the
;;; extent of calling proc.
(define (with-symbol-bindings bindings syms targets proc)
(if (or (not (list? syms))
(not (and-map symbol? syms)))
(error "can't bind non-symbols" syms))
(let ((lex ((record-accessor bindings-type 'lexical-bindings)
bindings)))
(for-each (lambda (sym)
(if (not (hash-ref lex sym))
(hash-set! lex sym (make-fluid))))
syms)
(with-fluids* (map (lambda (sym) (hash-ref lex sym)) syms)
targets
proc)))
(define (with-lexical-bindings bindings syms targets proc)
(if (or (not (list? targets))
(not (and-map symbol? targets)))
(error "invalid targets for lexical binding" targets)
(with-symbol-bindings bindings syms targets proc)))
(define (with-dynamic-bindings bindings syms proc)
(with-symbol-bindings bindings
syms
(map (lambda (el) #f) syms)
proc))
|