summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/elisp/bindings.scm25
-rw-r--r--module/language/elisp/compile-tree-il.scm115
2 files changed, 78 insertions, 62 deletions
diff --git a/module/language/elisp/bindings.scm b/module/language/elisp/bindings.scm
index 7a437aded..9fabddfc4 100644
--- a/module/language/elisp/bindings.scm
+++ b/module/language/elisp/bindings.scm
@@ -26,7 +26,9 @@
#:export (make-bindings
with-lexical-bindings
with-dynamic-bindings
- get-lexical-binding))
+ with-function-bindings
+ get-lexical-binding
+ get-function-binding))
;;; This module defines routines to handle analysis of symbol bindings
;;; used during elisp compilation. This data allows to collect the
@@ -41,15 +43,16 @@
;;; Record type used to hold the data necessary.
(define-record-type bindings
- (%make-bindings lexical-bindings)
+ (%make-bindings lexical-bindings function-bindings)
bindings?
- (lexical-bindings lexical-bindings set-lexical-bindings!))
+ (lexical-bindings lexical-bindings)
+ (function-bindings function-bindings))
;;; Construct an 'empty' instance of the bindings data structure to be
;;; used at the start of a fresh compilation.
(define (make-bindings)
- (%make-bindings (make-hash-table)))
+ (%make-bindings (make-hash-table) (make-hash-table)))
;;; Get the current lexical binding (gensym it should refer to in the
;;; current scope) for a symbol or #f if it is dynamically bound.
@@ -61,6 +64,10 @@
(fluid-ref slot)
#f)))
+(define (get-function-binding bindings symbol)
+ (and=> (hash-ref (function-bindings bindings) symbol)
+ fluid-ref))
+
;;; Establish a binding or mark a symbol as dynamically bound for the
;;; extent of calling proc.
@@ -88,3 +95,13 @@
syms
(map (lambda (el) #f) syms)
proc))
+
+(define (with-function-bindings bindings symbols gensyms thunk)
+ (let ((fb (function-bindings bindings)))
+ (for-each (lambda (symbol)
+ (if (not (hash-ref fb symbol))
+ (hash-set! fb symbol (make-fluid))))
+ symbols)
+ (with-fluids* (map (cut hash-ref fb <>) symbols)
+ gensyms
+ thunk)))
diff --git a/module/language/elisp/compile-tree-il.scm b/module/language/elisp/compile-tree-il.scm
index c26c33068..0f3aa3c84 100644
--- a/module/language/elisp/compile-tree-il.scm
+++ b/module/language/elisp/compile-tree-il.scm
@@ -108,43 +108,30 @@
(define (report-error loc . args)
(apply error args))
-;;; 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!
-
-(define (access-variable loc
- sym
- module
- handle-global
- handle-lexical
- handle-dynamic)
- (let ((lexical (get-lexical-binding (fluid-ref bindings-data) sym)))
- (cond
- (lexical (handle-lexical lexical))
- ((equal? module function-slot) (handle-global))
- (else (handle-dynamic)))))
-
-;;; Generate code to reference a variable. For references in the
-;;; value-slot module, we may want to generate a lexical reference
-;;; instead if the variable has a lexical binding.
+(define (access-variable loc symbol handle-lexical handle-dynamic)
+ (cond
+ ((get-lexical-binding (fluid-ref bindings-data) symbol)
+ => handle-lexical)
+ (else
+ (handle-dynamic))))
-(define (reference-variable loc sym module)
+(define (reference-variable loc symbol)
(access-variable
loc
- sym
- module
- (lambda () (make-module-ref loc module sym #t))
- (lambda (lexical) (make-lexical-ref loc lexical lexical))
+ symbol
+ (lambda (lexical)
+ (make-lexical-ref loc lexical lexical))
(lambda ()
(call-primitive loc
'fluid-ref
- (make-module-ref loc module sym #t)))))
+ (make-module-ref loc value-slot symbol #t)))))
(define (global? module symbol)
(module-variable module symbol))
(define (ensure-globals! loc names body)
- (if (every (cut global? (resolve-module value-slot) <>) names)
+ (if (and (every (cut global? (resolve-module value-slot) <>) names)
+ (every symbol-interned? names))
body
(make-sequence
loc
@@ -158,28 +145,45 @@
names)
,body))))
-;;; Generate code to set a variable. Just as with reference-variable, in
-;;; case of a reference to value-slot, we want to generate a lexical set
-;;; when the variable has a lexical binding.
-
-(define (set-variable! loc sym module value)
+(define (set-variable! loc symbol value)
(access-variable
loc
- sym
- module
+ symbol
+ (lambda (lexical)
+ (make-lexical-set loc lexical lexical value))
(lambda ()
- (make-application
+ (ensure-globals!
loc
- (make-module-ref loc runtime 'set-symbol-function! #t) ;++ fix
- (list (make-const loc sym) value)))
- (lambda (lexical) (make-lexical-set loc lexical lexical value))
+ (list symbol)
+ (call-primitive loc
+ 'fluid-set!
+ (make-module-ref loc value-slot symbol #t)
+ value)))))
+
+(define (access-function loc symbol handle-lexical handle-global)
+ (cond
+ ((get-function-binding (fluid-ref bindings-data) symbol)
+ => handle-lexical)
+ (else
+ (handle-global))))
+
+(define (reference-function loc symbol)
+ (access-function
+ loc
+ symbol
+ (lambda (gensym) (make-lexical-ref loc symbol gensym))
+ (lambda () (make-module-ref loc function-slot symbol #t))))
+
+(define (set-function! loc symbol value)
+ (access-function
+ loc
+ symbol
+ (lambda (gensym) (make-lexical-set loc symbol gensym value))
(lambda ()
- (ensure-globals! loc
- (list sym)
- (call-primitive loc
- 'fluid-set!
- (make-module-ref loc module sym #t)
- value)))))
+ (make-application
+ loc
+ (make-module-ref loc runtime 'set-symbol-function! #t)
+ (list (make-const loc symbol) value)))))
(define (bind-lexically? sym module decls)
(or (eq? module function-slot)
@@ -447,10 +451,7 @@
((,sym ,value . ,doc)
(if (handle-var-def loc sym doc)
(make-sequence loc
- (list (set-variable! loc
- sym
- value-slot
- (compile-expr value))
+ (list (set-variable! loc sym (compile-expr value))
(make-const loc sym)))))))
(defspecial defvar (loc args)
@@ -477,7 +478,7 @@
(make-module-ref loc value-slot sym #t))
(make-const loc #f))
(make-void loc)
- (set-variable! loc sym value-slot (compile-expr value)))
+ (set-variable! loc sym (compile-expr value)))
(make-const loc sym)))))))
(defspecial setq (loc args)
@@ -495,9 +496,9 @@
(if (not (symbol? sym))
(report-error loc "expected symbol in setq")
(cons
- (set-variable! loc sym value-slot val)
+ (set-variable! loc sym val)
(loop (cddr* args)
- (reference-variable loc sym value-slot)))))))))
+ (reference-variable loc sym)))))))))
(defspecial let (loc args)
(pmatch args
@@ -600,7 +601,7 @@
(let ((names (map car names+vals))
(vals (map cdr names+vals))
(gensyms (map (lambda (x) (gensym)) names+vals)))
- (with-lexical-bindings
+ (with-function-bindings
(fluid-ref bindings-data)
names
gensyms
@@ -619,7 +620,7 @@
(let ((names (map car names+vals))
(vals (map cdr names+vals))
(gensyms (map (lambda (x) (gensym)) names+vals)))
- (with-lexical-bindings
+ (with-function-bindings
(fluid-ref bindings-data)
names
gensyms
@@ -654,7 +655,7 @@
(((lambda ,args . ,body))
(compile-lambda loc '() args body))
((,sym) (guard (symbol? sym))
- (reference-variable loc sym function-slot))))
+ (reference-function loc sym))))
(defspecial defmacro (loc args)
(pmatch args
@@ -665,10 +666,9 @@
(make-sequence
loc
(list
- (set-variable!
+ (set-function!
loc
name
- function-slot
(make-application
loc
(make-module-ref loc '(guile) 'cons #t)
@@ -687,9 +687,8 @@
(if (not (symbol? name))
(report-error loc "expected symbol as function name" name)
(make-sequence loc
- (list (set-variable! loc
+ (list (set-function! loc
name
- function-slot
(compile-lambda loc
`((name . ,name))
args
@@ -741,7 +740,7 @@
(case sym
((nil) (nil-value loc))
((t) (t-value loc))
- (else (reference-variable loc sym value-slot))))
+ (else (reference-variable loc sym))))
;;; Compile a single expression to TreeIL.