Allow lexical binding of lambda arguments.

* module/language/elisp/compile-tree-il.scm: Rework lambda compiler to allow
  opional lexical binding of (some) lambda arguments.
* test-suite/tests/elisp-compiler.test: Check this.

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))
+          (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 (car tail) required) optional))
+                                   (cons arg required) optional
+                                   new-lexical new-dynamic))
               ((optional) (iterate (cdr tail) mode
-                                 required (cons (car tail) optional)))
+                                   required (cons arg optional)
-            ((else) (error "invalid mode in split-lambda-arguments" mode))))))))
+                                   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
-    (lambda ()
   (call-with-values
     (lambda ()
       (split-lambda-arguments loc args))
-        (lambda (required optional rest)
+    (lambda (required optional rest lexical dynamic)
-          (let ((required-sym (map (lambda (sym) (gensym)) required))
+      (let* ((make-sym (lambda (sym) (gensym)))
-                (rest-sym (if (or rest (not (null? optional))) (gensym) '())))
+             (required-sym (map make-sym required))
-            (let ((real-args (append required-sym rest-sym))
+             (required-pairs (map cons required required-sym))
-                  (locals `(,@required ,@optional ,@(if rest (list rest) '()))))
+             (have-real-rest (or rest (not (null? optional))))
-              (make-lambda loc
+             (rest-sym (if have-real-rest (gensym) '()))
-                real-args real-args '()
+             (rest-name (if rest rest rest-sym))
-                (begin
+             (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))
-                            locals)
+                  dynamic)
-                  (call-primitive loc 'with-fluids*
+        (with-dynamic-bindings (fluid-ref bindings-data) dynamic
-                    (make-application loc (make-primitive-ref loc 'list)
+          (lambda ()
-                      (map (lambda (sym)
+            (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))
-                           locals))
+                                      dynamic))
-                    (make-application loc (make-primitive-ref loc 'list)
+                         (init-req (map (lambda (name-sym)
-                      (append (map (lambda (sym) (make-lexical-ref loc sym sym))
+                                          (make-lexical-ref loc (car name-sym)
-                                   required-sym)
+                                                                (cdr name-sym)))
-                              (map (lambda (sym) (nil-value loc))
+                                        (find-required-pairs dynamic)))
-                                   (if rest
+                         (init-nils (map (lambda (sym) (nil-value loc))
-                                     `(,@optional ,rest-sym)
+                                         (if rest-dynamic
-                                     optional))))
+                                           `(,@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 '() '() '()
-                      (make-sequence loc
+                                               func-body)))
-                        `(,(process-optionals loc optional rest-sym)
+                         (full-body (if (null? dynamic)
-                          ,(process-rest loc rest rest-sym)
+                                      func-body
-                          ,@(map compile-expr 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-ref loc rest-name rest-sym)))
-                (make-lexical-set loc rest-sym 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)

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"