Adding typecase macro.

* lisplib.c (type_set_entries, type_instantiate): New static
functions.
(lisplib_init): Register new functions in dl_table.

* share/txr/stdlib/type.tl: New file, providing typecase

* txr.1: Documented typecase.

1 files changed, 38 insertions, 0 deletions

diff --git a/share/txr/stdlib/type.tl b/share/txr/stdlib/type.tl
new file mode 100644
index 00000000..830c5700
--- /dev/null
+++ b/share/txr/stdlib/type.tl
@@ -0,0 +1,38 @@
+;; Copyright 2015
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution of this software in source and binary forms, with or without
+;; modification, is permitted provided that the following two conditions are met.
+;;
+;; Use of this software in any manner constitutes agreement with the disclaimer
+;; which follows the two conditions.
+;;
+;; 1. Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 2. Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in
+;;    the documentation and/or other materials provided with the
+;;    distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED
+;; WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
+;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  IN NO EVENT SHALL THE
+;; COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DAMAGES, HOWEVER CAUSED,
+;; AND UNDER ANY THEORY OF LIABILITY, ARISING IN ANY WAY OUT OF THE USE OF THIS
+;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(defmacro typecase (expr . clauses)
+  (let* ((val (gensym))
+         (cond-pairs (collect-each ((cl clauses))
+                       (tree-case cl
+                         ((type . body)
+                          (if (symbolp type)
+                            ^((typep ,val ',type) ,*body)
+                            :))
+                         (else (throwf 'eval-error
+                                       "~s: bad clause syntax: ~s"
+                                       'typecase cl))))))
+    ^(let ((,val ,expr))
+       (cond ,*cond-pairs))))