[m-rev.] for review: make get_functor handle existential types
Zoltan Somogyi
zs at cs.mu.OZ.AU
Mon Dec 13 13:25:01 AEDT 2004
For review by anyone.
Zoltan.
Type_desc__get_functor looks up the types of the arguments of a function
symbol. This predicate used to abort when an argument has an existential
type. This diff makes type_desc__get_functor work even in that case.
However, since in such cases the type of an argument is not a ground type,
this diff has to add the concept of a pseudo_type_desc, a descriptor for
a not necessarily ground type. Pseudo_type_descs are implemented as
MR_PseudoTypeInfos.
runtime/mercury_type_info.[ch]:
Add new macros to operate on pseudo_type_infos. Most have a structure
modelled on corresponding macros operating on type_infos.
Provide versions of MR_get_arg_type_info, MR_compare_type_info,
MR_unify_type_info, MR_collapse_equivalences,
MR_type_params_vector_to_list, MR_create_type_info and
MR_create_type_info_maybe_existq that work on pseudo_type_infos,
not type_infos.
Change MR_pseudo_type_info_vector_to_type_info_list, which implements
the core of get_functor, to return pseudo_type_infos instead of
type_infos, and rename it to reflect this fact.
Change to four-space indentation to reduce the number of lines
that have to be wrapped.
runtime/mercury_make_type_info_body.h:
Generalize the code for creating type_infos to also be handle
pseudo_type_infos.
Change to four-space indentation to reduce the number of lines
that have to be wrapped.
runtime/mercury_type_desc.[ch]:
Provide versions of MR_make_type_ctor_desc and MR_type_ctor_and_args
that work on pseudo_type_infos, not type_infos.
Change to four-space indentation to reduce the number of lines
that have to be wrapped.
runtime/mercury_builtin_types.[ch]:
runtime/mercury_builtin_types_proc_layouts.h:
runtime/mercury_hlc_types.h:
runtime/mercury_unify_compare_body.h:
Add the C types, global variables and functions necessary for the
new builtin Mercury type pseudo_type_desc. This type must be builtin,
because its structure (MR_PseudoTypeInfo) is defined in C, and as such
cannot be unified, compared, deconstructed etc without hand-written
C code.
runtime/mercury_deep_copy.c:
runtime/mercury_deep_copy_body.h:
Handle the copying of pseudo_type_infos/pseudo_type_descs. This code
is almost the same as the code to copy type_infos, but must of course
handle type variables, and the arguments are themselves copied as
pseudo_type_infos, not type_infos.
runtime/mercury_types.h:
Since deep copy needs to create pseudo_type_infos, provide a version
of the MR_PseudoTypeInfo type without const.
runtime/mercury_construct.c:
runtime/mercury_deconstruct.c:
Handle pseudo_type_descs just as we handle type_descs: neither can be
constructed, nor do they have function symbols with named arguments.
runtime/mercury_ml_expand_body.c:
Provide code to deconstruct pseudo_type_descs. This code is almost
the same as the code to deconstruct type_descs, but must of course
handle type variables, and the arguments are themselves
pseudo_type_descs, not type_descs.
runtime/mercury_tabling.c:
Catch attempts to table pseudo_type_infos.
runtime/mercury_tags.h:
Add macros for constructing lists of
pseudo_type_infos/pseudo_type_descs.
runtime/mercury_wrapper.[ch]:
Define global variables holding the addresses of the typeinfos for
describing pseudo_type_descs and lists of pseudo_type_descs.
runtime/mercury_init.c:
Add the extern declarations required by new code in mkinit.c.
util/mkinit.c:
Make the addresses of the typeinfos for describing pseudo_type_descs
and lists of pseudo_type_descs, defined in the library, known to the
runtime.
library/type_desc.m:
Add a new builtin type, pseudo_type_desc, for describing possibly
nonground types.
Add utility predicates for operating on pseudo_type_descs.
library/private_builtin.m:
Handle the new builtin type.
Add builtin typeinfos for describing pseudo_type_descs and lists of
pseudo_type_descs, since some functions in the runtime need them
for memory profiling.
library/rtti_implementation.m:
Handle the new builtin type, mostly by ignoring it, since the backends
that use this module do not have any notion of pseudo_type_infos.
Bring the module up to date with our formatting guidelines.
library/construct.m:
Make get_functor return a list of pseudo_type_descs instead of
type_descs.
Change the name of the version of get_functor that returns argument
names, to distinguish it from the base version by more than just the
arity.
Make the order of predicates more logical.
library/std_util.m:
Change the name of the version of get_functor that returns argument
names, to distinguish it from the base version by more than just the
arity.
However, this name change is effectively the only change: both
get_functor and get_functor_with_names still return lists of
type_descs. This means that they will throw exceptions in the presence
of existential types, but code using them need no algorithmic changes.
library/term.m:
library/term_to_xml.m:
Add module qualifiers as necessary; no algorithmic changes.
library/list.m:
Add two general-purpose predicates, all_true and all_false,
for use in the other library modules.
compiler/ml_util.m:
compiler/rtti.m:
compiler/type_ctor_info.m:
Make sure we handle the new builtin type as a builtin type, and not
try to have the compiler create a type_ctor_into for it.
deep_profiler/canonical.m:
Delete the local definition of all_true.
tests/hard_coded/construct_test.{m,exp}:
Update this test case to test the ability to retrieve the names of the
fields of function symbols with existential types.
Add module qualifications as necessary.
tests/hard_coded/construct_test_exist.{m,exp}:
Add a tougher test case to print the types of the arguments of
function symbols with existential types.
tests/hard_coded/Mmakefile:
Add the new test case, and sort the names of the tests.
cvs diff: Diffing .
cvs diff: Diffing analysis
cvs diff: Diffing bindist
cvs diff: Diffing boehm_gc
cvs diff: Diffing boehm_gc/Mac_files
cvs diff: Diffing boehm_gc/cord
cvs diff: Diffing boehm_gc/cord/private
cvs diff: Diffing boehm_gc/doc
cvs diff: Diffing boehm_gc/include
cvs diff: Diffing boehm_gc/include/private
cvs diff: Diffing boehm_gc/tests
cvs diff: Diffing browser
cvs diff: Diffing bytecode
cvs diff: Diffing compiler
Index: compiler/ml_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_util.m,v
retrieving revision 1.31
diff -u -b -r1.31 ml_util.m
--- compiler/ml_util.m 2 Aug 2004 08:30:07 -0000 1.31
+++ compiler/ml_util.m 11 Dec 2004 11:08:34 -0000
@@ -620,6 +620,7 @@
; TypeName = qualified(RttiImplementation, _)
; TypeName = qualified(TypeDesc, "type_desc")
+ ; TypeName = qualified(TypeDesc, "pseudo_type_desc")
; TypeName = qualified(TypeDesc, "type_ctor_desc")
% Types which don't have a Mercury representation.
Index: compiler/mlds_to_gcc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_gcc.m,v
retrieving revision 1.99
diff -u -b -r1.99 mlds_to_gcc.m
--- compiler/mlds_to_gcc.m 20 Oct 2004 09:44:58 -0000 1.99
+++ compiler/mlds_to_gcc.m 11 Dec 2004 12:26:38 -0000
@@ -2504,7 +2504,8 @@
rtti_enum_const("MR_TYPECTOR_REP_FOREIGN", 37).
rtti_enum_const("MR_TYPECTOR_REP_REFERENCE", 38).
rtti_enum_const("MR_TYPECTOR_REP_STABLE_C_POINTER", 39).
-rtti_enum_const("MR_TYPECTOR_REP_UNKNOWN", 40).
+rtti_enum_const("MR_TYPECTOR_REP_PSEUDOTYPEDESC", 40).
+rtti_enum_const("MR_TYPECTOR_REP_UNKNOWN", 41).
rtti_enum_const("MR_SECTAG_NONE", 0).
rtti_enum_const("MR_SECTAG_LOCAL", 1).
rtti_enum_const("MR_SECTAG_REMOTE", 2).
Index: compiler/rtti.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rtti.m,v
retrieving revision 1.51
diff -u -b -r1.51 rtti.m
--- compiler/rtti.m 20 Oct 2004 09:44:59 -0000 1.51
+++ compiler/rtti.m 11 Dec 2004 12:27:50 -0000
@@ -373,6 +373,7 @@
; tuple
; ref
; type_desc
+ ; pseudo_type_desc
; type_ctor_desc.
% The list of type constructors that are used behind the scenes by
@@ -1520,6 +1521,8 @@
builtin_ctor_rep_to_string(tuple, "MR_TYPECTOR_REP_TUPLE").
builtin_ctor_rep_to_string(ref, "MR_TYPECTOR_REP_REFERENCE").
builtin_ctor_rep_to_string(type_ctor_desc, "MR_TYPECTOR_REP_TYPECTORDESC").
+builtin_ctor_rep_to_string(pseudo_type_desc,
+ "MR_TYPECTOR_REP_BASETYPECTORDESC").
builtin_ctor_rep_to_string(type_desc, "MR_TYPECTOR_REP_TYPEDESC").
:- pred impl_ctor_rep_to_string(impl_ctor::in, string::out) is det.
Index: compiler/type_ctor_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/type_ctor_info.m,v
retrieving revision 1.59
diff -u -b -r1.59 type_ctor_info.m
--- compiler/type_ctor_info.m 5 Sep 2004 23:52:46 -0000 1.59
+++ compiler/type_ctor_info.m 11 Dec 2004 11:08:34 -0000
@@ -446,6 +446,7 @@
builtin_type_ctor("builtin", "tuple", 0, tuple).
builtin_type_ctor("private_builtin", "ref", 1, ref).
builtin_type_ctor("type_desc", "type_ctor_desc", 0, type_ctor_desc).
+builtin_type_ctor("type_desc", "pseudo_type_desc", 0, pseudo_type_desc).
builtin_type_ctor("type_desc", "type_desc", 0, type_desc).
:- pred impl_type_ctor(string::in, string::in, int::in, impl_ctor::out)
cvs diff: Diffing compiler/notes
cvs diff: Diffing debian
cvs diff: Diffing deep_profiler
Index: deep_profiler/canonical.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/deep_profiler/canonical.m,v
retrieving revision 1.3
diff -u -b -r1.3 canonical.m
--- deep_profiler/canonical.m 2 Sep 2002 03:17:53 -0000 1.3
+++ deep_profiler/canonical.m 11 Dec 2004 13:48:31 -0000
@@ -1011,16 +1011,6 @@
%-----------------------------------------------------------------------------%
- % list__all_true(P, L) succeeds iff P is true for all elements of the
- % list L.
-:- pred all_true(pred(X), list(X)).
-:- mode all_true(pred(in) is semidet, in) is semidet.
-
-all_true(_, []).
-all_true(P, [H | T]) :-
- call(P, H),
- all_true(P, T).
-
% array_match_elements(Min, Max, BaseArray, OtherArrays):
% Succeeds iff all the elements of all the OtherArrays are equal to the
% corresponding element of BaseArray.
cvs diff: Diffing deep_profiler/notes
cvs diff: Diffing doc
cvs diff: Diffing extras
cvs diff: Diffing extras/aditi
cvs diff: Diffing extras/cgi
cvs diff: Diffing extras/complex_numbers
cvs diff: Diffing extras/complex_numbers/samples
cvs diff: Diffing extras/complex_numbers/tests
cvs diff: Diffing extras/concurrency
cvs diff: Diffing extras/curs
cvs diff: Diffing extras/curs/samples
cvs diff: Diffing extras/curses
cvs diff: Diffing extras/curses/sample
cvs diff: Diffing extras/dynamic_linking
cvs diff: Diffing extras/error
cvs diff: Diffing extras/graphics
cvs diff: Diffing extras/graphics/easyx
cvs diff: Diffing extras/graphics/easyx/samples
cvs diff: Diffing extras/graphics/mercury_glut
cvs diff: Diffing extras/graphics/mercury_opengl
cvs diff: Diffing extras/graphics/mercury_tcltk
cvs diff: Diffing extras/graphics/samples
cvs diff: Diffing extras/graphics/samples/calc
cvs diff: Diffing extras/graphics/samples/gears
cvs diff: Diffing extras/graphics/samples/maze
cvs diff: Diffing extras/graphics/samples/pent
cvs diff: Diffing extras/lazy_evaluation
cvs diff: Diffing extras/lex
cvs diff: Diffing extras/lex/samples
cvs diff: Diffing extras/lex/tests
cvs diff: Diffing extras/logged_output
cvs diff: Diffing extras/moose
cvs diff: Diffing extras/moose/samples
cvs diff: Diffing extras/moose/tests
cvs diff: Diffing extras/morphine
cvs diff: Diffing extras/morphine/non-regression-tests
cvs diff: Diffing extras/morphine/scripts
cvs diff: Diffing extras/morphine/source
cvs diff: Diffing extras/odbc
cvs diff: Diffing extras/posix
cvs diff: Diffing extras/quickcheck
cvs diff: Diffing extras/quickcheck/tutes
cvs diff: Diffing extras/references
cvs diff: Diffing extras/references/samples
cvs diff: Diffing extras/references/tests
cvs diff: Diffing extras/stream
cvs diff: Diffing extras/trailed_update
cvs diff: Diffing extras/trailed_update/samples
cvs diff: Diffing extras/trailed_update/tests
cvs diff: Diffing extras/xml
cvs diff: Diffing extras/xml/samples
cvs diff: Diffing extras/xml_stylesheets
cvs diff: Diffing java
cvs diff: Diffing java/runtime
cvs diff: Diffing library
Index: library/construct.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/construct.m,v
retrieving revision 1.17
diff -u -b -r1.17 construct.m
--- library/construct.m 7 Jul 2004 07:11:05 -0000 1.17
+++ library/construct.m 11 Dec 2004 08:43:26 -0000
@@ -41,9 +41,9 @@
% FunctorNumber is out of range.
%
:- pred get_functor(type_desc__type_desc::in, int::in, string::out, int::out,
- list(type_desc__type_desc)::out) is semidet.
+ list(type_desc__pseudo_type_desc)::out) is semidet.
- % get_functor(Type, FunctorNumber, FunctorName, Arity, ArgTypes,
+ % get_functor_with_names(Type, FunctorNumber, FunctorName, Arity, ArgTypes,
% ArgNames)
%
% Binds FunctorName and Arity to the name and arity of functor number
@@ -52,8 +52,8 @@
% field name of each functor argument, if any. Fails if the type is
% not a discriminated union type, or if FunctorNumber is out of range.
%
-:- pred get_functor(type_desc__type_desc::in, int::in, string::out, int::out,
- list(type_desc__type_desc)::out, list(maybe(string))::out)
+:- pred get_functor_with_names(type_desc__type_desc::in, int::in, string::out,
+ int::out, list(type_desc__pseudo_type_desc)::out, list(maybe(string))::out)
is semidet.
% get_functor_ordinal(Type, I, Ordinal)
@@ -107,9 +107,32 @@
num_functors(TypeDesc) = rtti_implementation__num_functors(TypeDesc).
+get_functor(TypeInfo, FunctorNumber, FunctorName, Arity,
+ PseudoTypeInfoList) :-
+ get_functor_internal(TypeInfo, FunctorNumber, FunctorName, Arity,
+ PseudoTypeInfoList).
+
+get_functor_with_names(TypeDesc, I, Functor, Arity,
+ PseudoTypeInfoList, ArgNameList) :-
+ get_functor_with_names_internal(TypeDesc, I, Functor, Arity,
+ PseudoTypeInfoList, ArgNameList0),
+ ArgNameList = map(null_to_no, ArgNameList0).
+
+:- pred get_functor_internal(type_desc__type_desc::in, int::in, string::out,
+ int::out, list(type_desc__pseudo_type_desc)::out) is semidet.
+
+get_functor_internal(TypeInfo, FunctorNumber, FunctorName, Arity,
+ MaybeTypeInfoList) :-
+ rtti_implementation__get_functor(TypeInfo, FunctorNumber,
+ FunctorName, Arity, TypeInfoList),
+ % The backends in which we use this definition of this predicate
+ % don't yet support function symbols with existential types, which is
+ % the only kind of function symbol in which we may want to return unbound.
+ MaybeTypeInfoList = list__map(type_desc_to_pseudo_type_desc, TypeInfoList).
+
:- pragma foreign_proc("C",
- get_functor(TypeDesc::in, FunctorNumber::in, FunctorName::out,
- Arity::out, TypeInfoList::out),
+ get_functor_internal(TypeDesc::in, FunctorNumber::in, FunctorName::out,
+ Arity::out, PseudoTypeInfoList::out),
[will_not_call_mercury, thread_safe, promise_pure],
"{
MR_TypeInfo type_info;
@@ -127,10 +150,9 @@
MR_restore_transient_registers();
/*
- ** Get information for this functor number and
- ** store in construct_info. If this is a discriminated union
- ** type and if the functor number is in range, we
- ** succeed.
+ ** Get information for this functor number and store in construct_info.
+ ** If this is a discriminated union type and if the functor number
+ ** is in range, we succeed.
*/
MR_save_transient_registers();
success = MR_get_functors_check_range(FunctorNumber, type_info,
@@ -151,13 +173,14 @@
MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info)))
{
MR_save_transient_registers();
- TypeInfoList = MR_type_params_vector_to_list(Arity,
+ PseudoTypeInfoList = MR_type_params_vector_to_list(Arity,
MR_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(type_info));
MR_restore_transient_registers();
} else {
MR_save_transient_registers();
- TypeInfoList = MR_pseudo_type_info_vector_to_type_info_list(
- arity, MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info),
+ PseudoTypeInfoList =
+ MR_pseudo_type_info_vector_to_pseudo_type_info_list(arity,
+ MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info),
construct_info.arg_pseudo_type_infos);
MR_restore_transient_registers();
}
@@ -165,48 +188,23 @@
SUCCESS_INDICATOR = success;
}").
-get_functor(TypeInfo, FunctorNumber, FunctorName, Arity, TypeInfoList) :-
- rtti_implementation__get_functor(TypeInfo, FunctorNumber,
- FunctorName, Arity, TypeInfoList).
-
-get_functor(TypeDesc, I, Functor, Arity, TypeInfoList, ArgNameList) :-
- get_functor_2(TypeDesc, I, Functor, Arity, TypeInfoList, ArgNameList0),
- ArgNameList = map(null_to_no, ArgNameList0).
-
-:- func null_to_no(string) = maybe(string).
-
-null_to_no(S) = ( if null(S) then no else yes(S) ).
-
-:- pred null(string).
-:- mode null(in) is semidet.
-
-:- pragma foreign_proc("C",
- null(S::in),
- [will_not_call_mercury, thread_safe, promise_pure],
-"
- SUCCESS_INDICATOR = (S == NULL);
-").
-
-:- pragma foreign_proc("C#",
- null(S::in),
- [will_not_call_mercury, thread_safe, promise_pure],
-"
- SUCCESS_INDICATOR = (S == null);
-").
-
-:- pragma foreign_proc("Java",
- null(S::in),
- [will_not_call_mercury, thread_safe, promise_pure],
-"
- succeeded = (S == null);
-").
-
-:- pred get_functor_2(type_desc__type_desc::in, int::in, string::out, int::out,
- list(type_desc__type_desc)::out, list(string)::out) is semidet.
+:- pred get_functor_with_names_internal(type_desc__type_desc::in, int::in,
+ string::out, int::out, list(type_desc__pseudo_type_desc)::out,
+ list(string)::out) is semidet.
+
+get_functor_with_names_internal(TypeDesc, FunctorNumber, FunctorName, Arity,
+ MaybeTypeInfoList, Names) :-
+ rtti_implementation__get_functor_with_names(TypeDesc, FunctorNumber,
+ FunctorName, Arity, TypeInfoList, Names),
+ % The backends in which we use this definition of this predicate
+ % don't yet support function symbols with existential types, which is
+ % the only kind of function symbol in which we may want to return unbound.
+ MaybeTypeInfoList = list__map(type_desc_to_pseudo_type_desc, TypeInfoList).
:- pragma foreign_proc("C",
- get_functor_2(TypeDesc::in, FunctorNumber::in, FunctorName::out,
- Arity::out, TypeInfoList::out, ArgNameList::out),
+ get_functor_with_names_internal(TypeDesc::in, FunctorNumber::in,
+ FunctorName::out, Arity::out, PseudoTypeInfoList::out,
+ ArgNameList::out),
[will_not_call_mercury, thread_safe, promise_pure],
"{
MR_TypeInfo type_info;
@@ -230,8 +228,8 @@
** succeed.
*/
MR_save_transient_registers();
- success = MR_get_functors_check_range(FunctorNumber,
- type_info, &construct_info);
+ success = MR_get_functors_check_range(FunctorNumber, type_info,
+ &construct_info);
MR_restore_transient_registers();
/*
@@ -250,7 +248,7 @@
int i;
MR_save_transient_registers();
- TypeInfoList = MR_type_params_vector_to_list(Arity,
+ PseudoTypeInfoList = MR_type_params_vector_to_list(Arity,
MR_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(type_info));
ArgNameList = MR_list_empty();
for (i = 0; i < Arity; i++) {
@@ -260,8 +258,9 @@
MR_restore_transient_registers();
} else {
MR_save_transient_registers();
- TypeInfoList = MR_pseudo_type_info_vector_to_type_info_list(
- arity, MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info),
+ PseudoTypeInfoList =
+ MR_pseudo_type_info_vector_to_pseudo_type_info_list(arity,
+ MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info),
construct_info.arg_pseudo_type_infos);
ArgNameList = MR_arg_name_vector_to_list(arity,
construct_info.arg_names);
@@ -271,10 +270,33 @@
SUCCESS_INDICATOR = success;
}").
-get_functor_2(TypeDesc, FunctorNumber,
- FunctorName, Arity, TypeInfoList, Names) :-
- rtti_implementation__get_functor_2(TypeDesc, FunctorNumber,
- FunctorName, Arity, TypeInfoList, Names).
+:- func null_to_no(string) = maybe(string).
+
+null_to_no(S) = ( if null(S) then no else yes(S) ).
+
+:- pred null(string).
+:- mode null(in) is semidet.
+
+:- pragma foreign_proc("C",
+ null(S::in),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+ SUCCESS_INDICATOR = (S == NULL);
+").
+
+:- pragma foreign_proc("C#",
+ null(S::in),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+ SUCCESS_INDICATOR = (S == null);
+").
+
+:- pragma foreign_proc("Java",
+ null(S::in),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+ succeeded = (S == null);
+").
:- pragma foreign_proc("C",
get_functor_ordinal(TypeDesc::in, FunctorNumber::in, Ordinal::out),
Index: library/list.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/list.m,v
retrieving revision 1.127
diff -u -b -r1.127 list.m
--- library/list.m 10 Dec 2004 00:45:45 -0000 1.127
+++ library/list.m 13 Dec 2004 01:57:57 -0000
@@ -692,6 +692,18 @@
in, out) is nondet,
in, out, in, out, in, out, in, out, in, out, in, out) is nondet.
+ % list__all_true(Pred, List) takes a closure with one input argument.
+ % If Pred succeeds for every member of List, all_true succeeds.
+ % If Pred fails for any member of List, all_true fails.
+:- pred list__all_true(pred(X)::in(pred(in) is semidet), list(X)::in)
+ is semidet.
+
+ % list__all_false(Pred, List) takes a closure with one input argument.
+ % If Pred fails for every member of List, all_false succeeds.
+ % If Pred succeeds for any member of List, all_false fails.
+:- pred list__all_false(pred(X)::in(pred(in) is semidet), list(X)::in)
+ is semidet.
+
% list__filter(Pred, List, TrueList) takes a closure with one
% input argument and for each member of List `X', calls the closure.
% Iff call(Pred, X) is true, then X is included in TrueList.
@@ -1445,6 +1457,16 @@
list__foldr(P, [H | T], !A) :-
list__foldr(P, T, !A),
call(P, H, !A).
+
+list__all_true(_P, []).
+list__all_true(P, [X | Xs]) :-
+ P(X),
+ list__all_true(P, Xs).
+
+list__all_false(_P, []).
+list__all_false(P, [X | Xs]) :-
+ not P(X),
+ list__all_false(P, Xs).
list__filter(P, Xs, Ys) :-
list__filter(P, Xs, Ys, _).
Index: library/private_builtin.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/private_builtin.m,v
retrieving revision 1.138
diff -u -b -r1.138 private_builtin.m
--- library/private_builtin.m 2 Aug 2004 08:30:17 -0000 1.138
+++ library/private_builtin.m 11 Dec 2004 12:28:55 -0000
@@ -472,7 +472,8 @@
public static int MR_TYPECTOR_REP_FOREIGN =37;
public static int MR_TYPECTOR_REP_REFERENCE =38;
public static int MR_TYPECTOR_REP_STABLE_C_POINTER =39;
-public static int MR_TYPECTOR_REP_UNKNOWN =40;
+public static int MR_TYPECTOR_REP_PSEUDOTYPEDESC =40;
+public static int MR_TYPECTOR_REP_UNKNOWN =41;
public static int MR_SECTAG_NONE = 0;
public static int MR_SECTAG_LOCAL = 1;
@@ -1154,6 +1155,15 @@
{ (MR_TypeInfo) &MR_TYPE_CTOR_INFO_NAME(builtin, void, 0) }
};
+const MR_FA_TypeInfo_Struct1 ML_type_info_for_pseudo_type_info = {
+ /*
+ ** For the time being, we handle pseudo_type_infos the same way
+ ** as we handle type_infos.
+ */
+ &MR_TYPE_CTOR_INFO_NAME(private_builtin, type_info, 1),
+ { (MR_TypeInfo) &MR_TYPE_CTOR_INFO_NAME(builtin, void, 0) }
+};
+
const MR_FA_TypeInfo_Struct1 ML_type_info_for_list_of_univ = {
&MR_TYPE_CTOR_INFO_NAME(list, list, 1),
{ (MR_TypeInfo) &MR_TYPE_CTOR_INFO_NAME(std_util, univ, 0) }
@@ -1179,6 +1189,16 @@
{ (MR_TypeInfo) &ML_type_info_for_type_info }
};
+
+const MR_FA_TypeInfo_Struct1 ML_type_info_for_list_of_pseudo_type_info = {
+ &MR_TYPE_CTOR_INFO_NAME(list, list, 1),
+ /*
+ ** For the time being, we handle pseudo_type_infos the same way
+ ** as we handle type_infos.
+ */
+ { (MR_TypeInfo) &ML_type_info_for_type_info }
+};
+
").
%-----------------------------------------------------------------------------%
@@ -1373,7 +1393,8 @@
public static final int MR_TYPECTOR_REP_FOREIGN = 37;
public static final int MR_TYPECTOR_REP_REFERENCE = 38;
public static final int MR_TYPECTOR_REP_STABLE_C_POINTER = 39;
- public static final int MR_TYPECTOR_REP_UNKNOWN = 40;
+ public static final int MR_TYPECTOR_REP_PSEUDOTYPEDESC = 40;
+ public static final int MR_TYPECTOR_REP_UNKNOWN = 41;
public static final int MR_SECTAG_NONE = 0;
public static final int MR_SECTAG_LOCAL = 1;
Index: library/rtti_implementation.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/rtti_implementation.m,v
retrieving revision 1.54
diff -u -b -r1.54 rtti_implementation.m
--- library/rtti_implementation.m 2 Aug 2004 08:30:17 -0000 1.54
+++ library/rtti_implementation.m 11 Dec 2004 11:53:29 -0000
@@ -150,6 +150,7 @@
; reference
; stable_c_pointer
; stable_foreign
+ ; pseudo_type_desc
; unknown.
% We keep all the other types abstract.
@@ -180,104 +181,145 @@
num_functors(TypeDesc) = NumFunctors :-
TypeCtorInfo = get_type_ctor_info(unsafe_cast(TypeDesc)),
TypeCtorRep = TypeCtorInfo ^ type_ctor_rep,
- ( TypeCtorRep = du,
+ (
+ TypeCtorRep = du,
NumFunctors = TypeCtorInfo ^ type_ctor_num_functors
- ; TypeCtorRep = du_usereq,
+ ;
+ TypeCtorRep = du_usereq,
NumFunctors = TypeCtorInfo ^ type_ctor_num_functors
- ; TypeCtorRep = reserved_addr,
+ ;
+ TypeCtorRep = reserved_addr,
NumFunctors = TypeCtorInfo ^ type_ctor_num_functors
- ; TypeCtorRep = reserved_addr_usereq,
+ ;
+ TypeCtorRep = reserved_addr_usereq,
NumFunctors = TypeCtorInfo ^ type_ctor_num_functors
- ; TypeCtorRep = enum,
+ ;
+ TypeCtorRep = enum,
NumFunctors = TypeCtorInfo ^ type_ctor_num_functors
- ; TypeCtorRep = enum_usereq,
+ ;
+ TypeCtorRep = enum_usereq,
NumFunctors = TypeCtorInfo ^ type_ctor_num_functors
-
- ; TypeCtorRep = notag,
+ ;
+ TypeCtorRep = notag,
NumFunctors = 1
- ; TypeCtorRep = notag_usereq,
+ ;
+ TypeCtorRep = notag_usereq,
NumFunctors = 1
- ; TypeCtorRep = notag_ground,
+ ;
+ TypeCtorRep = notag_ground,
NumFunctors = 1
- ; TypeCtorRep = notag_ground_usereq,
+ ;
+ TypeCtorRep = notag_ground_usereq,
NumFunctors = 1
- ; TypeCtorRep = tuple,
+ ;
+ TypeCtorRep = tuple,
NumFunctors = 1
- ; TypeCtorRep = subgoal,
+ ;
+ TypeCtorRep = subgoal,
NumFunctors = -1
-
- ; TypeCtorRep = equiv_ground,
+ ;
+ TypeCtorRep = equiv_ground,
error("rtti_implementation num_functors for equiv types")
- ; TypeCtorRep = equiv,
+ ;
+ TypeCtorRep = equiv,
error("rtti_implementation num_functors for equiv types")
-
- ; TypeCtorRep = int,
+ ;
+ TypeCtorRep = int,
+ NumFunctors = -1
+ ;
+ TypeCtorRep = char,
NumFunctors = -1
- ; TypeCtorRep = char,
+ ;
+ TypeCtorRep = float,
NumFunctors = -1
- ; TypeCtorRep = float,
+ ;
+ TypeCtorRep = string,
NumFunctors = -1
- ; TypeCtorRep = string,
+ ;
+ TypeCtorRep = (func),
NumFunctors = -1
- ; TypeCtorRep = (func),
+ ;
+ TypeCtorRep = (pred),
NumFunctors = -1
- ; TypeCtorRep = (pred),
+ ;
+ TypeCtorRep = void,
NumFunctors = -1
- ; TypeCtorRep = void,
+ ;
+ TypeCtorRep = c_pointer,
NumFunctors = -1
- ; TypeCtorRep = c_pointer,
+ ;
+ TypeCtorRep = stable_c_pointer,
NumFunctors = -1
- ; TypeCtorRep = stable_c_pointer,
+ ;
+ TypeCtorRep = typeinfo,
NumFunctors = -1
- ; TypeCtorRep = typeinfo,
+ ;
+ TypeCtorRep = type_ctor_info,
NumFunctors = -1
- ; TypeCtorRep = type_ctor_info,
+ ;
+ TypeCtorRep = type_desc,
NumFunctors = -1
- ; TypeCtorRep = type_desc,
+ ;
+ TypeCtorRep = pseudo_type_desc,
NumFunctors = -1
- ; TypeCtorRep = type_ctor_desc,
+ ;
+ TypeCtorRep = type_ctor_desc,
NumFunctors = -1
- ; TypeCtorRep = typeclassinfo,
+ ;
+ TypeCtorRep = typeclassinfo,
NumFunctors = -1
- ; TypeCtorRep = base_typeclass_info,
+ ;
+ TypeCtorRep = base_typeclass_info,
NumFunctors = -1
- ; TypeCtorRep = array,
+ ;
+ TypeCtorRep = array,
NumFunctors = -1
- ; TypeCtorRep = succip,
+ ;
+ TypeCtorRep = succip,
NumFunctors = -1
- ; TypeCtorRep = hp,
+ ;
+ TypeCtorRep = hp,
NumFunctors = -1
- ; TypeCtorRep = curfr,
+ ;
+ TypeCtorRep = curfr,
NumFunctors = -1
- ; TypeCtorRep = maxfr,
+ ;
+ TypeCtorRep = maxfr,
NumFunctors = -1
- ; TypeCtorRep = redofr,
+ ;
+ TypeCtorRep = redofr,
NumFunctors = -1
- ; TypeCtorRep = redoip,
+ ;
+ TypeCtorRep = redoip,
NumFunctors = -1
- ; TypeCtorRep = trail_ptr,
+ ;
+ TypeCtorRep = trail_ptr,
NumFunctors = -1
- ; TypeCtorRep = ticket,
+ ;
+ TypeCtorRep = ticket,
NumFunctors = -1
- ; TypeCtorRep = foreign,
+ ;
+ TypeCtorRep = foreign,
NumFunctors = -1
- ; TypeCtorRep = stable_foreign,
+ ;
+ TypeCtorRep = stable_foreign,
NumFunctors = -1
- ; TypeCtorRep = reference,
+ ;
+ TypeCtorRep = reference,
NumFunctors = -1
-
- ; TypeCtorRep = unknown,
+ ;
+ TypeCtorRep = unknown,
error("num_functors: unknown type_ctor_rep")
).
get_functor(TypeDesc, FunctorNumber, FunctorName, Arity, TypeInfoList) :-
- get_functor_impl(TypeDesc, FunctorNumber,
- FunctorName, Arity, TypeInfoList, _Names).
+ get_functor_impl(TypeDesc, FunctorNumber, FunctorName, Arity,
+ TypeInfoList, _Names).
-get_functor_2(TypeDesc, FunctorNumber,
- FunctorName, Arity, TypeInfoList, Names) :-
- get_functor_impl(TypeDesc, FunctorNumber,
- FunctorName, Arity, TypeInfoList, Names).
+get_functor_2(TypeDesc, FunctorNumber, FunctorName, Arity, TypeInfoList,
+ Names) :-
+ get_functor_impl(TypeDesc, FunctorNumber, FunctorName, Arity,
+ TypeInfoList, Names).
:- pred get_functor_impl(type_desc__type_desc::in, int::in,
string::out, int::out, list(type_desc__type_desc)::out,
@@ -290,132 +332,159 @@
TypeInfo = unsafe_cast(TypeDesc),
TypeCtorInfo = get_type_ctor_info(TypeInfo),
TypeCtorRep = TypeCtorInfo ^ type_ctor_rep,
- ( TypeCtorRep = du,
+ (
+ TypeCtorRep = du,
get_functor_du(TypeCtorRep, TypeInfo, TypeCtorInfo,
- FunctorNumber, FunctorName, Arity,
- TypeInfoList, Names)
- ; TypeCtorRep = du_usereq,
+ FunctorNumber, FunctorName, Arity, TypeInfoList, Names)
+ ;
+ TypeCtorRep = du_usereq,
get_functor_du(TypeCtorRep, TypeInfo, TypeCtorInfo,
- FunctorNumber, FunctorName, Arity,
- TypeInfoList, Names)
- ; TypeCtorRep = reserved_addr,
+ FunctorNumber, FunctorName, Arity, TypeInfoList, Names)
+ ;
+ TypeCtorRep = reserved_addr,
get_functor_du(TypeCtorRep, TypeInfo, TypeCtorInfo,
- FunctorNumber, FunctorName, Arity,
- TypeInfoList, Names)
- ; TypeCtorRep = reserved_addr_usereq,
+ FunctorNumber, FunctorName, Arity, TypeInfoList, Names)
+ ;
+ TypeCtorRep = reserved_addr_usereq,
get_functor_du(TypeCtorRep, TypeInfo, TypeCtorInfo,
- FunctorNumber, FunctorName, Arity,
- TypeInfoList, Names)
-
- ; TypeCtorRep = subgoal,
+ FunctorNumber, FunctorName, Arity, TypeInfoList, Names)
+ ;
+ TypeCtorRep = subgoal,
fail
-
- ; TypeCtorRep = enum,
+ ;
+ TypeCtorRep = enum,
get_functor_enum(TypeCtorRep, TypeCtorInfo,
- FunctorNumber, FunctorName, Arity,
- TypeInfoList, Names)
- ; TypeCtorRep = enum_usereq,
+ FunctorNumber, FunctorName, Arity, TypeInfoList, Names)
+ ;
+ TypeCtorRep = enum_usereq,
get_functor_enum(TypeCtorRep, TypeCtorInfo,
- FunctorNumber, FunctorName, Arity,
- TypeInfoList, Names)
-
- ; TypeCtorRep = notag,
+ FunctorNumber, FunctorName, Arity, TypeInfoList, Names)
+ ;
+ TypeCtorRep = notag,
get_functor_notag(TypeCtorRep, TypeCtorInfo,
- FunctorNumber, FunctorName, Arity,
- TypeInfoList, Names)
- ; TypeCtorRep = notag_usereq,
+ FunctorNumber, FunctorName, Arity, TypeInfoList, Names)
+ ;
+ TypeCtorRep = notag_usereq,
get_functor_notag(TypeCtorRep, TypeCtorInfo,
- FunctorNumber, FunctorName, Arity,
- TypeInfoList, Names)
- ; TypeCtorRep = notag_ground,
+ FunctorNumber, FunctorName, Arity, TypeInfoList, Names)
+ ;
+ TypeCtorRep = notag_ground,
get_functor_notag(TypeCtorRep, TypeCtorInfo,
- FunctorNumber, FunctorName, Arity,
- TypeInfoList, Names)
- ; TypeCtorRep = notag_ground_usereq,
+ FunctorNumber, FunctorName, Arity, TypeInfoList, Names)
+ ;
+ TypeCtorRep = notag_ground_usereq,
get_functor_notag(TypeCtorRep, TypeCtorInfo,
- FunctorNumber, FunctorName, Arity,
- TypeInfoList, Names)
-
- ; TypeCtorRep = equiv_ground,
+ FunctorNumber, FunctorName, Arity, TypeInfoList, Names)
+ ;
+ TypeCtorRep = equiv_ground,
NewTypeInfo = collapse_equivalences(TypeInfo),
get_functor_impl(unsafe_cast(NewTypeInfo), FunctorNumber,
FunctorName, Arity, TypeInfoList, Names)
- ; TypeCtorRep = equiv,
+ ;
+ TypeCtorRep = equiv,
NewTypeInfo = collapse_equivalences(TypeInfo),
get_functor_impl(unsafe_cast(NewTypeInfo), FunctorNumber,
FunctorName, Arity, TypeInfoList, Names)
-
- ; TypeCtorRep = tuple,
+ ;
+ TypeCtorRep = tuple,
FunctorName = "{}",
Arity = get_var_arity_typeinfo_arity(TypeInfo),
TypeInfoList = iterate(1, Arity, (func(I) =
unsafe_cast(TypeInfo ^ var_arity_type_info_index(I)))
),
Names = list__duplicate(Arity, null_string)
-
- ; TypeCtorRep = int,
+ ;
+ TypeCtorRep = int,
+ fail
+ ;
+ TypeCtorRep = char,
fail
- ; TypeCtorRep = char,
+ ;
+ TypeCtorRep = float,
fail
- ; TypeCtorRep = float,
+ ;
+ TypeCtorRep = string,
fail
- ; TypeCtorRep = string,
+ ;
+ TypeCtorRep = (func),
fail
- ; TypeCtorRep = (func),
+ ;
+ TypeCtorRep = (pred),
fail
- ; TypeCtorRep = (pred),
+ ;
+ TypeCtorRep = void,
fail
- ; TypeCtorRep = void,
+ ;
+ TypeCtorRep = c_pointer,
fail
- ; TypeCtorRep = c_pointer,
+ ;
+ TypeCtorRep = stable_c_pointer,
fail
- ; TypeCtorRep = stable_c_pointer,
+ ;
+ TypeCtorRep = typeinfo,
fail
- ; TypeCtorRep = typeinfo,
+ ;
+ TypeCtorRep = type_ctor_info,
fail
- ; TypeCtorRep = type_ctor_info,
+ ;
+ TypeCtorRep = type_desc,
fail
- ; TypeCtorRep = type_desc,
+ ;
+ TypeCtorRep = pseudo_type_desc,
fail
- ; TypeCtorRep = type_ctor_desc,
+ ;
+ TypeCtorRep = type_ctor_desc,
fail
- ; TypeCtorRep = typeclassinfo,
+ ;
+ TypeCtorRep = typeclassinfo,
fail
- ; TypeCtorRep = base_typeclass_info,
+ ;
+ TypeCtorRep = base_typeclass_info,
fail
- ; TypeCtorRep = array,
+ ;
+ TypeCtorRep = array,
fail
- ; TypeCtorRep = succip,
+ ;
+ TypeCtorRep = succip,
fail
- ; TypeCtorRep = hp,
+ ;
+ TypeCtorRep = hp,
fail
- ; TypeCtorRep = curfr,
+ ;
+ TypeCtorRep = curfr,
fail
- ; TypeCtorRep = maxfr,
+ ;
+ TypeCtorRep = maxfr,
fail
- ; TypeCtorRep = redofr,
+ ;
+ TypeCtorRep = redofr,
fail
- ; TypeCtorRep = redoip,
+ ;
+ TypeCtorRep = redoip,
fail
- ; TypeCtorRep = trail_ptr,
+ ;
+ TypeCtorRep = trail_ptr,
fail
- ; TypeCtorRep = ticket,
+ ;
+ TypeCtorRep = ticket,
fail
- ; TypeCtorRep = foreign,
+ ;
+ TypeCtorRep = foreign,
fail
- ; TypeCtorRep = stable_foreign,
+ ;
+ TypeCtorRep = stable_foreign,
fail
- ; TypeCtorRep = reference,
+ ;
+ TypeCtorRep = reference,
fail
-
- ; TypeCtorRep = unknown,
+ ;
+ TypeCtorRep = unknown,
error("get_functor: unknown type_ctor_rep")
).
-:- pred get_functor_du(type_ctor_rep::in(du), type_info::in, type_ctor_info::in,
- int::in, string::out, int::out,
- list(type_desc__type_desc)::out,
- list(string)::out) is semidet.
+:- pred get_functor_du(type_ctor_rep::in(du), type_info::in,
+ type_ctor_info::in, int::in, string::out, int::out,
+ list(type_desc__type_desc)::out, list(string)::out) is semidet.
get_functor_du(TypeCtorRep, TypeInfo, TypeCtorInfo, FunctorNumber,
FunctorName, Arity, TypeDescList, Names) :-
@@ -468,8 +537,7 @@
:- pred get_functor_notag(type_ctor_rep::in(notag),
type_ctor_info::in, int::in, string::out, int::out,
- list(type_desc__type_desc)::out,
- list(string)::out) is det.
+ list(type_desc__type_desc)::out, list(string)::out) is det.
get_functor_notag(TypeCtorRep, TypeCtorInfo, FunctorNumber,
FunctorName, Arity, TypeDescList, Names) :-
@@ -549,7 +617,8 @@
;
( TypeCtorRep = (pred) ; TypeCtorRep = (func) )
->
- error("rtti_implementation.m: unimplemented: higher order comparisons")
+ error("rtti_implementation.m: unimplemented: "
+ ++ "higher order comparisons")
;
Arity = TypeCtorInfo ^ type_ctor_arity,
ComparePred = TypeCtorInfo ^ type_ctor_compare_pred,
@@ -600,7 +669,8 @@
;
( TypeCtorRep = (pred) ; TypeCtorRep = (func) )
->
- error("rtti_implementation.m: unimplemented: higher order unifications")
+ error("rtti_implementation.m: unimplemented: " ++
+ "higher order unifications")
;
Arity = TypeCtorInfo ^ type_ctor_arity,
UnifyPred = TypeCtorInfo ^ type_ctor_unify_pred,
@@ -940,6 +1010,7 @@
% XXX For other backends this code may have to be completed.
:- func collapse_equivalences(type_info) = type_info.
+
collapse_equivalences(TypeInfo) = NewTypeInfo :-
TypeCtorInfo = get_type_ctor_info(TypeInfo),
(
@@ -949,7 +1020,8 @@
TypeCtorInfo ^ type_ctor_rep = equiv
)
->
- error("rtti_implementation.m: unimplemented: collapsing equivalence types")
+ error("rtti_implementation.m: unimplemented: " ++
+ "collapsing equivalence types")
;
NewTypeInfo = TypeInfo
).
@@ -981,6 +1053,7 @@
).
:- func iterate(int, int, func(int, T)) = list(T).
+
iterate(Start, Max, Func) = Results :-
( Start =< Max ->
Res = Func(Start),
@@ -991,6 +1064,7 @@
:- pred iterate_foldl(int, int, pred(int, T, T), T, T).
:- mode iterate_foldl(in, in, pred(in, in, out) is det, in, out) is det.
+
iterate_foldl(Start, Max, Pred) -->
( { Start =< Max } ->
Pred(Start),
@@ -1285,6 +1359,12 @@
Arguments = []
;
% XXX noncanonical term
+ TypeCtorRep = pseudo_type_desc,
+ Functor = "some_pseudo_type_desc",
+ Arity = 0,
+ Arguments = []
+ ;
+ % XXX noncanonical term
TypeCtorRep = type_ctor_desc,
Functor = "some_type_ctor_desc",
Arity = 0,
@@ -1319,7 +1399,6 @@
:- pred same_array_elem_type(array(T)::unused, T::unused) is det.
same_array_elem_type(_, _).
-
:- inst usereq == bound(enum_usereq; du_usereq; notag_usereq;
notag_ground_usereq; reserved_addr_usereq).
@@ -1335,32 +1414,38 @@
:- mode handle_usereq_type(in, in, in, in(usereq),
in, out, out, out) is cc_multi.
-
handle_usereq_type(Term, TypeInfo, TypeCtorInfo,
TypeCtorRep, NonCanon, Functor, Arity, Arguments) :-
- ( NonCanon = do_not_allow,
+ (
+ NonCanon = do_not_allow,
error("attempt to deconstruct noncanonical term")
- ; NonCanon = canonicalize,
+ ;
+ NonCanon = canonicalize,
Functor = expand_type_name(TypeCtorInfo, yes),
Arity = 0,
Arguments = []
- ; NonCanon = include_details_cc,
- ( TypeCtorRep = enum_usereq,
+ ;
+ NonCanon = include_details_cc,
+ (
+ TypeCtorRep = enum_usereq,
BaseTypeCtorRep = enum
- ; TypeCtorRep = du_usereq,
+ ;
+ TypeCtorRep = du_usereq,
BaseTypeCtorRep = du
- ; TypeCtorRep = notag_usereq,
+ ;
+ TypeCtorRep = notag_usereq,
BaseTypeCtorRep = notag
- ; TypeCtorRep = notag_ground_usereq,
+ ;
+ TypeCtorRep = notag_ground_usereq,
BaseTypeCtorRep = notag_ground
- ; TypeCtorRep = reserved_addr_usereq,
+ ;
+ TypeCtorRep = reserved_addr_usereq,
BaseTypeCtorRep = reserved_addr
),
deconstruct(Term, TypeInfo, TypeCtorInfo, BaseTypeCtorRep,
NonCanon, Functor, Arity, Arguments)
).
-
% MR_expand_type_name from mercury_deconstruct.c
:- func expand_type_name(type_ctor_info, bool) = string.
@@ -1389,8 +1474,8 @@
ArgTypes = FunctorDesc ^ du_functor_arg_types,
PseudoTypeInfo = get_pti_from_arg_types(ArgTypes, Index),
- get_arg_type_info(TypeInfo, PseudoTypeInfo, Term,
- FunctorDesc, ArgTypeInfo),
+ get_arg_type_info(TypeInfo, PseudoTypeInfo, Term, FunctorDesc,
+ ArgTypeInfo),
( ( SecTagLocn = none ; high_level_data ) ->
TagOffset = 0
;
@@ -1553,14 +1638,11 @@
%
% XXX existentially quantified vars are not yet handled.
-:- pred get_type_info_for_var(
- type_info::in, int::in, T::in, du_functor_desc::in,
- type_info::out) is det.
+:- pred get_type_info_for_var( type_info::in, int::in, T::in,
+ du_functor_desc::in, type_info::out) is det.
get_type_info_for_var(TypeInfo, VarNum, Term, FunctorDesc, ArgTypeInfo) :-
- (
- type_variable_is_univ_quant(VarNum)
- ->
+ ( type_variable_is_univ_quant(VarNum) ->
ArgTypeInfo = TypeInfo ^ type_info_index(VarNum)
;
( ExistInfo0 = FunctorDesc ^ du_functor_exist_info ->
@@ -1598,8 +1680,10 @@
det_unimplemented("get_subterm").
:- pragma foreign_proc("C#",
- get_subterm(TypeInfo::in, Term::in, Index::in,
- ExtraArgs::in) = (Arg::out), [promise_pure], "
+ get_subterm(TypeInfo::in, Term::in, Index::in, ExtraArgs::in)
+ = (Arg::out),
+ [promise_pure],
+"
int i = Index + ExtraArgs;
try {
// try low level data
@@ -1619,7 +1703,9 @@
semidet_unimplemented("typeinfo_is_variable").
:- pragma foreign_proc("C#",
- typeinfo_is_variable(TypeInfo::in, VarNum::out), [promise_pure], "
+ typeinfo_is_variable(TypeInfo::in, VarNum::out),
+ [promise_pure],
+"
try {
VarNum = System.Convert.ToInt32(TypeInfo);
SUCCESS_INDICATOR = true;
@@ -1798,14 +1884,18 @@
det_unimplemented("get_remote_secondary_tag").
:- pragma foreign_proc("C#",
- get_primary_tag(X::in) = (Tag::out), [promise_pure], "
+ get_primary_tag(X::in) = (Tag::out),
+ [promise_pure],
+"
// We don't look at X to find the tag, for .NET low-level data
// there is no primary tag, so we always return zero.
Tag = 0;
").
:- pragma foreign_proc("C#",
- get_remote_secondary_tag(X::in) = (Tag::out), [promise_pure], "
+ get_remote_secondary_tag(X::in) = (Tag::out),
+ [promise_pure],
+"
try {
// try the low-level data representation
object[] data = (object[]) X;
@@ -1817,14 +1907,16 @@
").
:- pragma foreign_proc("Java",
- get_primary_tag(_X::in) = (Tag::out), [promise_pure],
+ get_primary_tag(_X::in) = (Tag::out),
+ [promise_pure],
"
// For the Java back-end, there is no primary tag, so always return 0.
Tag = 0;
").
:- pragma foreign_proc("Java",
- get_remote_secondary_tag(X::in) = (Tag::out), [promise_pure],
+ get_remote_secondary_tag(X::in) = (Tag::out),
+ [promise_pure],
"
// If there is a secondary tag, it will be in a member called
// `data_tag', which we obtain by reflection.
@@ -1870,12 +1962,15 @@
det_unimplemented("ptag_index").
:- pragma foreign_proc("C#",
- ptag_index(X::in, TypeLayout::in) = (PtagEntry::out), [promise_pure], "
+ ptag_index(X::in, TypeLayout::in) = (PtagEntry::out),
+ [promise_pure],
+"
PtagEntry = (object[]) TypeLayout[X];
").
:- pragma foreign_proc("Java",
- ptag_index(X::in, TypeLayout::in) = (PtagEntry::out), [promise_pure],
+ ptag_index(X::in, TypeLayout::in) = (PtagEntry::out),
+ [promise_pure],
"
PtagEntry = TypeLayout.layout_du()[X];
").
@@ -1886,13 +1981,16 @@
det_unimplemented("sectag_locn").
:- pragma foreign_proc("C#",
- sectag_locn(PTagEntry::in) = (SectagLocn::out), [promise_pure], "
+ sectag_locn(PTagEntry::in) = (SectagLocn::out),
+ [promise_pure],
+"
SectagLocn = mercury.runtime.LowLevelData.make_enum((int)
PTagEntry[(int) ptag_layout_field_nums.sectag_locn]);
").
:- pragma foreign_proc("Java",
- sectag_locn(PTagEntry::in) = (SectagLocn::out), [promise_pure],
+ sectag_locn(PTagEntry::in) = (SectagLocn::out),
+ [promise_pure],
"
mercury.runtime.Sectag_Locn SL_struct = PTagEntry.sectag_locn;
@@ -1907,7 +2005,9 @@
:- pragma foreign_proc("C#",
du_sectag_alternatives(X::in, PTagEntry::in) =
- (FunctorDescriptor::out), [promise_pure], "
+ (FunctorDescriptor::out),
+ [promise_pure],
+"
object[] sectag_alternatives;
sectag_alternatives = (object [])
PTagEntry[(int) ptag_layout_field_nums.sectag_alternatives];
@@ -1916,7 +2016,8 @@
:- pragma foreign_proc("Java",
du_sectag_alternatives(X::in, PTagEntry::in) =
- (FunctorDescriptor::out), [promise_pure],
+ (FunctorDescriptor::out),
+ [promise_pure],
"
FunctorDescriptor = PTagEntry.sectag_alternatives[X];
").
@@ -1954,7 +2055,9 @@
det_unimplemented("exist_info_tcis").
:- pragma foreign_proc("C#",
- exist_info_tcis(ExistInfo::in) = (TCIs::out), [promise_pure], "
+ exist_info_tcis(ExistInfo::in) = (TCIs::out),
+ [promise_pure],
+"
TCIs = (int) ExistInfo[(int)
exist_info_field_nums.tcis];
").
@@ -1965,7 +2068,9 @@
det_unimplemented("exist_arg_num").
:- pragma foreign_proc("C#",
- exist_arg_num(TypeInfoLocn::in) = (ArgNum::out), [promise_pure], "
+ exist_arg_num(TypeInfoLocn::in) = (ArgNum::out),
+ [promise_pure],
+"
ArgNum = (int) TypeInfoLocn[(int) exist_locn_field_nums.exist_arg_num];
").
@@ -1976,10 +2081,11 @@
det_unimplemented("exist_arg_num").
:- pragma foreign_proc("C#",
- exist_offset_in_tci(TypeInfoLocn::in) = (ArgNum::out), [promise_pure], "
+ exist_offset_in_tci(TypeInfoLocn::in) = (ArgNum::out),
+ [promise_pure],
+"
ArgNum = (int)
TypeInfoLocn[(int) exist_locn_field_nums.exist_offset_in_tci];
-
").
:- func get_typeinfo_from_term(U, int) = type_info.
@@ -2048,12 +2154,15 @@
:- pragma foreign_proc("C#",
update_type_info_index(X::in, NewValue::in, OldTypeInfo::di,
- NewTypeInfo::uo), [will_not_call_mercury, promise_pure], "
+ NewTypeInfo::uo),
+ [will_not_call_mercury, promise_pure],
+"
OldTypeInfo[X] = NewValue;
NewTypeInfo = OldTypeInfo;
").
:- pred semidet_unimplemented(string::in) is semidet.
+
semidet_unimplemented(S) :-
( std_util__semidet_succeed ->
error("rtti_implementation: unimplemented: " ++ S)
@@ -2062,6 +2171,7 @@
).
:- pred det_unimplemented(string::in) is det.
+
det_unimplemented(S) :-
( std_util__semidet_succeed ->
error("rtti_implementation: unimplemented: " ++ S)
@@ -2229,8 +2339,6 @@
% matching foreign_proc version.
private_builtin__sorry("type_ctor_name").
-
-
:- func type_ctor_functors(type_ctor_info) = type_functors.
:- pragma foreign_proc("C#",
@@ -2253,8 +2361,6 @@
% matching foreign_proc version.
private_builtin__sorry("type_ctor_functors").
-
-
:- func type_layout(type_ctor_info) = type_layout.
:- pragma foreign_proc("C#",
@@ -2289,8 +2395,7 @@
type_ctor_num_functors(TypeCtorInfo::in) = (TypeLayout::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
- TypeLayout = (int)
- TypeCtorInfo[(int)
+ TypeLayout = (int) TypeCtorInfo[(int)
type_ctor_info_field_nums.type_ctor_num_functors];
").
@@ -2452,8 +2557,8 @@
ArgTypes = DuFunctorDesc.du_functor_arg_types;
").
-:- func du_functor_arg_names(du_functor_desc::in) =
- (arg_names::out) is semidet.
+:- func du_functor_arg_names(du_functor_desc::in) = (arg_names::out)
+ is semidet.
du_functor_arg_names(DuFunctorDesc) = ArgNames :-
ArgNames = DuFunctorDesc ^ unsafe_index(8),
@@ -2468,8 +2573,8 @@
succeeded = (ArgNames != null);
").
-:- func du_functor_exist_info(du_functor_desc::in) =
- (exist_info::out) is semidet.
+:- func du_functor_exist_info(du_functor_desc::in) = (exist_info::out)
+ is semidet.
du_functor_exist_info(DuFunctorDesc) = ExistInfo :-
ExistInfo = DuFunctorDesc ^ unsafe_index(9),
@@ -2484,7 +2589,7 @@
succeeded = (ExistInfo != null);
").
- %--------------------------%
+%--------------------------%
:- func enum_functor_desc(type_ctor_rep, int, type_functors)
= enum_functor_desc.
@@ -2592,7 +2697,8 @@
%--------------------------%
:- func unsafe_make_enum(int) = T.
-:- pragma foreign_proc("C#", unsafe_make_enum(Num::in) = (Enum::out),
+:- pragma foreign_proc("C#",
+ unsafe_make_enum(Num::in) = (Enum::out),
[will_not_call_mercury, thread_safe, promise_pure],
"
Enum = mercury.runtime.LowLevelData.make_enum(Num);
Index: library/std_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/std_util.m,v
retrieving revision 1.295
diff -u -b -r1.295 std_util.m
--- library/std_util.m 20 Jul 2004 04:41:13 -0000 1.295
+++ library/std_util.m 11 Dec 2004 09:01:11 -0000
@@ -523,8 +523,8 @@
:- pred get_functor(type_desc__type_desc::in, int::in, string::out, int::out,
list(type_desc__type_desc)::out) is semidet.
- % get_functor(Type, FunctorNumber, FunctorName, Arity, ArgTypes,
- % ArgNames)
+ % get_functor_with_names(Type, FunctorNumber, FunctorName, Arity,
+ % ArgTypes, ArgNames)
%
% Binds FunctorName and Arity to the name and arity of functor number
% FunctorNumber for the specified type, ArgTypes to the type_descs
@@ -532,8 +532,9 @@
% field name of each functor argument, if any. Fails if the type is
% not a discriminated union type, or if FunctorNumber is out of range.
%
-:- pred get_functor(type_desc__type_desc::in, int::in, string::out, int::out,
- list(type_desc__type_desc)::out, list(maybe(string))::out) is semidet.
+:- pred get_functor_with_names(type_desc__type_desc::in, int::in, string::out,
+ int::out, list(type_desc__type_desc)::out, list(maybe(string))::out)
+ is semidet.
% get_functor_ordinal(Type, I, Ordinal)
%
@@ -1707,12 +1708,22 @@
get_functor(TypeDesc, FunctorNumber, FunctorName, Arity, TypeInfoList) :-
construct__get_functor(TypeDesc, FunctorNumber, FunctorName,
- Arity, TypeInfoList).
-
-get_functor(TypeDesc, FunctorNumber, FunctorName, Arity, TypeInfoList,
- ArgNameList) :-
- construct__get_functor(TypeDesc, FunctorNumber, FunctorName,
- Arity, TypeInfoList, ArgNameList).
+ Arity, PseudoTypeInfoList),
+ % If a pseudo_type_info in PseudoTypeInfoList is not ground,
+ % then the resulting TypeInfoList will be silently invalid and
+ % will cause a core dump sooner or later. This is
+ TypeInfoList = list__map(ground_pseudo_type_desc_to_type_desc_det,
+ PseudoTypeInfoList).
+
+get_functor_with_names(TypeDesc, FunctorNumber, FunctorName, Arity,
+ TypeInfoList, ArgNameList) :-
+ construct__get_functor_with_names(TypeDesc, FunctorNumber, FunctorName,
+ Arity, PseudoTypeInfoList, ArgNameList),
+ % If a pseudo_type_info in PseudoTypeInfoList is not ground,
+ % then the resulting TypeInfoList will be silently invalid and
+ % will cause a core dump sooner or later. This is
+ TypeInfoList = list__map(ground_pseudo_type_desc_to_type_desc_det,
+ PseudoTypeInfoList).
get_functor_ordinal(TypeDesc, FunctorNumber, Ordinal) :-
construct__get_functor_ordinal(TypeDesc, FunctorNumber, Ordinal).
Index: library/term.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/term.m,v
retrieving revision 1.107
diff -u -b -r1.107 term.m
--- library/term.m 12 Oct 2004 06:37:40 -0000 1.107
+++ library/term.m 11 Dec 2004 09:03:42 -0000
@@ -18,6 +18,7 @@
:- module term.
:- interface.
:- import_module enum, list, map, std_util.
+:- import_module type_desc.
%-----------------------------------------------------------------------------%
@@ -81,7 +82,7 @@
:- type term_to_type_error(T)
---> type_error(
term(T),
- type_desc,
+ type_desc__type_desc,
term__context,
term_to_type_context
)
@@ -381,7 +382,9 @@
%-----------------------------------------------------------------------------%
:- implementation.
+
:- import_module bool, char, float, std_util, require, array, int, string.
+:- import_module construct.
%-----------------------------------------------------------------------------%
@@ -409,7 +412,7 @@
term__try_term_to_type(IsAditiTuple, Term, Result) :-
term__try_term_to_univ(IsAditiTuple, Term,
- type_of(ValTypedVar), UnivResult),
+ type_desc__type_of(ValTypedVar), UnivResult),
(
UnivResult = ok(Univ),
det_univ_to_type(Univ, Val),
@@ -420,24 +423,25 @@
Result = error(Error)
).
-:- pred term__try_term_to_univ(bool::in, term(T)::in, type_desc::in,
+:- pred term__try_term_to_univ(bool::in, term(T)::in, type_desc__type_desc::in,
term_to_type_result(univ, T)::out) is det.
term__try_term_to_univ(IsAditiTuple, Term, Type, Result) :-
term__try_term_to_univ_2(IsAditiTuple, Term, Type, [], Result).
-:- pred term__try_term_to_univ_2(bool::in, term(T)::in, type_desc::in,
- term_to_type_context::in, term_to_type_result(univ, T)::out) is det.
+:- pred term__try_term_to_univ_2(bool::in, term(T)::in,
+ type_desc__type_desc::in, term_to_type_context::in,
+ term_to_type_result(univ, T)::out) is det.
term__try_term_to_univ_2(_, term__variable(Var), _Type, Context,
error(mode_error(Var, Context))).
term__try_term_to_univ_2(IsAditiTuple, Term, Type, Context, Result) :-
Term = term__functor(Functor, ArgTerms, TermContext),
(
- type_ctor_and_args(Type, TypeCtor, TypeArgs),
+ type_desc__type_ctor_and_args(Type, TypeCtor, TypeArgs),
term__term_to_univ_special_case(IsAditiTuple,
- type_ctor_module_name(TypeCtor),
- type_ctor_name(TypeCtor),
+ type_desc__type_ctor_module_name(TypeCtor),
+ type_desc__type_ctor_name(TypeCtor),
TypeArgs, Term, Type, Context, SpecialCaseResult)
->
Result = SpecialCaseResult
@@ -450,7 +454,10 @@
->
(
ArgsResult = ok(ArgValues),
- ( Value = construct(Type, FunctorNumber, ArgValues) ->
+ (
+ Value = construct__construct(Type,
+ FunctorNumber, ArgValues)
+ ->
Result = ok(Value)
;
error("term_to_type: construct/3 failed")
@@ -467,9 +474,9 @@
).
:- pred term__term_to_univ_special_case(bool::in, string::in, string::in,
- list(type_desc)::in,
+ list(type_desc__type_desc)::in,
term(T)::in(bound(term__functor(ground, ground, ground))),
- type_desc::in, term_to_type_context::in,
+ type_desc__type_desc::in, term_to_type_context::in,
term_to_type_result(univ, T)::out) is semidet.
term__term_to_univ_special_case(IsAditiTuple, "builtin", "character", [],
@@ -514,15 +521,15 @@
% convert the term representing the list of elements back to a list,
% and then (if successful) we just call the array/1 function.
%
- has_type(Elem, ElemType),
- ListType = type_of([Elem]),
+ type_desc__has_type(Elem, ElemType),
+ ListType = type_desc__type_of([Elem]),
ArgContext = arg_context(term__atom("array"), 1, TermContext),
NewContext = [ArgContext | PrevContext],
term__try_term_to_univ_2(IsAditiTuple, ArgList, ListType, NewContext,
ArgResult),
(
ArgResult = ok(ListUniv),
- has_type(Elem2, ElemType),
+ type_desc__has_type(Elem2, ElemType),
same_type(List, [Elem2]),
det_univ_to_type(ListUniv, List),
Array = array(List),
@@ -563,14 +570,14 @@
fail.
:- pred term__term_list_to_univ_list(bool::in, list(term(T))::in,
- list(type_desc)::in, term__const::in, int::in,
+ list(type_desc__type_desc)::in, term__const::in, int::in,
term_to_type_context::in, term__context::in,
term_to_type_result(list(univ), T)::out) is semidet.
term__term_list_to_univ_list(_, [], [], _, _, _, _, ok([])).
-term__term_list_to_univ_list(IsAditiTuple, [ArgTerm|ArgTerms],
- [Type|Types], Functor, ArgNum, PrevContext,
- TermContext, Result) :-
+term__term_list_to_univ_list(IsAditiTuple, [ArgTerm | ArgTerms],
+ [Type | Types], Functor, ArgNum, PrevContext, TermContext,
+ Result) :-
ArgContext = arg_context(Functor, ArgNum, TermContext),
NewContext = [ArgContext | PrevContext],
term__try_term_to_univ_2(IsAditiTuple, ArgTerm, Type, NewContext,
@@ -578,8 +585,8 @@
(
ArgResult = ok(Arg),
term__term_list_to_univ_list(IsAditiTuple, ArgTerms, Types,
- Functor, ArgNum + 1, PrevContext,
- TermContext, RestResult),
+ Functor, ArgNum + 1, PrevContext, TermContext,
+ RestResult),
(
RestResult = ok(Rest),
Result = ok([Arg | Rest])
@@ -592,20 +599,20 @@
Result = error(Error)
).
-:- pred term__find_functor(type_desc::in, string::in, int::in, int::out,
- list(type_desc)::out) is semidet.
+:- pred term__find_functor(type_desc__type_desc::in, string::in, int::in,
+ int::out, list(type_desc__type_desc)::out) is semidet.
term__find_functor(Type, Functor, Arity, FunctorNumber, ArgTypes) :-
- N = num_functors(Type),
+ N = construct__num_functors(Type),
term__find_functor_2(Type, Functor, Arity, N, FunctorNumber, ArgTypes).
-:- pred term__find_functor_2(type_desc::in, string::in, int::in, int::in,
- int::out, list(type_desc)::out) is semidet.
+:- pred term__find_functor_2(type_desc__type_desc::in, string::in, int::in,
+ int::in, int::out, list(type_desc__type_desc)::out) is semidet.
term__find_functor_2(TypeInfo, Functor, Arity, Num, FunctorNumber, ArgTypes) :-
Num >= 0,
Num1 = Num - 1,
- ( get_functor(TypeInfo, Num1, Functor, Arity, ArgTypes1) ->
+ ( std_util.get_functor(TypeInfo, Num1, Functor, Arity, ArgTypes1) ->
ArgTypes = ArgTypes1,
FunctorNumber = Num1
;
@@ -623,7 +630,7 @@
string__append_list([
"term__det_term_to_type failed, due to a type error:\n",
"the term wasn't a valid term for type `",
- type_name(type_of(X)),
+ type_desc__type_name(type_desc__type_of(X)),
"'"], Message),
error(Message)
).
@@ -639,11 +646,13 @@
term__context_init(Context),
Type = univ_type(Univ),
% NU-Prolog barfs on `num_functors(Type) < 0'
- ( num_functors(Type) = N, N < 0 ->
+ ( construct__num_functors(Type) = N, N < 0 ->
(
- type_ctor_and_args(Type, TypeCtor, TypeArgs),
- TypeName = type_ctor_name(TypeCtor),
- ModuleName = type_ctor_module_name(TypeCtor),
+ type_desc__type_ctor_and_args(Type, TypeCtor,
+ TypeArgs),
+ TypeName = type_desc__type_ctor_name(TypeCtor),
+ ModuleName =
+ type_desc__type_ctor_module_name(TypeCtor),
term__univ_to_term_special_case(ModuleName, TypeName,
TypeArgs, Univ, Context, SpecialCaseTerm)
->
@@ -651,7 +660,7 @@
;
string__append_list(
["term__type_to_term: unknown type `",
- type_name(univ_type(Univ)),
+ type_desc__type_name(univ_type(Univ)),
"'"],
Message),
error(Message)
@@ -665,7 +674,7 @@
).
:- pred term__univ_to_term_special_case(string::in, string::in,
- list(type_desc)::in, univ::in, term__context::in,
+ list(type_desc__type_desc)::in, univ::in, term__context::in,
term(T)::out) is semidet.
term__univ_to_term_special_case("builtin", "int", [], Univ, Context,
@@ -699,7 +708,7 @@
term__univ_to_term_special_case("array", "array", [ElemType], Univ, Context,
Term) :-
Term = term__functor(term__atom("array"), [ArgsTerm], Context),
- has_type(Elem, ElemType),
+ type_desc__has_type(Elem, ElemType),
same_type(List, [Elem]),
det_univ_to_type(Univ, Array),
array__to_list(Array, List),
@@ -718,13 +727,13 @@
term__univ_list_to_term_list(Values, Terms).
% given a type_info, return a term that represents the name of that type.
-:- pred type_info_to_term(term__context::in, type_desc::in, term(T)::out)
- is det.
+:- pred type_info_to_term(term__context::in, type_desc__type_desc::in,
+ term(T)::out) is det.
type_info_to_term(Context, TypeInfo, Term) :-
- type_ctor_and_args(TypeInfo, TypeCtor, ArgTypes),
- TypeName = type_ctor_name(TypeCtor),
- ModuleName = type_ctor_name(TypeCtor),
+ type_desc__type_ctor_and_args(TypeInfo, TypeCtor, ArgTypes),
+ TypeName = type_desc__type_ctor_name(TypeCtor),
+ ModuleName = type_desc__type_ctor_name(TypeCtor),
list__map(type_info_to_term(Context), ArgTypes, ArgTerms),
( ModuleName = "builtin" ->
Index: library/term_to_xml.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/term_to_xml.m,v
retrieving revision 1.2
diff -u -b -r1.2 term_to_xml.m
--- library/term_to_xml.m 10 Dec 2004 09:44:23 -0000 1.2
+++ library/term_to_xml.m 13 Dec 2004 02:15:41 -0000
@@ -64,7 +64,7 @@
:- module term_to_xml.
:- interface.
-:- import_module io, int, deconstruct, std_util, list.
+:- import_module io, int, type_desc, deconstruct, list.
%-----------------------------------------------------------------------------%
@@ -262,7 +262,7 @@
% See the dtd_generation_result type for a list of the other
% possible values of DTDResult and their meanings.
%
-:- pred write_dtd_from_type(type_desc::in,
+:- pred write_dtd_from_type(type_desc__type_desc::in,
element_mapping::in(element_mapping), dtd_generation_result::out,
io::di, io::uo) is det.
@@ -270,9 +270,9 @@
% Same as write_dtd_for_type/5 except the DTD will be written to the
% given output stream.
%
-:- pred write_dtd_from_type(io.output_stream::in, type_desc::in,
- element_mapping::in(element_mapping),
- dtd_generation_result::out, io::di, io::uo) is det.
+:- pred write_dtd_from_type(io.output_stream::in, type_desc__type_desc::in,
+ element_mapping::in(element_mapping), dtd_generation_result::out,
+ io::di, io::uo) is det.
% write_xml_element(NonCanon, MakeElement, IndentLevel, Term, !IO).
% Write XML elements for the given term and all its descendents,
@@ -353,13 +353,14 @@
:- implementation.
-:- import_module string, char, bool, array.
+:- import_module std_util, string, char, bool, array.
:- import_module exception, map, require.
%-----------------------------------------------------------------------------%
write_xml_doc(X, ElementMapping, MaybeStyleSheet, MaybeDTD, DTDResult, !IO) :-
- DTDResult = can_generate_dtd(MaybeDTD, ElementMapping, type_of(X)),
+ DTDResult = can_generate_dtd(MaybeDTD, ElementMapping,
+ type_desc__type_of(X)),
(
DTDResult = ok
->
@@ -382,7 +383,8 @@
write_xml_doc_cc(X, ElementMapping, MaybeStyleSheet, MaybeDTD, DTDResult,
!IO) :-
- DTDResult = can_generate_dtd(MaybeDTD, ElementMapping, type_of(X)),
+ DTDResult = can_generate_dtd(MaybeDTD, ElementMapping,
+ type_desc__type_of(X)),
(
DTDResult = ok
->
@@ -409,7 +411,7 @@
!IO).
write_dtd(Term, ElementMapping, DTDResult, !IO) :-
- type_of(Term) = TypeDesc,
+ type_desc__type_of(Term) = TypeDesc,
write_dtd_from_type(TypeDesc, ElementMapping, DTDResult, !IO).
write_dtd(Stream, Term, ElementMapping, DTDResult, !IO) :-
@@ -465,13 +467,13 @@
get_element_pred(ElementMapping, MakeElement),
deconstruct.deconstruct(T, NonCanon, Functor, Arity, _),
(
- is_discriminated_union(type_of(T), _)
+ is_discriminated_union(type_desc__type_of(T), _)
->
Request = du_functor(Functor, Arity)
;
Request = none_du
),
- MakeElement(type_of(T), Request, Root, _),
+ MakeElement(type_desc__type_of(T), Request, Root, _),
io.write_string("<!DOCTYPE ", !IO),
io.write_string(Root, !IO),
(
@@ -493,7 +495,7 @@
% Implementation of the `unique' predefined mapping scheme.
%
-:- pred make_unique_element(type_desc::in, maybe_functor_info::in,
+:- pred make_unique_element(type_desc__type_desc::in, maybe_functor_info::in,
string::out, list(attribute)::out) is det.
% XXX This should be uncommented once memoing can be switched off for grades
@@ -510,7 +512,7 @@
MangledElement = mangle(Functor)
),
Element = MangledElement ++ "--" ++ string.int_to_string(Arity) ++
- "--" ++ mangle(type_name(TypeDesc)).
+ "--" ++ mangle(type_desc__type_name(TypeDesc)).
make_unique_element(TypeDesc, none_du, Element, Attributes) :-
(
is_primitive_type(TypeDesc, PrimitiveElement)
@@ -521,16 +523,17 @@
;
is_array(TypeDesc, _)
->
- Element = array_element ++ "--" ++ mangle(type_name(TypeDesc)),
+ Element = array_element ++ "--" ++
+ mangle(type_desc__type_name(TypeDesc)),
Attributes = all_attributes
;
- Element = mangle(type_name(TypeDesc)),
+ Element = mangle(type_desc__type_name(TypeDesc)),
Attributes = all_attributes
).
% Implementation of the `simple' mapping scheme.
%
-:- pred make_simple_element(type_desc::in, maybe_functor_info::in,
+:- pred make_simple_element(type_desc__type_desc::in, maybe_functor_info::in,
string::out, list(attribute)::out) is det.
% XXX This should be uncommented once memoing can be switched off for grades
@@ -605,23 +608,23 @@
array_element = "Array".
-:- pred is_primitive_type(type_desc::in, string::out) is semidet.
+:- pred is_primitive_type(type_desc__type_desc::in, string::out) is semidet.
is_primitive_type(TypeDesc, Element) :-
(
- type_of("") = TypeDesc
+ type_desc__type_of("") = TypeDesc
->
Element = "String"
;
- type_of('c') = TypeDesc
+ type_desc__type_of('c') = TypeDesc
->
Element = "Char"
;
- type_of(1) = TypeDesc
+ type_desc__type_of(1) = TypeDesc
->
Element = "Int"
;
- type_of(1.0) = TypeDesc,
+ type_desc__type_of(1.0) = TypeDesc,
Element = "Float"
).
@@ -683,8 +686,8 @@
% will be in each list if the type is not a discriminated union.
%
:- pred get_elements_and_args(element_pred::in(element_pred),
- type_desc::in, list(string)::out, list(maybe(string))::out,
- list(maybe(int))::out, list(list(type_desc))::out,
+ type_desc__type_desc::in, list(string)::out, list(maybe(string))::out,
+ list(maybe(int))::out, list(list(type_desc__type_desc))::out,
list(list(attribute))::out) is det.
% XXX This should be uncommented once memoing can be switched off for grades
@@ -698,7 +701,8 @@
->
FunctorNums = 0 `..` (NumFunctors - 1),
(
- list.map3(get_functor(TypeDesc), FunctorNums,
+ % XXX should change to construct.get_functor
+ list.map3(std_util.get_functor(TypeDesc), FunctorNums,
Functors, Arities, ArgTypeLists0)
->
MaybeFunctors = list.map((func(X) = yes(X)), Functors),
@@ -783,7 +787,7 @@
),
deconstruct.deconstruct(Term, NonCanon, Functor, Arity, Args),
Term = univ_value(Univ),
- TypeDesc = type_of(Term),
+ TypeDesc = type_desc__type_of(Term),
(
is_discriminated_union(TypeDesc, _)
->
@@ -826,21 +830,23 @@
)
).
-:- pred is_discriminated_union(type_desc::in, int::out) is semidet.
+:- pred is_discriminated_union(type_desc__type_desc::in, int::out) is semidet.
is_discriminated_union(TypeDesc, NumFunctors) :-
NumFunctors = num_functors(TypeDesc),
NumFunctors > -1.
-:- pred is_array(type_desc::in, type_desc::out) is semidet.
+:- pred is_array(type_desc__type_desc::in, type_desc__type_desc::out)
+ is semidet.
is_array(TypeDesc, ArgType) :-
- type_ctor_and_args(TypeDesc, TypeCtor, ArgTypes),
+ type_desc__type_ctor_and_args(TypeDesc, TypeCtor, ArgTypes),
ArgTypes = [ArgType],
- type_ctor_name(TypeCtor) = "array",
- type_ctor_module_name(TypeCtor) = "array".
+ type_desc__type_ctor_name(TypeCtor) = "array",
+ type_desc__type_ctor_module_name(TypeCtor) = "array".
-:- func get_field_names(type_desc, string, int) = list(maybe(string)).
+:- func get_field_names(type_desc__type_desc, string, int)
+ = list(maybe(string)).
% XXX This should be uncommented once memoing can be switched off for grades
% which don't support it.
@@ -863,13 +869,13 @@
MaybeFields = []
).
-:- pred find_field_names(type_desc::in, list(int)::in, string::in, int::in,
- list(maybe(string))::out) is semidet.
+:- pred find_field_names(type_desc__type_desc::in, list(int)::in, string::in,
+ int::in, list(maybe(string))::out) is semidet.
find_field_names(TypeDesc, [FunctorNum | FunctorNums], Functor, Arity,
MaybeFieldNames) :-
(
- get_functor(TypeDesc, FunctorNum, Functor, Arity, _,
+ get_functor_with_names(TypeDesc, FunctorNum, Functor, Arity, _,
FoundFieldNames)
->
MaybeFieldNames = FoundFieldNames
@@ -964,7 +970,7 @@
).
:- pred write_primitive_element(string::in, list(attribute)::in, string::in,
- maybe(string)::in, type_desc::in, io::di, io::uo) is det.
+ maybe(string)::in, type_desc__type_desc::in, io::di, io::uo) is det.
write_primitive_element(Element, Attributes, Value, MaybeFieldName,
TypeDesc, !IO) :-
@@ -979,8 +985,8 @@
io.write_string(">\n", !IO).
:- pred write_element_start(string::in, list(attribute)::in, maybe(string)::in,
- maybe(int)::in, maybe(string)::in, type_desc::in, io::di, io::uo) is
- det.
+ maybe(int)::in, maybe(string)::in, type_desc__type_desc::in,
+ io::di, io::uo) is det.
write_element_start(Element, Attributes, MaybeFunctor, MaybeArity, MaybeField,
TypeDesc, !IO) :-
@@ -991,8 +997,8 @@
io.write_string(">\n", !IO).
:- pred write_empty_element(string::in, list(attribute)::in,
- maybe(string)::in, maybe(int)::in, maybe(string)::in, type_desc::in,
- io::di, io::uo) is det.
+ maybe(string)::in, maybe(int)::in, maybe(string)::in,
+ type_desc__type_desc::in, io::di, io::uo) is det.
write_empty_element(Element, Attributes, MaybeFunctor, MaybeArity, MaybeField,
TypeDesc, !IO) :-
@@ -1010,8 +1016,8 @@
io.write_string(">\n", !IO).
:- pred write_attribute(maybe(string)::in, maybe(int)::in,
- type_desc::in, maybe(string)::in, attribute::in, io::di, io::uo)
- is det.
+ type_desc__type_desc::in, maybe(string)::in, attribute::in,
+ io::di, io::uo) is det.
write_attribute(MaybeFunctor, MaybeArity, TypeDesc, MaybeFieldName,
attribute(Name, Source), !IO) :-
@@ -1029,7 +1035,7 @@
)
;
Source = type_name,
- MaybeValue = yes(type_name(TypeDesc))
+ MaybeValue = yes(type_desc__type_name(TypeDesc))
;
Source = field_name,
MaybeValue = MaybeFieldName
@@ -1114,7 +1120,7 @@
).
:- func can_generate_dtd(maybe_dtd::in, element_mapping::in(element_mapping),
- type_desc::in) = (dtd_generation_result::out) is det.
+ type_desc__type_desc::in) = (dtd_generation_result::out) is det.
can_generate_dtd(no_dtd, _, _) = ok.
can_generate_dtd(external(_), _, _) = ok.
@@ -1127,8 +1133,9 @@
% be a discriminated union, an array, an int, a character, a float or a
% string.
:- func can_generate_dtd_for_types(element_pred::in(element_pred),
- list(type_desc)::in, map(type_desc, unit)::in,
- map(string, type_desc)::in) = (dtd_generation_result::out) is det.
+ list(type_desc__type_desc)::in, map(type_desc__type_desc, unit)::in,
+ map(string, type_desc__type_desc)::in) = (dtd_generation_result::out)
+ is det.
can_generate_dtd_for_types(_, [], _, _) = ok.
can_generate_dtd_for_types(MakeElement, [TypeDesc | TypeDescs], DoneTypeDescs,
@@ -1186,7 +1193,7 @@
% entry written.
%
:- pred write_dtd_types(element_pred::in(element_pred),
- list(type_desc)::in, map(type_desc, unit)::in,
+ list(type_desc__type_desc)::in, map(type_desc__type_desc, unit)::in,
io::di, io::uo) is det.
write_dtd_types(_, [], _, !IO).
@@ -1232,7 +1239,7 @@
% Write an ATTLIST entry for the given attribute.
%
:- pred write_dtd_attlist(string::in, maybe(string)::in, maybe(int)::in,
- type_desc::in, attribute::in, io::di, io::uo) is det.
+ type_desc__type_desc::in, attribute::in, io::di, io::uo) is det.
write_dtd_attlist(Element, MaybeFunctor, MaybeArity, TypeDesc,
attribute(Name, Source), !IO) :-
@@ -1250,7 +1257,7 @@
)
;
Source = type_name,
- MaybeValue = yes(type_name(TypeDesc))
+ MaybeValue = yes(type_desc__type_name(TypeDesc))
;
Source = field_name,
MaybeValue = no
@@ -1264,7 +1271,7 @@
io.write_string(">\n", !IO).
:- pred write_dtd_attlists(string::in, list(attribute)::in, maybe(string)::in,
- maybe(int)::in, type_desc::in, io::di, io::uo) is det.
+ maybe(int)::in, type_desc__type_desc::in, io::di, io::uo) is det.
write_dtd_attlists(Element, Attributes, MaybeFunctor, MaybeArity, TypeDesc,
!IO) :-
@@ -1273,23 +1280,24 @@
% Write DTD entries for all the functors for a type.
%
-:- pred write_dtd_type_elements(element_pred::in(element_pred), type_desc::in,
- list(type_desc)::out, io::di, io::uo) is det.
+:- pred write_dtd_type_elements(element_pred::in(element_pred),
+ type_desc__type_desc::in, list(type_desc__type_desc)::out,
+ io::di, io::uo) is det.
write_dtd_type_elements(MakeElement, TypeDesc, ChildArgTypes, !IO) :-
get_elements_and_args(MakeElement, TypeDesc, Elements,
MaybeFunctors, MaybeArities, ArgTypeLists, AttributeLists),
list.condense(ArgTypeLists, ChildArgTypes),
io.write_string("<!-- Elements for functors of type """, !IO),
- write_xml_escaped_string(type_name(TypeDesc), !IO),
+ write_xml_escaped_string(type_desc__type_name(TypeDesc), !IO),
io.write_string(""" -->\n\n", !IO),
write_dtd_entries(MakeElement, TypeDesc, Elements, MaybeFunctors,
MaybeArities, ArgTypeLists, AttributeLists, !IO).
-:- pred write_dtd_entries(element_pred::in(element_pred), type_desc::in,
- list(string)::in, list(maybe(string))::in, list(maybe(int))::in,
- list(list(type_desc))::in, list(list(attribute))::in,
- io::di, io::uo) is det.
+:- pred write_dtd_entries(element_pred::in(element_pred),
+ type_desc__type_desc::in, list(string)::in, list(maybe(string))::in,
+ list(maybe(int))::in, list(list(type_desc__type_desc))::in,
+ list(list(attribute))::in, io::di, io::uo) is det.
% Write all the given DTD entries.
%
@@ -1378,7 +1386,7 @@
% expression.
%
:- pred write_dtd_allowed_functors_regex(element_pred::in(element_pred),
- type_desc::in, io::di, io::uo) is det.
+ type_desc__type_desc::in, io::di, io::uo) is det.
write_dtd_allowed_functors_regex(MakeElement, TypeDesc, !IO) :-
get_elements_and_args(MakeElement, TypeDesc, Elements, _, _, _, _),
Index: library/type_desc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/type_desc.m,v
retrieving revision 1.27
diff -u -b -r1.27 type_desc.m
--- library/type_desc.m 2 Aug 2004 08:30:17 -0000 1.27
+++ library/type_desc.m 11 Dec 2004 14:58:21 -0000
@@ -17,14 +17,53 @@
:- import_module list.
- % The `type_desc' and `type_ctor_desc' types: these
+ % The `type_desc', `pseudo_type_desc' and `type_ctor_desc' types
% provide access to type information.
% A type_desc represents a type, e.g. `list(int)'.
+ % A pseudo_type_desc represents a type that possibly contains type
+ % variables, e.g. `list(T)'.
% A type_ctor_desc represents a type constructor, e.g. `list/1'.
:- type type_desc.
+:- type pseudo_type_desc.
:- type type_ctor_desc.
+ % The possibly nonground type represented by a pseudo_type_desc
+ % is either a type constructor applied to zero or more
+ % pseudo_type_descs, or a type variable. If the latter, the
+ % type variable may be either universally or existentially quantified.
+ % In either case, the type is identified by an integer, which has no
+ % meaning beyond the fact that two type variables will be represented
+ % by identical integers if and only if they are the same type variable.
+ % Existentially quantified type variables may have type class
+ % constraints placed on them, but for now we can't return these.
+
+:- type pseudo_type_rep
+ ---> bound(type_ctor_desc, list(pseudo_type_desc))
+ ; univ_tvar(int)
+ ; exist_tvar(int).
+
+:- pred pseudo_type_desc_is_ground(pseudo_type_desc::in) is semidet.
+
+ % This function allows the caller to look into the structure
+ % of the given pseudo_type_desc.
+:- func pseudo_type_desc_to_rep(pseudo_type_desc) = pseudo_type_rep.
+
+ % Convert a type_desc, which by definition describes a ground
+ % type, to a pseudo_type_desc.
+ %
+:- func type_desc_to_pseudo_type_desc(type_desc) = pseudo_type_desc.
+
+ % Convert a pseudo_type_desc describing a ground type to a type_desc.
+ % If the pseudo_type_desc describes a non-ground type, fail.
+:- func ground_pseudo_type_desc_to_type_desc(pseudo_type_desc) = type_desc
+ is semidet.
+
+ % Convert a pseudo_type_desc describing a ground type to a type_desc.
+ % If the pseudo_type_desc describes a non-ground type, abort.
+:- func ground_pseudo_type_desc_to_type_desc_det(pseudo_type_desc) = type_desc
+ is det.
+
% (Note: it is not possible for the type of a variable to be an
% unbound type variable; if there are no constraints on a type
% variable, then the typechecker will use the type `void'.
@@ -37,8 +76,7 @@
% The function type_of/1 returns a representation of the type
% of its argument.
%
-:- func type_of(T) = type_desc__type_desc.
-:- mode type_of(unused) = out is det.
+:- func type_of(T::unused) = (type_desc__type_desc::out) is det.
% The predicate has_type/2 is basically an existentially typed
% inverse to the function type_of/1. It constrains the type
@@ -77,16 +115,41 @@
type_desc__type_ctor_desc::out, list(type_desc__type_desc)::out)
is det.
+ % pseudo_type_ctor_and_args(Type, TypeCtor, TypeArgs):
+ % True iff `TypeCtor' is a representation of the top-level
+ % type constructor for `Type', and `TypeArgs' is a list
+ % of the corresponding type arguments to `TypeCtor',
+ % and `TypeCtor' is not an equivalence type.
+ %
+ % Similar to type_ctor_and_args, but works on pseudo_type_infos.
+ % Fails if the input pseudo_type_info is a variable.
+ %
+:- pred pseudo_type_ctor_and_args(type_desc__pseudo_type_desc::in,
+ type_desc__type_ctor_desc::out, list(type_desc__pseudo_type_desc)::out)
+ is semidet.
+
% type_ctor(Type) = TypeCtor :-
% type_ctor_and_args(Type, TypeCtor, _).
%
:- func type_ctor(type_desc__type_desc) = type_desc__type_ctor_desc.
+ % pseudo_type_ctor(Type) = TypeCtor :-
+ % type_ctor_and_args(Type, TypeCtor, _).
+ %
+:- func pseudo_type_ctor(type_desc__pseudo_type_desc) =
+ type_desc__type_ctor_desc is semidet.
+
% type_args(Type) = TypeArgs :-
% type_ctor_and_args(Type, _, TypeArgs).
%
:- func type_args(type_desc__type_desc) = list(type_desc__type_desc).
+ % pseudo_type_args(Type) = TypeArgs :-
+ % pseudo_type_ctor_and_args(Type, _, TypeArgs).
+ %
+:- func pseudo_type_args(type_desc__pseudo_type_desc) =
+ list(type_desc__pseudo_type_desc) is semidet.
+
% type_ctor_name(TypeCtor) returns the name of specified
% type constructor.
% (e.g. type_ctor_name(type_ctor(type_of([2,3]))) = "list").
@@ -213,13 +276,115 @@
return (MR_compare_type_info(x, y) == 0);
}
+public static void
+special___Compare___pseudo_type_desc_0_0(
+ ref object[] result, object[] x, object[] y)
+{
+ mercury.runtime.Errors.SORRY(
+ ""foreign code for comparing pseudo_type_desc"");
+}
+
+public static bool
+special___Unify___pseudo_type_desc_0_0(object[] x, object[] y)
+{
+ mercury.runtime.Errors.SORRY(
+ ""foreign code for unifying pseudo_type_desc"");
+}
+
").
%-----------------------------------------------------------------------------%
% Code for type manipulation.
- % Prototypes and type definitions.
+pseudo_type_desc_is_ground(PseudoTypeDesc) :-
+ pseudo_type_ctor_and_args(PseudoTypeDesc, _TypeCtor, ArgPseudos),
+ list__all_true(pseudo_type_desc_is_ground, ArgPseudos).
+
+pseudo_type_desc_to_rep(PseudoTypeDesc) = PseudoTypeRep :-
+ ( pseudo_type_ctor_and_args(PseudoTypeDesc, TypeCtor, ArgPseudos) ->
+ PseudoTypeRep = bound(TypeCtor, ArgPseudos)
+ ; is_exist_pseudo_type_desc(PseudoTypeDesc, UnivNum) ->
+ PseudoTypeRep = exist_tvar(UnivNum)
+ ; is_univ_pseudo_type_desc(PseudoTypeDesc, UnivNum) ->
+ PseudoTypeRep = univ_tvar(UnivNum)
+ ;
+ error("pseudo_type_desc_to_rep: internal error")
+ ).
+
+:- pred is_univ_pseudo_type_desc(pseudo_type_desc::in, int::out) is semidet.
+
+:- pragma foreign_proc("C",
+ is_univ_pseudo_type_desc(PseudoTypeDesc::in, TypeVarNum::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+ MR_PseudoTypeInfo pseudo_type_info;
+
+ pseudo_type_info = (MR_PseudoTypeInfo) PseudoTypeDesc;
+ if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(pseudo_type_info) &&
+ MR_TYPE_VARIABLE_IS_UNIV_QUANT(pseudo_type_info))
+ {
+ TypeVarNum = (MR_Integer) pseudo_type_info;
+ SUCCESS_INDICATOR = MR_TRUE;
+ } else {
+ SUCCESS_INDICATOR = MR_FALSE;
+ }
+").
+
+is_univ_pseudo_type_desc(_PseudoTypeDesc, -1) :-
+ % The backends in which we use this definition of this predicate
+ % don't yet support pseudo_type_descs.
+ semidet_fail.
+
+:- pred is_exist_pseudo_type_desc(pseudo_type_desc::in, int::out) is semidet.
+
+:- pragma foreign_proc("C",
+ is_exist_pseudo_type_desc(PseudoTypeDesc::in, TypeVarNum::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+ MR_PseudoTypeInfo pseudo_type_info;
+
+ pseudo_type_info = (MR_PseudoTypeInfo) PseudoTypeDesc;
+ if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(pseudo_type_info) &&
+ MR_TYPE_VARIABLE_IS_EXIST_QUANT(pseudo_type_info))
+ {
+ TypeVarNum = (MR_Integer) pseudo_type_info;
+ SUCCESS_INDICATOR = MR_TRUE;
+ } else {
+ SUCCESS_INDICATOR = MR_FALSE;
+ }
+").
+
+is_exist_pseudo_type_desc(_PseudoTypeDesc, -1) :-
+ % The backends in which we use this definition of this predicate
+ % don't yet support pseudo_type_descs.
+ semidet_fail.
+
+:- pragma foreign_proc("C",
+ type_desc_to_pseudo_type_desc(TypeDesc::in) = (PseudoTypeDesc::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+ PseudoTypeDesc = TypeDesc;
+").
+
+type_desc_to_pseudo_type_desc(_TypeDesc) = _PseudoTypeDesc :-
+ % The backends in which we use this definition of this predicate
+ % don't yet support pseudo_type_descs.
+ private_builtin__sorry("type_desc_to_pseudo_type_desc").
+
+ground_pseudo_type_desc_to_type_desc(PseudoTypeDesc) = TypeDesc :-
+ ( pseudo_type_desc_is_ground(PseudoTypeDesc) ->
+ private_builtin.unsafe_type_cast(PseudoTypeDesc, TypeDesc)
+ ;
+ fail
+ ).
+
+ground_pseudo_type_desc_to_type_desc_det(PseudoTypeDesc) = TypeDesc :-
+ ( pseudo_type_desc_is_ground(PseudoTypeDesc) ->
+ private_builtin.unsafe_type_cast(PseudoTypeDesc, TypeDesc)
+ ;
+ error("ground_pseudo_type_desc_to_type_desc_det: not ground")
+ ).
:- pragma foreign_proc("C",
type_of(_Value::unused) = (TypeInfo::out),
@@ -257,7 +422,6 @@
(mercury.runtime.TypeInfo_Struct) TypeInfo_for_T);
").
-
:- pragma foreign_proc("C",
has_type(_Arg::unused, TypeInfo::in),
[will_not_call_mercury, thread_safe, promise_pure],
@@ -355,6 +519,9 @@
type_args(Type) = ArgTypes :-
type_ctor_and_args(Type, _TypeCtor, ArgTypes).
+pseudo_type_args(PseudoType) = ArgPseudoTypes :-
+ pseudo_type_ctor_and_args(PseudoType, _TypeCtor, ArgPseudoTypes).
+
type_ctor_name(TypeCtor) = Name :-
type_ctor_name_and_arity(TypeCtor, _ModuleName, Name, _Arity).
@@ -390,6 +557,29 @@
}").
:- pragma foreign_proc("C",
+ pseudo_type_ctor(PseudoTypeInfo::in) = (TypeCtor::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+ MR_TypeCtorInfo type_ctor_info;
+ MR_PseudoTypeInfo pseudo_type_info;
+
+ MR_save_transient_registers();
+ pseudo_type_info = MR_collapse_equivalences_pseudo(
+ (MR_PseudoTypeInfo) PseudoTypeInfo);
+ MR_restore_transient_registers();
+
+ if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(pseudo_type_info)) {
+ SUCCESS_INDICATOR = MR_FALSE;
+ } else {
+ type_ctor_info = MR_PSEUDO_TYPEINFO_GET_TYPE_CTOR_INFO(
+ pseudo_type_info);
+ TypeCtor = (MR_Word) MR_make_type_ctor_desc_pseudo(
+ pseudo_type_info, type_ctor_info);
+ SUCCESS_INDICATOR = MR_TRUE;
+ }
+}").
+
+:- pragma foreign_proc("C",
type_ctor_and_args(TypeDesc::in, TypeCtorDesc::out, ArgTypes::out),
[will_not_call_mercury, thread_safe, promise_pure],
"{
@@ -435,6 +625,28 @@
TypeCtorDesc = rtti_implementation__unsafe_cast(TypeCtorDesc0),
ArgTypes = rtti_implementation__unsafe_cast(ArgTypes0).
+:- pragma foreign_proc("C",
+ pseudo_type_ctor_and_args(PseudoTypeDesc::in, TypeCtorDesc::out,
+ ArgPseudoTypeInfos::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+ MR_TypeCtorDesc type_ctor_desc;
+ MR_PseudoTypeInfo pseudo_type_info;
+ MR_bool success;
+
+ pseudo_type_info = (MR_PseudoTypeInfo) PseudoTypeDesc;
+ MR_save_transient_registers();
+ success = MR_pseudo_type_ctor_and_args(pseudo_type_info, MR_TRUE,
+ &type_ctor_desc, &ArgPseudoTypeInfos);
+ TypeCtorDesc = (MR_Word) type_ctor_desc;
+ MR_restore_transient_registers();
+ SUCCESS_INDICATOR = success;
+}").
+
+pseudo_type_ctor_and_args(_, _, _) :-
+ % The non-C backends can't (yet) handle pseudo_type_infos.
+ private_builtin__sorry("pseudo_type_ctor_and_args").
+
/*
** This is the forwards mode of make_type/2:
** given a type constructor and a list of argument
cvs diff: Diffing profiler
cvs diff: Diffing robdd
cvs diff: Diffing runtime
Index: runtime/mercury_builtin_types.c
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_builtin_types.c,v
retrieving revision 1.11
diff -u -b -r1.11 mercury_builtin_types.c
--- runtime/mercury_builtin_types.c 19 May 2004 03:59:43 -0000 1.11
+++ runtime/mercury_builtin_types.c 12 Dec 2004 23:46:35 -0000
@@ -83,6 +83,7 @@
TYPECLASSINFO, MR_TYPE_CTOR_FLAG_TYPEINFO_FAKE_ARITY);
MR_DEFINE_TYPE_CTOR_INFO(type_desc, type_ctor_desc, 0, TYPECTORDESC);
+MR_DEFINE_TYPE_CTOR_INFO(type_desc, pseudo_type_desc, 0, PSEUDOTYPEDESC);
MR_DEFINE_TYPE_CTOR_INFO(type_desc, type_desc, 0, TYPEDESC);
/*---------------------------------------------------------------------------*/
@@ -197,6 +198,14 @@
}
MR_bool MR_CALL
+mercury__type_desc____Unify____pseudo_type_desc_0_0(MR_Pseudo_Type_Desc x,
+ MR_Pseudo_Type_Desc y)
+{
+ return MR_unify_pseudo_type_info((MR_PseudoTypeInfo) x,
+ (MR_PseudoTypeInfo) y);
+}
+
+MR_bool MR_CALL
mercury__type_desc____Unify____type_desc_0_0(MR_Type_Desc x, MR_Type_Desc y)
{
return MR_unify_type_info((MR_TypeInfo) x, (MR_TypeInfo) y);
@@ -348,6 +357,15 @@
}
void MR_CALL
+mercury__type_desc____Compare____pseudo_type_desc_0_0(
+ MR_Comparison_Result *result,
+ MR_Pseudo_Type_Desc x, MR_Pseudo_Type_Desc y)
+{
+ *result = MR_compare_pseudo_type_info((MR_PseudoTypeInfo) x,
+ (MR_PseudoTypeInfo) y);
+}
+
+void MR_CALL
mercury__type_desc____Compare____type_desc_0_0(
MR_Comparison_Result *result, MR_Type_Desc x, MR_Type_Desc y)
{
@@ -483,6 +501,13 @@
}
MR_bool MR_CALL
+mercury__type_desc__do_unify__pseudo_type_desc_0_0(MR_Box x, MR_Box y)
+{
+ return mercury__type_desc____Unify____pseudo_type_desc_0_0(
+ (MR_Pseudo_Type_Desc) x, (MR_Pseudo_Type_Desc) y);
+}
+
+MR_bool MR_CALL
mercury__type_desc__do_unify__type_desc_0_0(MR_Box x, MR_Box y)
{
return mercury__type_desc____Unify____type_desc_0_0(
@@ -624,6 +649,14 @@
}
void MR_CALL
+mercury__type_desc__do_compare__pseudo_type_desc_0_0(
+ MR_Comparison_Result *result, MR_Box x, MR_Box y)
+{
+ mercury__type_desc____Compare____pseudo_type_desc_0_0(
+ result, (MR_Pseudo_Type_Desc) x, (MR_Pseudo_Type_Desc) y);
+}
+
+void MR_CALL
mercury__type_desc__do_compare__type_desc_0_0(
MR_Comparison_Result *result, MR_Box x, MR_Box y)
{
@@ -746,6 +779,7 @@
MR_UNIFY_COMPARE_REP_DECLS(private_builtin, base_typeclass_info, 1)
MR_UNIFY_COMPARE_REP_DECLS(private_builtin, typeclass_info, 1)
MR_UNIFY_COMPARE_REP_DECLS(type_desc, type_ctor_desc, 0);
+MR_UNIFY_COMPARE_REP_DECLS(type_desc, pseudo_type_desc, 0);
MR_UNIFY_COMPARE_REP_DECLS(type_desc, type_desc, 0);
MR_UNIFY_COMPARE_REP_DECLS(builtin, user_by_rtti, 0);
@@ -773,6 +807,7 @@
MR_UNIFY_COMPARE_REP_DEFNS(private_builtin, base_typeclass_info, 1)
MR_UNIFY_COMPARE_REP_DEFNS(private_builtin, typeclass_info, 1)
MR_UNIFY_COMPARE_REP_DEFNS(type_desc, type_ctor_desc, 0)
+MR_UNIFY_COMPARE_REP_DEFNS(type_desc, pseudo_type_desc, 0)
MR_UNIFY_COMPARE_REP_DEFNS(type_desc, type_desc, 0)
MR_UNIFY_COMPARE_REP_DEFNS(builtin, user_by_rtti, 0)
@@ -815,6 +850,11 @@
&MR_proc_layout_uci_name(m, __CompareRep__, n, a, 0)); \
} while (0)
+/*
+** If you add another entry to this list, you should also add the corresponding
+** declaration to mercury_builtin_types_proc_layouts.h.
+*/
+
MR_DEFINE_PROC_STATIC_LAYOUTS(builtin, int, 0);
MR_DEFINE_PROC_STATIC_LAYOUTS(builtin, string, 0);
MR_DEFINE_PROC_STATIC_LAYOUTS(builtin, float, 0);
@@ -839,6 +879,7 @@
MR_DEFINE_PROC_STATIC_LAYOUTS(private_builtin, base_typeclass_info, 1);
MR_DEFINE_PROC_STATIC_LAYOUTS(private_builtin, typeclass_info, 1);
MR_DEFINE_PROC_STATIC_LAYOUTS(type_desc, type_ctor_desc, 0);
+MR_DEFINE_PROC_STATIC_LAYOUTS(type_desc, pseudo_type_desc, 0);
MR_DEFINE_PROC_STATIC_LAYOUTS(type_desc, type_desc, 0);
MR_DEFINE_PROC_STATIC_LAYOUTS(builtin, user_by_rtti, 0);
@@ -869,6 +910,7 @@
MR_UNIFY_COMPARE_REP_LABELS(private_builtin, base_typeclass_info, 1)
MR_UNIFY_COMPARE_REP_LABELS(private_builtin, typeclass_info, 1)
MR_UNIFY_COMPARE_REP_LABELS(type_desc, type_ctor_desc, 0)
+ MR_UNIFY_COMPARE_REP_LABELS(type_desc, pseudo_type_desc, 0)
MR_UNIFY_COMPARE_REP_LABELS(type_desc, type_desc, 0)
MR_UNIFY_COMPARE_REP_LABELS(builtin, user_by_rtti, 0)
MR_BEGIN_CODE
@@ -1414,6 +1456,38 @@
/*****************************************************************************/
+#define module type_desc
+#define type pseudo_type_desc
+#define arity 0
+
+#define unify_code int comp; \
+ \
+ MR_save_transient_registers(); \
+ comp = MR_compare_pseudo_type_info( \
+ (MR_PseudoTypeInfo) MR_r1, \
+ (MR_PseudoTypeInfo) MR_r2); \
+ MR_restore_transient_registers(); \
+ MR_r1 = (comp == MR_COMPARE_EQUAL);
+
+#define compare_code int comp; \
+ \
+ MR_save_transient_registers(); \
+ comp = MR_compare_pseudo_type_info( \
+ (MR_PseudoTypeInfo) MR_r1, \
+ (MR_PseudoTypeInfo) MR_r2); \
+ MR_restore_transient_registers(); \
+ MR_r1 = comp;
+
+#include "mercury_hand_unify_compare_body.h"
+
+#undef module
+#undef type
+#undef arity
+#undef unify_code
+#undef compare_code
+
+/*****************************************************************************/
+
/*
** Unify and compare of type_descs are usually handled by the generic
** unify/2 and compare/3 predicates.
@@ -1559,6 +1633,7 @@
MR_INIT_TYPE_CTOR_INFO_MNA(private_builtin, base_typeclass_info, 1);
MR_INIT_TYPE_CTOR_INFO_MNA(private_builtin, typeclass_info, 1);
MR_INIT_TYPE_CTOR_INFO_MNA(type_desc, type_ctor_desc, 0);
+ MR_INIT_TYPE_CTOR_INFO_MNA(type_desc, pseudo_type_desc, 0);
MR_INIT_TYPE_CTOR_INFO_MNA(type_desc, type_desc, 0);
}
@@ -1591,6 +1666,7 @@
MR_REGISTER_TYPE_CTOR_INFO(private_builtin, base_typeclass_info, 1);
MR_REGISTER_TYPE_CTOR_INFO(private_builtin, typeclass_info, 1);
MR_REGISTER_TYPE_CTOR_INFO(type_desc, type_ctor_desc, 0);
+ MR_REGISTER_TYPE_CTOR_INFO(type_desc, pseudo_type_desc, 0);
MR_REGISTER_TYPE_CTOR_INFO(type_desc, type_desc, 0);
}
@@ -1617,11 +1693,15 @@
MR_WRITE_OUT_PROC_STATIC_LAYOUTS(fp, builtin, ticket, 0);
MR_WRITE_OUT_PROC_STATIC_LAYOUTS(fp, private_builtin, heap_pointer, 0);
MR_WRITE_OUT_PROC_STATIC_LAYOUTS(fp, private_builtin, ref, 1);
- MR_WRITE_OUT_PROC_STATIC_LAYOUTS(fp, private_builtin, type_ctor_info, 1);
+ MR_WRITE_OUT_PROC_STATIC_LAYOUTS(fp, private_builtin,
+ type_ctor_info, 1);
MR_WRITE_OUT_PROC_STATIC_LAYOUTS(fp, private_builtin, type_info, 1);
- MR_WRITE_OUT_PROC_STATIC_LAYOUTS(fp, private_builtin, base_typeclass_info, 1);
- MR_WRITE_OUT_PROC_STATIC_LAYOUTS(fp, private_builtin, typeclass_info, 1);
+ MR_WRITE_OUT_PROC_STATIC_LAYOUTS(fp, private_builtin,
+ base_typeclass_info, 1);
+ MR_WRITE_OUT_PROC_STATIC_LAYOUTS(fp, private_builtin,
+ typeclass_info, 1);
MR_WRITE_OUT_PROC_STATIC_LAYOUTS(fp, type_desc, type_ctor_desc, 0);
+ MR_WRITE_OUT_PROC_STATIC_LAYOUTS(fp, type_desc, pseudo_type_desc, 0);
MR_WRITE_OUT_PROC_STATIC_LAYOUTS(fp, type_desc, type_desc, 0);
}
#endif
Index: runtime/mercury_builtin_types.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_builtin_types.h,v
retrieving revision 1.4
diff -u -b -r1.4 mercury_builtin_types.h
--- runtime/mercury_builtin_types.h 12 Feb 2003 05:30:46 -0000 1.4
+++ runtime/mercury_builtin_types.h 11 Dec 2004 12:45:50 -0000
@@ -57,6 +57,8 @@
MR_DECLARE_TYPE_CTOR_INFO_STRUCT(
MR_TYPE_CTOR_INFO_NAME(type_desc, type_ctor_desc, 0));
MR_DECLARE_TYPE_CTOR_INFO_STRUCT(
+ MR_TYPE_CTOR_INFO_NAME(type_desc, pseudo_type_desc, 0));
+MR_DECLARE_TYPE_CTOR_INFO_STRUCT(
MR_TYPE_CTOR_INFO_NAME(type_desc, type_desc, 0));
/*---------------------------------------------------------------------------*/
@@ -86,6 +88,8 @@
MR_bool MR_CALL mercury__builtin____Unify____tuple_0_0(MR_Tuple x, MR_Tuple y);
MR_bool MR_CALL mercury__type_desc____Unify____type_ctor_desc_0_0(
MR_Type_Ctor_Desc x, MR_Type_Ctor_Desc y);
+MR_bool MR_CALL mercury__type_desc____Unify____pseudo_type_desc_0_0(
+ MR_Type_Ctor_Desc x, MR_Type_Ctor_Desc y);
MR_bool MR_CALL mercury__type_desc____Unify____type_desc_0_0(
MR_Type_Desc x, MR_Type_Desc y);
MR_bool MR_CALL mercury__private_builtin____Unify____type_ctor_info_1_0(
@@ -125,6 +129,9 @@
void MR_CALL mercury__builtin____Compare____tuple_0_0(
MR_Comparison_Result *result, MR_Tuple x, MR_Tuple y);
void MR_CALL mercury__type_desc____Compare____type_ctor_desc_0_0(
+ MR_Comparison_Result *result,
+ MR_Type_Ctor_Desc x, MR_Type_Ctor_Desc y);
+void MR_CALL mercury__type_desc____Compare____pseudo_type_desc_0_0(
MR_Comparison_Result *result,
MR_Type_Ctor_Desc x, MR_Type_Ctor_Desc y);
void MR_CALL mercury__type_desc____Compare____type_desc_0_0(
Index: runtime/mercury_builtin_types_proc_layouts.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_builtin_types_proc_layouts.h,v
retrieving revision 1.1
diff -u -b -r1.1 mercury_builtin_types_proc_layouts.h
--- runtime/mercury_builtin_types_proc_layouts.h 19 May 2004 03:59:43 -0000 1.1
+++ runtime/mercury_builtin_types_proc_layouts.h 12 Dec 2004 23:44:54 -0000
@@ -62,6 +62,7 @@
MR_DECLARE_UCI_PROC_STATIC_LAYOUTS(private_builtin, base_typeclass_info, 1);
MR_DECLARE_UCI_PROC_STATIC_LAYOUTS(private_builtin, typeclass_info, 1);
MR_DECLARE_UCI_PROC_STATIC_LAYOUTS(type_desc, type_ctor_desc, 0);
+MR_DECLARE_UCI_PROC_STATIC_LAYOUTS(type_desc, pseudo_type_desc, 0);
MR_DECLARE_UCI_PROC_STATIC_LAYOUTS(type_desc, type_desc, 0);
MR_DECLARE_UCI_PROC_STATIC_LAYOUTS(builtin, user_by_rtti, 0);
Index: runtime/mercury_construct.c
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_construct.c,v
retrieving revision 1.13
diff -u -b -r1.13 mercury_construct.c
--- runtime/mercury_construct.c 28 Jun 2004 04:50:03 -0000 1.13
+++ runtime/mercury_construct.c 11 Dec 2004 11:16:18 -0000
@@ -153,6 +153,7 @@
case MR_TYPECTOR_REP_STABLE_C_POINTER:
case MR_TYPECTOR_REP_TYPEINFO:
case MR_TYPECTOR_REP_TYPECTORINFO:
+ case MR_TYPECTOR_REP_PSEUDOTYPEDESC:
case MR_TYPECTOR_REP_TYPEDESC:
case MR_TYPECTOR_REP_TYPECTORDESC:
case MR_TYPECTOR_REP_TYPECLASSINFO:
@@ -314,6 +315,7 @@
case MR_TYPECTOR_REP_STABLE_C_POINTER:
case MR_TYPECTOR_REP_TYPEINFO:
case MR_TYPECTOR_REP_TYPECTORINFO:
+ case MR_TYPECTOR_REP_PSEUDOTYPEDESC:
case MR_TYPECTOR_REP_TYPEDESC:
case MR_TYPECTOR_REP_TYPECTORDESC:
case MR_TYPECTOR_REP_TYPECLASSINFO:
Index: runtime/mercury_deconstruct.c
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_deconstruct.c,v
retrieving revision 1.16
diff -u -b -r1.16 mercury_deconstruct.c
--- runtime/mercury_deconstruct.c 28 Jun 2004 04:50:04 -0000 1.16
+++ runtime/mercury_deconstruct.c 11 Dec 2004 11:16:18 -0000
@@ -281,6 +281,7 @@
case MR_TYPECTOR_REP_TYPECTORINFO:
case MR_TYPECTOR_REP_TYPEDESC:
case MR_TYPECTOR_REP_TYPECTORDESC:
+ case MR_TYPECTOR_REP_PSEUDOTYPEDESC:
case MR_TYPECTOR_REP_TYPECLASSINFO:
case MR_TYPECTOR_REP_BASETYPECLASSINFO:
case MR_TYPECTOR_REP_SUCCIP:
Index: runtime/mercury_deep_copy.c
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_deep_copy.c,v
retrieving revision 1.33
diff -u -b -r1.33 mercury_deep_copy.c
--- runtime/mercury_deep_copy.c 18 Dec 2003 10:41:16 -0000 1.33
+++ runtime/mercury_deep_copy.c 11 Dec 2004 11:11:58 -0000
@@ -37,6 +37,9 @@
#undef copy_type_info
#define copy_type_info MR_deep_copy_type_info
+#undef copy_pseudo_type_info
+#define copy_pseudo_type_info MR_deep_copy_pseudo_type_info
+
#undef copy_typeclass_info
#define copy_typeclass_info MR_deep_copy_typeclass_info
@@ -69,6 +72,9 @@
#undef copy_type_info
#define copy_type_info MR_agc_deep_copy_type_info
+#undef copy_pseudo_type_info
+#define copy_pseudo_type_info MR_agc_deep_copy_pseudo_type_info
+
#undef copy_typeclass_info
#define copy_typeclass_info MR_agc_deep_copy_typeclass_info
@@ -149,7 +155,8 @@
MR_restore_transient_hp(); /* Because we play with MR_hp */
if (lower_limit < MR_ENGINE(MR_eng_heap_zone)->bottom ||
- lower_limit > MR_ENGINE(MR_eng_heap_zone)->top) {
+ lower_limit > MR_ENGINE(MR_eng_heap_zone)->top)
+ {
lower_limit = MR_ENGINE(MR_eng_heap_zone)->bottom;
}
Index: runtime/mercury_deep_copy_body.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_deep_copy_body.h,v
retrieving revision 1.68
diff -u -b -r1.68 mercury_deep_copy_body.h
--- runtime/mercury_deep_copy_body.h 7 Jul 2004 07:11:10 -0000 1.68
+++ runtime/mercury_deep_copy_body.h 11 Dec 2004 11:11:58 -0000
@@ -19,7 +19,8 @@
** Prototypes.
*/
-static MR_Word copy_arg(const MR_Word *parent_data_ptr, MR_Word data,
+static MR_Word copy_arg(const MR_Word *parent_data_ptr,
+ MR_Word data,
const MR_DuFunctorDesc *functor_descriptor,
const MR_TypeInfoParams type_params,
const MR_PseudoTypeInfo arg_pseudotype_info,
@@ -28,6 +29,10 @@
static MR_TypeInfo copy_type_info(MR_TypeInfo type_info,
const MR_Word *lower_limit,
const MR_Word *upper_limit);
+static MR_PseudoTypeInfo copy_pseudo_type_info(
+ MR_PseudoTypeInfo pseudo_type_info,
+ const MR_Word *lower_limit,
+ const MR_Word *upper_limit);
static MR_Word copy_typeclass_info(MR_Word typeclass_info,
const MR_Word *lower_limit,
const MR_Word *upper_limit);
@@ -58,7 +63,7 @@
/*
** RETURN_IF_OUT_OF_RANGE(MR_Word tagged_pointer, MR_Word *pointer,
-** int forwarding_pointer_offset):
+** int forwarding_pointer_offset, rettype):
** Check if `pointer' is either out of range, or has already been
** processed, and if so, return (from the function that called this macro)
** with the appropriate value.
@@ -544,6 +549,10 @@
return (MR_Word) copy_type_info((MR_TypeInfo) data,
lower_limit, upper_limit);
+ case MR_TYPECTOR_REP_PSEUDOTYPEDESC:
+ return (MR_Word) copy_pseudo_type_info((MR_PseudoTypeInfo) data,
+ lower_limit, upper_limit);
+
case MR_TYPECTOR_REP_TYPECTORINFO:
/* type_ctor_infos are always pointers to static data */
return data;
@@ -726,6 +735,10 @@
copy_type_info(MR_TypeInfo type_info,
const MR_Word *lower_limit, const MR_Word *upper_limit)
{
+ /*
+ ** Most changes here should also be done in copy_pseudo_type_info below.
+ */
+
RETURN_IF_OUT_OF_RANGE((MR_Word) type_info, (MR_Word *) type_info,
TYPEINFO_FORWARDING_PTR_OFFSET, MR_TypeInfo);
@@ -793,6 +806,97 @@
leave_forwarding_pointer((MR_Word) type_info,
TYPEINFO_FORWARDING_PTR_OFFSET, (MR_Word) new_type_info_arena);
return (MR_TypeInfo) new_type_info_arena;
+ }
+}
+
+static MR_PseudoTypeInfo
+copy_pseudo_type_info(MR_PseudoTypeInfo pseudo_type_info,
+ const MR_Word *lower_limit, const MR_Word *upper_limit)
+{
+ /*
+ ** Most changes here should also be done in copy_type_info above.
+ */
+
+ if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(pseudo_type_info)) {
+ return pseudo_type_info;
+ }
+
+ RETURN_IF_OUT_OF_RANGE((MR_Word) pseudo_type_info,
+ (MR_Word *) pseudo_type_info, TYPEINFO_FORWARDING_PTR_OFFSET,
+ MR_PseudoTypeInfo);
+
+ {
+ MR_TypeCtorInfo type_ctor_info;
+ MR_Word *new_pseudo_type_info_arena;
+ MR_Word new_pseudo_type_info_arena_word;
+ MR_PseudoTypeInfo *pseudo_type_info_args;
+ MR_PseudoTypeInfo *new_pseudo_type_info_args;
+ int arity;
+ int i;
+ int forwarding_pointer_size;
+
+ /*
+ ** Note that we assume type_ctor_infos will always be
+ ** allocated statically, so we never copy them.
+ */
+
+ type_ctor_info =
+ MR_PSEUDO_TYPEINFO_GET_TYPE_CTOR_INFO(pseudo_type_info);
+
+ /*
+ ** Optimize a special case: if there are no arguments,
+ ** we don't need to construct a pseudo_type_info; instead,
+ ** we can just return the type_ctor_info.
+ */
+
+ if ((MR_Word) pseudo_type_info == (MR_Word) type_ctor_info) {
+ return (MR_PseudoTypeInfo) type_ctor_info;
+ }
+
+ /* compute how many words to reserve for the forwarding pointer */
+#ifdef MR_NATIVE_GC
+ forwarding_pointer_size = 1;
+#else
+ forwarding_pointer_size = 0;
+#endif
+
+ if (MR_type_ctor_has_variable_arity(type_ctor_info)) {
+ arity = MR_PSEUDO_TYPEINFO_GET_VAR_ARITY_ARITY(pseudo_type_info);
+ pseudo_type_info_args =
+ MR_PSEUDO_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(pseudo_type_info);
+ MR_offset_incr_saved_hp(new_pseudo_type_info_arena_word,
+ forwarding_pointer_size,
+ MR_var_arity_pseudo_type_info_size(arity)
+ + forwarding_pointer_size);
+ new_pseudo_type_info_arena = (MR_Word *)
+ new_pseudo_type_info_arena_word;
+ MR_fill_in_var_arity_pseudo_type_info(new_pseudo_type_info_arena,
+ type_ctor_info, arity, new_pseudo_type_info_args);
+ } else {
+ arity = type_ctor_info->MR_type_ctor_arity;
+ pseudo_type_info_args =
+ MR_PSEUDO_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(pseudo_type_info);
+ MR_offset_incr_saved_hp(new_pseudo_type_info_arena_word,
+ forwarding_pointer_size,
+ MR_fixed_arity_pseudo_type_info_size(arity)
+ + forwarding_pointer_size
+ );
+ new_pseudo_type_info_arena = (MR_Word *)
+ new_pseudo_type_info_arena_word;
+ MR_fill_in_fixed_arity_pseudo_type_info(new_pseudo_type_info_arena,
+ type_ctor_info, new_pseudo_type_info_args);
+ }
+
+ for (i = 1; i <= arity; i++) {
+ new_pseudo_type_info_args[i] =
+ copy_pseudo_type_info(pseudo_type_info_args[i],
+ lower_limit, upper_limit);
+ }
+
+ leave_forwarding_pointer((MR_Word) pseudo_type_info,
+ TYPEINFO_FORWARDING_PTR_OFFSET,
+ (MR_Word) new_pseudo_type_info_arena);
+ return (MR_PseudoTypeInfo) new_pseudo_type_info_arena;
}
}
Index: runtime/mercury_hlc_types.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_hlc_types.h,v
retrieving revision 1.3
diff -u -b -r1.3 mercury_hlc_types.h
--- runtime/mercury_hlc_types.h 20 Jun 2003 11:20:14 -0000 1.3
+++ runtime/mercury_hlc_types.h 11 Dec 2004 12:47:11 -0000
@@ -64,6 +64,7 @@
typedef struct mercury__array__array_1_s * MR_Array;
typedef struct mercury__std_util__univ_0_s * MR_Univ;
typedef struct mercury__type_desc__type_desc_0_s * MR_Type_Desc;
+ typedef struct mercury__type_desc__pseudo_type_desc_0_s * MR_Pseudo_Type_Desc;
typedef struct mercury__type_desc__type_ctor_desc_0_s * MR_Type_Ctor_Desc;
typedef struct mercury__private_builtin__type_info_1_s *
MR_Mercury_Type_Info;
@@ -85,6 +86,7 @@
typedef MR_ArrayPtr MR_Array;
typedef MR_Word MR_Univ;
typedef MR_Word MR_Type_Desc;
+ typedef MR_Word MR_Pseudo_Type_Desc;
typedef MR_Word MR_Type_Ctor_Desc;
typedef MR_Word MR_Mercury_Type_Info;
typedef MR_Word MR_Mercury_Type_Ctor_Info;
Index: runtime/mercury_init.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_init.h,v
retrieving revision 1.42
diff -u -b -r1.42 mercury_init.h
--- runtime/mercury_init.h 28 Nov 2003 02:11:35 -0000 1.42
+++ runtime/mercury_init.h 11 Dec 2004 13:41:43 -0000
@@ -125,11 +125,14 @@
/* in library/private_builtin.m */
extern const MR_TypeCtorInfo ML_type_ctor_info_for_univ;
extern const MR_FA_TypeInfo_Struct1 ML_type_info_for_type_info;
+extern const MR_FA_TypeInfo_Struct1 ML_type_info_for_pseudo_type_info;
extern const MR_FA_TypeInfo_Struct1 ML_type_info_for_list_of_univ;
extern const MR_FA_TypeInfo_Struct1 ML_type_info_for_list_of_int;
extern const MR_FA_TypeInfo_Struct1 ML_type_info_for_list_of_char;
extern const MR_FA_TypeInfo_Struct1 ML_type_info_for_list_of_string;
extern const MR_FA_TypeInfo_Struct1 ML_type_info_for_list_of_type_info;
+extern const MR_FA_TypeInfo_Struct1
+ ML_type_info_for_list_of_pseudo_type_info;
/* in trace/mercury_trace_internal.h */
extern char *MR_trace_getline(const char *, FILE *mdb_in, FILE *mdb_out);
Index: runtime/mercury_make_type_info_body.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_make_type_info_body.h,v
retrieving revision 1.12
diff -u -b -r1.12 mercury_make_type_info_body.h
--- runtime/mercury_make_type_info_body.h 7 Jul 2004 07:11:13 -0000 1.12
+++ runtime/mercury_make_type_info_body.h 11 Dec 2004 14:30:29 -0000
@@ -1,4 +1,7 @@
/*
+** vim:sw=4 ts=4 expandtab
+*/
+/*
** Copyright (C) 2000-2004 The 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.
@@ -6,28 +9,35 @@
/*
** This file is intended to be #included in mercury_type_info.c to provide
-** the definitions of MR_create_type_info and MR_make_type_info, and their
-** helper functions MR_create_type_info_maybe_existq and
+** the definitions of
+**
+** MR_create_type_info
+** MR_create_pseudo_type_info
+** MR_make_type_info
+**
+** and their helper functions
+**
+** MR_create_type_info_maybe_existq
+** MR_create_pseudo_type_info_maybe_existq
** MR_make_type_info_maybe_existq.
*/
-MR_TypeInfo
-usual_func(const MR_TypeInfoParams type_info_params,
- const MR_PseudoTypeInfo pseudo_type_info
+return_type
+usual_func(const params_type params, const MR_PseudoTypeInfo pseudo_type_info
MAYBE_DECLARE_ALLOC_ARG)
{
- return exist_func(type_info_params, pseudo_type_info, NULL, NULL
+ return exist_func(params, pseudo_type_info, NULL, NULL
MAYBE_PASS_ALLOC_ARG);
}
-MR_TypeInfo
-exist_func(const MR_TypeInfoParams type_info_params,
- const MR_PseudoTypeInfo pseudo_type_info, const MR_Word *data_value,
- const MR_DuFunctorDesc *functor_desc
+return_type
+exist_func(const params_type params, const MR_PseudoTypeInfo pseudo_type_info,
+ const MR_Word *data_value, const MR_DuFunctorDesc *functor_desc
MAYBE_DECLARE_ALLOC_ARG)
{
MR_TypeCtorInfo type_ctor_info;
MR_TypeInfo expanded_type_info;
+ return_type expanded;
MR_Word *type_info_arena;
MR_Word type_info_arena_word;
MR_PseudoTypeInfo *pseudo_type_info_arena;
@@ -41,25 +51,41 @@
*/
if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(pseudo_type_info)) {
- expanded_type_info = MR_get_arg_type_info(type_info_params,
- pseudo_type_info, data_value, functor_desc);
+#if create_pseudo
+ if (MR_TYPE_VARIABLE_IS_EXIST_QUANT(pseudo_type_info)) {
+ return pseudo_type_info;
+ }
- if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(
- (MR_PseudoTypeInfo) expanded_type_info))
+ expanded = MR_get_arg_pseudo_type_info(params, pseudo_type_info,
+ data_value, functor_desc);
+
+ if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(expanded))
{
- MR_fatal_error(exist_func_string
- ": unbound type variable");
+ MR_fatal_error(exist_func_string ": unbound type variable");
+ }
+
+ return expanded;
+#else
+ expanded = MR_get_arg_type_info(params, pseudo_type_info,
+ data_value, functor_desc);
+
+ if (MR_PSEUDO_TYPEINFO_IS_VARIABLE((MR_PseudoTypeInfo) expanded)) {
+ MR_fatal_error(exist_func_string ": unbound type variable");
}
- return expanded_type_info;
+ return expanded;
+#endif
}
- type_ctor_info = MR_PSEUDO_TYPEINFO_GET_TYPE_CTOR_INFO(
- pseudo_type_info);
+ type_ctor_info = MR_PSEUDO_TYPEINFO_GET_TYPE_CTOR_INFO(pseudo_type_info);
/* no arguments - optimise common case */
if ((MR_Word) type_ctor_info == (MR_Word) pseudo_type_info) {
+#if create_pseudo
+ return pseudo_type_info;
+#else
return MR_pseudo_type_info_is_ground(pseudo_type_info);
+#endif
}
if (MR_type_ctor_is_typeinfo_fake_arity(type_ctor_info)) {
@@ -78,12 +104,11 @@
type_info_arena[0] = (MR_Word) type_ctor_info;
type_info_arena[1] = (MR_Word)
&MR_TYPE_CTOR_INFO_NAME(builtin, void, 0);
- return (MR_TypeInfo) type_info_arena;
+ return (return_type) type_info_arena;
}
if (MR_type_ctor_has_variable_arity(type_ctor_info)) {
- arity = MR_PSEUDO_TYPEINFO_GET_VAR_ARITY_ARITY(
- pseudo_type_info);
+ arity = MR_PSEUDO_TYPEINFO_GET_VAR_ARITY_ARITY(pseudo_type_info);
start_region_size = 2;
} else {
arity = type_ctor_info->MR_type_ctor_arity;
@@ -93,28 +118,29 @@
/*
** Iterate over the arguments, figuring out whether we
** need to make any substitutions.
- ** If so, copy the resulting argument type-infos into
+ ** If so, copy the resulting argument type_infos into
** a new type_info.
*/
type_info_arena = NULL;
pseudo_type_info_arena = (MR_PseudoTypeInfo *) pseudo_type_info;
for (i = start_region_size; i < arity + start_region_size; i++) {
- expanded_type_info = exist_func(type_info_params,
- pseudo_type_info_arena[i],
- data_value, functor_desc
- MAYBE_PASS_ALLOC_ARG);
+ expanded = exist_func(params, pseudo_type_info_arena[i],
+ data_value, functor_desc MAYBE_PASS_ALLOC_ARG);
- if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(
- (MR_PseudoTypeInfo) expanded_type_info))
+#if create_pseudo
+ if (MR_PSEUDO_TYPEINFO_IS_VARIABLE((MR_PseudoTypeInfo) expanded) &&
+ ! MR_TYPE_VARIABLE_IS_EXIST_QUANT(pseudo_type_info))
{
- MR_fatal_error(exist_func_string
- ": unbound type variable");
+ MR_fatal_error(exist_func_string ": univ type variable");
+ }
+#else
+ if (MR_PSEUDO_TYPEINFO_IS_VARIABLE((MR_PseudoTypeInfo) expanded)) {
+ MR_fatal_error(exist_func_string ": unbound type variable");
}
+#endif
- if (expanded_type_info !=
- (MR_TypeInfo) pseudo_type_info_arena[i])
- {
+ if (expanded != (return_type) pseudo_type_info_arena[i]) {
/*
** We made a substitution.
** We need to allocate a new type_info,
@@ -123,20 +149,18 @@
if (type_info_arena == NULL) {
ALLOCATE_WORDS(type_info_arena_word,
arity + start_region_size);
- type_info_arena =
- (MR_Word *) type_info_arena_word;
- memcpy(type_info_arena,
- (MR_Word *) pseudo_type_info,
- (arity + start_region_size)
- * sizeof(MR_Word));
+ type_info_arena = (MR_Word *) type_info_arena_word;
+ memcpy(type_info_arena, (MR_Word *) pseudo_type_info,
+ (arity + start_region_size) * sizeof(MR_Word));
}
- type_info_arena[i] = (MR_Word) expanded_type_info;
+
+ type_info_arena[i] = (MR_Word) expanded;
}
}
if (type_info_arena == NULL) {
- return (MR_TypeInfo) pseudo_type_info;
+ return (return_type) pseudo_type_info;
} else {
- return (MR_TypeInfo) type_info_arena;
+ return (return_type) type_info_arena;
}
}
Index: runtime/mercury_ml_expand_body.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_ml_expand_body.h,v
retrieving revision 1.34
diff -u -b -r1.34 mercury_ml_expand_body.h
--- runtime/mercury_ml_expand_body.h 20 Jul 2004 04:41:23 -0000 1.34
+++ runtime/mercury_ml_expand_body.h 11 Dec 2004 15:10:30 -0000
@@ -921,6 +921,11 @@
MR_Word *arg_type_infos;
int num_args;
+ /*
+ ** Most changes here should also be made in the code for
+ ** MR_TYPECTOR_REP_PSEUDOTYPEDESC below.
+ */
+
if (noncanon == MR_NONCANON_ABORT) {
/* XXX should throw an exception */
MR_fatal_error(MR_STRINGIFY(EXPAND_FUNCTION_NAME)
@@ -928,7 +933,7 @@
}
/*
- ** The only source of noncanonicality in typeinfos is due
+ ** The only source of noncanonicality in type_infos is due
** to type equivalences, so we can eliminate noncanonicality
** by expanding out equivalences.
*/
@@ -943,8 +948,7 @@
handle_functor_name(MR_type_ctor_name(data_type_ctor_info));
if (MR_type_ctor_has_variable_arity(data_type_ctor_info)) {
- num_args =
- MR_TYPEINFO_GET_VAR_ARITY_ARITY(data_type_info);
+ num_args = MR_TYPEINFO_GET_VAR_ARITY_ARITY(data_type_info);
arg_type_infos = (MR_Word *)
MR_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(data_type_info);
} else {
@@ -975,8 +979,8 @@
MR_TRUE;
for (i = 0; i < num_args ; i++) {
/*
- ** The arguments of a typeinfo are themselves of type
- ** ``typeinfo''.
+ ** The arguments of a type_info are themselves of type
+ ** ``type_info''.
*/
expand_info->EXPAND_ARGS_FIELD.arg_type_infos[i] =
type_info;
@@ -989,6 +993,118 @@
MR_Word *arg_vector;
arg_vector = (MR_Word *) data_type_info;
+ expand_info->chosen_index_exists = MR_TRUE;
+ expand_info->chosen_value_ptr = &arg_type_infos[chosen];
+ expand_info->chosen_type_info = type_info;
+ } else {
+ expand_info->chosen_index_exists = MR_FALSE;
+ }
+#endif /* EXPAND_ONE_ARG */
+ }
+
+ return;
+
+ case MR_TYPECTOR_REP_PSEUDOTYPEDESC:
+ {
+ MR_PseudoTypeInfo data_pseudo_type_info;
+ MR_TypeCtorInfo data_type_ctor_info;
+ MR_Word *arg_type_infos;
+ int num_args;
+
+ /*
+ ** Most changes here should also be made in the code for
+ ** MR_TYPECTOR_REP_TYPEDESC above.
+ */
+
+ if (noncanon == MR_NONCANON_ABORT) {
+ /* XXX should throw an exception */
+ MR_fatal_error(MR_STRINGIFY(EXPAND_FUNCTION_NAME)
+ ": attempt to deconstruct noncanonical term");
+ }
+
+ /*
+ ** The only source of noncanonicality in pseudo_type_infos
+ ** is due to type equivalences, so we can eliminate
+ ** noncanonicality by expanding out equivalences.
+ */
+
+ data_pseudo_type_info = (MR_PseudoTypeInfo) *data_word_ptr;
+ if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(data_pseudo_type_info)) {
+#ifdef EXPAND_FUNCTOR_FIELD
+ {
+ char buf[500];
+ char *str;
+
+ sprintf(buf, "tvar%ld", (long) data_pseudo_type_info);
+ MR_make_aligned_string_copy_saved_hp(str, buf);
+ expand_info->EXPAND_FUNCTOR_FIELD = str;
+ }
+#endif /* EXPAND_FUNCTOR_FIELD */
+
+ handle_zero_arity_args();
+ return;
+ }
+
+ if (noncanon == MR_NONCANON_ALLOW) {
+ /* XXX should be MR_collapse_equivalences_pseudo */
+ data_pseudo_type_info = (MR_PseudoTypeInfo)
+ MR_collapse_equivalences(
+ (MR_TypeInfo) data_pseudo_type_info);
+ }
+
+ data_type_ctor_info = MR_PSEUDO_TYPEINFO_GET_TYPE_CTOR_INFO(
+ data_pseudo_type_info);
+ handle_functor_name(MR_type_ctor_name(data_type_ctor_info));
+
+ if (MR_type_ctor_has_variable_arity(data_type_ctor_info)) {
+ num_args = MR_PSEUDO_TYPEINFO_GET_VAR_ARITY_ARITY(
+ data_pseudo_type_info);
+ arg_type_infos = (MR_Word *)
+ MR_PSEUDO_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(
+ data_pseudo_type_info);
+ } else {
+ num_args = data_type_ctor_info->MR_type_ctor_arity;
+ arg_type_infos = (MR_Word *)
+ MR_PSEUDO_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(
+ data_pseudo_type_info);
+ }
+
+ expand_info->arity = num_args;
+ /* switch from 1-based to 0-based array indexing */
+ arg_type_infos++;
+
+#ifdef EXPAND_ARGS_FIELD
+ #ifdef EXPAND_APPLY_LIMIT
+ if (num_args > max_arity) {
+ expand_info->limit_reached = MR_TRUE;
+ } else
+ #endif /* EXPAND_APPLY_LIMIT */
+ {
+ int i;
+
+ expand_info->EXPAND_ARGS_FIELD.num_extra_args = 0;
+ expand_info->EXPAND_ARGS_FIELD.arg_values = arg_type_infos;
+
+ expand_info->EXPAND_ARGS_FIELD.arg_type_infos =
+ MR_GC_NEW_ARRAY(MR_TypeInfo, num_args);
+ expand_info->EXPAND_ARGS_FIELD.can_free_arg_type_infos =
+ MR_TRUE;
+ for (i = 0; i < num_args ; i++) {
+ /*
+ ** The arguments of a pseudo_type_info are themselves
+ ** of type ``pseudo_type_info''.
+ */
+ expand_info->EXPAND_ARGS_FIELD.arg_type_infos[i] =
+ type_info;
+ }
+ }
+#endif /* EXPAND_ARGS_FIELD */
+
+#ifdef EXPAND_ONE_ARG
+ if (0 <= chosen && chosen < expand_info->arity) {
+ MR_Word *arg_vector;
+
+ arg_vector = (MR_Word *) data_pseudo_type_info;
expand_info->chosen_index_exists = MR_TRUE;
expand_info->chosen_value_ptr = &arg_type_infos[chosen];
expand_info->chosen_type_info = type_info;
Index: runtime/mercury_tabling.c
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_tabling.c,v
retrieving revision 1.65
diff -u -b -r1.65 mercury_tabling.c
--- runtime/mercury_tabling.c 30 Jul 2004 04:58:38 -0000 1.65
+++ runtime/mercury_tabling.c 11 Dec 2004 11:12:41 -0000
@@ -1045,6 +1045,9 @@
MR_DEBUG_TABLE_TYPEINFO(table, (MR_TypeInfo) data);
return table;
+ case MR_TYPECTOR_REP_PSEUDOTYPEDESC:
+ MR_fatal_error("Attempt to table a pseudo_type_desc");
+
case MR_TYPECTOR_REP_TYPECTORINFO:
MR_fatal_error("Attempt to table a type_ctor_info");
Index: runtime/mercury_tags.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_tags.h,v
retrieving revision 1.22
diff -u -b -r1.22 mercury_tags.h
--- runtime/mercury_tags.h 5 May 2004 09:08:47 -0000 1.22
+++ runtime/mercury_tags.h 11 Dec 2004 08:26:49 -0000
@@ -283,6 +283,14 @@
MR_typed_list_cons_msg(MR_type_info_for_type_info, (head), \
MR_type_info_for_list_of_type_info, (tail), proclabel)
+#define MR_pseudo_type_info_list_cons(head, tail) \
+ MR_typed_list_cons(MR_type_info_for_pseudo_type_info, (head), \
+ MR_type_info_for_list_of_pseudo_type_info, (tail))
+
+#define MR_pseudo_type_info_list_cons_msg(head, tail, proclabel) \
+ MR_typed_list_cons_msg(MR_type_info_for_pseudo_type_info, (head), \
+ MR_type_info_for_list_of_pseudo_type_info, (tail), proclabel)
+
/*
** Convert an enumeration declaration into one which assigns the same
** values to the enumeration constants as Mercury's tag allocation scheme
Index: runtime/mercury_type_desc.c
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_type_desc.c,v
retrieving revision 1.7
diff -u -b -r1.7 mercury_type_desc.c
--- runtime/mercury_type_desc.c 7 Jul 2004 07:11:18 -0000 1.7
+++ runtime/mercury_type_desc.c 11 Dec 2004 16:56:18 -0000
@@ -1,4 +1,7 @@
/*
+** vim:sw=4 ts=4 expandtab
+*/
+/*
** Copyright (C) 2002-2004 The 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.
@@ -27,26 +30,53 @@
type_ctor_desc = MR_TYPECTOR_DESC_MAKE_PRED(
MR_TYPEINFO_GET_VAR_ARITY_ARITY(type_info));
if (! MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(type_ctor_desc)) {
- MR_fatal_error("MR_make_type_ctor_desc"
- " - arity out of range.");
+ MR_fatal_error("MR_make_type_ctor_desc - arity out of range.");
}
} else if (MR_TYPE_CTOR_INFO_IS_HO_FUNC(type_ctor_info)) {
type_ctor_desc = MR_TYPECTOR_DESC_MAKE_FUNC(
MR_TYPEINFO_GET_VAR_ARITY_ARITY(type_info));
if (! MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(type_ctor_desc)) {
- MR_fatal_error("MR_make_type_ctor_desc"
- " - arity out of range.");
+ MR_fatal_error("MR_make_type_ctor_desc - arity out of range.");
}
} else if (MR_TYPE_CTOR_INFO_IS_TUPLE(type_ctor_info)) {
type_ctor_desc = MR_TYPECTOR_DESC_MAKE_TUPLE(
MR_TYPEINFO_GET_VAR_ARITY_ARITY(type_info));
if (! MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(type_ctor_desc)) {
- MR_fatal_error("MR_make_type_ctor_desc"
- " - arity out of range.");
+ MR_fatal_error("MR_make_type_ctor_desc - arity out of range.");
}
} else {
- type_ctor_desc = MR_TYPECTOR_DESC_MAKE_FIXED_ARITY(
- type_ctor_info);
+ type_ctor_desc = MR_TYPECTOR_DESC_MAKE_FIXED_ARITY(type_ctor_info);
+ }
+
+ return type_ctor_desc;
+}
+
+MR_TypeCtorDesc
+MR_make_type_ctor_desc_pseudo(MR_PseudoTypeInfo pseudo,
+ MR_TypeCtorInfo type_ctor_info)
+{
+ MR_TypeCtorDesc type_ctor_desc;
+
+ if (MR_TYPE_CTOR_INFO_IS_HO_PRED(type_ctor_info)) {
+ type_ctor_desc = MR_TYPECTOR_DESC_MAKE_PRED(
+ MR_PSEUDO_TYPEINFO_GET_VAR_ARITY_ARITY(pseudo));
+ if (! MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(type_ctor_desc)) {
+ MR_fatal_error("MR_make_type_ctor_desc - arity out of range.");
+ }
+ } else if (MR_TYPE_CTOR_INFO_IS_HO_FUNC(type_ctor_info)) {
+ type_ctor_desc = MR_TYPECTOR_DESC_MAKE_FUNC(
+ MR_PSEUDO_TYPEINFO_GET_VAR_ARITY_ARITY(pseudo));
+ if (! MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(type_ctor_desc)) {
+ MR_fatal_error("MR_make_type_ctor_desc - arity out of range.");
+ }
+ } else if (MR_TYPE_CTOR_INFO_IS_TUPLE(type_ctor_info)) {
+ type_ctor_desc = MR_TYPECTOR_DESC_MAKE_TUPLE(
+ MR_PSEUDO_TYPEINFO_GET_VAR_ARITY_ARITY(pseudo));
+ if (! MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(type_ctor_desc)) {
+ MR_fatal_error("MR_make_type_ctor_desc - arity out of range.");
+ }
+ } else {
+ type_ctor_desc = MR_TYPECTOR_DESC_MAKE_FIXED_ARITY(type_ctor_info);
}
return type_ctor_desc;
@@ -79,6 +109,45 @@
}
}
+MR_bool
+MR_pseudo_type_ctor_and_args(MR_PseudoTypeInfo pseudo_type_info,
+ MR_bool collapse_equivalences, MR_TypeCtorDesc *type_ctor_desc_ptr,
+ MR_Word *arg_type_info_list_ptr)
+{
+ MR_TypeCtorInfo type_ctor_info;
+ MR_TypeCtorDesc type_ctor_desc;
+ MR_Integer arity;
+
+ if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(pseudo_type_info)) {
+ return MR_FALSE;
+ }
+
+ if (collapse_equivalences) {
+ pseudo_type_info = MR_collapse_equivalences_pseudo(pseudo_type_info);
+ }
+
+ if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(pseudo_type_info)) {
+ return MR_FALSE;
+ }
+
+ type_ctor_info = MR_PSEUDO_TYPEINFO_GET_TYPE_CTOR_INFO(pseudo_type_info);
+ type_ctor_desc = MR_make_type_ctor_desc_pseudo(pseudo_type_info,
+ type_ctor_info);
+ *type_ctor_desc_ptr = type_ctor_desc;
+
+ if (MR_type_ctor_has_variable_arity(type_ctor_info)) {
+ arity = MR_TYPECTOR_DESC_GET_VA_ARITY(type_ctor_desc);
+ *arg_type_info_list_ptr = MR_pseudo_type_params_vector_to_list(arity,
+ MR_PSEUDO_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(pseudo_type_info));
+ } else {
+ arity = type_ctor_info->MR_type_ctor_arity;
+ *arg_type_info_list_ptr = MR_pseudo_type_params_vector_to_list(arity,
+ MR_PSEUDO_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(pseudo_type_info));
+ }
+
+ return MR_TRUE;
+}
+
MR_TypeInfo
MR_make_type(int arity, MR_TypeCtorDesc type_ctor_desc, MR_Word arg_types_list)
{
@@ -97,35 +166,31 @@
type_ctor_desc);
MR_restore_transient_registers();
- MR_offset_incr_hp_atomic_msg(new_type_info_arena_word,
- 0, MR_var_arity_type_info_size(arity),
- "MR_make_type", "type_info");
+ MR_offset_incr_hp_atomic_msg(new_type_info_arena_word, 0,
+ MR_var_arity_type_info_size(arity), "MR_make_type", "type_info");
new_type_info_arena = (MR_Word *) new_type_info_arena_word;
MR_save_transient_registers();
- MR_fill_in_var_arity_type_info(new_type_info_arena,
- type_ctor_info, arity, new_type_info_args);
+ MR_fill_in_var_arity_type_info(new_type_info_arena, type_ctor_info,
+ arity, new_type_info_args);
} else {
type_ctor_info =
- MR_TYPECTOR_DESC_GET_FIXED_ARITY_TYPE_CTOR_INFO(
- type_ctor_desc);
+ MR_TYPECTOR_DESC_GET_FIXED_ARITY_TYPE_CTOR_INFO(type_ctor_desc);
if (arity == 0) {
return (MR_TypeInfo) type_ctor_info;
}
MR_restore_transient_registers();
- MR_offset_incr_hp_atomic_msg(new_type_info_arena_word,
- 0, MR_fixed_arity_type_info_size(arity),
- "MR_make_type", "type_info");
+ MR_offset_incr_hp_atomic_msg(new_type_info_arena_word, 0,
+ MR_fixed_arity_type_info_size(arity), "MR_make_type", "type_info");
new_type_info_arena = (MR_Word *) new_type_info_arena_word;
MR_save_transient_registers();
- MR_fill_in_fixed_arity_type_info(new_type_info_arena,
- type_ctor_info, new_type_info_args);
+ MR_fill_in_fixed_arity_type_info(new_type_info_arena, type_ctor_info,
+ new_type_info_args);
}
for (i = 1; i <= arity; i++) {
- new_type_info_args[i] = (MR_TypeInfo)
- MR_list_head(arg_types_list);
+ new_type_info_args[i] = (MR_TypeInfo) MR_list_head(arg_types_list);
arg_types_list = MR_list_tail(arg_types_list);
}
Index: runtime/mercury_type_desc.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_type_desc.h,v
retrieving revision 1.5
diff -u -b -r1.5 mercury_type_desc.h
--- runtime/mercury_type_desc.h 7 Jul 2004 07:11:18 -0000 1.5
+++ runtime/mercury_type_desc.h 11 Dec 2004 01:58:46 -0000
@@ -17,23 +17,28 @@
/* variable arity type constructors */
/*
-** Values of type `types:type_desc' are represented the same way as
+** Values of type `type_ctor.type_desc' are represented the same way as
** values of type `private_builtin:type_info' (this representation is
** documented in compiler/polymorphism.m). Some parts of the library
** (e.g. the gc initialization code) depend on this.
** The C type corresponding to these Mercury types is `MR_TypeInfo'.
**
-** Values of type `types:type_ctor_desc' are not guaranteed to be
+** Values of type `type_ctor.pseudo_type_desc' are represented the same way as
+** values of type `private_builtin:pseudo_type_info' (this representation is
+** documented in compiler/polymorphism.m).
+** The C type corresponding to these Mercury types is `MR_PseudoTypeInfo'.
+**
+** Values of type `type_ctor.type_ctor_desc' are not guaranteed to be
** represented the same way as values of type `private_builtin:type_ctor_info'.
** The representations *are* in fact identical for fixed arity types, but they
** differ for higher order and tuple types. Instead of a type_ctor_desc
** being a structure containing a pointer to the type_ctor_info for pred/0
** or func/0 and an arity, we have a single small encoded integer. This
-** integer is four times the arity, plus zero, one or two; plus zero encodes a
-** predicate, plus one encodes a function, plus two encodes a tuple.
+** integer is four times the arity, plus zero, one or two; plus zero encodes
+** a predicate, plus one encodes a function, plus two encodes a tuple.
** The maximum arity that can be encoded is given by MR_MAX_VARIABLE_ARITY
** (see below).
-** The C type corresponding to types:type_ctor_desc is `MR_TypeCtorDesc'.
+** The C type corresponding to type_ctor.type_ctor_desc is `MR_TypeCtorDesc'.
*/
/*
@@ -129,8 +134,18 @@
MR_TypeCtorInfo type_ctor_info);
/*
+** Create and return a MR_TypeCtorDesc that describes the same type as
+** type_ctor_info. If type_ctor_info is of variable arity, take the arity
+** from pseudo, which should be the pseudo_type_info that type_ctor_info was
+** extracted from.
+*/
+
+extern MR_TypeCtorDesc MR_make_type_ctor_desc_pseudo(MR_PseudoTypeInfo pseudo,
+ MR_TypeCtorInfo type_ctor_info);
+
+/*
** Given type_info, return the MR_TypeCtorDesc describing its outermost type
-** constructor in *type_ctor_desc_ptr and a list of the typeinfos of its
+** constructor in *type_ctor_desc_ptr and a list of the typei_nfos of its
** argument types in *arg_type_info_list_ptr. If collapse_equivalences is
** MR_TRUE, then expand out the equivalences in type_info first.
**
@@ -138,13 +153,30 @@
** calls to this function.
*/
-
extern void MR_type_ctor_and_args(MR_TypeInfo type_info,
MR_bool collapse_equivalences,
MR_TypeCtorDesc *type_ctor_desc_ptr,
MR_Word *arg_type_info_list_ptr);
/*
+** Given pseudo_type_info representing a variable, return MR_FALSE. Given a
+** pseudo_type_info representing a nonvariable type, return MR_TRUE, and
+** the return MR_TypeCtorDesc describing its outermost type constructor
+** in *type_ctor_desc_ptr and a list of the pseudo_type_infos of its argument
+** types in *arg_type_info_list_ptr. If collapse_equivalences is MR_TRUE,
+** then expand out the equivalences in pseudo_type_info first.
+**
+** You need to wrap MR_{save/restore}_transient_registers() around
+** calls to this function.
+*/
+
+extern MR_bool MR_pseudo_type_ctor_and_args(MR_PseudoTypeInfo
+ pseudo_type_info,
+ MR_bool collapse_equivalences,
+ MR_TypeCtorDesc *type_ctor_desc_ptr,
+ MR_Word *arg_type_info_list_ptr);
+
+/*
** ML_make_type(arity, type_ctor_info, arg_types_list):
**
** Construct and return a type_info for a type using the specified type_ctor
Index: runtime/mercury_type_info.c
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_type_info.c,v
retrieving revision 1.60
diff -u -b -r1.60 mercury_type_info.c
--- runtime/mercury_type_info.c 7 Jul 2004 07:11:18 -0000 1.60
+++ runtime/mercury_type_info.c 11 Dec 2004 16:56:56 -0000
@@ -1,4 +1,7 @@
/*
+** vim:sw=4 ts=4 expandtab
+*/
+/*
** Copyright (C) 1995-2004 The 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.
@@ -25,9 +28,16 @@
/*---------------------------------------------------------------------------*/
-static MR_TypeInfo
-MR_get_arg_type_info(const MR_TypeInfoParams type_info_params,
- const MR_PseudoTypeInfo pseudo_type_info, const MR_Word *data_value,
+static MR_PseudoTypeInfo MR_get_arg_pseudo_type_info(
+ const MR_PseudoTypeInfoParams params,
+ const MR_PseudoTypeInfo pseudo_type_info,
+ const MR_Word *data_value,
+ const MR_DuFunctorDesc *functor_desc);
+
+static MR_TypeInfo MR_get_arg_type_info(
+ const MR_TypeInfoParams params,
+ const MR_PseudoTypeInfo pseudo_type_info,
+ const MR_Word *data_value,
const MR_DuFunctorDesc *functor_desc);
/*---------------------------------------------------------------------------*/
@@ -35,15 +45,17 @@
#define usual_func MR_make_type_info
#define exist_func MR_make_type_info_maybe_existq
#define exist_func_string "MR_make_type_info_maybe_existq"
+#define return_type MR_TypeInfo
+#define params_type MR_TypeInfoParams
+#define create_pseudo MR_FALSE
#define MAYBE_DECLARE_ALLOC_ARG , MR_MemoryList *allocated
#define MAYBE_PASS_ALLOC_ARG , allocated
#define ALLOCATE_WORDS(target, size) \
do { \
MR_Word *target_word_ptr; \
MR_MemoryList node; \
- target_word_ptr = \
- MR_GC_NEW_ARRAY(MR_Word, \
- (size)); \
+ \
+ target_word_ptr = MR_GC_NEW_ARRAY(MR_Word, (size)); \
(target) = (MR_Word) target_word_ptr; \
node = MR_GC_malloc(sizeof(*node)); \
node->data = target_word_ptr; \
@@ -55,6 +67,9 @@
#undef usual_func
#undef exist_func
#undef exist_func_string
+#undef return_type
+#undef params_type
+#undef create_pseudo
#undef MAYBE_DECLARE_ALLOC_ARG
#undef MAYBE_PASS_ALLOC_ARG
#undef ALLOCATE_WORDS
@@ -62,6 +77,43 @@
#define usual_func MR_create_type_info
#define exist_func MR_create_type_info_maybe_existq
#define exist_func_string "MR_create_type_info_maybe_existq"
+#define return_type MR_TypeInfo
+#define params_type MR_TypeInfoParams
+#define create_pseudo MR_FALSE
+#define MAYBE_DECLARE_ALLOC_ARG
+#define MAYBE_PASS_ALLOC_ARG
+#ifdef MR_NATIVE_GC
+ #define ALLOCATE_WORDS(target, size) \
+ do { \
+ /* reserve one extra word for GC forwarding pointer */ \
+ /* (see comments in compiler/mlds_to_c.m for details) */ \
+ MR_offset_incr_saved_hp((target), 0, 1); \
+ MR_offset_incr_saved_hp((target), 0, (size)); \
+ } while (0)
+#else /* !MR_NATIVE_GC */
+ #define ALLOCATE_WORDS(target, size) \
+ do { \
+ MR_offset_incr_saved_hp((target), 0, (size)); \
+ } while (0)
+#endif /* !MR_NATIVE_GC */
+
+#include "mercury_make_type_info_body.h"
+#undef usual_func
+#undef exist_func
+#undef exist_func_string
+#undef return_type
+#undef params_type
+#undef create_pseudo
+#undef MAYBE_DECLARE_ALLOC_ARG
+#undef MAYBE_PASS_ALLOC_ARG
+#undef ALLOCATE_WORDS
+
+#define usual_func MR_create_pseudo_type_info
+#define exist_func MR_create_pseudo_type_info_maybe_existq
+#define exist_func_string "MR_create_pseudo_type_info_maybe_existq"
+#define return_type MR_PseudoTypeInfo
+#define params_type MR_PseudoTypeInfoParams
+#define create_pseudo MR_TRUE
#define MAYBE_DECLARE_ALLOC_ARG
#define MAYBE_PASS_ALLOC_ARG
#ifdef MR_NATIVE_GC
@@ -83,12 +135,62 @@
#undef usual_func
#undef exist_func
#undef exist_func_string
+#undef return_type
+#undef params_type
+#undef create_pseudo
#undef MAYBE_DECLARE_ALLOC_ARG
#undef MAYBE_PASS_ALLOC_ARG
#undef ALLOCATE_WORDS
+static MR_PseudoTypeInfo
+MR_get_arg_pseudo_type_info(const MR_PseudoTypeInfoParams params,
+ const MR_PseudoTypeInfo pseudo_type_info, const MR_Word *data_value,
+ const MR_DuFunctorDesc *functor_desc)
+{
+ MR_Unsigned arg_num;
+ const MR_DuExistInfo *exist_info;
+ MR_DuExistLocn exist_locn;
+ int exist_varnum;
+ int slot;
+ int offset;
+
+ /*
+ ** Most changes here should also be reflected in MR_get_arg_type_info
+ ** below.
+ */
+
+ arg_num = (MR_Unsigned) pseudo_type_info;
+
+ if (MR_TYPE_VARIABLE_IS_UNIV_QUANT(pseudo_type_info)) {
+ /*
+ ** This is a universally quantified type variable.
+ */
+ return params[arg_num];
+ }
+
+ /*
+ ** This is an existentially quantified type variable.
+ */
+
+ exist_info = functor_desc->MR_du_functor_exist_info;
+ if (exist_info == NULL) {
+ MR_fatal_error("MR_get_arg_pseudo_type_info: no exist_info");
+ }
+
+ exist_varnum = arg_num - MR_PSEUDOTYPEINFO_EXIST_VAR_BASE - 1;
+ exist_locn = exist_info->MR_exist_typeinfo_locns[exist_varnum];
+ slot = exist_locn.MR_exist_arg_num;
+ offset = exist_locn.MR_exist_offset_in_tci;
+ if (offset < 0) {
+ return (MR_PseudoTypeInfo) data_value[slot];
+ } else {
+ return (MR_PseudoTypeInfo) MR_typeclass_info_param_type_info(
+ data_value[slot], offset);
+ }
+}
+
static MR_TypeInfo
-MR_get_arg_type_info(const MR_TypeInfoParams type_info_params,
+MR_get_arg_type_info(const MR_TypeInfoParams params,
const MR_PseudoTypeInfo pseudo_type_info, const MR_Word *data_value,
const MR_DuFunctorDesc *functor_desc)
{
@@ -99,13 +201,18 @@
int slot;
int offset;
+ /*
+ ** Most changes here should also be reflected in
+ ** MR_get_arg_pseudo_type_info above.
+ */
+
arg_num = (MR_Unsigned) pseudo_type_info;
if (MR_TYPE_VARIABLE_IS_UNIV_QUANT(pseudo_type_info)) {
/*
** This is a universally quantified type variable.
*/
- return type_info_params[arg_num];
+ return params[arg_num];
}
/*
@@ -130,6 +237,224 @@
}
int
+MR_compare_pseudo_type_info(MR_PseudoTypeInfo pti1, MR_PseudoTypeInfo pti2)
+{
+ MR_TypeCtorInfo tci1;
+ MR_TypeCtorInfo tci2;
+ MR_PseudoTypeInfo *arg_vector_1;
+ MR_PseudoTypeInfo *arg_vector_2;
+ int num_arg_types_1;
+ int num_arg_types_2;
+ int i;
+ int comp;
+
+ /*
+ ** Try to optimize a common case:
+ ** If type_info addresses are equal, they must represent the
+ ** same type.
+ */
+
+ if (pti1 == pti2) {
+ return MR_COMPARE_EQUAL;
+ }
+
+ /*
+ ** Otherwise, we need to expand equivalence types, if any.
+ */
+
+ pti1 = MR_collapse_equivalences_pseudo(pti1);
+ pti2 = MR_collapse_equivalences_pseudo(pti2);
+
+ /*
+ ** Perhaps they are equal now...
+ */
+
+ if (pti1 == pti2) {
+ return MR_COMPARE_EQUAL;
+ }
+
+ /*
+ ** Handle the comparison if either pseudo_type_info is a variable.
+ ** Any non-variable is greater than a nonvariable
+ */
+
+ if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(pti1) &&
+ MR_PSEUDO_TYPEINFO_IS_VARIABLE(pti2))
+ {
+ if ((int) pti1 < (int) pti2) {
+ return MR_COMPARE_LESS;
+ } else if ((int) pti1 > (int) pti2) {
+ return MR_COMPARE_GREATER;
+ } else {
+ return MR_COMPARE_EQUAL;
+ }
+ }
+
+ if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(pti1)) {
+ return MR_COMPARE_LESS;
+ }
+
+ if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(pti2)) {
+ return MR_COMPARE_GREATER;
+ }
+
+ /*
+ ** Otherwise find the type_ctor_infos, and compare those.
+ */
+
+ tci1 = MR_PSEUDO_TYPEINFO_GET_TYPE_CTOR_INFO(pti1);
+ tci2 = MR_PSEUDO_TYPEINFO_GET_TYPE_CTOR_INFO(pti2);
+
+ comp = MR_compare_type_ctor_info(tci1, tci2);
+ if (comp != MR_COMPARE_EQUAL) {
+ return comp;
+ }
+
+ /*
+ ** If the type_ctor_infos are equal, we don't need to compare
+ ** the arity of the types - they must be the same - unless they are
+ ** higher-order (which are all mapped to pred/0 or func/0) or tuples
+ ** (which are all mapped to tuple/0), in which cases we must compare
+ ** the arities before we can check the argument types.
+ */
+
+ if (MR_type_ctor_has_variable_arity(tci1)) {
+ num_arg_types_1 = MR_PSEUDO_TYPEINFO_GET_VAR_ARITY_ARITY(pti1);
+ num_arg_types_2 = MR_PSEUDO_TYPEINFO_GET_VAR_ARITY_ARITY(pti2);
+
+ /* Check arity */
+ if (num_arg_types_1 < num_arg_types_2) {
+ return MR_COMPARE_LESS;
+ } else if (num_arg_types_1 > num_arg_types_2) {
+ return MR_COMPARE_GREATER;
+ }
+
+ arg_vector_1 = MR_PSEUDO_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(pti1);
+ arg_vector_2 = MR_PSEUDO_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(pti2);
+ } else {
+ num_arg_types_1 = tci1->MR_type_ctor_arity;
+ arg_vector_1 = MR_PSEUDO_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(pti1);
+ arg_vector_2 = MR_PSEUDO_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(pti2);
+ }
+
+ /* compare the argument types */
+ for (i = 1; i <= num_arg_types_1; i++) {
+ comp = MR_compare_pseudo_type_info(arg_vector_1[i], arg_vector_2[i]);
+ if (comp != MR_COMPARE_EQUAL) {
+ return comp;
+ }
+ }
+
+ return MR_COMPARE_EQUAL;
+}
+
+MR_bool
+MR_unify_pseudo_type_info(MR_PseudoTypeInfo pti1, MR_PseudoTypeInfo pti2)
+{
+ MR_TypeCtorInfo tci1;
+ MR_TypeCtorInfo tci2;
+ MR_PseudoTypeInfo *arg_vector_1;
+ MR_PseudoTypeInfo *arg_vector_2;
+ int num_arg_types_1;
+ int num_arg_types_2;
+ int i;
+ int comp;
+
+ /*
+ ** Try to optimize a common case:
+ ** If type_info addresses are equal, they must represent the
+ ** same type.
+ */
+
+ if (pti1 == pti2) {
+ return MR_TRUE;
+ }
+
+ /*
+ ** Otherwise, we need to expand equivalence types, if any.
+ */
+
+ pti1 = MR_collapse_equivalences_pseudo(pti1);
+ pti2 = MR_collapse_equivalences_pseudo(pti2);
+
+ /*
+ ** Perhaps they are equal now...
+ */
+
+ if (pti1 == pti2) {
+ return MR_TRUE;
+ }
+
+ /*
+ ** Handle the comparison if either pseudo_type_info is a variable.
+ ** Any non-variable is greater than a nonvariable
+ */
+
+ if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(pti1) &&
+ MR_PSEUDO_TYPEINFO_IS_VARIABLE(pti2))
+ {
+ if ((int) pti1 != (int) pti2) {
+ return MR_FALSE;
+ } else {
+ return MR_TRUE;
+ }
+ }
+
+ if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(pti1)) {
+ return MR_FALSE;
+ }
+
+ if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(pti2)) {
+ return MR_FALSE;
+ }
+
+ /*
+ ** Otherwise find the type_ctor_infos, and compare those.
+ */
+
+ tci1 = MR_PSEUDO_TYPEINFO_GET_TYPE_CTOR_INFO(pti1);
+ tci2 = MR_PSEUDO_TYPEINFO_GET_TYPE_CTOR_INFO(pti2);
+
+ if (! MR_unify_type_ctor_info(tci1, tci2)) {
+ return MR_FALSE;
+ }
+
+ /*
+ ** If the type_ctor_infos are equal, we don't need to compare
+ ** the arity of the types - they must be the same - unless they are
+ ** higher-order (which are all mapped to pred/0 or func/0) or tuples
+ ** (which are all mapped to tuple/0), in which cases we must compare
+ ** the arities before we can check the argument types.
+ */
+
+ if (MR_type_ctor_has_variable_arity(tci1)) {
+ num_arg_types_1 = MR_PSEUDO_TYPEINFO_GET_VAR_ARITY_ARITY(pti1);
+ num_arg_types_2 = MR_PSEUDO_TYPEINFO_GET_VAR_ARITY_ARITY(pti2);
+
+ /* Check arity */
+ if (num_arg_types_1 != num_arg_types_2) {
+ return MR_FALSE;
+ }
+
+ arg_vector_1 = MR_PSEUDO_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(pti1);
+ arg_vector_2 = MR_PSEUDO_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(pti2);
+ } else {
+ num_arg_types_1 = tci1->MR_type_ctor_arity;
+ arg_vector_1 = MR_PSEUDO_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(pti1);
+ arg_vector_2 = MR_PSEUDO_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(pti2);
+ }
+
+ /* compare the argument types */
+ for (i = 1; i <= num_arg_types_1; i++) {
+ if (! MR_unify_pseudo_type_info(arg_vector_1[i], arg_vector_2[i])) {
+ return MR_FALSE;
+ }
+ }
+
+ return MR_TRUE;
+}
+
+int
MR_compare_type_info(MR_TypeInfo ti1, MR_TypeInfo ti2)
{
MR_TypeCtorInfo tci1;
@@ -208,9 +533,10 @@
/* compare the argument types */
for (i = 1; i <= num_arg_types_1; i++) {
comp = MR_compare_type_info(arg_vector_1[i], arg_vector_2[i]);
- if (comp != MR_COMPARE_EQUAL)
+ if (comp != MR_COMPARE_EQUAL) {
return comp;
}
+ }
return MR_COMPARE_EQUAL;
}
@@ -385,19 +711,48 @@
while (MR_type_ctor_rep(type_ctor_info) == MR_TYPECTOR_REP_EQUIV_GROUND
|| MR_type_ctor_rep(type_ctor_info) == MR_TYPECTOR_REP_EQUIV)
{
-
maybe_equiv_type_info = MR_create_type_info(
- MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(
- maybe_equiv_type_info),
+ MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(maybe_equiv_type_info),
MR_type_ctor_layout(type_ctor_info).MR_layout_equiv);
- type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(
- maybe_equiv_type_info);
+ type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(maybe_equiv_type_info);
}
return maybe_equiv_type_info;
}
+MR_PseudoTypeInfo
+MR_collapse_equivalences_pseudo(MR_PseudoTypeInfo maybe_equiv_pseudo_type_info)
+{
+ MR_TypeCtorInfo type_ctor_info;
+
+ if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(maybe_equiv_pseudo_type_info)) {
+ return maybe_equiv_pseudo_type_info;
+ }
+
+ type_ctor_info = MR_PSEUDO_TYPEINFO_GET_TYPE_CTOR_INFO(
+ maybe_equiv_pseudo_type_info);
+
+ /* Look past equivalences */
+ while (MR_type_ctor_rep(type_ctor_info) == MR_TYPECTOR_REP_EQUIV_GROUND
+ || MR_type_ctor_rep(type_ctor_info) == MR_TYPECTOR_REP_EQUIV)
+ {
+ maybe_equiv_pseudo_type_info = MR_create_pseudo_type_info(
+ MR_PSEUDO_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(
+ maybe_equiv_pseudo_type_info),
+ MR_type_ctor_layout(type_ctor_info).MR_layout_equiv);
+
+ if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(maybe_equiv_pseudo_type_info)) {
+ return maybe_equiv_pseudo_type_info;
+ }
+
+ type_ctor_info = MR_PSEUDO_TYPEINFO_GET_TYPE_CTOR_INFO(
+ maybe_equiv_pseudo_type_info);
+ }
+
+ return maybe_equiv_pseudo_type_info;
+}
+
/*
** MR_deallocate() frees up a list of memory cells
*/
@@ -422,7 +777,26 @@
MR_restore_transient_registers();
type_info_list = MR_list_empty();
while (arity > 0) {
- type_info_list = MR_type_info_list_cons(
+ type_info_list = MR_type_info_list_cons((MR_Word) type_params[arity],
+ type_info_list);
+ --arity;
+ }
+
+ MR_save_transient_registers();
+ return type_info_list;
+}
+
+MR_Word
+MR_pseudo_type_params_vector_to_list(int arity,
+ MR_PseudoTypeInfoParams type_params)
+{
+ MR_TypeInfo arg_type;
+ MR_Word type_info_list;
+
+ MR_restore_transient_registers();
+ type_info_list = MR_list_empty();
+ while (arity > 0) {
+ type_info_list = MR_pseudo_type_info_list_cons(
(MR_Word) type_params[arity], type_info_list);
--arity;
}
@@ -443,14 +817,14 @@
/* No arguments have names. */
while (arity > 0) {
--arity;
- arg_names_list = MR_string_list_cons(
- (MR_Word) NULL, arg_names_list);
+ arg_names_list = MR_string_list_cons((MR_Word) NULL,
+ arg_names_list);
}
} else {
while (arity > 0) {
--arity;
- arg_names_list = MR_string_list_cons(
- (MR_Word) arg_names[arity], arg_names_list);
+ arg_names_list = MR_string_list_cons((MR_Word) arg_names[arity],
+ arg_names_list);
}
}
@@ -459,34 +833,44 @@
}
MR_Word
-MR_pseudo_type_info_vector_to_type_info_list(int arity,
+MR_pseudo_type_info_vector_to_pseudo_type_info_list(int arity,
MR_TypeInfoParams type_params,
const MR_PseudoTypeInfo *arg_pseudo_type_infos)
{
- MR_TypeInfo arg_type_info;
- MR_Word type_info_list;
+ MR_PseudoTypeInfo pseudo;
+ MR_PseudoTypeInfo arg_pseudo_type_info;
+ MR_Word pseudo_type_info_list;
MR_restore_transient_registers();
- type_info_list = MR_list_empty();
+ pseudo_type_info_list = MR_list_empty();
while (--arity >= 0) {
/* Get the argument type_info */
+ pseudo = arg_pseudo_type_infos[arity];
+ if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(pseudo) &&
+ MR_TYPE_VARIABLE_IS_EXIST_QUANT(pseudo))
+ {
+ arg_pseudo_type_info = pseudo;
+ } else {
MR_save_transient_registers();
- arg_type_info = MR_create_type_info(type_params,
- arg_pseudo_type_infos[arity]);
+ arg_pseudo_type_info =
+ MR_create_pseudo_type_info(
+ (MR_PseudoTypeInfoParams) type_params, pseudo);
MR_restore_transient_registers();
MR_save_transient_registers();
- arg_type_info = MR_collapse_equivalences(arg_type_info);
+ arg_pseudo_type_info =
+ MR_collapse_equivalences_pseudo(arg_pseudo_type_info);
MR_restore_transient_registers();
+ }
- type_info_list = MR_type_info_list_cons(
- (MR_Word) arg_type_info, type_info_list);
+ pseudo_type_info_list = MR_pseudo_type_info_list_cons(
+ (MR_Word) arg_pseudo_type_info, pseudo_type_info_list);
}
MR_save_transient_registers();
- return type_info_list;
+ return pseudo_type_info_list;
}
MR_Word
Index: runtime/mercury_type_info.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_type_info.h,v
retrieving revision 1.114
diff -u -b -r1.114 mercury_type_info.h
--- runtime/mercury_type_info.h 28 Jun 2004 04:50:07 -0000 1.114
+++ runtime/mercury_type_info.h 11 Dec 2004 16:57:26 -0000
@@ -252,6 +252,15 @@
typedef MR_TypeInfo *MR_TypeInfoParams;
/*
+** When deep copying a MR_PseudoTypeInfo, we need to know the parameters
+** of a non-variable pseudo_type_info, which are themselves pseudo_type_infos.
+** A MR_PseudoTypeInfoParams array serves this purpose. Because type variables
+** start at one, MR_PseudoTypeInfoParams arrays also start at one.
+*/
+
+typedef MR_PseudoTypeInfo *MR_PseudoTypeInfoParams;
+
+/*
** MR_PSEUDOTYPEINFO_EXIST_VAR_BASE should be kept in sync with
** base_type_layout__pseudo_typeinfo_min_exist_var in base_type_layout.m.
**
@@ -314,11 +323,17 @@
#define MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info) \
((MR_TypeInfoParams) &(type_info)->MR_ti_type_ctor_info)
+#define MR_PSEUDO_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(pseudo_type_info) \
+ ((MR_PseudoTypeInfoParams) &(pseudo_type_info)->MR_pti_type_ctor_info)
+
#define MR_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(type_info) \
((MR_TypeInfoParams) &(type_info)->MR_ti_var_arity_arity)
+#define MR_PSEUDO_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(pseudo_type_info) \
+ ((MR_PseudoTypeInfoParams) &(pseudo_type_info)->MR_pti_var_arity_arity)
+
/*
-** Macros for creating type_infos.
+** Macros for creating type_infos and pseudo_type_infos.
*/
#define MR_fixed_arity_type_info_size(arity) \
@@ -327,6 +342,12 @@
#define MR_var_arity_type_info_size(arity) \
(2 + (arity))
+#define MR_fixed_arity_pseudo_type_info_size(arity) \
+ (1 + (arity))
+
+#define MR_var_arity_pseudo_type_info_size(arity) \
+ (2 + (arity))
+
#define MR_fill_in_fixed_arity_type_info(arena, type_ctor_info, vector) \
do { \
MR_TypeInfo new_ti; \
@@ -344,6 +365,23 @@
(vector) = (MR_TypeInfoParams) &new_ti->MR_ti_var_arity_arity;\
} while (0)
+#define MR_fill_in_fixed_arity_pseudo_type_info(arena, type_ctor_info, vector) \
+ do { \
+ MR_NCPseudoTypeInfo new_pti; \
+ new_pti = (MR_NCPseudoTypeInfo) (arena); \
+ new_pti->MR_pti_type_ctor_info = (type_ctor_info); \
+ (vector) = (MR_PseudoTypeInfoParams) &new_pti->MR_pti_type_ctor_info; \
+ } while (0)
+
+#define MR_fill_in_var_arity_pseudo_type_info(arena, type_ctor_info, arity, vector)\
+ do { \
+ MR_NCPseudoTypeInfo new_pti; \
+ new_pti = (MR_NCPseudoTypeInfo) (arena); \
+ new_pti->MR_pti_type_ctor_info = (type_ctor_info); \
+ new_pti->MR_pti_var_arity_arity = (arity); \
+ (vector) = (MR_PseudoTypeInfoParams) &new_pti->MR_pti_var_arity_arity;\
+ } while (0)
+
#define MR_static_type_info_arity_0(name, ctor) \
struct { \
MR_TypeCtorInfo field1; \
@@ -616,6 +654,7 @@
MR_DEFINE_BUILTIN_ENUM_CONST(MR_TYPECTOR_REP_REFERENCE),
MR_DEFINE_BUILTIN_ENUM_CONST(MR_TYPECTOR_REP_STABLE_C_POINTER),
MR_DEFINE_BUILTIN_ENUM_CONST(MR_TYPECTOR_REP_STABLE_FOREIGN),
+ MR_DEFINE_BUILTIN_ENUM_CONST(MR_TYPECTOR_REP_PSEUDOTYPEDESC),
/*
** MR_TYPECTOR_REP_UNKNOWN should remain the last alternative;
** MR_TYPE_CTOR_STATS depends on this.
@@ -1484,6 +1523,58 @@
/*---------------------------------------------------------------------------*/
/*
+** Compare two pseudo_type_info structures, using an ordering based on the
+** module names, type names and arities of the types inside the type_info.
+** Return MR_COMPARE_GREATER, MR_COMPARE_EQUAL, or MR_COMPARE_LESS,
+** depending on whether pti1 is greater than, equal to, or less than pti2.
+**
+** You need to wrap MR_{save/restore}_transient_hp() around
+** calls to this function.
+*/
+
+extern int MR_compare_pseudo_type_info(MR_PseudoTypeInfo pti1,
+ MR_PseudoTypeInfo pti2);
+
+/*
+** Unify two pseudo_type_info structures, using an ordering based on the
+** module names, type names and arities of the types inside the type_info.
+** Return MR_TRUE if ti1 represents the same type as ti2, and MR_FALSE
+** otherwise.
+**
+** You need to wrap MR_{save/restore}_transient_hp() around
+** calls to this function.
+*/
+
+extern MR_bool MR_unify_pseudo_type_info(MR_PseudoTypeInfo pti1,
+ MR_PseudoTypeInfo pti2);
+
+/*
+** Compare two pseudo_type_info structures, using an ordering based on the
+** module names, type names and arities of the types inside the type_info.
+** Return MR_COMPARE_GREATER, MR_COMPARE_EQUAL, or MR_COMPARE_LESS,
+** depending on whether ti1 is greater than, equal to, or less than ti2.
+**
+** You need to wrap MR_{save/restore}_transient_hp() around
+** calls to this function.
+*/
+
+extern int MR_compare_pseudo_type_info(MR_PseudoTypeInfo ti1,
+ MR_PseudoTypeInfo ti2);
+
+/*
+** Unify two pseudo_type_info structures, using an ordering based on the
+** module names, type names and arities of the types inside the type_info.
+** Return MR_TRUE if ti1 represents the same type as ti2, and MR_FALSE
+** otherwise.
+**
+** You need to wrap MR_{save/restore}_transient_hp() around
+** calls to this function.
+*/
+
+extern MR_bool MR_unify_pseudo_type_info(MR_PseudoTypeInfo ti1,
+ MR_PseudoTypeInfo ti2);
+
+/*
** Compare two type_info structures, using an ordering based on the
** module names, type names and arities of the types inside the type_info.
** Return MR_COMPARE_GREATER, MR_COMPARE_EQUAL, or MR_COMPARE_LESS,
@@ -1535,10 +1626,10 @@
/*
** MR_collapse_equivalences expands out all the top-level equivalences in
-** the argument typeinfo. It guarantees that the returned typeinfo's
+** the argument type_info. It guarantees that the returned type_info's
** type_ctor_info will not have a MR_TYPE_CTOR_REP_EQUIV* representation.
** However, since it only works on the top level type constructor,
-** this is not guaranteed for the typeinfos of the type constructor's
+** this is not guaranteed for the type_infos of the type constructor's
** arguments.
**
** You need to wrap MR_{save/restore}_transient_hp() around
@@ -1548,6 +1639,38 @@
extern MR_TypeInfo MR_collapse_equivalences(MR_TypeInfo type_info);
/*
+** MR_collapse_equivalences_pseudo expands out all the top-level equivalences
+** in the argument pseudo_type_info. It guarantees that the returned
+** pseudo_type_info's type_ctor_info, if any, will not have a
+** MR_TYPE_CTOR_REP_EQUIV* representation.
+** However, since it only works on the top level type constructor,
+** this is not guaranteed for the type_infos of the type constructor's
+** arguments.
+**
+** You need to wrap MR_{save/restore}_transient_hp() around
+** calls to this function.
+*/
+
+extern MR_PseudoTypeInfo MR_collapse_equivalences_pseudo(
+ MR_PseudoTypeInfo pseudo_type_info);
+
+/*
+** MR_collapse_equivalences_pseudo expands out all the top-level equivalences
+** in the argument pseudo_type_info. It guarantees that the returned
+** pseudo_type_info's type_ctor_info, if any, will not have a
+** MR_TYPE_CTOR_REP_EQUIV* representation.
+** However, since it only works on the top level type constructor,
+** this is not guaranteed for the type_infos of the type constructor's
+** arguments.
+**
+** You need to wrap MR_{save/restore}_transient_hp() around
+** calls to this function.
+*/
+
+extern MR_PseudoTypeInfo MR_collapse_equivalences_pseudo(
+ MR_PseudoTypeInfo pseudo_type_info);
+
+/*
** MR_create_type and MR_make_type_info both turn a pseudo typeinfo into
** a typeinfo, looking up the typeinfos associated with the type variables
** in the pseudointo typeinfo in the supplied vector of type parameters.
@@ -1594,6 +1717,15 @@
const MR_Word *data_value,
const MR_DuFunctorDesc *functor_descriptor);
+extern MR_PseudoTypeInfo MR_create_pseudo_type_info(
+ const MR_PseudoTypeInfoParams type_info_params,
+ const MR_PseudoTypeInfo pseudo_type_info);
+extern MR_PseudoTypeInfo MR_create_pseudo_type_info_maybe_existq(
+ const MR_PseudoTypeInfoParams type_info_params,
+ const MR_PseudoTypeInfo pseudo_type_info,
+ const MR_Word *data_value,
+ const MR_DuFunctorDesc *functor_descriptor);
+
struct MR_MemoryCellNode {
void *data;
struct MR_MemoryCellNode *next;
@@ -1627,6 +1759,19 @@
MR_TypeInfoParams type_params);
/*
+** MR_pseudo_type_params_vector_to_list:
+**
+** Copy `arity' pseudo_type_infos from the `arg_type_infos' vector,
+** which starts at index 1, onto the Mercury heap in a list.
+**
+** You need to save and restore transient registers around
+** calls to this function.
+*/
+
+extern MR_Word MR_pseudo_type_params_vector_to_list(int arity,
+ MR_PseudoTypeInfoParams type_params);
+
+/*
** ML_arg_name_vector_to_list:
**
** Copy `arity' argument names from the `arg_names' vector, which starts
@@ -1643,18 +1788,20 @@
const MR_ConstString *arg_names);
/*
-** ML_pseudo_type_info_vector_to_type_info_list:
+** MR_pseudo_type_info_vector_to_pseudo_type_info_list:
**
** Take `arity' pseudo_type_infos from the `arg_pseudo_type_infos' vector,
** which starts at index 0, expand them, and copy them onto the heap
-** in a list.
+** in a list. The elements of the resulting list will be pseudo_type_infos
+** which shouldn't contain universally quantified type variables, but may
+** contain existentially quantified type variables.
**
** You need to save and restore transient registers around
** calls to this function.
*/
-extern MR_Word MR_pseudo_type_info_vector_to_type_info_list(int arity,
- MR_TypeInfoParams type_params,
+extern MR_Word MR_pseudo_type_info_vector_to_pseudo_type_info_list(
+ int arity, MR_TypeInfoParams type_params,
const MR_PseudoTypeInfo *arg_pseudo_type_infos);
/*---------------------------------------------------------------------------*/
Index: runtime/mercury_types.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_types.h,v
retrieving revision 1.39
diff -u -b -r1.39 mercury_types.h
--- runtime/mercury_types.h 20 Jul 2004 04:41:25 -0000 1.39
+++ runtime/mercury_types.h 11 Dec 2004 11:13:05 -0000
@@ -179,6 +179,7 @@
typedef const struct MR_TypeCtorInfo_Struct *MR_TypeCtorInfo;
typedef struct MR_TypeInfo_Almost_Struct *MR_TypeInfo;
typedef const struct MR_PseudoTypeInfo_Almost_Struct *MR_PseudoTypeInfo;
+typedef struct MR_PseudoTypeInfo_Almost_Struct *MR_NCPseudoTypeInfo;
typedef const void *MR_ReservedAddr;
#ifdef MR_HIGHLEVEL_CODE
Index: runtime/mercury_unify_compare_body.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_unify_compare_body.h,v
retrieving revision 1.38
diff -u -b -r1.38 mercury_unify_compare_body.h
--- runtime/mercury_unify_compare_body.h 26 Jul 2004 03:19:27 -0000 1.38
+++ runtime/mercury_unify_compare_body.h 11 Dec 2004 11:13:05 -0000
@@ -643,6 +643,27 @@
#endif
}
+ case MR_TYPECTOR_REP_PSEUDOTYPEDESC:
+ {
+#ifdef select_compare_code
+ int result;
+
+ MR_save_transient_registers();
+ result = MR_compare_pseudo_type_info(
+ (MR_PseudoTypeInfo) x, (MR_PseudoTypeInfo) y);
+ MR_restore_transient_registers();
+ return_compare_answer(type_desc, pseudo_type_desc, 0, result);
+#else
+ MR_bool result;
+
+ MR_save_transient_registers();
+ result = MR_unify_pseudo_type_info(
+ (MR_PseudoTypeInfo) x, (MR_PseudoTypeInfo) y);
+ MR_restore_transient_registers();
+ return_unify_answer(type_desc, pseudo_type_desc, 0, result);
+#endif
+ }
+
case MR_TYPECTOR_REP_TYPECTORINFO:
{
#ifdef select_compare_code
Index: runtime/mercury_wrapper.c
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_wrapper.c,v
retrieving revision 1.137
diff -u -b -r1.137 mercury_wrapper.c
--- runtime/mercury_wrapper.c 5 Nov 2004 05:03:16 -0000 1.137
+++ runtime/mercury_wrapper.c 11 Dec 2004 08:29:15 -0000
@@ -323,11 +323,13 @@
MR_TypeCtorInfo MR_type_ctor_info_for_univ;
MR_TypeInfo MR_type_info_for_type_info;
+MR_TypeInfo MR_type_info_for_pseudo_type_info;
MR_TypeInfo MR_type_info_for_list_of_univ;
MR_TypeInfo MR_type_info_for_list_of_int;
MR_TypeInfo MR_type_info_for_list_of_char;
MR_TypeInfo MR_type_info_for_list_of_string;
MR_TypeInfo MR_type_info_for_list_of_type_info;
+MR_TypeInfo MR_type_info_for_list_of_pseudo_type_info;
MR_Box (*MR_address_of_do_load_aditi_rl_code)(MR_Box, MR_Box);
Index: runtime/mercury_wrapper.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_wrapper.h,v
retrieving revision 1.63
diff -u -b -r1.63 mercury_wrapper.h
--- runtime/mercury_wrapper.h 20 Jul 2004 04:41:26 -0000 1.63
+++ runtime/mercury_wrapper.h 11 Dec 2004 08:28:57 -0000
@@ -101,11 +101,13 @@
extern MR_TypeCtorInfo MR_type_ctor_info_for_univ;
extern MR_TypeInfo MR_type_info_for_type_info;
+extern MR_TypeInfo MR_type_info_for_pseudo_type_info;
extern MR_TypeInfo MR_type_info_for_list_of_univ;
extern MR_TypeInfo MR_type_info_for_list_of_int;
extern MR_TypeInfo MR_type_info_for_list_of_char;
extern MR_TypeInfo MR_type_info_for_list_of_string;
extern MR_TypeInfo MR_type_info_for_list_of_type_info;
+extern MR_TypeInfo MR_type_info_for_list_of_pseudo_type_info;
#ifdef MR_CONSERVATIVE_GC
extern void (*MR_address_of_init_gc)(void);
cvs diff: Diffing runtime/GETOPT
cvs diff: Diffing runtime/machdeps
cvs diff: Diffing samples
cvs diff: Diffing samples/c_interface
cvs diff: Diffing samples/c_interface/c_calls_mercury
cvs diff: Diffing samples/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/mercury_calls_c
cvs diff: Diffing samples/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/diff
cvs diff: Diffing samples/muz
cvs diff: Diffing samples/rot13
cvs diff: Diffing samples/solutions
cvs diff: Diffing samples/tests
cvs diff: Diffing samples/tests/c_interface
cvs diff: Diffing samples/tests/c_interface/c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/tests/c_interface/mercury_calls_c
cvs diff: Diffing samples/tests/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/tests/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/tests/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/tests/diff
cvs diff: Diffing samples/tests/muz
cvs diff: Diffing samples/tests/rot13
cvs diff: Diffing samples/tests/solutions
cvs diff: Diffing samples/tests/toplevel
cvs diff: Diffing scripts
cvs diff: Diffing tests
cvs diff: Diffing tests/benchmarks
cvs diff: Diffing tests/debugger
cvs diff: Diffing tests/debugger/declarative
cvs diff: Diffing tests/dppd
cvs diff: Diffing tests/general
cvs diff: Diffing tests/general/accumulator
cvs diff: Diffing tests/general/string_format
cvs diff: Diffing tests/general/structure_reuse
cvs diff: Diffing tests/grade_subdirs
cvs diff: Diffing tests/hard_coded
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/hard_coded/Mmakefile,v
retrieving revision 1.243
diff -u -b -r1.243 Mmakefile
--- tests/hard_coded/Mmakefile 7 Dec 2004 04:55:50 -0000 1.243
+++ tests/hard_coded/Mmakefile 11 Dec 2004 16:58:45 -0000
@@ -11,10 +11,9 @@
any_free_unify \
backquoted_qualified_ops \
bidirectional \
+ boyer \
brace \
builtin_inst_rename \
- boyer \
- c_write_string \
cc_and_non_cc_test \
cc_multi_bug \
cc_nondet_disj \
@@ -23,17 +22,19 @@
common_type_cast \
compare_spec \
comparison \
- contains_char \
constant_prop_1 \
constraint \
constraint_order \
- construct_test \
construct_bug \
+ construct_test \
+ construct_test_exist \
+ contains_char \
contravariance_bug \
contravariance_poly \
curry \
curry2 \
cut_test \
+ c_write_string \
cycles \
cycles2 \
deconstruct_arg \
@@ -45,8 +46,8 @@
division_test \
dot_separator \
dst_test \
- dupcall_types_bug \
dupcall_impurity \
+ dupcall_types_bug \
elim_special_pred \
equality_pred_which_requires_boxing \
eqv_type_bug \
@@ -56,8 +57,8 @@
existential_float \
existential_reordering \
existential_reordering_class \
- existential_type_switch_opt \
existential_types_test \
+ existential_type_switch_opt \
expand \
export_test \
external_unification_pred \
@@ -94,13 +95,13 @@
impossible_unify \
impure_foreign \
impure_prune \
- int_fold_up_down \
integer_test \
intermod_c_code \
intermod_foreign_type \
intermod_multimode_main \
intermod_pragma_clause \
intermod_type_qual \
+ int_fold_up_down \
join_list \
loop_inv_test \
loop_inv_test1 \
@@ -115,10 +116,10 @@
no_fully_strict \
no_inline \
no_inline_builtins \
- no_warn_singleton \
nonascii \
- nondet_ctrl_vn \
nondet_copy_out \
+ nondet_ctrl_vn \
+ no_warn_singleton \
nullary_ho_func \
null_char \
ppc_bug \
@@ -166,8 +167,8 @@
test_bitset \
test_cord \
test_imported_no_tag \
- tim_qual1 \
time_test \
+ tim_qual1 \
trans_intermod_user_equality \
transitive_inst_type \
tuple_test \
@@ -178,9 +179,9 @@
type_spec_ho_term \
type_spec_modes \
type_to_term_bug \
+ unify_existq_cons \
unify_expression \
unify_typeinfo_bug \
- unify_existq_cons \
uniq_duplicate_call \
unused_float_box_test \
user_compare \
Index: tests/hard_coded/construct_test.exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/hard_coded/construct_test.exp,v
retrieving revision 1.3
diff -u -b -r1.3 construct_test.exp
--- tests/hard_coded/construct_test.exp 21 Nov 2002 15:32:47 -0000 1.3
+++ tests/hard_coded/construct_test.exp 11 Dec 2004 13:46:39 -0000
@@ -187,6 +187,9 @@
0 - qwerty/1 [qwerty_field]
+1 functors in this type
+0 - xyzzy/1 [f21name]
+
About to construct three/0
Constructed: three
Index: tests/hard_coded/construct_test.m
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/hard_coded/construct_test.m,v
retrieving revision 1.3
diff -u -b -r1.3 construct_test.m
--- tests/hard_coded/construct_test.m 21 Nov 2002 15:32:47 -0000 1.3
+++ tests/hard_coded/construct_test.m 11 Dec 2004 00:43:42 -0000
@@ -6,23 +6,12 @@
:- interface.
:- import_module io.
-:- pred main(io__state::di, io__state::uo) is det.
+:- pred main(io::di, io::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_desc::in, io__state::di, io__state::uo) is det.
-:- pred test_nth_functor(type_desc::in, io__state::di, io__state::uo) is det.
-:- pred test_all(T::in, io__state::di, io__state::uo) is det.
+:- import_module construct, type_desc.
:- type enum ---> one ; two ; three.
@@ -40,6 +29,8 @@
:- type no_tag ---> qwerty(qwerty_field :: int).
+:- type exist_type ---> some [T] xyzzy(f21name :: T).
+
%----------------------------------------------------------------------------%
main -->
@@ -51,19 +42,22 @@
%----------------------------------------------------------------------------%
+:- pred test_construct(io::di, io::uo) is det.
+
test_construct -->
% Valid tests.
% Enumerations:
- test_construct_2(type_of(one), "three", 0, []),
+ test_construct_2(type_desc__type_of(one), "three", 0, []),
{ type_to_univ([1, 2, 3], NumList) },
- test_construct_2(type_of(apple([])), "apple", 1, [NumList]),
+ test_construct_2(type_desc__type_of(apple([])), "apple", 1, [NumList]),
{ type_to_univ([one, two, three], EnumList) },
- test_construct_2(type_of(apple([])), "banana", 1, [EnumList]),
+ test_construct_2(type_desc__type_of(apple([])), "banana", 1,
+ [EnumList]),
% Discriminated union:
% (Simple, complicated and complicated constant tags).
@@ -71,38 +65,43 @@
{ 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]),
+ test_construct_2(type_desc__type_of(wombat), "foo", 0, []),
+ test_construct_2(type_desc__type_of(wombat), "bar", 1, [One]),
+ test_construct_2(type_desc__type_of(wombat), "bar", 2, [One, One]),
+ test_construct_2(type_desc__type_of(wombat), "qux", 1, [One]),
+ test_construct_2(type_desc__type_of(wombat), "quux", 1, [One]),
+ test_construct_2(type_desc__type_of(wombat), "quuux", 2, [One, One]),
+ test_construct_2(type_desc__type_of(wombat), "wombat", 0, []),
+ test_construct_2(type_desc__type_of(wombat), "zoom", 1, [One]),
+ test_construct_2(type_desc__type_of(wombat), "zap", 2,
+ [One, TwoPointOne]),
+ test_construct_2(type_desc__type_of(wombat), "zip", 2, [One, One]),
+ test_construct_2(type_desc__type_of(wombat), "zop", 2,
+ [TwoPointOne, TwoPointOne]),
% No-tag type:
- test_construct_2(type_of(qwerty(7)), "qwerty", 1, [One]),
+ test_construct_2(type_desc__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]),
- test_construct_2(type_of({1, "two", '3'}), "{}", 3,
+ test_construct_2(type_desc__type_of(poly_four(3, "hello")),
+ "poly_one", 1, [One]),
+ test_construct_2(type_desc__type_of(poly_four(3, "hello")),
+ "poly_two", 1, [Bye]),
+ test_construct_2(type_desc__type_of(poly_four(3, "hello")),
+ "poly_four", 2, [One, Bye]),
+ test_construct_2(type_desc__type_of({1, "two", '3'}), "{}", 3,
[univ(4), univ("five"), univ('6')]),
io__write_string("About to call construct_tuple\n"),
- { Tuple = construct_tuple([NumList, EnumList, One, TwoPointOne]) },
+ { Tuple = construct__construct_tuple(
+ [NumList, EnumList, One, TwoPointOne]) },
io__write_string("Constructed tuple: "),
io__write(Tuple),
io__nl.
-:- pred test_construct_2(type_desc::in, string::in, int::in, list(univ)::in,
- io__state::di, io__state::uo) is det.
+:- pred test_construct_2(type_desc__type_desc::in, string::in, int::in,
+ list(univ)::in, io::di, io::uo) is det.
test_construct_2(TypeInfo, FunctorName, Arity, Args) -->
{ find_functor(TypeInfo, FunctorName, Arity, FunctorNumber) },
@@ -112,7 +111,8 @@
io__write_int(Arity),
newline,
(
- { Constructed = construct(TypeInfo, FunctorNumber, Args) }
+ { Constructed =
+ construct__construct(TypeInfo, FunctorNumber, Args) }
->
io__write_string("Constructed: "),
io__print(Constructed),
@@ -121,24 +121,21 @@
io__write_string("Construction failed.\n")
).
-:- pred find_functor(type_desc::in, string::in, int::in, int::out) is det.
+:- pred find_functor(type_desc__type_desc::in, string::in, int::in, int::out)
+ is det.
find_functor(TypeInfo, Functor, Arity, FunctorNumber) :-
- N = num_functors(TypeInfo),
+ N = construct__num_functors(TypeInfo),
find_functor2(TypeInfo, Functor, Arity, N, FunctorNumber).
-:- pred find_functor2(type_desc::in, string::in, int::in, int::in,
+:- pred find_functor2(type_desc__type_desc::in, string::in, int::in, int::in,
int::out) is det.
find_functor2(TypeInfo, Functor, Arity, Num, FunctorNumber) :-
- (
- Num < 0
- ->
+ ( Num < 0 ->
error("unable to find functor")
;
- (
- get_functor(TypeInfo, Num, Functor, Arity, _List)
- ->
+ ( construct__get_functor(TypeInfo, Num, Functor, Arity, _) ->
FunctorNumber = Num
;
find_functor2(TypeInfo, Functor, Arity, Num - 1,
@@ -148,59 +145,64 @@
%----------------------------------------------------------------------------%
-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.
+:- pred test_all(T::in, io::di, io::uo) is det.
-test_nth_functor(TypeInfo) -->
- { N = num_functors(TypeInfo) },
- test_all_functors(TypeInfo, N - 1).
+test_all(T, !IO) :-
+ TypeInfo = type_desc__type_of(T),
+ N = construct__num_functors(TypeInfo),
+ io__write_int(N, !IO),
+ io__write_string(" functors in this type", !IO),
+ io__nl(!IO),
+ test_all_functors(TypeInfo, N, !IO),
+ io__nl(!IO).
+
+:- pred test_all_functors(type_desc__type_desc::in, int::in, io::di, io::uo)
+ is det.
+
+test_all_functors(TypeInfo, N, !IO) :-
+ ( N =< 0 ->
+ true
+ ;
+ test_nth_functor(TypeInfo, N - 1, !IO),
+ test_all_functors(TypeInfo, N - 1, !IO)
+ ).
-:- pred test_all_functors(type_desc::in, int::in,
- io__state::di, io__state::uo) is det.
+:- pred test_nth_functor(type_desc__type_desc::in, int::in, io::di, io::uo)
+ is det.
-test_all_functors(TypeInfo, N) -->
+test_nth_functor(TypeInfo, N, !IO) :-
+ io__write_int(N, !IO),
(
- { N < 0 }
+ construct__get_functor_with_names(TypeInfo, N, Name, Arity,
+ _List, Names)
->
- []
+ io__write_string(" - ", !IO),
+ io__write_string(Name, !IO),
+ io__write_string("/", !IO),
+ io__write_int(Arity, !IO),
+ io__write_string(" [", !IO),
+ io__write_list(Names, ", ", print_maybe_name, !IO),
+ io__write_string("]\n", !IO)
;
- io__write_int(N),
- (
- { get_functor(TypeInfo, N, Name, Arity, _List, Names) }
- ->
- io__write_string(" - "),
- io__write_string(Name),
- io__write_string("/"),
- io__write_int(Arity),
- io__write_string(" ["),
- io__write_list(Names, ", ",
- (pred(MaybeName::in, di, uo) is det -->
+ io__write_string(" failed ", !IO),
+ io__nl(!IO)
+ ).
+
+:- pred print_maybe_name(maybe(string)::in, io::di, io::uo) is det.
+
+print_maybe_name(MaybeName, !IO) :-
(
- { MaybeName = yes(FieldName) },
- io__write_string(FieldName)
+ MaybeName = yes(FieldName),
+ io__write_string(FieldName, !IO)
;
- { MaybeName = no },
- io__write_string("_")
- )
- )),
- io__write_string("]\n")
- ;
- io__write_string(" failed "),
- newline
- ),
- test_all_functors(TypeInfo, N - 1)
+ MaybeName = no,
+ io__write_string("_", !IO)
).
%----------------------------------------------------------------------------%
+:- pred test_discriminated(io::di, io::uo) is det.
+
test_discriminated -->
io__write_string("TESTING DISCRIMINATED UNIONS\n"),
@@ -225,6 +227,8 @@
newline.
+:- pred test_polymorphism(io::di, io::uo) is det.
+
test_polymorphism -->
io__write_string("TESTING POLYMORPHISM\n"),
test_all(poly_three(3.33, 4, poly_one(9.11))), newline,
@@ -233,6 +237,8 @@
newline.
+:- pred test_builtins(io::di, io::uo) is det.
+
test_builtins -->
io__write_string("TESTING BUILTINS\n"),
@@ -271,6 +277,8 @@
% that are dependent on the implementation. If someone changes
% the implementation, the results of this test can change.
+:- pred test_other(io::di, io::uo) is det.
+
test_other -->
io__write_string("TESTING OTHER TYPES\n"),
{ term__init_var_supply(VarSupply) },
@@ -287,7 +295,11 @@
% a no tag type
test_all(qwerty(4)), newline,
- newline.
+ % an existential type:
+ { ExistVal = 'new xyzzy'(8) },
+ test_all(ExistVal), newline.
+
+:- pred newline(io::di, io::uo) is det.
newline -->
io__write_char('\n').
Index: tests/hard_coded/construct_test_exist.exp
===================================================================
RCS file: tests/hard_coded/construct_test_exist.exp
diff -N tests/hard_coded/construct_test_exist.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/construct_test_exist.exp 11 Dec 2004 17:18:51 -0000
@@ -0,0 +1,19 @@
+5 functors in this type
+4 - f15/3 [E513, list(E514), E514] [_, _, _]
+3 - f14/2 [E513, list(E514)] [_, _]
+2 - f13/3 [int, E513, list(E513)] [_, _, _]
+1 - f12/1 [int] [_]
+0 - f11/0 [] []
+
+2 functors in this type
+1 - f22/5 [int, E513, list(E513), E513, float] [f21name, f22name, f23name, f24name, f25name]
+0 - f21/0 [] []
+
+2 functors in this type
+1 - f32/4 [int, pair(int, E513), tree234(int, pair(string, pair(E513, E514))), string] [f31name, f32name, f33name, f34name]
+0 - f31/2 [int, string] [_, _]
+
+2 functors in this type
+1 - f32/4 [int, pair(list(int), E513), tree234(list(int), pair(float, pair(E513, E514))), float] [f31name, f32name, f33name, f34name]
+0 - f31/2 [list(int), float] [_, _]
+
Index: tests/hard_coded/construct_test_exist.m
===================================================================
RCS file: tests/hard_coded/construct_test_exist.m
diff -N tests/hard_coded/construct_test_exist.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/construct_test_exist.m 11 Dec 2004 17:17:40 -0000
@@ -0,0 +1,139 @@
+% Test case for get_functor on a functor with existentially typed arguments.
+%
+% Author: zs
+
+:- module construct_test_exist.
+
+:- interface.
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+
+:- import_module list, int, std_util, term, map, string, require.
+:- import_module type_desc, construct.
+
+:- typeclass tc1(V) where [
+ func m1(V) = int
+].
+
+:- type t1
+ ---> f11
+ ; f12(int)
+ ; some [T] f13(int, T, list(T))
+ ; some [T, U] f14(T, list(U))
+ ; some [T, U] f15(T, list(U), U) => tc1(T).
+
+:- type t2
+ ---> f21
+ ; some [T] f22(
+ f21name :: int,
+ f22name :: T,
+ f23name :: list(T),
+ f24name :: T,
+ f25name :: float
+ ).
+
+:- type t3(T, U)
+ ---> f31(T, U)
+ ; some [V, W] f32(
+ f31name :: int,
+ f32name :: pair(T, V),
+ f33name :: map(T, pair(U, pair(V, W))),
+ f34name :: U
+ ).
+
+%----------------------------------------------------------------------------%
+
+main(!IO) :-
+ test_all(f11, !IO),
+ test_all(f21, !IO),
+ test_all(f31(3, "three"), !IO),
+ test_all(f31([3], 3.0), !IO).
+
+:- pred test_all(T::in, io::di, io::uo) is det.
+
+test_all(T, !IO) :-
+ TypeInfo = type_desc__type_of(T),
+ N = construct__num_functors(TypeInfo),
+ io__write_int(N, !IO),
+ io__write_string(" functors in this type", !IO),
+ io__nl(!IO),
+ test_all_functors(TypeInfo, N, !IO),
+ io__nl(!IO).
+
+:- pred test_all_functors(type_desc__type_desc::in, int::in, io::di, io::uo)
+ is det.
+
+test_all_functors(TypeInfo, N, !IO) :-
+ ( N =< 0 ->
+ true
+ ;
+ test_nth_functor(TypeInfo, N - 1, !IO),
+ test_all_functors(TypeInfo, N - 1, !IO)
+ ).
+
+:- pred test_nth_functor(type_desc__type_desc::in, int::in, io::di, io::uo)
+ is det.
+
+test_nth_functor(TypeInfo, N, !IO) :-
+ io__write_int(N, !IO),
+ (
+ construct__get_functor_with_names(TypeInfo, N, Name, Arity,
+ ArgTypes, Names)
+ ->
+ io__write_string(" - ", !IO),
+ io__write_string(Name, !IO),
+ io__write_string("/", !IO),
+ io__write_int(Arity, !IO),
+ io__write_string(" [", !IO),
+ io__write_list(ArgTypes, ", ", print_arg_type, !IO),
+ io__write_string("] ", !IO),
+ io__write_string(" [", !IO),
+ io__write_list(Names, ", ", print_maybe_name, !IO),
+ io__write_string("]\n", !IO)
+ ;
+ io__write_string(" failed ", !IO),
+ io__nl(!IO)
+ ).
+
+:- pred print_arg_type(type_desc__pseudo_type_desc::in, io::di, io::uo)
+ is det.
+
+print_arg_type(PseudoTypeDesc, !IO) :-
+ PseudoTypeRep = pseudo_type_desc_to_rep(PseudoTypeDesc),
+ (
+ PseudoTypeRep = bound(TypeCtorDesc, ArgPseudoTypeInfos),
+ io__write_string(type_desc__type_ctor_name(TypeCtorDesc), !IO),
+ (
+ ArgPseudoTypeInfos = []
+ ;
+ ArgPseudoTypeInfos = [_ | _],
+ io__write_string("(", !IO),
+ io__write_list(ArgPseudoTypeInfos, ", ",
+ print_arg_type, !IO),
+ io__write_string(")", !IO)
+ )
+ ;
+ PseudoTypeRep = univ_tvar(TypeVarNum),
+ io__write_string("U", !IO),
+ io__write_int(TypeVarNum, !IO)
+ ;
+ PseudoTypeRep = exist_tvar(TypeVarNum),
+ io__write_string("E", !IO),
+ io__write_int(TypeVarNum, !IO)
+ ).
+
+:- pred print_maybe_name(maybe(string)::in, io::di, io::uo) is det.
+
+print_maybe_name(MaybeName, !IO) :-
+ (
+ MaybeName = yes(FieldName),
+ io__write_string(FieldName, !IO)
+ ;
+ MaybeName = no,
+ io__write_string("_", !IO)
+ ).
+
+%----------------------------------------------------------------------------%
cvs diff: Diffing tests/hard_coded/exceptions
cvs diff: Diffing tests/hard_coded/purity
cvs diff: Diffing tests/hard_coded/sub-modules
cvs diff: Diffing tests/hard_coded/typeclasses
cvs diff: Diffing tests/invalid
cvs diff: Diffing tests/invalid/purity
cvs diff: Diffing tests/misc_tests
cvs diff: Diffing tests/mmc_make
cvs diff: Diffing tests/mmc_make/lib
cvs diff: Diffing tests/recompilation
cvs diff: Diffing tests/tabling
cvs diff: Diffing tests/term
cvs diff: Diffing tests/valid
cvs diff: Diffing tests/warnings
cvs diff: Diffing tools
cvs diff: Diffing trace
cvs diff: Diffing util
Index: util/mkinit.c
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/util/mkinit.c,v
retrieving revision 1.93
diff -u -b -r1.93 mkinit.c
--- util/mkinit.c 24 May 2004 04:32:56 -0000 1.93
+++ util/mkinit.c 11 Dec 2004 08:31:18 -0000
@@ -290,6 +290,8 @@
" MR_type_ctor_info_for_univ = ML_type_ctor_info_for_univ;\n"
" MR_type_info_for_type_info = (MR_TypeInfo)\n"
" &ML_type_info_for_type_info;\n"
+ " MR_type_info_for_pseudo_type_info = (MR_TypeInfo)\n"
+ " &ML_type_info_for_pseudo_type_info;\n"
" MR_type_info_for_list_of_univ = (MR_TypeInfo)\n"
" &ML_type_info_for_list_of_univ;\n"
" MR_type_info_for_list_of_int = (MR_TypeInfo)\n"
@@ -300,6 +302,8 @@
" &ML_type_info_for_list_of_string;\n"
" MR_type_info_for_list_of_type_info = (MR_TypeInfo)\n"
" &ML_type_info_for_list_of_type_info;\n"
+ " MR_type_info_for_list_of_pseudo_type_info = (MR_TypeInfo)\n"
+ " &ML_type_info_for_list_of_pseudo_type_info;\n"
" MR_address_of_do_load_aditi_rl_code = %s;\n"
"#ifdef MR_CONSERVATIVE_GC\n"
" MR_address_of_init_gc = init_gc;\n"
cvs diff: Diffing vim
cvs diff: Diffing vim/after
cvs diff: Diffing vim/ftplugin
cvs diff: Diffing vim/syntax
--------------------------------------------------------------------------
mercury-reviews mailing list
post: mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------
More information about the reviews
mailing list