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