[Guile-commits] GNU Guile branch, elisp, updated. release_1-9-1-29-g35b2e41

[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=35b2e41d6d8040251a5775fc33d7158b9598ea1c

The branch, elisp has been updated
       via  35b2e41d6d8040251a5775fc33d7158b9598ea1c (commit)
      from  5d221ca375e5bd762b0b8fb16b22118d2a077de9 (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 35b2e41d6d8040251a5775fc33d7158b9598ea1c
Author: Daniel Kraft <address@hidden>
Date:   Wed Jul 22 12:23:03 2009 +0200

    Implemented catch and throw in elisp.
    
    * module/language/elisp/README: Document this.
    * module/language/elisp/compile-tree-il.scm: Implement catch and throw.
    * test-suite/tests/elisp-compiler.test: Test catch/throw.

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

Summary of changes:
 module/language/elisp/README              |    5 ++-
 module/language/elisp/compile-tree-il.scm |   41 ++++++++++++++++++++++++++++-
 test-suite/tests/elisp-compiler.test      |   22 +++++++++++++++
 3 files changed, 65 insertions(+), 3 deletions(-)

diff --git a/module/language/elisp/README b/module/language/elisp/README
index 42a9bc6..0eb3799 100644
--- a/module/language/elisp/README
+++ b/module/language/elisp/README
@@ -10,6 +10,7 @@ Already implemented:
   * not, and, or
   * referencing and setting (setq) variables
   * while, dotimes, dolist
+  * catch, throw
   * let, let*
   * lambda expressions, function calls using list notation
   * some built-ins (mainly numbers/arithmetic)
@@ -18,7 +19,7 @@ Already implemented:
   * quotation and backquotation with unquote/unquote-splicing
 
 Especially still missing:
-  * catch/throw, unwind-protect
+  * unwind-protect
   * real elisp reader instead of Scheme's
   * set, makunbound, boundp functions
   * more general built-ins
@@ -32,4 +33,4 @@ Especially still missing:
 
 Other ideas and things to think about:
   * %nil vs. #f/'() handling in Guile
-  * don't ensure-fluids for variables known to be let- or argument-bound
+  * flet, lexical-let and/or optional lexical binding as extensions
diff --git a/module/language/elisp/compile-tree-il.scm 
b/module/language/elisp/compile-tree-il.scm
index 7a80730..dfff1fc 100644
--- a/module/language/elisp/compile-tree-il.scm
+++ b/module/language/elisp/compile-tree-il.scm
@@ -602,6 +602,41 @@
     ((dolist (,var ,iter-list ,result) . ,body) (guard (symbol? var))
      (compile-dolist loc bind var iter-list result body))
 
+    ; catch and throw can mainly be implemented directly using Guile's
+    ; primitives for exceptions, the only difficulty is that the keys used
+    ; within Guile must be symbols, while elisp allows any value and checks
+    ; for matches using eq (eq?).  We handle this by using always #t as key
+    ; for the Guile primitives and check for matches inside the handler; if
+    ; the elisp keys are not eq?, we rethrow the exception.
+
+    ((catch ,tag . ,body) (guard (not (null? body)))
+     (let* ((tag-value (gensym))
+            (tag-ref (make-lexical-ref loc tag-value tag-value)))
+       (make-let loc `(,tag-value) `(,tag-value) `(,(compile-expr bind tag))
+         (call-primitive loc 'catch
+           (make-const loc #t)
+           (make-lambda loc '() '() '()
+             (make-sequence loc (map (compiler bind) body)))
+           (let* ((dummy-key (gensym))
+                  (dummy-ref (make-lexical-ref loc dummy-key dummy-key))
+                  (elisp-key (gensym))
+                  (key-ref (make-lexical-ref loc elisp-key elisp-key))
+                  (value (gensym))
+                  (value-ref (make-lexical-ref loc value value))
+                  (arglist `(,dummy-key ,elisp-key ,value)))
+             (make-lambda loc arglist arglist '()
+               (make-conditional loc
+                 (call-primitive loc 'eq? key-ref tag-ref)
+                 value-ref
+                 (call-primitive loc 'throw
+                                 dummy-ref key-ref value-ref))))))))
+
+    ((throw ,tag ,value)
+     (call-primitive loc 'throw
+                     (make-const loc 'elisp-exception)
+                     (compile-expr bind tag)
+                     (compile-expr bind value)))
+
     ; Either (lambda ...) or (function (lambda ...)) denotes a 
lambda-expression
     ; that should be compiled.
     ((lambda ,args . ,body)
@@ -655,7 +690,8 @@
       (report-error loc "unrecognized elisp" expr))))
 
 
-; Compile a single expression to TreeIL.
+; Compile a single expression to TreeIL and create a closure over a bindings
+; data structure for easy map'ing of compile-expr.
 
 (define (compile-expr bind expr)
   (let ((loc (location expr)))
@@ -672,6 +708,9 @@
 
 
 ; Entry point for compilation to TreeIL.
+; This creates the bindings data structure, and after compiling the main
+; expression we need to make sure all fluids for symbols used during the
+; compilation are created using the generate-ensure-fluid function.
 
 (define (compile-tree-il expr env opts)
   (values
diff --git a/test-suite/tests/elisp-compiler.test 
b/test-suite/tests/elisp-compiler.test
index e475045..d70dd9f 100644
--- a/test-suite/tests/elisp-compiler.test
+++ b/test-suite/tests/elisp-compiler.test
@@ -147,6 +147,28 @@
            (equal mylist '(7 2 5))
            (equal b 5)))))
 
+(with-test-prefix/compile "Exceptions"
+
+  (pass-if "catch without exception"
+    (and (setq a 0)
+         (= (catch 'foobar
+                   (setq a (1+ a))
+                   (setq a (1+ a))
+                   a)
+            2)
+         (= (catch (+ 1 2) a) 2)))
+
+  ; FIXME: Figure out how to do this...
+  ;(pass-if-exception "uncaught exception" 'elisp-exception
+  ;  (throw 'abc 1))
+
+  (pass-if "catch and throw"
+    (and (setq mylist '(1 2))
+         (= (catch 'abc (throw 'abc 2) 1) 2)
+         (= (catch 'abc (catch 'def (throw 'abc 1) 2) 3) 1)
+         (= (catch 'abc (catch 'def (throw 'def 1) 2) 3) 3)
+         (= (catch mylist (catch '(1 2) (throw mylist 1) 2) 3) 1))))
+
 
 ; Test handling of variables.
 ; ===========================


hooks/post-receive
-- 
GNU Guile