New functions, subtypep and typep.

* eval.c (eval_init): Register subtypep and typep.

* eval.h (list_s): Existing variable declared.

* lib.c (atom_s, integer_s, number_s, sequence_s, string_s):
new symbol variables.
(subtypep, typep): New functions.
(obj_init): Initialize new symbol variables.

* lib.c (atom_s, integer_s, number_s, sequence_s, string_s):
Declared.

* txr.1: Documented type hierarchy and the new functions.

5 files changed, 203 insertions, 1 deletions

diff --git a/eval.c b/eval.c
index b4dd6bfe..dda00b49 100644
--- a/eval.c
+++ b/eval.c
@@ -4164,6 +4164,8 @@ void eval_init(void)
   reg_fun(intern(lit("list*"), user_package), func_n0v(list_star_intrinsic));
   reg_fun(identity_s, identity_f);
   reg_fun(intern(lit("typeof"), user_package), func_n1(typeof));
+  reg_fun(intern(lit("subtypep"), user_package), func_n2(subtypep));
+  reg_fun(intern(lit("typep"), user_package), func_n2(typep));
 
   reg_fun(intern(lit("atom"), user_package), func_n1(atom));
   reg_fun(intern(lit("null"), user_package), null_f);
diff --git a/eval.h b/eval.h
index 61bfb5db..8df0eac0 100644
--- a/eval.h
+++ b/eval.h
@@ -24,7 +24,7 @@
  * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  */
 
-extern val dwim_s, lambda_s, vector_lit_s, vector_list_s;
+extern val dwim_s, lambda_s, vector_lit_s, vector_list_s, list_s;
 extern val hash_lit_s, hash_construct_s, struct_lit_s, qref_s;
 extern val eval_error_s;
 extern val last_form_evaled, last_form_expanded;
diff --git a/lib.c b/lib.c
index 84988206..e93a73fb 100644
--- a/lib.c
+++ b/lib.c
@@ -81,6 +81,7 @@ val system_package_s, keyword_package_s, user_package_s;
 
 val null_s, t, cons_s, str_s, chr_s, fixnum_s, sym_s, pkg_s, fun_s, vec_s;
 val lit_s, stream_s, hash_s, hash_iter_s, lcons_s, lstr_s, cobj_s, cptr_s;
+val atom_s, integer_s, number_s, sequence_s, string_s;
 val env_s, bignum_s, float_s;
 val var_s, expr_s, regex_s, chset_s, set_s, cset_s, wild_s, oneplus_s;
 val nongreedy_s;
@@ -195,6 +196,53 @@ val typeof(val obj)
   }
 }
 
