[Guile-commits] GNU Guile branch, elisp, updated. release_1-9-1-67-gdfbc6e9

[Daniel Kraft]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=dfbc6e9d5415def4cf61c9caa9f44af056348741

The branch, elisp has been updated
       via  dfbc6e9d5415def4cf61c9caa9f44af056348741 (commit)
      from  c808c926fd35aeb5a3fd7768ea50edc060d48420 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit dfbc6e9d5415def4cf61c9caa9f44af056348741
Author: Daniel Kraft <address@hidden>
Date:   Sat Aug 1 13:00:27 2009 +0200

    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.

-----------------------------------------------------------------------

Summary of changes:
 module/language/elisp/compile-tree-il.scm |  195 +++++++++++++++++++++--------
 test-suite/tests/elisp-compiler.test      |   34 +++++-
 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 14059e6..d079d05 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 5a9f6fe..3d3bb1d 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"
 


hooks/post-receive
-- 
GNU Guile