summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/elisp/README6
-rw-r--r--module/language/elisp/compile-tree-il.scm24
-rw-r--r--module/language/elisp/runtime/function-slot.scm7
-rw-r--r--test-suite/tests/elisp-compiler.test15
4 files changed, 43 insertions, 9 deletions
diff --git a/module/language/elisp/README b/module/language/elisp/README
index 0eb3799bd..9cfe14384 100644
--- a/module/language/elisp/README
+++ b/module/language/elisp/README
@@ -10,7 +10,7 @@ Already implemented:
* not, and, or
* referencing and setting (setq) variables
* while, dotimes, dolist
- * catch, throw
+ * catch, throw, unwind-protect
* let, let*
* lambda expressions, function calls using list notation
* some built-ins (mainly numbers/arithmetic)
@@ -19,7 +19,6 @@ Already implemented:
* quotation and backquotation with unquote/unquote-splicing
Especially still missing:
- * unwind-protect
* real elisp reader instead of Scheme's
* set, makunbound, boundp functions
* more general built-ins
@@ -34,3 +33,6 @@ Especially still missing:
Other ideas and things to think about:
* %nil vs. #f/'() handling in Guile
* flet, lexical-let and/or optional lexical binding as extensions
+
+Extensions over original elisp:
+ * (guile-ref module symbol) construct to build a (@ module symbol) from elisp
diff --git a/module/language/elisp/compile-tree-il.scm b/module/language/elisp/compile-tree-il.scm
index dfff1fc0c..03772ff5f 100644
--- a/module/language/elisp/compile-tree-il.scm
+++ b/module/language/elisp/compile-tree-il.scm
@@ -572,6 +572,13 @@
(compile-expr bind (cdar tail))
(make-lambda loc '() '() '() (iterate (cdr tail)))))))))
+ ; guile-ref allows building TreeIL's module references from within
+ ; elisp as a way to access data (and primitives, for instance) within
+ ; the Guile universe. The module and symbol referenced are static values,
+ ; just like (@ module symbol) does!
+ ((guile-ref ,module ,sym) (guard (and (list? module) (symbol? sym)))
+ (make-module-ref loc module sym #t))
+
; A while construct is transformed into a tail-recursive loop like this:
; (letrec ((iterate (lambda ()
; (if condition
@@ -608,6 +615,8 @@
; 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.
+ ;
+ ; throw is implemented as built-in function.
((catch ,tag . ,body) (guard (not (null? body)))
(let* ((tag-value (gensym))
@@ -631,11 +640,16 @@
(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)))
+ ; unwind-protect is just some weaker construct as dynamic-wind, so
+ ; straight-forward to implement.
+ ((unwind-protect ,body . ,clean-ups) (guard (not (null? clean-ups)))
+ (call-primitive loc 'dynamic-wind
+ (make-lambda loc '() '() '() (make-void loc))
+ (make-lambda loc '() '() '()
+ (compile-expr bind body))
+ (make-lambda loc '() '() '()
+ (make-sequence loc
+ (map (compiler bind) clean-ups)))))
; Either (lambda ...) or (function (lambda ...)) denotes a lambda-expression
; that should be compiled.
diff --git a/module/language/elisp/runtime/function-slot.scm b/module/language/elisp/runtime/function-slot.scm
index 3b3cf3c8d..bc1645d8d 100644
--- a/module/language/elisp/runtime/function-slot.scm
+++ b/module/language/elisp/runtime/function-slot.scm
@@ -235,6 +235,13 @@
val))
+; Throw can be implemented as built-in function.
+
+(built-in-func throw
+ (lambda (tag value)
+ (prim throw 'elisp-exception tag value)))
+
+
; Miscellaneous.
(built-in-func not (lambda (x)
diff --git a/test-suite/tests/elisp-compiler.test b/test-suite/tests/elisp-compiler.test
index d70dd9fe5..cb87840a3 100644
--- a/test-suite/tests/elisp-compiler.test
+++ b/test-suite/tests/elisp-compiler.test
@@ -165,9 +165,20 @@
(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 'abc (1+ 0)) 2) 3) 1)
(= (catch 'abc (catch 'def (throw 'def 1) 2) 3) 3)
- (= (catch mylist (catch '(1 2) (throw mylist 1) 2) 3) 1))))
+ (= (catch mylist (catch '(1 2) (throw mylist 1) 2) 3) 1)))
+
+ (pass-if "unwind-protect"
+ (progn (setq a 0 b 1 c 1)
+ (catch 'exc
+ (unwind-protect (progn (setq a 1)
+ (throw 'exc 0))
+ (setq a 0)
+ (setq b 0)))
+ (unwind-protect nil (setq c 0))
+ (and (= a 0) (= b 0) (= c 0)
+ (= (unwind-protect 42 1 2 3) 42)))))
; Test handling of variables.