summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/elisp/README5
-rw-r--r--module/language/elisp/compile-tree-il.scm41
-rw-r--r--test-suite/tests/elisp-compiler.test22
3 files changed, 65 insertions, 3 deletions
diff --git a/module/language/elisp/README b/module/language/elisp/README
index 42a9bc679..0eb3799bd 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 7a807309a..dfff1fc0c 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 e475045e8..d70dd9fe5 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.
; ===========================