[m-rev.] for review: committed choice deconstruction
Zoltan Somogyi
zs at cs.mu.OZ.AU
Mon Jan 7 18:06:20 AEDT 2002
For review by Fergus.
Add committed choice versions of the functions and predicates that deconstruct
terms. These versions succeed even if the the term being deconstructed is of a
non-canonical type.
NEWS:
Mention the new procedures.
library/std_util.m:
Add the following procedures: functor_cc, argument_cc, det_argument_cc,
named_argument_cc, det_named_argument_cc, deconstruct_cc and
limited_deconstruct_cc.
To avoid code duplication, factor out the code common to several
procedures and put it into three new files in the runtime directory,
mercury_ml_{fuctor,arg,deconstruct__body.h.
Add arguments to the various expansion functions to control what they
should do for non-canonical types. Move them to mercury_deconstruct.c
in the runtime directory to make it easier to access them from other
places.
Fix some bugs in the code for det_arg and family in the computation
of abort messages.
library/store.m:
extras/trailed_update/tr_store.m:
trace/mercury_trace_vars.c:
Adjust the references to the expansion functions.
runtime/mercury_deconstruct.[ch]:
A new module to contain the expansion functions.
runtime/mercury_ml_arg_body.h:
runtime/mercury_ml_deconstruct_body.h:
runtime/mercury_ml_functor_body.h:
New files to contain the bodies of the std_util procedures for
deconstructing terms.
runtime/mercury_deconstruct_macros.h:
A new header file for macros used in several places.
library/Mmakefile:
runtime/Mmakefile:
Add the new files to the required lists.
Zoltan.
cvs diff: Diffing .
Index: NEWS
===================================================================
RCS file: /home/mercury1/repository/mercury/NEWS,v
retrieving revision 1.234
diff -u -b -r1.234 NEWS
--- NEWS 2001/12/29 04:40:57 1.234
+++ NEWS 2002/01/07 06:42:13
@@ -128,9 +128,13 @@
`std_util__map_maybe/2' to apply a predicate or a function to
a value stored in a term of type `std_util__maybe'.
-* We've added two predicates, named_argument and det_named_argument, to
- std_util.m. These are analogous to argument and det_argument, but specify
- the desired argument by its name, not its position.
+* We've added added several new predicates for deconstructing terms to
+ std_util.m. `named_argument' and `det_named_argument' are analogous
+ to `argument' and `det_argument' respectively, but specify the desired
+ argument by its name, not its position. We have also added committed choice
+ version of all the predicates that deconstruct terms. These differ from the
+ existing versions in that they do not abort when called upon to deconstruct
+ non-canonical terms, such as values of types with user-defined equality.
* We've added a predicate version of `set__fold'.
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
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
Index: extras/trailed_update/tr_store.m
===================================================================
RCS file: /home/mercury1/repository/mercury/extras/trailed_update/tr_store.m,v
retrieving revision 1.8
diff -u -b -r1.8 tr_store.m
--- extras/trailed_update/tr_store.m 2000/12/07 13:16:58 1.8
+++ extras/trailed_update/tr_store.m 2002/01/01 12:54:17
@@ -202,9 +202,7 @@
{ functor(Val, Functor, Arity) }.
:- pragma c_header_code("
- /* ML_arg() is defined in std_util.m */
-extern bool ML_arg(MR_TypeInfo type_info, MR_Word *term, int arg_index,
- MR_TypeInfo *arg_type_info_ptr, MR_Word **argument_ptr);
+#include ""mercury_deconstruct.h""
").
:- pragma c_code(arg_ref(Ref::in, ArgNum::in, ArgRef::out, S0::mdi, S::muo),
@@ -215,8 +213,8 @@
MR_save_transient_registers();
- if (!ML_arg((MR_TypeInfo) TypeInfo_for_T, (MR_Word *) Ref, ArgNum,
- &arg_type_info, &arg_ref))
+ if (!MR_arg((MR_TypeInfo) TypeInfo_for_T, (MR_Word *) Ref, ArgNum,
+ &arg_type_info, &arg_ref, FALSE, ""arg_ref/5""))
{
MR_fatal_error(""tr_store__arg_ref: ""
""argument number out of range"");
@@ -242,8 +240,8 @@
MR_save_transient_registers();
- if (!ML_arg((MR_TypeInfo) TypeInfo_for_T, (MR_Word *) &Val, ArgNum,
- &arg_type_info, &arg_ref))
+ if (!MR_arg((MR_TypeInfo) TypeInfo_for_T, (MR_Word *) &Val, ArgNum,
+ &arg_type_info, &arg_ref, FALSE, ""new_arg_ref/5""))
{
MR_fatal_error(""tr_store__new_arg_ref: ""
""argument number out of range"");
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
cvs diff: Diffing library
Index: library/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/mercury/library/Mmakefile,v
retrieving revision 1.81
diff -u -b -r1.81 Mmakefile
--- library/Mmakefile 2001/12/19 04:05:44 1.81
+++ library/Mmakefile 2002/01/01 05:54:03
@@ -299,7 +299,11 @@
$(os_subdir)std_util.$O \
$(os_subdir)std_util.pic_o \
- : ../runtime/mercury_ml_expand_body.h
+ : ../runtime/mercury_ml_functor_body.h \
+ ../runtime/mercury_ml_arg_body.h \
+ ../runtime/mercury_ml_deconstruct_body.h \
+ ../runtime/mercury_deconstruct_macros.h \
+ ../runtime/mercury_deconstruct.h
#-----------------------------------------------------------------------------#
Index: library/std_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/std_util.m,v
retrieving revision 1.251
diff -u -b -r1.251 std_util.m
--- library/std_util.m 2001/12/31 04:26:46 1.251
+++ library/std_util.m 2002/01/04 05:39:49
@@ -563,6 +563,7 @@
% user-defined equality predicate.)
%
:- pred functor(T::in, string::out, int::out) is det.
+:- pred functor_cc(T::in, string::out, int::out) is det.
% arg(Data, ArgumentIndex) = Argument
% argument(Data, ArgumentIndex) = ArgumentUniv
@@ -580,7 +581,9 @@
% equality predicate.)
%
:- 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
%
@@ -589,6 +592,7 @@
% name, named_argument fails.
%
:- 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
@@ -598,7 +602,9 @@
% det_arg/2 or det_argument/2 will abort.
%
:- 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
%
@@ -606,6 +612,7 @@
% 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)
%
@@ -626,6 +633,8 @@
% instead.
%
:- 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)
%
@@ -635,6 +644,8 @@
%
:- 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.
@@ -1016,7 +1027,7 @@
MR_save_transient_hp(); \\
NewVal = MR_deep_copy(&OldVal, (MR_TypeInfo) TypeInfo_for_T,\\
(const MR_Word *) SolutionsHeapPtr, \\
- MR_ENGINE(MR_eng_solutions_heap_zone)->top);\\
+ MR_ENGINE(MR_eng_solutions_heap_zone)->top); \\
MR_restore_transient_hp(); \\
} while (0)
#endif
@@ -1024,26 +1035,29 @@
").
:- pragma foreign_proc("C",
- partial_deep_copy(SolutionsHeapPtr::in,
- OldVal::in, NewVal::out), will_not_call_mercury,
+ partial_deep_copy(SolutionsHeapPtr::in, OldVal::in, NewVal::out),
+ [will_not_call_mercury],
"
MR_PARTIAL_DEEP_COPY(SolutionsHeapPtr, OldVal, NewVal, TypeInfo_for_T);
").
+
:- pragma foreign_proc("C",
- partial_deep_copy(SolutionsHeapPtr::in,
- OldVal::mdi, NewVal::muo), will_not_call_mercury,
+ partial_deep_copy(SolutionsHeapPtr::in, OldVal::mdi, NewVal::muo),
+ [will_not_call_mercury],
"
MR_PARTIAL_DEEP_COPY(SolutionsHeapPtr, OldVal, NewVal, TypeInfo_for_T);
").
-:- pragma foreign_proc("C", partial_deep_copy(SolutionsHeapPtr::in,
- OldVal::di, NewVal::uo), will_not_call_mercury,
+
+:- pragma foreign_proc("C",
+ partial_deep_copy(SolutionsHeapPtr::in, OldVal::di, NewVal::uo),
+ [will_not_call_mercury],
"
MR_PARTIAL_DEEP_COPY(SolutionsHeapPtr, OldVal, NewVal, TypeInfo_for_T);
").
:- pragma foreign_proc("MC++",
- partial_deep_copy(_SolutionsHeapPtr::in,
- OldVal::in, NewVal::out), will_not_call_mercury,
+ partial_deep_copy(_SolutionsHeapPtr::in, OldVal::in, NewVal::out),
+ [will_not_call_mercury],
"
/*
** For the IL back-end, we don't do heap reclamation on failure,
@@ -1053,13 +1067,14 @@
NewVal = OldVal;
").
:- pragma foreign_proc("MC++",
- partial_deep_copy(_SolutionsHeapPtr::in,
- OldVal::mdi, NewVal::muo), will_not_call_mercury,
+ partial_deep_copy(_SolutionsHeapPtr::in, OldVal::mdi, NewVal::muo),
+ [will_not_call_mercury],
"
NewVal = OldVal;
").
-:- pragma foreign_proc("MC++", partial_deep_copy(_SolutionsHeapPtr::in,
- OldVal::di, NewVal::uo), will_not_call_mercury,
+:- pragma foreign_proc("MC++",
+ partial_deep_copy(_SolutionsHeapPtr::in, OldVal::di, NewVal::uo),
+ [will_not_call_mercury],
"
NewVal = OldVal;
").
@@ -1073,7 +1088,7 @@
:- impure pred reset_solutions_heap(heap_ptr::in) is det.
:- pragma foreign_proc("C",
reset_solutions_heap(SolutionsHeapPtr::in),
- will_not_call_mercury,
+ [will_not_call_mercury],
"
#ifndef CONSERVATIVE_GC
MR_sol_hp = (MR_Word *) SolutionsHeapPtr;
@@ -1082,7 +1097,7 @@
:- pragma foreign_proc("MC++",
reset_solutions_heap(_SolutionsHeapPtr::in),
- will_not_call_mercury,
+ [will_not_call_mercury],
"
/*
** For the IL back-end, we don't have a separate `solutions heap'.
@@ -1444,7 +1459,8 @@
"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.
+ rtti_implementation__type_info::in, rtti_implementation__type_info::in)
+ is det.
:- use_module rtti_implementation.
@@ -2172,12 +2188,10 @@
} 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),
+ 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);
+ arity, construct_info.arg_names);
MR_restore_transient_registers();
}
}
@@ -2424,8 +2438,7 @@
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_field(MR_UNIV_TAG, MR_list_head(arg_list),
MR_UNIV_OFFSET_FOR_DATA);
arg_list = MR_list_tail(arg_list);
}
@@ -3072,467 +3085,50 @@
%-----------------------------------------------------------------------------%
:- pragma foreign_decl("C", "
-
- #include <stdio.h>
- #include ""mercury_library_types.h"" /* for MR_ArrayType */
-
-#ifdef MR_DEEP_PROFILING
- #include ""mercury_deep_profiling.h""
-#endif
-
-/* The `#ifndef ... #define ... #endif' guards against multiple inclusion */
-#ifndef ML_EXPAND_INFO_GUARD
-#define ML_EXPAND_INFO_GUARD
-
-typedef struct {
- int num_extra_args;
- MR_Word *arg_values;
- MR_TypeInfo *arg_type_infos;
- bool can_free_arg_type_infos;
-} ML_Expand_Args_Fields;
-
-typedef struct {
- bool non_canonical_type;
- int arity;
- MR_ConstString functor;
- ML_Expand_Args_Fields args;
-} ML_Expand_Functor_Args_Info;
-typedef struct {
- bool non_canonical_type;
- int arity;
- MR_ConstString functor;
- ML_Expand_Args_Fields args;
- bool limit_reached;
-} ML_Expand_Functor_Args_Limit_Info;
-
-typedef struct {
- bool non_canonical_type;
- int arity;
- MR_ConstString functor_only;
-} ML_Expand_Functor_Only_Info;
-
-typedef struct {
- bool non_canonical_type;
- int arity;
- ML_Expand_Args_Fields args_only;
-} ML_Expand_Args_Only_Info;
-
-typedef struct {
- bool non_canonical_type;
- int arity;
- bool chosen_index_exists;
- MR_Word *chosen_value_ptr;
- MR_TypeInfo chosen_type_info;
-} ML_Expand_Chosen_Arg_Only_Info;
-
- /* Prototypes */
-
-extern void ML_expand_functor_args(MR_TypeInfo type_info,
- MR_Word *data_word_ptr,
- ML_Expand_Functor_Args_Info *expand_info);
-
-extern void ML_expand_functor_args_limit(MR_TypeInfo type_info,
- MR_Word *data_word_ptr, int max_arity,
- ML_Expand_Functor_Args_Limit_Info *expand_info);
-
-extern void ML_expand_functor_only(MR_TypeInfo type_info,
- MR_Word *data_word_ptr,
- ML_Expand_Functor_Only_Info *expand_info);
-
-extern void ML_expand_args_only(MR_TypeInfo type_info,
- MR_Word *data_word_ptr,
- ML_Expand_Args_Only_Info *expand_info);
-
-extern void ML_expand_chosen_arg_only(MR_TypeInfo type_info,
- MR_Word *data_word_ptr, int chosen,
- ML_Expand_Chosen_Arg_Only_Info *expand_info);
-
-extern void ML_expand_named_arg_only(MR_TypeInfo type_info,
- MR_Word *data_word_ptr, MR_ConstString chosen_name,
- ML_Expand_Chosen_Arg_Only_Info *expand_info);
-
- /*
- ** NB. ML_arg() is also used by arg_ref and new_arg_ref
- ** in store.m, in trace/mercury_trace_vars.m, and in
- ** extras/trailed_update/tr_store.m.
- */
-extern bool ML_arg(MR_TypeInfo type_info, MR_Word *term, int arg_index,
- MR_TypeInfo *arg_type_info_ptr, MR_Word **argument_ptr);
-
-extern bool ML_named_arg(MR_TypeInfo type_info, MR_Word *term,
- MR_ConstString arg_name, MR_TypeInfo *arg_type_info_ptr,
- MR_Word **argument_ptr);
-
- /*
- ** NB. ML_named_arg_num() is used in mercury_trace_vars.c.
- */
-extern bool ML_named_arg_num(MR_TypeInfo type_info, MR_Word *term_ptr,
- const char *arg_name, int *arg_num_ptr);
+#include ""mercury_deconstruct.h""
+#include ""mercury_deconstruct_macros.h""
-/*
-** The following macros factor out the common parts of the various
-** deconstruction predicates.
-*/
-
- /*
- ** Check for attempts to deconstruct a non-canonical type.
- ** Such deconstructions must be cc_multi, which is why we treat
- ** violations of this as runtime errors in det deconstruction
- ** predicates.
- ** (There ought to be cc_multi versions of those predicates.)
- */
-#define ML_abort_if_type_is_noncanonical(ei, predname) \
- do { \
- if ((ei).non_canonical_type) { \
- MR_fatal_error(""called "" predname "" for a type "" \
- ""with a user-defined equality predicate""); \
- } \
- } while (0)
-
-#endif
-
-#define ML_deconstruct_get_functor(ei, functor_field, var) \
- do { \
- MR_make_aligned_string(MR_LVALUE_CAST(MR_ConstString, var), \
- (ei).functor_field); \
- } while (0)
-
-#define ML_deconstruct_get_arity(ei, var) \
- do { \
- var = (ei).arity; \
- } while (0)
-
-#define ML_deconstruct_get_arg_list(ei, args_field, var) \
- do { \
- int i; \
- \
- var = MR_list_empty_msg(MR_PROC_LABEL); \
- i = (ei).arity; \
- \
- while (--i >= 0) { \
- MR_Word arg; \
- \
- /* Create an argument on the heap */ \
- MR_new_univ_on_hp(arg, \
- (ei).args_field.arg_type_infos[i], \
- (ei).args_field.arg_values[i + \
- (ei).args_field.num_extra_args]); \
- \
- /* Join the argument to the front of the list */ \
- var = MR_list_cons_msg(arg, var, MR_PROC_LABEL); \
- } \
- } while (0)
-
- /*
- ** Free any arg_type_infos allocated by the ML_expand variant.
- ** Should be called after we have used them for the last time.
- */
-#define ML_deconstruct_free_allocated_arg_type_infos(ei, args_field)\
- do { \
- if ((ei).args_field.can_free_arg_type_infos) { \
- MR_GC_free((ei).args_field.arg_type_infos); \
- } \
- } while (0)
-
").
-:- pragma foreign_code("C", "
-
-#define EXPAND_FUNCTION_NAME ML_expand_functor_args
-#define EXPAND_TYPE_NAME ML_Expand_Functor_Args_Info
-#define EXPAND_FUNCTOR_FIELD functor
-#define EXPAND_ARGS_FIELD args
-#include ""mercury_ml_expand_body.h""
-#undef EXPAND_FUNCTION_NAME
-#undef EXPAND_TYPE_NAME
-#undef EXPAND_FUNCTOR_FIELD
-#undef EXPAND_ARGS_FIELD
-
-#define EXPAND_FUNCTION_NAME ML_expand_functor_args_limit
-#define EXPAND_TYPE_NAME ML_Expand_Functor_Args_Limit_Info
-#define EXPAND_FUNCTOR_FIELD functor
-#define EXPAND_ARGS_FIELD args
-#define EXPAND_APPLY_LIMIT
-#include ""mercury_ml_expand_body.h""
-#undef EXPAND_FUNCTION_NAME
-#undef EXPAND_TYPE_NAME
-#undef EXPAND_FUNCTOR_FIELD
-#undef EXPAND_ARGS_FIELD
-#undef EXPAND_APPLY_LIMIT
-
-#define EXPAND_FUNCTION_NAME ML_expand_functor_only
-#define EXPAND_TYPE_NAME ML_Expand_Functor_Only_Info
-#define EXPAND_FUNCTOR_FIELD functor_only
-#include ""mercury_ml_expand_body.h""
-#undef EXPAND_FUNCTION_NAME
-#undef EXPAND_TYPE_NAME
-#undef EXPAND_FUNCTOR_FIELD
-
-#define EXPAND_FUNCTION_NAME ML_expand_args_only
-#define EXPAND_TYPE_NAME ML_Expand_Args_Only_Info
-#define EXPAND_ARGS_FIELD args_only
-#include ""mercury_ml_expand_body.h""
-#undef EXPAND_FUNCTION_NAME
-#undef EXPAND_TYPE_NAME
-#undef EXPAND_ARGS_FIELD
-
-#define EXPAND_FUNCTION_NAME ML_expand_chosen_arg_only
-#define EXPAND_TYPE_NAME ML_Expand_Chosen_Arg_Only_Info
-#define EXPAND_CHOSEN_ARG
-#include ""mercury_ml_expand_body.h""
-#undef EXPAND_FUNCTION_NAME
-#undef EXPAND_TYPE_NAME
-#undef EXPAND_CHOSEN_ARG
-
-#define EXPAND_FUNCTION_NAME ML_expand_named_arg_only
-#define EXPAND_TYPE_NAME ML_Expand_Chosen_Arg_Only_Info
-#define EXPAND_NAMED_ARG
-#include ""mercury_ml_expand_body.h""
-#undef EXPAND_FUNCTION_NAME
-#undef EXPAND_TYPE_NAME
-#undef EXPAND_NAMED_ARG
-
-/*
-** ML_arg() is a subroutine used to implement arg/2, argument/2,
-** and also store__arg_ref/5 in store.m.
-** It takes the address of a term, its type, and an argument index.
-** If the selected argument exists, it succeeds and returns the address
-** of the argument, and its type; if it doesn't, it fails (i.e. returns FALSE).
-**
-** You need to wrap MR_{save/restore}_transient_hp() around
-** calls to this function.
-*/
-
-bool
-ML_arg(MR_TypeInfo type_info, MR_Word *term_ptr, int arg_index,
- MR_TypeInfo *arg_type_info_ptr, MR_Word **arg_ptr)
-{
- ML_Expand_Chosen_Arg_Only_Info expand_info;
-
- ML_expand_chosen_arg_only(type_info, term_ptr, arg_index, &expand_info);
- ML_abort_if_type_is_noncanonical(expand_info, ""argument/2"");
-
- /* Check range */
- if (expand_info.chosen_index_exists) {
- *arg_type_info_ptr = expand_info.chosen_type_info;
- *arg_ptr = expand_info.chosen_value_ptr;
- return TRUE;
- }
-
- return FALSE;
-}
-
-/*
-** ML_named_arg() is a subroutine used to implement named_arg/2.
-** It takes the address of a term, its type, and an argument name.
-** If an argument with that name exists, it succeeds and returns the address
-** of the argument, and its type; if it doesn't, it fails (i.e. returns FALSE).
-**
-** You need to wrap MR_{save/restore}_transient_hp() around
-** calls to this function.
-*/
-
-bool
-ML_named_arg(MR_TypeInfo type_info, MR_Word *term_ptr, MR_ConstString arg_name,
- MR_TypeInfo *arg_type_info_ptr, MR_Word **arg_ptr)
-{
- ML_Expand_Chosen_Arg_Only_Info expand_info;
-
- ML_expand_named_arg_only(type_info, term_ptr, arg_name, &expand_info);
- ML_abort_if_type_is_noncanonical(expand_info, ""named_argument/2"");
-
- /* Check range */
- if (expand_info.chosen_index_exists) {
- *arg_type_info_ptr = expand_info.chosen_type_info;
- *arg_ptr = expand_info.chosen_value_ptr;
- return TRUE;
- }
-
- return FALSE;
-}
-
-/*
-** ML_named_arg_num() takes the address of a term, its type, and an argument
-** name. If the given term has an argument with the given name, it succeeds and
-** returns the argument number (counted starting from 0) of the argument;
-** if it doesn't, it fails (i.e. returns FALSE).
-**
-** You need to wrap MR_{save/restore}_transient_hp() around
-** calls to this function.
-*/
-
-bool
-ML_named_arg_num(MR_TypeInfo type_info, MR_Word *term_ptr,
- const char *arg_name, int *arg_num_ptr)
-{
- MR_TypeCtorInfo type_ctor_info;
- MR_DuTypeLayout du_type_layout;
- const MR_DuPtagLayout *ptag_layout;
- const MR_DuFunctorDesc *functor_desc;
- const MR_NotagFunctorDesc *notag_functor_desc;
- MR_Word data;
- int ptag;
- MR_Word sectag;
- MR_TypeInfo eqv_type_info;
- int i;
-
- type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
-
- switch (MR_type_ctor_rep(type_ctor_info)) {
- case MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ:
- case MR_TYPECTOR_REP_RESERVED_ADDR:
- {
- MR_ReservedAddrTypeLayout ra_layout;
-
- ra_layout = type_ctor_info->type_layout.layout_reserved_addr;
- data = *term_ptr;
-
- /*
- ** First check if this value is one of
- ** the numeric reserved addresses.
- */
- if ((MR_Unsigned) data <
- (MR_Unsigned) ra_layout->MR_ra_num_res_numeric_addrs)
- {
- /*
- ** If so, it must be a constant, and constants never have
- ** any arguments.
- */
- return FALSE;
- }
-
- /*
- ** Next check if this value is one of the
- ** the symbolic reserved addresses.
- */
- for (i = 0; i < ra_layout->MR_ra_num_res_symbolic_addrs; i++) {
- if (data ==
- (MR_Word) ra_layout->MR_ra_res_symbolic_addrs[i])
- {
- return FALSE;
- }
- }
-
- /*
- ** Otherwise, it is not one of the reserved addresses,
- ** so handle it like a normal DU type.
- */
- du_type_layout = ra_layout->MR_ra_other_functors;
- goto du_type;
- }
-
-
- case MR_TYPECTOR_REP_DU_USEREQ:
- case MR_TYPECTOR_REP_DU:
- data = *term_ptr;
- du_type_layout = type_ctor_info->type_layout.layout_du;
- /* fall through */
-
- /*
- ** This label handles both the DU case and the second half of the
- ** RESERVED_ADDR case. `du_type_layout' and `data' must both be
- ** set before this code is entered.
- */
- du_type:
- ptag = MR_tag(data);
- ptag_layout = &du_type_layout[ptag];
-
- switch (ptag_layout->MR_sectag_locn) {
- case MR_SECTAG_NONE:
- functor_desc = ptag_layout->MR_sectag_alternatives[0];
- break;
- case MR_SECTAG_LOCAL:
- sectag = MR_unmkbody(data);
- functor_desc =
- ptag_layout->MR_sectag_alternatives[sectag];
- break;
- case MR_SECTAG_REMOTE:
- sectag = MR_field(ptag, data, 0);
- functor_desc =
- ptag_layout->MR_sectag_alternatives[sectag];
- break;
- case MR_SECTAG_VARIABLE:
- MR_fatal_error(""ML_named_arg_num(): unexpected variable"");
- }
-
- if (functor_desc->MR_du_functor_arg_names == NULL) {
- return FALSE;
- }
-
- for (i = 0; i < functor_desc->MR_du_functor_orig_arity; i++) {
- if (functor_desc->MR_du_functor_arg_names[i] != NULL
- && streq(arg_name, functor_desc->MR_du_functor_arg_names[i]))
- {
- *arg_num_ptr = i;
- return TRUE;
- }
- }
-
- return FALSE;
-
- case MR_TYPECTOR_REP_EQUIV:
- eqv_type_info = MR_create_type_info(
- MR_TYPEINFO_GET_FIRST_ORDER_ARG_VECTOR(type_info),
- type_ctor_info->type_layout.layout_equiv);
- return ML_named_arg_num(eqv_type_info, term_ptr, arg_name,
- arg_num_ptr);
-
- case MR_TYPECTOR_REP_EQUIV_GROUND:
- eqv_type_info = MR_pseudo_type_info_is_ground(
- type_ctor_info->type_layout.layout_equiv);
- return ML_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 = type_ctor_info->type_functors.functors_notag;
-
- if (notag_functor_desc->MR_notag_functor_arg_name != NULL
- && streq(arg_name, notag_functor_desc->MR_notag_functor_arg_name))
- {
- *arg_num_ptr = 0;
- return TRUE;
- }
-
- return FALSE;
-
- default:
- return FALSE;
- }
-}
-
-").
-
%-----------------------------------------------------------------------------%
% Code for functor, arg and deconstruct.
-:- pragma foreign_proc("C", functor(Term::in, Functor::out, Arity::out),
- will_not_call_mercury, "
+:- pragma foreign_proc("C",
+ functor(Term::in, Functor::out, Arity::out),
+ [will_not_call_mercury], "
{
- MR_TypeInfo type_info;
- ML_Expand_Functor_Only_Info expand_info;
-
- type_info = (MR_TypeInfo) TypeInfo_for_T;
-
- MR_save_transient_registers();
- ML_expand_functor_only(type_info, &Term, &expand_info);
- MR_restore_transient_registers();
+#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
+}").
- ML_abort_if_type_is_noncanonical(expand_info, ""functor/3"");
- ML_deconstruct_get_functor(expand_info, functor_only, Functor);
- ML_deconstruct_get_arity(expand_info, Arity);
+:- pragma foreign_proc("C",
+ functor_cc(Term::in, Functor::out, Arity::out),
+ will_not_call_mercury, "
+{
+#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
}").
/*
@@ -3540,88 +3136,233 @@
** changes to store__arg_ref in store.m.
*/
-:- pragma foreign_proc("C", arg(Term::in, ArgumentIndex::in) = (Argument::out),
- will_not_call_mercury, "
+:- pragma foreign_proc("C",
+ arg(Term::in, ArgumentIndex::in) = (Argument::out),
+ [will_not_call_mercury], "
{
- MR_TypeInfo type_info;
- MR_TypeInfo exp_arg_type_info;
- MR_TypeInfo arg_type_info;
- MR_Word *argument_ptr;
- bool success;
- int comparison_result;
-
- type_info = (MR_TypeInfo) TypeInfo_for_T;
- exp_arg_type_info = (MR_TypeInfo) TypeInfo_for_ArgT;
-
- MR_save_transient_registers();
- success = ML_arg(type_info, &Term, ArgumentIndex,
- &arg_type_info, &argument_ptr);
-
- if (success) {
- /* compare the actual type of the argument with its expected type */
- comparison_result = MR_compare_type_info(arg_type_info,
- exp_arg_type_info);
- success = (comparison_result == MR_COMPARE_EQUAL);
-
- if (success) {
- Argument = *argument_ptr;
- }
- }
+#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
+}").
- MR_restore_transient_registers();
- SUCCESS_INDICATOR = success;
+:- pragma foreign_proc("C",
+ arg_cc(Term::in, ArgumentIndex::in, Argument::out),
+ [will_not_call_mercury], "
+{
+#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, "
+ [will_not_call_mercury], "
{
- MR_TypeInfo type_info;
- MR_TypeInfo arg_type_info;
- MR_Word *argument_ptr;
- bool success;
-
- type_info = (MR_TypeInfo) TypeInfo_for_T;
-
- MR_save_transient_registers();
- success = ML_arg(type_info, &Term, ArgumentIndex,
- &arg_type_info, &argument_ptr);
- MR_restore_transient_registers();
-
- if (success) {
- /* Allocate enough room for a univ */
- MR_new_univ_on_hp(ArgumentUniv, arg_type_info, *argument_ptr);
- }
+#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
+}").
- SUCCESS_INDICATOR = success;
+:- pragma foreign_proc("C",
+ argument_cc(Term::in, ArgumentIndex::in, ArgumentUniv::out),
+ [will_not_call_mercury], "
+{
+#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], "
{
- MR_TypeInfo type_info;
- MR_TypeInfo arg_type_info;
- MR_Word *argument_ptr;
- bool success;
+#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], "
+{
+#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
+}").
- type_info = (MR_TypeInfo) TypeInfo_for_T;
+:- pragma foreign_proc("C",
+ deconstruct(Term::in, Functor::out, Arity::out, Arguments::out),
+ [will_not_call_mercury],
+"{
+#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
+}").
- MR_save_transient_registers();
- success = ML_named_arg(type_info, &Term, (MR_ConstString) ArgumentName,
- &arg_type_info, &argument_ptr);
- MR_restore_transient_registers();
+:- pragma foreign_proc("C",
+ deconstruct_cc(Term::in, Functor::out, Arity::out, Arguments::out),
+ [will_not_call_mercury],
+"{
+#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
+}").
- if (success) {
- /* Allocate enough room for a univ */
- MR_new_univ_on_hp(ArgumentUniv, arg_type_info, *argument_ptr);
- }
+:- pragma foreign_proc("C",
+ limited_deconstruct(Term::in, MaxArity::in, Functor::out,
+ Arity::out, Arguments::out),
+ [will_not_call_mercury],
+" {
+#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
+}").
- SUCCESS_INDICATOR = success;
+:- pragma foreign_proc("C",
+ limited_deconstruct_cc(Term::in, MaxArity::in, Functor::out,
+ Arity::out, Arguments::out),
+ [will_not_call_mercury],
+" {
+#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
}").
:- pragma foreign_proc("MC++", functor(_Term::in, _Functor::out, _Arity::out),
- will_not_call_mercury, "
+ [will_not_call_mercury], "
{
mercury::runtime::Errors::SORRY(""foreign code for functor"");
}").
@@ -3633,7 +3374,7 @@
:- pragma foreign_proc("C#",
arg(_Term::in, _ArgumentIndex::in) = (_Argument::out),
- will_not_call_mercury, "
+ [will_not_call_mercury], "
{
mercury.runtime.Errors.SORRY(""foreign code for arg"");
// XXX this is required to keep the C# compiler quiet
@@ -3641,8 +3382,17 @@
}").
:- pragma foreign_proc("C#",
+ arg_cc(_Term::in, _ArgumentIndex::in, _Argument::out),
+ [will_not_call_mercury], "
+{
+ 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, "
+ [will_not_call_mercury], "
{
mercury.runtime.Errors.SORRY(""foreign code for argument"");
// XXX this is required to keep the C# compiler quiet
@@ -3650,10 +3400,28 @@
}").
:- pragma foreign_proc("C#",
+ argument_cc(_Term::in, _ArgumentIndex::in, _ArgumentUniv::out),
+ [will_not_call_mercury], "
+{
+ 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], "
{
- mercury.runtime.Errors.SORRY(""foreign code for argument"");
+ 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], "
+{
+ mercury.runtime.Errors.SORRY(""foreign code for named_argument_cc"");
// XXX this is required to keep the C# compiler quiet
SUCCESS_INDICATOR = false;
}").
@@ -3663,9 +3431,20 @@
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
;
- error("det_arg: argument had wrong type")
+ ( argument_cc(Type, ArgumentIndex, _ArgumentUniv) ->
+ error("det_arg_cc: argument had wrong type")
+ ;
+ error("det_arg_cc: argument number out of range")
)
).
@@ -3676,59 +3455,26 @@
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")
).
-
-:- pragma foreign_proc("C",
- deconstruct(Term::in, Functor::out, Arity::out,
- Arguments::out), will_not_call_mercury, "
-{
- ML_Expand_Functor_Args_Info expand_info;
- MR_TypeInfo type_info;
-
- type_info = (MR_TypeInfo) TypeInfo_for_T;
-
- MR_save_transient_registers();
- ML_expand_functor_args(type_info, &Term, &expand_info);
- MR_restore_transient_registers();
-
- ML_abort_if_type_is_noncanonical(expand_info, ""deconstruct/4"");
- ML_deconstruct_get_functor(expand_info, functor, Functor);
- ML_deconstruct_get_arity(expand_info, Arity);
- ML_deconstruct_get_arg_list(expand_info, args, Arguments);
- ML_deconstruct_free_allocated_arg_type_infos(expand_info, args);
-}").
-
-:- pragma foreign_proc("C",
- limited_deconstruct(Term::in, MaxArity::in, Functor::out, Arity::out,
- Arguments::out), will_not_call_mercury, "
-{
- ML_Expand_Functor_Args_Limit_Info expand_info;
- MR_TypeInfo type_info;
-
- type_info = (MR_TypeInfo) TypeInfo_for_T;
-
- MR_save_transient_registers();
- ML_expand_functor_args_limit(type_info, &Term, MaxArity, &expand_info);
- MR_restore_transient_registers();
- ML_abort_if_type_is_noncanonical(expand_info, ""limited_deconstruct/5"");
-
- if (expand_info.limit_reached) {
- SUCCESS_INDICATOR = FALSE;
- } else {
- SUCCESS_INDICATOR = TRUE;
-
- ML_deconstruct_get_functor(expand_info, functor, Functor);
- ML_deconstruct_get_arity(expand_info, Arity);
- ML_deconstruct_get_arg_list(expand_info, args, Arguments);
- ML_deconstruct_free_allocated_arg_type_infos(expand_info, args);
- }
-}").
+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).
Index: library/store.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/store.m,v
retrieving revision 1.28
diff -u -b -r1.28 store.m
--- library/store.m 2001/08/06 14:11:35 1.28
+++ library/store.m 2002/01/01 10:30:26
@@ -342,11 +342,8 @@
#include ""mercury_type_info.h""
#include ""mercury_heap.h""
#include ""mercury_misc.h"" /* for MR_fatal_error() */
+ #include ""mercury_deconstruct.h"" /* for MR_arg() */
- /* ML_arg() is defined in std_util.m */
- bool ML_arg(MR_TypeInfo term_type_info, MR_Word *term, int arg_index,
- MR_TypeInfo *arg_type_info_ptr, MR_Word **arg_ptr);
-
").
:- pragma foreign_proc("C",
@@ -363,8 +360,8 @@
MR_save_transient_registers();
- if (!ML_arg(type_info, (MR_Word *) Ref, ArgNum,
- &arg_type_info, &arg_ref))
+ if (!MR_arg(type_info, (MR_Word *) Ref, ArgNum, &arg_type_info,
+ &arg_ref, MR_ABORT_ON_NONCANONICAL, ""arg_ref/4""))
{
MR_fatal_error(
""store__arg_ref: argument number out of range"");
@@ -396,8 +393,8 @@
MR_save_transient_registers();
- if (!ML_arg(type_info, (MR_Word *) &Val, ArgNum,
- &arg_type_info, &arg_ref))
+ if (!MR_arg(type_info, (MR_Word *) &Val, ArgNum, &arg_type_info,
+ &arg_ref, MR_ABORT_ON_NONCANONICAL, ""new_arg_ref/5""))
{
MR_fatal_error(
""store__new_arg_ref: argument number out of range"");
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.79
diff -u -b -r1.79 Mmakefile
--- runtime/Mmakefile 2001/12/27 07:25:22 1.79
+++ runtime/Mmakefile 2002/01/01 12:51:48
@@ -42,6 +42,8 @@
mercury_conf_param.h \
mercury_context.h \
mercury_debug.h \
+ mercury_deconstruct.h \
+ mercury_deconstruct_macros.h \
mercury_deep_copy.h \
mercury_deep_profiling.h \
mercury_deep_profiling_hand.h \
@@ -95,7 +97,7 @@
$(LIB_DLL_H)
# The headers in $(BODY_HDRS) contain code schemes included multiple times
-# in one source file each. Their dependencies must be explicitly listed.
+# in one or more source files. Their dependencies must be explicitly listed.
# They do not have to be syntactically well-formed.
BODY_HDRS = \
@@ -109,7 +111,10 @@
mercury_hand_compare_body.h \
mercury_hand_unify_body.h \
mercury_make_type_info_body.h \
+ mercury_ml_arg_body.h \
+ mercury_ml_deconstruct_body.h \
mercury_ml_expand_body.h \
+ mercury_ml_functor_body.h \
mercury_unify_compare_body.h
# Note that $(LIB_GLOBALS_H) cannot be part of $(HDRS), since it depends on
@@ -136,6 +141,7 @@
mercury_bootstrap.c \
mercury_context.c \
mercury_debug.c \
+ mercury_deconstruct.c \
mercury_deep_copy.c \
mercury_deep_profiling.c \
mercury_dlist.c \
Index: runtime/mercury_deconstruct.c
===================================================================
RCS file: mercury_deconstruct.c
diff -N mercury_deconstruct.c
--- /dev/null Fri Dec 1 02:25:58 2000
+++ mercury_deconstruct.c Tue Jan 1 21:31:26 2002
@@ -0,0 +1,324 @@
+/*
+** vim:ts=4 sw=4 expandtab
+*/
+/*
+** Copyright (C) 2001 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_deconstruct.c
+**
+** This file provides utility functions for deconstructing terms, for use by
+** the standard library.
+*/
+
+#include "mercury_imp.h"
+#include "mercury_deconstruct.h"
+#include "mercury_deconstruct_macros.h"
+
+#define EXPAND_FUNCTION_NAME MR_expand_functor_args
+#define EXPAND_TYPE_NAME MR_Expand_Functor_Args_Info
+#define EXPAND_FUNCTOR_FIELD functor
+#define EXPAND_ARGS_FIELD args
+#include "mercury_ml_expand_body.h"
+#undef EXPAND_FUNCTION_NAME
+#undef EXPAND_TYPE_NAME
+#undef EXPAND_FUNCTOR_FIELD
+#undef EXPAND_ARGS_FIELD
+
+#define EXPAND_FUNCTION_NAME MR_expand_functor_args_limit
+#define EXPAND_TYPE_NAME MR_Expand_Functor_Args_Limit_Info
+#define EXPAND_FUNCTOR_FIELD functor
+#define EXPAND_ARGS_FIELD args
+#define EXPAND_APPLY_LIMIT
+#include "mercury_ml_expand_body.h"
+#undef EXPAND_FUNCTION_NAME
+#undef EXPAND_TYPE_NAME
+#undef EXPAND_FUNCTOR_FIELD
+#undef EXPAND_ARGS_FIELD
+#undef EXPAND_APPLY_LIMIT
+
+#define EXPAND_FUNCTION_NAME MR_expand_functor_only
+#define EXPAND_TYPE_NAME MR_Expand_Functor_Only_Info
+#define EXPAND_FUNCTOR_FIELD functor_only
+#include "mercury_ml_expand_body.h"
+#undef EXPAND_FUNCTION_NAME
+#undef EXPAND_TYPE_NAME
+#undef EXPAND_FUNCTOR_FIELD
+
+#define EXPAND_FUNCTION_NAME MR_expand_args_only
+#define EXPAND_TYPE_NAME MR_Expand_Args_Only_Info
+#define EXPAND_ARGS_FIELD args_only
+#include "mercury_ml_expand_body.h"
+#undef EXPAND_FUNCTION_NAME
+#undef EXPAND_TYPE_NAME
+#undef EXPAND_ARGS_FIELD
+
+#define EXPAND_FUNCTION_NAME MR_expand_chosen_arg_only
+#define EXPAND_TYPE_NAME MR_Expand_Chosen_Arg_Only_Info
+#define EXPAND_CHOSEN_ARG
+#include "mercury_ml_expand_body.h"
+#undef EXPAND_FUNCTION_NAME
+#undef EXPAND_TYPE_NAME
+#undef EXPAND_CHOSEN_ARG
+
+#define EXPAND_FUNCTION_NAME MR_expand_named_arg_only
+#define EXPAND_TYPE_NAME MR_Expand_Chosen_Arg_Only_Info
+#define EXPAND_NAMED_ARG
+#include "mercury_ml_expand_body.h"
+#undef EXPAND_FUNCTION_NAME
+#undef EXPAND_TYPE_NAME
+#undef EXPAND_NAMED_ARG
+
+/*
+** MR_arg() is a subroutine used to implement arg/2, argument/2,
+** and also store__arg_ref/5 in store.m.
+** It takes the address of a term, its type, and an argument index.
+** If the selected argument exists, it succeeds and returns the address
+** of the argument, and its type; if it doesn't, it fails (i.e. returns FALSE).
+**
+** You need to wrap MR_{save/restore}_transient_hp() around
+** calls to this function.
+*/
+
+bool
+MR_arg(MR_TypeInfo type_info, MR_Word *term_ptr, int arg_index,
+ MR_TypeInfo *arg_type_info_ptr, MR_Word **arg_ptr,
+ MR_non_canon_handling noncanon_handling, MR_ConstString msg)
+{
+ MR_Expand_Chosen_Arg_Only_Info expand_info;
+
+ MR_expand_chosen_arg_only(type_info, term_ptr, arg_index, &expand_info);
+ if (expand_info.non_canonical_type) {
+ switch (noncanon_handling) {
+ case MR_ALLOW_NONCANONICAL:
+ break;
+
+ case MR_FAIL_ON_NONCANONICAL:
+ return FALSE;
+ break;
+
+ case MR_ABORT_ON_NONCANONICAL:
+ MR_fatal_error(msg);
+ break;
+
+ default:
+ MR_fatal_error("MR_arg: bad noncanon_handling");
+ break;
+ }
+ }
+
+ /* Check range */
+ if (expand_info.chosen_index_exists) {
+ *arg_type_info_ptr = expand_info.chosen_type_info;
+ *arg_ptr = expand_info.chosen_value_ptr;
+ return TRUE;
+ }
+
+ return FALSE;
+}
+
+/*
+** MR_named_arg() is a subroutine used to implement named_arg/2.
+** It takes the address of a term, its type, and an argument name.
+** If an argument with that name exists, it succeeds and returns the address
+** of the argument, and its type; if it doesn't, it fails (i.e. returns FALSE).
+**
+** You need to wrap MR_{save/restore}_transient_hp() around
+** calls to this function.
+*/
+
+bool
+MR_named_arg(MR_TypeInfo type_info, MR_Word *term_ptr, MR_ConstString arg_name,
+ MR_TypeInfo *arg_type_info_ptr, MR_Word **arg_ptr,
+ MR_non_canon_handling noncanon_handling, MR_ConstString msg)
+{
+ MR_Expand_Chosen_Arg_Only_Info expand_info;
+
+ MR_expand_named_arg_only(type_info, term_ptr, arg_name, &expand_info);
+ if (expand_info.non_canonical_type) {
+ switch (noncanon_handling) {
+ case MR_ALLOW_NONCANONICAL:
+ break;
+
+ case MR_FAIL_ON_NONCANONICAL:
+ return FALSE;
+ break;
+
+ case MR_ABORT_ON_NONCANONICAL:
+ MR_fatal_error(msg);
+ break;
+
+ default:
+ MR_fatal_error("MR_named_arg: bad noncanon_handling");
+ break;
+ }
+ }
+
+ /* Check range */
+ if (expand_info.chosen_index_exists) {
+ *arg_type_info_ptr = expand_info.chosen_type_info;
+ *arg_ptr = expand_info.chosen_value_ptr;
+ return TRUE;
+ }
+
+ return FALSE;
+}
+
+/*
+** MR_named_arg_num() takes the address of a term, its type, and an argument
+** name. If the given term has an argument with the given name, it succeeds and
+** returns the argument number (counted starting from 0) of the argument;
+** if it doesn't, it fails (i.e. returns FALSE).
+**
+** You need to wrap MR_{save/restore}_transient_hp() around
+** calls to this function.
+*/
+
+bool
+MR_named_arg_num(MR_TypeInfo type_info, MR_Word *term_ptr,
+ const char *arg_name, int *arg_num_ptr)
+{
+ MR_TypeCtorInfo type_ctor_info;
+ MR_DuTypeLayout du_type_layout;
+ const MR_DuPtagLayout *ptag_layout;
+ const MR_DuFunctorDesc *functor_desc;
+ const MR_NotagFunctorDesc *notag_functor_desc;
+ MR_Word data;
+ int ptag;
+ MR_Word sectag;
+ MR_TypeInfo eqv_type_info;
+ int i;
+
+ type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
+
+ switch (type_ctor_info->type_ctor_rep) {
+ case MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ:
+ case MR_TYPECTOR_REP_RESERVED_ADDR:
+ {
+ MR_ReservedAddrTypeLayout ra_layout;
+
+ ra_layout = type_ctor_info->type_layout.layout_reserved_addr;
+ data = *term_ptr;
+
+ /*
+ ** First check if this value is one of
+ ** the numeric reserved addresses.
+ */
+ if ((MR_Unsigned) data <
+ (MR_Unsigned) ra_layout->MR_ra_num_res_numeric_addrs)
+ {
+ /*
+ ** If so, it must be a constant, and constants never have
+ ** any arguments.
+ */
+ return FALSE;
+ }
+
+ /*
+ ** Next check if this value is one of the
+ ** the symbolic reserved addresses.
+ */
+ for (i = 0; i < ra_layout->MR_ra_num_res_symbolic_addrs; i++) {
+ if (data == (MR_Word) ra_layout->MR_ra_res_symbolic_addrs[i]) {
+ return FALSE;
+ }
+ }
+
+ /*
+ ** Otherwise, it is not one of the reserved addresses,
+ ** so handle it like a normal DU type.
+ */
+ du_type_layout = ra_layout->MR_ra_other_functors;
+ goto du_type;
+ }
+
+
+ case MR_TYPECTOR_REP_DU_USEREQ:
+ case MR_TYPECTOR_REP_DU:
+ data = *term_ptr;
+ du_type_layout = type_ctor_info->type_layout.layout_du;
+ /* fall through */
+
+ /*
+ ** This label handles both the DU case and the second half of the
+ ** RESERVED_ADDR case. `du_type_layout' and `data' must both be
+ ** set before this code is entered.
+ */
+ du_type:
+ ptag = MR_tag(data);
+ ptag_layout = &du_type_layout[ptag];
+
+ switch (ptag_layout->MR_sectag_locn) {
+ case MR_SECTAG_NONE:
+ functor_desc = ptag_layout->MR_sectag_alternatives[0];
+ break;
+ case MR_SECTAG_LOCAL:
+ sectag = MR_unmkbody(data);
+ functor_desc = ptag_layout->MR_sectag_alternatives[sectag];
+ break;
+ case MR_SECTAG_REMOTE:
+ sectag = MR_field(ptag, data, 0);
+ functor_desc = ptag_layout->MR_sectag_alternatives[sectag];
+ break;
+ case MR_SECTAG_VARIABLE:
+ MR_fatal_error("MR_named_arg_num(): unexpected variable");
+ }
+
+ if (functor_desc->MR_du_functor_arg_names == NULL) {
+ return FALSE;
+ }
+
+ for (i = 0; i < functor_desc->MR_du_functor_orig_arity; i++) {
+ if (functor_desc->MR_du_functor_arg_names[i] != NULL
+ && streq(arg_name, functor_desc->MR_du_functor_arg_names[i]))
+ {
+ *arg_num_ptr = i;
+ return TRUE;
+ }
+ }
+
+ return FALSE;
+
+ case MR_TYPECTOR_REP_EQUIV:
+ eqv_type_info = MR_create_type_info(
+ MR_TYPEINFO_GET_FIRST_ORDER_ARG_VECTOR(type_info),
+ type_ctor_info->type_layout.layout_equiv);
+ return MR_named_arg_num(eqv_type_info, term_ptr, arg_name,
+ arg_num_ptr);
+
+ case MR_TYPECTOR_REP_EQUIV_GROUND:
+ eqv_type_info = MR_pseudo_type_info_is_ground(
+ type_ctor_info->type_layout.layout_equiv);
+ 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 = type_ctor_info->type_functors.functors_notag;
+
+ if (notag_functor_desc->MR_notag_functor_arg_name != NULL
+ && streq(arg_name, notag_functor_desc->MR_notag_functor_arg_name))
+ {
+ *arg_num_ptr = 0;
+ return TRUE;
+ }
+
+ return FALSE;
+
+ default:
+ return FALSE;
+ }
+}
Index: runtime/mercury_deconstruct.h
===================================================================
RCS file: mercury_deconstruct.h
diff -N mercury_deconstruct.h
--- /dev/null Fri Dec 1 02:25:58 2000
+++ mercury_deconstruct.h Tue Jan 1 23:59:01 2002
@@ -0,0 +1,137 @@
+/*
+** vim:ts=4 sw=4 expandtab
+*/
+
+/*
+** Copyright (C) 2001 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_deconstruct.h
+**
+** This file declares utility functions for deconstructing terms,
+** for use by the standard library and the debugger.
+*/
+
+#ifndef MERCURY_DECONSTRUCT_H
+#define MERCURY_DECONSTRUCT_H
+
+#include "mercury_imp.h"
+#include <stdio.h>
+
+typedef struct {
+ int num_extra_args;
+ MR_Word *arg_values;
+ MR_TypeInfo *arg_type_infos;
+ bool can_free_arg_type_infos;
+} MR_Expand_Args_Fields;
+
+typedef struct {
+ bool non_canonical_type;
+ int arity;
+ MR_ConstString functor;
+ MR_Expand_Args_Fields args;
+} MR_Expand_Functor_Args_Info;
+
+typedef struct {
+ bool non_canonical_type;
+ int arity;
+ MR_ConstString functor;
+ MR_Expand_Args_Fields args;
+ bool limit_reached;
+} MR_Expand_Functor_Args_Limit_Info;
+
+typedef struct {
+ bool non_canonical_type;
+ int arity;
+ MR_ConstString functor_only;
+} MR_Expand_Functor_Only_Info;
+
+typedef struct {
+ bool non_canonical_type;
+ int arity;
+ MR_Expand_Args_Fields args_only;
+} MR_Expand_Args_Only_Info;
+
+typedef struct {
+ bool non_canonical_type;
+ int arity;
+ bool chosen_index_exists;
+ MR_Word *chosen_value_ptr;
+ MR_TypeInfo chosen_type_info;
+} MR_Expand_Chosen_Arg_Only_Info;
+
+extern void MR_expand_functor_args(MR_TypeInfo type_info,
+ MR_Word *data_word_ptr,
+ MR_Expand_Functor_Args_Info *expand_info);
+
+extern void MR_expand_functor_args_limit(MR_TypeInfo type_info,
+ MR_Word *data_word_ptr, int max_arity,
+ MR_Expand_Functor_Args_Limit_Info *expand_info);
+
+extern void MR_expand_functor_only(MR_TypeInfo type_info,
+ MR_Word *data_word_ptr,
+ MR_Expand_Functor_Only_Info *expand_info);
+
+extern void MR_expand_args_only(MR_TypeInfo type_info,
+ MR_Word *data_word_ptr,
+ MR_Expand_Args_Only_Info *expand_info);
+
+extern void MR_expand_chosen_arg_only(MR_TypeInfo type_info,
+ MR_Word *data_word_ptr, int chosen,
+ MR_Expand_Chosen_Arg_Only_Info *expand_info);
+
+extern void MR_expand_named_arg_only(MR_TypeInfo type_info,
+ MR_Word *data_word_ptr, MR_ConstString chosen_name,
+ MR_Expand_Chosen_Arg_Only_Info *expand_info);
+
+typedef enum {
+ MR_ALLOW_NONCANONICAL,
+ MR_FAIL_ON_NONCANONICAL,
+ MR_ABORT_ON_NONCANONICAL
+} MR_non_canon_handling;
+
+ /*
+ ** MR_arg() takes the address of a term, its type, and an
+ ** argument position (the first argument being at position 1).
+ ** If the given term has an argument at that position, MR_arg
+ ** returns TRUE and fills in the locations pointed to by the
+ ** argument_ptr and arg_type_info_ptr arguments with the value
+ ** and type of the argument at the selected position.
+ **
+ ** The noncanon argument says how MR_arg should behave if the
+ ** term being deconstructed is of a non-canonical type. The msg
+ ** is for use if noncanon is MR_ABORT_ON_NONCANONICAL.
+ */
+
+extern bool MR_arg(MR_TypeInfo type_info, MR_Word *term, int arg_index,
+ MR_TypeInfo *arg_type_info_ptr, MR_Word **argument_ptr,
+ MR_non_canon_handling noncanon, MR_ConstString msg);
+
+ /*
+ ** MR_named_arg() is just like MR_arg, except the argument
+ ** is selected by name, not by position.
+ */
+
+extern bool MR_named_arg(MR_TypeInfo type_info, MR_Word *term,
+ MR_ConstString arg_name, MR_TypeInfo *arg_type_info_ptr,
+ MR_Word **argument_ptr, MR_non_canon_handling noncanon,
+ MR_ConstString msg);
+
+ /*
+ ** MR_named_arg_num() takes the address of a term, its type,
+ ** and an argument name. If the given term has an argument
+ ** with the given name, it succeeds and returns the argument
+ ** number (counted starting from 0) of the argument; if it
+ ** doesn't, it fails (i.e. returns FALSE).
+ **
+ ** You need to wrap MR_{save/restore}_transient_hp() around
+ ** calls to this function.
+ */
+
+extern bool MR_named_arg_num(MR_TypeInfo type_info, MR_Word *term_ptr,
+ const char *arg_name, int *arg_num_ptr);
+
+#endif /* MERCURY_DECONSTRUCT_H */
Index: runtime/mercury_ml_arg_body.h
===================================================================
RCS file: mercury_ml_arg_body.h
diff -N mercury_ml_arg_body.h
--- /dev/null Fri Dec 1 02:25:58 2000
+++ mercury_ml_arg_body.h Tue Jan 1 20:00:22 2002
@@ -0,0 +1,85 @@
+/*
+** vim:ts=4 sw=4 expandtab
+*/
+/*
+** Copyright (C) 2001 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_ml_arg_body.h
+**
+** This file is included several times in library/std_util.m. Each inclusion
+** defines the body of one of several variants of `arg' function.
+**
+** The code including this file must define these macros:
+**
+** PREDNAME Gives the name of the function or predicate being
+** defined.
+**
+** NONCANON_HANDLING Gives the desired handling of non-canonical types
+** as a value of C type MR_noncanon_handling.
+**
+** TYPEINFO_ARG Gives the name of the argument that contains the
+** typeinfo of the term being deconstructed.
+**
+** TERM_ARG Gives the name of the argument that contains the
+** value of the term being deconstructed.
+**
+** SELECTOR_ARG Gives the C expression that selects one field of the
+** term.
+**
+** SELECTED_ARG Gives the name of the argument to which the value of
+** the selected field should be assigned.
+**
+** The code including this file may define these macros:
+**
+** SELECT_BY_NAME If defined, the argument is selected by name; if it is
+** not defined, the argument is selected by position.
+**
+** EXPECTED_TYPE_INFO If defined, gives a C expression containing the
+** typeinfo of the expected type
+*/
+
+#ifdef SELECT_BY_NAME
+ #define arg_func MR_named_arg
+#else
+ #define arg_func MR_arg
+#endif
+
+ MR_TypeInfo type_info;
+ MR_TypeInfo arg_type_info;
+ MR_Word *argument_ptr;
+ bool success;
+
+ type_info = (MR_TypeInfo) TYPEINFO_ARG;
+
+ MR_save_transient_registers();
+ success = arg_func(type_info, &TERM_ARG, SELECTOR_ARG, &arg_type_info,
+ &argument_ptr, NONCANON_HANDLING, MR_noncanon_msg(PREDNAME));
+#ifdef EXPECTED_TYPE_INFO
+ if (success) { \
+ /* compare the actual type of the argument with its expected type */\
+ int comparison_result; \
+ comparison_result = MR_compare_type_info(arg_type_info, \
+ (MR_TypeInfo) EXPECTED_TYPE_INFO); \
+ success = (comparison_result == MR_COMPARE_EQUAL); \
+ \
+ if (success) { \
+ SELECTED_ARG = *argument_ptr; \
+ } \
+ } \
+ \
+ MR_restore_transient_registers(); \
+ SUCCESS_INDICATOR = success;
+#else
+ MR_restore_transient_registers(); \
+ if (success) { \
+ MR_new_univ_on_hp(SELECTED_ARG, arg_type_info, *argument_ptr); \
+ } \
+ \
+ SUCCESS_INDICATOR = success;
+#endif
+
+#undef arg_func
Index: runtime/mercury_ml_deconstruct_body.h
===================================================================
RCS file: mercury_ml_deconstruct_body.h
diff -N mercury_ml_deconstruct_body.h
--- /dev/null Fri Dec 1 02:25:58 2000
+++ mercury_ml_deconstruct_body.h Tue Jan 1 21:42:05 2002
@@ -0,0 +1,97 @@
+/*
+** vim:ts=4 sw=4 expandtab
+*/
+/*
+** Copyright (C) 2001 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_ml_deconstruct_body.h
+**
+** This file is included several times in library/std_util.m. Each inclusion
+** defines the body of one of several variants of `deconstruct' function.
+**
+** The code including this file must define these macros:
+**
+** PREDNAME Gives the name of the function or predicate being
+** defined.
+**
+** EXPAND_INFO_CALL Gives the name of the MR_expand_functor_* variant that
+** we want to use.
+**
+** EXPAND_INFO_TYPE Gives the type of the expand_info argument of
+** EXPAND_INFO_CALL.
+**
+** TYPEINFO_ARG Gives the name of the argument that contains the
+** typeinfo of the term being deconstructed.
+**
+** TERM_ARG Gives the name of the argument that contains the
+** value of the term being deconstructed.
+**
+** FUNCTOR_ARG Gives the name of the argument to which we assign
+** the function symbol of the term.
+**
+** ARITY_ARG Gives the name of the argument to which the value of
+** the arity field should be assigned.
+**
+** ARGUMENTS_ARG Gives the name of the argument to which the list of
+** univs representing the arguments of the term should
+** be assigned.
+**
+** The code including this file may define these macros:
+**
+** ALLOW_NONCANONICAL If defined, allow the deconstruction of non-canonical
+** types. If not defined, abort if the type being
+** deconstructed is non-canonical.
+**
+** MAX_ARITY_ARG If defined, gives the name of the argument whose value
+** gives the maximum number of arguments we want to
+** succeed for.
+*/
+
+#ifdef ALLOW_NONCANONICAL
+ #define maybe_abort_if_noncanonical(expand_info, msg) \
+ ((void) 0)
+#else
+ #define maybe_abort_if_noncanonical(expand_info, msg) \
+ MR_abort_if_type_is_noncanonical(expand_info, msg)
+#endif
+
+#ifdef MAX_ARITY_ARG
+ #define maybe_max_arity_arg MAX_ARITY_ARG,
+ #define max_arity_check_start \
+ if (expand_info.limit_reached) { \
+ SUCCESS_INDICATOR = FALSE; \
+ } else { \
+ SUCCESS_INDICATOR = TRUE;
+ #define max_arity_check_end }
+#else
+ #define maybe_max_arity_arg
+ #define max_arity_check_start
+ #define max_arity_check_end
+#endif
+
+ EXPAND_INFO_TYPE expand_info;
+ MR_TypeInfo type_info;
+
+ type_info = (MR_TypeInfo) TYPEINFO_ARG;
+
+ MR_save_transient_registers();
+ EXPAND_INFO_CALL(type_info, &TERM_ARG, maybe_max_arity_arg &expand_info);
+ MR_restore_transient_registers();
+
+ maybe_abort_if_noncanonical(expand_info, MR_noncanon_msg(PREDNAME));
+
+ max_arity_check_start
+ MR_deconstruct_get_functor(expand_info, functor, FUNCTOR_ARG);
+ MR_deconstruct_get_arity(expand_info, ARITY_ARG);
+ MR_deconstruct_get_arg_list(expand_info, args, ARGUMENTS_ARG);
+ MR_deconstruct_free_allocated_arg_type_infos(expand_info, args);
+ max_arity_check_end
+
+#undef maybe_abort_if_noncanonical
+#undef maybe_max_arity_arg
+#undef max_arity_check_start
+#undef max_arity_check_end
Index: runtime/mercury_ml_expand_body.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_ml_expand_body.h,v
retrieving revision 1.6
diff -u -b -r1.6 mercury_ml_expand_body.h
--- runtime/mercury_ml_expand_body.h 2001/12/31 04:26:50 1.6
+++ runtime/mercury_ml_expand_body.h 2002/01/01 12:43:29
@@ -1,4 +1,7 @@
/*
+** vim:ts=4 sw=4 expandtab
+*/
+/*
** Copyright (C) 2001 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.
@@ -7,10 +10,10 @@
/*
** mercury_ml_expand_body.h
**
-** This file is included several times in library/std_util.m. Each inclusion
-** defines the body of one of several variants of the old ML_expand function,
-** which, given a data word and its type_info, returned its functor, arity,
-** argument vector and a type_info vector describing its arguments.
+** This file is included several times in runtime/mercury_deconstruct.c. Each
+** inclusion defines the body of one of several variants of the old ML_expand
+** function, which, given a data word and its type_info, returned its functor,
+** arity, argument vector and a type_info vector describing its arguments.
** One variant still does all that. The others perform different subsets of
** this task. The reason for having those specialized variants is that
** executing the full task can be extremely time consuming, especially when
Index: runtime/mercury_ml_functor_body.h
===================================================================
RCS file: mercury_ml_functor_body.h
diff -N mercury_ml_functor_body.h
--- /dev/null Fri Dec 1 02:25:58 2000
+++ mercury_ml_functor_body.h Tue Jan 1 20:58:46 2002
@@ -0,0 +1,61 @@
+/*
+** vim:ts=4 sw=4 expandtab
+*/
+/*
+** Copyright (C) 2001 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_ml_functor_body.h
+**
+** This file is included several times in library/std_util.m. Each inclusion
+** defines the body of one of several variants of `functor' function.
+**
+** The code including this file must define these macros:
+**
+** PREDNAME Gives the name of the function or predicate being
+** defined.
+**
+** TYPEINFO_ARG Gives the name of the argument that contains the
+** typeinfo of the term being deconstructed.
+**
+** TERM_ARG Gives the name of the argument that contains the
+** value of the term being deconstructed.
+**
+** FUNCTOR_ARG Gives the name of the argument to which we assign
+** the function symbol of the term.
+**
+** ARITY_ARG Gives the name of the argument to which we assign
+** the arity of the term.
+**
+** The code including this file may define these macros:
+**
+** ALLOW_NONCANONICAL If defined, allow the deconstruction of non-canonical
+** types. If not defined, abort if the type being
+** deconstructed is non-canonical.
+*/
+
+#ifdef ALLOW_NONCANONICAL
+ #define maybe_abort_if_noncanonical(expand_info, msg) \
+ ((void) 0)
+#else
+ #define maybe_abort_if_noncanonical(expand_info, msg) \
+ MR_abort_if_type_is_noncanonical(expand_info, msg)
+#endif
+
+ MR_TypeInfo type_info;
+ MR_Expand_Functor_Only_Info expand_info;
+
+ type_info = (MR_TypeInfo) TYPEINFO_ARG;
+
+ MR_save_transient_registers();
+ MR_expand_functor_only(type_info, &TERM_ARG, &expand_info);
+ MR_restore_transient_registers();
+
+ maybe_abort_if_noncanonical(expand_info, MR_noncanon_msg(PREDNAME));
+ MR_deconstruct_get_functor(expand_info, functor_only, FUNCTOR_ARG);
+ MR_deconstruct_get_arity(expand_info, ARITY_ARG);
+
+#undef maybe_abort_if_noncanonical
cvs diff: Diffing runtime/GETOPT
cvs diff: Diffing runtime/machdeps
cvs diff: Diffing samples
cvs diff: Diffing samples/c_interface
cvs diff: Diffing samples/c_interface/c_calls_mercury
cvs diff: Diffing samples/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/mercury_calls_c
cvs diff: Diffing samples/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/diff
cvs diff: Diffing samples/muz
cvs diff: Diffing samples/rot13
cvs diff: Diffing samples/solutions
cvs diff: Diffing samples/tests
cvs diff: Diffing samples/tests/c_interface
cvs diff: Diffing samples/tests/c_interface/c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/tests/c_interface/mercury_calls_c
cvs diff: Diffing samples/tests/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/tests/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/tests/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/tests/diff
cvs diff: Diffing samples/tests/muz
cvs diff: Diffing samples/tests/rot13
cvs diff: Diffing samples/tests/solutions
cvs diff: Diffing samples/tests/toplevel
cvs diff: Diffing scripts
cvs diff: Diffing tests
cvs diff: Diffing tests/benchmarks
cvs diff: Diffing tests/debugger
cvs diff: Diffing tests/debugger/declarative
cvs diff: Diffing tests/dppd
cvs diff: Diffing tests/general
cvs diff: Diffing tests/general/accumulator
cvs diff: Diffing tests/general/structure_reuse
cvs diff: Diffing tests/hard_coded
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_vars.c
===================================================================
RCS file: /home/mercury1/repository/mercury/trace/mercury_trace_vars.c,v
retrieving revision 1.28
diff -u -b -r1.28 mercury_trace_vars.c
--- trace/mercury_trace_vars.c 2001/12/10 06:50:15 1.28
+++ trace/mercury_trace_vars.c 2002/01/01 07:16:14
@@ -16,6 +16,7 @@
#include "mercury_array_macros.h"
#include "mercury_memory.h"
#include "mercury_layout_util.h"
+#include "mercury_deconstruct.h"
#include "mercury_stack_layout.h"
#include "mercury_trace_util.h"
#include "mercury_trace_vars.h"
@@ -864,14 +865,6 @@
MR_BROWSE_DEFAULT_FORMAT);
}
-/* ML_arg() is defined in std_util.m */
-extern bool ML_arg(MR_TypeInfo term_type_info, MR_Word *term, int arg_index,
- MR_TypeInfo *arg_type_info_ptr, MR_Word **arg_ptr);
-/* ML_named_arg_num() is defined in std_util.m */
-extern bool ML_named_arg_num(MR_TypeInfo term_type_info, MR_Word *term,
- const char *arg_name, int *arg_num_ptr);
-
-
static char *
MR_trace_browse_var(FILE *out, MR_Var_Details *var, char *path,
MR_Browser browser, MR_Browse_Caller_Type caller,
@@ -901,7 +894,7 @@
path++;
}
- /* ML_arg numbers fields from 0, not 1 */
+ /* MR_arg numbers fields from 0, not 1 */
--arg_num;
} else {
/* we have a field name */
@@ -914,7 +907,7 @@
saved_char = *path;
*path = '\0';
- if (! ML_named_arg_num(typeinfo, value,
+ if (! MR_named_arg_num(typeinfo, value,
old_path, &arg_num))
{
*path = saved_char;
@@ -929,8 +922,8 @@
path++; /* step over / or ^ */
}
- if (ML_arg(typeinfo, value, arg_num,
- &new_typeinfo, &new_value))
+ if (MR_arg(typeinfo, value, arg_num, &new_typeinfo,
+ &new_value, TRUE, "debugger"))
{
typeinfo = new_typeinfo;
value = new_value;
cvs diff: Diffing util
--------------------------------------------------------------------------
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