diff: type_name/1 et al
Fergus Henderson
fjh at cs.mu.oz.au
Thu Apr 24 09:31:53 AEST 1997
Hi Tyson,
Can you please review this one?
Provide Mercury predicates for manipulating types.
Also some more fixes to make the `type_info' and `c_pointer' types
do the right thing.
library/std_util.m:
Add functions `type_name', `type_constructor_name',
`type_constructor_arity', and `type_constructor_args'.
Also, change the definition of type `type_info' so that
deep_copy(), compare/3 and unify/2 work for it.
library/mercury_builtin.m:
Change the definition of type `c_pointer' so that
deep_copy(), compare/3 and unify/2 give appropriate
error messages. Also add a few minor comments.
Index: std_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/library/std_util.m,v
retrieving revision 1.77
diff -u -r1.77 std_util.m
--- std_util.m 1997/04/21 14:46:54 1.77
+++ std_util.m 1997/04/23 21:16:02
@@ -1,5 +1,5 @@
%---------------------------------------------------------------------------%
-% Copyright (C) 1995 University of Melbourne.
+% Copyright (C) 1994-1997 University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution.
%---------------------------------------------------------------------------%
@@ -28,8 +28,8 @@
%-----------------------------------------------------------------------------%
% The universal type.
-% Note that the current NU-Prolog implementation of univ_to_type
-% is buggy in that it always succeeds, even if the types didn't
+% Note that the current NU-Prolog/SICStus Prolog implementation of
+% univ_to_type is buggy in that it always succeeds, even if the types didn't
% match, so until this gets implemented correctly, don't use
% univ_to_type unless you are sure that the types will definely match.
@@ -125,19 +125,42 @@
:- type type_info.
- % type_info(Data) returns the type_info of the type of Data.
+ % type_info(Data) returns the type_info for 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.
+ % type_name(Type) returns the name of the specified type.
+ % (e.g. type_name(type_of([2,3])) = "list(int)").
+
+:- func type_name(type_info) = string.
+
+ % type_constructor_name(TypeInfo) returns the name of the top-level
+ % type constructor for the specified type.
+ % (e.g. type_constructor_name(type_of([2,3])) = "list").
+
+:- func type_constructor_name(type_info) = string.
+
+ % type_constructor_arity(Type) returns the arity of the top-level
+ % type constructor for the specified type.
+ % (e.g. type_constructor_name(type_of([2,3])) = 1).
+
+:- func type_constructor_arity(type_info) = int.
+
+ % type_constructor_args(Type) returns the type arguments of the
+ % top-level type constructor for the specified type.
+ % (e.g. type_constructor_args(type_of([2,3])) = [Int],
+ % where type_name(Int) = "int").
+
+:- func type_constructor_args(type_info) = list(type_info).
+
+ % num_functors(Type) returns the number of different functors
+ % for the top-level type constructor of the specified type, 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_functor(Var, N, Functor, Arity, ArgTypes)
+ % get_functor(Type, N, Functor, Arity, ArgTypes)
%
% Binds Functor and Arity to the name and arity of the Nth
% functor for the specified type (starting at zero), and binds
@@ -220,9 +243,7 @@
:- implementation.
-:- import_module require, set.
-
-:- type type_info == c_pointer.
+:- import_module require, set, string.
/****
Is this really useful?
@@ -752,6 +773,19 @@
MR_TYPEFUNCTORS_UNIV
};
+const struct mercury_data_std_util__base_type_layout_type_info_0_struct {
+ TYPE_LAYOUT_FIELDS
+} mercury_data_std_util__base_type_layout_type_info_0 = {
+ make_typelayout_for_all_tags(TYPELAYOUT_CONST_TAG,
+ mkbody(TYPELAYOUT_TYPEINFO_VALUE))
+};
+
+const struct mercury_data_std_util__base_type_functors_type_info_0_struct {
+ Integer f1;
+} mercury_data_std_util__base_type_functors_type_info_0 = {
+ MR_TYPEFUNCTORS_SPECIAL
+};
+
#endif
Define_extern_entry(mercury____Unify___std_util__univ_0_0);
@@ -761,6 +795,13 @@
Define_extern_entry(mercury____Term_To_Type___std_util__univ_0_0);
Define_extern_entry(mercury____Type_To_Term___std_util__univ_0_0);
+Define_extern_entry(mercury____Unify___std_util__type_info_0_0);
+Define_extern_entry(mercury____Index___std_util__type_info_0_0);
+Define_extern_entry(mercury____Compare___std_util__type_info_0_0);
+Declare_label(mercury____Compare___std_util__type_info_0_0_i1);
+Define_extern_entry(mercury____Term_To_Type___std_util__type_info_0_0);
+Define_extern_entry(mercury____Type_To_Term___std_util__type_info_0_0);
+
BEGIN_MODULE(unify_univ_module)
init_entry(mercury____Unify___std_util__univ_0_0);
init_entry(mercury____Index___std_util__univ_0_0);
@@ -768,6 +809,13 @@
init_label(mercury____Compare___std_util__univ_0_0_i1);
init_entry(mercury____Term_To_Type___std_util__univ_0_0);
init_entry(mercury____Type_To_Term___std_util__univ_0_0);
+
+ init_entry(mercury____Unify___std_util__type_info_0_0);
+ init_entry(mercury____Index___std_util__type_info_0_0);
+ init_entry(mercury____Compare___std_util__type_info_0_0);
+ init_label(mercury____Compare___std_util__type_info_0_0_i1);
+ init_entry(mercury____Term_To_Type___std_util__type_info_0_0);
+ init_entry(mercury____Type_To_Term___std_util__type_info_0_0);
BEGIN_CODE
Define_entry(mercury____Unify___std_util__univ_0_0);
{
@@ -876,6 +924,40 @@
/* don't know what to put here. */
fatal_error(""cannot convert type univ to term"");
+
+Define_entry(mercury____Unify___std_util__type_info_0_0);
+ /*
+ ** Unification for type_info.
+ **
+ ** The two inputs are in the registers named by unify_input[12].
+ ** The success/failure indication should go in unify_output.
+ */
+ unify_output = mercury_compare_type_info(unify_input1, unify_input2);
+ proceed();
+
+Define_entry(mercury____Index___std_util__type_info_0_0);
+ r2 = -1;
+ proceed();
+
+Define_entry(mercury____Compare___std_util__type_info_0_0);
+ /*
+ ** Comparison for type_info:
+ **
+ ** The two inputs are in the registers named by compare_input[12].
+ ** The result should go in compare_output.
+ */
+ compare_output = mercury_compare_type_info(
+ compare_input1, compare_input2);
+ proceed();
+
+Define_entry(mercury____Term_To_Type___std_util__type_info_0_0);
+ /* don't know what to put here. */
+ fatal_error(""cannot convert term to type type_info"");
+
+Define_entry(mercury____Type_To_Term___std_util__type_info_0_0);
+ /* don't know what to put here. */
+ fatal_error(""cannot convert type type_info to term"");
+
END_MODULE
/* Ensure that the initialization code for the above module gets run. */
@@ -943,6 +1025,60 @@
}
").
+type_name(Type) = TypeName :-
+ TypeConsName = type_constructor_name(Type),
+ ( type_constructor_arity(Type) = 0 ->
+ TypeName = TypeConsName
+ ;
+ ArgTypes = type_constructor_args(Type),
+ type_arg_names(ArgTypes, ArgTypeNames),
+ string__append_list([TypeConsName, "(" | ArgTypeNames],
+ TypeName)
+ ).
+
+:- pred type_arg_names(list(type_info), list(string)).
+:- mode type_arg_names(in, out) is det.
+
+type_arg_names([], []).
+type_arg_names([Type|Types], ArgNames) :-
+ Name = type_name(Type),
+ ( Types = [] ->
+ ArgNames = [Name, ")"]
+ ;
+ type_arg_names(Types, Names),
+ ArgNames = [Name, ", " | Names]
+ ).
+
+:- pragma c_code(type_constructor_name(TypeInfo::in) = (TypeName::out),
+ will_not_call_mercury, "
+{
+ Word *type_info = (Word *) TypeInfo;
+ Word *base_type_info = MR_TYPEINFO_GET_BASE_TYPEINFO(type_info);
+ TypeName = MR_BASE_TYPEINFO_GET_TYPE_NAME(base_type_info);
+}
+").
+
+:- pragma c_code(type_constructor_arity(TypeInfo::in) = (TypeArity::out),
+ will_not_call_mercury, "
+{
+ Word *type_info = (Word *) TypeInfo;
+ Word *base_type_info = MR_TYPEINFO_GET_BASE_TYPEINFO(type_info);
+ TypeArity = MR_BASE_TYPEINFO_GET_TYPE_ARITY(base_type_info);
+}
+").
+
+:- pragma c_code(type_constructor_args(TypeInfo::in) = (TypeArgs::out),
+ will_not_call_mercury, "
+{
+ Word *type_info = (Word *) TypeInfo;
+ Word *base_type_info = MR_TYPEINFO_GET_BASE_TYPEINFO(type_info);
+ Integer arity = MR_BASE_TYPEINFO_GET_TYPE_ARITY(base_type_info);
+ save_transient_registers();
+ TypeArgs = ML_copy_argument_typeinfos(arity, 0,
+ type_info + OFFSET_FOR_ARG_TYPE_INFOS);
+ restore_transient_registers();
+}
+").
:- pragma c_code(num_functors(TypeInfo::in) = (Functors::out),
will_not_call_mercury, "
Index: mercury_builtin.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/library/mercury_builtin.m,v
retrieving revision 1.70
diff -u -r1.70 mercury_builtin.m
--- mercury_builtin.m 1997/04/22 02:22:44 1.70
+++ mercury_builtin.m 1997/04/23 23:16:07
@@ -25,6 +25,7 @@
% The types `character', `int', `float', and `string',
% and the types `pred', `pred(T)', `pred(T1, T2)', `pred(T1, T2, T3)', ...
+% and `func(T1) = T2', `func(T1, T2) = T3', `func(T1, T2, T3) = T4', ...
% are builtin and are implemented using special code in the
% type-checker. (XXX TODO: report an error for attempts to redefine
% these types.)
@@ -48,7 +49,9 @@
% The not yet properly supported `any' inst used for the
% constraint solver interface is also builtin.
-% Higher-order predicate insts `pred(<modes>) is <detism>' are also builtin.
+% Higher-order predicate insts `pred(<modes>) is <detism>'
+% and higher-order functions insts `func(<modes>) = <mode> is det'
+% are also builtin.
%-----------------------------------------------------------------------------%
@@ -479,6 +482,8 @@
/* base_type_layout definitions */
+ /* base_type_layout for `int' */
+
const struct mercury_data___base_type_layout_int_0_struct {
TYPE_LAYOUT_FIELDS
} mercury_data___base_type_layout_int_0 = {
@@ -486,6 +491,8 @@
mkbody(TYPELAYOUT_INT_VALUE))
};
+ /* base_type_layout for `character' */
+
const struct mercury_data___base_type_layout_character_0_struct {
TYPE_LAYOUT_FIELDS
} mercury_data___base_type_layout_character_0 = {
@@ -493,6 +500,8 @@
mkbody(TYPELAYOUT_CHARACTER_VALUE))
};
+ /* base_type_layout for `string' */
+
const struct mercury_data___base_type_layout_string_0_struct {
TYPE_LAYOUT_FIELDS
} mercury_data___base_type_layout_string_0 = {
@@ -500,6 +509,8 @@
mkbody(TYPELAYOUT_STRING_VALUE))
};
+ /* base_type_layout for `float' */
+
const struct mercury_data___base_type_layout_float_0_struct {
TYPE_LAYOUT_FIELDS
} mercury_data___base_type_layout_float_0 = {
@@ -507,6 +518,9 @@
mkbody(TYPELAYOUT_FLOAT_VALUE))
};
+ /* base_type_layout for `pred' */
+ /* (this is used for all higher-order types) */
+
const struct mercury_data___base_type_layout_pred_0_struct {
TYPE_LAYOUT_FIELDS
} mercury_data___base_type_layout_pred_0 = {
@@ -514,48 +528,59 @@
mkbody(TYPELAYOUT_PREDICATE_VALUE))
};
- /* The void type */
+ /* base_type_layout for `void' */
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))
+ mkbody(TYPELAYOUT_VOID_VALUE))
};
/* base_type_functors definitions */
+ /* base_type_functors for `int' */
+
const struct mercury_data___base_type_functors_int_0_struct {
Integer f1;
} mercury_data___base_type_functors_int_0 = {
MR_TYPEFUNCTORS_SPECIAL
};
+ /* base_type_functors for `character' */
+
const struct mercury_data___base_type_functors_character_0_struct {
Integer f1;
} mercury_data___base_type_functors_character_0 = {
MR_TYPEFUNCTORS_SPECIAL
};
+ /* base_type_functors for `string' */
+
const struct mercury_data___base_type_functors_string_0_struct {
Integer f1;
} mercury_data___base_type_functors_string_0 = {
MR_TYPEFUNCTORS_SPECIAL
};
+ /* base_type_functors for `float' */
+
const struct mercury_data___base_type_functors_float_0_struct {
Integer f1;
} mercury_data___base_type_functors_float_0 = {
MR_TYPEFUNCTORS_SPECIAL
};
+ /* base_type_functors for `pred' */
+ /* (this is used for all higher-order types) */
+
const struct mercury_data___base_type_functors_pred_0_struct {
Integer f1;
} mercury_data___base_type_functors_pred_0 = {
MR_TYPEFUNCTORS_SPECIAL
};
- /* The void type */
+ /* base_type_functors for `void' */
const struct mercury_data___base_type_functors_void_0_struct {
Integer f1;
@@ -565,6 +590,10 @@
#endif /* USE_TYPE_LAYOUT */
+ /* base_type_infos definitions */
+
+ /* base_type_info for `int' */
+
Declare_entry(mercury__builtin_unify_int_2_0);
Declare_entry(mercury__builtin_index_int_2_0);
Declare_entry(mercury__builtin_compare_int_3_0);
@@ -600,6 +629,7 @@
#endif
};
+ /* base_type_info for `character' */
Declare_entry(mercury__builtin_unify_character_2_0);
Declare_entry(mercury__builtin_index_character_2_0);
@@ -639,6 +669,7 @@
#endif
};
+ /* base_type_info for `string' */
Declare_entry(mercury__builtin_unify_string_2_0);
Declare_entry(mercury__builtin_index_string_2_0);
@@ -675,6 +706,7 @@
#endif
};
+ /* base_type_info for `float' */
Declare_entry(mercury__builtin_unify_float_2_0);
Declare_entry(mercury__builtin_index_float_2_0);
@@ -711,6 +743,8 @@
#endif
};
+ /* base_type_info for `pred' */
+ /* (this is used for all higher-order types) */
Declare_entry(mercury__builtin_unify_pred_2_0);
Declare_entry(mercury__builtin_index_pred_2_0);
@@ -747,7 +781,7 @@
#endif
};
- /* The void type */
+ /* base_type_info for `void' */
Declare_entry(mercury__unused_0_0);
MR_STATIC_CODE_CONST struct mercury_data___base_type_info_void_0_struct {
@@ -892,7 +926,79 @@
%-----------------------------------------------------------------------------%
% The type c_pointer can be used by predicates which use the C interface.
-:- type c_pointer == int.
+
+:- pragma(c_code, "
+
+/*
+ * c_pointer has a special value reserved for its layout, since it needs to
+ * be handled as a special case.
+ */
+
+#ifdef USE_TYPE_LAYOUT
+
+const struct mercury_data_std_util__base_type_layout_c_pointer_0_struct {
+ TYPE_LAYOUT_FIELDS
+} mercury_data_std_util__base_type_layout_c_pointer_0 = {
+ make_typelayout_for_all_tags(TYPELAYOUT_CONST_TAG,
+ mkbody(TYPELAYOUT_C_POINTER_VALUE))
+};
+
+const struct mercury_data_std_util__base_type_functors_c_pointer_0_struct {
+ Integer f1;
+} mercury_data_std_util__base_type_functors_c_pointer_0 = {
+ MR_TYPEFUNCTORS_SPECIAL
+};
+
+#endif
+
+Define_extern_entry(mercury____Unify___std_util__c_pointer_0_0);
+Define_extern_entry(mercury____Index___std_util__c_pointer_0_0);
+Define_extern_entry(mercury____Compare___std_util__c_pointer_0_0);
+Declare_label(mercury____Compare___std_util__c_pointer_0_0_i1);
+Define_extern_entry(mercury____Term_To_Type___std_util__c_pointer_0_0);
+Define_extern_entry(mercury____Type_To_Term___std_util__c_pointer_0_0);
+
+BEGIN_MODULE(unify_c_pointer_module)
+ init_entry(mercury____Unify___std_util__c_pointer_0_0);
+ init_entry(mercury____Index___std_util__c_pointer_0_0);
+ init_entry(mercury____Compare___std_util__c_pointer_0_0);
+ init_label(mercury____Compare___std_util__c_pointer_0_0_i1);
+ init_entry(mercury____Term_To_Type___std_util__c_pointer_0_0);
+ init_entry(mercury____Type_To_Term___std_util__c_pointer_0_0);
+
+BEGIN_CODE
+Define_entry(mercury____Unify___std_util__type_info_0_0);
+ fatal_error(""cannot unify two values of type `c_pointer'"");
+
+Define_entry(mercury____Index___std_util__type_info_0_0);
+ r2 = -1;
+ proceed();
+
+Define_entry(mercury____Compare___std_util__type_info_0_0);
+ fatal_error(""cannot compare two values of type `c_pointer'"");
+
+Define_entry(mercury____Term_To_Type___std_util__c_pointer_0_0);
+ fatal_error(""cannot convert term to type `c_pointer'"");
+
+Define_entry(mercury____Type_To_Term___std_util__c_pointer_0_0);
+ fatal_error(""cannot convert type `c_pointer' to term"");
+
+END_MODULE
+
+/* Ensure that the initialization code for the above module gets run. */
+/*
+INIT sys_init_unify_c_pointer_module
+*/
+extern ModuleFunc unify_c_pointer_module;
+void sys_init_unify_c_pointer_module(void);
+ /* duplicate declaration to suppress gcc -Wmissing-decl warning */
+void sys_init_unify_c_pointer_module(void) {
+ unify_c_pointer_module();
+}
+
+").
+
+
:- end_module mercury_builtin.
More information about the developers
mailing list