+val subtypep(val sub, val sup)
+{
+  if (sub == nil || sup == t) {
+    return t;
+  } else if (sub == sup) {
+    return t;
+  } else if (sup == atom_s) {
+    return tnil(sub != cons_s && sub != lcons_s);
+  } else if (sup == integer_s) {
+    return tnil(sub == fixnum_s || sub == bignum_s);
+  } else if (sup == number_s) {
+    return tnil(sub == fixnum_s || sub == bignum_s ||
+                sub == integer_s || sub == float_s);
+  } else if (sup == cons_s) {
+    return tnil(sub == lcons_s);
+  } else if (sup == sym_s) {
+    return tnil(sub == null_s);
+  } else if (sup == list_s) {
+    return tnil(sub == null_s || sub == cons_s || sub == lcons_s);
+  } else if (sup == sequence_s) {
+    return tnil(sub == str_s || sub == lit_s || sub == lstr_s ||
+                sub == vec_s || sub == null_s || sub == cons_s ||
+                sub == list_s);
+  } else if (sup == string_s) {
+    return tnil(sub == str_s || sub == lit_s || sub == lstr_s);
+  } else {
+    val sub_struct = find_struct_type(sub);
+    val sup_struct = find_struct_type(sup);
+
+    if (sub_struct && sup_struct) {
+      do {
+        sub_struct = super(sub_struct);
+        if (sub_struct == sup_struct)
+          return t;
+      } while (sub_struct);
+      return nil;
+    }
+
+    return eq(sub, sup);
+  }
+}
+
+val typep(val obj, val type)
+{
+  return subtypep(typeof(obj), type);
+}
+
 val throw_mismatch(val obj, type_t t)
 {
   type_mismatch(lit("~s is not of type ~s"), obj, code2type(t), nao);
@@ -7035,6 +7083,11 @@ static void obj_init(void)
   lstr_s = intern(lit("lstr"), user_package);
   cobj_s = intern(lit("cobj"), user_package);
   cptr_s = intern(lit("cptr"), user_package);
+  atom_s = intern(lit("atom"), user_package);
+  integer_s = intern(lit("integer"), user_package);
+  number_s = intern(lit("number"), user_package);
+  sequence_s = intern(lit("sequence"), user_package);
+  string_s = intern(lit("string"), user_package);
   env_s = intern(lit("env"), user_package);
   bignum_s = intern(lit("bignum"), user_package);
   float_s = intern(lit("float"), user_package);
diff --git a/lib.h b/lib.h
index 6b8a9d6e..074ccd3c 100644
--- a/lib.h
+++ b/lib.h
@@ -386,6 +386,7 @@ extern val keyword_package_s, system_package_s, user_package_s;
 extern val null_s, t, cons_s, str_s, chr_s, fixnum_sl;
 extern val sym_s, pkg_s, fun_s, vec_s;
 extern val stream_s, hash_s, hash_iter_s, lcons_s, lstr_s, cobj_s, cptr_s;
+extern val atom_s, integer_s, number_s, sequence_s, string_s;
 extern val env_s, bignum_s, float_s;
 extern val var_s, expr_s, regex_s, chset_s, set_s, cset_s, wild_s, oneplus_s;
 extern val nongreedy_s;
@@ -432,6 +433,8 @@ extern alloc_bytes_t gc_bytes;
 
 val identity(val obj);
 val typeof(val obj);
+val subtypep(val sub, val sup);
+val typep(val obj, val type);
 val throw_mismatch(val obj, type_t);
 INLINE val type_check(val obj, type_t typecode)
 {
diff --git a/txr.1 b/txr.1
index bac8d8e6..5b173c78 100644
--- a/txr.1
+++ b/txr.1
@@ -12968,6 +12968,106 @@ is a symbol which names a special operator, otherwise it returns
 .codn nil .
 
 .SS* Object Type And Equivalence
+
+In \*(TL, objects obey the following type hierarchy. In this type hierarchy,
+the internal nodes denote abstract types: no object is an instance of
+an abstract type:
+
+.cblk
+  t ----+--- <cobj types> ---+--- hash
+        |                    |
+        |                    +--- stream
+        |                    |
+        |                    +--- random-state
+        |                    |
+        |                    .
+        |                    +... <others>
+        |
+        +--- <structures>
+        |
+        +--- sequence ---+--- string ---+--- str
+        |                |              |
+        |                |              +--- lstr
+        |                |              |
+        |                |              +--- lit
+        |                |
+        |                +--- list ---+--- null
+        |                |            |
+        |                |            +--- cons
+        |                |            |
+        |                |            +--- lcons
+        |                |
+        |                +--- vec
+        |
+        +--- number ---+--- float
+        |              |
+        |              +--- integer ---+--- fixnum
+        |                              |
+        |                              +--- bignum
+        |
+        +--- sym
+        |
+        +--- env
+        |
+        +--- pkg
+        |
+        +--- fun
+.cble
+
+In addition to the above hierarchy, the following relationships also exist:
+
+.cblk
+  t ---+--- atom --- <any type other than cons> --- nil
+       |
+       +--- cons ---+--- lcons --- nil
+                    |
+                    +--- nil
+
+  sym --- null
+.cble
+
+That is to say, the types are exhaustively partitioned into atoms and conses;
+an object is either a
+.code cons
+or else it isn't, in which case it is the abstract
+type
+.codn atom .
+
+The
+.code cons
+type is odd in that it is both an abstract type,
+serving as a supertype for the type
+.code lcons
+and it is also a concrete type in that regular conses are of
+this type.
+
+The type
+.code nil
+is an abstract type which is empty. That is to say, no object is of
+type
+.codn nil .
+This type is considered the abstract subtype of every other type,
+including itself.
+
+The type
+.code nil
+is not to be confused with the type
+.code null
+which is the type of the
+.code nil
+symbol.
+
+Lastly, because the type of
+.code nil
+is the type
+.code null
+and
+.code nil
+is also a symbol, the
+.codn null
+type is a subtype of
+.codn sym .
+
 .coNP Function @ typeof
 .synb
 .mets (typeof << value )
@@ -13023,6 +13123,50 @@ A bignum integer: arbitrary precision integer that is heap-allocated.
 
 There are additional kinds of objects, such as streams.
 
+.coNP Function @ subtypep
+.synb
+.mets (subtypep < left-type-symbol << right-type-symbol )
+.syne
+.desc
+The
+.code subtypep
+function tests whether
+.meta left-type-symbol
+and
+.meta right-type-symbol
+name a pair of types, such that the left type is a subtype of the right
+type.
+
+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
+and
+.meta right-type-symbol
+both name 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.
+
+.coNP Function @ typep
+.synb
+.mets (typep < object << type-symbol )
+.syne
+.desc
+The
+.code typep
+function tests whether the type of
+.meta object
+is a subtype of the type named by
+.meta type-symbol .
+
+The following equivalence holds:
+
+.cblk
+  (typep a b) --> (subtypep (typeof a) b)
+.cble
+
 .coNP Function @ identity
 .synb
 .mets (identity << value )