[m-rev.] for review: divide up std_util.m
Zoltan Somogyi
zs at cs.mu.OZ.AU
Wed Jan 30 01:45:09 AEDT 2002
For review by anyone.
Move the RTTI-related parts of std_util.m to three new modules in the standard
library, and (in the case of embedded C code) to new modules in the runtime.
The main reason for this is to allow a reorganization of some of the
RTTi-related functionality without breaking backward compatibility. However,
the new arrangement should also be easier to maintain.
Use a separate type_ctor_rep for functions, to distinguish them from predicates
for RTTI code. (At one point, I thought this could avoid the need for the
change to the initialization files mentioned below. It can't, but it is a good
idea in any case.)
library/std_util.m:
Remove the functionality moved to the new modules, and replace them
with type equivalences and forwarding code. There are no changes in
the meanings of the user-visible predicates, with two exceptions.
- First, the true, equivalence-expanded names of what used to be
std_util:type_desc and std_util:type_ctor_desc are now
type_desc:type_desc and type_desc: type_ctor_desc.
- Second, deconstructing a function term now yields
"<<function>>" instead of "<<predicate>>".
The intention is that the RTTI predicates in std_util.m will continue
to work in a backwards-compatible manner for the near future, i.e. as
the new modules are updated, the code in std_util will be updated to
maintain the same functionality, modulo improvements such as avoiding
unwanted exceptions. When the RTTI functionality in the other modules
has stabilised, the RTTI predicates in std_util.m should be marked
obsolete.
The exported but non-documented functionality of std_util has been
moved to one of the new modules without forwarding code, with one
of the moved predicates being turned into the function it should have
been in the first place.
library/construct.m:
library/deconstruct.m:
library/type_desc.m:
Three new modules for the code moved from std_util.m.
library/library.m:
compiler/modules.m:
Record the names of the three new library modules.
runtime/mercury.[ch]:
compiler/mlds_to_il.m:
Record that type_desc is now in type_desc.m, not std_util.m.
compiler/static_term.m:
Import the deconstruct module, since we are using its undocumented
facilities.
runtime/Mmakefile:
Mention the two new modules.
runtime/mercury_construct.[ch]:
runtime/mercury_type_desc.[ch]:
Two new modules holding the C functions that used to be in foreign_code
in std_util, now using MR_ instead of ML_ prefixes, and being more
consistent about indentation.
runtime/mercury_type_info.h:
Add a new type_ctor_rep for functions, separate from predicates.
(It reuses the EQUIV_VAR type_ctor_rep, which hasn't been used
in ages.)
Use type_ctor_reps to distinguish between the type_ctor_infos of
pred/0 and func/0. However, to create higher order typeinfos, we
still need to know the addresses of the type_ctor_infos for
pred/0 and func/0, and we still need to know the address of the
type_ctor_info for tuples to create typeinfos for tuples. Since
these three type_ctor_infos are defined in the library,
we cannot access them directly from the runtime. We therefore need
to access them indirectly in the usual manner, via address_of
variables initialized by mkinit-generated code.
library/builtin.m:
library/private_builtin.m:
library/rtti_implementation.m:
runtime/mercury.c:
runtime/mercury_mcpp.{h,cpp}:
java/TypeCtorRep.java:
Updates to accommondate the new function type_ctor_rep.
runtime/mercury_type_info.[ch]:
Add some functions from foreign_code in std_util that fit in best here.
runtime/mercury_ml_expand_body.h:
runtime/mercury_tabling.h:
runtime/mercury_unify_compare_body.h:
Delete the code for handling EQUIV_VAR, and add code for handling
functions.
runtime/mercury_init.h:
runtime/mercury_wrapper.[ch]:
Add three variables holding the address of the type_ctor_infos
representing functions, predicates and tuples.
util/mkinit.c:
Fill in these three variables.
tests/general/accumulator/construct.{m,exp}:
tests/general/accumulator/deconstruct.{m,exp}:
tests/hard_coded/construct.{m,exp}:
Rename these tests by adding a _test at the ends of their names,
in order to avoid collisions with the names of the new standard library
modules. The test cases have not changed, with the exception of the :-
module declaration of course.
tests/general/accumulator/Mmakefile:
tests/general/accumulator/INTRODUCED:
tests/hard_coded/Mmakefile:
Record the name changes.
tests/hard_coded/existential_float.exp:
Updated the expected output to reflect that deconstructions now print
"<<function>>" instead of "<<predicate>>" when appropriate.
tests/hard_coded/higher_order_type_manip.exp:
Updated the expected output to reflect the new name of what used to be
std_util:type_desc.
trace/mercury_trace_browse.c:
trace/mercury_trace_external.c:
trace/mercury_trace_help.c:
#include type_desc.h instead of std_util.h, since the C functions
we want to call are now defined there.
trace/mercury_trace_vars.c:
Update to account for the movement of type_desc from std_util to
type_desc, and ensure that we don't refer to any type_ctor_infos
in MLDS grades.
Zoltan.
cvs diff: Diffing .
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/mlds_to_il.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_il.m,v
retrieving revision 1.98
diff -u -b -r1.98 mlds_to_il.m
--- compiler/mlds_to_il.m 28 Jan 2002 05:30:25 -0000 1.98
+++ compiler/mlds_to_il.m 29 Jan 2002 11:55:22 -0000
@@ -3226,7 +3226,7 @@
(
Name = "array", Arity = 1
)
- ; LibModuleName0 = "std_util",
+ ; LibModuleName0 = "type_desc",
(
Name = "type_desc", Arity = 0
)
Index: compiler/modules.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.212
diff -u -b -r1.212 modules.m
--- compiler/modules.m 7 Jan 2002 07:48:06 -0000 1.212
+++ compiler/modules.m 28 Jan 2002 12:28:40 -0000
@@ -640,7 +640,9 @@
mercury_std_library_module("bt_array").
mercury_std_library_module("builtin").
mercury_std_library_module("char").
+mercury_std_library_module("construct").
mercury_std_library_module("counter").
+mercury_std_library_module("deconstruct").
mercury_std_library_module("dir").
mercury_std_library_module("enum").
mercury_std_library_module("eqvclass").
@@ -689,6 +691,7 @@
mercury_std_library_module("term_io").
mercury_std_library_module("time").
mercury_std_library_module("tree234").
+mercury_std_library_module("type_desc").
mercury_std_library_module("varset").
% It is not really clear what the naming convention
Index: compiler/static_term.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/static_term.m,v
retrieving revision 1.1
diff -u -b -r1.1 static_term.m
--- compiler/static_term.m 25 Sep 2000 04:37:15 -0000 1.1
+++ compiler/static_term.m 28 Jan 2002 14:39:11 -0000
@@ -28,10 +28,10 @@
:- implementation.
:- import_module builtin_ops.
-:- import_module list, require.
+:- import_module deconstruct, list, require.
static_term__term_to_rval(Univ, Rval, CellCounter0, CellCounter) :-
- ( std_util__get_functor_info(Univ, FunctorInfo) ->
+ ( deconstruct__get_functor_info(Univ, FunctorInfo) ->
static_term__functor_info_to_rval(FunctorInfo, Rval,
CellCounter0, CellCounter)
;
cvs diff: Diffing compiler/notes
cvs diff: Diffing debian
cvs diff: Diffing deep_profiler
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/graphics
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/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/logged_output
cvs diff: Diffing extras/moose
cvs diff: Diffing extras/moose/samples
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 java
Index: java/TypeCtorRep.java
===================================================================
RCS file: /home/mercury1/repository/mercury/java/TypeCtorRep.java,v
retrieving revision 1.2
diff -u -b -r1.2 TypeCtorRep.java
--- java/TypeCtorRep.java 28 Jan 2002 17:27:31 -0000 1.2
+++ java/TypeCtorRep.java 29 Jan 2002 10:23:17 -0000
@@ -17,7 +17,7 @@
public static final int MR_TYPECTOR_REP_NOTAG = 4;
public static final int MR_TYPECTOR_REP_NOTAG_USEREQ = 5;
public static final int MR_TYPECTOR_REP_EQUIV = 6;
- public static final int MR_TYPECTOR_REP_EQUIV_VAR = 7;
+ public static final int MR_TYPECTOR_REP_FUNC = 7;
public static final int MR_TYPECTOR_REP_INT = 8;
public static final int MR_TYPECTOR_REP_CHAR = 9;
public static final int MR_TYPECTOR_REP_FLOAT = 10;
cvs diff: Diffing library
Index: library/builtin.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/builtin.m,v
retrieving revision 1.65
diff -u -b -r1.65 builtin.m
--- library/builtin.m 20 Jan 2002 07:32:18 -0000 1.65
+++ library/builtin.m 29 Jan 2002 04:19:42 -0000
@@ -318,7 +318,7 @@
*/
MR_DEFINE_BUILTIN_TYPE_CTOR_INFO_NOCM(builtin, func, 0,
- MR_TYPECTOR_REP_PRED,
+ MR_TYPECTOR_REP_FUNC,
mercury__builtin_unify_pred_2_0,
mercury__builtin_compare_pred_3_0);
MR_DEFINE_BUILTIN_TYPE_CTOR_INFO_NOCM(builtin, pred, 0,
@@ -506,7 +506,7 @@
MR_TYPECTOR_REP_C_POINTER)
MR_DEFINE_BUILTIN_TYPE_CTOR_INFO(builtin, void, 0, MR_TYPECTOR_REP_VOID)
MR_DEFINE_BUILTIN_TYPE_CTOR_INFO(builtin, float, 0, MR_TYPECTOR_REP_FLOAT)
-MR_DEFINE_BUILTIN_TYPE_CTOR_INFO(builtin, func, 0, MR_TYPECTOR_REP_PRED)
+MR_DEFINE_BUILTIN_TYPE_CTOR_INFO(builtin, func, 0, MR_TYPECTOR_REP_FUNC)
MR_DEFINE_BUILTIN_TYPE_CTOR_INFO(builtin, pred, 0, MR_TYPECTOR_REP_PRED)
MR_DEFINE_BUILTIN_TYPE_CTOR_INFO(builtin, tuple, 0, MR_TYPECTOR_REP_TUPLE)
Index: library/construct.m
===================================================================
RCS file: library/construct.m
diff -N library/construct.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ library/construct.m 29 Jan 2002 04:19:42 -0000
@@ -0,0 +1,598 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2002 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.
+%-----------------------------------------------------------------------------%
+
+% File: construct.m.
+% Main author: zs.
+% Stability: low.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- module construct.
+
+:- interface.
+
+:- import_module std_util, list, type_desc.
+
+ % num_functors(TypeInfo)
+ %
+ % Returns the number of different functors for the top-level
+ % type constructor of the type specified by TypeInfo, or -1
+ % if the type is not a discriminated union type.
+ %
+ % The functors of a discriminated union type are numbered from
+ % zero to N-1, where N is the value returned by num_functors.
+ % The functors are numbered in lexicographic order. If two
+ % functors have the same name, the one with the lower arity
+ % will have the lower number.
+ %
+:- func num_functors(type_desc__type_desc) = int.
+
+ % get_functor(Type, FunctorNumber, FunctorName, Arity, ArgTypes)
+ %
+ % Binds FunctorName and Arity to the name and arity of functor number
+ % FunctorNumber for the specified type, and binds ArgTypes to the
+ % type_descs for the types of the arguments of that functor.
+ % 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) is semidet.
+
+ % get_functor(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
+ % for the types of the arguments of that functor, and ArgNames to the
+ % 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.
+
+ % get_functor_ordinal(Type, I, Ordinal)
+ %
+ % Returns Ordinal, where Ordinal is the position in declaration order
+ % for the specified type of the function symbol that is in position I
+ % in lexicographic order. Fails if the type is not a discriminated
+ % union type, or if I is out of range.
+:- pred get_functor_ordinal(type_desc__type_desc::in, int::in, int::out)
+ is semidet.
+
+ % construct(TypeInfo, I, Args) = Term
+ %
+ % Returns a term of the type specified by TypeInfo whose functor
+ % is functor number I of the type given by TypeInfo, and whose
+ % arguments are given by Args. Fails if the type is not a
+ % discriminated union type, or if I is out of range, or if the
+ % number of arguments supplied doesn't match the arity of the selected
+ % functor, or if the types of the arguments do not match
+ % the expected argument types of that functor.
+ %
+:- func construct(type_desc__type_desc, int, list(univ)) = univ.
+:- mode construct(in, in, in) = out is semidet.
+
+ % construct_tuple(Args) = Term
+ %
+ % Returns a tuple whose arguments are given by Args.
+:- func construct_tuple(list(univ)) = univ.
+
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- pragma foreign_decl("C", "
+
+#include ""mercury_type_desc.h""
+#include ""mercury_construct.h""
+
+").
+
+:- pragma foreign_proc("C",
+ num_functors(TypeInfo::in) = (Functors::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+ MR_save_transient_registers();
+ Functors = MR_get_num_functors((MR_TypeInfo) TypeInfo);
+ MR_restore_transient_registers();
+}").
+
+:- pragma foreign_proc("C",
+ get_functor(TypeDesc::in, FunctorNumber::in, FunctorName::out,
+ Arity::out, TypeInfoList::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+ MR_TypeInfo type_info;
+ MR_Construct_Info construct_info;
+ int arity;
+ bool success;
+
+ type_info = (MR_TypeInfo) TypeDesc;
+
+ /*
+ ** 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, &construct_info);
+ MR_restore_transient_registers();
+
+ /*
+ ** Get the functor name and arity, construct the list
+ ** of type_infos for arguments.
+ */
+
+ if (success) {
+ MR_make_aligned_string(FunctorName, (MR_String) (MR_Word)
+ construct_info.functor_name);
+ arity = construct_info.arity;
+ Arity = arity;
+
+ if (MR_TYPE_CTOR_INFO_IS_TUPLE(
+ MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info)))
+ {
+ MR_save_transient_registers();
+ TypeInfoList = MR_type_params_vector_to_list(Arity,
+ MR_TYPEINFO_GET_TUPLE_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_FIRST_ORDER_ARG_VECTOR(type_info),
+ construct_info.arg_pseudo_type_infos);
+ MR_restore_transient_registers();
+ }
+ }
+ SUCCESS_INDICATOR = success;
+}").
+
+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("MC++",
+ null(S::in),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+ SUCCESS_INDICATOR = (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.
+
+:- pragma foreign_proc("C",
+ get_functor_2(TypeDesc::in, FunctorNumber::in, FunctorName::out,
+ Arity::out, TypeInfoList::out, ArgNameList::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+ MR_TypeInfo type_info;
+ MR_Construct_Info construct_info;
+ int arity;
+ bool success;
+
+ type_info = (MR_TypeInfo) TypeDesc;
+
+ /*
+ ** 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, &construct_info);
+ MR_restore_transient_registers();
+
+ /*
+ ** Get the functor name and arity, construct the list
+ ** of type_infos for arguments.
+ */
+
+ if (success) {
+ MR_make_aligned_string(FunctorName, (MR_String) (MR_Word)
+ construct_info.functor_name);
+ arity = construct_info.arity;
+ Arity = arity;
+
+ if (MR_TYPE_CTOR_INFO_IS_TUPLE(
+ MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info)))
+ {
+ MR_save_transient_registers();
+ TypeInfoList = MR_type_params_vector_to_list(Arity,
+ MR_TYPEINFO_GET_TUPLE_ARG_VECTOR(type_info));
+ ArgNameList = MR_list_empty();
+ MR_restore_transient_registers();
+ } else {
+ MR_save_transient_registers();
+ TypeInfoList = MR_pseudo_type_info_vector_to_type_info_list(
+ arity, MR_TYPEINFO_GET_FIRST_ORDER_ARG_VECTOR(type_info),
+ construct_info.arg_pseudo_type_infos);
+ ArgNameList = MR_arg_name_vector_to_list(
+ arity, construct_info.arg_names);
+ MR_restore_transient_registers();
+ }
+ }
+ SUCCESS_INDICATOR = success;
+}").
+
+:- pragma foreign_proc("MC++",
+ get_functor_2(_TypeDesc::in, _FunctorNumber::in, _FunctorName::out,
+ _Arity::out, _TypeInfoList::out, _ArgNameList::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+ mercury::runtime::Errors::SORRY(""foreign code for get_functor_2"");
+ SUCCESS_INDICATOR = FALSE;
+").
+
+:- pragma foreign_proc("C",
+ get_functor_ordinal(TypeDesc::in, FunctorNumber::in, Ordinal::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+ MR_TypeInfo type_info;
+ MR_Construct_Info construct_info;
+ bool success;
+
+ type_info = (MR_TypeInfo) TypeDesc;
+
+ /*
+ ** 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,
+ &construct_info);
+ MR_restore_transient_registers();
+
+ if (success) {
+ switch (construct_info.type_ctor_rep) {
+
+ case MR_TYPECTOR_REP_ENUM:
+ case MR_TYPECTOR_REP_ENUM_USEREQ:
+ Ordinal = construct_info.functor_info.
+ enum_functor_desc->MR_enum_functor_ordinal;
+ break;
+
+ case MR_TYPECTOR_REP_NOTAG:
+ case MR_TYPECTOR_REP_NOTAG_USEREQ:
+ case MR_TYPECTOR_REP_NOTAG_GROUND:
+ case MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ:
+ case MR_TYPECTOR_REP_TUPLE:
+ Ordinal = 0;
+ break;
+
+ case MR_TYPECTOR_REP_DU:
+ case MR_TYPECTOR_REP_DU_USEREQ:
+ case MR_TYPECTOR_REP_RESERVED_ADDR:
+ case MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ:
+ Ordinal = construct_info.functor_info.
+ du_functor_desc->MR_du_functor_ordinal;
+ break;
+
+ default:
+ success = FALSE;
+
+ }
+ }
+ SUCCESS_INDICATOR = success;
+}").
+
+:- pragma foreign_proc("C",
+ construct(TypeDesc::in, FunctorNumber::in, ArgList::in) = (Term::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+ MR_TypeInfo type_info;
+ MR_TypeCtorInfo type_ctor_info;
+ MR_Word new_data;
+ MR_Construct_Info construct_info;
+ bool success;
+
+ type_info = (MR_TypeInfo) TypeDesc;
+
+ /*
+ ** Check range of FunctorNum, get info for this
+ ** functor.
+ */
+ MR_save_transient_registers();
+ success =
+ MR_get_functors_check_range(FunctorNumber, type_info, &construct_info)
+ && MR_typecheck_arguments(type_info, construct_info.arity, ArgList,
+ construct_info.arg_pseudo_type_infos);
+ MR_restore_transient_registers();
+
+ /*
+ ** Build the new term in `new_data'.
+ */
+ if (success) {
+
+ type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
+
+ if (MR_type_ctor_rep(type_ctor_info) != construct_info.type_ctor_rep) {
+ MR_fatal_error(""construct:construct: type_ctor_rep mismatch"");
+ }
+
+ switch (MR_type_ctor_rep(type_ctor_info)) {
+
+ case MR_TYPECTOR_REP_ENUM:
+ case MR_TYPECTOR_REP_ENUM_USEREQ:
+ new_data = construct_info.functor_info.enum_functor_desc->
+ MR_enum_functor_ordinal;
+ break;
+
+ case MR_TYPECTOR_REP_NOTAG:
+ case MR_TYPECTOR_REP_NOTAG_USEREQ:
+ case MR_TYPECTOR_REP_NOTAG_GROUND:
+ case MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ:
+ if (MR_list_is_empty(ArgList)) {
+ MR_fatal_error(""notag arg list is empty"");
+ }
+
+ if (! MR_list_is_empty(MR_list_tail(ArgList))) {
+ MR_fatal_error(""notag arg list is too long"");
+ }
+
+ new_data = MR_field(MR_UNIV_TAG, MR_list_head(ArgList),
+ MR_UNIV_OFFSET_FOR_DATA);
+ break;
+
+ case MR_TYPECTOR_REP_RESERVED_ADDR:
+ case MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ:
+ /*
+ ** First check whether the functor we want is one of the
+ ** reserved addresses.
+ */
+ {
+ int i;
+ MR_ReservedAddrTypeLayout ra_layout;
+ int total_reserved_addrs;
+ const MR_ReservedAddrFunctorDesc *functor_desc;
+
+ ra_layout = MR_type_ctor_layout(type_ctor_info).layout_reserved_addr;
+ total_reserved_addrs = ra_layout->MR_ra_num_res_numeric_addrs
+ + ra_layout->MR_ra_num_res_symbolic_addrs;
+
+ for (i = 0; i < total_reserved_addrs; i++) {
+ functor_desc = ra_layout->MR_ra_constants[i];
+ if (functor_desc->MR_ra_functor_ordinal == FunctorNumber)
+ {
+ new_data = (MR_Word)
+ functor_desc->MR_ra_functor_reserved_addr;
+
+ /* `break' here would just exit the `for' loop */
+ goto end_of_main_switch;
+ }
+ }
+ }
+
+ /*
+ ** Otherwise, it is not one of the reserved addresses,
+ ** so handle it like a normal DU type.
+ */
+
+ /* fall through */
+
+ case MR_TYPECTOR_REP_DU:
+ case MR_TYPECTOR_REP_DU_USEREQ:
+ {
+ const MR_DuFunctorDesc *functor_desc;
+ MR_Word arg_list;
+ MR_Word ptag;
+ MR_Word arity;
+ int i;
+
+ functor_desc = construct_info.functor_info.du_functor_desc;
+ if (functor_desc->MR_du_functor_exist_info != NULL) {
+ MR_fatal_error(""not yet implemented: construction ""
+ ""of terms containing existentially types"");
+ }
+
+ arg_list = ArgList;
+ ptag = functor_desc->MR_du_functor_primary;
+ switch (functor_desc->MR_du_functor_sectag_locn) {
+ case MR_SECTAG_LOCAL:
+ new_data = (MR_Word) MR_mkword(ptag,
+ MR_mkbody((MR_Word)
+ functor_desc->MR_du_functor_secondary));
+ break;
+
+ case MR_SECTAG_REMOTE:
+ arity = functor_desc->MR_du_functor_orig_arity;
+
+ MR_tag_incr_hp_msg(new_data, ptag, arity + 1,
+ MR_PROC_LABEL, ""<created by construct:construct/3>"");
+
+ MR_field(ptag, new_data, 0) =
+ functor_desc->MR_du_functor_secondary;
+ for (i = 0; i < arity; i++) {
+ MR_field(ptag, new_data, i + 1) =
+ MR_field(MR_UNIV_TAG,
+ MR_list_head(arg_list),
+ MR_UNIV_OFFSET_FOR_DATA);
+ arg_list = MR_list_tail(arg_list);
+ }
+
+ break;
+
+ case MR_SECTAG_NONE:
+ arity = functor_desc->MR_du_functor_orig_arity;
+
+ MR_tag_incr_hp_msg(new_data, ptag, arity,
+ MR_PROC_LABEL, ""<created by construct:construct/3>"");
+
+ for (i = 0; i < arity; i++) {
+ MR_field(ptag, new_data, i) =
+ MR_field(MR_UNIV_TAG,
+ MR_list_head(arg_list),
+ MR_UNIV_OFFSET_FOR_DATA);
+ arg_list = MR_list_tail(arg_list);
+ }
+
+ break;
+ case MR_SECTAG_VARIABLE:
+ MR_fatal_error(""construct(): cannot construct variable"");
+ }
+
+ if (! MR_list_is_empty(arg_list)) {
+ MR_fatal_error(""excess arguments in construct:construct"");
+ }
+ }
+ break;
+
+ case MR_TYPECTOR_REP_TUPLE:
+ {
+ int arity, i;
+ MR_Word arg_list;
+
+ arity = MR_TYPEINFO_GET_TUPLE_ARITY(type_info);
+
+ if (arity == 0) {
+ new_data = (MR_Word) NULL;
+ } else {
+ MR_incr_hp_msg(new_data, arity, MR_PROC_LABEL,
+ ""<created by construct:construct/3>"");
+
+ arg_list = ArgList;
+ for (i = 0; i < arity; i++) {
+ MR_field(MR_mktag(0), new_data, i) =
+ MR_field(MR_UNIV_TAG, MR_list_head(arg_list),
+ MR_UNIV_OFFSET_FOR_DATA);
+ arg_list = MR_list_tail(arg_list);
+ }
+
+ if (! MR_list_is_empty(arg_list)) {
+ MR_fatal_error(
+ ""excess arguments in construct:construct"");
+ }
+ }
+ }
+ break;
+
+ default:
+ MR_fatal_error(""bad type_ctor_rep in construct:construct"");
+ }
+
+ end_of_main_switch:
+
+ /*
+ ** Create a univ.
+ */
+
+ MR_new_univ_on_hp(Term, type_info, new_data);
+ }
+
+ SUCCESS_INDICATOR = success;
+}").
+
+:- pragma foreign_proc("C#",
+ num_functors(_TypeInfo::in) = (Functors::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+ mercury.runtime.Errors.SORRY(""foreign code for num_functors"");
+ // XXX keep the C# compiler quiet
+ Functors = 0;
+}").
+
+:- pragma foreign_proc("MC++",
+ get_functor(_TypeDesc::in, _FunctorNumber::in, _FunctorName::out,
+ _Arity::out, _TypeInfoList::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+ mercury::runtime::Errors::SORRY(""foreign code for get_functor"");
+").
+
+:- pragma foreign_proc("MC++",
+ get_functor_ordinal(_TypeDesc::in, _FunctorNumber::in, _Ordinal::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+ mercury::runtime::Errors::SORRY(""foreign code for get_functor_ordinal"");
+").
+
+:- pragma foreign_proc("C#",
+ construct(_TypeDesc::in, _FunctorNumber::in, _ArgList::in)
+ = (_Term::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+ mercury.runtime.Errors.SORRY(""foreign code for construct"");
+ _Term = null;
+ // XXX this is required to keep the C# compiler quiet
+ SUCCESS_INDICATOR = false;
+}").
+
+construct_tuple(Args) =
+ construct_tuple_2(Args,
+ list__map(univ_type, Args),
+ list__length(Args)).
+
+:- func construct_tuple_2(list(univ), list(type_desc__type_desc), int) = univ.
+
+:- pragma foreign_proc("C",
+ construct_tuple_2(Args::in, ArgTypes::in, Arity::in) = (Term::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+ MR_TypeInfo type_info;
+ MR_Word new_data;
+ MR_Word arg_value;
+ int i;
+
+ /*
+ ** Construct a type_info for the tuple.
+ */
+ MR_save_transient_registers();
+ type_info = MR_make_type(Arity, MR_TYPECTOR_DESC_MAKE_TUPLE(Arity),
+ ArgTypes);
+ MR_restore_transient_registers();
+
+ /*
+ ** Create the tuple.
+ */
+ if (Arity == 0) {
+ new_data = (MR_Word) NULL;
+ } else {
+ MR_incr_hp_msg(new_data, Arity, MR_PROC_LABEL,
+ ""<created by construct:construct_tuple/1>"");
+ for (i = 0; i < Arity; i++) {
+ arg_value = MR_field(MR_UNIV_TAG,
+ MR_list_head(Args),
+ MR_UNIV_OFFSET_FOR_DATA);
+ MR_field(MR_mktag(0), new_data, i) = arg_value;
+ Args = MR_list_tail(Args);
+ }
+ }
+
+ /*
+ ** Create a univ.
+ */
+ MR_new_univ_on_hp(Term, type_info, new_data);
+}").
+
+:- pragma foreign_proc("C#",
+ construct_tuple_2(_Args::in, _ArgTypes::in, _Arity::in) = (_Term::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+ mercury.runtime.Errors.SORRY(""construct_tuple_2"");
+ _Term = null;
+}").
Index: library/deconstruct.m
===================================================================
RCS file: library/deconstruct.m
diff -N library/deconstruct.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ library/deconstruct.m 29 Jan 2002 04:19:42 -0000
@@ -0,0 +1,869 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2002 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.
+%-----------------------------------------------------------------------------%
+
+% File: deconstruct.m.
+% Main author: zs.
+% Stability: low.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- module deconstruct.
+
+:- interface.
+
+:- import_module std_util, list.
+
+ % functor, argument and deconstruct and their variants take any type
+ % (including univ), and return representation information for that type.
+ %
+ % The string representation of the functor that these predicates
+ % return is:
+ %
+ % - for user defined types, the functor that is given
+ % in the type definition. For lists, this
+ % means the functors [|]/2 and []/0 are used, even if
+ % the list uses the [....] shorthand.
+ % - for integers, the string is a base 10 number,
+ % positive integers have no sign.
+ % - for floats, the string is a floating point,
+ % base 10 number, positive floating point numbers have
+ % no sign.
+ % - for strings, the string, inside double quotation marks
+ % - for characters, the character inside single quotation marks
+ % - for predicates and functions, the string <<predicate>>
+ % - for tuples, the string {}
+ % - for arrays, the string <<array>>
+ %
+ % The arity that these predicates return is:
+ %
+ % - for user defined types, the arity of the functor.
+ % - for integers, zero.
+ % - for floats, zero.
+ % - for strings, zero.
+ % - for characters, zero.
+ % - for predicates and functions, zero; we do not return the
+ % number of arguments expected by the predicate or function.
+ % - for tuples, the number of elements in the tuple.
+ % - for arrays, the number of elements in the array.
+
+ % functor(Data, Functor, Arity)
+ %
+ % Given a data item (Data), binds Functor to a string
+ % representation of the functor and Arity to the arity of this
+ % data item. (Aborts if the type of Data is a type with a
+ % non-canonical representation, i.e. one for which there is a
+ % user-defined equality predicate.)
+ %
+ % Functor_cc succeeds even if the first argument is of a
+ % non-canonical type.
+ %
+:- pred functor(T::in, string::out, int::out) is det.
+:- pred functor_cc(T::in, string::out, int::out) is cc_multi.
+
+ % arg(Data, ArgumentIndex) = Argument
+ % argument(Data, ArgumentIndex) = ArgumentUniv
+ %
+ % Given a data item (Data) and an argument index
+ % (ArgumentIndex), starting at 0 for the first argument, binds
+ % Argument to that argument of the functor of the data item. If
+ % the argument index is out of range -- that is, greater than or
+ % equal to the arity of the functor or lower than 0 -- then
+ % the call fails. For argument/2 the argument returned has the
+ % type univ, which can store any type. For arg/2, if the
+ % argument has the wrong type, then the call fails.
+ % (Both abort if the type of Data is a type with a non-canonical
+ % representation, i.e. one for which there is a user-defined
+ % equality predicate.)
+ %
+ % arg_cc and argument_cc succeed even if the first argument is
+ % of a non-canonical type.
+ %
+:- func arg(T::in, int::in) = (ArgT::out) is semidet.
+:- pred arg_cc(T::in, int::in, ArgT::out) is cc_nondet.
+:- func argument(T::in, int::in) = (univ::out) is semidet.
+:- pred argument_cc(T::in, int::in, univ::out) is cc_nondet.
+
+ % named_argument(Data, ArgumentName) = ArgumentUniv
+ %
+ % Same as argument/2, except the chosen argument is specified by giving
+ % its name rather than its position. If Data has no argument with that
+ % name, named_argument fails.
+ %
+ % named_argument_cc succeeds even if the first argument is
+ % of a non-canonical type.
+ %
+:- func named_argument(T::in, string::in) = (univ::out) is semidet.
+:- pred named_argument_cc(T::in, string::in, univ::out) is cc_nondet.
+
+ % det_arg(Data, ArgumentIndex) = Argument
+ % det_argument(Data, ArgumentIndex) = ArgumentUniv
+ %
+ % Same as arg/2 and argument/2 respectively, except that
+ % for cases where arg/2 or argument/2 would fail,
+ % det_arg/2 or det_argument/2 will abort.
+ %
+ % det_arg_cc and det_argument_cc succeed even if the first argument is
+ % of a non-canonical type.
+ %
+:- func det_arg(T::in, int::in) = (ArgT::out) is det.
+:- pred det_arg_cc(T::in, int::in, ArgT::out) is cc_multi.
+:- func det_argument(T::in, int::in) = (univ::out) is det.
+:- pred det_argument_cc(T::in, int::in, univ::out) is cc_multi.
+
+ % det_named_argument(Data, ArgumentName) = ArgumentUniv
+ %
+ % Same as named_argument/2, except that for cases where
+ % named_argument/2 would fail, det_named_argument/2 will abort.
+ %
+:- func det_named_argument(T::in, string::in) = (univ::out) is det.
+:- pred det_named_argument_cc(T::in, string::in, univ::out) is cc_multi.
+
+ % deconstruct(Data, Functor, Arity, Arguments)
+ %
+ % Given a data item (Data), binds Functor to a string
+ % representation of the functor, Arity to the arity of this data
+ % item, and Arguments to a list of arguments of the functor.
+ % The arguments in the list are each of type univ.
+ % (Aborts if the type of Data is a type with a non-canonical
+ % representation, i.e. one for which there is a user-defined
+ % equality predicate.)
+ %
+ % The cost of calling deconstruct depends greatly on how many arguments
+ % Data has. If Data is an array, then each element of the array is
+ % considered one of its arguments. Therefore calling deconstruct
+ % on large arrays can take a very large amount of memory and a very
+ % long time. If you call deconstruct in a situation in which you may
+ % pass it a large array, you should probably use limited_deconstruct
+ % instead.
+ %
+ % deconstruct_cc succeeds even if the first argument is
+ % of a non-canonical type.
+ %
+:- pred deconstruct(T::in, string::out, int::out, list(univ)::out) is det.
+:- pred deconstruct_cc(T::in, string::out, int::out, list(univ)::out)
+ is cc_multi.
+
+ % limited_deconstruct(Data, MaxArity, Functor, Arity, Arguments)
+ %
+ % limited_deconstruct works like deconstruct, but if the arity of T is
+ % greater than MaxArity, limited_deconstruct fails. This is useful in
+ % avoiding bad performance in cases where Data may be a large array.
+ %
+ % limited_deconstruct_cc succeeds even if the first argument is
+ % of a non-canonical type.
+ %
+:- pred limited_deconstruct(T::in, int::in, string::out,
+ int::out, list(univ)::out) is semidet.
+:- pred limited_deconstruct_cc(T::in, int::in, string::out,
+ int::out, list(univ)::out) is cc_nondet.
+
+:- implementation.
+:- interface.
+
+% The rest of the interface is for use by implementors only.
+
+:- type functor_tag_info
+ ---> functor_integer(int)
+ ; functor_float(float)
+ ; functor_string(string)
+ ; functor_enum(int)
+ ; functor_local(int, int)
+ ; functor_remote(int, int, list(univ))
+ ; functor_unshared(int, list(univ))
+ ; functor_notag(univ)
+ ; functor_equiv(univ).
+
+ % get_functor_info is a variant of deconstruct for use by the compiler,
+ % specifically prog_rep.m and static_term.m. It differs from
+ % deconstruct in two main ways. First, instead of returning the
+ % function symbol, it returns implementation information about
+ % its tag. Second, it succeeds for just the kinds of terms needed
+ % to represent procedure bodies for ordinary procedures. For the time
+ % being, these are procedures that do not involve higher order code
+ % or tabling.
+:- pred get_functor_info(univ::in, functor_tag_info::out) is semidet.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module int, require.
+
+%-----------------------------------------------------------------------------%
+
+:- pragma foreign_decl("C", "
+
+#include ""mercury_deconstruct.h""
+#include ""mercury_deconstruct_macros.h""
+
+").
+
+%-----------------------------------------------------------------------------%
+
+:- pragma foreign_proc("C",
+ functor(Term::in, Functor::out, Arity::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+#define PREDNAME ""functor/3""
+#define TYPEINFO_ARG TypeInfo_for_T
+#define TERM_ARG Term
+#define FUNCTOR_ARG Functor
+#define ARITY_ARG Arity
+#include ""mercury_ml_functor_body.h""
+#undef PREDNAME
+#undef TYPEINFO_ARG
+#undef TERM_ARG
+#undef FUNCTOR_ARG
+#undef ARITY_ARG
+}").
+
+:- pragma foreign_proc("C",
+ functor_cc(Term::in, Functor::out, Arity::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+#define PREDNAME ""functor_cc/3""
+#define ALLOW_NONCANONICAL
+#define TYPEINFO_ARG TypeInfo_for_T
+#define TERM_ARG Term
+#define FUNCTOR_ARG Functor
+#define ARITY_ARG Arity
+#include ""mercury_ml_functor_body.h""
+#undef PREDNAME
+#undef ALLOW_NONCANONICAL
+#undef TYPEINFO_ARG
+#undef TERM_ARG
+#undef FUNCTOR_ARG
+#undef ARITY_ARG
+}").
+
+functor_cc(_Term::in, _Functor::out, _Arity::out) :-
+ error("NYI: std_util__functor_cc/3").
+
+/*
+** N.B. any modifications to arg/2 might also require similar
+** changes to store__arg_ref in store.m.
+*/
+
+:- pragma foreign_proc("C",
+ arg(Term::in, ArgumentIndex::in) = (Argument::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+#define PREDNAME ""arg/2""
+#define NONCANON_HANDLING MR_ABORT_ON_NONCANONICAL
+#define TYPEINFO_ARG TypeInfo_for_T
+#define TERM_ARG Term
+#define SELECTOR_ARG ArgumentIndex
+#define SELECTED_ARG Argument
+#define EXPECTED_TYPE_INFO TypeInfo_for_ArgT
+#include ""mercury_ml_arg_body.h""
+#undef PREDNAME
+#undef NONCANON_HANDLING
+#undef TYPEINFO_ARG
+#undef TERM_ARG
+#undef SELECTOR_ARG
+#undef SELECTED_ARG
+#undef EXPECTED_TYPE_INFO
+}").
+
+:- pragma foreign_proc("C",
+ arg_cc(Term::in, ArgumentIndex::in, Argument::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+#define PREDNAME ""arg/2""
+#define NONCANON_HANDLING MR_ALLOW_NONCANONICAL
+#define TYPEINFO_ARG TypeInfo_for_T
+#define TERM_ARG Term
+#define SELECTOR_ARG ArgumentIndex
+#define SELECTED_ARG Argument
+#define EXPECTED_TYPE_INFO TypeInfo_for_ArgT
+#include ""mercury_ml_arg_body.h""
+#undef PREDNAME
+#undef NONCANON_HANDLING
+#undef TYPEINFO_ARG
+#undef TERM_ARG
+#undef SELECTOR_ARG
+#undef SELECTED_ARG
+#undef EXPECTED_TYPE_INFO
+}").
+
+:- pragma foreign_proc("C",
+ argument(Term::in, ArgumentIndex::in) = (ArgumentUniv::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+#define PREDNAME ""argument/2""
+#define NONCANON_HANDLING MR_FAIL_ON_NONCANONICAL
+#define TYPEINFO_ARG TypeInfo_for_T
+#define TERM_ARG Term
+#define SELECTOR_ARG ArgumentIndex
+#define SELECTED_ARG ArgumentUniv
+#include ""mercury_ml_arg_body.h""
+#undef PREDNAME
+#undef NONCANON_HANDLING
+#undef TYPEINFO_ARG
+#undef TERM_ARG
+#undef SELECTOR_ARG
+#undef SELECTED_ARG
+}").
+
+:- pragma foreign_proc("C",
+ argument_cc(Term::in, ArgumentIndex::in, ArgumentUniv::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+#define PREDNAME ""argument_cc/3""
+#define NONCANON_HANDLING MR_ALLOW_NONCANONICAL
+#define TYPEINFO_ARG TypeInfo_for_T
+#define TERM_ARG Term
+#define SELECTOR_ARG ArgumentIndex
+#define SELECTED_ARG ArgumentUniv
+#include ""mercury_ml_arg_body.h""
+#undef PREDNAME
+#undef NONCANON_HANDLING
+#undef TYPEINFO_ARG
+#undef TERM_ARG
+#undef SELECTOR_ARG
+#undef SELECTED_ARG
+}").
+
+:- pragma foreign_proc("C",
+ named_argument(Term::in, ArgumentName::in) = (ArgumentUniv::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+#define PREDNAME ""named_argument/2""
+#define NONCANON_HANDLING MR_FAIL_ON_NONCANONICAL
+#define TYPEINFO_ARG TypeInfo_for_T
+#define TERM_ARG Term
+#define SELECTOR_ARG (MR_ConstString) ArgumentName
+#define SELECTED_ARG ArgumentUniv
+#define SELECT_BY_NAME
+#include ""mercury_ml_arg_body.h""
+#undef PREDNAME
+#undef NONCANON_HANDLING
+#undef TYPEINFO_ARG
+#undef TERM_ARG
+#undef SELECTOR_ARG
+#undef SELECTED_ARG
+#undef SELECT_BY_NAME
+}").
+
+:- pragma foreign_proc("C",
+ named_argument_cc(Term::in, ArgumentName::in, ArgumentUniv::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+#define PREDNAME ""named_argument_cc/3""
+#define NONCANON_HANDLING MR_ALLOW_NONCANONICAL
+#define TYPEINFO_ARG TypeInfo_for_T
+#define TERM_ARG Term
+#define SELECTOR_ARG (MR_ConstString) ArgumentName
+#define SELECTED_ARG ArgumentUniv
+#define SELECT_BY_NAME
+#include ""mercury_ml_arg_body.h""
+#undef PREDNAME
+#undef NONCANON_HANDLING
+#undef TYPEINFO_ARG
+#undef TERM_ARG
+#undef SELECTOR_ARG
+#undef SELECTED_ARG
+#undef SELECT_BY_NAME
+}").
+
+:- pragma foreign_proc("C",
+ deconstruct(Term::in, Functor::out, Arity::out, Arguments::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+#define PREDNAME ""deconstruct/4""
+#define EXPAND_INFO_TYPE MR_Expand_Functor_Args_Info
+#define EXPAND_INFO_CALL MR_expand_functor_args
+#define TYPEINFO_ARG TypeInfo_for_T
+#define TERM_ARG Term
+#define FUNCTOR_ARG Functor
+#define ARITY_ARG Arity
+#define ARGUMENTS_ARG Arguments
+#include ""mercury_ml_deconstruct_body.h""
+#undef PREDNAME
+#undef EXPAND_INFO_TYPE
+#undef EXPAND_INFO_CALL
+#undef TYPEINFO_ARG
+#undef TERM_ARG
+#undef FUNCTOR_ARG
+#undef ARITY_ARG
+#undef ARGUMENTS_ARG
+}").
+
+:- pragma foreign_proc("C",
+ deconstruct_cc(Term::in, Functor::out, Arity::out, Arguments::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+#define PREDNAME ""deconstruct_cc/4""
+#define EXPAND_INFO_TYPE MR_Expand_Functor_Args_Info
+#define EXPAND_INFO_CALL MR_expand_functor_args
+#define ALLOW_NONCANONICAL
+#define TYPEINFO_ARG TypeInfo_for_T
+#define TERM_ARG Term
+#define FUNCTOR_ARG Functor
+#define ARITY_ARG Arity
+#define ARGUMENTS_ARG Arguments
+#include ""mercury_ml_deconstruct_body.h""
+#undef PREDNAME
+#undef NONCANON_HANDLING
+#undef EXPAND_INFO_TYPE
+#undef EXPAND_INFO_CALL
+#undef ALLOW_NONCANONICAL
+#undef TYPEINFO_ARG
+#undef TERM_ARG
+#undef FUNCTOR_ARG
+#undef ARITY_ARG
+#undef ARGUMENTS_ARG
+}").
+
+deconstruct_cc(_Term::in, _Functor::out, _Arity::out, _Arguments::out) :-
+ error("NYI: std_util__deconstruct_cc/3").
+
+:- pragma foreign_proc("C",
+ limited_deconstruct(Term::in, MaxArity::in, Functor::out,
+ Arity::out, Arguments::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+#define PREDNAME ""limited_deconstruct/5""
+#define EXPAND_INFO_TYPE MR_Expand_Functor_Args_Limit_Info
+#define EXPAND_INFO_CALL MR_expand_functor_args_limit
+#define TYPEINFO_ARG TypeInfo_for_T
+#define TERM_ARG Term
+#define MAX_ARITY_ARG MaxArity
+#define FUNCTOR_ARG Functor
+#define ARITY_ARG Arity
+#define ARGUMENTS_ARG Arguments
+#include ""mercury_ml_deconstruct_body.h""
+#undef PREDNAME
+#undef EXPAND_INFO_TYPE
+#undef EXPAND_INFO_CALL
+#undef TYPEINFO_ARG
+#undef TERM_ARG
+#undef MAX_ARITY_ARG
+#undef FUNCTOR_ARG
+#undef ARITY_ARG
+#undef ARGUMENTS_ARG
+}").
+
+:- pragma foreign_proc("C",
+ limited_deconstruct_cc(Term::in, MaxArity::in, Functor::out,
+ Arity::out, Arguments::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+#define PREDNAME ""limited_deconstruct_cc/5""
+#define EXPAND_INFO_TYPE MR_Expand_Functor_Args_Limit_Info
+#define EXPAND_INFO_CALL MR_expand_functor_args_limit
+#define ALLOW_NONCANONICAL
+#define TYPEINFO_ARG TypeInfo_for_T
+#define TERM_ARG Term
+#define MAX_ARITY_ARG MaxArity
+#define FUNCTOR_ARG Functor
+#define ARITY_ARG Arity
+#define ARGUMENTS_ARG Arguments
+#include ""mercury_ml_deconstruct_body.h""
+#undef PREDNAME
+#undef EXPAND_INFO_TYPE
+#undef EXPAND_INFO_CALL
+#undef ALLOW_NONCANONICAL
+#undef TYPEINFO_ARG
+#undef TERM_ARG
+#undef MAX_ARITY_ARG
+#undef FUNCTOR_ARG
+#undef ARITY_ARG
+#undef ARGUMENTS_ARG
+}").
+
+limited_deconstruct_cc(_Term::in, _MaxArity::in, _Functor::out, _Arity::out,
+ _Arguments::out) :-
+ error("NYI: std_util__limited_deconstruct_cc/3").
+
+:- pragma foreign_proc("MC++",
+ functor(_Term::in, _Functor::out, _Arity::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+ mercury::runtime::Errors::SORRY(""foreign code for functor"");
+").
+
+:- pragma foreign_proc("C#",
+ arg(_Term::in, _ArgumentIndex::in) = (_Argument::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+ mercury.runtime.Errors.SORRY(""foreign code for arg"");
+ // XXX this is required to keep the C# compiler quiet
+ SUCCESS_INDICATOR = false;
+}").
+
+:- pragma foreign_proc("C#",
+ arg_cc(_Term::in, _ArgumentIndex::in, _Argument::out),
+ [will_not_call_mercury, thread_safe],
+"{
+ mercury.runtime.Errors.SORRY(""foreign code for arg_cc"");
+ // XXX this is required to keep the C# compiler quiet
+ SUCCESS_INDICATOR = false;
+}").
+
+:- pragma foreign_proc("C#",
+ argument(_Term::in, _ArgumentIndex::in) = (_ArgumentUniv::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+ mercury.runtime.Errors.SORRY(""foreign code for argument"");
+ // XXX this is required to keep the C# compiler quiet
+ SUCCESS_INDICATOR = false;
+}").
+
+:- pragma foreign_proc("C#",
+ argument_cc(_Term::in, _ArgumentIndex::in, _ArgumentUniv::out),
+ [will_not_call_mercury, thread_safe],
+"{
+ mercury.runtime.Errors.SORRY(""foreign code for argument_cc"");
+ // XXX this is required to keep the C# compiler quiet
+ SUCCESS_INDICATOR = false;
+}").
+
+:- pragma foreign_proc("C#",
+ named_argument(_Term::in, _ArgumentName::in) = (_ArgumentUniv::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+ mercury.runtime.Errors.SORRY(""foreign code for named_argument"");
+ // XXX this is required to keep the C# compiler quiet
+ SUCCESS_INDICATOR = false;
+}").
+
+:- pragma foreign_proc("C#",
+ named_argument_cc(_Term::in, _ArgumentName::in, _ArgumentUniv::out),
+ [will_not_call_mercury, thread_safe],
+"{
+ mercury.runtime.Errors.SORRY(""foreign code for named_argument_cc"");
+ // XXX this is required to keep the C# compiler quiet
+ SUCCESS_INDICATOR = false;
+}").
+
+det_arg(Type, ArgumentIndex) = Argument :-
+ ( deconstruct__arg(Type, ArgumentIndex) = Argument0 ->
+ Argument = Argument0
+ ;
+ ( deconstruct__argument(Type, ArgumentIndex) = _ArgumentUniv ->
+ error("det_arg: argument had wrong type")
+ ;
+ error("det_arg: argument number out of range")
+ )
+ ).
+
+det_arg_cc(Type, ArgumentIndex, Argument) :-
+ ( deconstruct__arg_cc(Type, ArgumentIndex, Argument0) ->
+ Argument = Argument0
+ ;
+ ( deconstruct__argument_cc(Type, ArgumentIndex, _ArgumentUniv) ->
+ error("det_arg_cc: argument had wrong type")
+ ;
+ error("det_arg_cc: argument number out of range")
+ )
+ ).
+
+det_argument(Type, ArgumentIndex) = Argument :-
+ ( deconstruct__argument(Type, ArgumentIndex) = Argument0 ->
+ Argument = Argument0
+ ;
+ error("det_argument: argument out of range")
+ ).
+
+det_argument_cc(Type, ArgumentIndex, Argument) :-
+ ( deconstruct__argument_cc(Type, ArgumentIndex, Argument0) ->
+ Argument = Argument0
+ ;
+ error("det_argument_cc: argument out of range")
+ ).
+
+det_named_argument(Type, ArgumentName) = Argument :-
+ ( deconstruct__named_argument(Type, ArgumentName) = Argument0 ->
+ Argument = Argument0
+ ;
+ error("det_named_argument: no argument with that name")
+ ).
+
+det_named_argument_cc(Type, ArgumentName, Argument) :-
+ ( deconstruct__named_argument_cc(Type, ArgumentName, Argument0) ->
+ Argument = Argument0
+ ;
+ error("det_named_argument_cc: no argument with that name")
+ ).
+
+deconstruct(Term::in, Functor::out, Arity::out, Arguments::out) :-
+ rtti_implementation__deconstruct(Term, Functor, Arity, Arguments).
+
+:- pragma foreign_proc("MC++",
+ limited_deconstruct(_Term::in, _MaxArity::in, _Functor::out,
+ _Arity::out, _Arguments::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+ mercury::runtime::Errors::SORRY(""foreign code for limited_deconstruct"");
+ SUCCESS_INDICATOR = FALSE;
+}").
+
+get_functor_info(Univ, FunctorInfo) :-
+ ( univ_to_type(Univ, Int) ->
+ FunctorInfo = functor_integer(Int)
+ ; univ_to_type(Univ, Float) ->
+ FunctorInfo = functor_float(Float)
+ ; univ_to_type(Univ, String) ->
+ FunctorInfo = functor_string(String)
+ ; get_enum_functor_info(Univ, Enum) ->
+ FunctorInfo = functor_enum(Enum)
+ %
+ % XXX we should handle reserved_addr types here
+ %
+ ; get_du_functor_info(Univ, Where, Ptag, Sectag, Args) ->
+ ( Where = 0 ->
+ FunctorInfo = functor_unshared(Ptag, Args)
+ ; Where > 0 ->
+ FunctorInfo = functor_remote(Ptag, Sectag, Args)
+ ;
+ FunctorInfo = functor_local(Ptag, Sectag)
+ )
+ ; get_notag_functor_info(Univ, ExpUniv) ->
+ FunctorInfo = functor_notag(ExpUniv)
+ ; get_equiv_functor_info(Univ, ExpUniv) ->
+ FunctorInfo = functor_equiv(ExpUniv)
+ ;
+ fail
+ ).
+
+ % Given a value of an arbitrary type, succeed if its type is defined
+ % as a notag type, and return a univ which bundles up the value
+ % with the type of the single function symbol of the notag type.
+:- pred get_notag_functor_info(univ::in, univ::out) is semidet.
+
+:- pragma foreign_proc("C",
+ get_notag_functor_info(Univ::in, ExpUniv::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+ MR_TypeInfo type_info;
+ MR_TypeInfo exp_type_info;
+ MR_TypeCtorInfo type_ctor_info;
+ MR_NotagFunctorDesc *functor_desc;
+ MR_Word value;
+
+ MR_unravel_univ(Univ, type_info, value);
+ type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
+ switch (MR_type_ctor_rep(type_ctor_info)) {
+ case MR_TYPECTOR_REP_NOTAG:
+ case MR_TYPECTOR_REP_NOTAG_USEREQ:
+ functor_desc = MR_type_ctor_functors(type_ctor_info).functors_notag;
+ exp_type_info = MR_pseudo_type_info_is_ground(
+ functor_desc->MR_notag_functor_arg_type);
+ MR_new_univ_on_hp(ExpUniv, exp_type_info, value);
+ SUCCESS_INDICATOR = TRUE;
+ break;
+
+ case MR_TYPECTOR_REP_NOTAG_GROUND:
+ case MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ:
+ functor_desc = MR_type_ctor_functors(type_ctor_info).functors_notag;
+ exp_type_info = MR_create_type_info(
+ MR_TYPEINFO_GET_FIRST_ORDER_ARG_VECTOR(type_info),
+ functor_desc->MR_notag_functor_arg_type);
+ MR_new_univ_on_hp(ExpUniv, exp_type_info, value);
+ SUCCESS_INDICATOR = TRUE;
+ break;
+
+ default:
+ SUCCESS_INDICATOR = FALSE;
+ break;
+ }
+}").
+
+:- pragma foreign_proc("MC++",
+ get_notag_functor_info(_Univ::in, _ExpUniv::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+ mercury::runtime::Errors::SORRY(""foreign code for get_notag_functor_info"");
+").
+
+ % Given a value of an arbitrary type, succeed if its type is defined
+ % as an equivalence type, and return a univ which bundles up the value
+ % with the equivalent type. (I.e. this removes one layer of equivalence
+ % from the type stored in the univ.)
+:- pred get_equiv_functor_info(univ::in, univ::out) is semidet.
+
+:- pragma foreign_proc("C",
+ get_equiv_functor_info(Univ::in, ExpUniv::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+ MR_TypeInfo type_info;
+ MR_TypeInfo exp_type_info;
+ MR_TypeCtorInfo type_ctor_info;
+ MR_Word value;
+
+ MR_unravel_univ(Univ, type_info, value);
+ type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
+ switch (MR_type_ctor_rep(type_ctor_info)) {
+ case MR_TYPECTOR_REP_EQUIV:
+ exp_type_info = MR_pseudo_type_info_is_ground(
+ MR_type_ctor_layout(type_ctor_info).layout_equiv);
+ MR_new_univ_on_hp(ExpUniv, exp_type_info, value);
+ SUCCESS_INDICATOR = TRUE;
+ break;
+
+ case MR_TYPECTOR_REP_EQUIV_GROUND:
+ exp_type_info = MR_create_type_info(
+ MR_TYPEINFO_GET_FIRST_ORDER_ARG_VECTOR(type_info),
+ MR_type_ctor_layout(type_ctor_info).layout_equiv);
+ MR_new_univ_on_hp(ExpUniv, exp_type_info, value);
+ SUCCESS_INDICATOR = TRUE;
+ break;
+
+ default:
+ SUCCESS_INDICATOR = FALSE;
+ break;
+ }
+}").
+
+:- pragma foreign_proc("MC++",
+ get_equiv_functor_info(_Univ::in, _ExpUniv::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+ mercury::runtime::Errors::SORRY(""foreign code for get_equiv_functor_info"");
+").
+
+ % Given a value of an arbitrary type, succeed if it is an enum type,
+ % and return the integer value corresponding to the value.
+:- pred get_enum_functor_info(univ::in, int::out) is semidet.
+
+:- pragma foreign_proc("C",
+ get_enum_functor_info(Univ::in, Enum::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+ MR_TypeInfo type_info;
+ MR_TypeCtorInfo type_ctor_info;
+ MR_Word value;
+
+ MR_unravel_univ(Univ, type_info, value);
+ type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
+ switch (MR_type_ctor_rep(type_ctor_info)) {
+ case MR_TYPECTOR_REP_ENUM:
+ case MR_TYPECTOR_REP_ENUM_USEREQ:
+ Enum = (MR_Integer) value;
+ SUCCESS_INDICATOR = TRUE;
+ break;
+
+ default:
+ SUCCESS_INDICATOR = FALSE;
+ break;
+ }
+}").
+
+:- pragma foreign_proc("MC++",
+ get_enum_functor_info(_Univ::in, _Enum::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+ mercury::runtime::Errors::SORRY(""foreign code for get_enum_functor_info"");
+}").
+
+ % Given a value of an arbitrary type, succeed if it is a general du type
+ % (i.e. non-enum, non-notag du type), and return the top function symbol's
+ % arguments as well as its tag information: an indication of where the
+ % secondary tag is (-1 for local secondary tag, 0 for nonexistent secondary
+ % tag, and 1 for remote secondary tag), as well as the primary and
+ % secondary tags themselves (the secondary tag argument will be meaningful
+ % only if the secondary tag exists, of course).
+:- pred get_du_functor_info(univ::in, int::out, int::out, int::out,
+ list(univ)::out) is semidet.
+
+:- pragma foreign_proc("C",
+ get_du_functor_info(Univ::in, Where::out, Ptag::out, Sectag::out,
+ Args::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+ MR_TypeInfo type_info;
+ MR_TypeCtorInfo type_ctor_info;
+ const MR_DuPtagLayout *ptag_layout;
+ const MR_DuFunctorDesc *functor_desc;
+ MR_Word value;
+ MR_Word *arg_vector;
+ int i;
+
+ MR_unravel_univ(Univ, type_info, value);
+ type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
+ switch (MR_type_ctor_rep(type_ctor_info)) {
+ case MR_TYPECTOR_REP_DU:
+ case MR_TYPECTOR_REP_DU_USEREQ:
+ SUCCESS_INDICATOR = TRUE;
+ Ptag = MR_tag(value);
+ ptag_layout = &MR_type_ctor_layout(type_ctor_info).layout_du[Ptag];
+
+ switch(ptag_layout->MR_sectag_locn) {
+ case MR_SECTAG_LOCAL:
+ Where = -1;
+ Sectag = MR_unmkbody(value);
+ Args = MR_list_empty();
+ break;
+
+ case MR_SECTAG_REMOTE:
+ case MR_SECTAG_NONE:
+ if (ptag_layout->MR_sectag_locn == MR_SECTAG_NONE) {
+ Where = 0;
+ arg_vector = (MR_Word *) MR_body(value, Ptag);
+ Sectag = 0;
+ } else {
+ Where = 1;
+ arg_vector = (MR_Word *) MR_body(value, Ptag);
+ Sectag = arg_vector[0];
+ arg_vector++;
+ }
+
+ functor_desc = ptag_layout->MR_sectag_alternatives[Sectag];
+ if (functor_desc->MR_du_functor_exist_info != NULL) {
+ SUCCESS_INDICATOR = FALSE;
+ break;
+ }
+
+ Args = MR_list_empty_msg(MR_PROC_LABEL);
+ for (i = functor_desc->MR_du_functor_orig_arity - 1;
+ i >= 0; i--)
+ {
+ MR_Word arg;
+ MR_TypeInfo arg_type_info;
+
+ if (MR_arg_type_may_contain_var(functor_desc, i)) {
+ arg_type_info = MR_create_type_info_maybe_existq(
+ MR_TYPEINFO_GET_FIRST_ORDER_ARG_VECTOR(
+ type_info),
+ functor_desc->MR_du_functor_arg_types[i],
+ arg_vector, functor_desc);
+ } else {
+ arg_type_info = MR_pseudo_type_info_is_ground(
+ functor_desc->MR_du_functor_arg_types[i]);
+ }
+
+ MR_new_univ_on_hp(arg,
+ arg_type_info, arg_vector[i]);
+ Args = MR_list_cons_msg(arg, Args, MR_PROC_LABEL);
+ }
+ break;
+
+ case MR_SECTAG_VARIABLE:
+ MR_fatal_error(
+ ""get_du_functor_info: unexpected variable"");
+
+ default:
+ MR_fatal_error(
+ ""get_du_functor_info: unknown sectag locn"");
+ }
+ break;
+
+ default:
+ SUCCESS_INDICATOR = FALSE;
+ break;
+ }
+}").
+
+:- pragma foreign_proc("MC++",
+ get_du_functor_info(_Univ::in, _Where::out, _Ptag::out, _Sectag::out,
+ _Args::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+ mercury::runtime::Errors::SORRY(""foreign code for get_du_functor_info"");
+").
Index: library/library.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/library.m,v
retrieving revision 1.59
diff -u -b -r1.59 library.m
--- library/library.m 20 Jan 2002 07:32:21 -0000 1.59
+++ library/library.m 29 Jan 2002 04:19:42 -0000
@@ -23,27 +23,28 @@
:- implementation.
% Note: if you add a new module to this list, you must also a new clause
-% to mercury_std_library_module/1 in compiler/modules.m.
+% to mercury_std_library_module/1 in compiler/modules.m. Conversely, this
+% should list all the modules named by mercury_std_library_module, except
+% library itself.
+%
+% Please keep both parts of this list in alphabetical order.
+% The modules intended for application programmers.
:- import_module array, assoc_list, bag, benchmarking.
-:- import_module bimap, bintree, bintree_set, bool.
-:- import_module bt_array, char, counter, dir, enum, eqvclass, float.
-:- import_module math, getopt, graph, group, int.
-:- import_module io, list, map, multi_map, pqueue, queue, random, relation.
-:- import_module require, set, set_bbbtree, set_ordlist, set_unordlist.
-:- import_module sparse_bitset, stack, std_util, string, term, term_io.
-:- import_module tree234, varset.
-:- import_module store, rbtree, parser, lexer, ops.
-:- import_module prolog.
-:- import_module integer, rational.
-:- import_module exception, gc.
-:- import_module time.
-:- import_module pprint.
-:- import_module bitmap.
-:- import_module hash_table.
+:- import_module bimap, bintree, bintree_set, bitmap, bool, bt_array.
+:- import_module char, construct, counter, deconstruct, dir.
+:- import_module enum, eqvclass, exception.
+:- import_module float, gc, getopt, graph, group, hash_table.
+:- import_module int, integer, io, lexer, list, map, math, multi_map, ops.
+:- import_module parser, pprint, pqueue, prolog, queue.
+:- import_module random, rational, rbtree, relation, require.
+:- import_module set, set_bbbtree, set_ordlist, set_unordlist, sparse_bitset.
+:- import_module stack, std_util, store, string.
+:- import_module term, term_io, tree234, time, type_desc, varset.
-:- import_module rtti_implementation.
+% The modules intended for Mercury system implementors.
:- import_module builtin, private_builtin, table_builtin, profiling_builtin.
+:- import_module rtti_implementation.
% library__version must be implemented using pragma c_code,
% so we can get at the MR_VERSION and MR_FULLARCH configuration
Index: library/private_builtin.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/private_builtin.m,v
retrieving revision 1.88
diff -u -b -r1.88 private_builtin.m
--- library/private_builtin.m 28 Jan 2002 17:27:46 -0000 1.88
+++ library/private_builtin.m 29 Jan 2002 04:19:42 -0000
@@ -550,7 +550,7 @@
static int MR_TYPECTOR_REP_NOTAG = 4;
static int MR_TYPECTOR_REP_NOTAG_USEREQ = 5;
static int MR_TYPECTOR_REP_EQUIV = 6;
-static int MR_TYPECTOR_REP_EQUIV_VAR = 7;
+static int MR_TYPECTOR_REP_FUNC = 7;
static int MR_TYPECTOR_REP_INT = 8;
static int MR_TYPECTOR_REP_CHAR = 9;
static int MR_TYPECTOR_REP_FLOAT =10;
Index: library/rtti_implementation.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/rtti_implementation.m,v
retrieving revision 1.12
diff -u -b -r1.12 rtti_implementation.m
--- library/rtti_implementation.m 28 Jan 2002 17:27:47 -0000 1.12
+++ library/rtti_implementation.m 29 Jan 2002 04:19:42 -0000
@@ -84,7 +84,7 @@
; notag
; notag_usereq
; equiv
- ; equiv_var
+ ; (func)
; int
; char
; float
@@ -150,7 +150,7 @@
->
compare_tuple(TypeInfo, Res, X, Y)
;
- TypeCtorRep = (pred)
+ ( TypeCtorRep = (pred) ; TypeCtorRep = (func) )
->
error("rtti_implementation.m: unimplemented: higher order comparisons")
;
@@ -202,7 +202,7 @@
->
unify_tuple(TypeInfo, X, Y)
;
- TypeCtorRep = (pred)
+ ( TypeCtorRep = (pred) ; TypeCtorRep = (func) )
->
error("rtti_implementation.m: unimplemented: higher order unifications")
;
@@ -466,6 +466,7 @@
:- pred type_ctor_is_variable_arity(type_ctor_info::in) is semidet.
type_ctor_is_variable_arity(TypeCtorInfo) :-
( TypeCtorInfo ^ type_ctor_rep = (pred)
+ ; TypeCtorInfo ^ type_ctor_rep = (func)
; TypeCtorInfo ^ type_ctor_rep = tuple
).
@@ -631,8 +632,8 @@
Arity = 0,
Arguments = []
;
- TypeCtorRep = equiv_var,
- Functor = "some_equiv_var",
+ TypeCtorRep = (func),
+ Functor = "some_func",
Arity = 0,
Arguments = []
;
Index: library/std_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/std_util.m,v
retrieving revision 1.259
diff -u -b -r1.259 std_util.m
--- library/std_util.m 28 Jan 2002 17:27:48 -0000 1.259
+++ library/std_util.m 29 Jan 2002 04:19:42 -0000
@@ -6,7 +6,7 @@
% File: std_util.m.
% Main author: fjh.
-% Stability: medium to high.
+% Stability: medium.
% This file is intended for all the useful standard utilities
% that don't belong elsewhere, like <stdlib.h> in C.
@@ -19,6 +19,7 @@
:- interface.
:- import_module list, set, bool.
+:- import_module type_desc.
%-----------------------------------------------------------------------------%
@@ -70,7 +71,7 @@
% univ_type(Univ):
% returns the type_desc for the type stored in `Univ'.
%
-:- func univ_type(univ) = type_desc.
+:- func univ_type(univ) = type_desc__type_desc.
% univ_value(Univ):
% returns the value of the object stored in Univ.
@@ -332,14 +333,14 @@
% A type_desc represents a type, e.g. `list(int)'.
% A type_ctor_desc represents a type constructor, e.g. `list/1'.
-:- type type_desc.
-:- type type_ctor_desc.
+:- type type_desc == type_desc__type_desc.
+:- type type_ctor_desc == type_desc__type_ctor_desc.
% Type_info and type_ctor_info are the old names for type_desc and
% type_ctor_desc. They should not be used by new software.
-:- type type_info == type_desc.
-:- type type_ctor_info == type_ctor_desc.
+:- type type_info == type_desc__type_desc.
+:- type type_ctor_info == type_desc__type_ctor_desc.
% (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
@@ -353,14 +354,14 @@
% The function type_of/1 returns a representation of the type
% of its argument.
%
-:- func type_of(T) = type_desc.
+:- func type_of(T) = type_desc__type_desc.
:- mode type_of(unused) = out is det.
% The predicate has_type/2 is basically an existentially typed
% inverse to the function type_of/1. It constrains the type
% of the first argument to be the type represented by the
% second argument.
-:- some [T] pred has_type(T::unused, type_desc::in) is det.
+:- some [T] pred has_type(T::unused, type_desc__type_desc::in) is det.
% type_name(Type) returns the name of the specified type
% (e.g. type_name(type_of([2,3])) = "list:list(int)").
@@ -368,7 +369,7 @@
% Builtin types (those defined in builtin.m) will
% not have a module qualifier.
%
-:- func type_name(type_desc) = string.
+:- func type_name(type_desc__type_desc) = string.
% type_ctor_and_args(Type, TypeCtor, TypeArgs):
% True iff `TypeCtor' is a representation of the top-level
@@ -389,44 +390,45 @@
% (If you don't want them expanded, you can use the reverse mode
% of make_type/2 instead.)
%
-:- pred type_ctor_and_args(type_desc, type_ctor_desc, list(type_desc)).
+:- pred type_ctor_and_args(type_desc__type_desc, type_desc__type_ctor_desc,
+ list(type_desc__type_desc)).
:- mode type_ctor_and_args(in, out, out) is det.
% type_ctor(Type) = TypeCtor :-
% type_ctor_and_args(Type, TypeCtor, _).
%
-:- func type_ctor(type_desc) = type_ctor_desc.
+:- func type_ctor(type_desc__type_desc) = type_desc__type_ctor_desc.
% type_args(Type) = TypeArgs :-
% type_ctor_and_args(Type, _, TypeArgs).
%
-:- func type_args(type_desc) = list(type_desc).
+:- func type_args(type_desc__type_desc) = list(type_desc__type_desc).
% type_ctor_name(TypeCtor) returns the name of specified
% type constructor.
% (e.g. type_ctor_name(type_ctor(type_of([2,3]))) = "list").
%
-:- func type_ctor_name(type_ctor_desc) = string.
+:- func type_ctor_name(type_desc__type_ctor_desc) = string.
% type_ctor_module_name(TypeCtor) returns the module name of specified
% type constructor.
% (e.g. type_ctor_module_name(type_ctor(type_of(2))) = "builtin").
%
-:- func type_ctor_module_name(type_ctor_desc) = string.
+:- func type_ctor_module_name(type_desc__type_ctor_desc) = string.
% type_ctor_arity(TypeCtor) returns the arity of specified
% type constructor.
% (e.g. type_ctor_arity(type_ctor(type_of([2,3]))) = 1).
%
-:- func type_ctor_arity(type_ctor_desc) = int.
+:- func type_ctor_arity(type_desc__type_ctor_desc) = int.
% type_ctor_name_and_arity(TypeCtor, ModuleName, TypeName, Arity) :-
% Name = type_ctor_name(TypeCtor),
% ModuleName = type_ctor_module_name(TypeCtor),
% Arity = type_ctor_arity(TypeCtor).
%
-:- pred type_ctor_name_and_arity(type_ctor_desc, string, string, int).
-:- mode type_ctor_name_and_arity(in, out, out, out) is det.
+:- pred type_ctor_name_and_arity(type_desc__type_ctor_desc::in, string::out,
+ string::out, int::out) is det.
% make_type(TypeCtor, TypeArgs) = Type:
% True iff `Type' is a type constructed by applying
@@ -442,7 +444,8 @@
% (and hence this reverse mode of make_type/2 may be more useful
% for some purposes than the type_ctor/1 function).
%
-:- func make_type(type_ctor_desc, list(type_desc)) = type_desc.
+:- func make_type(type_desc__type_ctor_desc, list(type_desc__type_desc)) =
+ type_desc__type_desc.
:- mode make_type(in, in) = out is semidet.
:- mode make_type(out, out) = in is cc_multi.
@@ -452,7 +455,8 @@
% constructor to the specified argument types. Aborts if the
% length of `TypeArgs' is not the same as the arity of `TypeCtor'.
%
-:- func det_make_type(type_ctor_desc, list(type_desc)) = type_desc.
+:- func det_make_type(type_desc__type_ctor_desc, list(type_desc__type_desc)) =
+ type_desc__type_desc.
:- mode det_make_type(in, in) = out is det.
%-----------------------------------------------------------------------------%
@@ -469,28 +473,31 @@
% functors have the same name, the one with the lower arity
% will have the lower number.
%
-:- func num_functors(type_desc) = int.
+:- func num_functors(type_desc__type_desc) = int.
- % get_functor(Type, I, Functor, Arity, ArgTypes)
+ % get_functor(Type, FunctorNumber, FunctorName, Arity, ArgTypes)
%
- % Binds Functor and Arity to the name and arity of functor number I
- % for the specified type, and binds ArgTypes to the type_descs for
- % the types of the arguments of that functor. Fails if the type
- % is not a discriminated union type, or if I is out of range.
- %
-:- pred get_functor(type_desc::in, int::in, string::out, int::out,
- list(type_desc)::out) is semidet.
-
- % get_functor(Type, I, Functor, Arity, ArgTypes, ArgNames)
- %
- % Binds Functor and Arity to the name and arity of functor number I
- % for the specified type, ArgTypes to the type_descs for the types
- % of the arguments of that functor, and ArgNames to the field name
- % of each functor argument, if any. Fails if the type is not a
- % discriminated union type, or if I is out of range.
- %
-:- pred get_functor(type_desc::in, int::in, string::out, int::out,
- list(type_desc)::out, list(maybe(string))::out) is semidet.
+ % Binds FunctorName and Arity to the name and arity of functor number
+ % FunctorNumber for the specified type, and binds ArgTypes to the
+ % type_descs for the types of the arguments of that functor.
+ % 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) is semidet.
+
+ % get_functor(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
+ % for the types of the arguments of that functor, and ArgNames to the
+ % 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.
% get_functor_ordinal(Type, I, Ordinal)
%
@@ -498,7 +505,8 @@
% for the specified type of the function symbol that is in position I
% in lexicographic order. Fails if the type is not a discriminated
% union type, or if I is out of range.
-:- pred get_functor_ordinal(type_desc::in, int::in, int::out) is semidet.
+:- pred get_functor_ordinal(type_desc__type_desc::in, int::in, int::out)
+ is semidet.
% construct(TypeInfo, I, Args) = Term
%
@@ -510,7 +518,7 @@
% functor, or if the types of the arguments do not match
% the expected argument types of that functor.
%
-:- func construct(type_desc, int, list(univ)) = univ.
+:- func construct(type_desc__type_desc, int, list(univ)) = univ.
:- mode construct(in, in, in) = out is semidet.
% construct_tuple(Args) = Term
@@ -664,32 +672,13 @@
:- pred limited_deconstruct_cc(T::in, int::in, string::out,
int::out, list(univ)::out) is cc_nondet.
+%-----------------------------------------------------------------------------%
+
:- implementation.
:- interface.
% The rest of the interface is for use by implementors only.
-:- type functor_tag_info
- ---> functor_integer(int)
- ; functor_float(float)
- ; functor_string(string)
- ; functor_enum(int)
- ; functor_local(int, int)
- ; functor_remote(int, int, list(univ))
- ; functor_unshared(int, list(univ))
- ; functor_notag(univ)
- ; functor_equiv(univ).
-
- % get_functor_info is a variant of deconstruct for use by the compiler,
- % specifically prog_rep.m and static_term.m. It differs from
- % deconstruct in two main ways. First, instead of returning the
- % function symbol, it returns implementation information about
- % its tag. Second, it succeeds for just the kinds of terms needed
- % to represent procedure bodies for ordinary procedures. For the time
- % being, these are procedures that do not involve higher order code
- % or tabling.
-:- pred get_functor_info(univ::in, functor_tag_info::out) is semidet.
-
% dynamic_cast(X, Y) succeeds with Y = X iff X has the same
% ground type as Y (so this may succeed if Y is of type
% list(int), say, but not if Y is of type list(T)).
@@ -702,6 +691,7 @@
:- implementation.
:- import_module require, set, int, string, bool.
+:- use_module construct, deconstruct.
%-----------------------------------------------------------------------------%
@@ -995,9 +985,8 @@
:- pragma foreign_proc("C",
swap_heap_and_solutions_heap,
[will_not_call_mercury, thread_safe],
-"
+"{
#ifndef CONSERVATIVE_GC
- {
MR_MemoryZone *temp_zone;
MR_Word *temp_hp;
@@ -1007,9 +996,8 @@
temp_hp = MR_hp;
MR_hp = MR_sol_hp;
MR_sol_hp = temp_hp;
- }
#endif
-").
+}").
:- pragma foreign_proc("MC++",
swap_heap_and_solutions_heap,
@@ -1334,8 +1322,8 @@
( type_to_univ(X0, Univ) ->
X = X0
;
- UnivTypeName = type_name(univ_type(Univ)),
- ObjectTypeName = type_name(type_of(X)),
+ UnivTypeName = type_desc__type_name(univ_type(Univ)),
+ ObjectTypeName = type_desc__type_name(type_desc__type_of(X)),
string__append_list(["det_univ_to_type: conversion failed\\n",
"\tUniv Type: ", UnivTypeName,
"\\n\tObject Type: ", ObjectTypeName], ErrorString),
@@ -1355,7 +1343,7 @@
Univ = univ_cons(T0),
private_builtin__typed_unify(T0, T).
-univ_type(Univ) = type_of(univ_value(Univ)).
+univ_type(Univ) = type_desc__type_of(univ_value(Univ)).
:- pred construct_univ(T, univ).
:- mode construct_univ(in, out) is det.
@@ -1371,2501 +1359,172 @@
unravel_univ(Univ, X) :-
univ_value(Univ) = X.
-:- pragma foreign_decl("C", "
-#include ""mercury_heap.h"" /* for MR_incr_hp_msg() etc. */
-#include ""mercury_misc.h"" /* for MR_fatal_error() */
-#include ""mercury_string.h"" /* for MR_make_aligned_string() */
-").
-
-:- pragma foreign_code("C", "
-
-#include ""mercury_deep_profiling_hand.h""
-
-/* Ensure that the initialization code for the above module gets run. */
-/*
-INIT sys_init_type_desc_module
-*/
-
-/* suppress gcc -Wmissing-decl warnings */
-void sys_init_type_desc_module_init(void);
-void sys_init_type_desc_module_init_type_tables(void);
-#ifdef MR_DEEP_PROFILING
-void sys_init_type_desc_module_write_out_proc_statics(FILE *);
-#endif
-
-#ifndef MR_HIGHLEVEL_CODE
-
-#ifdef MR_DEEP_PROFILING
-MR_proc_static_compiler_empty(std_util, __Unify__, type_desc, 0, 0,
- ""std_util.m"", 0, TRUE);
-MR_proc_static_compiler_empty(std_util, __Compare__, type_desc, 0, 0,
- ""std_util.m"", 0, TRUE);
-#endif
-
-MR_DEFINE_BUILTIN_TYPE_CTOR_INFO(std_util, type_desc, 0,
- MR_TYPECTOR_REP_TYPEINFO);
-
-MR_define_extern_entry(mercury____Unify___std_util__type_desc_0_0);
-MR_define_extern_entry(mercury____Compare___std_util__type_desc_0_0);
-
-MR_BEGIN_MODULE(type_desc_module)
- MR_init_entry(mercury____Unify___std_util__type_desc_0_0);
- MR_init_entry(mercury____Compare___std_util__type_desc_0_0);
-#ifdef MR_DEEP_PROFILING
- MR_init_label(mercury____Unify___std_util__type_desc_0_0_i1);
- MR_init_label(mercury____Unify___std_util__type_desc_0_0_i2);
- MR_init_label(mercury____Unify___std_util__type_desc_0_0_i3);
- MR_init_label(mercury____Unify___std_util__type_desc_0_0_i4);
- MR_init_label(mercury____Compare___std_util__type_desc_0_0_i1);
- MR_init_label(mercury____Compare___std_util__type_desc_0_0_i2);
-#endif
-MR_BEGIN_CODE
-
-#define proc_label mercury____Unify___std_util__type_desc_0_0
-#define proc_static MR_proc_static_compiler_name(std_util, __Unify__, \
- type_desc, 0, 0)
-#define body_code do { \
- int comp; \
- \
- MR_save_transient_registers(); \
- comp = MR_compare_type_info( \
- (MR_TypeInfo) MR_r1, \
- (MR_TypeInfo) MR_r2); \
- MR_restore_transient_registers(); \
- MR_r1 = (comp == MR_COMPARE_EQUAL); \
- } while (0)
-
-#include ""mercury_hand_unify_body.h""
-
-#undef body_code
-#undef proc_static
-#undef proc_label
-
-#define proc_label mercury____Compare___std_util__type_desc_0_0
-#define proc_static MR_proc_static_compiler_name(std_util, __Compare__, \
- type_desc, 0, 0)
-#define body_code do { \
- int comp; \
- \
- MR_save_transient_registers(); \
- comp = MR_compare_type_info( \
- (MR_TypeInfo) MR_r1, \
- (MR_TypeInfo) MR_r2); \
- MR_restore_transient_registers(); \
- MR_r1 = comp; \
- } while (0)
-
-#include ""mercury_hand_compare_body.h""
-
-#undef body_code
-#undef proc_static
-#undef proc_label
-
-MR_END_MODULE
-
-MR_MODULE_STATIC_OR_EXTERN MR_ModuleFunc type_desc_module;
+dynamic_cast(X, Y) :-
+ univ_to_type(univ(X), Y).
-#endif /* ! MR_HIGHLEVEL_CODE */
+%-----------------------------------------------------------------------------%
-void
-sys_init_type_desc_module_init(void)
-{
-#ifndef MR_HIGHLEVEL_CODE
- type_desc_module();
+% The actual code of these predicates and functions is now in
+% the file type_desc.m.
- MR_INIT_TYPE_CTOR_INFO(
- mercury_data_std_util__type_ctor_info_type_desc_0,
- std_util__type_desc_0_0);
-#endif
-}
+type_of(Value) =
+ type_desc__type_of(Value).
-void
-sys_init_type_desc_module_init_type_tables(void)
-{
-#ifndef MR_HIGHLEVEL_CODE
- MR_register_type_ctor_info(
- &mercury_data_std_util__type_ctor_info_type_desc_0);
-#endif
-}
+has_type(Arg, TypeInfo) :-
+ type_desc__has_type(Arg, TypeInfo).
-#ifdef MR_DEEP_PROFILING
-void
-sys_init_type_desc_module_write_out_proc_statics(FILE *fp)
-{
- MR_write_out_proc_static(fp, (MR_ProcStatic *)
- &MR_proc_static_compiler_name(std_util, __Compare__, type_desc,
- 0, 0));
- MR_write_out_proc_static(fp, (MR_ProcStatic *)
- &MR_proc_static_compiler_name(std_util, __Unify__, type_desc,
- 0, 0));
-}
-#endif
+type_name(Type) =
+ type_desc__type_name(Type).
-").
+type_args(Type) =
+ type_desc__type_args(Type).
- % We need to call the rtti_implementation module -- so that we get the
- % dependencies right it's easiest to do it from Mercury.
+type_ctor_name(TypeCtor) =
+ type_desc__type_ctor_name(TypeCtor).
-:- pragma export(call_rtti_compare_type_infos(out, in, in),
- "ML_call_rtti_compare_type_infos").
+type_ctor_module_name(TypeCtor) =
+ type_desc__type_ctor_module_name(TypeCtor).
-:- pred call_rtti_compare_type_infos(comparison_result::out,
- rtti_implementation__type_info::in, rtti_implementation__type_info::in)
- is det.
+type_ctor_arity(TypeCtor) =
+ type_desc__type_ctor_arity(TypeCtor).
-:- use_module rtti_implementation.
+det_make_type(TypeCtor, ArgTypes) =
+ type_desc__det_make_type(TypeCtor, ArgTypes).
-call_rtti_compare_type_infos(Res, T1, T2) :-
- rtti_implementation__compare_type_infos(Res, T1, T2).
+type_ctor(TypeInfo) =
+ type_desc__type_ctor(TypeInfo).
-:- pragma foreign_code("MC++", "
+type_ctor_and_args(TypeDesc, TypeCtorDesc, ArgTypes) :-
+ type_desc__type_ctor_and_args(TypeDesc, TypeCtorDesc, ArgTypes).
-MR_DEFINE_BUILTIN_TYPE_CTOR_INFO(std_util, type_desc, 0,
- MR_TYPECTOR_REP_TYPEINFO)
-
-static int MR_compare_type_info(MR_Word t1, MR_Word t2) {
- MR_Word res;
-
- mercury::std_util::mercury_code::ML_call_rtti_compare_type_infos(
- &res, t1, t2);
- return System::Convert::ToInt32(res[0]);
-}
-
-static void
-__Compare____type_desc_0_0(
- MR_Word_Ref result, MR_Word x, MR_Word y)
-{
- mercury::std_util::mercury_code::ML_call_rtti_compare_type_infos(
- result, x, y);
-}
-
-static bool
-__Unify____type_desc_0_0(MR_Word x, MR_Word y)
-{
- return (MR_compare_type_info(x, y) == MR_COMPARE_EQUAL);
-}
-
-static void
-special___Compare___type_desc_0_0(
- MR_Word_Ref result, MR_Word x, MR_Word y)
-{
- mercury::std_util::mercury_code::ML_call_rtti_compare_type_infos(
- result, x, y);
-}
-
-static bool
-special___Unify___type_desc_0_0(MR_Word x, MR_Word y)
-{
- return (MR_compare_type_info(x, y) == MR_COMPARE_EQUAL);
-}
-
-static int
-do_unify__type_desc_0_0(MR_Box x, MR_Box y)
-{
- return mercury::std_util__cpp_code::mercury_code::__Unify____type_desc_0_0(
- dynamic_cast<MR_Word>(x),
- dynamic_cast<MR_Word>(y));
-}
-
-static void
-do_compare__type_desc_0_0(
- MR_Word_Ref result, MR_Box x, MR_Box y)
-{
- mercury::std_util__cpp_code::mercury_code::__Compare____type_desc_0_0(
- result,
- dynamic_cast<MR_Word>(x),
- dynamic_cast<MR_Word>(y));
-}
+make_type(TypeCtorDesc, ArgTypes) =
+ type_desc__make_type(TypeCtorDesc, ArgTypes).
-").
+type_ctor_name_and_arity(TypeCtorDesc, TypeCtorModuleName,
+ TypeCtorName, TypeCtorArity) :-
+ type_desc__type_ctor_name_and_arity(TypeCtorDesc, TypeCtorModuleName,
+ TypeCtorName, TypeCtorArity).
%-----------------------------------------------------------------------------%
-
- % Code for type manipulation.
-
- % Prototypes and type definitions.
-
-:- pragma foreign_decl("C", "
-
-/* The `#ifndef ... #define ... #endif' guards against multiple inclusion */
-#ifndef ML_TYPECTORDESC_GUARD
-#define ML_TYPECTORDESC_GUARD
-
-/*
-** Values of type `std_util: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 `std_util: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 first order 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.
-** The maximum arity that can be encoded is given by MR_MAX_VARIABLE_ARITY
-** (see below).
-** The C type corresponding to std_util:type_ctor_desc is `MR_TypeCtorDesc'.
-*/
-
-/*
-** Declare the MR_TypeCtorDesc ADT.
-**
-** Note that `struct MR_TypeCtorDesc_Struct' is deliberately left undefined.
-** MR_TypeCtorDesc is declared as a pointer to a dummy structure only
-** in order to allow the C compiler to catch errors in which things other
-** than MR_TypeCtorDescs are given as arguments to macros that depend on their
-** arguments being MR_TypeCtorDescs. The actual value is either a small integer
-** or a pointer to a MR_TypeCtorInfo_Struct structure, as described above.
-*/
-typedef struct MR_TypeCtorDesc_Struct *MR_TypeCtorDesc;
-
-/*
-** The maximum arity that can be encoded should be set to twice the maximum
-** number of general purpose registers, since an predicate or function having
-** more arguments that this would run out of registers when passing the input
-** arguments, or the output arguments, or both.
-**
-** XXX When tuples were added this was reduced to be the maximum number
-** of general purpose registers, to reduce the probability that the
-** `small' integers for higher-order and tuple types are confused with
-** type_ctor_info pointers. This still allows higher-order terms with
-** 1024 arguments, which is more than ../LIMITATIONS promises.
-*/
-#define MR_MAX_VARIABLE_ARITY MR_MAX_VIRTUAL_REG
-
-/*
-** Constructors for the MR_TypeCtorDesc ADT
-*/
-
-#define MR_TYPECTOR_DESC_MAKE_PRED(Arity) \
- ( (MR_TypeCtorDesc) ((Arity) * 4) )
-#define MR_TYPECTOR_DESC_MAKE_FUNC(Arity) \
- ( (MR_TypeCtorDesc) ((Arity) * 4 + 1) )
-#define MR_TYPECTOR_DESC_MAKE_TUPLE(Arity) \
- ( (MR_TypeCtorDesc) ((Arity) * 4 + 2) )
-#define MR_TYPECTOR_DESC_MAKE_FIXED_ARITY(type_ctor_info) \
- ( MR_CHECK_EXPR_TYPE(type_ctor_info, MR_TypeCtorInfo), \
- (MR_TypeCtorDesc) type_ctor_info )
-
-/*
-** Access macros for the MR_TypeCtor ADT.
-**
-** The MR_TYPECTOR_DESC_GET_VA_* macros should only be called if
-** MR_TYPECTOR_DESC_IS_VARIABLE_ARITY() returns true.
-** The MR_TYPECTOR_DESC_GET_FIXED_ARITY_TYPE_CTOR_INFO() macro
-** should only be called if MR_TYPECTOR_DESC_IS_VARIABLE_ARITY() returns false.
-*/
-#define MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(T) \
- ( MR_CHECK_EXPR_TYPE(T, MR_TypeCtorDesc), \
- (MR_Unsigned) (T) <= (4 * MR_MAX_VARIABLE_ARITY + 2) )
-#define MR_TYPECTOR_DESC_GET_FIXED_ARITY_TYPE_CTOR_INFO(T) \
- ( MR_CHECK_EXPR_TYPE(T, MR_TypeCtorDesc), \
- (MR_TypeCtorInfo) (T) )
-#define MR_TYPECTOR_DESC_GET_VA_ARITY(T) \
- ( MR_CHECK_EXPR_TYPE(T, MR_TypeCtorDesc), \
- (MR_Unsigned) (T) / 4 )
-#define MR_TYPECTOR_DESC_GET_VA_NAME(T) \
- ( MR_CHECK_EXPR_TYPE(T, MR_TypeCtorDesc), \
- (MR_ConstString) (((MR_Unsigned) (T) % 4 == 0) \
- ? ""pred"" \
- : (((MR_Unsigned) (T) % 4 == 1) \
- ? ""func"" \
- : ""{}"" )) )
-#define MR_TYPECTOR_DESC_GET_VA_MODULE_NAME(T) \
- ( MR_CHECK_EXPR_TYPE(T, MR_TypeCtorDesc), \
- (MR_ConstString) ""builtin"" )
-#define MR_TYPECTOR_DESC_GET_VA_TYPE_CTOR_INFO(T) \
- ( MR_CHECK_EXPR_TYPE(T, MR_TypeCtorDesc), \
- ((MR_Unsigned) (T) % 4 == 0) \
- ? MR_TYPE_CTOR_INFO_HO_PRED \
- : (((MR_Unsigned) (T) % 4 == 1) \
- ? MR_TYPE_CTOR_INFO_HO_FUNC \
- : MR_TYPE_CTOR_INFO_TUPLE ) )
-
-#endif /* ML_TYPECTORDESC_GUARD */
-
-").
-
%-----------------------------------------------------------------------------%
-:- pragma foreign_decl("C", "
-
-/* The `#ifndef ... #define ... #endif' guards against multiple inclusion */
-#ifndef ML_CONSTRUCT_INFO_GUARD
-#define ML_CONSTRUCT_INFO_GUARD
-
-typedef struct ML_Construct_Info_Struct {
- MR_ConstString functor_name;
- MR_Integer arity;
- const MR_PseudoTypeInfo *arg_pseudo_type_infos;
- const MR_ConstString *arg_names;
- MR_TypeCtorRep type_ctor_rep;
- union {
- const MR_EnumFunctorDesc *enum_functor_desc;
- const MR_NotagFunctorDesc *notag_functor_desc;
- const MR_DuFunctorDesc *du_functor_desc;
- } functor_info;
-} ML_Construct_Info;
-
-#endif
-
-extern void ML_type_ctor_and_args(MR_TypeInfo type_info,
- bool collapse_equivalences,
- MR_TypeCtorDesc *type_ctor_desc_ptr,
- MR_Word *arg_type_info_list_ptr);
-extern int ML_get_num_functors(MR_TypeInfo type_info);
-extern MR_Word ML_type_params_vector_to_list(int arity,
- MR_TypeInfoParams type_params);
-extern MR_Word ML_arg_name_vector_to_list(int arity,
- const MR_ConstString *arg_names);
-extern MR_Word ML_pseudo_type_info_vector_to_type_info_list(int arity,
- MR_TypeInfoParams type_params,
- const MR_PseudoTypeInfo *arg_pseudo_type_infos);
-extern bool ML_get_functors_check_range(int functor_number,
- MR_TypeInfo type_info,
- ML_Construct_Info *construct_info);
-extern void ML_copy_arguments_from_list_to_vector(int arity,
- MR_Word arg_list, MR_Word term_vector);
-extern bool ML_typecheck_arguments(MR_TypeInfo type_info,
- int arity, MR_Word arg_list,
- const MR_PseudoTypeInfo *arg_pseudo_type_infos);
-extern MR_TypeInfo ML_make_type(int arity, MR_TypeCtorDesc type_ctor_desc,
- MR_Word arg_type_list);
-").
-
- % A type_ctor_desc is not (quite) a subtype of type_desc,
- % so we use a separate type for it.
-:- type type_ctor_desc ---> type_ctor_desc(c_pointer).
-
-:- pragma foreign_proc("C",
- type_of(_Value::unused) = (TypeInfo::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
- TypeInfo = TypeInfo_for_T;
-
- /*
- ** We used to collapse equivalences for efficiency here,
- ** but that's not always desirable, due to the reverse
- ** mode of make_type/2, and efficiency of type_infos
- ** probably isn't very important anyway.
- */
-#if 0
- MR_save_transient_registers();
- TypeInfo = (MR_Word) MR_collapse_equivalences(
- (MR_TypeInfo) TypeInfo_for_T);
- MR_restore_transient_registers();
-#endif
-
-}").
-
-:- pragma foreign_proc("C#",
- type_of(_Value::unused) = (TypeInfo::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"
- TypeInfo = TypeInfo_for_T;
-").
-
-:- pragma foreign_proc("C",
- has_type(_Arg::unused, TypeInfo::in),
- [will_not_call_mercury, thread_safe, promise_pure],
-"
- TypeInfo_for_T = TypeInfo;
-").
-
-:- pragma foreign_proc("C#",
- has_type(_Arg::unused, TypeInfo::in),
- [will_not_call_mercury, thread_safe, promise_pure],
-"
- TypeInfo_for_T = TypeInfo;
-").
-
-% Export this function in order to use it in runtime/mercury_trace_external.c
-:- pragma export(type_name(in) = out, "ML_type_name").
-
-type_name(Type) = TypeName :-
- type_ctor_and_args(Type, TypeCtor, ArgTypes),
- type_ctor_name_and_arity(TypeCtor, ModuleName, Name, Arity),
- ( Arity = 0 ->
- UnqualifiedTypeName = Name
- ;
- ( ModuleName = "builtin", Name = "func" ->
- IsFunc = yes
- ;
- IsFunc = no
- ),
- (
- ModuleName = "builtin", Name = "{}"
- ->
- type_arg_names(ArgTypes, IsFunc, ArgTypeNames),
- list__append(ArgTypeNames, ["}"], TypeStrings0),
- TypeStrings = ["{" | TypeStrings0],
- string__append_list(TypeStrings, UnqualifiedTypeName)
- ;
- IsFunc = yes,
- ArgTypes = [FuncRetType]
- ->
- FuncRetTypeName = type_name(FuncRetType),
- string__append_list(
- ["((func) = ", FuncRetTypeName, ")"],
- UnqualifiedTypeName)
- ;
- type_arg_names(ArgTypes, IsFunc, ArgTypeNames),
- ( IsFunc = no ->
- list__append(ArgTypeNames, [")"], TypeStrings0)
- ;
- TypeStrings0 = ArgTypeNames
- ),
- TypeNameStrings = [Name, "(" | TypeStrings0],
- string__append_list(TypeNameStrings,
- UnqualifiedTypeName)
- )
- ),
- ( ModuleName = "builtin" ->
- TypeName = UnqualifiedTypeName
- ;
- string__append_list([ModuleName, ":",
- UnqualifiedTypeName], TypeName)
- ).
-
- % Turn the types into a list of strings representing an argument
- % list, adding commas as separators as required. For example:
- % ["TypeName1", ",", "TypeName2"]
- % If formatting a function type, we close the parentheses around
- % the function's input parameters, e.g.
- % ["TypeName1", ",", "TypeName2", ") = ", "ReturnTypeName"]
- % It is the caller's reponsibility to add matching parentheses.
-:- pred type_arg_names(list(type_desc), bool, list(string)).
-:- mode type_arg_names(in, in, out) is det.
-
-type_arg_names([], _, []).
-type_arg_names([Type|Types], IsFunc, ArgNames) :-
- Name = type_name(Type),
- ( Types = [] ->
- ArgNames = [Name]
- ; IsFunc = yes, Types = [FuncReturnType] ->
- FuncReturnName = type_name(FuncReturnType),
- ArgNames = [Name, ") = ", FuncReturnName]
- ;
- type_arg_names(Types, IsFunc, Names),
- ArgNames = [Name, ", " | Names]
- ).
-
-type_args(Type) = ArgTypes :-
- type_ctor_and_args(Type, _TypeCtor, ArgTypes).
-
-type_ctor_name(TypeCtor) = Name :-
- type_ctor_name_and_arity(TypeCtor, _ModuleName, Name, _Arity).
-
-type_ctor_module_name(TypeCtor) = ModuleName :-
- type_ctor_name_and_arity(TypeCtor, ModuleName, _Name, _Arity).
-
-type_ctor_arity(TypeCtor) = Arity :-
- type_ctor_name_and_arity(TypeCtor, _ModuleName, _Name, Arity).
-
-det_make_type(TypeCtor, ArgTypes) = Type :-
- ( make_type(TypeCtor, ArgTypes) = NewType ->
- Type = NewType
- ;
- error("det_make_type/2: make_type/2 failed (wrong arity)")
- ).
-
-:- pragma foreign_proc("C",
- type_ctor(TypeInfo::in) = (TypeCtor::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
- MR_TypeCtorInfo type_ctor_info;
- MR_TypeInfo type_info;
-
- MR_save_transient_registers();
- type_info = MR_collapse_equivalences((MR_TypeInfo) TypeInfo);
- MR_restore_transient_registers();
-
- type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
-
- TypeCtor = (MR_Word) ML_make_type_ctor_desc(type_info, type_ctor_info);
-}").
-
-:- pragma foreign_proc("C#", type_ctor(_TypeInfo::in) = (_TypeCtor::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
- mercury.runtime.Errors.SORRY(""foreign code for type_ctor"");
- _TypeCtor = null;
-}").
-
-:- pragma foreign_decl("C", "
-
-extern MR_TypeCtorDesc ML_make_type_ctor_desc(MR_TypeInfo type_info,
- MR_TypeCtorInfo type_ctor_info);
-
-").
-
-:- pragma foreign_code("C", "
-
-MR_TypeCtorDesc
-ML_make_type_ctor_desc(MR_TypeInfo type_info, 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_TYPEINFO_GET_HIGHER_ORDER_ARITY(type_info));
- if (! MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(type_ctor_desc)) {
- MR_fatal_error(""std_util:ML_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_HIGHER_ORDER_ARITY(type_info));
- if (! MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(type_ctor_desc)) {
- MR_fatal_error(""std_util:ML_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_TUPLE_ARITY(type_info));
- if (! MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(type_ctor_desc)) {
- MR_fatal_error(""std_util:ML_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;
-}
-
-/*
-** You need to wrap MR_{save/restore}_transient_registers() around
-** calls to this function.
-*/
-
-void
-ML_type_ctor_and_args(MR_TypeInfo type_info, 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 (collapse_equivalences) {
- type_info = MR_collapse_equivalences(type_info);
- }
-
- type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
- type_ctor_desc = ML_make_type_ctor_desc(type_info, type_ctor_info);
- *type_ctor_desc_ptr = type_ctor_desc;
-
- if (MR_type_ctor_rep_is_variable_arity(MR_type_ctor_rep(type_ctor_info)))
- {
- arity = MR_TYPECTOR_DESC_GET_VA_ARITY(type_ctor_desc);
- *arg_type_info_list_ptr = ML_type_params_vector_to_list(arity,
- MR_TYPEINFO_GET_HIGHER_ORDER_ARG_VECTOR(type_info));
- } else {
- arity = type_ctor_info->MR_type_ctor_arity;
- *arg_type_info_list_ptr = ML_type_params_vector_to_list(arity,
- MR_TYPEINFO_GET_FIRST_ORDER_ARG_VECTOR(type_info));
- }
-}
-").
-
-:- pragma foreign_proc("C",
- type_ctor_and_args(TypeDesc::in, TypeCtorDesc::out, ArgTypes::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
- MR_TypeCtorDesc type_ctor_desc;
- MR_TypeInfo type_info;
-
- MR_save_transient_registers();
-
- type_info = (MR_TypeInfo) TypeDesc;
- ML_type_ctor_and_args(type_info, TRUE, &type_ctor_desc, &ArgTypes);
- TypeCtorDesc = (MR_Word) type_ctor_desc;
-
- MR_restore_transient_registers();
-}").
+% The actual code of these predicates and functions is now in
+% the file construct.m.
-type_ctor_and_args(TypeDesc::in, TypeCtorDesc::out, ArgTypes::out) :-
- rtti_implementation__type_ctor_and_args(
- rtti_implementation__unsafe_cast(TypeDesc),
- TypeCtorDesc0, ArgTypes0),
- TypeCtorDesc = rtti_implementation__unsafe_cast(TypeCtorDesc0),
- ArgTypes = rtti_implementation__unsafe_cast(ArgTypes0).
+num_functors(TypeInfo) =
+ construct__num_functors(TypeInfo).
- /*
- ** This is the forwards mode of make_type/2:
- ** given a type constructor and a list of argument
- ** types, check that the length of the argument
- ** types matches the arity of the type constructor,
- ** and if so, use the type constructor to construct
- ** a new type with the specified arguments.
- */
-
-:- pragma foreign_proc("C",
- make_type(TypeCtorDesc::in, ArgTypes::in) = (TypeDesc::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
- MR_TypeCtorDesc type_ctor_desc;
- MR_TypeCtorInfo type_ctor_info;
- MR_Word arg_type;
- int list_length;
- int arity;
-
- type_ctor_desc = (MR_TypeCtorDesc) TypeCtorDesc;
-
- if (MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(type_ctor_desc)) {
- arity = MR_TYPECTOR_DESC_GET_VA_ARITY(type_ctor_desc);
- } else {
- type_ctor_info = MR_TYPECTOR_DESC_GET_FIXED_ARITY_TYPE_CTOR_INFO(
- type_ctor_desc);
- arity = type_ctor_info->MR_type_ctor_arity;
- }
-
- arg_type = ArgTypes;
- for (list_length = 0; ! MR_list_is_empty(arg_type); list_length++) {
- arg_type = MR_list_tail(arg_type);
- }
-
- if (list_length != arity) {
- SUCCESS_INDICATOR = FALSE;
- } else {
- MR_save_transient_registers();
- TypeDesc = (MR_Word) ML_make_type(arity, type_ctor_desc,
- ArgTypes);
- MR_restore_transient_registers();
- SUCCESS_INDICATOR = TRUE;
- }
-}").
-
-:- pragma foreign_proc("C#",
- make_type(_TypeCtorDesc::in, _ArgTypes::in) = (_TypeDesc::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
- mercury.runtime.Errors.SORRY(""make_type"");
- // XXX this is required to keep the C# compiler quiet
- SUCCESS_INDICATOR = false;
-}").
-
- /*
- ** This is the reverse mode of make_type: given a type,
- ** split it up into a type constructor and a list of
- ** arguments.
- */
-
-:- pragma foreign_proc("C",
- make_type(TypeCtorDesc::out, ArgTypes::out) = (TypeDesc::in),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
- MR_TypeCtorDesc type_ctor_desc;
- MR_TypeInfo type_info;
+get_functor(TypeDesc, FunctorNumber, FunctorName, Arity, TypeInfoList) :-
+ construct__get_functor(TypeDesc, FunctorNumber, FunctorName,
+ Arity, TypeInfoList).
- MR_save_transient_registers();
+get_functor(TypeDesc, FunctorNumber, FunctorName, Arity, TypeInfoList,
+ ArgNameList) :-
+ construct__get_functor(TypeDesc, FunctorNumber, FunctorName,
+ Arity, TypeInfoList, ArgNameList).
- type_info = (MR_TypeInfo) TypeDesc;
- ML_type_ctor_and_args(type_info, FALSE, &type_ctor_desc, &ArgTypes);
- TypeCtorDesc = (MR_Word) type_ctor_desc;
+get_functor_ordinal(TypeDesc, FunctorNumber, Ordinal) :-
+ construct__get_functor_ordinal(TypeDesc, FunctorNumber, Ordinal).
- MR_restore_transient_registers();
-}").
+construct(TypeDesc, FunctorNumber, ArgList) =
+ construct__construct(TypeDesc, FunctorNumber, ArgList).
-:- pragma foreign_proc("C",
- type_ctor_name_and_arity(TypeCtorDesc::in, TypeCtorModuleName::out,
- TypeCtorName::out, TypeCtorArity::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
- MR_TypeCtorDesc type_ctor_desc;
+construct_tuple(Args) =
+ construct__construct_tuple(Args).
- type_ctor_desc = (MR_TypeCtorDesc) TypeCtorDesc;
+%-----------------------------------------------------------------------------%
- if (MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(type_ctor_desc)) {
- TypeCtorModuleName = (MR_String) (MR_Word)
- MR_TYPECTOR_DESC_GET_VA_MODULE_NAME(type_ctor_desc);
- TypeCtorName = (MR_String) (MR_Word)
- MR_TYPECTOR_DESC_GET_VA_NAME(type_ctor_desc);
- TypeCtorArity = MR_TYPECTOR_DESC_GET_VA_ARITY(type_ctor_desc);
- } else {
- MR_TypeCtorInfo type_ctor_info;
+% The actual code of these predicates and functions is now in
+% the file deconstruct.m.
- type_ctor_info = MR_TYPECTOR_DESC_GET_FIXED_ARITY_TYPE_CTOR_INFO(
- type_ctor_desc);
+functor(Term, Functor, Arity) :-
+ deconstruct__functor(Term, Functor, Arity).
- /*
- ** We cast away the const-ness of the module and type names,
- ** because MR_String is defined as char *, not const char *.
- */
+functor_cc(Term, Functor, Arity) :-
+ deconstruct__functor_cc(Term, Functor, Arity).
- TypeCtorModuleName = (MR_String) (MR_Integer)
- MR_type_ctor_module_name(type_ctor_info);
- TypeCtorName = (MR_String) (MR_Integer)
- MR_type_ctor_name(type_ctor_info);
- TypeCtorArity = type_ctor_info->MR_type_ctor_arity;
- }
-}").
+arg(Term, ArgumentIndex) = Argument :-
+ deconstruct__arg(Term, ArgumentIndex) = Argument.
-:- pragma foreign_proc("C",
- num_functors(TypeInfo::in) = (Functors::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
- MR_save_transient_registers();
- Functors = ML_get_num_functors((MR_TypeInfo) TypeInfo);
- MR_restore_transient_registers();
-}").
+arg_cc(Term, ArgumentIndex, Argument) :-
+ deconstruct__arg_cc(Term, ArgumentIndex, Argument).
-:- pragma foreign_proc("C",
- get_functor(TypeDesc::in, FunctorNumber::in, FunctorName::out,
- Arity::out, TypeInfoList::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
- MR_TypeInfo type_info;
- int arity;
- ML_Construct_Info construct_info;
- bool success;
+argument(Term, ArgumentIndex) = ArgumentUniv :-
+ deconstruct__argument(Term, ArgumentIndex) = ArgumentUniv.
- type_info = (MR_TypeInfo) TypeDesc;
+argument_cc(Term, ArgumentIndex, ArgumentUniv) :-
+ deconstruct__argument_cc(Term, ArgumentIndex, ArgumentUniv).
- /*
- ** 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 = ML_get_functors_check_range(FunctorNumber,
- type_info, &construct_info);
- MR_restore_transient_registers();
+named_argument(Term, ArgumentName) = ArgumentUniv :-
+ deconstruct__named_argument(Term, ArgumentName) = ArgumentUniv.
- /*
- ** Get the functor name and arity, construct the list
- ** of type_infos for arguments.
- */
+named_argument_cc(Term, ArgumentName, ArgumentUniv) :-
+ deconstruct__named_argument_cc(Term, ArgumentName, ArgumentUniv).
- if (success) {
- MR_make_aligned_string(FunctorName, (MR_String) (MR_Word)
- construct_info.functor_name);
- arity = construct_info.arity;
- Arity = arity;
-
- if (MR_TYPE_CTOR_INFO_IS_TUPLE(
- MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info)))
- {
- MR_save_transient_registers();
- TypeInfoList = ML_type_params_vector_to_list(Arity,
- MR_TYPEINFO_GET_TUPLE_ARG_VECTOR(type_info));
- MR_restore_transient_registers();
- } else {
- MR_save_transient_registers();
- TypeInfoList = ML_pseudo_type_info_vector_to_type_info_list(
- arity,
- MR_TYPEINFO_GET_FIRST_ORDER_ARG_VECTOR(type_info),
- construct_info.arg_pseudo_type_infos);
- MR_restore_transient_registers();
- }
- }
- SUCCESS_INDICATOR = success;
-}").
+deconstruct(Term, Functor, Arity, Arguments) :-
+ deconstruct__deconstruct(Term, Functor, Arity, Arguments).
-get_functor(TypeDesc, I, Functor, Arity, TypeInfoList, ArgNameList) :-
- get_functor_2(TypeDesc, I, Functor, Arity, TypeInfoList, ArgNameList0),
- ArgNameList = map(null_to_no, ArgNameList0).
+deconstruct_cc(Term, Functor, Arity, Arguments) :-
+ deconstruct__deconstruct_cc(Term, Functor, Arity, Arguments).
-:- func null_to_no(string) = maybe(string).
+limited_deconstruct(Term, MaxArity, Functor, Arity, Arguments) :-
+ deconstruct__limited_deconstruct(Term, MaxArity, Functor, Arity,
+ Arguments).
-null_to_no(S) = ( if null(S) then no else yes(S) ).
+limited_deconstruct_cc(Term, MaxArity, Functor, Arity, Arguments) :-
+ deconstruct__limited_deconstruct_cc(Term, MaxArity, Functor, Arity,
+ Arguments).
-:- pred null(string).
-:- mode null(in) is semidet.
+det_arg(Type, ArgumentIndex) = Argument :-
+ deconstruct__det_arg(Type, ArgumentIndex) = Argument.
-:- pragma foreign_proc("C",
- null(S::in),
- [will_not_call_mercury, thread_safe, promise_pure],
-"
- SUCCESS_INDICATOR = (S == NULL);
-").
+det_arg_cc(Type, ArgumentIndex, Argument) :-
+ deconstruct__det_arg_cc(Type, ArgumentIndex, Argument).
-:- pragma foreign_proc("MC++",
- null(S::in),
- [will_not_call_mercury, thread_safe, promise_pure],
-"
- SUCCESS_INDICATOR = (S == NULL);
-").
+det_argument(Type, ArgumentIndex) = Argument :-
+ deconstruct__det_argument(Type, ArgumentIndex) = Argument.
-:- pred get_functor_2(type_desc::in, int::in, string::out, int::out,
- list(type_desc)::out, list(string)::out) is semidet.
+det_argument_cc(Type, ArgumentIndex, Argument) :-
+ deconstruct__det_argument_cc(Type, ArgumentIndex, Argument).
-:- pragma foreign_proc("C",
- get_functor_2(TypeDesc::in, FunctorNumber::in, FunctorName::out,
- Arity::out, TypeInfoList::out, ArgNameList::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
- MR_TypeInfo type_info;
- int arity;
- ML_Construct_Info construct_info;
- bool success;
+det_named_argument(Type, ArgumentName) = Argument :-
+ deconstruct__det_named_argument(Type, ArgumentName) = Argument.
- type_info = (MR_TypeInfo) TypeDesc;
+det_named_argument_cc(Type, ArgumentName, Argument) :-
+ deconstruct__det_named_argument_cc(Type, ArgumentName, Argument).
- /*
- ** 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 = ML_get_functors_check_range(FunctorNumber,
- type_info, &construct_info);
- MR_restore_transient_registers();
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+% Ralph Becket <rwab1 at cam.sri.com> 24/04/99
+% Function forms added.
- /*
- ** Get the functor name and arity, construct the list
- ** of type_infos for arguments.
- */
+pair(X, Y) =
+ X-Y.
- if (success) {
- MR_make_aligned_string(FunctorName, (MR_String) (MR_Word)
- construct_info.functor_name);
- arity = construct_info.arity;
- Arity = arity;
-
- if (MR_TYPE_CTOR_INFO_IS_TUPLE(
- MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info)))
- {
- MR_save_transient_registers();
- TypeInfoList = ML_type_params_vector_to_list(Arity,
- MR_TYPEINFO_GET_TUPLE_ARG_VECTOR(type_info));
- ArgNameList = MR_list_empty();
- MR_restore_transient_registers();
- } else {
- MR_save_transient_registers();
- TypeInfoList = ML_pseudo_type_info_vector_to_type_info_list(
- arity, MR_TYPEINFO_GET_FIRST_ORDER_ARG_VECTOR(type_info),
- construct_info.arg_pseudo_type_infos);
- ArgNameList = ML_arg_name_vector_to_list(
- arity, construct_info.arg_names);
- MR_restore_transient_registers();
- }
- }
- SUCCESS_INDICATOR = success;
-}").
+maybe_func(PF, X) =
+ ( if Y = PF(X) then yes(Y) else no ).
-:- pragma foreign_proc("MC++",
- get_functor_2(_TypeDesc::in, _FunctorNumber::in, _FunctorName::out,
- _Arity::out, _TypeInfoList::out, _ArgNameList::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"
- mercury::runtime::Errors::SORRY(""foreign code for get_functor_2"");
- SUCCESS_INDICATOR = FALSE;
-").
+compose(F, G, X) =
+ F(G(X)).
-:- pragma foreign_proc("C",
- get_functor_ordinal(TypeDesc::in, FunctorNumber::in, Ordinal::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
- MR_TypeInfo type_info;
- ML_Construct_Info construct_info;
- bool success;
+converse(F, X, Y) =
+ F(Y, X).
- type_info = (MR_TypeInfo) TypeDesc;
+pow(F, N, X) =
+ ( if N = 0 then X else pow(F, N - 1, F(X)) ).
- /*
- ** 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 = ML_get_functors_check_range(FunctorNumber, type_info,
- &construct_info);
- MR_restore_transient_registers();
-
- if (success) {
- switch (construct_info.type_ctor_rep) {
-
- case MR_TYPECTOR_REP_ENUM:
- case MR_TYPECTOR_REP_ENUM_USEREQ:
- Ordinal = construct_info.functor_info.
- enum_functor_desc->MR_enum_functor_ordinal;
- break;
-
- case MR_TYPECTOR_REP_NOTAG:
- case MR_TYPECTOR_REP_NOTAG_USEREQ:
- case MR_TYPECTOR_REP_NOTAG_GROUND:
- case MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ:
- case MR_TYPECTOR_REP_TUPLE:
- Ordinal = 0;
- break;
-
- case MR_TYPECTOR_REP_DU:
- case MR_TYPECTOR_REP_DU_USEREQ:
- case MR_TYPECTOR_REP_RESERVED_ADDR:
- case MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ:
- Ordinal = construct_info.functor_info.
- du_functor_desc->MR_du_functor_ordinal;
- break;
-
- default:
- success = FALSE;
-
- }
- }
- SUCCESS_INDICATOR = success;
-}").
+isnt(P, X) :-
+ not P(X).
-:- pragma foreign_proc("C",
- construct(TypeDesc::in, FunctorNumber::in, ArgList::in) = (Term::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
- MR_TypeInfo type_info;
- MR_TypeCtorInfo type_ctor_info;
- MR_Word new_data;
- ML_Construct_Info construct_info;
- bool success;
+id(X) = X.
- type_info = (MR_TypeInfo) TypeDesc;
+solutions(P) = S :- solutions(P, S).
- /*
- ** Check range of FunctorNum, get info for this
- ** functor.
- */
- MR_save_transient_registers();
- success =
- ML_get_functors_check_range(FunctorNumber, type_info, &construct_info)
- && ML_typecheck_arguments(type_info, construct_info.arity, ArgList,
- construct_info.arg_pseudo_type_infos);
- MR_restore_transient_registers();
-
- /*
- ** Build the new term in `new_data'.
- */
- if (success) {
-
- type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
-
- if (MR_type_ctor_rep(type_ctor_info) != construct_info.type_ctor_rep) {
- MR_fatal_error(""std_util:construct: type_ctor_rep mismatch"");
- }
-
- switch (MR_type_ctor_rep(type_ctor_info)) {
-
- case MR_TYPECTOR_REP_ENUM:
- case MR_TYPECTOR_REP_ENUM_USEREQ:
- new_data = construct_info.functor_info.enum_functor_desc->
- MR_enum_functor_ordinal;
- break;
-
- case MR_TYPECTOR_REP_NOTAG:
- case MR_TYPECTOR_REP_NOTAG_USEREQ:
- case MR_TYPECTOR_REP_NOTAG_GROUND:
- case MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ:
- if (MR_list_is_empty(ArgList)) {
- MR_fatal_error(""notag arg list is empty"");
- }
-
- if (! MR_list_is_empty(MR_list_tail(ArgList))) {
- MR_fatal_error(""notag arg list is too long"");
- }
-
- new_data = MR_field(MR_UNIV_TAG, MR_list_head(ArgList),
- MR_UNIV_OFFSET_FOR_DATA);
- break;
-
- case MR_TYPECTOR_REP_RESERVED_ADDR:
- case MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ:
- /*
- ** First check whether the functor we want is one of the
- ** reserved addresses.
- */
- {
- int i;
- MR_ReservedAddrTypeLayout ra_layout;
- int total_reserved_addrs;
- const MR_ReservedAddrFunctorDesc *functor_desc;
-
- ra_layout = MR_type_ctor_layout(type_ctor_info).layout_reserved_addr;
- total_reserved_addrs = ra_layout->MR_ra_num_res_numeric_addrs
- + ra_layout->MR_ra_num_res_symbolic_addrs;
-
- for (i = 0; i < total_reserved_addrs; i++) {
- functor_desc = ra_layout->MR_ra_constants[i];
- if (functor_desc->MR_ra_functor_ordinal == FunctorNumber)
- {
- new_data = (MR_Word)
- functor_desc->MR_ra_functor_reserved_addr;
-
- /* `break' here would just exit the `for' loop */
- goto end_of_main_switch;
- }
- }
- }
-
- /*
- ** Otherwise, it is not one of the reserved addresses,
- ** so handle it like a normal DU type.
- */
-
- /* fall through */
-
- case MR_TYPECTOR_REP_DU:
- case MR_TYPECTOR_REP_DU_USEREQ:
- {
- const MR_DuFunctorDesc *functor_desc;
- MR_Word arg_list;
- MR_Word ptag;
- MR_Word arity;
- int i;
-
- functor_desc = construct_info.functor_info.du_functor_desc;
- if (functor_desc->MR_du_functor_exist_info != NULL) {
- MR_fatal_error(""not yet implemented: construction ""
- ""of terms containing existentially types"");
- }
-
- arg_list = ArgList;
- ptag = functor_desc->MR_du_functor_primary;
- switch (functor_desc->MR_du_functor_sectag_locn) {
- case MR_SECTAG_LOCAL:
- new_data = (MR_Word) MR_mkword(ptag,
- MR_mkbody((MR_Word)
- functor_desc->MR_du_functor_secondary));
- break;
-
- case MR_SECTAG_REMOTE:
- arity = functor_desc->MR_du_functor_orig_arity;
-
- MR_tag_incr_hp_msg(new_data, ptag, arity + 1,
- MR_PROC_LABEL, ""<created by std_util:construct/3>"");
-
- MR_field(ptag, new_data, 0) =
- functor_desc->MR_du_functor_secondary;
- for (i = 0; i < arity; i++) {
- MR_field(ptag, new_data, i + 1) =
- MR_field(MR_UNIV_TAG,
- MR_list_head(arg_list),
- MR_UNIV_OFFSET_FOR_DATA);
- arg_list = MR_list_tail(arg_list);
- }
-
- break;
-
- case MR_SECTAG_NONE:
- arity = functor_desc->MR_du_functor_orig_arity;
-
- MR_tag_incr_hp_msg(new_data, ptag, arity,
- MR_PROC_LABEL, ""<created by std_util:construct/3>"");
-
- for (i = 0; i < arity; i++) {
- MR_field(ptag, new_data, i) =
- MR_field(MR_UNIV_TAG,
- MR_list_head(arg_list),
- MR_UNIV_OFFSET_FOR_DATA);
- arg_list = MR_list_tail(arg_list);
- }
-
- break;
- case MR_SECTAG_VARIABLE:
- MR_fatal_error(""construct(): cannot construct variable"");
- }
-
- if (! MR_list_is_empty(arg_list)) {
- MR_fatal_error(""excess arguments in std_util:construct"");
- }
- }
- break;
-
- case MR_TYPECTOR_REP_TUPLE:
- {
- int arity, i;
- MR_Word arg_list;
-
- arity = MR_TYPEINFO_GET_TUPLE_ARITY(type_info);
-
- if (arity == 0) {
- new_data = (MR_Word) NULL;
- } else {
- MR_incr_hp_msg(new_data, arity, MR_PROC_LABEL,
- ""<created by std_util:construct/3>"");
-
- arg_list = ArgList;
- for (i = 0; i < arity; i++) {
- MR_field(MR_mktag(0), new_data, i) =
- MR_field(MR_UNIV_TAG, MR_list_head(arg_list),
- MR_UNIV_OFFSET_FOR_DATA);
- arg_list = MR_list_tail(arg_list);
- }
-
- if (! MR_list_is_empty(arg_list)) {
- MR_fatal_error(
- ""excess arguments in std_util:construct"");
- }
- }
- }
- break;
-
- default:
- MR_fatal_error(""bad type_ctor_rep in std_util:construct"");
- }
-
- end_of_main_switch:
-
- /*
- ** Create a univ.
- */
-
- MR_new_univ_on_hp(Term, type_info, new_data);
- }
-
- SUCCESS_INDICATOR = success;
-}").
-
-:- pragma foreign_proc("C#",
- make_type(_TypeCtorDesc::out, _ArgTypes::out) = (_TypeDesc::in),
- [will_not_call_mercury, thread_safe, promise_pure],
-"
- mercury.runtime.Errors.SORRY(""foreign code for make_type"");
-").
-
-type_ctor_name_and_arity(TypeCtorDesc0::in, TypeCtorModuleName::out,
- TypeCtorName::out, TypeCtorArity::out) :-
- TypeCtorDesc = rtti_implementation__unsafe_cast(TypeCtorDesc0),
- rtti_implementation__type_ctor_name_and_arity(TypeCtorDesc,
- TypeCtorModuleName, TypeCtorName, TypeCtorArity).
-
-:- pragma foreign_proc("C#",
- num_functors(_TypeInfo::in) = (Functors::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
- mercury.runtime.Errors.SORRY(""foreign code for num_functors"");
- // XXX keep the C# compiler quiet
- Functors = 0;
-}").
-
-:- pragma foreign_proc("MC++",
- get_functor(_TypeDesc::in, _FunctorNumber::in, _FunctorName::out,
- _Arity::out, _TypeInfoList::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"
- mercury::runtime::Errors::SORRY(""foreign code for get_functor"");
-").
-
-:- pragma foreign_proc("MC++",
- get_functor_ordinal(_TypeDesc::in, _FunctorNumber::in, _Ordinal::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"
- mercury::runtime::Errors::SORRY(""foreign code for get_functor_ordinal"");
-").
-
-:- pragma foreign_proc("C#",
- construct(_TypeDesc::in, _FunctorNumber::in, _ArgList::in)
- = (_Term::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
- mercury.runtime.Errors.SORRY(""foreign code for construct"");
- _Term = null;
- // XXX this is required to keep the C# compiler quiet
- SUCCESS_INDICATOR = false;
-}").
-
-construct_tuple(Args) =
- construct_tuple_2(Args,
- list__map(univ_type, Args),
- list__length(Args)).
-
-:- func construct_tuple_2(list(univ), list(type_desc), int) = univ.
-
-:- pragma foreign_proc("C",
- construct_tuple_2(Args::in, ArgTypes::in, Arity::in) = (Term::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
- MR_TypeInfo type_info;
- MR_Word new_data;
- MR_Word arg_value;
- int i;
-
- /*
- ** Construct a type_info for the tuple.
- */
- MR_save_transient_registers();
- type_info = ML_make_type(Arity, MR_TYPECTOR_DESC_MAKE_TUPLE(Arity),
- ArgTypes);
- MR_restore_transient_registers();
-
- /*
- ** Create the tuple.
- */
- if (Arity == 0) {
- new_data = (MR_Word) NULL;
- } else {
- MR_incr_hp_msg(new_data, Arity, MR_PROC_LABEL,
- ""<created by std_util:construct_tuple/1>"");
- for (i = 0; i < Arity; i++) {
- arg_value = MR_field(MR_UNIV_TAG,
- MR_list_head(Args),
- MR_UNIV_OFFSET_FOR_DATA);
- MR_field(MR_mktag(0), new_data, i) = arg_value;
- Args = MR_list_tail(Args);
- }
- }
-
- /*
- ** Create a univ.
- */
- MR_new_univ_on_hp(Term, type_info, new_data);
-}").
-
-:- pragma foreign_proc("C#",
- construct_tuple_2(_Args::in, _ArgTypes::in, _Arity::in) = (_Term::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
- mercury.runtime.Errors.SORRY(""construct_tuple_2"");
- _Term = null;
-}").
-
-:- pragma foreign_code("C", "
-
- /*
- ** Prototypes
- */
-
-static int ML_get_functor_info(MR_TypeInfo type_info, int functor_number,
- ML_Construct_Info *construct_info);
-
- /*
- ** ML_get_functor_info:
- **
- ** Extract the information for functor number `functor_number',
- ** for the type represented by type_info.
- ** We succeed if the type is some sort of discriminated union.
- **
- ** You need to save and restore transient registers around
- ** calls to this function.
- */
-
-static int
-ML_get_functor_info(MR_TypeInfo type_info, int functor_number,
- ML_Construct_Info *construct_info)
-{
- MR_TypeCtorInfo type_ctor_info;
-
- type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
- construct_info->type_ctor_rep = MR_type_ctor_rep(type_ctor_info);
-
- switch(MR_type_ctor_rep(type_ctor_info)) {
-
- case MR_TYPECTOR_REP_RESERVED_ADDR:
- case MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ:
- case MR_TYPECTOR_REP_DU:
- case MR_TYPECTOR_REP_DU_USEREQ:
- {
- MR_DuFunctorDesc *functor_desc;
-
- if (functor_number < 0 ||
- functor_number >= MR_type_ctor_num_functors(type_ctor_info))
- {
- MR_fatal_error(""ML_get_functor_info: ""
- ""du functor_number out of range"");
- }
-
- functor_desc = MR_type_ctor_functors(type_ctor_info).
- functors_du[functor_number];
- construct_info->functor_info.du_functor_desc = functor_desc;
- construct_info->functor_name = functor_desc->MR_du_functor_name;
- construct_info->arity = functor_desc->MR_du_functor_orig_arity;
- construct_info->arg_pseudo_type_infos =
- functor_desc->MR_du_functor_arg_types;
- construct_info->arg_names =
- functor_desc->MR_du_functor_arg_names;
- }
- break;
-
- case MR_TYPECTOR_REP_ENUM:
- case MR_TYPECTOR_REP_ENUM_USEREQ:
- {
- MR_EnumFunctorDesc *functor_desc;
-
- if (functor_number < 0 ||
- functor_number >= MR_type_ctor_num_functors(type_ctor_info))
- {
- MR_fatal_error(""ML_get_functor_info: ""
- ""enum functor_number out of range"");
- }
-
- functor_desc = MR_type_ctor_functors(type_ctor_info).
- functors_enum[functor_number];
- construct_info->functor_info.enum_functor_desc = functor_desc;
- construct_info->functor_name = functor_desc->MR_enum_functor_name;
- construct_info->arity = 0;
- construct_info->arg_pseudo_type_infos = NULL;
- construct_info->arg_names = NULL;
- }
- break;
-
- case MR_TYPECTOR_REP_NOTAG:
- case MR_TYPECTOR_REP_NOTAG_USEREQ:
- case MR_TYPECTOR_REP_NOTAG_GROUND:
- case MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ:
- {
- MR_NotagFunctorDesc *functor_desc;
-
- if (functor_number != 0) {
- MR_fatal_error(""ML_get_functor_info: ""
- ""notag functor_number out of range"");
- }
-
- functor_desc = MR_type_ctor_functors(type_ctor_info).functors_notag;
- construct_info->functor_info.notag_functor_desc = functor_desc;
- construct_info->functor_name = functor_desc->MR_notag_functor_name;
- construct_info->arity = 1;
- construct_info->arg_pseudo_type_infos =
- &functor_desc->MR_notag_functor_arg_type;
- construct_info->arg_names =
- &functor_desc->MR_notag_functor_arg_name;
- }
- break;
-
- case MR_TYPECTOR_REP_EQUIV_GROUND:
- case MR_TYPECTOR_REP_EQUIV:
- return ML_get_functor_info(
- MR_create_type_info(
- MR_TYPEINFO_GET_FIRST_ORDER_ARG_VECTOR(type_info),
- MR_type_ctor_layout(type_ctor_info).layout_equiv),
- functor_number, construct_info);
-
- case MR_TYPECTOR_REP_EQUIV_VAR:
- /*
- ** The current version of the RTTI gives all such equivalence types
- ** the EQUIV type_ctor_rep, not EQUIV_VAR.
- */
- MR_fatal_error(""unexpected EQUIV_VAR type_ctor_rep"");
- break;
-
- case MR_TYPECTOR_REP_TUPLE:
- construct_info->functor_name = ""{}"";
- construct_info->arity = MR_TYPEINFO_GET_TUPLE_ARITY(type_info);
-
- /* Tuple types don't have pseudo-type_infos for the functors. */
- construct_info->arg_pseudo_type_infos = NULL;
- construct_info->arg_names = NULL;
- break;
-
- case MR_TYPECTOR_REP_INT:
- case MR_TYPECTOR_REP_CHAR:
- case MR_TYPECTOR_REP_FLOAT:
- case MR_TYPECTOR_REP_STRING:
- case MR_TYPECTOR_REP_PRED:
- case MR_TYPECTOR_REP_VOID:
- case MR_TYPECTOR_REP_C_POINTER:
- case MR_TYPECTOR_REP_TYPEINFO:
- case MR_TYPECTOR_REP_TYPECTORINFO:
- case MR_TYPECTOR_REP_TYPECLASSINFO:
- case MR_TYPECTOR_REP_BASETYPECLASSINFO:
- case MR_TYPECTOR_REP_ARRAY:
- case MR_TYPECTOR_REP_SUCCIP:
- case MR_TYPECTOR_REP_HP:
- case MR_TYPECTOR_REP_CURFR:
- case MR_TYPECTOR_REP_MAXFR:
- case MR_TYPECTOR_REP_REDOFR:
- case MR_TYPECTOR_REP_REDOIP:
- case MR_TYPECTOR_REP_TRAIL_PTR:
- case MR_TYPECTOR_REP_TICKET:
- return FALSE;
-
- case MR_TYPECTOR_REP_UNKNOWN:
- default:
- MR_fatal_error(""std_util:construct - unexpected type."");
- }
-
- return TRUE;
-}
-
- /*
- ** ML_typecheck_arguments:
- **
- ** Given a list of univs (`arg_list'), and a vector of
- ** type_infos (`arg_vector'), checks that they are all of the
- ** same type; if so, returns TRUE, otherwise returns FALSE;
- ** `arg_vector' may contain type variables, these
- ** will be filled in by the type arguments of `type_info'.
- **
- ** Assumes the length of the list has already been checked.
- **
- ** You need to save and restore transient registers around
- ** calls to this function.
- */
-
-bool
-ML_typecheck_arguments(MR_TypeInfo type_info, int arity, MR_Word arg_list,
- const MR_PseudoTypeInfo *arg_pseudo_type_infos)
-{
- MR_TypeInfo arg_type_info;
- MR_TypeInfo list_arg_type_info;
- int comp;
- int i;
-
- /* Type check list of arguments */
-
- for (i = 0; i < arity; i++) {
- if (MR_list_is_empty(arg_list)) {
- return FALSE;
- }
-
- list_arg_type_info = (MR_TypeInfo) MR_field(MR_UNIV_TAG,
- MR_list_head(arg_list), MR_UNIV_OFFSET_FOR_TYPEINFO);
-
- if (MR_TYPE_CTOR_INFO_IS_TUPLE(
- MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info)))
- {
- arg_type_info = MR_TYPEINFO_GET_TUPLE_ARG_VECTOR(type_info)[i + 1];
- } else {
- arg_type_info = MR_create_type_info(
- MR_TYPEINFO_GET_FIRST_ORDER_ARG_VECTOR(type_info),
- arg_pseudo_type_infos[i]);
- }
-
- comp = MR_compare_type_info(list_arg_type_info, arg_type_info);
- if (comp != MR_COMPARE_EQUAL) {
- return FALSE;
- }
- arg_list = MR_list_tail(arg_list);
- }
-
- /* List should now be empty */
- return MR_list_is_empty(arg_list);
-}
-
- /*
- ** ML_copy_arguments_from_list_to_vector:
- **
- ** Copy the arguments from a list of univs (`arg_list'),
- ** into the vector (`term_vector').
- **
- ** Assumes the length of the list has already been checked.
- */
-
-void
-ML_copy_arguments_from_list_to_vector(int arity, MR_Word arg_list,
- MR_Word term_vector)
-{
- int i;
-
- for (i = 0; i < arity; i++) {
- MR_field(MR_mktag(0), term_vector, i) =
- MR_field(MR_UNIV_TAG, MR_list_head(arg_list),
- MR_UNIV_OFFSET_FOR_DATA);
- arg_list = MR_list_tail(arg_list);
- }
-}
-
- /*
- ** ML_make_type(arity, type_ctor_info, arg_types_list):
- **
- ** Construct and return a type_info for a type using the
- ** specified type_ctor for the type constructor,
- ** and using the arguments specified in arg_types_list
- ** for the type arguments (if any).
- **
- ** Assumes that the arity of the type constructor represented
- ** by type_ctor_info and the length of the arg_types_list
- ** are both equal to `arity'.
- **
- ** You need to save and restore transient registers around
- ** calls to this function.
- */
-
-MR_TypeInfo
-ML_make_type(int arity, MR_TypeCtorDesc type_ctor_desc, MR_Word arg_types_list)
-{
- MR_TypeCtorInfo type_ctor_info;
- MR_Word *new_type_info_arena;
- MR_TypeInfo *new_type_info_args;
- int i;
-
- /*
- ** We need to treat higher-order and tuple types as a special case here.
- */
-
- if (MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(type_ctor_desc)) {
- type_ctor_info = MR_TYPECTOR_DESC_GET_VA_TYPE_CTOR_INFO(
- type_ctor_desc);
-
- MR_restore_transient_registers();
- MR_incr_hp_atomic_msg(MR_LVALUE_CAST(MR_Word, new_type_info_arena),
- MR_higher_order_type_info_size(arity),
- ""mercury__std_util__ML_make_type"", ""type_info"");
- MR_save_transient_registers();
- MR_fill_in_higher_order_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);
-
- if (arity == 0) {
- return (MR_TypeInfo) type_ctor_info;
- }
-
- MR_restore_transient_registers();
- MR_incr_hp_atomic_msg(MR_LVALUE_CAST(MR_Word, new_type_info_arena),
- MR_first_order_type_info_size(arity),
- ""mercury__std_util__ML_make_type"", ""type_info"");
- MR_save_transient_registers();
- MR_fill_in_first_order_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);
- arg_types_list = MR_list_tail(arg_types_list);
- }
-
- return (MR_TypeInfo) new_type_info_arena;
-}
-
- /*
- ** ML_get_functors_check_range:
- **
- ** Check that functor_number is in range, and get the functor
- ** info if it is. Return FALSE if it is out of range, or
- ** if ML_get_functor_info returns FALSE, otherwise return TRUE.
- **
- ** You need to save and restore transient registers around
- ** calls to this function.
- */
-
-bool
-ML_get_functors_check_range(int functor_number, MR_TypeInfo type_info,
- ML_Construct_Info *construct_info)
-{
- /*
- ** Check range of functor_number, get functors
- ** vector
- */
- return functor_number < ML_get_num_functors(type_info) &&
- functor_number >= 0 &&
- ML_get_functor_info(type_info, functor_number, construct_info);
-}
-
- /*
- ** ML_type_params_vector_to_list:
- **
- ** Copy `arity' 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.
- */
-
-MR_Word
-ML_type_params_vector_to_list(int arity, MR_TypeInfoParams 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_list_cons((MR_Word) type_params[arity],
- type_info_list);
- --arity;
- }
- MR_save_transient_registers();
-
- return type_info_list;
-}
-
- /*
- ** ML_arg_name_vector_to_list:
- **
- ** Copy `arity' argument names from the `arg_names' vector, which starts
- ** at index 0, onto the Mercury heap in a list.
- **
- ** You need to save and restore transient registers around
- ** calls to this function.
- */
-
-MR_Word
-ML_arg_name_vector_to_list(int arity, const MR_ConstString *arg_names)
-{
- MR_TypeInfo arg_type;
- MR_Word arg_names_list;
-
- MR_restore_transient_registers();
- arg_names_list = MR_list_empty();
-
- while (arity > 0) {
- --arity;
- arg_names_list = MR_list_cons((MR_Word) arg_names[arity],
- arg_names_list);
- }
- MR_save_transient_registers();
-
- return arg_names_list;
-}
-
- /*
- ** ML_pseudo_type_info_vector_to_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.
- **
- ** You need to save and restore transient registers around
- ** calls to this function.
- */
-
-MR_Word
-ML_pseudo_type_info_vector_to_type_info_list(int arity,
- MR_TypeInfoParams type_params,
- const MR_PseudoTypeInfo *arg_pseudo_type_infos)
-{
- MR_TypeInfo arg_type;
- MR_Word type_info_list;
-
- MR_restore_transient_registers();
- type_info_list = MR_list_empty();
-
- while (--arity >= 0) {
- /* Get the argument type_info */
-
- /* Fill in any polymorphic pseudo type_infos */
- MR_save_transient_registers();
- arg_type = MR_create_type_info(type_params,
- arg_pseudo_type_infos[arity]);
- MR_restore_transient_registers();
-
- /* Look past any equivalences */
- MR_save_transient_registers();
- arg_type = MR_collapse_equivalences(arg_type);
- MR_restore_transient_registers();
-
- /* Join the argument to the front of the list */
- type_info_list = MR_list_cons((MR_Word) arg_type, type_info_list);
- }
- MR_save_transient_registers();
-
- return type_info_list;
-}
-
- /*
- ** ML_get_num_functors:
- **
- ** Get the number of functors for a type. If it isn't a
- ** discriminated union, return -1.
- **
- ** You need to save and restore transient registers around
- ** calls to this function.
- */
-
-int
-ML_get_num_functors(MR_TypeInfo type_info)
-{
- MR_TypeCtorInfo type_ctor_info;
- MR_Integer functors;
-
- type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
-
- switch(MR_type_ctor_rep(type_ctor_info)) {
- case MR_TYPECTOR_REP_DU:
- case MR_TYPECTOR_REP_DU_USEREQ:
- case MR_TYPECTOR_REP_RESERVED_ADDR:
- case MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ:
- case MR_TYPECTOR_REP_ENUM:
- case MR_TYPECTOR_REP_ENUM_USEREQ:
- functors = MR_type_ctor_num_functors(type_ctor_info);
- break;
-
- case MR_TYPECTOR_REP_NOTAG:
- case MR_TYPECTOR_REP_NOTAG_USEREQ:
- case MR_TYPECTOR_REP_NOTAG_GROUND:
- case MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ:
- case MR_TYPECTOR_REP_TUPLE:
- functors = 1;
- break;
-
- case MR_TYPECTOR_REP_EQUIV_VAR:
- /*
- ** The current version of the RTTI gives all such equivalence types
- ** the EQUIV type_ctor_rep, not EQUIV_VAR.
- */
- MR_fatal_error(""unexpected EQUIV_VAR type_ctor_rep"");
- break;
-
- case MR_TYPECTOR_REP_EQUIV_GROUND:
- case MR_TYPECTOR_REP_EQUIV:
- functors = ML_get_num_functors(
- MR_create_type_info((MR_TypeInfo *) type_info,
- MR_type_ctor_layout(type_ctor_info).layout_equiv));
- break;
-
- case MR_TYPECTOR_REP_INT:
- case MR_TYPECTOR_REP_CHAR:
- case MR_TYPECTOR_REP_FLOAT:
- case MR_TYPECTOR_REP_STRING:
- case MR_TYPECTOR_REP_PRED:
- case MR_TYPECTOR_REP_VOID:
- case MR_TYPECTOR_REP_C_POINTER:
- case MR_TYPECTOR_REP_TYPEINFO:
- case MR_TYPECTOR_REP_TYPECTORINFO:
- case MR_TYPECTOR_REP_TYPECLASSINFO:
- case MR_TYPECTOR_REP_BASETYPECLASSINFO:
- case MR_TYPECTOR_REP_ARRAY:
- case MR_TYPECTOR_REP_SUCCIP:
- case MR_TYPECTOR_REP_HP:
- case MR_TYPECTOR_REP_CURFR:
- case MR_TYPECTOR_REP_MAXFR:
- case MR_TYPECTOR_REP_REDOFR:
- case MR_TYPECTOR_REP_REDOIP:
- case MR_TYPECTOR_REP_TRAIL_PTR:
- case MR_TYPECTOR_REP_TICKET:
- functors = -1;
- break;
-
- case MR_TYPECTOR_REP_UNKNOWN:
- default:
- MR_fatal_error(""std_util:ML_get_num_functors :""
- "" unknown type_ctor_rep"");
- }
-
- return functors;
-}
-
-").
-
-%-----------------------------------------------------------------------------%
-
-:- pragma foreign_decl("C", "
-
-#include ""mercury_deconstruct.h""
-#include ""mercury_deconstruct_macros.h""
-
-").
-
-%-----------------------------------------------------------------------------%
-
- % Code for functor, arg and deconstruct.
-
-:- pragma foreign_proc("C",
- functor(Term::in, Functor::out, Arity::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
-#define PREDNAME ""functor/3""
-#define TYPEINFO_ARG TypeInfo_for_T
-#define TERM_ARG Term
-#define FUNCTOR_ARG Functor
-#define ARITY_ARG Arity
-#include ""mercury_ml_functor_body.h""
-#undef PREDNAME
-#undef TYPEINFO_ARG
-#undef TERM_ARG
-#undef FUNCTOR_ARG
-#undef ARITY_ARG
-}").
-
-:- pragma foreign_proc("C",
- functor_cc(Term::in, Functor::out, Arity::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
-#define PREDNAME ""functor_cc/3""
-#define ALLOW_NONCANONICAL
-#define TYPEINFO_ARG TypeInfo_for_T
-#define TERM_ARG Term
-#define FUNCTOR_ARG Functor
-#define ARITY_ARG Arity
-#include ""mercury_ml_functor_body.h""
-#undef PREDNAME
-#undef ALLOW_NONCANONICAL
-#undef TYPEINFO_ARG
-#undef TERM_ARG
-#undef FUNCTOR_ARG
-#undef ARITY_ARG
-}").
-
-functor_cc(_Term::in, _Functor::out, _Arity::out) :-
- error("NYI: std_util__functor_cc/3").
-
-/*
-** N.B. any modifications to arg/2 might also require similar
-** changes to store__arg_ref in store.m.
-*/
-
-:- pragma foreign_proc("C",
- arg(Term::in, ArgumentIndex::in) = (Argument::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
-#define PREDNAME ""arg/2""
-#define NONCANON_HANDLING MR_ABORT_ON_NONCANONICAL
-#define TYPEINFO_ARG TypeInfo_for_T
-#define TERM_ARG Term
-#define SELECTOR_ARG ArgumentIndex
-#define SELECTED_ARG Argument
-#define EXPECTED_TYPE_INFO TypeInfo_for_ArgT
-#include ""mercury_ml_arg_body.h""
-#undef PREDNAME
-#undef NONCANON_HANDLING
-#undef TYPEINFO_ARG
-#undef TERM_ARG
-#undef SELECTOR_ARG
-#undef SELECTED_ARG
-#undef EXPECTED_TYPE_INFO
-}").
-
-:- pragma foreign_proc("C",
- arg_cc(Term::in, ArgumentIndex::in, Argument::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
-#define PREDNAME ""arg/2""
-#define NONCANON_HANDLING MR_ALLOW_NONCANONICAL
-#define TYPEINFO_ARG TypeInfo_for_T
-#define TERM_ARG Term
-#define SELECTOR_ARG ArgumentIndex
-#define SELECTED_ARG Argument
-#define EXPECTED_TYPE_INFO TypeInfo_for_ArgT
-#include ""mercury_ml_arg_body.h""
-#undef PREDNAME
-#undef NONCANON_HANDLING
-#undef TYPEINFO_ARG
-#undef TERM_ARG
-#undef SELECTOR_ARG
-#undef SELECTED_ARG
-#undef EXPECTED_TYPE_INFO
-}").
-
-:- pragma foreign_proc("C",
- argument(Term::in, ArgumentIndex::in) = (ArgumentUniv::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
-#define PREDNAME ""argument/2""
-#define NONCANON_HANDLING MR_FAIL_ON_NONCANONICAL
-#define TYPEINFO_ARG TypeInfo_for_T
-#define TERM_ARG Term
-#define SELECTOR_ARG ArgumentIndex
-#define SELECTED_ARG ArgumentUniv
-#include ""mercury_ml_arg_body.h""
-#undef PREDNAME
-#undef NONCANON_HANDLING
-#undef TYPEINFO_ARG
-#undef TERM_ARG
-#undef SELECTOR_ARG
-#undef SELECTED_ARG
-}").
-
-:- pragma foreign_proc("C",
- argument_cc(Term::in, ArgumentIndex::in, ArgumentUniv::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
-#define PREDNAME ""argument_cc/3""
-#define NONCANON_HANDLING MR_ALLOW_NONCANONICAL
-#define TYPEINFO_ARG TypeInfo_for_T
-#define TERM_ARG Term
-#define SELECTOR_ARG ArgumentIndex
-#define SELECTED_ARG ArgumentUniv
-#include ""mercury_ml_arg_body.h""
-#undef PREDNAME
-#undef NONCANON_HANDLING
-#undef TYPEINFO_ARG
-#undef TERM_ARG
-#undef SELECTOR_ARG
-#undef SELECTED_ARG
-}").
-
-:- pragma foreign_proc("C",
- named_argument(Term::in, ArgumentName::in) = (ArgumentUniv::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
-#define PREDNAME ""named_argument/2""
-#define NONCANON_HANDLING MR_FAIL_ON_NONCANONICAL
-#define TYPEINFO_ARG TypeInfo_for_T
-#define TERM_ARG Term
-#define SELECTOR_ARG (MR_ConstString) ArgumentName
-#define SELECTED_ARG ArgumentUniv
-#define SELECT_BY_NAME
-#include ""mercury_ml_arg_body.h""
-#undef PREDNAME
-#undef NONCANON_HANDLING
-#undef TYPEINFO_ARG
-#undef TERM_ARG
-#undef SELECTOR_ARG
-#undef SELECTED_ARG
-#undef SELECT_BY_NAME
-}").
-
-:- pragma foreign_proc("C",
- named_argument_cc(Term::in, ArgumentName::in, ArgumentUniv::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
-#define PREDNAME ""named_argument_cc/3""
-#define NONCANON_HANDLING MR_ALLOW_NONCANONICAL
-#define TYPEINFO_ARG TypeInfo_for_T
-#define TERM_ARG Term
-#define SELECTOR_ARG (MR_ConstString) ArgumentName
-#define SELECTED_ARG ArgumentUniv
-#define SELECT_BY_NAME
-#include ""mercury_ml_arg_body.h""
-#undef PREDNAME
-#undef NONCANON_HANDLING
-#undef TYPEINFO_ARG
-#undef TERM_ARG
-#undef SELECTOR_ARG
-#undef SELECTED_ARG
-#undef SELECT_BY_NAME
-}").
-
-:- pragma foreign_proc("C",
- deconstruct(Term::in, Functor::out, Arity::out, Arguments::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
-#define PREDNAME ""deconstruct/4""
-#define EXPAND_INFO_TYPE MR_Expand_Functor_Args_Info
-#define EXPAND_INFO_CALL MR_expand_functor_args
-#define TYPEINFO_ARG TypeInfo_for_T
-#define TERM_ARG Term
-#define FUNCTOR_ARG Functor
-#define ARITY_ARG Arity
-#define ARGUMENTS_ARG Arguments
-#include ""mercury_ml_deconstruct_body.h""
-#undef PREDNAME
-#undef EXPAND_INFO_TYPE
-#undef EXPAND_INFO_CALL
-#undef TYPEINFO_ARG
-#undef TERM_ARG
-#undef FUNCTOR_ARG
-#undef ARITY_ARG
-#undef ARGUMENTS_ARG
-}").
-
-:- pragma foreign_proc("C",
- deconstruct_cc(Term::in, Functor::out, Arity::out, Arguments::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
-#define PREDNAME ""deconstruct_cc/4""
-#define EXPAND_INFO_TYPE MR_Expand_Functor_Args_Info
-#define EXPAND_INFO_CALL MR_expand_functor_args
-#define ALLOW_NONCANONICAL
-#define TYPEINFO_ARG TypeInfo_for_T
-#define TERM_ARG Term
-#define FUNCTOR_ARG Functor
-#define ARITY_ARG Arity
-#define ARGUMENTS_ARG Arguments
-#include ""mercury_ml_deconstruct_body.h""
-#undef PREDNAME
-#undef NONCANON_HANDLING
-#undef EXPAND_INFO_TYPE
-#undef EXPAND_INFO_CALL
-#undef ALLOW_NONCANONICAL
-#undef TYPEINFO_ARG
-#undef TERM_ARG
-#undef FUNCTOR_ARG
-#undef ARITY_ARG
-#undef ARGUMENTS_ARG
-}").
-
-deconstruct_cc(_Term::in, _Functor::out, _Arity::out, _Arguments::out) :-
- error("NYI: std_util__deconstruct_cc/3").
-
-:- pragma foreign_proc("C",
- limited_deconstruct(Term::in, MaxArity::in, Functor::out,
- Arity::out, Arguments::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
-#define PREDNAME ""limited_deconstruct/5""
-#define EXPAND_INFO_TYPE MR_Expand_Functor_Args_Limit_Info
-#define EXPAND_INFO_CALL MR_expand_functor_args_limit
-#define TYPEINFO_ARG TypeInfo_for_T
-#define TERM_ARG Term
-#define MAX_ARITY_ARG MaxArity
-#define FUNCTOR_ARG Functor
-#define ARITY_ARG Arity
-#define ARGUMENTS_ARG Arguments
-#include ""mercury_ml_deconstruct_body.h""
-#undef PREDNAME
-#undef EXPAND_INFO_TYPE
-#undef EXPAND_INFO_CALL
-#undef TYPEINFO_ARG
-#undef TERM_ARG
-#undef MAX_ARITY_ARG
-#undef FUNCTOR_ARG
-#undef ARITY_ARG
-#undef ARGUMENTS_ARG
-}").
-
-:- pragma foreign_proc("C",
- limited_deconstruct_cc(Term::in, MaxArity::in, Functor::out,
- Arity::out, Arguments::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
-#define PREDNAME ""limited_deconstruct_cc/5""
-#define EXPAND_INFO_TYPE MR_Expand_Functor_Args_Limit_Info
-#define EXPAND_INFO_CALL MR_expand_functor_args_limit
-#define ALLOW_NONCANONICAL
-#define TYPEINFO_ARG TypeInfo_for_T
-#define TERM_ARG Term
-#define MAX_ARITY_ARG MaxArity
-#define FUNCTOR_ARG Functor
-#define ARITY_ARG Arity
-#define ARGUMENTS_ARG Arguments
-#include ""mercury_ml_deconstruct_body.h""
-#undef PREDNAME
-#undef EXPAND_INFO_TYPE
-#undef EXPAND_INFO_CALL
-#undef ALLOW_NONCANONICAL
-#undef TYPEINFO_ARG
-#undef TERM_ARG
-#undef MAX_ARITY_ARG
-#undef FUNCTOR_ARG
-#undef ARITY_ARG
-#undef ARGUMENTS_ARG
-}").
-
-limited_deconstruct_cc(_Term::in, _MaxArity::in, _Functor::out, _Arity::out,
- _Arguments::out) :-
- error("NYI: std_util__limited_deconstruct_cc/3").
-
-:- pragma foreign_proc("MC++",
- functor(_Term::in, _Functor::out, _Arity::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"
- mercury::runtime::Errors::SORRY(""foreign code for functor"");
-").
-
-/*
-** N.B. any modifications to arg/2 might also require similar
-** changes to store__arg_ref in store.m.
-*/
-
-:- pragma foreign_proc("C#",
- arg(_Term::in, _ArgumentIndex::in) = (_Argument::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
- mercury.runtime.Errors.SORRY(""foreign code for arg"");
- // XXX this is required to keep the C# compiler quiet
- SUCCESS_INDICATOR = false;
-}").
-
-:- pragma foreign_proc("C#",
- arg_cc(_Term::in, _ArgumentIndex::in, _Argument::out),
- [will_not_call_mercury, thread_safe],
-"{
- mercury.runtime.Errors.SORRY(""foreign code for arg_cc"");
- // XXX this is required to keep the C# compiler quiet
- SUCCESS_INDICATOR = false;
-}").
-
-:- pragma foreign_proc("C#",
- argument(_Term::in, _ArgumentIndex::in) = (_ArgumentUniv::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
- mercury.runtime.Errors.SORRY(""foreign code for argument"");
- // XXX this is required to keep the C# compiler quiet
- SUCCESS_INDICATOR = false;
-}").
-
-:- pragma foreign_proc("C#",
- argument_cc(_Term::in, _ArgumentIndex::in, _ArgumentUniv::out),
- [will_not_call_mercury, thread_safe],
-"{
- mercury.runtime.Errors.SORRY(""foreign code for argument_cc"");
- // XXX this is required to keep the C# compiler quiet
- SUCCESS_INDICATOR = false;
-}").
-
-:- pragma foreign_proc("C#",
- named_argument(_Term::in, _ArgumentName::in) = (_ArgumentUniv::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
- mercury.runtime.Errors.SORRY(""foreign code for named_argument"");
- // XXX this is required to keep the C# compiler quiet
- SUCCESS_INDICATOR = false;
-}").
-
-:- pragma foreign_proc("C#",
- named_argument_cc(_Term::in, _ArgumentName::in, _ArgumentUniv::out),
- [will_not_call_mercury, thread_safe],
-"{
- mercury.runtime.Errors.SORRY(""foreign code for named_argument_cc"");
- // XXX this is required to keep the C# compiler quiet
- SUCCESS_INDICATOR = false;
-}").
-
-det_arg(Type, ArgumentIndex) = Argument :-
- ( arg(Type, ArgumentIndex) = Argument0 ->
- Argument = Argument0
- ;
- ( argument(Type, ArgumentIndex) = _ArgumentUniv ->
- error("det_arg: argument had wrong type")
- ;
- error("det_arg: argument number out of range")
- )
- ).
-
-det_arg_cc(Type, ArgumentIndex, Argument) :-
- ( arg_cc(Type, ArgumentIndex, Argument0) ->
- Argument = Argument0
- ;
- ( argument_cc(Type, ArgumentIndex, _ArgumentUniv) ->
- error("det_arg_cc: argument had wrong type")
- ;
- error("det_arg_cc: argument number out of range")
- )
- ).
-
-det_argument(Type, ArgumentIndex) = Argument :-
- ( argument(Type, ArgumentIndex) = Argument0 ->
- Argument = Argument0
- ;
- error("det_argument: argument out of range")
- ).
-
-det_argument_cc(Type, ArgumentIndex, Argument) :-
- ( argument_cc(Type, ArgumentIndex, Argument0) ->
- Argument = Argument0
- ;
- error("det_argument_cc: argument out of range")
- ).
-
-det_named_argument(Type, ArgumentName) = Argument :-
- ( named_argument(Type, ArgumentName) = Argument0 ->
- Argument = Argument0
- ;
- error("det_named_argument: no argument with that name")
- ).
-
-det_named_argument_cc(Type, ArgumentName, Argument) :-
- ( named_argument_cc(Type, ArgumentName, Argument0) ->
- Argument = Argument0
- ;
- error("det_named_argument_cc: no argument with that name")
- ).
-
-deconstruct(Term::in, Functor::out, Arity::out, Arguments::out) :-
- rtti_implementation__deconstruct(Term, Functor, Arity, Arguments).
-
-:- pragma foreign_proc("MC++",
- limited_deconstruct(_Term::in, _MaxArity::in, _Functor::out,
- _Arity::out, _Arguments::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
- mercury::runtime::Errors::SORRY(""foreign code for limited_deconstruct"");
- SUCCESS_INDICATOR = FALSE;
-}").
-
-get_functor_info(Univ, FunctorInfo) :-
- ( univ_to_type(Univ, Int) ->
- FunctorInfo = functor_integer(Int)
- ; univ_to_type(Univ, Float) ->
- FunctorInfo = functor_float(Float)
- ; univ_to_type(Univ, String) ->
- FunctorInfo = functor_string(String)
- ; get_enum_functor_info(Univ, Enum) ->
- FunctorInfo = functor_enum(Enum)
- %
- % XXX we should handle reserved_addr types here
- %
- ; get_du_functor_info(Univ, Where, Ptag, Sectag, Args) ->
- ( Where = 0 ->
- FunctorInfo = functor_unshared(Ptag, Args)
- ; Where > 0 ->
- FunctorInfo = functor_remote(Ptag, Sectag, Args)
- ;
- FunctorInfo = functor_local(Ptag, Sectag)
- )
- ; get_notag_functor_info(Univ, ExpUniv) ->
- FunctorInfo = functor_notag(ExpUniv)
- ; get_equiv_functor_info(Univ, ExpUniv) ->
- FunctorInfo = functor_equiv(ExpUniv)
- ;
- fail
- ).
-
- % Given a value of an arbitrary type, succeed if its type is defined
- % as a notag type, and return a univ which bundles up the value
- % with the type of the single function symbol of the notag type.
-:- pred get_notag_functor_info(univ::in, univ::out) is semidet.
-
-:- pragma foreign_proc("C",
- get_notag_functor_info(Univ::in, ExpUniv::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
- MR_TypeInfo type_info;
- MR_TypeInfo exp_type_info;
- MR_TypeCtorInfo type_ctor_info;
- MR_NotagFunctorDesc *functor_desc;
- MR_Word value;
-
- MR_unravel_univ(Univ, type_info, value);
- type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
- switch (MR_type_ctor_rep(type_ctor_info)) {
- case MR_TYPECTOR_REP_NOTAG:
- case MR_TYPECTOR_REP_NOTAG_USEREQ:
- functor_desc = MR_type_ctor_functors(type_ctor_info).functors_notag;
- exp_type_info = MR_pseudo_type_info_is_ground(
- functor_desc->MR_notag_functor_arg_type);
- MR_new_univ_on_hp(ExpUniv, exp_type_info, value);
- SUCCESS_INDICATOR = TRUE;
- break;
-
- case MR_TYPECTOR_REP_NOTAG_GROUND:
- case MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ:
- functor_desc = MR_type_ctor_functors(type_ctor_info).functors_notag;
- exp_type_info = MR_create_type_info(
- MR_TYPEINFO_GET_FIRST_ORDER_ARG_VECTOR(type_info),
- functor_desc->MR_notag_functor_arg_type);
- MR_new_univ_on_hp(ExpUniv, exp_type_info, value);
- SUCCESS_INDICATOR = TRUE;
- break;
-
- default:
- SUCCESS_INDICATOR = FALSE;
- break;
- }
-}").
-
-:- pragma foreign_proc("MC++",
- get_notag_functor_info(_Univ::in, _ExpUniv::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"
- mercury::runtime::Errors::SORRY(""foreign code for get_notag_functor_info"");
-").
-
- % Given a value of an arbitrary type, succeed if its type is defined
- % as an equivalence type, and return a univ which bundles up the value
- % with the equivalent type. (I.e. this removes one layer of equivalence
- % from the type stored in the univ.)
-:- pred get_equiv_functor_info(univ::in, univ::out) is semidet.
-
-:- pragma foreign_proc("C",
- get_equiv_functor_info(Univ::in, ExpUniv::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
- MR_TypeInfo type_info;
- MR_TypeInfo exp_type_info;
- MR_TypeCtorInfo type_ctor_info;
- MR_Word value;
-
- MR_unravel_univ(Univ, type_info, value);
- type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
- switch (MR_type_ctor_rep(type_ctor_info)) {
- case MR_TYPECTOR_REP_EQUIV:
- exp_type_info = MR_pseudo_type_info_is_ground(
- MR_type_ctor_layout(type_ctor_info).layout_equiv);
- MR_new_univ_on_hp(ExpUniv, exp_type_info, value);
- SUCCESS_INDICATOR = TRUE;
- break;
-
- case MR_TYPECTOR_REP_EQUIV_GROUND:
- exp_type_info = MR_create_type_info(
- MR_TYPEINFO_GET_FIRST_ORDER_ARG_VECTOR(type_info),
- MR_type_ctor_layout(type_ctor_info).layout_equiv);
- MR_new_univ_on_hp(ExpUniv, exp_type_info, value);
- SUCCESS_INDICATOR = TRUE;
- break;
-
- default:
- SUCCESS_INDICATOR = FALSE;
- break;
- }
-}").
-
-:- pragma foreign_proc("MC++",
- get_equiv_functor_info(_Univ::in, _ExpUniv::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"
- mercury::runtime::Errors::SORRY(""foreign code for get_equiv_functor_info"");
-").
-
- % Given a value of an arbitrary type, succeed if it is an enum type,
- % and return the integer value corresponding to the value.
-:- pred get_enum_functor_info(univ::in, int::out) is semidet.
-
-:- pragma foreign_proc("C",
- get_enum_functor_info(Univ::in, Enum::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
- MR_TypeInfo type_info;
- MR_TypeCtorInfo type_ctor_info;
- MR_Word value;
-
- MR_unravel_univ(Univ, type_info, value);
- type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
- switch (MR_type_ctor_rep(type_ctor_info)) {
- case MR_TYPECTOR_REP_ENUM:
- case MR_TYPECTOR_REP_ENUM_USEREQ:
- Enum = (MR_Integer) value;
- SUCCESS_INDICATOR = TRUE;
- break;
-
- default:
- SUCCESS_INDICATOR = FALSE;
- break;
- }
-}").
-
-:- pragma foreign_proc("MC++",
- get_enum_functor_info(_Univ::in, _Enum::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
- mercury::runtime::Errors::SORRY(""foreign code for get_enum_functor_info"");
-}").
-
- % Given a value of an arbitrary type, succeed if it is a general du type
- % (i.e. non-enum, non-notag du type), and return the top function symbol's
- % arguments as well as its tag information: an indication of where the
- % secondary tag is (-1 for local secondary tag, 0 for nonexistent secondary
- % tag, and 1 for remote secondary tag), as well as the primary and
- % secondary tags themselves (the secondary tag argument will be meaningful
- % only if the secondary tag exists, of course).
-:- pred get_du_functor_info(univ::in, int::out, int::out, int::out,
- list(univ)::out) is semidet.
-
-:- pragma foreign_proc("C",
- get_du_functor_info(Univ::in, Where::out, Ptag::out, Sectag::out,
- Args::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
- MR_TypeInfo type_info;
- MR_TypeCtorInfo type_ctor_info;
- const MR_DuPtagLayout *ptag_layout;
- const MR_DuFunctorDesc *functor_desc;
- MR_Word value;
- MR_Word *arg_vector;
- int i;
-
- MR_unravel_univ(Univ, type_info, value);
- type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
- switch (MR_type_ctor_rep(type_ctor_info)) {
- case MR_TYPECTOR_REP_DU:
- case MR_TYPECTOR_REP_DU_USEREQ:
- SUCCESS_INDICATOR = TRUE;
- Ptag = MR_tag(value);
- ptag_layout = &MR_type_ctor_layout(type_ctor_info).layout_du[Ptag];
-
- switch(ptag_layout->MR_sectag_locn) {
- case MR_SECTAG_LOCAL:
- Where = -1;
- Sectag = MR_unmkbody(value);
- Args = MR_list_empty();
- break;
-
- case MR_SECTAG_REMOTE:
- case MR_SECTAG_NONE:
- if (ptag_layout->MR_sectag_locn == MR_SECTAG_NONE) {
- Where = 0;
- arg_vector = (MR_Word *) MR_body(value, Ptag);
- Sectag = 0;
- } else {
- Where = 1;
- arg_vector = (MR_Word *) MR_body(value, Ptag);
- Sectag = arg_vector[0];
- arg_vector++;
- }
-
- functor_desc = ptag_layout->MR_sectag_alternatives[Sectag];
- if (functor_desc->MR_du_functor_exist_info != NULL) {
- SUCCESS_INDICATOR = FALSE;
- break;
- }
-
- Args = MR_list_empty_msg(MR_PROC_LABEL);
- for (i = functor_desc->MR_du_functor_orig_arity - 1;
- i >= 0; i--)
- {
- MR_Word arg;
- MR_TypeInfo arg_type_info;
-
- if (MR_arg_type_may_contain_var(functor_desc, i)) {
- arg_type_info = MR_create_type_info_maybe_existq(
- MR_TYPEINFO_GET_FIRST_ORDER_ARG_VECTOR(
- type_info),
- functor_desc->MR_du_functor_arg_types[i],
- arg_vector, functor_desc);
- } else {
- arg_type_info = MR_pseudo_type_info_is_ground(
- functor_desc->MR_du_functor_arg_types[i]);
- }
-
- MR_new_univ_on_hp(arg,
- arg_type_info, arg_vector[i]);
- Args = MR_list_cons_msg(arg, Args, MR_PROC_LABEL);
- }
- break;
-
- case MR_SECTAG_VARIABLE:
- MR_fatal_error(
- ""get_du_functor_info: unexpected variable"");
-
- default:
- MR_fatal_error(
- ""get_du_functor_info: unknown sectag locn"");
- }
- break;
-
- default:
- SUCCESS_INDICATOR = FALSE;
- break;
- }
-}").
-
-:- pragma foreign_proc("MC++",
- get_du_functor_info(_Univ::in, _Where::out, _Ptag::out, _Sectag::out,
- _Args::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"
- mercury::runtime::Errors::SORRY(""foreign code for get_du_functor_info"");
-").
-
-%-----------------------------------------------------------------------------%
-
- % This predicate returns the type_info for the type std_util:type_info.
- % It is intended for use from C code, since Mercury code can access
- % this type_info easily enough even without this predicate.
-:- pred get_type_info_for_type_info(type_desc).
-:- mode get_type_info_for_type_info(out) is det.
-
-:- pragma export(get_type_info_for_type_info(out),
- "ML_get_type_info_for_type_info").
-
-get_type_info_for_type_info(TypeInfo) :-
- Type = type_of(1),
- TypeInfo = type_of(Type).
-
-%-----------------------------------------------------------------------------%
-%-----------------------------------------------------------------------------%
-% Ralph Becket <rwab1 at cam.sri.com> 24/04/99
-% Function forms added.
-
-pair(X, Y) =
- X-Y.
-
-maybe_func(PF, X) =
- ( if Y = PF(X) then yes(Y) else no ).
-
-compose(F, G, X) =
- F(G(X)).
-
-converse(F, X, Y) =
- F(Y, X).
-
-pow(F, N, X) =
- ( if N = 0 then X else pow(F, N - 1, F(X)) ).
-
-isnt(P, X) :-
- not P(X).
-
-id(X) = X.
-
-solutions(P) = S :- solutions(P, S).
-
-solutions_set(P) = S :- solutions_set(P, S).
+solutions_set(P) = S :- solutions_set(P, S).
aggregate(P, F, Acc0) = Acc :-
aggregate(P, (pred(X::in, A0::in, A::out) is det :- A = F(X, A0)),
Acc0, Acc).
-
-%------------------------------------------------------------------------------%
-
-dynamic_cast(X, Y) :-
- univ_to_type(univ(X), Y).
%------------------------------------------------------------------------------%
%------------------------------------------------------------------------------%
Index: library/type_desc.m
===================================================================
RCS file: library/type_desc.m
diff -N library/type_desc.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ library/type_desc.m 29 Jan 2002 10:31:31 -0000
@@ -0,0 +1,677 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2002 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.
+%-----------------------------------------------------------------------------%
+
+% File: types.m.
+% Main author: fjh, zs.
+% Stability: low.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- module type_desc.
+
+:- interface.
+
+:- import_module list.
+
+ % The `type_desc' and `type_ctor_desc' types: these
+ % provide access to type information.
+ % A type_desc represents a type, e.g. `list(int)'.
+ % A type_ctor_desc represents a type constructor, e.g. `list/1'.
+
+:- type type_desc.
+:- type type_ctor_desc.
+
+ % (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'.
+ % `void' is a special (builtin) type that has no constructors.
+ % There is no way of creating an object of type `void'.
+ % `void' is not considered to be a discriminated union, so
+ % get_functor/5 and construct/3 will fail if used upon a value
+ % of this type.)
+
+ % 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.
+
+ % The predicate has_type/2 is basically an existentially typed
+ % inverse to the function type_of/1. It constrains the type
+ % of the first argument to be the type represented by the
+ % second argument.
+:- some [T] pred has_type(T::unused, type_desc__type_desc::in) is det.
+
+ % type_name(Type) returns the name of the specified type
+ % (e.g. type_name(type_of([2,3])) = "list:list(int)").
+ % Any equivalence types will be fully expanded.
+ % Builtin types (those defined in builtin.m) will
+ % not have a module qualifier.
+ %
+:- func type_name(type_desc__type_desc) = string.
+
+ % 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.
+ %
+ % For example, type_ctor_and_args(type_of([2,3]), TypeCtor,
+ % TypeArgs) will bind `TypeCtor' to a representation of the
+ % type constructor list/1, and will bind `TypeArgs' to the list
+ % `[Int]', where `Int' is a representation of the type `int'.
+ %
+ % Note that the requirement that `TypeCtor' not be an
+ % equivalence type is fulfilled by fully expanding any
+ % equivalence types. For example, if you have a declaration
+ % `:- type foo == bar.', then type_ctor_and_args/3 will always
+ % return a representation of type constructor `bar/0', not `foo/0'.
+ % (If you don't want them expanded, you can use the reverse mode
+ % of make_type/2 instead.)
+ %
+:- pred type_ctor_and_args(type_desc__type_desc::in,
+ type_desc__type_ctor_desc::out, list(type_desc__type_desc)::out)
+ is det.
+
+ % type_ctor(Type) = TypeCtor :-
+ % type_ctor_and_args(Type, TypeCtor, _).
+ %
+:- func type_ctor(type_desc__type_desc) = type_desc__type_ctor_desc.
+
+ % type_args(Type) = TypeArgs :-
+ % type_ctor_and_args(Type, _, TypeArgs).
+ %
+:- func type_args(type_desc__type_desc) = list(type_desc__type_desc).
+
+ % type_ctor_name(TypeCtor) returns the name of specified
+ % type constructor.
+ % (e.g. type_ctor_name(type_ctor(type_of([2,3]))) = "list").
+ %
+:- func type_ctor_name(type_desc__type_ctor_desc) = string.
+
+ % type_ctor_module_name(TypeCtor) returns the module name of specified
+ % type constructor.
+ % (e.g. type_ctor_module_name(type_ctor(type_of(2))) = "builtin").
+ %
+:- func type_ctor_module_name(type_desc__type_ctor_desc) = string.
+
+ % type_ctor_arity(TypeCtor) returns the arity of specified
+ % type constructor.
+ % (e.g. type_ctor_arity(type_ctor(type_of([2,3]))) = 1).
+ %
+:- func type_ctor_arity(type_desc__type_ctor_desc) = int.
+
+ % type_ctor_name_and_arity(TypeCtor, ModuleName, TypeName, Arity) :-
+ % Name = type_ctor_name(TypeCtor),
+ % ModuleName = type_ctor_module_name(TypeCtor),
+ % Arity = type_ctor_arity(TypeCtor).
+ %
+:- pred type_ctor_name_and_arity(type_desc__type_ctor_desc::in,
+ string::out, string::out, int::out) is det.
+
+ % make_type(TypeCtor, TypeArgs) = Type:
+ % True iff `Type' is a type constructed by applying
+ % the type constructor `TypeCtor' to the type arguments
+ % `TypeArgs'.
+ %
+ % Operationally, the forwards mode returns the type formed by
+ % applying the specified type constructor to the specified
+ % argument types, or fails if the length of TypeArgs is not the
+ % same as the arity of TypeCtor. The reverse mode returns a
+ % type constructor and its argument types, given a type_desc;
+ % the type constructor returned may be an equivalence type
+ % (and hence this reverse mode of make_type/2 may be more useful
+ % for some purposes than the type_ctor/1 function).
+ %
+:- func make_type(type_desc__type_ctor_desc, list(type_desc__type_desc)) =
+ type_desc__type_desc.
+:- mode make_type(in, in) = out is semidet.
+:- mode make_type(out, out) = in is cc_multi.
+
+ % det_make_type(TypeCtor, TypeArgs):
+ %
+ % Returns the type formed by applying the specified type
+ % constructor to the specified argument types. Aborts if the
+ % length of `TypeArgs' is not the same as the arity of `TypeCtor'.
+ %
+:- func det_make_type(type_desc__type_ctor_desc, list(type_desc__type_desc)) =
+ type_desc__type_desc.
+
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module bool, string, require.
+:- use_module rtti_implementation.
+
+:- pragma foreign_decl("C", "
+#include ""mercury_heap.h"" /* for MR_incr_hp_msg() etc. */
+#include ""mercury_misc.h"" /* for MR_fatal_error() */
+#include ""mercury_string.h"" /* for MR_make_aligned_string() */
+#include ""mercury_type_desc.h""
+").
+
+ % We need to call the rtti_implementation module -- so that we get the
+ % dependencies right it's easiest to do it from Mercury.
+
+:- pragma export(call_rtti_compare_type_infos(out, in, in),
+ "ML_call_rtti_compare_type_infos").
+
+:- pred call_rtti_compare_type_infos(comparison_result::out,
+ rtti_implementation__type_info::in, rtti_implementation__type_info::in)
+ is det.
+
+call_rtti_compare_type_infos(Res, T1, T2) :-
+ rtti_implementation__compare_type_infos(Res, T1, T2).
+
+:- pragma foreign_code("C", "
+
+#include ""mercury_deep_profiling_hand.h""
+
+/* Ensure that the initialization code for the above module gets run. */
+/*
+INIT sys_init_type_desc_module
+*/
+
+/* suppress gcc -Wmissing-decl warnings */
+void sys_init_type_desc_module_init(void);
+void sys_init_type_desc_module_init_type_tables(void);
+#ifdef MR_DEEP_PROFILING
+void sys_init_type_desc_module_write_out_proc_statics(FILE *);
+#endif
+
+#ifndef MR_HIGHLEVEL_CODE
+
+#ifdef MR_DEEP_PROFILING
+MR_proc_static_compiler_empty(type_desc, __Unify__, type_desc, 0, 0,
+ ""type_desc.m"", 0, TRUE);
+MR_proc_static_compiler_empty(type_desc, __Compare__, type_desc, 0, 0,
+ ""type_desc.m"", 0, TRUE);
+#endif
+
+MR_DEFINE_BUILTIN_TYPE_CTOR_INFO(type_desc, type_desc, 0,
+ MR_TYPECTOR_REP_TYPEINFO);
+
+MR_define_extern_entry(mercury____Unify___type_desc__type_desc_0_0);
+MR_define_extern_entry(mercury____Compare___type_desc__type_desc_0_0);
+
+MR_BEGIN_MODULE(type_desc_module)
+ MR_init_entry(mercury____Unify___type_desc__type_desc_0_0);
+ MR_init_entry(mercury____Compare___type_desc__type_desc_0_0);
+#ifdef MR_DEEP_PROFILING
+ MR_init_label(mercury____Unify___type_desc__type_desc_0_0_i1);
+ MR_init_label(mercury____Unify___type_desc__type_desc_0_0_i2);
+ MR_init_label(mercury____Unify___type_desc__type_desc_0_0_i3);
+ MR_init_label(mercury____Unify___type_desc__type_desc_0_0_i4);
+ MR_init_label(mercury____Compare___type_desc__type_desc_0_0_i1);
+ MR_init_label(mercury____Compare___type_desc__type_desc_0_0_i2);
+#endif
+MR_BEGIN_CODE
+
+#define proc_label mercury____Unify___type_desc__type_desc_0_0
+#define proc_static MR_proc_static_compiler_name(type_desc, __Unify__, \
+ type_desc, 0, 0)
+#define body_code do { \
+ int comp; \
+ \
+ MR_save_transient_registers(); \
+ comp = MR_compare_type_info( \
+ (MR_TypeInfo) MR_r1, \
+ (MR_TypeInfo) MR_r2); \
+ MR_restore_transient_registers(); \
+ MR_r1 = (comp == MR_COMPARE_EQUAL); \
+ } while (0)
+
+#include ""mercury_hand_unify_body.h""
+
+#undef body_code
+#undef proc_static
+#undef proc_label
+
+#define proc_label mercury____Compare___type_desc__type_desc_0_0
+#define proc_static MR_proc_static_compiler_name(type_desc, __Compare__, \
+ type_desc, 0, 0)
+#define body_code do { \
+ int comp; \
+ \
+ MR_save_transient_registers(); \
+ comp = MR_compare_type_info( \
+ (MR_TypeInfo) MR_r1, \
+ (MR_TypeInfo) MR_r2); \
+ MR_restore_transient_registers(); \
+ MR_r1 = comp; \
+ } while (0)
+
+#include ""mercury_hand_compare_body.h""
+
+#undef body_code
+#undef proc_static
+#undef proc_label
+
+MR_END_MODULE
+
+MR_MODULE_STATIC_OR_EXTERN MR_ModuleFunc type_desc_module;
+
+#endif /* ! MR_HIGHLEVEL_CODE */
+
+void
+sys_init_type_desc_module_init(void)
+{
+#ifndef MR_HIGHLEVEL_CODE
+ type_desc_module();
+
+ MR_INIT_TYPE_CTOR_INFO(
+ mercury_data_type_desc__type_ctor_info_type_desc_0,
+ type_desc__type_desc_0_0);
+#endif
+}
+
+void
+sys_init_type_desc_module_init_type_tables(void)
+{
+#ifndef MR_HIGHLEVEL_CODE
+ MR_register_type_ctor_info(
+ &mercury_data_type_desc__type_ctor_info_type_desc_0);
+#endif
+}
+
+#ifdef MR_DEEP_PROFILING
+void
+sys_init_type_desc_module_write_out_proc_statics(FILE *fp)
+{
+ MR_write_out_proc_static(fp, (MR_ProcStatic *)
+ &MR_proc_static_compiler_name(type_desc, __Compare__, type_desc,
+ 0, 0));
+ MR_write_out_proc_static(fp, (MR_ProcStatic *)
+ &MR_proc_static_compiler_name(type_desc, __Unify__, type_desc,
+ 0, 0));
+}
+#endif
+
+").
+
+:- pragma foreign_code("MC++", "
+
+MR_DEFINE_BUILTIN_TYPE_CTOR_INFO(types, type_desc, 0,
+ MR_TYPECTOR_REP_TYPEINFO)
+
+static int MR_compare_type_info(MR_Word t1, MR_Word t2) {
+ MR_Word res;
+
+ mercury::types::mercury_code::ML_call_rtti_compare_type_infos(
+ &res, t1, t2);
+ return System::Convert::ToInt32(res[0]);
+}
+
+static void
+__Compare____type_desc_0_0(
+ MR_Word_Ref result, MR_Word x, MR_Word y)
+{
+ mercury::types::mercury_code::ML_call_rtti_compare_type_infos(
+ result, x, y);
+}
+
+static bool
+__Unify____type_desc_0_0(MR_Word x, MR_Word y)
+{
+ return (MR_compare_type_info(x, y) == MR_COMPARE_EQUAL);
+}
+
+static void
+special___Compare___type_desc_0_0(
+ MR_Word_Ref result, MR_Word x, MR_Word y)
+{
+ mercury::types::mercury_code::ML_call_rtti_compare_type_infos(
+ result, x, y);
+}
+
+static bool
+special___Unify___type_desc_0_0(MR_Word x, MR_Word y)
+{
+ return (MR_compare_type_info(x, y) == MR_COMPARE_EQUAL);
+}
+
+static int
+do_unify__type_desc_0_0(MR_Box x, MR_Box y)
+{
+ return mercury::type_desc__cpp_code::mercury_code::__Unify____type_desc_0_0(
+ dynamic_cast<MR_Word>(x),
+ dynamic_cast<MR_Word>(y));
+}
+
+static void
+do_compare__type_desc_0_0(
+ MR_Word_Ref result, MR_Box x, MR_Box y)
+{
+ mercury::type_desc__cpp_code::mercury_code::__Compare____type_desc_0_0(
+ result,
+ dynamic_cast<MR_Word>(x),
+ dynamic_cast<MR_Word>(y));
+}
+
+").
+
+%-----------------------------------------------------------------------------%
+
+ % Code for type manipulation.
+
+ % Prototypes and type definitions.
+
+ % A type_ctor_desc is not (quite) a subtype of type_desc,
+ % so we use a separate type for it.
+:- type type_ctor_desc ---> type_ctor_desc(c_pointer).
+
+:- pragma foreign_proc("C",
+ type_of(_Value::unused) = (TypeInfo::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+ TypeInfo = TypeInfo_for_T;
+
+ /*
+ ** We used to collapse equivalences for efficiency here,
+ ** but that's not always desirable, due to the reverse
+ ** mode of make_type/2, and efficiency of type_infos
+ ** probably isn't very important anyway.
+ */
+#if 0
+ MR_save_transient_registers();
+ TypeInfo = (MR_Word) MR_collapse_equivalences(
+ (MR_TypeInfo) TypeInfo_for_T);
+ MR_restore_transient_registers();
+#endif
+
+}").
+
+:- pragma foreign_proc("C#",
+ type_of(_Value::unused) = (TypeInfo::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+ TypeInfo = TypeInfo_for_T;
+").
+
+:- pragma foreign_proc("C",
+ has_type(_Arg::unused, TypeInfo::in),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+ TypeInfo_for_T = TypeInfo;
+").
+
+:- pragma foreign_proc("C#",
+ has_type(_Arg::unused, TypeInfo::in),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+ TypeInfo_for_T = TypeInfo;
+").
+
+% Export this function in order to use it in runtime/mercury_trace_external.c
+:- pragma export(type_name(in) = out, "ML_type_name").
+
+type_name(Type) = TypeName :-
+ type_ctor_and_args(Type, TypeCtor, ArgTypes),
+ type_ctor_name_and_arity(TypeCtor, ModuleName, Name, Arity),
+ ( Arity = 0 ->
+ UnqualifiedTypeName = Name
+ ;
+ ( ModuleName = "builtin", Name = "func" ->
+ IsFunc = yes
+ ;
+ IsFunc = no
+ ),
+ (
+ ModuleName = "builtin", Name = "{}"
+ ->
+ type_arg_names(ArgTypes, IsFunc, ArgTypeNames),
+ list__append(ArgTypeNames, ["}"], TypeStrings0),
+ TypeStrings = ["{" | TypeStrings0],
+ string__append_list(TypeStrings, UnqualifiedTypeName)
+ ;
+ IsFunc = yes,
+ ArgTypes = [FuncRetType]
+ ->
+ FuncRetTypeName = type_name(FuncRetType),
+ string__append_list(
+ ["((func) = ", FuncRetTypeName, ")"],
+ UnqualifiedTypeName)
+ ;
+ type_arg_names(ArgTypes, IsFunc, ArgTypeNames),
+ ( IsFunc = no ->
+ list__append(ArgTypeNames, [")"], TypeStrings0)
+ ;
+ TypeStrings0 = ArgTypeNames
+ ),
+ TypeNameStrings = [Name, "(" | TypeStrings0],
+ string__append_list(TypeNameStrings,
+ UnqualifiedTypeName)
+ )
+ ),
+ ( ModuleName = "builtin" ->
+ TypeName = UnqualifiedTypeName
+ ;
+ string__append_list([ModuleName, ":",
+ UnqualifiedTypeName], TypeName)
+ ).
+
+ % Turn the types into a list of strings representing an argument
+ % list, adding commas as separators as required. For example:
+ % ["TypeName1", ",", "TypeName2"]
+ % If formatting a function type, we close the parentheses around
+ % the function's input parameters, e.g.
+ % ["TypeName1", ",", "TypeName2", ") = ", "ReturnTypeName"]
+ % It is the caller's reponsibility to add matching parentheses.
+
+:- pred type_arg_names(list(type_desc__type_desc)::in, bool::in,
+ list(string)::out) is det.
+
+type_arg_names([], _, []).
+type_arg_names([Type | Types], IsFunc, ArgNames) :-
+ Name = type_name(Type),
+ ( Types = [] ->
+ ArgNames = [Name]
+ ; IsFunc = yes, Types = [FuncReturnType] ->
+ FuncReturnName = type_name(FuncReturnType),
+ ArgNames = [Name, ") = ", FuncReturnName]
+ ;
+ type_arg_names(Types, IsFunc, Names),
+ ArgNames = [Name, ", " | Names]
+ ).
+
+type_args(Type) = ArgTypes :-
+ type_ctor_and_args(Type, _TypeCtor, ArgTypes).
+
+type_ctor_name(TypeCtor) = Name :-
+ type_ctor_name_and_arity(TypeCtor, _ModuleName, Name, _Arity).
+
+type_ctor_module_name(TypeCtor) = ModuleName :-
+ type_ctor_name_and_arity(TypeCtor, ModuleName, _Name, _Arity).
+
+type_ctor_arity(TypeCtor) = Arity :-
+ type_ctor_name_and_arity(TypeCtor, _ModuleName, _Name, Arity).
+
+det_make_type(TypeCtor, ArgTypes) = Type :-
+ ( make_type(TypeCtor, ArgTypes) = NewType ->
+ Type = NewType
+ ;
+ error("det_make_type/2: make_type/2 failed (wrong arity)")
+ ).
+
+%-----------------------------------------------------------------------------%
+
+:- pragma foreign_proc("C",
+ type_ctor(TypeInfo::in) = (TypeCtor::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+ MR_TypeCtorInfo type_ctor_info;
+ MR_TypeInfo type_info;
+
+ MR_save_transient_registers();
+ type_info = MR_collapse_equivalences((MR_TypeInfo) TypeInfo);
+ MR_restore_transient_registers();
+
+ type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
+
+ TypeCtor = (MR_Word) MR_make_type_ctor_desc(type_info, type_ctor_info);
+}").
+
+:- pragma foreign_proc("C#", type_ctor(_TypeInfo::in) = (_TypeCtor::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+ mercury.runtime.Errors.SORRY(""foreign code for type_ctor"");
+ _TypeCtor = null;
+}").
+
+:- pragma foreign_proc("C",
+ type_ctor_and_args(TypeDesc::in, TypeCtorDesc::out, ArgTypes::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+ MR_TypeCtorDesc type_ctor_desc;
+ MR_TypeInfo type_info;
+
+ MR_save_transient_registers();
+
+ type_info = (MR_TypeInfo) TypeDesc;
+ MR_type_ctor_and_args(type_info, TRUE, &type_ctor_desc, &ArgTypes);
+ TypeCtorDesc = (MR_Word) type_ctor_desc;
+
+ MR_restore_transient_registers();
+}").
+
+type_ctor_and_args(TypeDesc::in, TypeCtorDesc::out, ArgTypes::out) :-
+ rtti_implementation__type_ctor_and_args(
+ rtti_implementation__unsafe_cast(TypeDesc),
+ TypeCtorDesc0, ArgTypes0),
+ TypeCtorDesc = rtti_implementation__unsafe_cast(TypeCtorDesc0),
+ ArgTypes = rtti_implementation__unsafe_cast(ArgTypes0).
+
+ /*
+ ** This is the forwards mode of make_type/2:
+ ** given a type constructor and a list of argument
+ ** types, check that the length of the argument
+ ** types matches the arity of the type constructor,
+ ** and if so, use the type constructor to construct
+ ** a new type with the specified arguments.
+ */
+
+:- pragma foreign_proc("C",
+ make_type(TypeCtorDesc::in, ArgTypes::in) = (TypeDesc::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+ MR_TypeCtorDesc type_ctor_desc;
+ MR_TypeCtorInfo type_ctor_info;
+ MR_Word arg_type;
+ int list_length;
+ int arity;
+
+ type_ctor_desc = (MR_TypeCtorDesc) TypeCtorDesc;
+
+ if (MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(type_ctor_desc)) {
+ arity = MR_TYPECTOR_DESC_GET_VA_ARITY(type_ctor_desc);
+ } else {
+ type_ctor_info = MR_TYPECTOR_DESC_GET_FIXED_ARITY_TYPE_CTOR_INFO(
+ type_ctor_desc);
+ arity = type_ctor_info->MR_type_ctor_arity;
+ }
+
+ arg_type = ArgTypes;
+ for (list_length = 0; ! MR_list_is_empty(arg_type); list_length++) {
+ arg_type = MR_list_tail(arg_type);
+ }
+
+ if (list_length != arity) {
+ SUCCESS_INDICATOR = FALSE;
+ } else {
+ MR_save_transient_registers();
+ TypeDesc = (MR_Word) MR_make_type(arity, type_ctor_desc,
+ ArgTypes);
+ MR_restore_transient_registers();
+ SUCCESS_INDICATOR = TRUE;
+ }
+}").
+
+:- pragma foreign_proc("C#",
+ make_type(_TypeCtorDesc::in, _ArgTypes::in) = (_TypeDesc::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+ mercury.runtime.Errors.SORRY(""make_type"");
+ // XXX this is required to keep the C# compiler quiet
+ SUCCESS_INDICATOR = false;
+}").
+
+ /*
+ ** This is the reverse mode of make_type: given a type,
+ ** split it up into a type constructor and a list of
+ ** arguments.
+ */
+
+:- pragma foreign_proc("C",
+ make_type(TypeCtorDesc::out, ArgTypes::out) = (TypeDesc::in),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+ MR_TypeCtorDesc type_ctor_desc;
+ MR_TypeInfo type_info;
+
+ MR_save_transient_registers();
+
+ type_info = (MR_TypeInfo) TypeDesc;
+ MR_type_ctor_and_args(type_info, FALSE, &type_ctor_desc, &ArgTypes);
+ TypeCtorDesc = (MR_Word) type_ctor_desc;
+
+ MR_restore_transient_registers();
+}").
+
+:- pragma foreign_proc("C",
+ type_ctor_name_and_arity(TypeCtorDesc::in, TypeCtorModuleName::out,
+ TypeCtorName::out, TypeCtorArity::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+ MR_TypeCtorDesc type_ctor_desc;
+
+ type_ctor_desc = (MR_TypeCtorDesc) TypeCtorDesc;
+
+ if (MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(type_ctor_desc)) {
+ TypeCtorModuleName = (MR_String) (MR_Word)
+ MR_TYPECTOR_DESC_GET_VA_MODULE_NAME(type_ctor_desc);
+ TypeCtorName = (MR_String) (MR_Word)
+ MR_TYPECTOR_DESC_GET_VA_NAME(type_ctor_desc);
+ TypeCtorArity = MR_TYPECTOR_DESC_GET_VA_ARITY(type_ctor_desc);
+ } else {
+ MR_TypeCtorInfo type_ctor_info;
+
+ type_ctor_info = MR_TYPECTOR_DESC_GET_FIXED_ARITY_TYPE_CTOR_INFO(
+ type_ctor_desc);
+
+ /*
+ ** We cast away the const-ness of the module and type names,
+ ** because MR_String is defined as char *, not const char *.
+ */
+
+ TypeCtorModuleName = (MR_String) (MR_Integer)
+ MR_type_ctor_module_name(type_ctor_info);
+ TypeCtorName = (MR_String) (MR_Integer)
+ MR_type_ctor_name(type_ctor_info);
+ TypeCtorArity = type_ctor_info->MR_type_ctor_arity;
+ }
+}").
+
+%-----------------------------------------------------------------------------%
+
+ % This function returns the type_info for the builtin type "typeinfo"
+ % itself. It is intended for use from C code, since Mercury code can
+ % access this type_info easily enough even without this predicate.
+ %
+ % XXX This code relies on the type "type_desc:type_desc" being the
+ % same type as the builtin type "typeinfo".
+
+:- func get_type_info_for_type_info = type_desc__type_desc.
+
+:- pragma export(get_type_info_for_type_info = out,
+ "ML_get_type_info_for_type_info").
+
+get_type_info_for_type_info = TypeDesc :-
+ Type = type_of(1),
+ TypeDesc = type_of(Type).
+
+%-----------------------------------------------------------------------------%
cvs diff: Diffing profiler
cvs diff: Diffing robdd
cvs diff: Diffing runtime
Index: runtime/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/Mmakefile,v
retrieving revision 1.81
diff -u -b -r1.81 Mmakefile
--- runtime/Mmakefile 28 Jan 2002 07:17:51 -0000 1.81
+++ runtime/Mmakefile 28 Jan 2002 07:27:23 -0000
@@ -40,6 +40,7 @@
mercury_calls.h \
mercury_conf.h \
mercury_conf_param.h \
+ mercury_construct.h \
mercury_context.h \
mercury_debug.h \
mercury_deconstruct.h \
@@ -91,6 +92,7 @@
mercury_trace_base.h \
mercury_trail.h \
mercury_types.h \
+ mercury_type_desc.h \
mercury_type_info.h \
mercury_type_tables.h \
mercury_wrapper.h \
@@ -139,6 +141,7 @@
mercury_accurate_gc.c \
mercury_agc_debug.c \
mercury_bootstrap.c \
+ mercury_construct.c \
mercury_context.c \
mercury_debug.c \
mercury_deconstruct.c \
@@ -176,6 +179,7 @@
mercury_timing.c \
mercury_trace_base.c \
mercury_trail.c \
+ mercury_type_desc.c \
mercury_type_info.c \
mercury_type_tables.c \
mercury_wrapper.c
Index: runtime/mercury.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury.c,v
retrieving revision 1.32
diff -u -b -r1.32 mercury.c
--- runtime/mercury.c 28 Jan 2002 17:27:57 -0000 1.32
+++ runtime/mercury.c 29 Jan 2002 12:02:26 -0000
@@ -86,7 +86,7 @@
mercury__builtin__do_unify__c_pointer_0_0,
mercury__builtin__do_unify__func_0_0,
mercury__builtin__do_unify__pred_0_0,
- mercury__std_util__do_unify__type_desc_0_0;
+ mercury__type_desc__do_unify__type_desc_0_0;
static MR_UnifyFunc_1
mercury__builtin__do_unify__tuple_0_0,
@@ -104,7 +104,7 @@
mercury__builtin__do_compare__c_pointer_0_0,
mercury__builtin__do_compare__func_0_0,
mercury__builtin__do_compare__pred_0_0,
- mercury__std_util__do_compare__type_desc_0_0;
+ mercury__type_desc__do_compare__type_desc_0_0;
static MR_CompareFunc_1
mercury__builtin__do_compare__tuple_0_0,
@@ -129,9 +129,9 @@
MR_define_type_ctor_info(builtin, void, 0, MR_TYPECTOR_REP_VOID);
MR_define_type_ctor_info(builtin, c_pointer, 0, MR_TYPECTOR_REP_C_POINTER);
MR_define_type_ctor_info(builtin, pred, 0, MR_TYPECTOR_REP_PRED);
-MR_define_type_ctor_info(builtin, func, 0, MR_TYPECTOR_REP_PRED);
+MR_define_type_ctor_info(builtin, func, 0, MR_TYPECTOR_REP_FUNC);
MR_define_type_ctor_info(builtin, tuple, 0, MR_TYPECTOR_REP_TUPLE);
-MR_define_type_ctor_info(std_util, type_desc, 0, MR_TYPECTOR_REP_TYPEINFO);
+MR_define_type_ctor_info(type_desc, type_desc, 0, MR_TYPECTOR_REP_TYPEINFO);
MR_define_type_ctor_info(private_builtin, type_ctor_info, 1,
MR_TYPECTOR_REP_TYPECTORINFO);
MR_define_type_ctor_info(private_builtin, type_info, 1,
@@ -179,6 +179,9 @@
} else if (type_ctor_rep == MR_TYPECTOR_REP_PRED) {
return mercury__builtin____Unify____pred_0_0((MR_Pred) x,
(MR_Pred) y);
+ } else if (type_ctor_rep == MR_TYPECTOR_REP_FUNC) {
+ return mercury__builtin____Unify____pred_0_0((MR_Pred) x,
+ (MR_Pred) y);
}
arity = type_ctor_info->MR_type_ctor_arity;
@@ -244,6 +247,9 @@
} else if (type_ctor_rep == MR_TYPECTOR_REP_PRED) {
mercury__builtin____Compare____pred_0_0(res,
(MR_Pred) x, (MR_Pred) y);
+ } else if (type_ctor_rep == MR_TYPECTOR_REP_FUNC) {
+ mercury__builtin____Compare____pred_0_0(res,
+ (MR_Pred) x, (MR_Pred) y);
return;
}
@@ -404,7 +410,7 @@
}
bool MR_CALL
-mercury__std_util____Unify____type_desc_0_0(MR_Type_Desc x, MR_Type_Desc y)
+mercury__type_desc____Unify____type_desc_0_0(MR_Type_Desc x, MR_Type_Desc y)
{
int comp;
@@ -551,7 +557,7 @@
}
void MR_CALL
-mercury__std_util____Compare____type_desc_0_0(
+mercury__type_desc____Compare____type_desc_0_0(
MR_Comparison_Result *result, MR_Type_Desc x, MR_Type_Desc y)
{
int comp;
@@ -663,9 +669,9 @@
}
static bool MR_CALL
-mercury__std_util__do_unify__type_desc_0_0(MR_Box x, MR_Box y)
+mercury__type_desc__do_unify__type_desc_0_0(MR_Box x, MR_Box y)
{
- return mercury__std_util____Unify____type_desc_0_0(
+ return mercury__type_desc____Unify____type_desc_0_0(
(MR_Type_Desc) x, (MR_Type_Desc) y);
}
@@ -780,10 +786,10 @@
}
static void MR_CALL
-mercury__std_util__do_compare__type_desc_0_0(
+mercury__type_desc__do_compare__type_desc_0_0(
MR_Comparison_Result *result, MR_Box x, MR_Box y)
{
- mercury__std_util____Compare____type_desc_0_0(
+ mercury__type_desc____Compare____type_desc_0_0(
result, (MR_Type_Desc) x, (MR_Type_Desc) y);
}
Index: runtime/mercury.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury.h,v
retrieving revision 1.44
diff -u -b -r1.44 mercury.h
--- runtime/mercury.h 28 Jan 2002 05:30:31 -0000 1.44
+++ runtime/mercury.h 29 Jan 2002 12:06:32 -0000
@@ -317,7 +317,7 @@
mercury__builtin__builtin__type_ctor_info_tuple_0,
mercury__array__array__type_ctor_info_array_1,
mercury__std_util__std_util__type_ctor_info_univ_0,
- mercury__std_util__std_util__type_ctor_info_type_desc_0,
+ mercury__type_desc__type_desc__type_ctor_info_type_desc_0,
mercury__private_builtin__private_builtin__type_ctor_info_type_ctor_info_1,
mercury__private_builtin__private_builtin__type_ctor_info_type_info_1,
mercury__private_builtin__private_builtin__type_ctor_info_typeclass_info_1,
@@ -543,7 +543,7 @@
bool MR_CALL mercury__builtin____Unify____pred_0_0(MR_Pred x, MR_Pred y);
bool MR_CALL mercury__builtin____Unify____tuple_0_0(
MR_Mercury_Type_Info type_info, MR_Tuple x, MR_Tuple y);
-bool MR_CALL mercury__std_util____Unify____type_desc_0_0(
+bool MR_CALL mercury__type_desc____Unify____type_desc_0_0(
MR_Type_Desc x, MR_Type_Desc y);
bool MR_CALL mercury__private_builtin____Unify____type_ctor_info_1_0(
MR_Mercury_Type_Info type_info,
@@ -577,7 +577,7 @@
void MR_CALL mercury__builtin____Compare____tuple_0_0(
MR_Mercury_Type_Info type_info, MR_Comparison_Result *result,
MR_Tuple x, MR_Tuple y);
-void MR_CALL mercury__std_util____Compare____type_desc_0_0(
+void MR_CALL mercury__type_desc____Compare____type_desc_0_0(
MR_Comparison_Result *result, MR_Type_Desc x, MR_Type_Desc y);
void MR_CALL mercury__private_builtin____Compare____type_ctor_info_1_0(
MR_Mercury_Type_Info type_info, MR_Comparison_Result *result,
Index: runtime/mercury_construct.c
===================================================================
RCS file: runtime/mercury_construct.c
diff -N runtime/mercury_construct.c
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ runtime/mercury_construct.c 29 Jan 2002 12:26:48 -0000
@@ -0,0 +1,321 @@
+/*
+** vim:ts=4 sw=4 expandtab
+*/
+/*
+** Copyright (C) 2002 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.
+*/
+
+/*
+** mercury_construct.c
+**
+** This file provides utility functions for constructing terms, for use by
+** the standard library.
+*/
+
+#include "mercury_conf.h"
+#ifndef MR_HIGHLEVEL_CODE
+ #include "mercury_imp.h"
+#endif
+#include "mercury_type_info.h"
+#include "mercury_construct.h"
+#include "mercury_misc.h" /* for MR_fatal_error() */
+
+static int MR_get_functor_info(MR_TypeInfo type_info, int functor_number,
+ MR_Construct_Info *construct_info);
+
+/*
+** MR_get_functor_info:
+**
+** Extract the information for functor number `functor_number',
+** for the type represented by type_info.
+** We succeed if the type is some sort of discriminated union.
+**
+** You need to save and restore transient registers around
+** calls to this function.
+*/
+
+static int
+MR_get_functor_info(MR_TypeInfo type_info, int functor_number,
+ MR_Construct_Info *construct_info)
+{
+ MR_TypeCtorInfo type_ctor_info;
+
+ type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
+ construct_info->type_ctor_rep = MR_type_ctor_rep(type_ctor_info);
+
+ switch(MR_type_ctor_rep(type_ctor_info)) {
+
+ case MR_TYPECTOR_REP_RESERVED_ADDR:
+ case MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ:
+ case MR_TYPECTOR_REP_DU:
+ case MR_TYPECTOR_REP_DU_USEREQ:
+ {
+ MR_DuFunctorDesc *functor_desc;
+
+ if (functor_number < 0 ||
+ functor_number >= MR_type_ctor_num_functors(type_ctor_info))
+ {
+ MR_fatal_error("MR_get_functor_info: "
+ "du functor_number out of range");
+ }
+
+ functor_desc = MR_type_ctor_functors(type_ctor_info).
+ functors_du[functor_number];
+ construct_info->functor_info.du_functor_desc = functor_desc;
+ construct_info->functor_name = functor_desc->MR_du_functor_name;
+ construct_info->arity = functor_desc->MR_du_functor_orig_arity;
+ construct_info->arg_pseudo_type_infos =
+ functor_desc->MR_du_functor_arg_types;
+ construct_info->arg_names =
+ functor_desc->MR_du_functor_arg_names;
+ }
+ break;
+
+ case MR_TYPECTOR_REP_ENUM:
+ case MR_TYPECTOR_REP_ENUM_USEREQ:
+ {
+ MR_EnumFunctorDesc *functor_desc;
+
+ if (functor_number < 0 ||
+ functor_number >= MR_type_ctor_num_functors(type_ctor_info))
+ {
+ MR_fatal_error("MR_get_functor_info: "
+ "enum functor_number out of range");
+ }
+
+ functor_desc = MR_type_ctor_functors(type_ctor_info).
+ functors_enum[functor_number];
+ construct_info->functor_info.enum_functor_desc = functor_desc;
+ construct_info->functor_name = functor_desc->MR_enum_functor_name;
+ construct_info->arity = 0;
+ construct_info->arg_pseudo_type_infos = NULL;
+ construct_info->arg_names = NULL;
+ }
+ break;
+
+ case MR_TYPECTOR_REP_NOTAG:
+ case MR_TYPECTOR_REP_NOTAG_USEREQ:
+ case MR_TYPECTOR_REP_NOTAG_GROUND:
+ case MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ:
+ {
+ MR_NotagFunctorDesc *functor_desc;
+
+ if (functor_number != 0) {
+ MR_fatal_error("MR_get_functor_info: "
+ "notag functor_number out of range");
+ }
+
+ functor_desc = MR_type_ctor_functors(type_ctor_info).functors_notag;
+ construct_info->functor_info.notag_functor_desc = functor_desc;
+ construct_info->functor_name = functor_desc->MR_notag_functor_name;
+ construct_info->arity = 1;
+ construct_info->arg_pseudo_type_infos =
+ &functor_desc->MR_notag_functor_arg_type;
+ construct_info->arg_names =
+ &functor_desc->MR_notag_functor_arg_name;
+ }
+ break;
+
+ case MR_TYPECTOR_REP_EQUIV_GROUND:
+ case MR_TYPECTOR_REP_EQUIV:
+ return MR_get_functor_info(
+ MR_create_type_info(
+ MR_TYPEINFO_GET_FIRST_ORDER_ARG_VECTOR(type_info),
+ MR_type_ctor_layout(type_ctor_info).layout_equiv),
+ functor_number, construct_info);
+
+ case MR_TYPECTOR_REP_TUPLE:
+ construct_info->functor_name = "{}";
+ construct_info->arity = MR_TYPEINFO_GET_TUPLE_ARITY(type_info);
+
+ /* Tuple types don't have pseudo-type_infos for the functors. */
+ construct_info->arg_pseudo_type_infos = NULL;
+ construct_info->arg_names = NULL;
+ break;
+
+ case MR_TYPECTOR_REP_INT:
+ case MR_TYPECTOR_REP_CHAR:
+ case MR_TYPECTOR_REP_FLOAT:
+ case MR_TYPECTOR_REP_STRING:
+ case MR_TYPECTOR_REP_FUNC:
+ case MR_TYPECTOR_REP_PRED:
+ case MR_TYPECTOR_REP_VOID:
+ case MR_TYPECTOR_REP_C_POINTER:
+ case MR_TYPECTOR_REP_TYPEINFO:
+ case MR_TYPECTOR_REP_TYPECTORINFO:
+ case MR_TYPECTOR_REP_TYPECLASSINFO:
+ case MR_TYPECTOR_REP_BASETYPECLASSINFO:
+ case MR_TYPECTOR_REP_ARRAY:
+ case MR_TYPECTOR_REP_SUCCIP:
+ case MR_TYPECTOR_REP_HP:
+ case MR_TYPECTOR_REP_CURFR:
+ case MR_TYPECTOR_REP_MAXFR:
+ case MR_TYPECTOR_REP_REDOFR:
+ case MR_TYPECTOR_REP_REDOIP:
+ case MR_TYPECTOR_REP_TRAIL_PTR:
+ case MR_TYPECTOR_REP_TICKET:
+ return FALSE;
+
+ case MR_TYPECTOR_REP_UNKNOWN:
+ default:
+ MR_fatal_error(":construct - unexpected type.");
+ }
+
+ return TRUE;
+}
+
+/*
+** MR_typecheck_arguments:
+**
+** Given a list of univs (`arg_list'), and a vector of
+** type_infos (`arg_vector'), checks that they are all of the
+** same type; if so, returns TRUE, otherwise returns FALSE;
+** `arg_vector' may contain type variables, these
+** will be filled in by the type arguments of `type_info'.
+**
+** Assumes the length of the list has already been checked.
+**
+** You need to save and restore transient registers around
+** calls to this function.
+*/
+
+bool
+MR_typecheck_arguments(MR_TypeInfo type_info, int arity, MR_Word arg_list,
+ const MR_PseudoTypeInfo *arg_pseudo_type_infos)
+{
+ MR_TypeInfo arg_type_info;
+ MR_TypeInfo list_arg_type_info;
+ int comp;
+ int i;
+
+ /* Type check list of arguments */
+
+ for (i = 0; i < arity; i++) {
+ if (MR_list_is_empty(arg_list)) {
+ return FALSE;
+ }
+
+ list_arg_type_info = (MR_TypeInfo) MR_field(MR_UNIV_TAG,
+ MR_list_head(arg_list), MR_UNIV_OFFSET_FOR_TYPEINFO);
+
+ if (MR_TYPE_CTOR_INFO_IS_TUPLE(
+ MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info)))
+ {
+ arg_type_info = MR_TYPEINFO_GET_TUPLE_ARG_VECTOR(type_info)[i + 1];
+ } else {
+ arg_type_info = MR_create_type_info(
+ MR_TYPEINFO_GET_FIRST_ORDER_ARG_VECTOR(type_info),
+ arg_pseudo_type_infos[i]);
+ }
+
+ comp = MR_compare_type_info(list_arg_type_info, arg_type_info);
+ if (comp != MR_COMPARE_EQUAL) {
+ return FALSE;
+ }
+ arg_list = MR_list_tail(arg_list);
+ }
+
+ /* List should now be empty */
+ return MR_list_is_empty(arg_list);
+}
+
+/*
+** MR_get_functors_check_range:
+**
+** Check that functor_number is in range, and get the functor
+** info if it is. Return FALSE if it is out of range, or
+** if MR_get_functor_info returns FALSE, otherwise return TRUE.
+**
+** You need to save and restore transient registers around
+** calls to this function.
+*/
+
+bool
+MR_get_functors_check_range(int functor_number, MR_TypeInfo type_info,
+ MR_Construct_Info *construct_info)
+{
+ /*
+ ** Check range of functor_number, get functors
+ ** vector
+ */
+ return functor_number < MR_get_num_functors(type_info) &&
+ functor_number >= 0 &&
+ MR_get_functor_info(type_info, functor_number, construct_info);
+}
+
+/*
+** MR_get_num_functors:
+**
+** Get the number of functors for a type. If it isn't a
+** discriminated union, return -1.
+**
+** You need to save and restore transient registers around
+** calls to this function.
+*/
+
+int
+MR_get_num_functors(MR_TypeInfo type_info)
+{
+ MR_TypeCtorInfo type_ctor_info;
+ MR_Integer functors;
+
+ type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
+
+ switch(MR_type_ctor_rep(type_ctor_info)) {
+ case MR_TYPECTOR_REP_DU:
+ case MR_TYPECTOR_REP_DU_USEREQ:
+ case MR_TYPECTOR_REP_RESERVED_ADDR:
+ case MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ:
+ case MR_TYPECTOR_REP_ENUM:
+ case MR_TYPECTOR_REP_ENUM_USEREQ:
+ functors = MR_type_ctor_num_functors(type_ctor_info);
+ break;
+
+ case MR_TYPECTOR_REP_NOTAG:
+ case MR_TYPECTOR_REP_NOTAG_USEREQ:
+ case MR_TYPECTOR_REP_NOTAG_GROUND:
+ case MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ:
+ case MR_TYPECTOR_REP_TUPLE:
+ functors = 1;
+ break;
+
+ case MR_TYPECTOR_REP_EQUIV_GROUND:
+ case MR_TYPECTOR_REP_EQUIV:
+ functors = MR_get_num_functors(
+ MR_create_type_info((MR_TypeInfo *) type_info,
+ MR_type_ctor_layout(type_ctor_info).layout_equiv));
+ break;
+
+ case MR_TYPECTOR_REP_INT:
+ case MR_TYPECTOR_REP_CHAR:
+ case MR_TYPECTOR_REP_FLOAT:
+ case MR_TYPECTOR_REP_STRING:
+ case MR_TYPECTOR_REP_FUNC:
+ case MR_TYPECTOR_REP_PRED:
+ case MR_TYPECTOR_REP_VOID:
+ case MR_TYPECTOR_REP_C_POINTER:
+ case MR_TYPECTOR_REP_TYPEINFO:
+ case MR_TYPECTOR_REP_TYPECTORINFO:
+ case MR_TYPECTOR_REP_TYPECLASSINFO:
+ case MR_TYPECTOR_REP_BASETYPECLASSINFO:
+ case MR_TYPECTOR_REP_ARRAY:
+ case MR_TYPECTOR_REP_SUCCIP:
+ case MR_TYPECTOR_REP_HP:
+ case MR_TYPECTOR_REP_CURFR:
+ case MR_TYPECTOR_REP_MAXFR:
+ case MR_TYPECTOR_REP_REDOFR:
+ case MR_TYPECTOR_REP_REDOIP:
+ case MR_TYPECTOR_REP_TRAIL_PTR:
+ case MR_TYPECTOR_REP_TICKET:
+ functors = -1;
+ break;
+
+ case MR_TYPECTOR_REP_UNKNOWN:
+ default:
+ MR_fatal_error("MR_get_num_functors: unknown type_ctor_rep");
+ }
+
+ return functors;
+}
Index: runtime/mercury_construct.h
===================================================================
RCS file: runtime/mercury_construct.h
diff -N runtime/mercury_construct.h
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ runtime/mercury_construct.h 29 Jan 2002 12:26:31 -0000
@@ -0,0 +1,80 @@
+/*
+** Copyright (C) 2002 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.
+*/
+
+/*
+** mercury_construct.h
+**
+** This module provides utility functions for constructing terms, for use by
+** the standard library.
+*/
+
+#ifndef MERCURY_CONSTRUCT_H
+#define MERCURY_CONSTRUCT_H
+
+#include "mercury_types.h"
+#include "mercury_type_info.h"
+#include "mercury_stack_layout.h"
+
+typedef struct MR_Construct_Info_Struct {
+ MR_ConstString functor_name;
+ MR_Integer arity;
+ const MR_PseudoTypeInfo *arg_pseudo_type_infos;
+ const MR_ConstString *arg_names;
+ MR_TypeCtorRep type_ctor_rep;
+ union {
+ const MR_EnumFunctorDesc *enum_functor_desc;
+ const MR_NotagFunctorDesc *notag_functor_desc;
+ const MR_DuFunctorDesc *du_functor_desc;
+ } functor_info;
+} MR_Construct_Info;
+
+/*
+** MR_get_num_functors:
+**
+** Get the number of functors for a type. If it isn't a
+** discriminated union, return -1.
+**
+** You need to save and restore transient registers around
+** calls to this function.
+*/
+
+extern int MR_get_num_functors(MR_TypeInfo type_info);
+
+/*
+** MR_get_functors_check_range:
+**
+** Check that functor_number is in range, and get the functor
+** info if it is. Return FALSE if it is out of range, or
+** if MR_get_functor_info returns FALSE, otherwise return TRUE.
+**
+** You need to save and restore transient registers around
+** calls to this function.
+*/
+
+extern bool MR_get_functors_check_range(int functor_number,
+ MR_TypeInfo type_info,
+ MR_Construct_Info *construct_info);
+
+/*
+** MR_typecheck_arguments:
+**
+** Given a list of univs (`arg_list'), and a vector of
+** type_infos (`arg_vector'), checks that they are all of the
+** same type; if so, returns TRUE, otherwise returns FALSE;
+** `arg_vector' may contain type variables, these
+** will be filled in by the type arguments of `type_info'.
+**
+** Assumes the length of the list has already been checked.
+**
+** You need to save and restore transient registers around
+** calls to this function.
+*/
+
+extern bool MR_typecheck_arguments(MR_TypeInfo type_info,
+ int arity, MR_Word arg_list,
+ const MR_PseudoTypeInfo *arg_pseudo_type_infos);
+
+#endif /* MERCURY_CONSTRUCT_H */
Index: runtime/mercury_deconstruct.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_deconstruct.c,v
retrieving revision 1.3
diff -u -b -r1.3 mercury_deconstruct.c
--- runtime/mercury_deconstruct.c 25 Jan 2002 08:23:21 -0000 1.3
+++ runtime/mercury_deconstruct.c 28 Jan 2002 02:36:39 -0000
@@ -200,7 +200,8 @@
{
MR_ReservedAddrTypeLayout ra_layout;
- ra_layout = MR_type_ctor_layout(type_ctor_info).layout_reserved_addr;
+ ra_layout = MR_type_ctor_layout(type_ctor_info).
+ layout_reserved_addr;
data = *term_ptr;
/*
@@ -295,19 +296,12 @@
return MR_named_arg_num(eqv_type_info, term_ptr, arg_name,
arg_num_ptr);
- case MR_TYPECTOR_REP_EQUIV_VAR:
- /*
- ** The current version of the RTTI gives all such equivalence types
- ** the EQUIV type_ctor_rep, not EQUIV_VAR.
- */
- MR_fatal_error("unexpected EQUIV_VAR type_ctor_rep");
- break;
-
case MR_TYPECTOR_REP_NOTAG:
case MR_TYPECTOR_REP_NOTAG_USEREQ:
case MR_TYPECTOR_REP_NOTAG_GROUND:
case MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ:
- notag_functor_desc = MR_type_ctor_functors(type_ctor_info).functors_notag;
+ notag_functor_desc = MR_type_ctor_functors(type_ctor_info).
+ functors_notag;
if (notag_functor_desc->MR_notag_functor_arg_name != NULL
&& streq(arg_name, notag_functor_desc->MR_notag_functor_arg_name))
Index: runtime/mercury_deep_copy_body.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_deep_copy_body.h,v
retrieving revision 1.43
diff -u -b -r1.43 mercury_deep_copy_body.h
--- runtime/mercury_deep_copy_body.h 28 Jan 2002 17:27:57 -0000 1.43
+++ runtime/mercury_deep_copy_body.h 29 Jan 2002 03:59:14 -0000
@@ -403,14 +403,6 @@
goto try_again;
break;
- case MR_TYPECTOR_REP_EQUIV_VAR:
- /*
- ** The current version of the RTTI gives all equivalence types
- ** the EQUIV type_ctor_rep, not EQUIV_VAR.
- */
- MR_fatal_error("unexpected EQUIV_VAR type_ctor_rep");
- break;
-
case MR_TYPECTOR_REP_INT: /* fallthru */
case MR_TYPECTOR_REP_CHAR:
new_data = data;
@@ -470,6 +462,7 @@
}
break;
+ case MR_TYPECTOR_REP_FUNC:
case MR_TYPECTOR_REP_PRED:
{
MR_Word *data_value;
Index: runtime/mercury_init.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_init.h,v
retrieving revision 1.30
diff -u -b -r1.30 mercury_init.h
--- runtime/mercury_init.h 4 Dec 2001 00:44:34 -0000 1.30
+++ runtime/mercury_init.h 28 Jan 2002 13:43:04 -0000
@@ -85,6 +85,7 @@
mercury_runtime_terminate(),
etc. */
#include "mercury_trace_base.h" /* for MR_trace_port */
+#include "mercury_type_info.h" /* for MR_TypeCtorInfo_Struct */
#ifdef CONSERVATIVE_GC
#include "gc.h"
Index: runtime/mercury_mcpp.cpp
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_mcpp.cpp,v
retrieving revision 1.11
diff -u -b -r1.11 mercury_mcpp.cpp
--- runtime/mercury_mcpp.cpp 28 Jan 2002 17:27:59 -0000 1.11
+++ runtime/mercury_mcpp.cpp 29 Jan 2002 10:23:02 -0000
@@ -130,7 +130,7 @@
static int MR_TYPECTOR_REP_NOTAG = 4;
static int MR_TYPECTOR_REP_NOTAG_USEREQ = 5;
static int MR_TYPECTOR_REP_EQUIV = 6;
- static int MR_TYPECTOR_REP_EQUIV_VAR = 7;
+ static int MR_TYPECTOR_REP_FUNC = 7;
static int MR_TYPECTOR_REP_INT = 8;
static int MR_TYPECTOR_REP_CHAR = 9;
static int MR_TYPECTOR_REP_FLOAT =10;
Index: runtime/mercury_mcpp.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_mcpp.h,v
retrieving revision 1.15
diff -u -b -r1.15 mercury_mcpp.h
--- runtime/mercury_mcpp.h 28 Jan 2002 17:27:59 -0000 1.15
+++ runtime/mercury_mcpp.h 29 Jan 2002 04:02:31 -0000
@@ -128,9 +128,7 @@
#define MR_TYPECTOR_REP_NOTAG_val 4
#define MR_TYPECTOR_REP_NOTAG_USEREQ_val 5
#define MR_TYPECTOR_REP_EQUIV_val 6
- // MR_TYPECTOR_REP_EQUIV_VAR_val is unused - it is retained
- // only for backwards compatability.
-#define MR_TYPECTOR_REP_EQUIV_VAR_val 7
+#define MR_TYPECTOR_REP_FUNC_val 7
#define MR_TYPECTOR_REP_INT_val 8
#define MR_TYPECTOR_REP_CHAR_val 9
#define MR_TYPECTOR_REP_FLOAT_val 10
Index: runtime/mercury_ml_expand_body.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_ml_expand_body.h,v
retrieving revision 1.11
diff -u -b -r1.11 mercury_ml_expand_body.h
--- runtime/mercury_ml_expand_body.h 28 Jan 2002 17:27:59 -0000 1.11
+++ runtime/mercury_ml_expand_body.h 29 Jan 2002 03:59:14 -0000
@@ -544,14 +544,6 @@
data_word_ptr, EXTRA_ARGS expand_info);
break;
- case MR_TYPECTOR_REP_EQUIV_VAR:
- /*
- ** The current version of the RTTI gives all such equivalence types
- ** the EQUIV type_ctor_rep, not EQUIV_VAR.
- */
- MR_fatal_error("unexpected EQUIV_VAR type_ctor_rep");
- break;
-
case MR_TYPECTOR_REP_INT:
#ifdef EXPAND_FUNCTOR_FIELD
{
@@ -626,6 +618,12 @@
}
#endif /* EXPAND_FUNCTOR_FIELD */
+ handle_zero_arity_args();
+ break;
+
+ case MR_TYPECTOR_REP_FUNC:
+ /* XXX expand_info->non_canonical_type = TRUE; */
+ handle_functor_name("<<function>>");
handle_zero_arity_args();
break;
Index: runtime/mercury_tabling.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_tabling.c,v
retrieving revision 1.47
diff -u -b -r1.47 mercury_tabling.c
--- runtime/mercury_tabling.c 28 Jan 2002 17:27:59 -0000 1.47
+++ runtime/mercury_tabling.c 29 Jan 2002 03:59:14 -0000
@@ -826,14 +826,6 @@
MR_type_ctor_layout(type_ctor_info).layout_equiv), data);
break;
- case MR_TYPECTOR_REP_EQUIV_VAR:
- /*
- ** The current version of the RTTI gives all equivalence types
- ** the EQUIV type_ctor_rep, not EQUIV_VAR.
- */
- MR_fatal_error("unexpected EQUIV_VAR type_ctor_rep");
- break;
-
case MR_TYPECTOR_REP_INT:
MR_DEBUG_TABLE_INT(table, data);
break;
@@ -850,11 +842,12 @@
MR_DEBUG_TABLE_STRING(table, (MR_String) data);
break;
+ case MR_TYPECTOR_REP_FUNC:
case MR_TYPECTOR_REP_PRED:
{
/*
** XXX tabling of the closures by tabling their code address
- ** and arguments is not yet implemented, due to the difficulty
+ ** and arguments is not yet implemented, due to the overhead
** of figuring out the closure argument types.
*/
#if 0
Index: runtime/mercury_type_desc.c
===================================================================
RCS file: runtime/mercury_type_desc.c
diff -N runtime/mercury_type_desc.c
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ runtime/mercury_type_desc.c 29 Jan 2002 12:17:09 -0000
@@ -0,0 +1,134 @@
+/*
+** Copyright (C) 2002 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.
+*/
+
+/*
+** This module exists to handle user-visible descriptions of types and type
+** constructors.
+*/
+
+#include "mercury_conf.h"
+#ifndef MR_HIGHLEVEL_CODE
+ #include "mercury_imp.h"
+#endif
+#include "mercury_type_info.h"
+#include "mercury_type_desc.h"
+#include "mercury_heap.h" /* for MR_incr_hp_atomic_msg() */
+#include "mercury_misc.h" /* for MR_fatal_error() */
+
+MR_TypeCtorDesc
+MR_make_type_ctor_desc(MR_TypeInfo type_info, 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_TYPEINFO_GET_HIGHER_ORDER_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.");
+ }
+ } else if (MR_TYPE_CTOR_INFO_IS_HO_FUNC(type_ctor_info)) {
+ type_ctor_desc = MR_TYPECTOR_DESC_MAKE_FUNC(
+ MR_TYPEINFO_GET_HIGHER_ORDER_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.");
+ }
+ } else if (MR_TYPE_CTOR_INFO_IS_TUPLE(type_ctor_info)) {
+ type_ctor_desc = MR_TYPECTOR_DESC_MAKE_TUPLE(
+ MR_TYPEINFO_GET_TUPLE_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.");
+ }
+ } else {
+ type_ctor_desc = MR_TYPECTOR_DESC_MAKE_FIXED_ARITY(
+ type_ctor_info);
+ }
+
+ return type_ctor_desc;
+}
+
+void
+MR_type_ctor_and_args(MR_TypeInfo type_info, 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 (collapse_equivalences) {
+ type_info = MR_collapse_equivalences(type_info);
+ }
+
+ type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
+ type_ctor_desc = MR_make_type_ctor_desc(type_info, type_ctor_info);
+ *type_ctor_desc_ptr = type_ctor_desc;
+
+ if (MR_type_ctor_rep_is_variable_arity(
+ MR_type_ctor_rep(type_ctor_info)))
+ {
+ arity = MR_TYPECTOR_DESC_GET_VA_ARITY(type_ctor_desc);
+ *arg_type_info_list_ptr = MR_type_params_vector_to_list(arity,
+ MR_TYPEINFO_GET_HIGHER_ORDER_ARG_VECTOR(type_info));
+ } else {
+ arity = type_ctor_info->MR_type_ctor_arity;
+ *arg_type_info_list_ptr = MR_type_params_vector_to_list(arity,
+ MR_TYPEINFO_GET_FIRST_ORDER_ARG_VECTOR(type_info));
+ }
+}
+
+MR_TypeInfo
+MR_make_type(int arity, MR_TypeCtorDesc type_ctor_desc, MR_Word arg_types_list)
+{
+ MR_TypeCtorInfo type_ctor_info;
+ MR_Word *new_type_info_arena;
+ MR_TypeInfo *new_type_info_args;
+ int i;
+
+ /*
+ ** We need to treat variable-arity types as a special case here.
+ */
+
+ if (MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(type_ctor_desc)) {
+ type_ctor_info = MR_TYPECTOR_DESC_GET_VA_TYPE_CTOR_INFO(
+ type_ctor_desc);
+
+ MR_restore_transient_registers();
+ MR_incr_hp_atomic_msg(
+ MR_LVALUE_CAST(MR_Word, new_type_info_arena),
+ MR_higher_order_type_info_size(arity),
+ "MR_make_type", "type_info");
+ MR_save_transient_registers();
+ MR_fill_in_higher_order_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);
+
+ if (arity == 0) {
+ return (MR_TypeInfo) type_ctor_info;
+ }
+
+ MR_restore_transient_registers();
+ MR_incr_hp_atomic_msg(
+ MR_LVALUE_CAST(MR_Word, new_type_info_arena),
+ MR_first_order_type_info_size(arity),
+ "MR_make_type", "type_info");
+ MR_save_transient_registers();
+ MR_fill_in_first_order_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);
+ arg_types_list = MR_list_tail(arg_types_list);
+ }
+
+ return (MR_TypeInfo) new_type_info_arena;
+}
Index: runtime/mercury_type_desc.h
===================================================================
RCS file: runtime/mercury_type_desc.h
diff -N runtime/mercury_type_desc.h
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ runtime/mercury_type_desc.h 29 Jan 2002 12:16:28 -0000
@@ -0,0 +1,159 @@
+/*
+** Copyright (C) 2002 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.
+*/
+
+/*
+**
+*/
+
+#ifndef MERCURY_TYPE_DESC_H
+#define MERCURY_TYPE_DESC_H
+
+#include "mercury_types.h"
+#include "mercury_type_info.h"
+#include "mercury_wrapper.h" /* for MR_address_of_type_ctor_info_for_pred ... */
+
+/*
+** Values of type `types: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
+** represented the same way as values of type `private_builtin:type_ctor_info'.
+** The representations *are* in fact identical for first order 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.
+** 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'.
+*/
+
+/*
+** Declare the MR_TypeCtorDesc ADT.
+**
+** Note that `struct MR_TypeCtorDesc_Struct' is deliberately left undefined.
+** MR_TypeCtorDesc is declared as a pointer to a dummy structure only
+** in order to allow the C compiler to catch errors in which things other
+** than MR_TypeCtorDescs are given as arguments to macros that depend on their
+** arguments being MR_TypeCtorDescs. The actual value is either a small integer
+** or a pointer to a MR_TypeCtorInfo_Struct structure, as described above.
+*/
+
+typedef struct MR_TypeCtorDesc_Struct *MR_TypeCtorDesc;
+
+/*
+** The maximum arity that can be encoded should be set to twice the maximum
+** number of general purpose registers, since an predicate or function having
+** more arguments that this would run out of registers when passing the input
+** arguments, or the output arguments, or both.
+**
+** XXX When tuples were added this was reduced to be the maximum number
+** of general purpose registers, to reduce the probability that the
+** `small' integers for higher-order and tuple types are confused with
+** type_ctor_info pointers. This still allows higher-order terms with
+** 1024 arguments, which is more than ../LIMITATIONS promises.
+*/
+
+#define MR_MAX_VARIABLE_ARITY MR_MAX_VIRTUAL_REG
+
+/*
+** Constructors for the MR_TypeCtorDesc ADT
+*/
+
+#define MR_TYPECTOR_DESC_MAKE_PRED(Arity) \
+ ( (MR_TypeCtorDesc) ((Arity) * 4) )
+#define MR_TYPECTOR_DESC_MAKE_FUNC(Arity) \
+ ( (MR_TypeCtorDesc) ((Arity) * 4 + 1) )
+#define MR_TYPECTOR_DESC_MAKE_TUPLE(Arity) \
+ ( (MR_TypeCtorDesc) ((Arity) * 4 + 2) )
+#define MR_TYPECTOR_DESC_MAKE_FIXED_ARITY(type_ctor_info) \
+ ( MR_CHECK_EXPR_TYPE(type_ctor_info, MR_TypeCtorInfo), \
+ (MR_TypeCtorDesc) type_ctor_info )
+
+/*
+** Access macros for the MR_TypeCtor ADT.
+**
+** The MR_TYPECTOR_DESC_GET_VA_* macros should only be called if
+** MR_TYPECTOR_DESC_IS_VARIABLE_ARITY() returns true.
+** The MR_TYPECTOR_DESC_GET_FIXED_ARITY_TYPE_CTOR_INFO() macro
+** should only be called if MR_TYPECTOR_DESC_IS_VARIABLE_ARITY() returns false.
+*/
+
+#define MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(T) \
+ ( MR_CHECK_EXPR_TYPE(T, MR_TypeCtorDesc), \
+ (MR_Unsigned) (T) <= (4 * MR_MAX_VARIABLE_ARITY + 2) )
+#define MR_TYPECTOR_DESC_GET_FIXED_ARITY_TYPE_CTOR_INFO(T) \
+ ( MR_CHECK_EXPR_TYPE(T, MR_TypeCtorDesc), \
+ (MR_TypeCtorInfo) (T) )
+#define MR_TYPECTOR_DESC_GET_VA_ARITY(T) \
+ ( MR_CHECK_EXPR_TYPE(T, MR_TypeCtorDesc), \
+ (MR_Unsigned) (T) / 4 )
+#define MR_TYPECTOR_DESC_GET_VA_NAME(T) \
+ ( MR_CHECK_EXPR_TYPE(T, MR_TypeCtorDesc), \
+ (MR_ConstString) (((MR_Unsigned) (T) % 4 == 0) \
+ ? "pred" \
+ : (((MR_Unsigned) (T) % 4 == 1) \
+ ? "func" \
+ : "{}" )) )
+#define MR_TYPECTOR_DESC_GET_VA_MODULE_NAME(T) \
+ ( MR_CHECK_EXPR_TYPE(T, MR_TypeCtorDesc), \
+ (MR_ConstString) "builtin" )
+#define MR_TYPECTOR_DESC_GET_VA_TYPE_CTOR_INFO(T) \
+ ( MR_CHECK_EXPR_TYPE(T, MR_TypeCtorDesc), \
+ ((MR_Unsigned) (T) % 4 == 0) \
+ ? (MR_address_of_type_ctor_info_for_pred) \
+ : (((MR_Unsigned) (T) % 4 == 1) \
+ ? (MR_address_of_type_ctor_info_for_func) \
+ : (MR_address_of_type_ctor_info_for_tuple) ) )
+
+/*
+** 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 type_info, which should be the type_info that type_ctor_info was
+** extracted from.
+*/
+
+extern MR_TypeCtorDesc MR_make_type_ctor_desc(MR_TypeInfo type_info,
+ 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
+** argument types in *arg_type_info_list_ptr. If collapse_equivalences is TRUE,
+** then expand out the equivalences in type_info first.
+**
+** You need to wrap MR_{save/restore}_transient_registers() around
+** calls to this function.
+*/
+
+
+extern void MR_type_ctor_and_args(MR_TypeInfo type_info,
+ 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
+** for the type constructor, and using the arguments specified in
+** arg_types_list for the type arguments (if any).
+**
+** Assumes that the arity of the type constructor represented by type_ctor_info
+** and the length of the arg_types_list are both equal to `arity'.
+**
+** You need to wrap MR_{save/restore}_transient_registers() around
+** calls to this function.
+*/
+
+extern MR_TypeInfo MR_make_type(int arity, MR_TypeCtorDesc type_ctor_desc,
+ MR_Word arg_type_list);
+
+#endif /* MERCURY_TYPE_DESC_H */
Index: runtime/mercury_type_info.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_type_info.c,v
retrieving revision 1.46
diff -u -b -r1.46 mercury_type_info.c
--- runtime/mercury_type_info.c 28 Jan 2002 17:28:00 -0000 1.46
+++ runtime/mercury_type_info.c 29 Jan 2002 04:02:59 -0000
@@ -272,3 +272,71 @@
allocated = next;
}
}
+
+MR_Word
+MR_type_params_vector_to_list(int arity, MR_TypeInfoParams 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_list_cons((MR_Word) type_params[arity],
+ type_info_list);
+ --arity;
+ }
+
+ MR_save_transient_registers();
+ return type_info_list;
+}
+
+MR_Word
+MR_arg_name_vector_to_list(int arity, const MR_ConstString *arg_names)
+{
+ MR_TypeInfo arg_type;
+ MR_Word arg_names_list;
+
+ MR_restore_transient_registers();
+ arg_names_list = MR_list_empty();
+
+ while (arity > 0) {
+ --arity;
+ arg_names_list = MR_list_cons((MR_Word) arg_names[arity],
+ arg_names_list);
+ }
+
+ MR_save_transient_registers();
+ return arg_names_list;
+}
+
+MR_Word
+MR_pseudo_type_info_vector_to_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_restore_transient_registers();
+ type_info_list = MR_list_empty();
+
+ while (--arity >= 0) {
+ /* Get the argument type_info */
+
+ MR_save_transient_registers();
+ arg_type_info = MR_create_type_info(type_params,
+ arg_pseudo_type_infos[arity]);
+ MR_restore_transient_registers();
+
+ MR_save_transient_registers();
+ arg_type_info = MR_collapse_equivalences(arg_type_info);
+ MR_restore_transient_registers();
+
+ type_info_list = MR_list_cons((MR_Word) arg_type_info,
+ type_info_list);
+ }
+
+ MR_save_transient_registers();
+ return type_info_list;
+}
Index: runtime/mercury_type_info.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_type_info.h,v
retrieving revision 1.83
diff -u -b -r1.83 mercury_type_info.h
--- runtime/mercury_type_info.h 28 Jan 2002 17:28:00 -0000 1.83
+++ runtime/mercury_type_info.h 29 Jan 2002 07:12:37 -0000
@@ -482,7 +482,7 @@
MR_DEFINE_BUILTIN_ENUM_CONST(MR_TYPECTOR_REP_NOTAG),
MR_DEFINE_BUILTIN_ENUM_CONST(MR_TYPECTOR_REP_NOTAG_USEREQ),
MR_DEFINE_BUILTIN_ENUM_CONST(MR_TYPECTOR_REP_EQUIV),
- MR_DEFINE_BUILTIN_ENUM_CONST(MR_TYPECTOR_REP_EQUIV_VAR),
+ MR_DEFINE_BUILTIN_ENUM_CONST(MR_TYPECTOR_REP_FUNC),
MR_DEFINE_BUILTIN_ENUM_CONST(MR_TYPECTOR_REP_INT),
MR_DEFINE_BUILTIN_ENUM_CONST(MR_TYPECTOR_REP_CHAR),
MR_DEFINE_BUILTIN_ENUM_CONST(MR_TYPECTOR_REP_FLOAT),
@@ -539,7 +539,7 @@
"NOTAG", \
"NOTAG_USEREQ", \
"EQUIV", \
- "EQUIV_VAR", \
+ "FUNC", \
"INT", \
"CHAR", \
"FLOAT", \
@@ -589,6 +589,7 @@
*/
#define MR_type_ctor_rep_is_variable_arity(rep) \
( ((rep) == MR_TYPECTOR_REP_PRED) \
+ || ((rep) == MR_TYPECTOR_REP_FUNC) \
|| ((rep) == MR_TYPECTOR_REP_TUPLE))
/*---------------------------------------------------------------------------*/
@@ -1193,37 +1194,14 @@
/*---------------------------------------------------------------------------*/
-#ifdef MR_HIGHLEVEL_CODE
- extern const struct MR_TypeCtorInfo_Struct
- mercury__builtin__builtin__type_ctor_info_pred_0,
- mercury__builtin__builtin__type_ctor_info_func_0,
- mercury__builtin__builtin__type_ctor_info_tuple_0;
- #define MR_TYPE_CTOR_INFO_HO_PRED \
- (&mercury__builtin__builtin__type_ctor_info_pred_0)
- #define MR_TYPE_CTOR_INFO_HO_FUNC \
- (&mercury__builtin__builtin__type_ctor_info_func_0)
- #define MR_TYPE_CTOR_INFO_TUPLE \
- (&mercury__builtin__builtin__type_ctor_info_tuple_0)
-#else
- MR_DECLARE_TYPE_CTOR_INFO_STRUCT(mercury_data___type_ctor_info_pred_0);
- MR_DECLARE_TYPE_CTOR_INFO_STRUCT(mercury_data___type_ctor_info_func_0);
- MR_DECLARE_TYPE_CTOR_INFO_STRUCT(mercury_data___type_ctor_info_tuple_0);
- #define MR_TYPE_CTOR_INFO_HO_PRED \
- ((MR_TypeCtorInfo) &mercury_data___type_ctor_info_pred_0)
- #define MR_TYPE_CTOR_INFO_HO_FUNC \
- ((MR_TypeCtorInfo) &mercury_data___type_ctor_info_func_0)
- #define MR_TYPE_CTOR_INFO_TUPLE \
- ((MR_TypeCtorInfo) &mercury_data___type_ctor_info_tuple_0)
-#endif
-
#define MR_TYPE_CTOR_INFO_IS_HO_PRED(T) \
- (T == MR_TYPE_CTOR_INFO_HO_PRED)
+ (MR_type_ctor_rep(T) == MR_TYPECTOR_REP_PRED)
#define MR_TYPE_CTOR_INFO_IS_HO_FUNC(T) \
- (T == MR_TYPE_CTOR_INFO_HO_FUNC)
+ (MR_type_ctor_rep(T) == MR_TYPECTOR_REP_FUNC)
#define MR_TYPE_CTOR_INFO_IS_HO(T) \
(MR_TYPE_CTOR_INFO_IS_HO_FUNC(T) || MR_TYPE_CTOR_INFO_IS_HO_PRED(T))
#define MR_TYPE_CTOR_INFO_IS_TUPLE(T) \
- (T == MR_TYPE_CTOR_INFO_TUPLE)
+ (MR_type_ctor_rep(T) == MR_TYPECTOR_REP_TUPLE)
/*---------------------------------------------------------------------------*/
@@ -1331,6 +1309,47 @@
const MR_DuFunctorDesc *functor_descriptor,
MR_MemoryList *allocated);
extern void MR_deallocate(MR_MemoryList allocated_memory_cells);
+
+/*
+** MR_type_params_vector_to_list:
+**
+** Copy `arity' 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_type_params_vector_to_list(int arity,
+ MR_TypeInfoParams type_params);
+
+/*
+** ML_arg_name_vector_to_list:
+**
+** Copy `arity' argument names from the `arg_names' vector, which starts
+** at index 0, onto the Mercury heap in a list.
+**
+** You need to save and restore transient registers around
+** calls to this function.
+*/
+
+extern MR_Word MR_arg_name_vector_to_list(int arity,
+ const MR_ConstString *arg_names);
+
+/*
+** ML_pseudo_type_info_vector_to_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.
+**
+** 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,
+ const MR_PseudoTypeInfo *arg_pseudo_type_infos);
/*---------------------------------------------------------------------------*/
Index: runtime/mercury_unify_compare_body.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_unify_compare_body.h,v
retrieving revision 1.15
diff -u -b -r1.15 mercury_unify_compare_body.h
--- runtime/mercury_unify_compare_body.h 28 Jan 2002 17:28:01 -0000 1.15
+++ runtime/mercury_unify_compare_body.h 29 Jan 2002 03:59:14 -0000
@@ -292,7 +292,6 @@
case MR_TYPECTOR_REP_EQUIV:
case MR_TYPECTOR_REP_EQUIV_GROUND:
- case MR_TYPECTOR_REP_EQUIV_VAR:
case MR_TYPECTOR_REP_NOTAG:
case MR_TYPECTOR_REP_NOTAG_GROUND:
case MR_TYPECTOR_REP_RESERVED_ADDR:
@@ -585,6 +584,7 @@
case MR_TYPECTOR_REP_VOID:
MR_fatal_error(attempt_msg "terms of type `void'");
+ case MR_TYPECTOR_REP_FUNC:
case MR_TYPECTOR_REP_PRED:
MR_fatal_error(attempt_msg "higher-order terms");
Index: runtime/mercury_wrapper.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_wrapper.c,v
retrieving revision 1.95
diff -u -b -r1.95 mercury_wrapper.c
--- runtime/mercury_wrapper.c 13 Jan 2002 10:13:09 -0000 1.95
+++ runtime/mercury_wrapper.c 28 Jan 2002 13:52:40 -0000
@@ -186,6 +186,10 @@
int (*MR_address_of_do_load_aditi_rl_code)(void);
+MR_TypeCtorInfo MR_address_of_type_ctor_info_for_func;
+MR_TypeCtorInfo MR_address_of_type_ctor_info_for_pred;
+MR_TypeCtorInfo MR_address_of_type_ctor_info_for_tuple;
+
char *(*MR_address_of_trace_getline)(const char *, FILE *, FILE *);
char *(*MR_address_of_trace_get_command)(const char *, FILE *, FILE *);
const char *
Index: runtime/mercury_wrapper.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_wrapper.h,v
retrieving revision 1.45
diff -u -b -r1.45 mercury_wrapper.h
--- runtime/mercury_wrapper.h 13 Jan 2002 10:13:10 -0000 1.45
+++ runtime/mercury_wrapper.h 28 Jan 2002 13:52:29 -0000
@@ -18,6 +18,7 @@
#include "mercury_stack_layout.h" /* for `MR_Label_Layout' etc */
#include "mercury_trace_base.h" /* for `MR_trace_port' */
#include "mercury_stacks.h" /* for `MR_{Cut,Generator}StackFrame' */
+#include "mercury_type_info.h" /* for `MR_TypeCtorInfo' */
#include <stdio.h> /* for `FILE' */
/*
@@ -98,6 +99,10 @@
#endif
extern int (*MR_address_of_do_load_aditi_rl_code)(void);
+
+extern MR_TypeCtorInfo MR_address_of_type_ctor_info_for_func;
+extern MR_TypeCtorInfo MR_address_of_type_ctor_info_for_pred;
+extern MR_TypeCtorInfo MR_address_of_type_ctor_info_for_tuple;
/*
** MR_trace_getline(const char *, FILE *, FILE *) and
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
Index: tests/general/accumulator/INTRODUCED
===================================================================
RCS file: /home/mercury1/repository/tests/general/accumulator/INTRODUCED,v
retrieving revision 1.3
diff -u -b -r1.3 INTRODUCED
--- tests/general/accumulator/INTRODUCED 28 Jun 2000 07:42:58 -0000 1.3
+++ tests/general/accumulator/INTRODUCED 29 Jan 2002 14:34:31 -0000
@@ -1,7 +1,7 @@
% mode 0 `base:AccFrom__pred__p/4' (det):
% mode 0 `call_in_base:AccFrom__pred__l/4' (det):
% mode 0 `chain:AccFrom__pred__pa/4' (det):
- % mode 0 `construct:AccFrom__pred__p2/5' (det):
+ % mode 0 `construct_test:AccFrom__pred__p2/5' (det):
% mode 0 `dcg:AccFrom__pred__p/7' (det):
% mode 0 `disj:AccFrom__pred__p/3' (multi):
% mode 0 `func:AccFrom__func__sumlist/2' (det):
Index: tests/general/accumulator/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/general/accumulator/Mmakefile,v
retrieving revision 1.16
diff -u -b -r1.16 Mmakefile
--- tests/general/accumulator/Mmakefile 15 May 2001 07:12:04 -0000 1.16
+++ tests/general/accumulator/Mmakefile 29 Jan 2002 10:21:30 -0000
@@ -20,8 +20,8 @@
call_in_base \
chain \
commutative \
- construct \
- deconstruct \
+ construct_test \
+ deconstruct_test\
dcg \
disj \
func \
Index: tests/general/accumulator/construct.exp
===================================================================
RCS file: tests/general/accumulator/construct.exp
diff -N tests/general/accumulator/construct.exp
--- tests/general/accumulator/construct.exp 16 Jun 1999 06:19:21 -0000 1.1
+++ /dev/null 1 Jan 1970 00:00:00 -0000
@@ -1,2 +0,0 @@
-p1: [1, 10, 100]
-pb: [5, 6, 7, 1, 1, 1]
Index: tests/general/accumulator/construct.m
===================================================================
RCS file: tests/general/accumulator/construct.m
diff -N tests/general/accumulator/construct.m
--- tests/general/accumulator/construct.m 16 Jun 1999 06:19:21 -0000 1.1
+++ /dev/null 1 Jan 1970 00:00:00 -0000
@@ -1,53 +0,0 @@
- %
- % Tests that any construction unifications get handled properly.
- %
-:- module construct.
-
-:- interface.
-
-:- import_module io.
-
-:- pred main(io__state::di, io__state::uo) is det.
-
-:- implementation.
-
-:- import_module list.
-
-main -->
- io__write_string("p1: "),
- { p([1,10,100], ListA) },
- io__write(ListA),
- io__nl,
- io__write_string("pb: "),
- { p2([5,6,7], ListB) },
- io__write(ListB),
- io__nl.
-
-:- pred p(list(T), list(T)).
-:- mode p(in, out) is det.
-
- %
- % Direct construction unification.
- %
-p([], []).
-p(X,Y) :-
- X = [H|T],
- p(T,T0),
- Y = [H|T0].
-
- %
- % Hide the construction by introducing some intermediate
- % variables.
- %
- % This will introduce accumulators provided
- % --optimize-constructor-last-call is turned on.
- %
-:- pred p2(list(int), list(int)).
-:- mode p2(in, out) is det.
-
-p2([], []).
-p2(X,Y) :-
- X = [H|T],
- p2(T, T0),
- append(T0, [1], T1),
- Y = [H|T1].
Index: tests/general/accumulator/construct_test.exp
===================================================================
RCS file: tests/general/accumulator/construct_test.exp
diff -N tests/general/accumulator/construct_test.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/general/accumulator/construct_test.exp 16 Jun 1999 06:19:21 -0000
@@ -0,0 +1,2 @@
+p1: [1, 10, 100]
+pb: [5, 6, 7, 1, 1, 1]
Index: tests/general/accumulator/construct_test.m
===================================================================
RCS file: tests/general/accumulator/construct_test.m
diff -N tests/general/accumulator/construct_test.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/general/accumulator/construct_test.m 29 Jan 2002 14:03:41 -0000
@@ -0,0 +1,53 @@
+ %
+ % Tests that any construction unifications get handled properly.
+ %
+:- module construct_test.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io__state::di, io__state::uo) is det.
+
+:- implementation.
+
+:- import_module list.
+
+main -->
+ io__write_string("p1: "),
+ { p([1,10,100], ListA) },
+ io__write(ListA),
+ io__nl,
+ io__write_string("pb: "),
+ { p2([5,6,7], ListB) },
+ io__write(ListB),
+ io__nl.
+
+:- pred p(list(T), list(T)).
+:- mode p(in, out) is det.
+
+ %
+ % Direct construction unification.
+ %
+p([], []).
+p(X,Y) :-
+ X = [H|T],
+ p(T,T0),
+ Y = [H|T0].
+
+ %
+ % Hide the construction by introducing some intermediate
+ % variables.
+ %
+ % This will introduce accumulators provided
+ % --optimize-constructor-last-call is turned on.
+ %
+:- pred p2(list(int), list(int)).
+:- mode p2(in, out) is det.
+
+p2([], []).
+p2(X,Y) :-
+ X = [H|T],
+ p2(T, T0),
+ append(T0, [1], T1),
+ Y = [H|T1].
Index: tests/general/accumulator/deconstruct.exp
===================================================================
RCS file: tests/general/accumulator/deconstruct.exp
diff -N tests/general/accumulator/deconstruct.exp
--- tests/general/accumulator/deconstruct.exp 16 Jun 1999 06:19:23 -0000 1.1
+++ /dev/null 1 Jan 1970 00:00:00 -0000
@@ -1,2 +0,0 @@
-p1: [1000, 1, 10, 100]
-pb: wrapper(3, [7, 6, 5])
Index: tests/general/accumulator/deconstruct.m
===================================================================
RCS file: tests/general/accumulator/deconstruct.m
diff -N tests/general/accumulator/deconstruct.m
--- tests/general/accumulator/deconstruct.m 16 Jun 1999 06:19:24 -0000 1.1
+++ /dev/null 1 Jan 1970 00:00:00 -0000
@@ -1,66 +0,0 @@
- %
- % Tests that any deconstruction unifications get handled properly.
- %
-:- module deconstruct.
-
-:- interface.
-
-:- import_module io.
-
-:- pred main(io__state::di, io__state::uo) is det.
-
-:- implementation.
-
-:- import_module int, list.
-
-:- type wrapper ---> wrapper(int, list(int)).
-
-main -->
- io__write_string("p1: "),
- (
- { p([1,10,100], ListA) }
- ->
- io__write(ListA)
- ;
- io__write_string("failed")
- ),
- io__nl,
- io__write_string("pb: "),
- (
- { p2([5,6,7], ListB) }
- ->
- io__write(ListB)
- ;
- io__write_string("failed")
- ),
- io__nl.
-
-:- pred p(list(int), list(int)).
-:- mode p(in, out) is semidet.
-
- %
- % Direct deconstruction unification.
- %
-p([], [1000]).
-p(X,Y) :-
- X = [H|T],
- p(T,T0),
- T0 = [Ht | Tt],
- append([Ht], [H], NewH),
- append(NewH, Tt, Y).
-
- %
- % Using a deconstruction as a wrapper. Should introduce
- % accumlator recursion, doesn't.
- %
-:- pred p2(list(int), wrapper).
-:- mode p2(in, out) is semidet.
-
-p2([], wrapper(0, [])).
-p2(X,W) :-
- X = [H|T],
- p2(T, W0),
- W0 = wrapper(L0, R0),
- L is L0 + 1,
- append(R0, [H], R),
- W = wrapper(L, R).
Index: tests/general/accumulator/deconstruct_test.exp
===================================================================
RCS file: tests/general/accumulator/deconstruct_test.exp
diff -N tests/general/accumulator/deconstruct_test.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/general/accumulator/deconstruct_test.exp 16 Jun 1999 06:19:23 -0000
@@ -0,0 +1,2 @@
+p1: [1000, 1, 10, 100]
+pb: wrapper(3, [7, 6, 5])
Index: tests/general/accumulator/deconstruct_test.m
===================================================================
RCS file: tests/general/accumulator/deconstruct_test.m
diff -N tests/general/accumulator/deconstruct_test.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/general/accumulator/deconstruct_test.m 29 Jan 2002 04:09:52 -0000
@@ -0,0 +1,66 @@
+ %
+ % Tests that any deconstruction unifications get handled properly.
+ %
+:- module deconstruct_test.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io__state::di, io__state::uo) is det.
+
+:- implementation.
+
+:- import_module int, list.
+
+:- type wrapper ---> wrapper(int, list(int)).
+
+main -->
+ io__write_string("p1: "),
+ (
+ { p([1,10,100], ListA) }
+ ->
+ io__write(ListA)
+ ;
+ io__write_string("failed")
+ ),
+ io__nl,
+ io__write_string("pb: "),
+ (
+ { p2([5,6,7], ListB) }
+ ->
+ io__write(ListB)
+ ;
+ io__write_string("failed")
+ ),
+ io__nl.
+
+:- pred p(list(int), list(int)).
+:- mode p(in, out) is semidet.
+
+ %
+ % Direct deconstruction unification.
+ %
+p([], [1000]).
+p(X,Y) :-
+ X = [H|T],
+ p(T,T0),
+ T0 = [Ht | Tt],
+ append([Ht], [H], NewH),
+ append(NewH, Tt, Y).
+
+ %
+ % Using a deconstruction as a wrapper. Should introduce
+ % accumlator recursion, doesn't.
+ %
+:- pred p2(list(int), wrapper).
+:- mode p2(in, out) is semidet.
+
+p2([], wrapper(0, [])).
+p2(X,W) :-
+ X = [H|T],
+ p2(T, W0),
+ W0 = wrapper(L0, R0),
+ L is L0 + 1,
+ append(R0, [H], R),
+ W = wrapper(L, R).
cvs diff: Diffing tests/general/structure_reuse
cvs diff: Diffing tests/hard_coded
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/Mmakefile,v
retrieving revision 1.142
diff -u -b -r1.142 Mmakefile
--- tests/hard_coded/Mmakefile 22 Jan 2002 17:27:56 -0000 1.142
+++ tests/hard_coded/Mmakefile 29 Jan 2002 04:06:51 -0000
@@ -24,7 +24,7 @@
comparison \
constraint \
constraint_order \
- construct \
+ construct_test \
curry \
curry2 \
cut_test \
Index: tests/hard_coded/construct.exp
===================================================================
RCS file: tests/hard_coded/construct.exp
diff -N tests/hard_coded/construct.exp
--- tests/hard_coded/construct.exp 13 Jan 2001 02:30:30 -0000 1.7
+++ /dev/null 1 Jan 1970 00:00:00 -0000
@@ -1,230 +0,0 @@
-TESTING DISCRIMINATED UNIONS
-3 functors in this type
-2 - two/0
-1 - three/0
-0 - one/0
-
-
-3 functors in this type
-2 - two/0
-1 - three/0
-0 - one/0
-
-
-3 functors in this type
-2 - two/0
-1 - three/0
-0 - one/0
-
-
-2 functors in this type
-1 - banana/1
-0 - apple/1
-
-
-2 functors in this type
-1 - banana/1
-0 - apple/1
-
-
-11 functors in this type
-10 - zop/2
-9 - zoom/1
-8 - zip/2
-7 - zap/2
-6 - wombat/0
-5 - qux/1
-4 - quux/1
-3 - quuux/2
-2 - foo/0
-1 - bar/2
-0 - bar/1
-
-
-11 functors in this type
-10 - zop/2
-9 - zoom/1
-8 - zip/2
-7 - zap/2
-6 - wombat/0
-5 - qux/1
-4 - quux/1
-3 - quuux/2
-2 - foo/0
-1 - bar/2
-0 - bar/1
-
-
-11 functors in this type
-10 - zop/2
-9 - zoom/1
-8 - zip/2
-7 - zap/2
-6 - wombat/0
-5 - qux/1
-4 - quux/1
-3 - quuux/2
-2 - foo/0
-1 - bar/2
-0 - bar/1
-
-
-11 functors in this type
-10 - zop/2
-9 - zoom/1
-8 - zip/2
-7 - zap/2
-6 - wombat/0
-5 - qux/1
-4 - quux/1
-3 - quuux/2
-2 - foo/0
-1 - bar/2
-0 - bar/1
-
-
-11 functors in this type
-10 - zop/2
-9 - zoom/1
-8 - zip/2
-7 - zap/2
-6 - wombat/0
-5 - qux/1
-4 - quux/1
-3 - quuux/2
-2 - foo/0
-1 - bar/2
-0 - bar/1
-
-
-
-TESTING POLYMORPHISM
-4 functors in this type
-3 - poly_two/1
-2 - poly_three/3
-1 - poly_one/1
-0 - poly_four/2
-
-
-4 functors in this type
-3 - poly_two/1
-2 - poly_three/3
-1 - poly_one/1
-0 - poly_four/2
-
-
-4 functors in this type
-3 - poly_two/1
-2 - poly_three/3
-1 - poly_one/1
-0 - poly_four/2
-
-
-
-TESTING BUILTINS
--1 functors in this type
-
-
--1 functors in this type
-
-
--1 functors in this type
-
-
--1 functors in this type
-
-
--1 functors in this type
-
-
--1 functors in this type
-
-
--1 functors in this type
-
-
--1 functors in this type
-
-
--1 functors in this type
-
-
--1 functors in this type
-
-
--1 functors in this type
-
-
--1 functors in this type
-
-
-1 functors in this type
-0 - {}/4
-
-
-
-TESTING OTHER TYPES
-1 functors in this type
-0 - var/1
-
-
-1 functors in this type
-0 - var_supply/1
-
-
-1 functors in this type
-0 - var_supply/1
-
-
-4 functors in this type
-3 - two/4
-2 - three/7
-1 - four/10
-0 - empty/0
-
-
-1 functors in this type
-0 - qwerty/1
-
-
-
-About to construct three/0
-Constructed: three
-About to construct apple/1
-Constructed: apple([1, 2, 3])
-About to construct banana/1
-Constructed: banana([one, two, three])
-About to construct foo/0
-Constructed: foo
-About to construct bar/1
-Constructed: bar(1)
-About to construct bar/2
-Constructed: bar(1, 1)
-About to construct qux/1
-Constructed: qux(1)
-About to construct quux/1
-Constructed: quux(1)
-About to construct quuux/2
-Constructed: quuux(1, 1)
-About to construct wombat/0
-Constructed: wombat
-About to construct zoom/1
-Constructed: zoom(1)
-About to construct zap/2
-Constructed: zap(1, 2.10000000000000)
-About to construct zip/2
-Constructed: zip(1, 1)
-About to construct zop/2
-Constructed: zop(2.10000000000000, 2.10000000000000)
-About to construct qwerty/1
-Constructed: qwerty(1)
-About to construct poly_one/1
-Constructed: poly_one(1)
-About to construct poly_two/1
-Constructed: poly_two("goodbye")
-About to construct poly_four/2
-Constructed: poly_four(1, "goodbye")
-About to construct {}/3
-Constructed: {4, "five", '6'}
-About to call construct_tuple
-Constructed tuple: univ_cons({[1, 2, 3], [one, two, three], 1, 2.10000000000000})
Index: tests/hard_coded/construct.m
===================================================================
RCS file: tests/hard_coded/construct.m
diff -N tests/hard_coded/construct.m
--- tests/hard_coded/construct.m 18 Sep 2000 11:52:41 -0000 1.4
+++ /dev/null 1 Jan 1970 00:00:00 -0000
@@ -1,288 +0,0 @@
-% Test case for construct, num_functors, type_of and get_functor.
-%
-% Author: trd
-
-:- module construct.
-:- interface.
-:- import_module io.
-
-:- pred main(io__state::di, io__state::uo) is det.
-
-:- implementation.
-
-:- import_module list, int, std_util, term, map, string, require.
-
-:- pred test_builtins(io__state::di, io__state::uo) is det.
-:- pred test_discriminated(io__state::di, io__state::uo) is det.
-:- pred test_polymorphism(io__state::di, io__state::uo) is det.
-:- pred test_other(io__state::di, io__state::uo) is det.
-:- pred test_construct(io__state::di, io__state::uo) is det.
-
-:- pred newline(io__state::di, io__state::uo) is det.
-
-:- pred test_num_functors(type_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.
-
-
-:- type enum ---> one ; two ; three.
-
-:- type fruit ---> apple(list(int))
- ; banana(list(enum)).
-
-:- type thingie ---> foo ; bar(int) ; bar(int, int) ; qux(int) ;
- quux(int) ; quuux(int, int) ; wombat ;
- zoom(int) ; zap(int, float) ; zip(int, int) ;
- zop(float, float).
-
-:- type poly(A, B) ---> poly_one(A) ; poly_two(B) ;
- poly_three(B, A, poly(B, A));
- poly_four(A, B).
-
-:- type no_tag ---> qwerty(int).
-
-%----------------------------------------------------------------------------%
-
-main -->
- test_discriminated,
- test_polymorphism,
- test_builtins,
- test_other,
- test_construct.
-
-%----------------------------------------------------------------------------%
-
-test_construct -->
-
- % Valid tests.
-
- % Enumerations:
-
- test_construct_2(type_of(one), "three", 0, []),
-
- { type_to_univ([1, 2, 3], NumList) },
- test_construct_2(type_of(apple([])), "apple", 1, [NumList]),
-
- { type_to_univ([one, two, three], EnumList) },
- test_construct_2(type_of(apple([])), "banana", 1, [EnumList]),
-
- % Discriminated union:
- % (Simple, complicated and complicated constant tags).
-
- { type_to_univ(1, One) },
- { type_to_univ(2.1, TwoPointOne) },
-
- test_construct_2(type_of(wombat), "foo", 0, []),
- test_construct_2(type_of(wombat), "bar", 1, [One]),
- test_construct_2(type_of(wombat), "bar", 2, [One, One]),
- test_construct_2(type_of(wombat), "qux", 1, [One]),
- test_construct_2(type_of(wombat), "quux", 1, [One]),
- test_construct_2(type_of(wombat), "quuux", 2, [One, One]),
- test_construct_2(type_of(wombat), "wombat", 0, []),
- test_construct_2(type_of(wombat), "zoom", 1, [One]),
- test_construct_2(type_of(wombat), "zap", 2, [One, TwoPointOne]),
- test_construct_2(type_of(wombat), "zip", 2, [One, One]),
- test_construct_2(type_of(wombat), "zop", 2, [TwoPointOne, TwoPointOne]),
-
- % No-tag type:
- test_construct_2(type_of(qwerty(7)), "qwerty", 1, [One]),
-
-
- { type_to_univ("goodbye", Bye) },
-
- test_construct_2(type_of(poly_four(3, "hello")), "poly_one", 1, [One]),
- test_construct_2(type_of(poly_four(3, "hello")), "poly_two", 1, [Bye]),
- test_construct_2(type_of(poly_four(3, "hello")), "poly_four", 2,
- [One, Bye]),
- test_construct_2(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]) },
- 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.
-test_construct_2(TypeInfo, FunctorName, Arity, Args) -->
- { find_functor(TypeInfo, FunctorName, Arity, FunctorNumber) },
- io__write_string("About to construct "),
- io__write_string(FunctorName),
- io__write_string("/"),
- io__write_int(Arity),
- newline,
- (
- { Constructed = construct(TypeInfo, FunctorNumber, Args) }
- ->
- io__write_string("Constructed: "),
- io__print(Constructed),
- newline
- ;
- io__write_string("Construction failed.\n")
- ).
-
-:- pred find_functor(type_desc::in, string::in, int::in, int::out) is det.
-find_functor(TypeInfo, Functor, Arity, FunctorNumber) :-
- N = num_functors(TypeInfo),
- find_functor2(TypeInfo, Functor, Arity, N, FunctorNumber).
-
-:- pred find_functor2(type_desc::in, string::in, int::in, int::in,
- int::out) is det.
-find_functor2(TypeInfo, Functor, Arity, Num, FunctorNumber) :-
- (
- Num < 0
- ->
- error("unable to find functor")
- ;
- (
- get_functor(TypeInfo, Num, Functor, Arity, _List)
- ->
- FunctorNumber = Num
- ;
- find_functor2(TypeInfo, Functor, Arity, Num - 1,
- FunctorNumber)
- )
- ).
-
-
-
-
-%----------------------------------------------------------------------------%
-test_all(T) -->
- { TypeInfo = type_of(T) },
- test_num_functors(TypeInfo),
- test_nth_functor(TypeInfo), newline.
-
-test_num_functors(TypeInfo) -->
- { N = num_functors(TypeInfo) },
- io__write_int(N),
- io__write_string(" functors in this type"),
- newline.
-
-test_nth_functor(TypeInfo) -->
- { N = num_functors(TypeInfo) },
- test_all_functors(TypeInfo, N - 1).
-
-
-:- pred test_all_functors(type_desc::in, int::in,
- io__state::di, io__state::uo) is det.
-
-test_all_functors(TypeInfo, N) -->
- (
- { N < 0 }
- ->
- []
- ;
- io__write_int(N),
- (
- { get_functor(TypeInfo, N, Name, Arity, _List) }
- ->
- io__write_string(" - "),
- io__write_string(Name),
- io__write_string("/"),
- io__write_int(Arity),
- newline
- ;
- io__write_string(" failed "),
- newline
- ),
- test_all_functors(TypeInfo, N - 1)
- ).
-
-%----------------------------------------------------------------------------%
-
-test_discriminated -->
- io__write_string("TESTING DISCRIMINATED UNIONS\n"),
-
- % test enumerations
- test_all(two), newline,
- test_all(one), newline,
- test_all(three), newline,
-
- % test simple tags
- test_all(apple([9,5,1])), newline,
- test_all(banana([three, one, two])), newline,
-
-
- % test complicated tags
- test_all(zop(3.3, 2.03)), newline,
- test_all(zip(3, 2)), newline,
- test_all(zap(3, -2.111)), newline,
-
- % test complicated constant
-
- test_all(wombat), newline,
- test_all(foo), newline,
-
- newline.
-
-test_polymorphism -->
- io__write_string("TESTING POLYMORPHISM\n"),
- test_all(poly_three(3.33, 4, poly_one(9.11))), newline,
- test_all(poly_two(3)), newline,
- test_all(poly_one([2399.3])), newline,
-
- newline.
-
-
-test_builtins -->
- io__write_string("TESTING BUILTINS\n"),
-
- % test strings
- test_all(""), newline,
- test_all("Hello, world\n"), newline,
- test_all("Foo%sFoo"), newline,
- test_all(""""), newline,
-
- % test characters
- test_all('a'), newline,
- test_all('&'), newline,
-
- % test floats
- test_all(3.14159), newline,
- test_all(11.28324983E-22), newline,
- test_all(22.3954899E22), newline,
-
- % test integers
- test_all(-65), newline,
- test_all(4), newline,
-
- % test univ.
- %{ type_to_univ(["hi! I'm a univ!"], Univ) },
- % test_all(Univ), newline,
-
- % test predicates
- test_all(newline), newline,
-
- % test tuples
- test_all({1, "a", 'a', {4, 'd'}}), newline,
-
- newline.
-
- % Note: testing abstract types is always going to have results
- % that are dependent on the implementation. If someone changes
- % the implementation, the results of this test can change.
-
-test_other -->
- io__write_string("TESTING OTHER TYPES\n"),
- { term__init_var_supply(VarSupply) },
- { term__create_var(VarSupply, Var, NewVarSupply) },
- test_all(Var), newline,
- test_all(VarSupply), newline,
- test_all(NewVarSupply), newline,
-
- % presently, at least, map is an equivalence and
- % an abstract type.
- { map__init(Map) },
- test_all(Map), newline,
-
- % a no tag type
- test_all(qwerty(4)), newline,
-
- newline.
-
-newline -->
- io__write_char('\n').
-
-
Index: tests/hard_coded/construct_test.exp
===================================================================
RCS file: tests/hard_coded/construct_test.exp
diff -N tests/hard_coded/construct_test.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/construct_test.exp 13 Jan 2001 07:19:46 -0000
@@ -0,0 +1,230 @@
+TESTING DISCRIMINATED UNIONS
+3 functors in this type
+2 - two/0
+1 - three/0
+0 - one/0
+
+
+3 functors in this type
+2 - two/0
+1 - three/0
+0 - one/0
+
+
+3 functors in this type
+2 - two/0
+1 - three/0
+0 - one/0
+
+
+2 functors in this type
+1 - banana/1
+0 - apple/1
+
+
+2 functors in this type
+1 - banana/1
+0 - apple/1
+
+
+11 functors in this type
+10 - zop/2
+9 - zoom/1
+8 - zip/2
+7 - zap/2
+6 - wombat/0
+5 - qux/1
+4 - quux/1
+3 - quuux/2
+2 - foo/0
+1 - bar/2
+0 - bar/1
+
+
+11 functors in this type
+10 - zop/2
+9 - zoom/1
+8 - zip/2
+7 - zap/2
+6 - wombat/0
+5 - qux/1
+4 - quux/1
+3 - quuux/2
+2 - foo/0
+1 - bar/2
+0 - bar/1
+
+
+11 functors in this type
+10 - zop/2
+9 - zoom/1
+8 - zip/2
+7 - zap/2
+6 - wombat/0
+5 - qux/1
+4 - quux/1
+3 - quuux/2
+2 - foo/0
+1 - bar/2
+0 - bar/1
+
+
+11 functors in this type
+10 - zop/2
+9 - zoom/1
+8 - zip/2
+7 - zap/2
+6 - wombat/0
+5 - qux/1
+4 - quux/1
+3 - quuux/2
+2 - foo/0
+1 - bar/2
+0 - bar/1
+
+
+11 functors in this type
+10 - zop/2
+9 - zoom/1
+8 - zip/2
+7 - zap/2
+6 - wombat/0
+5 - qux/1
+4 - quux/1
+3 - quuux/2
+2 - foo/0
+1 - bar/2
+0 - bar/1
+
+
+
+TESTING POLYMORPHISM
+4 functors in this type
+3 - poly_two/1
+2 - poly_three/3
+1 - poly_one/1
+0 - poly_four/2
+
+
+4 functors in this type
+3 - poly_two/1
+2 - poly_three/3
+1 - poly_one/1
+0 - poly_four/2
+
+
+4 functors in this type
+3 - poly_two/1
+2 - poly_three/3
+1 - poly_one/1
+0 - poly_four/2
+
+
+
+TESTING BUILTINS
+-1 functors in this type
+
+
+-1 functors in this type
+
+
+-1 functors in this type
+
+
+-1 functors in this type
+
+
+-1 functors in this type
+
+
+-1 functors in this type
+
+
+-1 functors in this type
+
+
+-1 functors in this type
+
+
+-1 functors in this type
+
+
+-1 functors in this type
+
+
+-1 functors in this type
+
+
+-1 functors in this type
+
+
+1 functors in this type
+0 - {}/4
+
+
+
+TESTING OTHER TYPES
+1 functors in this type
+0 - var/1
+
+
+1 functors in this type
+0 - var_supply/1
+
+
+1 functors in this type
+0 - var_supply/1
+
+
+4 functors in this type
+3 - two/4
+2 - three/7
+1 - four/10
+0 - empty/0
+
+
+1 functors in this type
+0 - qwerty/1
+
+
+
+About to construct three/0
+Constructed: three
+About to construct apple/1
+Constructed: apple([1, 2, 3])
+About to construct banana/1
+Constructed: banana([one, two, three])
+About to construct foo/0
+Constructed: foo
+About to construct bar/1
+Constructed: bar(1)
+About to construct bar/2
+Constructed: bar(1, 1)
+About to construct qux/1
+Constructed: qux(1)
+About to construct quux/1
+Constructed: quux(1)
+About to construct quuux/2
+Constructed: quuux(1, 1)
+About to construct wombat/0
+Constructed: wombat
+About to construct zoom/1
+Constructed: zoom(1)
+About to construct zap/2
+Constructed: zap(1, 2.10000000000000)
+About to construct zip/2
+Constructed: zip(1, 1)
+About to construct zop/2
+Constructed: zop(2.10000000000000, 2.10000000000000)
+About to construct qwerty/1
+Constructed: qwerty(1)
+About to construct poly_one/1
+Constructed: poly_one(1)
+About to construct poly_two/1
+Constructed: poly_two("goodbye")
+About to construct poly_four/2
+Constructed: poly_four(1, "goodbye")
+About to construct {}/3
+Constructed: {4, "five", '6'}
+About to call construct_tuple
+Constructed tuple: univ_cons({[1, 2, 3], [one, two, three], 1, 2.10000000000000})
Index: tests/hard_coded/construct_test.m
===================================================================
RCS file: tests/hard_coded/construct_test.m
diff -N tests/hard_coded/construct_test.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/construct_test.m 29 Jan 2002 04:08:20 -0000
@@ -0,0 +1,282 @@
+% Test case for construct, num_functors, type_of and get_functor.
+%
+% Author: trd
+
+:- module construct_test.
+:- interface.
+:- import_module io.
+
+:- pred main(io__state::di, io__state::uo) is det.
+
+:- implementation.
+
+:- import_module list, int, std_util, term, map, string, require.
+
+:- pred test_builtins(io__state::di, io__state::uo) is det.
+:- pred test_discriminated(io__state::di, io__state::uo) is det.
+:- pred test_polymorphism(io__state::di, io__state::uo) is det.
+:- pred test_other(io__state::di, io__state::uo) is det.
+:- pred test_construct(io__state::di, io__state::uo) is det.
+
+:- pred newline(io__state::di, io__state::uo) is det.
+
+:- pred test_num_functors(type_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.
+
+:- type enum ---> one ; two ; three.
+
+:- type fruit ---> apple(list(int))
+ ; banana(list(enum)).
+
+:- type thingie ---> foo ; bar(int) ; bar(int, int) ; qux(int) ;
+ quux(int) ; quuux(int, int) ; wombat ;
+ zoom(int) ; zap(int, float) ; zip(int, int) ;
+ zop(float, float).
+
+:- type poly(A, B) ---> poly_one(A) ; poly_two(B) ;
+ poly_three(B, A, poly(B, A));
+ poly_four(A, B).
+
+:- type no_tag ---> qwerty(int).
+
+%----------------------------------------------------------------------------%
+
+main -->
+ test_discriminated,
+ test_polymorphism,
+ test_builtins,
+ test_other,
+ test_construct.
+
+%----------------------------------------------------------------------------%
+
+test_construct -->
+
+ % Valid tests.
+
+ % Enumerations:
+
+ test_construct_2(type_of(one), "three", 0, []),
+
+ { type_to_univ([1, 2, 3], NumList) },
+ test_construct_2(type_of(apple([])), "apple", 1, [NumList]),
+
+ { type_to_univ([one, two, three], EnumList) },
+ test_construct_2(type_of(apple([])), "banana", 1, [EnumList]),
+
+ % Discriminated union:
+ % (Simple, complicated and complicated constant tags).
+
+ { type_to_univ(1, One) },
+ { type_to_univ(2.1, TwoPointOne) },
+
+ test_construct_2(type_of(wombat), "foo", 0, []),
+ test_construct_2(type_of(wombat), "bar", 1, [One]),
+ test_construct_2(type_of(wombat), "bar", 2, [One, One]),
+ test_construct_2(type_of(wombat), "qux", 1, [One]),
+ test_construct_2(type_of(wombat), "quux", 1, [One]),
+ test_construct_2(type_of(wombat), "quuux", 2, [One, One]),
+ test_construct_2(type_of(wombat), "wombat", 0, []),
+ test_construct_2(type_of(wombat), "zoom", 1, [One]),
+ test_construct_2(type_of(wombat), "zap", 2, [One, TwoPointOne]),
+ test_construct_2(type_of(wombat), "zip", 2, [One, One]),
+ test_construct_2(type_of(wombat), "zop", 2, [TwoPointOne, TwoPointOne]),
+
+ % No-tag type:
+ test_construct_2(type_of(qwerty(7)), "qwerty", 1, [One]),
+
+ { type_to_univ("goodbye", Bye) },
+
+ test_construct_2(type_of(poly_four(3, "hello")), "poly_one", 1, [One]),
+ test_construct_2(type_of(poly_four(3, "hello")), "poly_two", 1, [Bye]),
+ test_construct_2(type_of(poly_four(3, "hello")), "poly_four", 2,
+ [One, Bye]),
+ test_construct_2(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]) },
+ 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.
+
+test_construct_2(TypeInfo, FunctorName, Arity, Args) -->
+ { find_functor(TypeInfo, FunctorName, Arity, FunctorNumber) },
+ io__write_string("About to construct "),
+ io__write_string(FunctorName),
+ io__write_string("/"),
+ io__write_int(Arity),
+ newline,
+ (
+ { Constructed = construct(TypeInfo, FunctorNumber, Args) }
+ ->
+ io__write_string("Constructed: "),
+ io__print(Constructed),
+ newline
+ ;
+ io__write_string("Construction failed.\n")
+ ).
+
+:- pred find_functor(type_desc::in, string::in, int::in, int::out) is det.
+
+find_functor(TypeInfo, Functor, Arity, FunctorNumber) :-
+ N = num_functors(TypeInfo),
+ find_functor2(TypeInfo, Functor, Arity, N, FunctorNumber).
+
+:- pred find_functor2(type_desc::in, string::in, int::in, int::in,
+ int::out) is det.
+
+find_functor2(TypeInfo, Functor, Arity, Num, FunctorNumber) :-
+ (
+ Num < 0
+ ->
+ error("unable to find functor")
+ ;
+ (
+ get_functor(TypeInfo, Num, Functor, Arity, _List)
+ ->
+ FunctorNumber = Num
+ ;
+ find_functor2(TypeInfo, Functor, Arity, Num - 1,
+ FunctorNumber)
+ )
+ ).
+
+%----------------------------------------------------------------------------%
+
+test_all(T) -->
+ { TypeInfo = type_of(T) },
+ test_num_functors(TypeInfo),
+ test_nth_functor(TypeInfo), newline.
+
+test_num_functors(TypeInfo) -->
+ { N = num_functors(TypeInfo) },
+ io__write_int(N),
+ io__write_string(" functors in this type"),
+ newline.
+
+test_nth_functor(TypeInfo) -->
+ { N = num_functors(TypeInfo) },
+ test_all_functors(TypeInfo, N - 1).
+
+:- pred test_all_functors(type_desc::in, int::in,
+ io__state::di, io__state::uo) is det.
+
+test_all_functors(TypeInfo, N) -->
+ (
+ { N < 0 }
+ ->
+ []
+ ;
+ io__write_int(N),
+ (
+ { get_functor(TypeInfo, N, Name, Arity, _List) }
+ ->
+ io__write_string(" - "),
+ io__write_string(Name),
+ io__write_string("/"),
+ io__write_int(Arity),
+ newline
+ ;
+ io__write_string(" failed "),
+ newline
+ ),
+ test_all_functors(TypeInfo, N - 1)
+ ).
+
+%----------------------------------------------------------------------------%
+
+test_discriminated -->
+ io__write_string("TESTING DISCRIMINATED UNIONS\n"),
+
+ % test enumerations
+ test_all(two), newline,
+ test_all(one), newline,
+ test_all(three), newline,
+
+ % test simple tags
+ test_all(apple([9,5,1])), newline,
+ test_all(banana([three, one, two])), newline,
+
+ % test complicated tags
+ test_all(zop(3.3, 2.03)), newline,
+ test_all(zip(3, 2)), newline,
+ test_all(zap(3, -2.111)), newline,
+
+ % test complicated constant
+
+ test_all(wombat), newline,
+ test_all(foo), newline,
+
+ newline.
+
+test_polymorphism -->
+ io__write_string("TESTING POLYMORPHISM\n"),
+ test_all(poly_three(3.33, 4, poly_one(9.11))), newline,
+ test_all(poly_two(3)), newline,
+ test_all(poly_one([2399.3])), newline,
+
+ newline.
+
+test_builtins -->
+ io__write_string("TESTING BUILTINS\n"),
+
+ % test strings
+ test_all(""), newline,
+ test_all("Hello, world\n"), newline,
+ test_all("Foo%sFoo"), newline,
+ test_all(""""), newline,
+
+ % test characters
+ test_all('a'), newline,
+ test_all('&'), newline,
+
+ % test floats
+ test_all(3.14159), newline,
+ test_all(11.28324983E-22), newline,
+ test_all(22.3954899E22), newline,
+
+ % test integers
+ test_all(-65), newline,
+ test_all(4), newline,
+
+ % test univ.
+ %{ type_to_univ(["hi! I'm a univ!"], Univ) },
+ % test_all(Univ), newline,
+
+ % test predicates
+ test_all(newline), newline,
+
+ % test tuples
+ test_all({1, "a", 'a', {4, 'd'}}), newline,
+
+ newline.
+
+ % Note: testing abstract types is always going to have results
+ % that are dependent on the implementation. If someone changes
+ % the implementation, the results of this test can change.
+
+test_other -->
+ io__write_string("TESTING OTHER TYPES\n"),
+ { term__init_var_supply(VarSupply) },
+ { term__create_var(VarSupply, Var, NewVarSupply) },
+ test_all(Var), newline,
+ test_all(VarSupply), newline,
+ test_all(NewVarSupply), newline,
+
+ % presently, at least, map is an equivalence and
+ % an abstract type.
+ { map__init(Map) },
+ test_all(Map), newline,
+
+ % a no tag type
+ test_all(qwerty(4)), newline,
+
+ newline.
+
+newline -->
+ io__write_char('\n').
Index: tests/hard_coded/existential_float.exp
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/existential_float.exp,v
retrieving revision 1.3
diff -u -b -r1.3 existential_float.exp
--- tests/hard_coded/existential_float.exp 13 Jan 2001 02:30:30 -0000 1.3
+++ tests/hard_coded/existential_float.exp 28 Jan 2002 18:25:57 -0000
@@ -2,20 +2,20 @@
'c'
42.0000000000000
42.0000000000000
-'<<predicate>>'
-'<<predicate>>'
+'<<function>>'
+'<<function>>'
'c'
'c'
42.0000000000000
42.0000000000000
-'<<predicate>>'
-'<<predicate>>'
+'<<function>>'
+'<<function>>'
'c'
42.0000000000000
-'<<predicate>>'
+'<<function>>'
'c'
42.0000000000000
-'<<predicate>>'
+'<<function>>'
33.3000000000000
no.
33.3000000000000
Index: tests/hard_coded/higher_order_type_manip.exp
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/higher_order_type_manip.exp,v
retrieving revision 1.5
diff -u -b -r1.5 higher_order_type_manip.exp
--- tests/hard_coded/higher_order_type_manip.exp 21 Dec 2000 23:50:08 -0000 1.5
+++ tests/hard_coded/higher_order_type_manip.exp 29 Jan 2002 07:17:25 -0000
@@ -1,5 +1,5 @@
-func(std_util:type_desc) = string
-pred(std_util:type_desc, std_util:type_ctor_desc, list:list(std_util:type_desc))
+func(type_desc:type_desc) = string
+pred(type_desc:type_desc, type_desc:type_ctor_desc, list:list(type_desc:type_desc))
int
higher_order_type_manip:container(list:list(int))
higher_order_type_manip:container(pred(io:state, io:state))
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/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
Index: trace/mercury_trace_browse.c
===================================================================
RCS file: /home/mercury1/repository/mercury/trace/mercury_trace_browse.c,v
retrieving revision 1.23
diff -u -b -r1.23 mercury_trace_browse.c
--- trace/mercury_trace_browse.c 23 Jan 2002 05:37:09 -0000 1.23
+++ trace/mercury_trace_browse.c 28 Jan 2002 12:40:13 -0000
@@ -33,9 +33,9 @@
#include "mdb.browser_info.h"
#include "mdb.interactive_query.h"
#ifdef MR_HIGHLEVEL_CODE
- #include "mercury.std_util.h"
+ #include "mercury.type_desc.h"
#else
- #include "std_util.h"
+ #include "type_desc.h"
#endif
#include <stdio.h>
@@ -294,7 +294,7 @@
if (! done) {
MR_TRACE_CALL_MERCURY(
- ML_get_type_info_for_type_info(&typeinfo_type_word);
+ typeinfo_type_word = ML_get_type_info_for_type_info();
ML_BROWSE_browser_persistent_state_type(
&MR_trace_browser_persistent_state_type_word);
ML_BROWSE_init_persistent_state(
Index: trace/mercury_trace_external.c
===================================================================
RCS file: /home/mercury1/repository/mercury/trace/mercury_trace_external.c,v
retrieving revision 1.60
diff -u -b -r1.60 mercury_trace_external.c
--- trace/mercury_trace_external.c 4 Dec 2001 00:44:39 -0000 1.60
+++ trace/mercury_trace_external.c 28 Jan 2002 12:32:15 -0000
@@ -32,9 +32,9 @@
#include "mdb.debugger_interface.h"
#include "mdb.collect_lib.h"
#ifdef MR_HIGHLEVEL_CODE
- #include "mercury.std_util.h"
+ #include "mercury.type_desc.h"
#else
- #include "std_util.h"
+ #include "type_desc.h"
#endif
#include "mercury_deep_copy.h"
Index: trace/mercury_trace_help.c
===================================================================
RCS file: /home/mercury1/repository/mercury/trace/mercury_trace_help.c,v
retrieving revision 1.15
diff -u -b -r1.15 mercury_trace_help.c
--- trace/mercury_trace_help.c 23 Jan 2002 05:37:09 -0000 1.15
+++ trace/mercury_trace_help.c 28 Jan 2002 12:31:46 -0000
@@ -32,10 +32,10 @@
#include "mercury_trace_util.h"
#ifdef MR_HIGHLEVEL_CODE
- #include "mercury.std_util.h"
+ #include "mercury.type_desc.h"
#include "mercury.io.h"
#else
- #include "std_util.h"
+ #include "type_desc.h"
#include "io.h"
#endif
#include "mdb.help.h"
@@ -182,7 +182,7 @@
if (! done) {
MR_TRACE_CALL_MERCURY(
- ML_get_type_info_for_type_info(&typeinfo_type);
+ typeinfo_type = ML_get_type_info_for_type_info();
ML_HELP_help_system_type(
&MR_trace_help_system_type_word);
MR_trace_help_system_type =
Index: trace/mercury_trace_vars.c
===================================================================
RCS file: /home/mercury1/repository/mercury/trace/mercury_trace_vars.c,v
retrieving revision 1.31
diff -u -b -r1.31 mercury_trace_vars.c
--- trace/mercury_trace_vars.c 18 Jan 2002 04:02:24 -0000 1.31
+++ trace/mercury_trace_vars.c 29 Jan 2002 07:02:29 -0000
@@ -135,32 +135,44 @@
** do not export them. The types are a lie, but a safe lie.
*/
-extern struct MR_TypeCtorInfo_Struct
+#ifndef MR_HIGHLEVEL_CODE
+ extern struct MR_TypeCtorInfo_Struct
mercury_data_private_builtin__type_ctor_info_type_info_1;
-extern struct MR_TypeCtorInfo_Struct
+ extern struct MR_TypeCtorInfo_Struct
mercury_data_private_builtin__type_ctor_info_type_ctor_info_1;
-extern struct MR_TypeCtorInfo_Struct
+ extern struct MR_TypeCtorInfo_Struct
mercury_data_private_builtin__type_ctor_info_typeclass_info_1;
-extern struct MR_TypeCtorInfo_Struct
+ extern struct MR_TypeCtorInfo_Struct
mercury_data_private_builtin__type_ctor_info_base_typeclass_info_1;
-extern struct MR_TypeCtorInfo_Struct
+ extern struct MR_TypeCtorInfo_Struct
mercury_data_std_util__type_ctor_info_type_desc_0;
-extern struct MR_TypeCtorInfo_Struct
+ extern struct MR_TypeCtorInfo_Struct
mercury_data_std_util__type_ctor_info_type_ctor_desc_0;
-extern struct MR_TypeCtorInfo_Struct mercury_data___type_ctor_info_void_0;
-
-#ifdef MR_HIGHLEVEL_CODE
- extern struct MR_TypeCtorInfo_Struct mercury_data___type_ctor_info_func_0;
- extern struct MR_TypeCtorInfo_Struct mercury_data___type_ctor_info_pred_0;
-#endif
-
-#ifdef NATIVE_GC
-extern struct MR_TypeCtorInfo_Struct mercury_data___type_ctor_info_succip_0;
-extern struct MR_TypeCtorInfo_Struct mercury_data___type_ctor_info_hp_0;
-extern struct MR_TypeCtorInfo_Struct mercury_data___type_ctor_info_curfr_0;
-extern struct MR_TypeCtorInfo_Struct mercury_data___type_ctor_info_maxfr_0;
-extern struct MR_TypeCtorInfo_Struct mercury_data___type_ctor_info_redoip_0;
-extern struct MR_TypeCtorInfo_Struct mercury_data___type_ctor_info_redofr_0;
+ extern struct MR_TypeCtorInfo_Struct
+ mercury_data_type_desc__type_ctor_info_type_desc_0;
+ extern struct MR_TypeCtorInfo_Struct
+ mercury_data_type_desc__type_ctor_info_type_ctor_desc_0;
+ extern struct MR_TypeCtorInfo_Struct
+ mercury_data___type_ctor_info_func_0;
+ extern struct MR_TypeCtorInfo_Struct
+ mercury_data___type_ctor_info_pred_0;
+ extern struct MR_TypeCtorInfo_Struct
+ mercury_data___type_ctor_info_void_0;
+
+ #ifdef NATIVE_GC
+ extern struct MR_TypeCtorInfo_Struct
+ mercury_data___type_ctor_info_succip_0;
+ extern struct MR_TypeCtorInfo_Struct
+ mercury_data___type_ctor_info_hp_0;
+ extern struct MR_TypeCtorInfo_Struct
+ mercury_data___type_ctor_info_curfr_0;
+ extern struct MR_TypeCtorInfo_Struct
+ mercury_data___type_ctor_info_maxfr_0;
+ extern struct MR_TypeCtorInfo_Struct
+ mercury_data___type_ctor_info_redoip_0;
+ extern struct MR_TypeCtorInfo_Struct
+ mercury_data___type_ctor_info_redofr_0;
+ #endif
#endif
static MR_TypeCtorInfo
@@ -174,6 +186,8 @@
&mercury_data_private_builtin__type_ctor_info_base_typeclass_info_1,
&mercury_data_std_util__type_ctor_info_type_desc_0,
&mercury_data_std_util__type_ctor_info_type_ctor_desc_0,
+ &mercury_data_type_desc__type_ctor_info_type_desc_0,
+ &mercury_data_type_desc__type_ctor_info_type_ctor_desc_0,
/* we ignore these until the debugger can print higher-order terms */
&mercury_data___type_ctor_info_func_0,
@@ -181,9 +195,8 @@
/* we ignore these because they should never be needed */
&mercury_data___type_ctor_info_void_0,
-#endif
-#ifdef NATIVE_GC
+ #ifdef NATIVE_GC
/* we ignore these because they are not interesting */
&mercury_data___type_ctor_info_succip_0,
&mercury_data___type_ctor_info_hp_0,
@@ -191,6 +204,7 @@
&mercury_data___type_ctor_info_maxfr_0,
&mercury_data___type_ctor_info_redoip_0,
&mercury_data___type_ctor_info_redofr_0,
+ #endif
#endif
/* dummy member */
NULL
cvs diff: Diffing util
Index: util/mkinit.c
===================================================================
RCS file: /home/mercury1/repository/mercury/util/mkinit.c,v
retrieving revision 1.82
diff -u -b -r1.82 mkinit.c
--- util/mkinit.c 22 Jan 2002 17:27:52 -0000 1.82
+++ util/mkinit.c 28 Jan 2002 13:51:18 -0000
@@ -249,6 +249,22 @@
" #endif\n"
"#endif\n"
"\n"
+ "#ifdef MR_HIGHLEVEL_CODE\n"
+ "extern const struct MR_TypeCtorInfo_Struct\n"
+ " mercury__builtin__builtin__type_ctor_info_func_0;\n"
+ "extern const struct MR_TypeCtorInfo_Struct\n"
+ " mercury__builtin__builtin__type_ctor_info_pred_0;\n"
+ "extern const struct MR_TypeCtorInfo_Struct\n"
+ " mercury__builtin__builtin__type_ctor_info_tuple_0;\n"
+ "#else\n"
+ "extern const struct MR_TypeCtorInfo_Struct\n"
+ " mercury_data___type_ctor_info_func_0;\n"
+ "extern const struct MR_TypeCtorInfo_Struct\n"
+ " mercury_data___type_ctor_info_pred_0;\n"
+ "extern const struct MR_TypeCtorInfo_Struct\n"
+ " mercury_data___type_ctor_info_tuple_0;\n"
+ "#endif\n"
+ "\n"
"void\n"
"mercury_init(int argc, char **argv, char *stackbottom)\n"
"{\n"
@@ -286,6 +302,21 @@
" write_out_proc_statics;\n"
"#endif\n"
" MR_address_of_do_load_aditi_rl_code = %s;\n"
+ "#ifdef MR_HIGHLEVEL_CODE\n"
+ " MR_address_of_type_ctor_info_for_func ="
+ " &mercury__builtin__builtin__type_ctor_info_func_0;\n"
+ " MR_address_of_type_ctor_info_for_pred ="
+ " &mercury__builtin__builtin__type_ctor_info_pred_0;\n"
+ " MR_address_of_type_ctor_info_for_tuple ="
+ " &mercury__builtin__builtin__type_ctor_info_tuple_0;\n"
+ "#else\n"
+ " MR_address_of_type_ctor_info_for_func ="
+ " &mercury_data___type_ctor_info_func_0;\n"
+ " MR_address_of_type_ctor_info_for_pred ="
+ " &mercury_data___type_ctor_info_pred_0;\n"
+ " MR_address_of_type_ctor_info_for_tuple ="
+ " &mercury_data___type_ctor_info_tuple_0;\n"
+ "#endif\n"
"#ifdef CONSERVATIVE_GC\n"
" MR_address_of_init_gc = init_gc;\n"
"#endif\n"
--------------------------------------------------------------------------
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