diff options
| -rw-r--r-- | eval.c | 2 | ||||
| -rw-r--r-- | eval.h | 2 | ||||
| -rw-r--r-- | lib.c | 53 | ||||
| -rw-r--r-- | lib.h | 3 | ||||
| -rw-r--r-- | txr.1 | 144 |
5 files changed, 203 insertions, 1 deletions
@@ -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); @@ -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; @@ -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); @@ -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) { @@ -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 ) |