summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/elisp/compile-tree-il.scm195
-rw-r--r--test-suite/tests/elisp-compiler.test34
2 files changed, 174 insertions, 55 deletions
diff --git a/module/language/elisp/compile-tree-il.scm b/module/language/elisp/compile-tree-il.scm
index 14059e65f..d079d0526 100644
--- a/module/language/elisp/compile-tree-il.scm
+++ b/module/language/elisp/compile-tree-il.scm
@@ -1,6 +1,6 @@
-;;; Guile Emac Lisp
+;;; Guile Emacs Lisp
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2009 Free Software Foundation, Inc.
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
@@ -24,6 +24,7 @@
#:use-module (language tree-il)
#:use-module (system base pmatch)
#:use-module (system base compile)
+ #:use-module (srfi srfi-1)
#:export (compile-tree-il))
@@ -304,36 +305,74 @@
; Split the argument list of a lambda expression into required, optional and
; rest arguments and also check it is actually valid.
+; Additionally, we create a list of all "local variables" (that is, required,
+; optional and rest arguments together) and also this one split into those to
+; be bound lexically and dynamically.
+; Returned is as multiple values: required optional rest lexical dynamic
+
+(define (bind-arg-lexical? arg)
+ (let ((always (fluid-ref always-lexical)))
+ (or (eq? always 'all)
+ (memq arg always))))
(define (split-lambda-arguments loc args)
(let iterate ((tail args)
(mode 'required)
(required '())
- (optional '()))
+ (optional '())
+ (lexical '())
+ (dynamic '()))
(cond
((null? tail)
- (values (reverse required) (reverse optional) #f))
+ (let ((final-required (reverse required))
+ (final-optional (reverse optional))
+ (final-lexical (reverse lexical))
+ (final-dynamic (reverse dynamic)))
+ (values final-required final-optional #f
+ final-lexical final-dynamic)))
((and (eq? mode 'required)
(eq? (car tail) '&optional))
- (iterate (cdr tail) 'optional required optional))
+ (iterate (cdr tail) 'optional required optional lexical dynamic))
((eq? (car tail) '&rest)
(if (or (null? (cdr tail))
(not (null? (cddr tail))))
(report-error loc "expected exactly one symbol after &rest")
- (values (reverse required) (reverse optional) (cadr tail))))
+ (let* ((rest (cadr tail))
+ (rest-lexical (bind-arg-lexical? rest))
+ (final-required (reverse required))
+ (final-optional (reverse optional))
+ (final-lexical (reverse (if rest-lexical
+ (cons rest lexical)
+ lexical)))
+ (final-dynamic (reverse (if rest-lexical
+ dynamic
+ (cons rest dynamic)))))
+ (values final-required final-optional rest
+ final-lexical final-dynamic))))
(else
(if (not (symbol? (car tail)))
(report-error loc "expected symbol in argument list, got" (car tail))
- (case mode
- ((required) (iterate (cdr tail) mode
- (cons (car tail) required) optional))
- ((optional) (iterate (cdr tail) mode
- required (cons (car tail) optional)))
- ((else) (error "invalid mode in split-lambda-arguments" mode))))))))
+ (let* ((arg (car tail))
+ (bind-lexical (bind-arg-lexical? arg))
+ (new-lexical (if bind-lexical
+ (cons arg lexical)
+ lexical))
+ (new-dynamic (if bind-lexical
+ dynamic
+ (cons arg dynamic))))
+ (case mode
+ ((required) (iterate (cdr tail) mode
+ (cons arg required) optional
+ new-lexical new-dynamic))
+ ((optional) (iterate (cdr tail) mode
+ required (cons arg optional)
+ new-lexical new-dynamic))
+ (else
+ (error "invalid mode in split-lambda-arguments" mode)))))))))
; Compile a lambda expression. Things get a little complicated because TreeIL
@@ -357,77 +396,125 @@
; This is formulated very imperatively, but I think in this case that is quite
; clear and better than creating a lot of nested let's.
;
-; Another thing we have to be aware of is that lambda arguments are always
+; 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.
+; 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
+; register a lexical binding for them (the lexical target variable is already
+; there, namely the real lambda argument from TreeIL).
+; For optional arguments that are lexically bound we need to create the lexical
+; bindings though with an additional let, as those arguments are not part of the
+; ordinary argument list.
(define (compile-lambda loc args body)
(if (not (list? args))
(report-error loc "expected list for argument-list" args))
(if (null? body)
(report-error loc "function body might not be empty"))
- (with-dynamic-bindings (fluid-ref bindings-data) args
+ (call-with-values
(lambda ()
- (call-with-values
- (lambda ()
- (split-lambda-arguments loc args))
- (lambda (required optional rest)
- (let ((required-sym (map (lambda (sym) (gensym)) required))
- (rest-sym (if (or rest (not (null? optional))) (gensym) '())))
- (let ((real-args (append required-sym rest-sym))
- (locals `(,@required ,@optional ,@(if rest (list rest) '()))))
- (make-lambda loc
- real-args real-args '()
- (begin
- (for-each (lambda (sym)
- (mark-fluid-needed! (fluid-ref bindings-data)
- sym value-slot))
- locals)
- (call-primitive loc 'with-fluids*
- (make-application loc (make-primitive-ref loc 'list)
- (map (lambda (sym)
- (make-module-ref loc value-slot sym #t))
- locals))
- (make-application loc (make-primitive-ref loc 'list)
- (append (map (lambda (sym) (make-lexical-ref loc sym sym))
- required-sym)
- (map (lambda (sym) (nil-value loc))
- (if rest
- `(,@optional ,rest-sym)
- optional))))
- (make-lambda loc '() '() '()
- (make-sequence loc
- `(,(process-optionals loc optional rest-sym)
- ,(process-rest loc rest rest-sym)
- ,@(map compile-expr body))))))))))))))
+ (split-lambda-arguments loc args))
+ (lambda (required optional rest lexical dynamic)
+ (let* ((make-sym (lambda (sym) (gensym)))
+ (required-sym (map make-sym required))
+ (required-pairs (map cons required required-sym))
+ (have-real-rest (or rest (not (null? optional))))
+ (rest-sym (if have-real-rest (gensym) '()))
+ (rest-name (if rest rest rest-sym))
+ (rest-lexical (and rest (memq rest lexical)))
+ (rest-dynamic (and rest (not rest-lexical)))
+ (real-args (append required-sym rest-sym))
+ (arg-names (append required rest-name))
+ (lex-optionals (lset-intersection eq? optional lexical))
+ (dyn-optionals (lset-intersection eq? optional dynamic))
+ (optional-sym (map make-sym lex-optionals))
+ (optional-lex-pairs (map cons lex-optionals optional-sym))
+ (find-required-pairs (lambda (filter)
+ (lset-intersection (lambda (name-sym el)
+ (eq? (car name-sym)
+ el))
+ required-pairs filter)))
+ (required-lex-pairs (find-required-pairs lexical))
+ (rest-pair (if rest-lexical `((,rest . ,rest-sym)) '()))
+ (all-lex-pairs (append required-lex-pairs optional-lex-pairs
+ rest-pair)))
+ (for-each (lambda (sym)
+ (mark-fluid-needed! (fluid-ref bindings-data)
+ sym value-slot))
+ dynamic)
+ (with-dynamic-bindings (fluid-ref bindings-data) dynamic
+ (lambda ()
+ (with-lexical-bindings (fluid-ref bindings-data)
+ (map car all-lex-pairs)
+ (map cdr all-lex-pairs)
+ (lambda ()
+ (make-lambda loc
+ arg-names real-args '()
+ (let* ((fluids (map (lambda (sym)
+ (make-module-ref loc value-slot sym #t))
+ dynamic))
+ (init-req (map (lambda (name-sym)
+ (make-lexical-ref loc (car name-sym)
+ (cdr name-sym)))
+ (find-required-pairs dynamic)))
+ (init-nils (map (lambda (sym) (nil-value loc))
+ (if rest-dynamic
+ `(,@dyn-optionals ,rest-sym)
+ dyn-optionals)))
+ (init (append init-req init-nils))
+ (func-body (make-sequence loc
+ `(,(process-optionals loc optional
+ rest-name rest-sym)
+ ,(process-rest loc rest
+ rest-name rest-sym)
+ ,@(map compile-expr body))))
+ (with-fluids-call (call-primitive loc 'with-fluids*
+ (make-application loc
+ (make-primitive-ref loc 'list)
+ 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)
+ full-body
+ (make-let loc
+ optional-sym optional-sym
+ (map (lambda (sym) (nil-value loc)) optional-sym)
+ full-body))))))))))))
; Build the code to handle setting of optional arguments that are present
; and updating the rest list.
-(define (process-optionals loc optional rest-sym)
+(define (process-optionals loc optional rest-name rest-sym)
(let iterate ((tail optional))
(if (null? tail)
(make-void loc)
(make-conditional loc
- (call-primitive loc 'null? (make-lexical-ref loc rest-sym rest-sym))
+ (call-primitive loc 'null? (make-lexical-ref loc rest-name rest-sym))
(make-void loc)
(make-sequence loc
(list (set-variable! loc (car tail) value-slot
(call-primitive loc 'car
- (make-lexical-ref loc rest-sym rest-sym)))
- (make-lexical-set loc rest-sym rest-sym
+ (make-lexical-ref loc rest-name rest-sym)))
+ (make-lexical-set loc rest-name rest-sym
(call-primitive loc 'cdr
- (make-lexical-ref loc rest-sym rest-sym)))
+ (make-lexical-ref loc rest-name rest-sym)))
(iterate (cdr tail))))))))
; This builds the code to set the rest variable to nil if it is empty.
-(define (process-rest loc rest rest-sym)
+(define (process-rest loc rest rest-name rest-sym)
(let ((rest-empty (call-primitive loc 'null?
- (make-lexical-ref loc rest-sym rest-sym))))
+ (make-lexical-ref loc rest-name rest-sym))))
(cond
(rest
(make-conditional loc rest-empty
(make-void loc)
(set-variable! loc rest value-slot
- (make-lexical-ref loc rest-sym rest-sym))))
+ (make-lexical-ref loc rest-name rest-sym))))
((not (null? rest-sym))
(make-conditional loc rest-empty
(make-void loc)
diff --git a/test-suite/tests/elisp-compiler.test b/test-suite/tests/elisp-compiler.test
index 5a9f6fe13..3d3bb1d6e 100644
--- a/test-suite/tests/elisp-compiler.test
+++ b/test-suite/tests/elisp-compiler.test
@@ -327,6 +327,8 @@
(lexical-let ((a 2) (b 42))
(and (= a 2) (= (dyna) 1)
((lambda (a) (and (= a 3) (= b 42) (= (dyna) 3))) 3)
+ ((lambda () (let ((a 3))
+ (and (= a 3) (= (dyna) 1)))))
(= a 2) (= (dyna) 1)))
(= a 1)))
@@ -364,7 +366,37 @@
(defun dyna () a)
(with-always-lexical (a)
(let ((a 1))
- (and (= a 1) (= (dyna) 0)))))))
+ (and (= a 1) (= (dyna) 0))))))
+
+ (pass-if "lexical lambda args"
+ (progn (setq a 1 b 1)
+ (defun dyna () a)
+ (defun dynb () b)
+ (with-always-lexical (a c)
+ ((lambda (a b &optional c)
+ (and (= a 3) (= (dyna) 1)
+ (= b 2) (= (dynb) 2)
+ (= c 1)))
+ 3 2 1))))
+
+ ; Check if a lambda without dynamically bound arguments
+ ; is tail-optimized by doing a deep recursion that would otherwise overflow
+ ; the stack.
+ (pass-if "lexical lambda tail-recursion"
+ (with-always-lexical (i)
+ (setq to 1000000)
+ (defun iteration-1 (i)
+ (if (< i to)
+ (iteration-1 (1+ i))))
+ (iteration-1 0)
+ (setq x 0)
+ (defun iteration-2 ()
+ (if (< x to)
+ (setq x (1+ x))
+ (iteration-2)))
+ (iteration-2)
+ t)))
+
(with-test-prefix/compile "defconst and defvar"