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.

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

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

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.
 ; ===========================