From 85bd4d95c5615b39324d5c82434b616cfdb7cf3f Mon Sep 17 00:00:00 2001
From: "Paul A. Patience" <paul@apatience.com>
Date: Mon, 17 Jan 2022 06:40:51 -0500
Subject: type: new macro etypecase.

* lisplib.c (type_set_entries): Add etypecase to autoload list.

* stdlib/type.tl (etypecase): New macro.

* txr.1: Documented.

* stdlib/doc-syms.tl: Updated.
---
 lisplib.c          |  4 +++-
 stdlib/doc-syms.tl |  1 +
 stdlib/type.tl     | 11 +++++++++++
 txr.1              | 36 ++++++++++++++++++++++++++++++++++++
 4 files changed, 51 insertions(+), 1 deletion(-)

diff --git a/lisplib.c b/lisplib.c
index 80c8dc59..f841f4c7 100644
--- a/lisplib.c
+++ b/lisplib.c
@@ -292,7 +292,9 @@ static val except_instantiate(val set_fun)
 
 static val type_set_entries(val dlt, val fun)
 {
-  val name[] = { lit("typecase"), nil };
+  val name[] = {
+    lit("typecase"), lit("etypecase"), nil
+  };
   set_dlt_entries(dlt, name, fun);
   return nil;
 }
diff --git a/stdlib/doc-syms.tl b/stdlib/doc-syms.tl
index 19804e8d..676323a4 100644
--- a/stdlib/doc-syms.tl
+++ b/stdlib/doc-syms.tl
@@ -658,6 +658,7 @@
       ("etime" "N-036B1BDB")
       ("etimedout" "N-036B1BDB")
       ("etxtbsy" "N-036B1BDB")
+      ("etypecase" "N-033FBE77")
       ("eval" "N-0286C8B8")
       ("eval-only" "N-030BF4F5")
       ("evenp" "D-001C")
diff --git a/stdlib/type.tl b/stdlib/type.tl
index f75c88e2..8a83a171 100644
--- a/stdlib/type.tl
+++ b/stdlib/type.tl
@@ -37,3 +37,14 @@
                                        'typecase cl))))))
     ^(let ((,val ,form))
        (cond ,*cond-pairs))))
+
+(defmacro etypecase (form . clauses)
+  (if [find t clauses eq car]
+    ^(typecase ,form ,*clauses)
+    (let ((val (gensym)))
+      ^(let ((,val ,form))
+         (typecase ,val
+           ,*clauses
+           (t (throwf 'case-error
+                      "~s: unhandled type: ~s"
+                      'etypecase (typeof ,val))))))))
diff --git a/txr.1 b/txr.1
index 267b66dc..edbdd5f0 100644
--- a/txr.1
+++ b/txr.1
@@ -19850,6 +19850,42 @@ always matches.  If such a clause is placed as the last clause of a
 it provides a fallback case, whose forms are evaluated if none of the
 previous clauses match.
 
+.coNP Macro @ etypecase
+.synb
+.mets (etypecase < test-form >> {( type-sym << clause-form *)}*)
+.syne
+.desc
+The
+.code etypecase
+macro is the error-catching variant of
+.codn typecase ,
+similar to the relationship between the
+.code ecaseq
+and
+.code caseq
+families of macros.
+
+If one of the clauses has a
+.meta type-sym
+which is the symbol
+.codn t ,
+then
+.code etypecase
+is precisely equivalent to
+.codn typecase .
+Otherwise,
+a clause with a
+.meta type-sym
+of
+.code t
+and which throws an exception of type
+.codn case-error ,
+derived from
+.codn error ,
+is appended to the existing clauses,
+after which the semantics follows that of
+.codn typecase .
+
 .coNP Function @ built-in-type-p
 .synb
 .mets (built-in-type-p << object )
-- 
cgit v1.2.3