From 474790ae526c164b2852997501b78fab03dcf339 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Fri, 21 Jan 2022 23:04:50 -0800
Subject: typecase: merge with etypecase, handle t differnetly.

* stdlib/type.tl (sys:typecase-expander): New function, formed
from body of typecase. Bad clause syntax now handled with
compile-error rather than (throwf 'eval-error). The t symbol
is handled specially: it turns into a t conditon in the
resulting cond rather than a typep test. The compiler will
nicely eliminate dead code after that. Now etypecase is handled
here also: if we are expanding etypecase, we just emit the
extra clause.
(typecase, etypecase): Reduced to sys:typecase-expander calls.

* tests/012/typecase.tl: New file.

* tests/012/compile.tl: Add type.tl to list of compile-tested
files.
---
 stdlib/type.tl        | 40 +++++++++++++++++++++-------------------
 tests/012/compile.tl  |  2 +-
 tests/012/typecase.tl | 18 ++++++++++++++++++
 3 files changed, 40 insertions(+), 20 deletions(-)
 create mode 100644 tests/012/typecase.tl

diff --git a/stdlib/type.tl b/stdlib/type.tl
index 8a83a171..680a4061 100644
--- a/stdlib/type.tl
+++ b/stdlib/type.tl
@@ -24,27 +24,29 @@
 ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
 ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 ;; POSSIBILITY OF SUCH DAMAGE.
-(defmacro typecase (form . clauses)
+(defun sys:typecase-expander (form obj clauses)
   (let* ((val (gensym))
          (cond-pairs (collect-each ((cl clauses))
                        (tree-case cl
                          ((type . body)
-                          (if (symbolp type)
-                            ^((typep ,val ',type) ,*(or body '(nil)))
-                            :))
-                         (else (throwf 'eval-error
-                                       "~s: bad clause syntax: ~s"
-                                       'typecase cl))))))
-    ^(let ((,val ,form))
-       (cond ,*cond-pairs))))
+                          (cond
+                            ((eq type t)
+                             ^(t ,*(or body '(nil))))
+                            ((symbolp type)
+                             ^((typep ,val ',type) ,*(or body '(nil))))
+                            (t :)))
+                         (else (compile-error form
+                                              "~s: bad clause syntax: ~s"
+                                              'typecase cl))))))
+    ^(let ((,val ,obj))
+       (cond ,*cond-pairs
+         ,*(if (eq (car form) 'etypecase)
+             ^((t (throwf 'case-error
+                          "~s: unhandled type: ~s"
+                          'etypecase (typeof ,val)))))))))
 
-(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))))))))
+(defmacro typecase (:form f obj . clauses)
+  (sys:typecase-expander f obj clauses))
+
+(defmacro etypecase (:form f obj . clauses)
+  (sys:typecase-expander f obj clauses))
diff --git a/tests/012/compile.tl b/tests/012/compile.tl
index d0c4913e..9b22d92a 100644
--- a/tests/012/compile.tl
+++ b/tests/012/compile.tl
@@ -5,7 +5,7 @@
 
 (each ((f '#"aseq ashwin circ cont defset except \
              fini ifa man-or-boy oop-mi oop-seq oop \
-             parse syms quasi quine seq stslot const"))
+             parse syms quasi quine seq stslot const type"))
   (let ((exf `@{%this-dir%}/@f.expected`))
     (when (path-exists-p exf)
       (file-append-string %expected-file%
diff --git a/tests/012/typecase.tl b/tests/012/typecase.tl
new file mode 100644
index 00000000..97b3da48
--- /dev/null
+++ b/tests/012/typecase.tl
@@ -0,0 +1,18 @@
+(load "../common")
+
+(mtest
+  (typecase) :error
+  (typecase nil) nil
+  (typecase nil a) :error
+  (typecase 0 (symbol 1)) nil
+  (typecase 0 (integer 1)) 1
+  (typecase 0 (integer 1) (integer 2)) 1
+  (typecase 0 (t 3) (integer 1)) 3)
+
+(mtest
+  (etypecase) :error
+  (etypecase nil) :error
+  (etypecase nil a) :error
+  (etypecase 0 (string 1)) :error
+  (etypecase 0 (string 1) (integer 2)) 2
+  (etypecase 0 (string 1) (t 2)) 2)
-- 
cgit v1.2.3