From 81f7dcca6528252c1f0a57d3b5581c628efa4bf1 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Tue, 21 Oct 2014 06:13:14 -0700
Subject: * share/txr/stdlib/txr-case.txr: New file.

* txr.1: Document txr-if, txr-when and txr-case.

* genvim.txr: Added new macro names.

* tests/011/txr-case.expected: New file.

* tests/011/txr-case.txr: New file.

* txr.vim: Regenerated.
---
 share/txr/stdlib/txr-case.txr | 48 +++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 48 insertions(+)
 create mode 100644 share/txr/stdlib/txr-case.txr

(limited to 'share')

diff --git a/share/txr/stdlib/txr-case.txr b/share/txr/stdlib/txr-case.txr
new file mode 100644
index 00000000..4d0081b3
--- /dev/null
+++ b/share/txr/stdlib/txr-case.txr
@@ -0,0 +1,48 @@
+@(do
+   (macro-time
+     (defun bindable (obj)
+       (and obj
+            (symbolp obj)
+            (not (keywordp obj))
+            (not (eq t obj)))))
+
+   (defmacro txr-if (name args input : then else)
+     (let ((syms [keep-if bindable args])
+           (arg-exprs [mapcar [iffi symbolp (ret ^',@1)] args])
+           (result (gensym "res-"))
+           (bindings (gensym "bindings-"))
+           (insym (gensym "input-")))
+       ^(let* ((,insym ,input)
+               (,result (match-fun ',name (list ,*arg-exprs)
+                                   (if (stringp ,insym) (list ,insym) ,insym)
+                                   nil)))
+          (if ,result
+            (let ((,bindings (car ,result)))
+              (let (,*[mapcar (ret ^(,@1 (cdr (assoc ',@1 ,bindings))))
+                              syms])
+                ,then))
+            ,else))))
+
+   (defmacro txr-when (name args input . body)
+     ^(txr-if ,name ,args ,input (progn ,*body)))
+
+   (defmacro txr-case-impl (sym . clauses)
+     (tree-case clauses
+       (((name args . body) . other-clauses)
+        (if (eq name t) :
+          ^(txr-if ,name ,args ,sym
+             (progn ,*body)
+             (txr-case-impl ,sym ,*other-clauses))))
+       (((sym . rest) . other-clauses)
+        (if (eq sym t)
+          (if other-clauses
+            (error "txr-case: clauses after (t ...) clause ignored")
+            ^(progn ,*rest))
+          (error "txr-case: bad syntax: ~s" (car clauses))))
+       (atom
+          (error "txr-case: unexpected atom in syntax: ~s" atom))))
+
+   (defmacro txr-case (input-expr . clauses)
+     (let ((input (gensym "input-")))
+       ^(let ((,input ,input-expr))
+          (txr-case-impl ,input ,*clauses)))))
-- 
cgit v1.2.3