From c808c926fd35aeb5a3fd7768ea50edc060d48420 Mon Sep 17 00:00:00 2001 From: Daniel Kraft Date: Fri, 31 Jul 2009 18:00:01 +0200 Subject: [PATCH] Compiler option to always bind certain symbols lexically. Affects so far let-bound symbols, lambda arguments to come in the future. * module/language/elisp/README: Document it. * module/language/elisp/compile-tree-il.scm: Add :always-lexical option. * test-suite/tests/elisp-compiler.test: Test it. --- module/language/elisp/README | 12 ++- module/language/elisp/compile-tree-il.scm | 114 ++++++++++++++-------- test-suite/tests/elisp-compiler.test | 24 ++++- 3 files changed, 104 insertions(+), 46 deletions(-) diff --git a/module/language/elisp/README b/module/language/elisp/README index 004fd971a..be625ffd3 100644 --- a/module/language/elisp/README +++ b/module/language/elisp/README @@ -32,17 +32,18 @@ Especially still missing: Other ideas and things to think about: * %nil vs. #f/'() handling in Guile - * compiler options for all lexical binding Compiler options implemented: * #:disable-void-check ['all / '(sym1 sym2 sym3)] to disable the check for void value on access either completely or for some symbols + * #:always-lexical (usable same as disable-void-check) to always bind + certain or all symbols lexically (including lambda arguments) Extensions over original elisp: * guile-ref, guile-primitive * flet and flet* * lexical-let and lexical-let* - * without-void-checks + * without-void-checks, with-always-lexical Details to the implemented extensions @@ -105,3 +106,10 @@ in the lexical scope of this construct: (without-void-checks all body...) or (without-void-checks (sym1 sym2 ...) body... + +with-always-lexical: +-------------------- + +As without-void-checks but adds to list of symbols that should always be bound +lexically. This lexical binding includes lambda arguments (if the symbols +match up with the list), which can not be bound lexically otherwise. diff --git a/module/language/elisp/compile-tree-il.scm b/module/language/elisp/compile-tree-il.scm index 42daaf10a..14059e65f 100644 --- a/module/language/elisp/compile-tree-il.scm +++ b/module/language/elisp/compile-tree-il.scm @@ -28,7 +28,8 @@ ; Certain common parameters (like the bindings data structure or compiler -; options) are not always passed around but accessed using fluids. +; options) are not always passed around but accessed using fluids to simulate +; dynamic binding (hey, this is about elisp). ; The bindings data structure to keep track of symbol binding related data. (define bindings-data (make-fluid)) @@ -36,6 +37,10 @@ ; Store for which symbols (or all/none) void checks are disabled. (define disable-void-check (make-fluid)) +; Store which symbols (or all/none) should always be bound lexically, even +; with ordinary let and as lambda arguments. +(define always-lexical (make-fluid)) + ; Find the source properties of some parsed expression if there are any ; associated with it. @@ -195,12 +200,15 @@ ; A symbol will be bound lexically if and only if: ; We're processing a lexical-let (i.e. module is 'lexical), OR ; we're processing a value-slot binding AND -; the symbol is already lexically bound. +; the symbol is already lexically bound or it is always lexical. (define (bind-lexically? sym module) (or (eq? module 'lexical) (and (equal? module value-slot) - (get-lexical-binding (fluid-ref bindings-data) sym)))) + (let ((always (fluid-ref always-lexical))) + (or (eq? always 'all) + (memq sym always) + (get-lexical-binding (fluid-ref bindings-data) sym)))))) (define (split-let-bindings bindings module) (let iterate ((tail bindings) @@ -354,9 +362,9 @@ (define (compile-lambda loc args body) (if (not (list? args)) - (error "expected list for argument-list" args)) + (report-error loc "expected list for argument-list" args)) (if (null? body) - (error "function body might not be empty")) + (report-error loc "function body might not be empty")) (with-dynamic-bindings (fluid-ref bindings-data) args (lambda () (call-with-values @@ -500,10 +508,32 @@ (compile-expr (cadr head)) (process-backquote loc head)) processed-tail)))) - (error "non-pair expression contains unquotes" expr)) + (report-error loc "non-pair expression contains unquotes" expr)) (make-const loc expr))) +; Temporarily update a list of symbols that are handled specially (disabled +; void check or always lexical) for compiling body. +; We need to handle special cases for already all / set to all and the like. + +(define (with-added-symbols loc fluid syms body) + (if (null? body) + (report-error loc "symbol-list construct has empty body")) + (if (not (or (eq? syms 'all) + (and (list? syms) (and-map symbol? syms)))) + (report-error loc "invalid symbol list" syms)) + (let ((old (fluid-ref fluid)) + (make-body (lambda () + (make-sequence loc (map compile-expr body))))) + (if (eq? old 'all) + (make-body) + (let ((new (if (eq? syms 'all) + 'all + (append syms old)))) + (with-fluids ((fluid new)) + (make-body)))))) + + ; Compile a symbol expression. This is a variable reference or maybe some ; special value like nil. @@ -610,22 +640,14 @@ (not (null? body)))) (generate-let* loc function-slot bindings body)) - ; Temporarily disable void checks for certain symbols within the lexical - ; scope of without-void-checks. - ((without-void-checks ,syms . ,body) - (guard (and (list? body) (not (null? body)) - (or (eq? syms 'all) - (and (list? syms) (and-map symbol? syms))))) - (let ((disabled (fluid-ref disable-void-check)) - (make-body (lambda () - (make-sequence loc (map compile-expr body))))) - (if (eq? disabled 'all) - (make-body) - (let ((new-disabled (if (eq? syms 'all) - 'all - (append syms disabled)))) - (with-fluid* disable-void-check new-disabled make-body))))) + ; Temporarily disable void checks or set symbols as always lexical only + ; for the lexical scope of a construct. + ((without-void-checks ,syms . ,body) + (with-added-symbols loc disable-void-check syms body)) + + ((with-always-lexical ,syms . ,body) + (with-added-symbols loc always-lexical syms body)) ; guile-ref allows building TreeIL's module references from within ; elisp as a way to access data within @@ -721,7 +743,7 @@ ; just as with defvar/defconst. ((defun ,name ,args . ,body) (if (not (symbol? name)) - (error "expected symbol as function name" name) + (report-error loc "expected symbol as function name" name) (make-sequence loc (list (set-variable! loc name function-slot (compile-lambda loc args body)) @@ -731,10 +753,9 @@ ; FIXME: Recursive macros don't work! ((defmacro ,name ,args . ,body) (if (not (symbol? name)) - (error "expected symbol as macro name" name) - (let* ((tree-il (with-fluid* bindings-data (make-bindings) - (lambda () - (compile-lambda loc args body)))) + (report-error loc "expected symbol as macro name" name) + (let* ((tree-il (with-fluids ((bindings-data (make-bindings))) + (compile-lambda loc args body))) (object (compile tree-il #:from 'tree-il #:to 'value))) (define-macro! loc name object) (make-const loc name)))) @@ -782,20 +803,27 @@ ; Process the compiler options. ; FIXME: Why is '(()) passed as options by the REPL? +(define (valid-symbol-list-arg? value) + (or (eq? value 'all) + (and (list? value) (and-map symbol? value)))) + (define (process-options! opt) (if (and (not (null? opt)) (not (equal? opt '(())))) (if (null? (cdr opt)) - (error "Invalid compiler options" opt) + (report-error #f "Invalid compiler options" opt) (let ((key (car opt)) (value (cadr opt))) (case key ((#:disable-void-check) - (if (and (not (eq? value 'all)) - (not (and (list? value) (and-map symbol? value)))) - (error "Invalid value for #:disable-void-check" value) - (fluid-set! disable-void-check value))) - (else (error "Invalid compiler option" key))))))) + (if (valid-symbol-list-arg? value) + (fluid-set! disable-void-check value) + (report-error #f "Invalid value for #:disable-void-check" value))) + ((#:always-lexical) + (if (valid-symbol-list-arg? value) + (fluid-set! always-lexical value) + (report-error #f "Invalid value for #:always-lexical" value))) + (else (report-error #f "Invalid compiler option" key))))))) ; Entry point for compilation to TreeIL. @@ -805,16 +833,16 @@ (define (compile-tree-il expr env opts) (values - (with-fluids* (list bindings-data disable-void-check) - (list (make-bindings) '()) - (lambda () - (process-options! opts) - (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))) - ,compiled))))) + (with-fluids ((bindings-data (make-bindings)) + (disable-void-check '()) + (always-lexical '())) + (process-options! opts) + (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))) + ,compiled)))) env env)) diff --git a/test-suite/tests/elisp-compiler.test b/test-suite/tests/elisp-compiler.test index 7e013b825..5a9f6fe13 100644 --- a/test-suite/tests/elisp-compiler.test +++ b/test-suite/tests/elisp-compiler.test @@ -342,7 +342,29 @@ (= (funcall c2) 1) (= (funcall c2) 2) (= (funcall c1) 4) - (= (funcall c2) 3)))) + (= (funcall c2) 3))) + + (pass-if "always lexical option (all)" + (progn (setq a 0) + (defun dyna () a) + (let ((a 1)) + (and (= a 1) (= (dyna) 0)))) + #:opts '(#:always-lexical all)) + (pass-if "always lexical option (list)" + (progn (setq a 0 b 0) + (defun dyna () a) + (defun dynb () b) + (let ((a 1) + (b 1)) + (and (= a 1) (= (dyna) 0) + (= b 1) (= (dynb) 1)))) + #:opts '(#:always-lexical (a))) + (pass-if "with-always-lexical" + (progn (setq a 0) + (defun dyna () a) + (with-always-lexical (a) + (let ((a 1)) + (and (= a 1) (= (dyna) 0))))))) (with-test-prefix/compile "defconst and defvar"