From ac8a694beb385af6d2bdb464ba67b1a7c044cef7 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Tue, 27 Jul 2021 22:33:01 -0700
Subject: subtypep: handle struct type objects.

The subtypep function has poor requirements, handling only type
symbols. Let's extend it to handle structure type objects.

* lib.c (subtypep): In all cases when an argument is considered to be a
possible structure symbol, and thus subject to find_struct_type,
consider whether it already is a struct type, and just take it as-is.

* tests/012/type.tl: New tests.

* txr.1: Updated.
---
 lib.c             |  8 ++++----
 tests/012/type.tl | 48 ++++++++++++++++++++++++++++++++++++++++++++++++
 txr.1             | 20 ++++++++++++++------
 3 files changed, 66 insertions(+), 10 deletions(-)

diff --git a/lib.c b/lib.c
index 14ddbe68..1a12e678 100644
--- a/lib.c
+++ b/lib.c
@@ -281,7 +281,7 @@ val subtypep(val sub, val sup)
   } else if (sup == list_s) {
     return tnil(sub == null_s || sub == cons_s || sub == lcons_s);
   } else if (sup == sequence_s) {
-    val sub_struct = find_struct_type(sub);
+    val sub_struct = if3(struct_type_p(sub), sub, find_struct_type(sub));
     if (sub_struct) {
       if (get_special_slot_by_type(sub_struct, length_m) ||
           get_special_slot_by_type(sub_struct, car_m))
@@ -294,11 +294,11 @@ val subtypep(val sub, val sup)
   } else if (sup == string_s) {
     return tnil(sub == str_s || sub == lit_s || sub == lstr_s);
   } else if (sup == struct_s) {
-    return tnil(find_struct_type(sub));
+    return tnil(struct_type_p(sub) || find_struct_type(sub));
   } else {
     {
-      val sub_struct = find_struct_type(sub);
-      val sup_struct = find_struct_type(sup);
+      val sub_struct = if3(struct_type_p(sub), sub, find_struct_type(sub));
+      val sup_struct = if3(struct_type_p(sup), sup, find_struct_type(sup));
 
       if (sub_struct && sup_struct)
         return struct_subtype_p(sub_struct, sup_struct);
diff --git a/tests/012/type.tl b/tests/012/type.tl
index 0cac2581..97007b3c 100644
--- a/tests/012/type.tl
+++ b/tests/012/type.tl
@@ -18,3 +18,51 @@
 (mtest
   (subtypep 'stream 'stdio-stream) nil
   (subtypep 'stdio-stream 'stream) t)
+
+(defstruct xtime time)
+(defstruct nottime nil)
+
+(mtest
+  (typep #S(time) 'time) t
+  (typep #S(time) (find-struct-type 'time)) t
+  (typep #S(xtime) 'time) t
+  (typep #S(xtime) (find-struct-type 'time)) t
+  (typep #S(nottime) 'time) nil
+  (typep #S(nottime) (find-struct-type 'time)) nil)
+
+(mtest
+  (subtypep (find-struct-type 'time) (find-struct-type 'time)) t
+  (subtypep (find-struct-type 'time) 'time) t
+  (subtypep 'time (find-struct-type 'time)) t)
+
+(mtest
+  (subtypep (find-struct-type 'xtime) (find-struct-type 'time)) t
+  (subtypep (find-struct-type 'xtime) 'time) t
+  (subtypep 'xtime (find-struct-type 'time)) t)
+
+(mtest
+  (subtypep (find-struct-type 'time) (find-struct-type 'xtime)) nil
+  (subtypep (find-struct-type 'time) 'xtime) nil
+  (subtypep 'time (find-struct-type 'xtime)) nil)
+
+(mtest
+  (subtypep 'time 'struct) t
+  (subtypep (find-struct-type 'time) 'struct) t
+  (subtypep 'hash 'struct) nil)
+
+(defstruct listlike nil
+  (:method car (me)))
+
+(defstruct veclike nil
+  (:method length (me)))
+
+(mtest
+  (subtypep 'listlike 'sequence) t
+  (subtypep (find-struct-type 'listlike) 'sequence) t
+  (subtypep 'veclike 'sequence) t
+  (subtypep (find-struct-type 'veclike) 'sequence) t
+  (subtypep 'time 'sequence) nil
+  (subtypep 'hash 'sequence) nil
+  (subtypep 'str 'sequence) t
+  (subtypep 'string 'sequence) t
+  (subtypep 'vec 'sequence) t)
diff --git a/txr.1 b/txr.1
index 9e5651c1..3c606329 100644
--- a/txr.1
+++ b/txr.1
@@ -19203,18 +19203,26 @@ There are more kinds of objects, such as user-defined structures.
 
 .coNP Function @ subtypep
 .synb
-.mets (subtypep < left-type-symbol << right-type-symbol )
+.mets (subtypep < left-type << right-type )
 .syne
 .desc
 The
 .code subtypep
 function tests whether
-.meta left-type-symbol
+.meta left-type
 and
-.meta right-type-symbol
+.meta right-type
 name a pair of types, such that the left type is a subtype of the right
 type.
 
+The arguments are either type symbols, or structure type objects, as returned by the
+.code find-struct-type
+function. Thus, the symbol
+.codn time ,
+which is the name of a predefined struct type, and the object returned by
+.code "(find-struct-type 'time)"
+are considered equivalent argument values.
+
 If either argument doesn't name a type, the behavior is
 unspecified.
 
@@ -19222,10 +19230,10 @@ Each type is a subtype of itself. Most other type relationships can be inferred
 from the type hierarchy diagrams given in the introduction to this section.
 
 In addition, there are inheritance relationships among structures. If
-.meta left-type-symbol
+.meta left-type
 and
-.meta right-type-symbol
-both name structure types, then
+.meta right-type
+are both structure types, then
 .code subtypep
 yields true if the types are the same struct type, or if the right
 type is a direct or indirect supertype of the left.
-- 
cgit v1.2.3