cvs diff: type_info code (round 2)
Tyson Richard DOWD
trd at hydra.cs.mu.oz.au
Mon Apr 21 12:30:27 AEST 1997
Here's the second round of this diff.
===================================================================
Estimated hours taken: 50
Add the type `type_info', which represents the type of a variable.
Implement functions and predicates to deal with type_infos, including
finding what functors they have, getting the arity and type_infos of their
the arguments of a functor, and constructing types.
compiler/base_type_layout.m:
Document the constant used to represent the type 'void'.
Make sure enumeration vectors are output in the same order for
base_type_layouts and base_type_functors, so that we can
refer to functors by the same functor number.
library/mercury_builtin.m:
Add base_type_* for 'void'. 'void' is the type_info
used for unbound type_variables.
library/std_util.m:
Add
function type_of/1
function num_functors/1
predicate get_nth_functor/5
function construct/3
Use MR_DECLARE_STRUCT to declare base_type_* structs
for handwritten code, so less code needs to be changed if this
changes.
Rename `mercury_expand_info' as `Mercury_Expand_Info' (C coding
standard for typedefs).
runtime/type_info.h:
Add a bunch of macros to deal with the various type information
data structures. Eventually all the code that uses these data
strcutures should use these macros.
tests/hard_coded/Mmake:
Add `construct' to the test suite.
hard_coded/construct.m:
hard_coded/construct.exp:
Test of type_of, num_functors, get_nth_functor and construct.
Index: compiler/base_type_layout.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/base_type_layout.m,v
retrieving revision 1.15
diff -u -r1.15 base_type_layout.m
--- base_type_layout.m 1997/03/19 01:37:51 1.15
+++ base_type_layout.m 1997/04/21 01:59:54
@@ -61,7 +61,8 @@
% Tag 0 - CONST Word = 5 - character
% Tag 0 - CONST Word = 6 - univ
% Tag 0 - CONST Word = 7 - pred
-% Words 8 - 1024 reserved for future use
+% Tag 0 - CONST Word = 8 - void
+% Words 9 - 1024 reserved for future use
% Tag 0 - CONST Word = 1024+ - constant(s)
% word is pointer to enum
% vector.
@@ -359,7 +360,7 @@
Enum = yes,
base_type_layout__layout_enum(SortedConsTags,
LayoutInfo1, LayoutInfo2, LayoutTypeData),
- base_type_layout__functors_enum(UnsortedConsTags,
+ base_type_layout__functors_enum(SortedConsTags,
LayoutInfo2, LayoutInfo3, FunctorsTypeData)
;
Enum = no,
Index: library/mercury_builtin.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/library/mercury_builtin.m,v
retrieving revision 1.68
diff -u -r1.68 mercury_builtin.m
--- mercury_builtin.m 1997/02/23 01:13:49 1.68
+++ mercury_builtin.m 1997/04/21 01:59:17
@@ -514,6 +514,15 @@
mkbody(TYPELAYOUT_PREDICATE_VALUE))
};
+ /* The void type */
+
+const struct mercury_data___base_type_layout_void_0_struct {
+ TYPE_LAYOUT_FIELDS
+} mercury_data___base_type_layout_void_0 = {
+ make_typelayout_for_all_tags(TYPELAYOUT_CONST_TAG,
+ mkbody(TYPELAYOUT_NO_NAME_VALUE))
+};
+
/* base_type_functors definitions */
const struct mercury_data___base_type_functors_int_0_struct {
@@ -546,6 +555,14 @@
MR_TYPEFUNCTORS_SPECIAL
};
+ /* The void type */
+
+const struct mercury_data___base_type_functors_void_0_struct {
+ Integer f1;
+} mercury_data___base_type_functors_void_0 = {
+ MR_TYPEFUNCTORS_SPECIAL
+};
+
#endif /* USE_TYPE_LAYOUT */
Declare_entry(mercury__builtin_unify_int_2_0);
@@ -727,6 +744,38 @@
(const Word *) & mercury_data___base_type_layout_pred_0,
(const Word *) & mercury_data___base_type_functors_pred_0,
(const Word *) string_const(""pred"", 4)
+#endif
+};
+
+ /* The void type */
+
+MR_STATIC_CODE_CONST struct mercury_data___base_type_info_void_0_struct {
+ Integer f1;
+ Code *f2;
+ Code *f3;
+ Code *f4;
+#ifdef USE_TYPE_TO_TERM
+ Code *f5;
+ Code *f6;
+#endif
+#ifdef USE_TYPE_LAYOUT
+ const Word *f7;
+ const Word *f8;
+ const Word *f9;
+#endif
+} mercury_data___base_type_info_void_0 = {
+ ((Integer) 0),
+ MR_MAYBE_STATIC_CODE(ENTRY(mercury__unused_0_0)),
+ MR_MAYBE_STATIC_CODE(ENTRY(mercury__unused_0_0)),
+ MR_MAYBE_STATIC_CODE(ENTRY(mercury__unused_0_0)),
+#ifdef USE_TYPE_TO_TERM
+ MR_MAYBE_STATIC_CODE(ENTRY(mercury__unused_0_0)),
+ MR_MAYBE_STATIC_CODE(ENTRY(mercury__unused_0_0))
+#endif
+#ifdef USE_TYPE_LAYOUT
+ (const Word *) & mercury_data___base_type_layout_void_0,
+ (const Word *) & mercury_data___base_type_functors_void_0,
+ (const Word *) string_const(""void"", 4)
#endif
};
Index: library/std_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/library/std_util.m,v
retrieving revision 1.75
diff -u -r1.75 std_util.m
--- std_util.m 1997/03/14 05:22:45 1.75
+++ std_util.m 1997/04/21 02:07:49
@@ -113,7 +113,60 @@
%-----------------------------------------------------------------------------%
- % functor, arg and expand take any type (including univ),
+ % The `type_info' type - allows access to type information.
+ %
+ % A type_info represents the type of a variable.
+ %
+ % It is possible for the type of a variable to be an unbound type
+ % variable, this is represented as the type 'void'/0. 'void' is
+ % considered a special (builtin) type - it is not a discriminated
+ % union, so get_nth_functor/5 and the function construct/3 will
+ % fail if used upon this type.
+
+:- type type_info == c_pointer.
+
+ % TypeInfo = type_info(Data) returns the type_info (TypeInfo) of
+ % the type of Data.
+
+:- func type_of(T) = type_info.
+:- mode type_of(unused) = out is det.
+
+ % num_functors(TypeInfo) returns the number of different
+ %
+ % Functors for the type specified by TypeInfo, or -1 if the type
+ % is not a discriminated union type.
+
+:- func num_functors(type_info) = int.
+:- mode num_functors(in) = out is det.
+
+ % get_nth_functor(Var, N, Functor, Arity, ArgTypes)
+ %
+ % Binds Functor and Arity to the name and arity of the Nth
+ % functor for the specified type, and binds ArgTypes to the
+ % type_infos for the types of the arguments of that functor.
+ % Fails if the type is not a discriminated union type,
+ % or if N is out of range.
+
+:- pred get_nth_functor(type_info::in, int::in, string::out, int::out,
+ list(type_info)::out) is semidet.
+
+ % construct(TypeInfo, N, Args) = Term
+ %
+ % Returns a term of the type specified by TypeInfo (or possibly
+ % an instance thereof, if that type is polymorphic) whose
+ % functor is the Nth functor of TypeInfo, and whose arguments
+ % are given by Args. Fails if the type is not a discriminated
+ % union type, or if N is out of range, or if the number of
+ % arguments doesn't match the arity of the Nth functor of the
+ % type, or if the types of the arguments doesn't match the
+ % expected argument types for that functor.
+
+:- func construct(type_info::in, int::in, list(univ)::in) = (univ::out)
+ is semidet.
+
+%-----------------------------------------------------------------------------%
+
+ % functor, arg and expand take any type (including univ),
% and return representation information for that type.
%
% The string representation of the functor that functor and
@@ -210,9 +263,8 @@
#include ""imp.h""
#include ""deep_copy.h""
-extern const struct
- mercury_data_mercury_builtin__base_type_info_list_1_struct
- mercury_data_mercury_builtin__base_type_info_list_1;
+MR_DECLARE_STRUCT(
+ mercury_data_mercury_builtin__base_type_info_list_1);
Declare_entry(do_call_nondet_closure);
@@ -490,9 +542,7 @@
** the case of higher order types, the arity).
*/
-extern const struct
- mercury_data___base_type_info_pred_0_struct
- mercury_data___base_type_info_pred_0;
+MR_DECLARE_STRUCT(mercury_data___base_type_info_pred_0);
int
mercury_compare_type_info(Word type_info_1, Word type_info_2)
@@ -843,6 +893,540 @@
%-----------------------------------------------------------------------------%
+ % Code for type manipulation.
+
+
+ % Prototypes and type definitions.
+
+:- pragma(c_header_code, "
+
+typedef struct Mercury_Construct_Info {
+ int vector_type;
+ int arity;
+ Word *functors_vector;
+ Word *argument_vector;
+ Word primary_tag;
+ Word secondary_tag;
+ ConstString functor_name;
+} Construct_Info;
+
+int ML_get_num_functors(Word type_info);
+Word ML_copy_argument_typeinfos(int arity, Word type_info,
+ Word *arg_vector);
+bool ML_get_functors_check_range(int functor_number, Word type_info,
+ Construct_Info *info);
+void ML_copy_arguments_from_list_to_vector(int arity, Word arg_list,
+ Word term_vector);
+int ML_typecheck_arguments(Word type_info, int arity,
+ Word arg_list, Word* arg_vector);
+Word ML_collapse_equivalences(Word maybe_equiv_type_info);
+
+static int get_functor_info(Word type_info, int functor_number,
+ Construct_Info *info);
+").
+
+
+:- pragma c_code(type_of(Value::unused) = (TypeInfo::out),
+ will_not_call_mercury, "
+{
+ /*
+ ** `Value' isn't used in this c_code, but the compiler
+ ** gives a warning if you don't mention it.
+ */
+
+ save_transient_registers();
+ TypeInfo = ML_collapse_equivalences(TypeInfo_for_T);
+ restore_transient_registers();
+
+}
+").
+
+
+:- pragma c_code(num_functors(TypeInfo::in) = (Functors::out),
+ will_not_call_mercury, "
+{
+ save_transient_registers();
+ Functors = ML_get_num_functors(TypeInfo);
+ restore_transient_registers();
+}
+").
+
+
+:- pragma c_code(get_nth_functor(TypeInfo::in, FunctorNumber::in,
+ FunctorName::out, Arity::out, TypeInfoList::out),
+ will_not_call_mercury, "
+{
+ int i;
+ Construct_Info info;
+
+ /*
+ ** Get information for this functor number and
+ ** store in info. If this is a discriminated union
+ ** type and if the functor number is in range, we
+ ** succeed.
+ */
+ save_transient_registers();
+ SUCCESS_INDICATOR = ML_get_functors_check_range(FunctorNumber,
+ TypeInfo, &info);
+ restore_transient_registers();
+
+ /*
+ ** Get the functor name and arity, construct the list
+ ** of type_infos for arguments.
+ */
+
+ if (SUCCESS_INDICATOR) {
+ make_aligned_string(FunctorName, (String) (Word)
+ info.functor_name);
+ Arity = info.arity;
+ save_transient_registers();
+ TypeInfoList = ML_copy_argument_typeinfos((int) Arity,
+ TypeInfo, info.argument_vector);
+ restore_transient_registers();
+ }
+
+}
+").
+
+:- pragma c_code(construct(TypeInfo::in, FunctorNumber::in, ArgList::in) =
+ (Term::out), will_not_call_mercury, "
+{
+ Word arg_list, arg_type_info, layout_entry, new_data,
+ term_vector, list_arg_type_info;
+ int i;
+ Construct_Info info;
+
+ /*
+ ** Check range of FunctorNum, get info for this
+ ** functor.
+ */
+ save_transient_registers();
+ SUCCESS_INDICATOR =
+ ML_get_functors_check_range(FunctorNumber, TypeInfo, &info) &&
+ ML_typecheck_arguments(TypeInfo, info.arity, ArgList,
+ info.argument_vector);
+ restore_transient_registers();
+
+ /*
+ ** Build the new term.
+ **
+ ** It will be stored in `new_data', and `term_vector' is a
+ ** the argument vector.
+ **
+ */
+ if (SUCCESS_INDICATOR) {
+
+ layout_entry = MR_BASE_TYPEINFO_GET_TYPELAYOUT_ENTRY(
+ MR_TYPEINFO_GET_BASE_TYPEINFO((Word *) TypeInfo),
+ info.primary_tag);
+
+ if (info.vector_type == MR_TYPEFUNCTORS_ENUM) {
+ /*
+ ** Enumeratiors don't have tags or arguments,
+ ** just the enumeration value.
+ */
+ new_data = (Word) info.secondary_tag;
+ } else {
+ /*
+ ** It must be some sort of tagged functor.
+ */
+
+ if (info.vector_type == MR_TYPEFUNCTORS_NO_TAG) {
+
+ /*
+ ** We set term_vector to point to
+ ** new_data so that the argument filling
+ ** loop will fill the argument in.
+ */
+
+ term_vector = (Word) &new_data;
+
+ } else if (tag(layout_entry) ==
+ TYPELAYOUT_COMPLICATED_TAG) {
+
+ /*
+ ** Create arity + 1 words, fill in the
+ ** secondary tag, and the term_vector will
+ ** be the rest of the words.
+ */
+ incr_hp(new_data, info.arity + 1);
+ field(0, new_data, 0) = info.secondary_tag;
+ term_vector = (Word) (new_data + sizeof(Word));
+
+ } else if (tag(layout_entry) == TYPELAYOUT_CONST_TAG) {
+
+ /*
+ ** If it's a du, and this tag is
+ ** constant, it must be a complicated
+ ** constant tag.
+ */
+
+ new_data = mkbody(info.secondary_tag);
+ term_vector = (Word) NULL;
+
+ } else {
+
+ /*
+ ** A simple tagged word, just need to
+ ** create arguments.
+ */
+
+ incr_hp(new_data, info.arity);
+ term_vector = (Word) new_data;
+ }
+
+ /*
+ ** Copy arguments.
+ */
+
+ ML_copy_arguments_from_list_to_vector(info.arity,
+ ArgList, term_vector);
+
+ /*
+ ** Add tag to new_data.
+ */
+ new_data = (Word) mkword(mktag(info.primary_tag),
+ new_data);
+ }
+
+ /*
+ ** Create a univ.
+ */
+
+ incr_hp(Term, 2);
+ field(mktag(0), Term, UNIV_OFFSET_FOR_TYPEINFO) =
+ (Word) TypeInfo;
+ field(mktag(0), Term, UNIV_OFFSET_FOR_DATA) = (Word) new_data;
+ }
+
+}
+").
+
+:- pragma(c_code, "
+
+ /*
+ ** get_functor_info:
+ **
+ ** Extract the information for functor number `functor_number',
+ ** for the type represented by type_info.
+ ** We succeed if the type is some sort of discriminated union.
+ **
+ ** You need to save and restore transient registers around
+ ** calls to this function.
+ */
+
+int
+get_functor_info(Word type_info, int functor_number, Construct_Info *info)
+{
+ Word *base_type_functors;
+
+ base_type_functors = MR_BASE_TYPEINFO_GET_TYPEFUNCTORS(
+ MR_TYPEINFO_GET_BASE_TYPEINFO((Word *) type_info));
+
+ info->vector_type = MR_TYPEFUNCTORS_INDICATOR(base_type_functors);
+
+ switch (info->vector_type) {
+
+ case MR_TYPEFUNCTORS_ENUM:
+ info->functors_vector = MR_TYPEFUNCTORS_ENUM_FUNCTORS(
+ base_type_functors);
+ info->arity = 0;
+ info->argument_vector = NULL;
+ info->primary_tag = 0;
+ info->secondary_tag = functor_number - 1;
+ info->functor_name = MR_TYPELAYOUT_ENUM_VECTOR_FUNCTOR_NAME(
+ info->functors_vector, functor_number);
+ break;
+
+ case MR_TYPEFUNCTORS_DU:
+ info->functors_vector = MR_TYPEFUNCTORS_DU_FUNCTOR_N(
+ base_type_functors, functor_number);
+ info->arity = MR_TYPELAYOUT_SIMPLE_VECTOR_ARITY(
+ info->functors_vector);
+ info->argument_vector = MR_TYPELAYOUT_SIMPLE_VECTOR_ARGS(
+ info->functors_vector);
+ info->primary_tag = tag(MR_TYPELAYOUT_SIMPLE_VECTOR_TAG(
+ info->functors_vector));
+ info->secondary_tag = unmkbody(
+ body(MR_TYPELAYOUT_SIMPLE_VECTOR_TAG(
+ info->functors_vector), info->primary_tag));
+ info->functor_name = MR_TYPELAYOUT_SIMPLE_VECTOR_FUNCTOR_NAME(
+ info->functors_vector);
+ break;
+
+ case MR_TYPEFUNCTORS_NO_TAG:
+ info->functors_vector = MR_TYPEFUNCTORS_NO_TAG_FUNCTOR(
+ base_type_functors);
+ info->arity = 1;
+ info->argument_vector = MR_TYPELAYOUT_NO_TAG_VECTOR_ARGS(
+ info->functors_vector);
+ info->primary_tag = 0;
+ info->secondary_tag = 0;
+ info->functor_name = MR_TYPELAYOUT_NO_TAG_VECTOR_FUNCTOR_NAME(
+ info->functors_vector);
+ break;
+
+ case MR_TYPEFUNCTORS_EQUIV:
+ {
+ Word *equiv_type;
+ equiv_type = (Word *) MR_TYPEFUNCTORS_EQUIV_TYPE(
+ base_type_functors);
+ return get_functor_info((Word)
+ create_type_info((Word *) type_info,
+ equiv_type),
+ functor_number, info);
+ }
+ break;
+
+ case MR_TYPEFUNCTORS_SPECIAL:
+ return FALSE;
+ case MR_TYPEFUNCTORS_UNIV:
+ return FALSE;
+ default:
+ fatal_error(""std_util:construct - unexpected type."");
+ }
+
+ return TRUE;
+}
+
+ /*
+ ** ML_typecheck_arguments:
+ **
+ ** Given a list of univs (`arg_list'), and an vector of
+ ** type_infos (`arg_vector'), checks that they are all of the
+ ** same type. `arg_vector' may contain type variables, these
+ ** will be filled in by the type arguments of `type_info'.
+ **
+ ** If the type arguments of `type_info' are still type variables
+ ** they will be replaced by the void type (see the
+ ** documentation of `create_type_info').
+ **
+ ** Assumes the length of the list has already been checked.
+ **
+ ** You need to save and restore transient registers around
+ ** calls to this function.
+ */
+
+int
+ML_typecheck_arguments(Word type_info, int arity, Word arg_list,
+ Word* arg_vector)
+{
+ int i, success;
+ Word arg_type_info, list_arg_type_info;
+
+ /* Type check list of arguments */
+
+ for (i = 0; success && i < arity; i++) {
+ if (list_is_empty(arg_list)) {
+ return FALSE;
+ }
+ list_arg_type_info = field(0, (list_head(arg_list)),
+ UNIV_OFFSET_FOR_TYPEINFO);
+
+ arg_type_info = (Word) create_type_info(
+ (Word *) type_info, (Word *) arg_vector[i]);
+
+ success = (mercury_compare_type_info(
+ list_arg_type_info, arg_type_info) == COMPARE_EQUAL);
+ arg_list = list_tail(arg_list);
+ }
+
+ /* List should now be empty */
+ return list_is_empty(arg_list);
+}
+
+ /*
+ ** ML_copy_arguments_from_list_to_vector:
+ **
+ ** Copy the arguments from a list of univs (`arg_list'),
+ ** into the vector (`term_vector').
+ **
+ ** Assumes the length of the list has already been checked.
+ */
+
+void
+ML_copy_arguments_from_list_to_vector(int arity, Word arg_list,
+ Word term_vector)
+{
+ int i;
+
+ for (i = 0; i < arity; i++) {
+ field(mktag(0), term_vector, i) =
+ field(mktag(0), list_head(arg_list),
+ UNIV_OFFSET_FOR_DATA);
+ arg_list = list_tail(arg_list);
+ }
+}
+
+
+ /*
+ ** ML_get_functors_check_range:
+ **
+ ** Check that functor_number is in range, and get the functor
+ ** info if it is. Return FALSE if it is out of range, or
+ ** if get_functor_info returns FALSE, otherwise return TRUE.
+ **
+ ** You need to save and restore transient registers around
+ ** calls to this function.
+ */
+
+bool
+ML_get_functors_check_range(int functor_number, Word type_info,
+ Construct_Info *info)
+{
+ /*
+ ** Check range of functor_number, get functors
+ ** vector
+ */
+ return functor_number <= ML_get_num_functors(type_info) &&
+ functor_number > 0 &&
+ get_functor_info(type_info, functor_number, info);
+}
+
+
+ /*
+ ** ML_copy_argument_typeinfos:
+ **
+ ** Copy `arity' type_infos from `arg_vector' onto the heap
+ ** in a list.
+ **
+ ** You need to save and restore transient registers around
+ ** calls to this function.
+ */
+
+Word
+ML_copy_argument_typeinfos(int arity, Word type_info, Word *arg_vector)
+{
+ Word type_info_list, *functors;
+
+ restore_transient_registers();
+ type_info_list = list_empty();
+
+ while (--arity >= 0) {
+ Word argument;
+
+ /* Get the argument type_info */
+ argument = arg_vector[arity];
+
+ /* Fill in any polymorphic type_infos */
+ save_transient_registers();
+ argument = (Word) create_type_info(
+ (Word *) type_info, (Word *) argument);
+ restore_transient_registers();
+
+ /* Look past any equivalences */
+ save_transient_registers();
+ argument = ML_collapse_equivalences(argument);
+ restore_transient_registers();
+
+ /* Join the argument to the front of the list */
+ type_info_list = list_cons(argument, type_info_list);
+ }
+ save_transient_registers();
+
+ return type_info_list;
+}
+
+ /*
+ ** ML_collapse_equivalences:
+ **
+ ** Keep looking past equivalences until the there are no more.
+ **
+ ** You need to save and restore transient registers around
+ ** calls to this function.
+ */
+
+Word
+ML_collapse_equivalences(Word maybe_equiv_type_info)
+{
+ Word *functors, equiv_type_info;
+
+ functors = MR_BASE_TYPEINFO_GET_TYPEFUNCTORS(
+ MR_TYPEINFO_GET_BASE_TYPEINFO((Word *)
+ maybe_equiv_type_info));
+
+ /* Look past equivalences */
+ while (MR_TYPEFUNCTORS_INDICATOR(functors) == MR_TYPEFUNCTORS_EQUIV) {
+ equiv_type_info = (Word) MR_TYPEFUNCTORS_EQUIV_TYPE(functors);
+ equiv_type_info = (Word) create_type_info(
+ (Word *) maybe_equiv_type_info,
+ (Word *) equiv_type_info);
+ functors = MR_BASE_TYPEINFO_GET_TYPEFUNCTORS(
+ MR_TYPEINFO_GET_BASE_TYPEINFO((Word *)
+ equiv_type_info));
+ maybe_equiv_type_info = equiv_type_info;
+ }
+
+ return maybe_equiv_type_info;
+}
+
+ /*
+ ** ML_get_num_functors:
+ **
+ ** Get the number of functors for a type. If it isn't a
+ ** discriminated union, return -1.
+ **
+ ** You need to save and restore transient registers around
+ ** calls to this function.
+ */
+
+int
+ML_get_num_functors(Word type_info)
+{
+ Word *base_type_functors;
+ int Functors;
+
+ base_type_functors = MR_BASE_TYPEINFO_GET_TYPEFUNCTORS(
+ MR_TYPEINFO_GET_BASE_TYPEINFO((Word *) type_info));
+
+ switch ((int) MR_TYPEFUNCTORS_INDICATOR(base_type_functors)) {
+
+ case MR_TYPEFUNCTORS_DU:
+ Functors = MR_TYPEFUNCTORS_DU_NUM_FUNCTORS(
+ base_type_functors);
+ break;
+
+ case MR_TYPEFUNCTORS_ENUM:
+ Functors = MR_TYPEFUNCTORS_ENUM_NUM_FUNCTORS(
+ base_type_functors);
+ break;
+
+ case MR_TYPEFUNCTORS_EQUIV:
+ {
+ Word *equiv_type;
+ equiv_type = (Word *)
+ MR_TYPEFUNCTORS_EQUIV_TYPE(
+ base_type_functors);
+ Functors = ML_get_num_functors((Word)
+ create_type_info((Word *)
+ type_info, equiv_type));
+ }
+ break;
+
+ case MR_TYPEFUNCTORS_SPECIAL:
+ Functors = -1;
+ break;
+
+ case MR_TYPEFUNCTORS_NO_TAG:
+ Functors = 1;
+ break;
+
+ case MR_TYPEFUNCTORS_UNIV:
+ Functors = -1;
+ break;
+
+ default:
+ fatal_error(""std_util:ML_get_num_functors :""
+ "" unknown indicator"");
+ }
+ return Functors;
+}
+
+").
+
+%-----------------------------------------------------------------------------%
+
+
:- pragma(c_header_code, "
/*
@@ -870,31 +1454,30 @@
*/
-typedef struct mercury_expand_info {
+typedef struct Mercury_Expand_Info {
ConstString functor;
int arity;
Word *argument_vector;
Word *type_info_vector;
bool need_functor;
bool need_args;
-} expand_info;
+} Expand_Info;
/* Prototypes */
-void mercury_expand(Word* type_info, Word data_word, expand_info *info);
+void mercury_expand(Word* type_info, Word data_word, Expand_Info *info);
static void mercury_expand_const(Word data_value, Word entry_value,
- expand_info *info);
+ Expand_Info *info);
static void mercury_expand_enum(Word data_value, Word entry_value,
- expand_info *info);
+ Expand_Info *info);
static void mercury_expand_simple(Word data_value, Word* arg_type_infos,
- Word * type_info, expand_info *info);
+ Word * type_info, Expand_Info *info);
static void mercury_expand_builtin(Word data_value, Word entry_value,
- expand_info *info);
+ Expand_Info *info);
static void mercury_expand_complicated(Word data_value, Word entry_value,
- Word * type_info, expand_info *info);
-
+ Word * type_info, Expand_Info *info);
static Word * create_type_info(Word *term_type_info,
Word *arg_pseudo_type_info);
@@ -927,7 +1510,7 @@
*/
void
-mercury_expand(Word* type_info, Word data_word, expand_info *info)
+mercury_expand(Word* type_info, Word data_word, Expand_Info *info)
{
Word *base_type_info, *arg_type_info, *base_type_layout;
Word data_value, entry_value, base_type_layout_entry;
@@ -1035,7 +1618,7 @@
*/
void
-mercury_expand_const(Word data_value, Word entry_value, expand_info *info)
+mercury_expand_const(Word data_value, Word entry_value, Expand_Info *info)
{
#ifdef DEBUG_STD_UTIL__EXPAND
@@ -1060,7 +1643,7 @@
*/
void
-mercury_expand_enum(Word data_value, Word entry_value, expand_info *info)
+mercury_expand_enum(Word data_value, Word entry_value, Expand_Info *info)
{
#ifdef DEBUG_STD_UTIL__EXPAND
@@ -1093,7 +1676,7 @@
*/
void
mercury_expand_simple(Word data_value, Word* arg_type_infos, Word * type_info,
- expand_info *info)
+ Expand_Info *info)
{
int i;
@@ -1136,7 +1719,7 @@
void
mercury_expand_complicated(Word data_value, Word entry_value, Word * type_info,
- expand_info *info)
+ Expand_Info *info)
{
Word new_data_value, new_entry_value, new_entry_body,
new_entry_tag, secondary_tag;
@@ -1158,7 +1741,7 @@
}
void
-mercury_expand_builtin(Word data_value, Word entry_value, expand_info *info)
+mercury_expand_builtin(Word data_value, Word entry_value, Expand_Info *info)
{
switch ((int) entry_value) {
@@ -1267,68 +1850,97 @@
/*
- * Given a type_info (term_type_info) which contains a
- * base_type_info pointer and possibly other type_infos
- * giving the values of the type parameters of this type,
- * and a pseudo-type_info (arg_pseudo_type_info), which contains a
- * base_type_info pointer and possibly other type_infos
- * giving EITHER
- * - the values of the type parameters of this type,
- * or - an indication of the type parameter of the
- * term_type_info that should be substituted here
- *
- * This returns a fully instantiated type_info, a version of the
- * arg_pseudo_type_info with all the type variables filled in.
- * We allocate memory for a new type_info on the Mercury heap,
- * copy the necessary information, and return a pointer to the
- * new type_info.
- *
- * In the case where the argument's pseudo_type_info is a
- * base_type_info with no arguments, we don't copy the
- * base_type_info - we just return a pointer to it - no memory
- * is allocated. The caller can check this by looking at the
- * first cell of the returned pointer - if it is zero, this is a
- * base_type_info. Otherwise, it is an allocated copy of a
- * type_info.
- *
- * NOTE: If you are changing this code, you might also need
- * to change the code in create_type_info in runtime/deep_copy.c,
- * which does much the same thing, only allocating using malloc
- * instead of on the heap.
- */
+ ** Given a type_info (term_type_info) which contains a
+ ** base_type_info pointer and possibly other type_infos
+ ** giving the values of the type parameters of this type,
+ ** and a pseudo-type_info (arg_pseudo_type_info), which contains a
+ ** base_type_info pointer and possibly other type_infos
+ ** giving EITHER
+ ** - the values of the type parameters of this type,
+ ** or - an indication of the type parameter of the
+ ** term_type_info that should be substituted here
+ **
+ ** This returns a fully instantiated type_info, a version of the
+ ** arg_pseudo_type_info with all the type variables filled in.
+ **
+ ** If the substituted type parameters from the term_type_info
+ ** were type variables, they will be replaced with references
+ ** to the void type ('void'/0).
+ ** XXX: This is a temporary measure. It would be best if the
+ ** code in polymorphism.m and typecheck.m was changed to output
+ ** references to 'void' for unbound type variables, rather than
+ ** outputting NULL pointers, which we convert to references to
+ ** void here. Note that this would also involve changing any
+ ** code that relied upon the NULL definition (for example,
+ ** mercury_compare_type_info).
+ **
+ ** We allocate memory for a new type_info on the Mercury heap,
+ ** copy the necessary information, and return a pointer to the
+ ** new type_info.
+ **
+ ** In the case where the argument's pseudo_type_info is a
+ ** base_type_info with no arguments, we don't copy the
+ ** base_type_info - we just return a pointer to it - no memory
+ ** is allocated. The caller can check this by looking at the
+ ** first cell of the returned pointer - if it is zero, this is a
+ ** base_type_info. Otherwise, it is an allocated copy of a
+ ** type_info.
+ **
+ ** NOTE: If you are changing this code, you might also need
+ ** to change the code in create_type_info in runtime/deep_copy.c,
+ ** which does much the same thing, only allocating using malloc
+ ** instead of on the heap.
+ */
+
+MR_DECLARE_STRUCT(mercury_data___base_type_info_void_0);
-Word * create_type_info(Word *term_type_info, Word *arg_pseudo_type_info)
+Word *
+create_type_info(Word *term_type_info, Word *arg_pseudo_type_info)
{
int i, arity;
Word base_type_info;
Word *type_info;
- /* The arg_pseudo_type_info might be a polymorphic variable */
+ /*
+ ** The arg_pseudo_type_info might be a polymorphic variable,
+ ** if so - substitute.
+ */
if ((Word) arg_pseudo_type_info < TYPELAYOUT_MAX_VARINT) {
arg_pseudo_type_info = (Word *)
term_type_info[(Word) arg_pseudo_type_info];
}
+ /*
+ ** If it's still a variable, make it a reference to 'void'.
+ */
+ if ((Word) arg_pseudo_type_info < TYPELAYOUT_MAX_VARINT) {
+ return (Word *) (Word) &mercury_data___base_type_info_void_0;
+ }
+
base_type_info = arg_pseudo_type_info[0];
/* no arguments - optimise common case */
if (base_type_info == 0) {
-
- /* The only case where we don't allocate memory */
return arg_pseudo_type_info;
}
- arity = ((Word *) base_type_info)[0];
+ arity = MR_BASE_TYPEINFO_GET_TYPE_ARITY(base_type_info);
incr_saved_hp(LVALUE_CAST(Word, type_info), arity + 1);
for (i = 0; i <= arity; i++) {
if (arg_pseudo_type_info[i] < TYPELAYOUT_MAX_VARINT) {
type_info[i] = term_type_info[arg_pseudo_type_info[i]];
+
+ /*
+ ** It's a variable, make it a reference to`void'.
+ */
if (type_info[i] < TYPELAYOUT_MAX_VARINT) {
- fatal_error(""Error! Can't instantiate type variable."");
+ type_info[i] = (Word)
+ &mercury_data___base_type_info_void_0;
}
+
} else {
type_info[i] = arg_pseudo_type_info[i];
}
@@ -1344,7 +1956,7 @@
:- pragma(c_code, functor(Type::in, Functor::out, Arity::out), "
{
- expand_info info;
+ Expand_Info info;
info.need_functor = TRUE;
info.need_args = FALSE;
@@ -1364,7 +1976,7 @@
:- pragma(c_code, arg(ArgumentIndex::in, Type::in, Argument::out), "
{
- expand_info info;
+ Expand_Info info;
Word arg_pseudo_type_info;
info.need_functor = FALSE;
@@ -1415,7 +2027,7 @@
:- pragma(c_code, expand(Type::in, Functor::out, Arity::out, Arguments::out), "
{
- expand_info info;
+ Expand_Info info;
Word arg_pseudo_type_info;
Word Argument, tmp;
int i;
Index: runtime/type_info.h
===================================================================
RCS file: /home/staff/zs/imp/mercury/runtime/type_info.h,v
retrieving revision 1.21
diff -u -r1.21 type_info.h
--- type_info.h 1997/03/04 04:22:40 1.21
+++ type_info.h 1997/04/21 00:55:58
@@ -225,6 +225,13 @@
#endif
/*
+** Declaration for structs.
+*/
+
+#define MR_DECLARE_STRUCT(T) \
+ extern const struct T##_struct T
+
+/*
** Typelayouts for builtins are often defined as X identical
** values, where X is the number of possible tag values.
*/
@@ -295,6 +302,7 @@
#define TYPELAYOUT_CHARACTER_VALUE ((Integer) 5)
#define TYPELAYOUT_UNIV_VALUE ((Integer) 6)
#define TYPELAYOUT_PREDICATE_VALUE ((Integer) 7)
+#define TYPELAYOUT_NO_NAME_VALUE ((Integer) 8)
/*
** Highest allowed type variable number
@@ -463,12 +471,234 @@
** base_type_functors.
*/
+/*
+** All type_functors have an indicator.
+*/
+
+#define MR_TYPEFUNCTORS_OFFSET_FOR_INDICATOR ((Integer) 0)
+
+#define MR_TYPEFUNCTORS_INDICATOR(Functors) \
+ ((Functors)[MR_TYPEFUNCTORS_OFFSET_FOR_INDICATOR])
+
+
+/*
+** Values that the indicator can take.
+*/
+
#define MR_TYPEFUNCTORS_DU ((Integer) 0)
#define MR_TYPEFUNCTORS_ENUM ((Integer) 1)
#define MR_TYPEFUNCTORS_EQUIV ((Integer) 2)
#define MR_TYPEFUNCTORS_SPECIAL ((Integer) 3)
#define MR_TYPEFUNCTORS_NO_TAG ((Integer) 4)
#define MR_TYPEFUNCTORS_UNIV ((Integer) 5)
+
+
+ /*
+ ** Macros to access the data in a discriminated union
+ ** type_functors, the number of functors, and the simple_vector
+ ** for functor number N (where N starts at 1).
+ */
+
+#define MR_TYPEFUNCTORS_DU_OFFSET_FOR_NUM_FUNCTORS ((Integer) 1)
+#define MR_TYPEFUNCTORS_DU_OFFSET_FOR_FUNCTORS_VECTOR ((Integer) 2)
+
+#define MR_TYPEFUNCTORS_DU_NUM_FUNCTORS(Functors) \
+ ((Functors)[MR_TYPEFUNCTORS_DU_OFFSET_FOR_NUM_FUNCTORS])
+
+#define MR_TYPEFUNCTORS_DU_FUNCTOR_N(Functor, N) \
+ ((Word *) ((Functor)[ \
+ MR_TYPEFUNCTORS_DU_OFFSET_FOR_FUNCTORS_VECTOR + (N) - 1]))
+
+ /*
+ ** Macros to access the data in a enumeration type_functors, the
+ ** number of functors, and the enumeration vector.
+ */
+
+#define MR_TYPEFUNCTORS_ENUM_OFFSET_FOR_FUNCTORS_VECTOR ((Integer) 1)
+
+#define MR_TYPEFUNCTORS_ENUM_NUM_FUNCTORS(Functors) \
+ MR_TYPELAYOUT_ENUM_VECTOR_NUM_FUNCTORS( \
+ MR_TYPEFUNCTORS_ENUM_FUNCTORS((Functors)))
+
+#define MR_TYPEFUNCTORS_ENUM_FUNCTORS(Functor) \
+ ((Word *) ((Functor)[MR_TYPEFUNCTORS_ENUM_OFFSET_FOR_FUNCTORS_VECTOR]))
+
+ /*
+ ** Macros to access the data in a no_tag type_functors, the
+ ** simple_vector for the functor (there can only be one functor
+ ** with no_tags).
+ */
+
+#define MR_TYPEFUNCTORS_NO_TAG_OFFSET_FOR_FUNCTORS_VECTOR ((Integer) 1)
+
+#define MR_TYPEFUNCTORS_NO_TAG_FUNCTOR(Functors) \
+ ((Word *) ((Functors) \
+ [MR_TYPEFUNCTORS_NO_TAG_OFFSET_FOR_FUNCTORS_VECTOR]))
+
+ /*
+ ** Macros to access the data in an equivalence type_functors,
+ ** the equivalent type of this type.
+ */
+
+#define MR_TYPEFUNCTORS_EQUIV_OFFSET_FOR_TYPE ((Integer) 1)
+
+#define MR_TYPEFUNCTORS_EQUIV_TYPE(Functors) \
+ ((Functors)[MR_TYPEFUNCTORS_EQUIV_OFFSET_FOR_TYPE])
+
+/*---------------------------------------------------------------------------*/
+
+/*
+** Macros and defintions for defining and dealing with the vectors
+** created by base_type_layouts (these are the same vectors referred to
+** by base_type_functors)
+** - the simple_vector, describing a single functor
+** - the enum_vector, describing an enumeration
+** - the no_tag_vector, describing a single functor
+*/
+
+ /*
+ ** Macros for dealing with enum vectors.
+ */
+
+typedef struct {
+ Word enum_or_comp_const;
+ Word num_sharers;
+ ConstString functor1;
+/* other functors follow, num_sharers of them.
+** ConstString functor2;
+** ...
+*/
+} MR_TypeLayout_EnumVector;
+
+#define MR_TYPELAYOUT_ENUM_VECTOR_NUM_FUNCTORS(Vector) \
+ ((MR_TypeLayout_EnumVector *) (Vector))->num_sharers
+
+#define MR_TYPELAYOUT_ENUM_VECTOR_FUNCTOR_NAME(Vector, N) \
+ ( (&((MR_TypeLayout_EnumVector *)(Vector))->functor1) [(N) - 1] )
+
+
+ /*
+ ** Macros for dealing with simple vectors.
+ */
+
+#define MR_TYPELAYOUT_SIMPLE_VECTOR_OFFSET_FOR_ARITY ((Integer) 0)
+#define MR_TYPELAYOUT_SIMPLE_VECTOR_OFFSET_FOR_ARGS ((Integer) 1)
+ /* Note, these offsets are from the end of the args */
+#define MR_TYPELAYOUT_SIMPLE_VECTOR_OFFSET_FOR_FUNCTOR_NAME ((Integer) 1)
+#define MR_TYPELAYOUT_SIMPLE_VECTOR_OFFSET_FOR_FUNCTOR_TAG ((Integer) 2)
+
+#define MR_TYPELAYOUT_SIMPLE_VECTOR_ARITY(V) \
+ ((V)[MR_TYPELAYOUT_SIMPLE_VECTOR_OFFSET_FOR_ARITY])
+
+#define MR_TYPELAYOUT_SIMPLE_VECTOR_ARGS(V) \
+ (V + MR_TYPELAYOUT_SIMPLE_VECTOR_OFFSET_FOR_ARGS)
+
+#define MR_TYPELAYOUT_SIMPLE_VECTOR_FUNCTOR_NAME(V) \
+ ((String) ((V)[MR_TYPELAYOUT_SIMPLE_VECTOR_ARITY(V) + \
+ MR_TYPELAYOUT_SIMPLE_VECTOR_OFFSET_FOR_FUNCTOR_NAME]))
+
+#define MR_TYPELAYOUT_SIMPLE_VECTOR_TAG(V) \
+ ((Word) ((V)[MR_TYPELAYOUT_SIMPLE_VECTOR_ARITY(V) + \
+ MR_TYPELAYOUT_SIMPLE_VECTOR_OFFSET_FOR_FUNCTOR_TAG]))
+
+ /*
+ ** Macros for dealing with no_tag vectors
+ **
+ ** (Note, we know the arity is 1).
+ */
+
+typedef struct {
+ Word arity;
+ Word arg;
+ ConstString name;
+} MR_TypeLayout_NoTagVector;
+
+#define MR_TYPELAYOUT_NO_TAG_VECTOR_ARITY(Vector) \
+ (1)
+#define MR_TYPELAYOUT_NO_TAG_VECTOR_ARGS(Vector) \
+ (&(((MR_TypeLayout_NoTagVector *) (Vector))->arg))
+
+#define MR_TYPELAYOUT_NO_TAG_VECTOR_FUNCTOR_NAME(Vector) \
+ (((MR_TypeLayout_NoTagVector *) (Vector))->name)
+
+/*---------------------------------------------------------------------------*/
+
+ /*
+ ** Macros for retreiving things from type_infos and
+ ** base_type_infos
+ */
+
+#define MR_TYPEINFO_GET_BASE_TYPEINFO(TypeInfo) \
+ ((*TypeInfo) ? ((Word *) *TypeInfo) : TypeInfo)
+
+#define MR_BASE_TYPEINFO_GET_TYPEFUNCTORS(BaseTypeInfo) \
+ ((Word *) (BaseTypeInfo)[OFFSET_FOR_BASE_TYPE_FUNCTORS])
+
+#define MR_BASE_TYPEINFO_GET_TYPELAYOUT(BaseTypeInfo) \
+ ((Word *) (BaseTypeInfo)[OFFSET_FOR_BASE_TYPE_LAYOUT])
+
+#define MR_BASE_TYPEINFO_GET_TYPELAYOUT_ENTRY(BaseTypeInfo, Tag) \
+ (MR_BASE_TYPEINFO_GET_TYPELAYOUT(BaseTypeInfo)[(Tag)])
+
+#define MR_BASE_TYPEINFO_GET_TYPE_ARITY(BaseTypeInfo) \
+ (((Word *) (BaseTypeInfo))[OFFSET_FOR_COUNT])
+
+/*---------------------------------------------------------------------------*/
+
+#if 0
+
+ /* XXX: We should use structs to represent the various
+ ** data structures in the functors and layouts.
+ **
+ ** To implement this:
+ ** 1. The code that uses the data in the library and
+ ** runtime should be modified to use the above access
+ ** macros
+ ** 2. Then we can simplify the ordering of the data
+ ** structures (for example, put variable length fields
+ ** last)
+ ** 3. Then we can create structs for them.
+ **
+ ** Some examples are below, (no guarantees of correctness).
+ **
+ ** Note that enum_vectors have already been handled in this way.
+ */
+
+ /*
+ ** ** IMPORTANT: the layout in memory of the following
+ ** struct must match the way that the Mercury compiler
+ ** generates code for it.
+ */
+
+
+typedef struct {
+ Word arity;
+ Word arg1;
+/* other arguments follow, there are arity of them,
+** then followed by functor name, and functor tag.
+** Word arg2;
+** ...
+** Word argarity;
+** ConstString functorname;
+** Word tag;
+*/
+} MR_TypeLayout_SimpleVector;
+
+
+typedef struct {
+ Word arity;
+ Word arg_pseudo_type_infos[1]; /* variable-sized array */
+ /* actualy length is `arity', not 1 */
+} MR_TypeLayout_part1;
+
+typedef struct {
+ ConstString name;
+ Word arg_layouts[1]; /* variable-sized array */
+ /* actualy length is `arity', not 1 */
+} MR_TypeLayout_part2;
+typedef MR_TypeLayout_part1 MR_TypeLayout;
+
+#endif
/*---------------------------------------------------------------------------*/
Index: tests/hard_coded/Mmake
===================================================================
RCS file: /home/staff/zs/imp/tests/hard_coded/Mmake,v
retrieving revision 1.40
diff -u -r1.40 Mmake
--- Mmake 1997/04/10 16:04:25 1.40
+++ Mmake 1997/04/21 01:01:05
@@ -14,7 +14,7 @@
reverse_arith curry curry2 higher_order_syntax \
ho_func_reg float_reg write expand ho_solns write_reg1 \
ho_univ_to_type elim_special_pred division_test test_imported_no_tag \
- name_mangling cycles deep_copy_bug
+ name_mangling cycles deep_copy_bug construct
#-----------------------------------------------------------------------------#
New file: tests/hard_coded/construct.m
===================================================================
% Test case for construct, num_functors, type_of and get_nth_functor.
%
% Author: trd
:- module construct.
:- interface.
:- import_module io.
:- pred main(io__state::di, io__state::uo) is det.
:- implementation.
:- import_module list, int, std_util, term, map, string, require.
:- pred test_builtins(io__state::di, io__state::uo) is det.
:- pred test_discriminated(io__state::di, io__state::uo) is det.
:- pred test_polymorphism(io__state::di, io__state::uo) is det.
:- pred test_other(io__state::di, io__state::uo) is det.
:- pred test_construct(io__state::di, io__state::uo) is det.
:- pred newline(io__state::di, io__state::uo) is det.
:- pred test_num_functors(type_info::in, io__state::di, io__state::uo) is det.
:- pred test_nth_functor(type_info::in, io__state::di, io__state::uo) is det.
:- pred test_all(T::in, io__state::di, io__state::uo) is det.
:- type enum ---> one ; two ; three.
:- type fruit ---> apple(list(int))
; banana(list(enum)).
:- type thingie ---> foo ; bar(int) ; bar(int, int) ; qux(int) ;
quux(int) ; quuux(int, int) ; wombat ;
zoom(int) ; zap(int, float) ; zip(int, int) ;
zop(float, float).
:- type poly(A, B) ---> poly_one(A) ; poly_two(B) ;
poly_three(B, A, poly(B, A));
poly_four(A, B).
:- type no_tag ---> qwerty(int).
%----------------------------------------------------------------------------%
main -->
test_discriminated,
test_polymorphism,
test_builtins,
test_other,
test_construct.
%----------------------------------------------------------------------------%
test_construct -->
% Valid tests.
% Enumerations:
test_construct_2(type_of(one), "three", 0, []),
{ type_to_univ([1, 2, 3], NumList) },
test_construct_2(type_of(apple([])), "apple", 1, [NumList]),
{ type_to_univ([one, two, three], EnumList) },
test_construct_2(type_of(apple([])), "banana", 1, [EnumList]),
% Discriminated union:
% (Simple, complicated and complicated constant tags).
{ type_to_univ(1, One) },
{ type_to_univ(2.1, TwoPointOne) },
test_construct_2(type_of(wombat), "foo", 0, []),
test_construct_2(type_of(wombat), "bar", 1, [One]),
test_construct_2(type_of(wombat), "bar", 2, [One, One]),
test_construct_2(type_of(wombat), "qux", 1, [One]),
test_construct_2(type_of(wombat), "quux", 1, [One]),
test_construct_2(type_of(wombat), "quuux", 2, [One, One]),
test_construct_2(type_of(wombat), "wombat", 0, []),
test_construct_2(type_of(wombat), "zoom", 1, [One]),
test_construct_2(type_of(wombat), "zap", 2, [One, TwoPointOne]),
test_construct_2(type_of(wombat), "zip", 2, [One, One]),
test_construct_2(type_of(wombat), "zop", 2, [TwoPointOne, TwoPointOne]),
% No-tag type:
test_construct_2(type_of(qwerty(7)), "qwerty", 1, [One]),
{ type_to_univ("goodbye", Bye) },
test_construct_2(type_of(poly_four(3, "hello")), "poly_one", 1, [One]),
test_construct_2(type_of(poly_four(3, "hello")), "poly_two", 1, [Bye]),
test_construct_2(type_of(poly_four(3, "hello")), "poly_four", 2,
[One, Bye]).
:- pred test_construct_2(type_info::in, string::in, int::in, list(univ)::in,
io__state::di, io__state::uo) is det.
test_construct_2(TypeInfo, FunctorName, Arity, Args) -->
{ find_functor(TypeInfo, FunctorName, Arity, FunctorNumber) },
io__write_string("About to construct "),
io__write_string(FunctorName),
io__write_string("/"),
io__write_int(Arity),
newline,
(
{ Constructed = construct(TypeInfo, FunctorNumber, Args) }
->
io__write_string("Constructed: "),
io__write(Constructed),
newline
;
io__write_string("Construction failed.\n")
).
:- pred write_thingie(thingie::in, io__state::di, io__state::uo) is det.
write_thingie(foo) --> io__write_string("foo/0").
write_thingie(bar(_)) --> io__write_string("bar/1").
write_thingie(bar(_,_)) --> io__write_string("bar/2").
write_thingie(qux(_)) --> io__write_string("qux/1").
write_thingie(quux(_)) --> io__write_string("quux/1").
write_thingie(quuux(_,_)) --> io__write_string("quuux/2").
write_thingie(wombat) --> io__write_string("wombat/0").
write_thingie(zoom(_)) --> io__write_string("zoom/1").
write_thingie(zap(_,_)) --> io__write_string("zap/2").
write_thingie(zip(_,_)) --> io__write_string("zip/2").
write_thingie(zop(_,_)) --> io__write_string("zop/2").
:- pred write_thingie2(thingie::in, io__state::di, io__state::uo) is det.
:- pragma c_code(write_thingie2(Thingie::in, IO0::di, IO::uo), "
printf(""thingie is: %ld"", (Word) Thingie);
IO = IO0;
").
:- pred write_enum(enum::in, io__state::di, io__state::uo) is det.
write_enum(one) --> io__write_string("one").
write_enum(two) --> io__write_string("two").
write_enum(three) --> io__write_string("three").
:- pred write_enum2(enum::in, io__state::di, io__state::uo) is det.
:- pragma c_code(write_enum2(Enum::in, IO0::di, IO::uo), "
printf(""enum is: %ld"", (Word) Enum);
IO = IO0;
").
:- pred find_functor(type_info::in, string::in, int::in, int::out) is det.
find_functor(TypeInfo, Functor, Arity, FunctorNumber) :-
N = num_functors(TypeInfo),
find_functor2(TypeInfo, Functor, Arity, N, FunctorNumber).
:- pred find_functor2(type_info::in, string::in, int::in, int::in,
int::out) is det.
find_functor2(TypeInfo, Functor, Arity, Num, FunctorNumber) :-
(
Num = 0
->
error("unable to find functor")
;
(
get_nth_functor(TypeInfo, Num, Functor, Arity, _List)
->
FunctorNumber = Num
;
find_functor2(TypeInfo, Functor, Arity, Num - 1,
FunctorNumber)
)
).
%----------------------------------------------------------------------------%
test_all(T) -->
{ TypeInfo = type_of(T) },
test_num_functors(TypeInfo),
test_nth_functor(TypeInfo), newline.
test_num_functors(TypeInfo) -->
{ N = num_functors(TypeInfo) },
io__write_int(N),
io__write_string(" functors in this type"),
newline.
test_nth_functor(TypeInfo) -->
{ N = num_functors(TypeInfo) },
test_all_functors(TypeInfo, N).
:- pred test_all_functors(type_info::in, int::in,
io__state::di, io__state::uo) is det.
test_all_functors(TypeInfo, N) -->
(
{ N =< 0 }
->
[]
;
io__write_int(N),
(
{ get_nth_functor(TypeInfo, N, Name, Arity, _List) }
->
io__write_string(" - "),
io__write_string(Name),
io__write_string("/"),
io__write_int(Arity),
newline
;
io__write_string(" failed "),
newline
),
test_all_functors(TypeInfo, N - 1)
).
%----------------------------------------------------------------------------%
test_discriminated -->
io__write_string("TESTING DISCRIMINATED UNIONS\n"),
% test enumerations
test_all(two), newline,
test_all(one), newline,
test_all(three), newline,
% test simple tags
test_all(apple([9,5,1])), newline,
test_all(banana([three, one, two])), newline,
% test complicated tags
test_all(zop(3.3, 2.03)), newline,
test_all(zip(3, 2)), newline,
test_all(zap(3, -2.111)), newline,
% test complicated constant
test_all(wombat), newline,
test_all(foo), newline,
newline.
test_polymorphism -->
io__write_string("TESTING POLYMORPHISM\n"),
test_all(poly_three(3.33, 4, poly_one(9.11))), newline,
test_all(poly_two(3)), newline,
test_all(poly_one([2399.3])), newline,
newline.
test_builtins -->
io__write_string("TESTING BUILTINS\n"),
% test strings
test_all(""), newline,
test_all("Hello, world\n"), newline,
test_all("Foo%sFoo"), newline,
test_all(""""), newline, % interesting - prints """ of course
% test characters
test_all('a'), newline,
test_all('&'), newline,
% test floats
test_all(3.14159), newline,
test_all(11.28324983E-22), newline,
test_all(22.3954899E22), newline,
% test integers
test_all(-65), newline,
test_all(4), newline,
% test univ.
%{ type_to_univ(["hi! I'm a univ!"], Univ) },
% test_all(Univ), newline,
% test predicates
test_all(newline), newline,
newline.
% Note: testing abstract types is always going to have results
% that are dependent on the implementation. If someone changes
% the implementation, the results of this test can change.
test_other -->
io__write_string("TESTING OTHER TYPES\n"),
{ term__init_var_supply(VarSupply) },
{ term__create_var(VarSupply, Var, NewVarSupply) },
test_all(Var), newline,
test_all(VarSupply), newline,
test_all(NewVarSupply), newline,
% presently, at least, map is an equivalence and
% an abstract type.
{ map__init(Map) },
test_all(Map), newline,
% a no tag type
test_all(qwerty(4)), newline,
newline.
newline -->
io__write_char('\n').
New file: tests/hard_coded/construct.exp
===================================================================
TESTING DISCRIMINATED UNIONS
3 functors in this type
3 - three/0
2 - two/0
1 - one/0
3 functors in this type
3 - three/0
2 - two/0
1 - one/0
3 functors in this type
3 - three/0
2 - two/0
1 - one/0
2 functors in this type
2 - banana/1
1 - apple/1
2 functors in this type
2 - banana/1
1 - apple/1
11 functors in this type
11 - zop/2
10 - zoom/1
9 - zip/2
8 - zap/2
7 - wombat/0
6 - qux/1
5 - quux/1
4 - quuux/2
3 - foo/0
2 - bar/2
1 - bar/1
11 functors in this type
11 - zop/2
10 - zoom/1
9 - zip/2
8 - zap/2
7 - wombat/0
6 - qux/1
5 - quux/1
4 - quuux/2
3 - foo/0
2 - bar/2
1 - bar/1
11 functors in this type
11 - zop/2
10 - zoom/1
9 - zip/2
8 - zap/2
7 - wombat/0
6 - qux/1
5 - quux/1
4 - quuux/2
3 - foo/0
2 - bar/2
1 - bar/1
11 functors in this type
11 - zop/2
10 - zoom/1
9 - zip/2
8 - zap/2
7 - wombat/0
6 - qux/1
5 - quux/1
4 - quuux/2
3 - foo/0
2 - bar/2
1 - bar/1
11 functors in this type
11 - zop/2
10 - zoom/1
9 - zip/2
8 - zap/2
7 - wombat/0
6 - qux/1
5 - quux/1
4 - quuux/2
3 - foo/0
2 - bar/2
1 - bar/1
TESTING POLYMORPHISM
4 functors in this type
4 - poly_two/1
3 - poly_three/3
2 - poly_one/1
1 - poly_four/2
4 functors in this type
4 - poly_two/1
3 - poly_three/3
2 - poly_one/1
1 - poly_four/2
4 functors in this type
4 - poly_two/1
3 - poly_three/3
2 - poly_one/1
1 - poly_four/2
TESTING BUILTINS
-1 functors in this type
-1 functors in this type
-1 functors in this type
-1 functors in this type
-1 functors in this type
-1 functors in this type
-1 functors in this type
-1 functors in this type
-1 functors in this type
-1 functors in this type
-1 functors in this type
-1 functors in this type
TESTING OTHER TYPES
-1 functors in this type
-1 functors in this type
-1 functors in this type
4 functors in this type
4 - two/4
3 - three/7
2 - four/10
1 - empty/0
1 functors in this type
1 - qwerty/1
About to construct three/0
Constructed: three
About to construct apple/1
Constructed: apple(.(1, .(2, .(3, []))))
About to construct banana/1
Constructed: banana(.(one, .(two, .(three, []))))
About to construct foo/0
Constructed: foo
About to construct bar/1
Constructed: bar(1)
About to construct bar/2
Constructed: bar(1, 1)
About to construct qux/1
Constructed: qux(1)
About to construct quux/1
Constructed: quux(1)
About to construct quuux/2
Constructed: quuux(1, 1)
About to construct wombat/0
Constructed: wombat
About to construct zoom/1
Constructed: zoom(1)
About to construct zap/2
Constructed: zap(1, 2.10000000000000)
About to construct zip/2
Constructed: zip(1, 1)
About to construct zop/2
Constructed: zop(2.10000000000000, 2.10000000000000)
About to construct qwerty/1
Constructed: qwerty(1)
About to construct poly_one/1
Constructed: poly_one(1)
About to construct poly_two/1
Constructed: poly_two("goodbye")
About to construct poly_four/2
Constructed: poly_four(1, "goodbye")
--
Tyson Dowd #
# Sign on refrigerator:
trd at cs.mu.oz.au # Refrigerate after opening.
http://www.cs.mu.oz.au/~trd # - C. J. Owen.
More information about the developers
mailing list