[m-rev.] for review: arrays and the debugger
Zoltan Somogyi
zs at cs.mu.OZ.AU
Fri Jun 15 14:37:59 AEST 2001
For review by anyone.
Allow the debugger to treat arrays as other types.
The RTTI routines used to pretend that terms of array type had no arguments.
This lead the browser to believe that their size was small, and handed them
over to io__write, which then printed the entire array. For large arrays,
this could take minutes. It also lead the browser to believe that you can't
"cd" to an element of an array.
The RTTI routines now treat arrays mostly like they treat tuples, which fixes
both problems.
The debugger's prettyprinters do not yet use limited_deconstruct; that is
future work.
library/std_util.m:
Add a new predicate, limited_deconstruct, which usually does what
deconstruct does, but fails (and does not allocate any memory) if
the arity of the supplied term is beyond a given limit. With normal
terms, the memory allocated by deconstruct to hold the typeinfos
of the arguments is not a problem. However, arrays can have millions
of elements, and for them this *is* a problem. Programmers can avoid
this problem by using imited_deconstruct instead of deconstruct.
Make ML_arg (used by the arg and argument predicates) avoid the
construction of a typeinfo vector for all the arguments, for the same
reason.
Since we now need more variants of ML_expand than ever, and we don't
want the new, relatively rarely used functionality to slow down the old
functionality, create several variants of ML_expand, each specialized
to a given use, and choose between them at compile time, not run time.
This should actually speed up the old functionality.o
runtime/mercury_ml_expand_body.h:
A new file which is included several times in library/std_util.m,
containing the bodies of the several variants of the old ML_expand.
runtime/Mmakefile:
Mention the new file.
browser/browse.m:
Avoid unlimited deconstructions when checking whether the term fits
within the size range we give to io__write.
Special case path resolution on terms of type array, because while
in the debugger we count arguments from one, array elements start at
index zero, and any other behavior would be misleading.
tests/hard_coded/deconstruct_arg.{m,exp}:
A new test case to check the various variants of ML_expand through
its callers, the predicates functor, argument, deconstruct and
limited_deconstruct, on all kinds of data types.
tests/hard_coded/Mmakefile:
Enable the new test case.
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
Index: browser/browse.m
===================================================================
RCS file: /home/mercury1/repository/mercury/browser/browse.m,v
retrieving revision 1.19
diff -u -b -r1.19 browse.m
--- browser/browse.m 2001/04/23 16:26:26 1.19
+++ browser/browse.m 2001/06/12 16:44:51
@@ -456,15 +456,21 @@
max_print_size(60).
term_size_left_from_max(Univ, MaxSize, RemainingSize) :-
- ( MaxSize < 0 ->
+ (
+ MaxSize < 0
+ ->
RemainingSize = MaxSize
;
- deconstruct(univ_value(Univ), Functor, Arity, Args),
+ limited_deconstruct(univ_value(Univ), MaxSize,
+ Functor, Arity, Args)
+ ->
string__length(Functor, FunctorSize),
PrincipalSize = FunctorSize + Arity * 2,
MaxArgsSize = MaxSize - PrincipalSize,
list__foldl(term_size_left_from_max,
Args, MaxArgsSize, RemainingSize)
+ ;
+ RemainingSize = -1
).
%---------------------------------------------------------------------------%
@@ -720,8 +726,19 @@
Univ = SubUniv
;
Path = [N | Ns],
- deconstruct(univ_value(Univ), _Functor, _Arity, Args),
- list__index1(Args, N, ArgN),
+ (
+ TypeCtor = type_ctor(univ_type(Univ)),
+ type_ctor_name(TypeCtor) = "array",
+ type_ctor_module_name(TypeCtor) = "array"
+ ->
+ % The first element of an array is at index zero.
+ ArgN = argument(univ_value(Univ), N)
+ ;
+ % The first argument of a non-array is is numbered
+ % argument 1 by the user but argument 0 by
+ % std_util:argument.
+ ArgN = argument(univ_value(Univ), N - 1)
+ ),
deref_subterm_2(ArgN, Ns, SubUniv)
).
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
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/std_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/std_util.m,v
retrieving revision 1.232
diff -u -b -r1.232 std_util.m
--- library/std_util.m 2001/06/04 13:39:15 1.232
+++ library/std_util.m 2001/06/12 16:44:41
@@ -566,6 +566,13 @@
%
:- pred deconstruct(T::in, string::out, int::out, list(univ)::out) is det.
+ % 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.
+:- pred limited_deconstruct(T::in, int::in, string::out,
+ int::out, list(univ)::out) is semidet.
+
:- implementation.
:- interface.
@@ -2795,66 +2802,79 @@
:- 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
- /*
- ** Code for functor, arg and deconstruct
- **
- ** This relies on some C primitives that take a type_info
- ** and a data_word, and get a functor, arity, argument vector,
- ** and argument type_info vector.
- */
-
- /* Type definitions */
-
- /*
- ** The last two fields, need_functor, and need_args, must
- ** be set by the caller, to indicate whether ML_expand
- ** should copy the functor (if need_functor is non-zero) or
- ** the argument vector and arg_type_infos (if need_args is
- ** non-zero). The arity will always be set.
- **
- ** ML_expand will fill in the other fields (functor, arity,
- ** arg_values, arg_type_infos, and non_canonical_type) accordingly,
- ** but the values of fields not asked for should be assumed to contain
- ** random data when ML_expand returns (that is, they should not be
- ** relied on to remain unchanged).
- **
- ** The arg_type_infos field will contain a pointer to an array of arity
- ** MR_TypeInfos, one for each user-visible field of the cell. The
- ** arg_values field will contain a pointer to an arity + num_extra_args
- ** MR_Words, one for each field of the cell, whether user-visible or not.
- ** The first num_extra_args words will be the type infos and/or typeclass
- ** infos added by the implementation to describe the types of the
- ** existentially typed fields, while the last arity words will be the
- ** user-visible fields themselves.
- */
-
/* The `#ifndef ... #define ... #endif' guards against multiple inclusion */
#ifndef ML_EXPAND_INFO_GUARD
#define ML_EXPAND_INFO_GUARD
-typedef struct ML_Expand_Info_Struct {
- MR_ConstString functor;
- int arity;
+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;
- bool need_functor;
- bool need_args;
-} ML_Expand_Info;
+ int arity;
+ MR_ConstString functor;
+ ML_Expand_Args_Fields args;
+} ML_Expand_Functor_Args_Info;
-#endif
+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(MR_TypeInfo type_info, MR_Word *data_word_ptr,
- ML_Expand_Info *expand_info);
+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);
/*
** NB. ML_arg() is also used by arg_ref and new_arg_ref
@@ -2870,489 +2890,58 @@
extern bool ML_named_arg_num(MR_TypeInfo type_info, MR_Word *term_ptr,
const char *arg_name, int *arg_num_ptr);
+#endif
+
").
:- pragma foreign_code("C", "
-
-/*
-** Expand the given data using its type_info, find its
-** functor, arity, argument vector and type_info vector.
-**
-** The expand_info.arg_type_infos is allocated using MR_GC_malloc().
-** (We need to use MR_GC_malloc() rather than MR_malloc() or malloc(),
-** since this vector may contain pointers into the Mercury heap, and
-** memory allocated with MR_malloc() or malloc() will not be traced by the
-** Boehm collector.)
-** It is the responsibility of the caller to deallocate this
-** memory (using MR_GC_free()), and to copy any fields of this vector to
-** the Mercury heap. The type_infos that the elements of
-** this vector point to are either
-** - already allocated on the heap.
-** - constants (eg type_ctor_infos)
-**
-** Please note:
-** ML_expand increments the heap pointer, however, on
-** some platforms the register windows mean that transient
-** Mercury registers may be lost. Before calling ML_expand,
-** call MR_save_transient_registers(), and afterwards, call
-** MR_restore_transient_registers().
-**
-** If writing a C function that calls MR_deep_copy, make sure you
-** document that around your function, MR_save_transient_registers()
-** MR_restore_transient_registers() need to be used.
-**
-** If you change this code you will also have reflect any changes in
-** runtime/mercury_deep_copy_body.h and runtime/mercury_tabling.c
-**
-** We use 4 space tabs here because of the level of indenting.
-*/
-
-void
-ML_expand(MR_TypeInfo type_info, MR_Word *data_word_ptr,
- ML_Expand_Info *expand_info)
-{
- MR_TypeCtorInfo type_ctor_info;
-
- type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
- expand_info->non_canonical_type = FALSE;
- expand_info->can_free_arg_type_infos = FALSE;
-
- switch(type_ctor_info->type_ctor_rep) {
-
- case MR_TYPECTOR_REP_ENUM_USEREQ:
- expand_info->non_canonical_type = TRUE;
- /* fall through */
-
- case MR_TYPECTOR_REP_ENUM:
- expand_info->functor = type_ctor_info->type_layout.layout_enum
- [*data_word_ptr]->MR_enum_functor_name;
- expand_info->arity = 0;
- expand_info->num_extra_args = 0;
- expand_info->arg_values = NULL;
- expand_info->arg_type_infos = NULL;
- break;
-
- case MR_TYPECTOR_REP_DU_USEREQ:
- expand_info->non_canonical_type = TRUE;
- /* fall through */
-
- case MR_TYPECTOR_REP_DU:
- {
- const MR_DuPtagLayout *ptag_layout;
- const MR_DuFunctorDesc *functor_desc;
- const MR_DuExistInfo *exist_info;
- MR_Word data;
- int ptag;
- MR_Word sectag;
- MR_Word *arg_vector;
-
- data = *data_word_ptr;
- ptag = MR_tag(data);
- ptag_layout = &type_ctor_info->type_layout.layout_du[ptag];
-
- switch (ptag_layout->MR_sectag_locn) {
- case MR_SECTAG_NONE:
- functor_desc = ptag_layout->MR_sectag_alternatives[0];
- arg_vector = (MR_Word *) MR_body(data, ptag);
- break;
- case MR_SECTAG_LOCAL:
- sectag = MR_unmkbody(data);
- functor_desc =
- ptag_layout->MR_sectag_alternatives[sectag];
- arg_vector = NULL;
- break;
- case MR_SECTAG_REMOTE:
- sectag = MR_field(ptag, data, 0);
- functor_desc =
- ptag_layout->MR_sectag_alternatives[sectag];
- arg_vector = (MR_Word *) MR_body(data, ptag) + 1;
- break;
- case MR_SECTAG_VARIABLE:
- MR_fatal_error(""ML_expand(): cannot expand variable"");
- }
-
- expand_info->arity = functor_desc->MR_du_functor_orig_arity;
-
- exist_info = functor_desc->MR_du_functor_exist_info;
- if (exist_info != NULL) {
- expand_info->num_extra_args =
- exist_info->MR_exist_typeinfos_plain
- + exist_info->MR_exist_tcis;
- } else {
- expand_info->num_extra_args = 0;
- }
-
- if (expand_info->need_functor) {
- MR_make_aligned_string(expand_info->functor,
- functor_desc->MR_du_functor_name);
- }
-
- if (expand_info->need_args) {
- int i;
-
- expand_info->arg_values = arg_vector;
- expand_info->can_free_arg_type_infos = TRUE;
- expand_info->arg_type_infos = MR_GC_NEW_ARRAY(MR_TypeInfo,
- expand_info->arity);
-
- for (i = 0; i < expand_info->arity; i++) {
- if (MR_arg_type_may_contain_var(functor_desc, i)) {
- expand_info->arg_type_infos[i] =
- 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 {
- expand_info->arg_type_infos[i] =
- MR_pseudo_type_info_is_ground(
- functor_desc->MR_du_functor_arg_types[i]);
- }
- }
- }
- }
- break;
-
- case MR_TYPECTOR_REP_NOTAG_USEREQ:
- expand_info->non_canonical_type = TRUE;
- /* fall through */
-
- case MR_TYPECTOR_REP_NOTAG:
- expand_info->arity = 1;
- expand_info->num_extra_args = 0;
-
- if (expand_info->need_functor) {
- MR_make_aligned_string(expand_info->functor,
- type_ctor_info->type_layout.layout_notag
- ->MR_notag_functor_name);
- }
-
- if (expand_info->need_args) {
- expand_info->arg_values = data_word_ptr;
- expand_info->can_free_arg_type_infos = TRUE;
- expand_info->arg_type_infos = MR_GC_NEW_ARRAY(MR_TypeInfo, 1);
- expand_info->arg_type_infos[0] = MR_create_type_info(
- MR_TYPEINFO_GET_FIRST_ORDER_ARG_VECTOR(type_info),
- type_ctor_info->type_layout.layout_notag->
- MR_notag_functor_arg_type);
- }
- break;
-
- case MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ:
- expand_info->non_canonical_type = TRUE;
- /* fall through */
-
- case MR_TYPECTOR_REP_NOTAG_GROUND:
- expand_info->arity = 1;
- expand_info->num_extra_args = 0;
-
- if (expand_info->need_functor) {
- MR_make_aligned_string(expand_info->functor,
- type_ctor_info->type_layout.layout_notag
- ->MR_notag_functor_name);
- }
-
- if (expand_info->need_args) {
- expand_info->arg_values = data_word_ptr;
- expand_info->can_free_arg_type_infos = TRUE;
- expand_info->arg_type_infos = MR_GC_NEW_ARRAY(MR_TypeInfo, 1);
- expand_info->arg_type_infos[0] =
- MR_pseudo_type_info_is_ground(type_ctor_info->
- type_layout.layout_notag->MR_notag_functor_arg_type);
- }
- break;
-
- case MR_TYPECTOR_REP_EQUIV:
- {
- MR_TypeInfo eqv_type_info;
-
- eqv_type_info = MR_create_type_info(
- MR_TYPEINFO_GET_FIRST_ORDER_ARG_VECTOR(type_info),
- type_ctor_info->type_layout.layout_equiv);
- ML_expand(eqv_type_info, data_word_ptr, expand_info);
- }
- break;
-
- case MR_TYPECTOR_REP_EQUIV_GROUND:
- ML_expand(MR_pseudo_type_info_is_ground(
- type_ctor_info->type_layout.layout_equiv),
- data_word_ptr, 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:
- if (expand_info->need_functor) {
- MR_Word data_word;
- char buf[500];
- char *str;
-
- data_word = *data_word_ptr;
- sprintf(buf, ""%ld"", (long) data_word);
- MR_incr_saved_hp_atomic(MR_LVALUE_CAST(MR_Word, str),
- (strlen(buf) + sizeof(MR_Word)) / sizeof(MR_Word));
- strcpy(str, buf);
- expand_info->functor = str;
- }
-
- expand_info->arg_values = NULL;
- expand_info->arg_type_infos = NULL;
- expand_info->arity = 0;
- expand_info->num_extra_args = 0;
- break;
-
- case MR_TYPECTOR_REP_CHAR:
- /* XXX should escape characters correctly */
- if (expand_info->need_functor) {
- MR_Word data_word;
- char *str;
-
- data_word = *data_word_ptr;
- MR_incr_saved_hp_atomic(MR_LVALUE_CAST(MR_Word, str),
- (3 + sizeof(MR_Word)) / sizeof(MR_Word));
- sprintf(str, ""\'%c\'"", (char) data_word);
- expand_info->functor = str;
- }
- expand_info->arg_values = NULL;
- expand_info->arg_type_infos = NULL;
- expand_info->arity = 0;
- expand_info->num_extra_args = 0;
- break;
-
- case MR_TYPECTOR_REP_FLOAT:
- if (expand_info->need_functor) {
- MR_Word data_word;
- char buf[500];
- MR_Float f;
- char *str;
-
- data_word = *data_word_ptr;
- f = MR_word_to_float(data_word);
- sprintf(buf, ""%#.15g"", f);
- MR_incr_saved_hp_atomic(MR_LVALUE_CAST(MR_Word, str),
- (strlen(buf) + sizeof(MR_Word)) / sizeof(MR_Word));
- strcpy(str, buf);
- expand_info->functor = str;
- }
- expand_info->arg_values = NULL;
- expand_info->arg_type_infos = NULL;
- expand_info->arity = 0;
- expand_info->num_extra_args = 0;
- break;
-
- case MR_TYPECTOR_REP_STRING:
- /* XXX should escape characters correctly */
- if (expand_info->need_functor) {
- MR_Word data_word;
- char *str;
-
- data_word = *data_word_ptr;
- MR_incr_saved_hp_atomic(MR_LVALUE_CAST(MR_Word, str),
- (strlen((MR_String) data_word) + 2 + sizeof(MR_Word))
- / sizeof(MR_Word));
- sprintf(str, ""%c%s%c"", '""', (MR_String) data_word, '""');
- expand_info->functor = str;
- }
- expand_info->arg_values = NULL;
- expand_info->arg_type_infos = NULL;
- expand_info->arity = 0;
- expand_info->num_extra_args = 0;
- break;
- case MR_TYPECTOR_REP_PRED:
- /* XXX expand_info->non_canonical_type = TRUE; */
- if (expand_info->need_functor) {
- MR_make_aligned_string(expand_info->functor,
- ""<<predicate>>"");
- }
- expand_info->arg_values = NULL;
- expand_info->arg_type_infos = NULL;
- expand_info->arity = 0;
- expand_info->num_extra_args = 0;
- break;
-
- case MR_TYPECTOR_REP_TUPLE:
- expand_info->arity = MR_TYPEINFO_GET_TUPLE_ARITY(type_info);
- expand_info->num_extra_args = 0;
-
- if (expand_info->need_functor) {
- MR_make_aligned_string(expand_info->functor, ""{}"");
- }
- if (expand_info->need_args) {
- expand_info->arg_values = (MR_Word *) *data_word_ptr;
-
- /*
- ** Type-infos are normally counted from one, but
- ** the users of this vector count from zero.
- */
- expand_info->arg_type_infos =
- MR_TYPEINFO_GET_TUPLE_ARG_VECTOR(type_info) + 1;
- }
- break;
-
- case MR_TYPECTOR_REP_UNIV: {
- MR_Word data_word;
-
- MR_TypeInfo univ_type_info;
- MR_Word univ_data;
- /*
- * Univ is a two word structure, containing
- * type_info and data.
- */
- data_word = *data_word_ptr;
- MR_unravel_univ(data_word, univ_type_info, univ_data);
- ML_expand(univ_type_info, &univ_data, expand_info);
- break;
- }
-
- case MR_TYPECTOR_REP_VOID:
- /*
- ** There's no way to create values of type `void',
- ** so this should never happen.
- */
- MR_fatal_error(""ML_expand: cannot expand void types"");
-
- case MR_TYPECTOR_REP_C_POINTER:
- /* XXX expand_info->non_canonical_type = TRUE; */
- if (expand_info->need_functor) {
- MR_make_aligned_string(expand_info->functor,
- ""<<c_pointer>>"");
- }
- expand_info->arg_values = NULL;
- expand_info->arg_type_infos = NULL;
- expand_info->arity = 0;
- expand_info->num_extra_args = 0;
- break;
-
- case MR_TYPECTOR_REP_TYPEINFO:
- /* XXX expand_info->non_canonical_type = TRUE; */
- if (expand_info->need_functor) {
- MR_make_aligned_string(expand_info->functor, ""<<typeinfo>>"");
- }
- /* XXX should we return the arguments here? */
- expand_info->arg_values = NULL;
- expand_info->arg_type_infos = NULL;
- expand_info->arity = 0;
- expand_info->num_extra_args = 0;
- break;
-
- case MR_TYPECTOR_REP_TYPECLASSINFO:
- /* XXX expand_info->non_canonical_type = TRUE; */
- if (expand_info->need_functor) {
- MR_make_aligned_string(expand_info->functor,
- ""<<typeclassinfo>>"");
- }
- /* XXX should we return the arguments here? */
- expand_info->arg_values = NULL;
- expand_info->arg_type_infos = NULL;
- expand_info->arity = 0;
- expand_info->num_extra_args = 0;
- break;
-
- case MR_TYPECTOR_REP_ARRAY:
- if (expand_info->need_functor) {
- MR_make_aligned_string(expand_info->functor, ""<<array>>"");
- }
- /* XXX should we return the arguments here? */
- expand_info->arg_values = NULL;
- expand_info->arg_type_infos = NULL;
- expand_info->arity = 0;
- expand_info->num_extra_args = 0;
- break;
-
- case MR_TYPECTOR_REP_SUCCIP:
- if (expand_info->need_functor) {
- MR_make_aligned_string(expand_info->functor, ""<<succip>>"");
- }
- expand_info->arg_values = NULL;
- expand_info->arg_type_infos = NULL;
- expand_info->arity = 0;
- expand_info->num_extra_args = 0;
- break;
+#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
- case MR_TYPECTOR_REP_HP:
- if (expand_info->need_functor) {
- MR_make_aligned_string(expand_info->functor, ""<<hp>>"");
- }
- expand_info->arg_values = NULL;
- expand_info->arg_type_infos = NULL;
- expand_info->arity = 0;
- expand_info->num_extra_args = 0;
- break;
-
- case MR_TYPECTOR_REP_CURFR:
- if (expand_info->need_functor) {
- MR_make_aligned_string(expand_info->functor, ""<<curfr>>"");
- }
- expand_info->arg_values = NULL;
- expand_info->arg_type_infos = NULL;
- expand_info->arity = 0;
- expand_info->num_extra_args = 0;
- break;
-
- case MR_TYPECTOR_REP_MAXFR:
- if (expand_info->need_functor) {
- MR_make_aligned_string(expand_info->functor, ""<<maxfr>>"");
- }
- expand_info->arg_values = NULL;
- expand_info->arg_type_infos = NULL;
- expand_info->arity = 0;
- expand_info->num_extra_args = 0;
- break;
-
- case MR_TYPECTOR_REP_REDOFR:
- if (expand_info->need_functor) {
- MR_make_aligned_string(expand_info->functor, ""<<redofr>>"");
- }
- expand_info->arg_values = NULL;
- expand_info->arg_type_infos = NULL;
- expand_info->arity = 0;
- expand_info->num_extra_args = 0;
- break;
-
- case MR_TYPECTOR_REP_REDOIP:
- if (expand_info->need_functor) {
- MR_make_aligned_string(expand_info->functor, ""<<redoip>>"");
- }
- expand_info->arg_values = NULL;
- expand_info->arg_type_infos = NULL;
- expand_info->arity = 0;
- expand_info->num_extra_args = 0;
- break;
-
- case MR_TYPECTOR_REP_TRAIL_PTR:
- if (expand_info->need_functor) {
- MR_make_aligned_string(expand_info->functor, ""<<trail_ptr>>"");
- }
- expand_info->arg_values = NULL;
- expand_info->arg_type_infos = NULL;
- expand_info->arity = 0;
- expand_info->num_extra_args = 0;
- break;
-
- case MR_TYPECTOR_REP_TICKET:
- if (expand_info->need_functor) {
- MR_make_aligned_string(expand_info->functor, ""<<ticket>>"");
- }
- expand_info->arg_values = NULL;
- expand_info->arg_type_infos = NULL;
- expand_info->arity = 0;
- expand_info->num_extra_args = 0;
- break;
-
- case MR_TYPECTOR_REP_UNKNOWN: /* fallthru */
- default:
- MR_fatal_error(""ML_expand: cannot expand -- unknown data type"");
- break;
- }
-}
-
/*
** ML_arg() is a subroutine used to implement arg/2, argument/2,
** and also store__arg_ref/5 in store.m.
@@ -3368,13 +2957,9 @@
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_Info expand_info;
- bool success;
-
- expand_info.need_functor = FALSE;
- expand_info.need_args = TRUE;
+ ML_Expand_Chosen_Arg_Only_Info expand_info;
- ML_expand(type_info, term_ptr, &expand_info);
+ ML_expand_chosen_arg_only(type_info, term_ptr, arg_index, &expand_info);
/*
** Check for attempts to deconstruct a non-canonical type:
@@ -3390,23 +2975,13 @@
}
/* Check range */
- success = (arg_index >= 0 && arg_index < expand_info.arity);
- if (success) {
- *arg_type_info_ptr = expand_info.arg_type_infos[arg_index];
- *arg_ptr = &expand_info.arg_values[
- arg_index + expand_info.num_extra_args];
- }
-
- /*
- ** Free the allocated arg_type_infos, since we just copied
- ** the stuff we want out of it.
- */
-
- if (expand_info.can_free_arg_type_infos) {
- MR_GC_free(expand_info.arg_type_infos);
+ 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 success;
+ return FALSE;
}
/*
@@ -3526,15 +3101,12 @@
will_not_call_mercury, "
{
MR_TypeInfo type_info;
- ML_Expand_Info expand_info;
+ ML_Expand_Functor_Only_Info expand_info;
type_info = (MR_TypeInfo) TypeInfo_for_T;
- expand_info.need_functor = TRUE;
- expand_info.need_args = FALSE;
-
MR_save_transient_registers();
- ML_expand(type_info, &Term, &expand_info);
+ ML_expand_functor_only(type_info, &Term, &expand_info);
MR_restore_transient_registers();
/*
@@ -3552,7 +3124,7 @@
/* Copy functor onto the heap */
MR_make_aligned_string(MR_LVALUE_CAST(MR_ConstString, Functor),
- expand_info.functor);
+ expand_info.functor_only);
Arity = expand_info.arity;
}").
@@ -3668,19 +3240,78 @@
:- 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;
+ MR_Word Argument;
+ MR_Word tmp;
+ int i;
+
+ type_info = (MR_TypeInfo) TypeInfo_for_T;
+
+ MR_save_transient_registers();
+ ML_expand_functor_args(type_info, &Term, &expand_info);
+ MR_restore_transient_registers();
+
+ /*
+ ** Check for attempts to deconstruct a non-canonical type:
+ ** such deconstructions must be cc_multi, and since
+ ** deconstruct/4 is det, we must treat violations of this
+ ** as runtime errors.
+ ** (There ought to be a cc_multi version of deconstruct/4
+ ** that allows this.)
+ */
+ if (expand_info.non_canonical_type) {
+ MR_fatal_error(""called deconstruct/4 for a type with a ""
+ ""user-defined equality predicate"");
+ }
+
+ /* Get functor */
+ MR_make_aligned_string(MR_LVALUE_CAST(MR_ConstString, Functor),
+ expand_info.functor);
+
+ /* Get arity */
+ Arity = expand_info.arity;
+
+ /* Build argument list */
+ Arguments = MR_list_empty_msg(MR_PROC_LABEL);
+ i = expand_info.arity;
+
+ while (--i >= 0) {
+
+ /* Create an argument on the heap */
+ MR_new_univ_on_hp(Argument,
+ expand_info.args.arg_type_infos[i],
+ expand_info.args.arg_values[i + expand_info.args.num_extra_args]);
+
+ /* Join the argument to the front of the list */
+ Arguments = MR_list_cons_msg(Argument, Arguments, MR_PROC_LABEL);
+ }
+
+ /*
+ ** Free the allocated arg_type_infos, since we just copied
+ ** all its arguments onto the heap.
+ */
+
+ if (expand_info.args.can_free_arg_type_infos) {
+ MR_GC_free(expand_info.args.arg_type_infos);
+ }
+}").
+
+:- pragma foreign_proc("C",
+ limited_deconstruct(Term::in, MaxArity::in, Functor::out, Arity::out,
+ Arguments::out), will_not_call_mercury, "
{
- ML_Expand_Info expand_info;
+ ML_Expand_Functor_Args_Limit_Info expand_info;
MR_TypeInfo type_info;
MR_Word Argument;
MR_Word tmp;
int i;
type_info = (MR_TypeInfo) TypeInfo_for_T;
- expand_info.need_functor = TRUE;
- expand_info.need_args = TRUE;
MR_save_transient_registers();
- ML_expand(type_info, &Term, &expand_info);
+ ML_expand_functor_args_limit(type_info, &Term, MaxArity, &expand_info);
MR_restore_transient_registers();
/*
@@ -3696,6 +3327,11 @@
""user-defined equality predicate"");
}
+ if (expand_info.limit_reached) {
+ SUCCESS_INDICATOR = FALSE;
+ } else {
+ SUCCESS_INDICATOR = TRUE;
+
/* Get functor */
MR_make_aligned_string(MR_LVALUE_CAST(MR_ConstString, Functor),
expand_info.functor);
@@ -3711,8 +3347,8 @@
/* Create an argument on the heap */
MR_new_univ_on_hp(Argument,
- expand_info.arg_type_infos[i],
- expand_info.arg_values[i + expand_info.num_extra_args]);
+ expand_info.args.arg_type_infos[i],
+ expand_info.args.arg_values[i + expand_info.args.num_extra_args]);
/* Join the argument to the front of the list */
Arguments = MR_list_cons_msg(Argument, Arguments, MR_PROC_LABEL);
@@ -3723,13 +3359,22 @@
** all its arguments onto the heap.
*/
- if (expand_info.can_free_arg_type_infos) {
- MR_GC_free(expand_info.arg_type_infos);
+ if (expand_info.args.can_free_arg_type_infos) {
+ MR_GC_free(expand_info.args.arg_type_infos);
+ }
}
}").
:- pragma foreign_proc("MC++",
deconstruct(_Term::in, _Functor::out, _Arity::out,
+ _Arguments::out), will_not_call_mercury, "
+{
+ mercury::runtime::Errors::SORRY(""foreign code for this function"");
+}
+").
+
+:- pragma foreign_proc("MC++",
+ limited_deconstruct(_Term::in, _MaxArity::in, _Functor::out, _Arity::out,
_Arguments::out), will_not_call_mercury, "
{
mercury::runtime::Errors::SORRY(""foreign code for this function"");
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.72
diff -u -b -r1.72 Mmakefile
--- runtime/Mmakefile 2001/05/31 06:00:09 1.72
+++ runtime/Mmakefile 2001/06/12 16:44:41
@@ -101,13 +101,14 @@
mercury_deep_call_port_body.h \
mercury_deep_copy_body.h \
mercury_deep_leave_port_body.h \
- mercury_deep_redo_port_body.h \
mercury_deep_rec_depth_actions.h \
mercury_deep_rec_depth_body.h \
+ mercury_deep_redo_port_body.h \
mercury_exception_catch_body.h \
mercury_hand_compare_body.h \
mercury_hand_unify_body.h \
mercury_make_type_info_body.h \
+ mercury_ml_expand_body.h \
mercury_unify_compare_body.h
# Note that $(LIB_GLOBALS_H) cannot be part of $(HDRS), since it depends on
Index: runtime/mercury_ml_expand_body.h
===================================================================
RCS file: mercury_ml_expand_body.h
diff -N mercury_ml_expand_body.h
--- /dev/null Fri Dec 1 02:25:58 2000
+++ mercury_ml_expand_body.h Wed Jun 13 02:44:41 2001
@@ -0,0 +1,671 @@
+/*
+** 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_expand_body.h
+**
+** This file is included several times in library/std_util.m. Each inclusion
+** defines a function that the body 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 variants 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
+** large arrays are involved. (Simply allocating and filling in an array of
+** a million typeinfos can cause a system to start paging.) Therefore we try to
+** make sure that in every circumstance we perform the minimum work possible.
+**
+** The code including this file must define these macros:
+**
+** EXPAND_FUNCTION_NAME Gives the name of the function being defined.
+**
+** EXPAND_TYPE_NAME Gives the name of the type of the expand_info
+** argument.
+**
+** The code including this file may define these macros:
+**
+** EXPAND_FUNCTOR_FIELD If defined, gives the name of the field in the
+** expand_info structure that contains the name of the
+** functor. This field should be of type
+** MR_ConstString. The function will fill in this
+** field.
+**
+** EXPAND_ARGS_FIELD If defined, gives the name of the field in the
+** expand_info structure that contains information
+** about all the functor's arguments. This field
+** should be of type ML_Expand_Args_Fields. The
+** function will fill in this field.
+**
+** EXPAND_CHOSEN_ARG If defined, the function will have an extra
+** argument, chosen, and it will fill in the fields
+** of the ML_Expand_Chosen_Arg_Only structure.
+**
+** EXPAND_APPLY_LIMIT If defined, the function will have an extra
+** argument, max_arity. If the number of arguments
+** exceeds this limit, the function will store FALSE
+** in the limit_reached field of expand_info and will
+** not fill in the other fields about the arguments.
+**
+** Most combinations are allowed, but
+**
+** - only one of EXPAND_ARGS_FIELD and EXPAND_CHOSEN_ARG may be defined at once
+** - EXPAND_APPLY_LIMIT should be defined only if EXPAND_ARGS_FIELD is also
+** defined.
+**
+** Each variant of the function will fill in all the fields of the expand_info
+** structure passed to it, although the set of fields in that structure will
+** be different for different variants. The type in EXPAND_TYPE_NAME must be
+** consistent with the set of defined optional macros.
+**
+** All variants contain the boolean field non_canonical_type, which will be
+** set to TRUE iff the type has user-defined equality, and the integer field
+** arity, which will be set to the number of arguments the functor has.
+**
+** The variants that return all the arguments do so in a field of type
+** ML_Expand_Args_Fields. Its arg_type_infos subfield will contain a pointer
+** to an array of arity MR_TypeInfos, one for each user-visible field of the
+** cell. The arg_values field will contain a pointer to a block of
+** arity + num_extra_args MR_Words, one for each field of the cell,
+** whether user-visible or not. The first num_extra_args words will be
+** the type infos and/or typeclass infos added by the implementation to
+** describe the types of the existentially typed fields, while the last
+** arity words will be the user-visible fields themselves.
+**
+** If the can_free_arg_type_infos field is true, then the array returned
+** in the arg_type_infos field was allocated by this function, and should be
+** freed by the caller when it has finished using the information it contains.
+** Since the array will have been allocated using MR_GC_malloc(), it should be
+** freed with MR_GC_free. (We need to use MR_GC_malloc() rather than
+** MR_malloc() or malloc(), since this vector may contain pointers into the
+** Mercury heap, and memory allocated with MR_malloc() or malloc() will not be
+** traced by the Boehm collector.) The elements of the array should not be
+** freed, since they point either previously allocated data, which is either
+** on the heap or is in constant storage (e.g. type_ctor_infos).
+** If the can_free_arg_type_infos field is false, then the array returned in
+** the arg_type_infos field was not allocated by the function (it came from the
+** type_info argument passed to it) and must not be freed.
+**
+** Please note:
+** These functions increment the heap pointer; however, on some platforms
+** the register windows mean that transient Mercury registers may be lost.
+** Before calling these functions, call MR_save_transient_registers(), and
+** afterwards, call MR_restore_transient_registers().
+**
+** If you change this code, you may also have to reflect your changes
+** in runtime/mercury_deep_copy_body.h and runtime/mercury_tabling.c
+**
+** We use 4 space tabs here (sw=4 ts=4) because of the level of indenting.
+*/
+
+#include <stdio.h>
+#include "mercury_library_types.h" /* for MR_ArrayType */
+
+#ifdef MR_DEEP_PROFILING
+ #include "mercury_deep_profiling.h"
+#endif
+
+/* set up for recursive calls */
+#ifdef EXPAND_APPLY_LIMIT
+ #define EXTRA_ARG1 max_arity,
+#else
+ #define EXTRA_ARG1
+#endif
+#ifdef EXPAND_CHOSEN_ARG
+ #define EXTRA_ARG2 chosen,
+#else
+ #define EXTRA_ARG2
+#endif
+#define EXTRA_ARGS EXTRA_ARG1 EXTRA_ARG2
+
+/* set up macro for setting field names without #ifdefs */
+#ifdef EXPAND_FUNCTOR_FIELD
+ #define handle_functor_name(name) \
+ do { \
+ MR_make_aligned_string(expand_info->EXPAND_FUNCTOR_FIELD,\
+ name); \
+ } while (0)
+#else /* EXPAND_FUNCTOR_FIELD */
+ #define handle_functor_name(name) \
+ ((void) 0)
+#endif /* EXPAND_FUNCTOR_FIELD */
+
+/* set up macros for the common code handling zero arity terms */
+
+#ifdef EXPAND_ARGS_FIELD
+ #define handle_zero_arity_all_args() \
+ do { \
+ expand_info->EXPAND_ARGS_FIELD.arg_values = NULL; \
+ expand_info->EXPAND_ARGS_FIELD.arg_type_infos = NULL; \
+ expand_info->EXPAND_ARGS_FIELD.num_extra_args = 0; \
+ } while (0)
+#else /* EXPAND_ARGS_FIELD */
+ #define handle_zero_arity_all_args() \
+ ((void) 0)
+#endif /* EXPAND_ARGS_FIELD */
+
+#ifdef EXPAND_CHOSEN_ARG
+ #define handle_zero_arity_chosen_arg() \
+ do { \
+ expand_info->chosen_index_exists = FALSE; \
+ } while (0)
+#else /* EXPAND_CHOSEN_ARG */
+ #define handle_zero_arity_chosen_arg() \
+ ((void) 0)
+#endif /* EXPAND_CHOSEN_ARG */
+
+#define handle_zero_arity_args() \
+ do { \
+ expand_info->arity = 0; \
+ handle_zero_arity_all_args(); \
+ handle_zero_arity_chosen_arg(); \
+ } while (0)
+
+/***********************************************************************/
+
+void
+EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr,
+#ifdef EXPAND_APPLY_LIMIT
+ int max_arity,
+#endif /* EXPAND_APPLY_LIMIT */
+#ifdef EXPAND_CHOSEN_ARG
+ int chosen,
+#endif /* CHOSEN_ARG */
+ EXPAND_TYPE_NAME *expand_info)
+{
+ MR_TypeCtorInfo type_ctor_info;
+
+ type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
+ expand_info->non_canonical_type = FALSE;
+#ifdef EXPAND_ARGS_FIELD
+ expand_info->EXPAND_ARGS_FIELD.can_free_arg_type_infos = FALSE;
+#endif /* EXPAND_ARGS_FIELD */
+#ifdef EXPAND_APPLY_LIMIT
+ expand_info->limit_reached = FALSE;
+#endif /* EXPAND_APPLY_LIMIT */
+
+ switch(type_ctor_info->type_ctor_rep) {
+
+ case MR_TYPECTOR_REP_ENUM_USEREQ:
+ expand_info->non_canonical_type = TRUE;
+ /* fall through */
+
+ case MR_TYPECTOR_REP_ENUM:
+ handle_functor_name(type_ctor_info->type_layout.
+ layout_enum[*data_word_ptr]->MR_enum_functor_name);
+ handle_zero_arity_args();
+ break;
+
+ case MR_TYPECTOR_REP_DU_USEREQ:
+ expand_info->non_canonical_type = TRUE;
+ /* fall through */
+
+ case MR_TYPECTOR_REP_DU:
+ {
+ const MR_DuPtagLayout *ptag_layout;
+ const MR_DuFunctorDesc *functor_desc;
+ const MR_DuExistInfo *exist_info;
+ int extra_args;
+ MR_Word data;
+ int ptag;
+ MR_Word sectag;
+ MR_Word *arg_vector;
+
+ data = *data_word_ptr;
+ ptag = MR_tag(data);
+ ptag_layout = &type_ctor_info->type_layout.layout_du[ptag];
+
+ switch (ptag_layout->MR_sectag_locn) {
+ case MR_SECTAG_NONE:
+ functor_desc = ptag_layout->MR_sectag_alternatives[0];
+ arg_vector = (MR_Word *) MR_body(data, ptag);
+ break;
+ case MR_SECTAG_LOCAL:
+ sectag = MR_unmkbody(data);
+ functor_desc =
+ ptag_layout->MR_sectag_alternatives[sectag];
+ arg_vector = NULL;
+ break;
+ case MR_SECTAG_REMOTE:
+ sectag = MR_field(ptag, data, 0);
+ functor_desc =
+ ptag_layout->MR_sectag_alternatives[sectag];
+ arg_vector = (MR_Word *) MR_body(data, ptag) + 1;
+ break;
+ case MR_SECTAG_VARIABLE:
+ MR_fatal_error(MR_STRINGIFY(EXPAND_FUNCTION_NAME)
+ ": cannot expand variable");
+ }
+
+ handle_functor_name(functor_desc->MR_du_functor_name);
+ expand_info->arity = functor_desc->MR_du_functor_orig_arity;
+
+#if defined(EXPAND_ARGS_FIELD) || defined(EXPAND_CHOSEN_ARG)
+ exist_info = functor_desc->MR_du_functor_exist_info;
+ if (exist_info != NULL) {
+ extra_args = exist_info->MR_exist_typeinfos_plain
+ + exist_info->MR_exist_tcis;
+ } else {
+ extra_args = 0;
+ }
+#endif /* defined(EXPAND_ARGS_FIELD) || defined(EXPAND_CHOSEN_ARG) */
+
+#ifdef EXPAND_ARGS_FIELD
+ #ifdef EXPAND_APPLY_LIMIT
+ if (expand_info->arity > max_arity) {
+ expand_info->limit_reached = TRUE;
+ } else
+ #endif /* EXPAND_APPLY_LIMIT */
+ {
+ int i;
+ expand_info->EXPAND_ARGS_FIELD.num_extra_args = extra_args;
+ expand_info->EXPAND_ARGS_FIELD.arg_values = arg_vector;
+ expand_info->EXPAND_ARGS_FIELD.can_free_arg_type_infos =
+ TRUE;
+ expand_info->EXPAND_ARGS_FIELD.arg_type_infos =
+ MR_GC_NEW_ARRAY(MR_TypeInfo, expand_info->arity);
+
+ for (i = 0; i < expand_info->arity; i++) {
+ if (MR_arg_type_may_contain_var(functor_desc, i)) {
+ expand_info->EXPAND_ARGS_FIELD.arg_type_infos[i] =
+ 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 {
+ expand_info->EXPAND_ARGS_FIELD.arg_type_infos[i] =
+ MR_pseudo_type_info_is_ground(
+ functor_desc->MR_du_functor_arg_types[i]);
+ }
+ }
+ }
+#endif /* EXPAND_ARGS_FIELD */
+#ifdef EXPAND_CHOSEN_ARG
+ if (0 <= chosen && chosen < expand_info->arity) {
+ expand_info->chosen_index_exists = TRUE;
+ expand_info->chosen_value_ptr =
+ &arg_vector[extra_args + chosen];
+ if (MR_arg_type_may_contain_var(functor_desc, chosen)) {
+ expand_info->chosen_type_info =
+ MR_create_type_info_maybe_existq(
+ MR_TYPEINFO_GET_FIRST_ORDER_ARG_VECTOR(
+ type_info),
+ functor_desc->MR_du_functor_arg_types[chosen],
+ arg_vector, functor_desc);
+ } else {
+ expand_info->chosen_type_info =
+ MR_pseudo_type_info_is_ground(
+ functor_desc->MR_du_functor_arg_types[chosen]);
+ }
+ } else {
+ expand_info->chosen_index_exists = FALSE;
+ }
+#endif /* EXPAND_CHOSEN_ARG */
+ }
+ break;
+
+ case MR_TYPECTOR_REP_NOTAG_USEREQ:
+ expand_info->non_canonical_type = TRUE;
+ /* fall through */
+
+ case MR_TYPECTOR_REP_NOTAG:
+ expand_info->arity = 1;
+ handle_functor_name(type_ctor_info->type_layout.layout_notag
+ ->MR_notag_functor_name);
+
+#ifdef EXPAND_ARGS_FIELD
+ expand_info->EXPAND_ARGS_FIELD.num_extra_args = 0;
+ expand_info->EXPAND_ARGS_FIELD.arg_values = data_word_ptr;
+ expand_info->EXPAND_ARGS_FIELD.can_free_arg_type_infos = TRUE;
+ expand_info->EXPAND_ARGS_FIELD.arg_type_infos =
+ MR_GC_NEW_ARRAY(MR_TypeInfo, 1);
+ expand_info->EXPAND_ARGS_FIELD.arg_type_infos[0] =
+ MR_create_type_info(
+ MR_TYPEINFO_GET_FIRST_ORDER_ARG_VECTOR(type_info),
+ type_ctor_info->type_layout.layout_notag->
+ MR_notag_functor_arg_type);
+#endif /* EXPAND_ARGS_FIELD */
+#ifdef EXPAND_CHOSEN_ARG
+ if (chosen == 0) {
+ expand_info->chosen_index_exists = TRUE;
+ expand_info->chosen_value_ptr = data_word_ptr;
+ expand_info->chosen_type_info =
+ MR_create_type_info(
+ MR_TYPEINFO_GET_FIRST_ORDER_ARG_VECTOR(type_info),
+ type_ctor_info->type_layout.layout_notag->
+ MR_notag_functor_arg_type);
+ } else {
+ expand_info->chosen_index_exists = FALSE;
+ }
+#endif /* EXPAND_CHOSEN_ARG */
+ break;
+
+ case MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ:
+ expand_info->non_canonical_type = TRUE;
+ /* fall through */
+
+ case MR_TYPECTOR_REP_NOTAG_GROUND:
+ expand_info->arity = 1;
+ handle_functor_name(type_ctor_info->type_layout.layout_notag
+ ->MR_notag_functor_name);
+
+#ifdef EXPAND_ARGS_FIELD
+ expand_info->EXPAND_ARGS_FIELD.num_extra_args = 0;
+ expand_info->EXPAND_ARGS_FIELD.arg_values = data_word_ptr;
+ expand_info->EXPAND_ARGS_FIELD.can_free_arg_type_infos = TRUE;
+ expand_info->EXPAND_ARGS_FIELD.arg_type_infos =
+ MR_GC_NEW_ARRAY(MR_TypeInfo, 1);
+ expand_info->EXPAND_ARGS_FIELD.arg_type_infos[0] =
+ MR_pseudo_type_info_is_ground(type_ctor_info->
+ type_layout.layout_notag->MR_notag_functor_arg_type);
+#endif /* EXPAND_ARGS_FIELD */
+#ifdef EXPAND_CHOSEN_ARG
+ if (chosen == 0) {
+ expand_info->chosen_index_exists = TRUE;
+ expand_info->chosen_value_ptr = data_word_ptr;
+ expand_info->chosen_type_info =
+ MR_pseudo_type_info_is_ground(type_ctor_info->
+ type_layout.layout_notag->MR_notag_functor_arg_type);
+ } else {
+ expand_info->chosen_index_exists = FALSE;
+ }
+#endif /* EXPAND_CHOSEN_ARG */
+ break;
+
+ case MR_TYPECTOR_REP_EQUIV:
+ {
+ MR_TypeInfo eqv_type_info;
+
+ eqv_type_info = MR_create_type_info(
+ MR_TYPEINFO_GET_FIRST_ORDER_ARG_VECTOR(type_info),
+ type_ctor_info->type_layout.layout_equiv);
+ EXPAND_FUNCTION_NAME(eqv_type_info, data_word_ptr,
+ EXTRA_ARGS expand_info);
+ }
+ break;
+
+ case MR_TYPECTOR_REP_EQUIV_GROUND:
+ EXPAND_FUNCTION_NAME(MR_pseudo_type_info_is_ground(
+ type_ctor_info->type_layout.layout_equiv),
+ 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
+ {
+ MR_Word data_word;
+ char buf[500];
+ char *str;
+
+ data_word = *data_word_ptr;
+ sprintf(buf, "%ld", (long) data_word);
+ MR_incr_saved_hp_atomic(MR_LVALUE_CAST(MR_Word, str),
+ (strlen(buf) + sizeof(MR_Word)) / sizeof(MR_Word));
+ strcpy(str, buf);
+ expand_info->EXPAND_FUNCTOR_FIELD = str;
+ }
+#endif /* EXPAND_FUNCTOR_FIELD */
+
+ handle_zero_arity_args();
+ break;
+
+ case MR_TYPECTOR_REP_CHAR:
+#ifdef EXPAND_FUNCTOR_FIELD
+ {
+ /* XXX should escape characters correctly */
+ MR_Word data_word;
+ char *str;
+
+ data_word = *data_word_ptr;
+ MR_incr_saved_hp_atomic(MR_LVALUE_CAST(MR_Word, str),
+ (3 + sizeof(MR_Word)) / sizeof(MR_Word));
+ sprintf(str, "\'%c\'", (char) data_word);
+ expand_info->EXPAND_FUNCTOR_FIELD = str;
+ }
+#endif /* EXPAND_FUNCTOR_FIELD */
+
+ handle_zero_arity_args();
+ break;
+
+ case MR_TYPECTOR_REP_FLOAT:
+#ifdef EXPAND_FUNCTOR_FIELD
+ {
+ MR_Word data_word;
+ char buf[500];
+ MR_Float f;
+ char *str;
+
+ data_word = *data_word_ptr;
+ f = MR_word_to_float(data_word);
+ sprintf(buf, "%#.15g", f);
+ MR_incr_saved_hp_atomic(MR_LVALUE_CAST(MR_Word, str),
+ (strlen(buf) + sizeof(MR_Word)) / sizeof(MR_Word));
+ strcpy(str, buf);
+ expand_info->EXPAND_FUNCTOR_FIELD = str;
+ }
+#endif /* EXPAND_FUNCTOR_FIELD */
+
+ handle_zero_arity_args();
+ break;
+
+ case MR_TYPECTOR_REP_STRING:
+#ifdef EXPAND_FUNCTOR_FIELD
+ {
+ /* XXX should escape characters correctly */
+ MR_Word data_word;
+ char *str;
+
+ data_word = *data_word_ptr;
+ MR_incr_saved_hp_atomic(MR_LVALUE_CAST(MR_Word, str),
+ (strlen((MR_String) data_word) + 2 + sizeof(MR_Word))
+ / sizeof(MR_Word));
+ sprintf(str, "%c%s%c", '"', (MR_String) data_word, '"');
+ expand_info->EXPAND_FUNCTOR_FIELD = str;
+ }
+#endif /* EXPAND_FUNCTOR_FIELD */
+
+ handle_zero_arity_args();
+ break;
+
+ case MR_TYPECTOR_REP_PRED:
+ /* XXX expand_info->non_canonical_type = TRUE; */
+ handle_functor_name("<<predicate>>");
+ handle_zero_arity_args();
+ break;
+
+ case MR_TYPECTOR_REP_TUPLE:
+ expand_info->arity = MR_TYPEINFO_GET_TUPLE_ARITY(type_info);
+ handle_functor_name("{}");
+
+#ifdef EXPAND_ARGS_FIELD
+ #ifdef EXPAND_APPLY_LIMIT
+ if (expand_info->arity > max_arity) {
+ expand_info->limit_reached = TRUE;
+ } else
+ #endif /* EXPAND_APPLY_LIMIT */
+ {
+ expand_info->EXPAND_ARGS_FIELD.num_extra_args = 0;
+ expand_info->EXPAND_ARGS_FIELD.arg_values =
+ (MR_Word *) *data_word_ptr;
+
+ /*
+ ** Type-infos are normally counted from one, but
+ ** the users of this vector count from zero.
+ */
+ expand_info->EXPAND_ARGS_FIELD.arg_type_infos =
+ MR_TYPEINFO_GET_TUPLE_ARG_VECTOR(type_info) + 1;
+ }
+#endif /* EXPAND_ARGS_FIELD */
+#ifdef EXPAND_CHOSEN_ARG
+ if (0 <= chosen && chosen < expand_info->arity) {
+ MR_Word *arg_vector;
+
+ arg_vector = (MR_Word *) *data_word_ptr;
+ expand_info->chosen_index_exists = TRUE;
+ expand_info->chosen_value_ptr = &arg_vector[chosen];
+ expand_info->chosen_type_info =
+ MR_TYPEINFO_GET_TUPLE_ARG_VECTOR(type_info)[chosen + 1];
+ } else {
+ expand_info->chosen_index_exists = FALSE;
+ }
+#endif /* EXPAND_CHOSEN_ARG */
+ break;
+
+ case MR_TYPECTOR_REP_UNIV: {
+ MR_Word data_word;
+
+ MR_TypeInfo univ_type_info;
+ MR_Word univ_data;
+ /*
+ * Univ is a two word structure, containing
+ * type_info and data.
+ */
+ data_word = *data_word_ptr;
+ MR_unravel_univ(data_word, univ_type_info, univ_data);
+ EXPAND_FUNCTION_NAME(univ_type_info, &univ_data,
+ EXTRA_ARGS expand_info);
+ break;
+ }
+
+ case MR_TYPECTOR_REP_VOID:
+ /*
+ ** There's no way to create values of type `void',
+ ** so this should never happen.
+ */
+ MR_fatal_error(MR_STRINGIFY(EXPAND_FUNCTION_NAME)
+ ": cannot expand void types");
+
+ case MR_TYPECTOR_REP_C_POINTER:
+ /* XXX expand_info->non_canonical_type = TRUE; */
+ handle_functor_name("<<c_pointer>>");
+ handle_zero_arity_args();
+ break;
+
+ case MR_TYPECTOR_REP_TYPEINFO:
+ /* XXX expand_info->non_canonical_type = TRUE; */
+ /* XXX should we return the arguments here? */
+ handle_functor_name("<<typeinfo>>");
+ handle_zero_arity_args();
+ break;
+
+ case MR_TYPECTOR_REP_TYPECLASSINFO:
+ /* XXX expand_info->non_canonical_type = TRUE; */
+ /* XXX should we return the arguments here? */
+ handle_functor_name("<<typeclassinfo>>");
+ handle_zero_arity_args();
+ break;
+
+ case MR_TYPECTOR_REP_ARRAY:
+ {
+ MR_ArrayType *array;
+
+ array = (MR_ArrayType *) *data_word_ptr;
+ expand_info->arity = array->size;
+
+ handle_functor_name("<<array>>");
+
+#ifdef EXPAND_ARGS_FIELD
+ #ifdef EXPAND_APPLY_LIMIT
+ if (expand_info->arity > max_arity) {
+ expand_info->limit_reached = TRUE;
+ } else
+ #endif /* EXPAND_APPLY_LIMIT */
+ {
+ MR_TypeInfoParams params;
+ int i;
+
+ params = MR_TYPEINFO_GET_FIRST_ORDER_ARG_VECTOR(type_info);
+ expand_info->EXPAND_ARGS_FIELD.num_extra_args = 0;
+ expand_info->EXPAND_ARGS_FIELD.arg_values =
+ &array->elements[0];
+ expand_info->EXPAND_ARGS_FIELD.can_free_arg_type_infos =
+ TRUE;
+ expand_info->EXPAND_ARGS_FIELD.arg_type_infos =
+ MR_GC_NEW_ARRAY(MR_TypeInfo, array->size);
+ for (i = 0; i < array->size; i++) {
+ expand_info->EXPAND_ARGS_FIELD.arg_type_infos[i] =
+ params[1];
+ }
+ }
+#endif /* EXPAND_ARGS_FIELD */
+#ifdef EXPAND_CHOSEN_ARG
+ if (0 <= chosen && chosen < array->size) {
+ MR_TypeInfoParams params;
+
+ params = MR_TYPEINFO_GET_FIRST_ORDER_ARG_VECTOR(type_info);
+ expand_info->chosen_value_ptr = &array->elements[chosen];
+ expand_info->chosen_type_info = params[1];
+ expand_info->chosen_index_exists = TRUE;
+ } else {
+ expand_info->chosen_index_exists = FALSE;
+ }
+#endif /* EXPAND_CHOSEN_ARG */
+ }
+ break;
+
+ case MR_TYPECTOR_REP_SUCCIP:
+ handle_functor_name("<<succip>>");
+ handle_zero_arity_args();
+ break;
+
+ case MR_TYPECTOR_REP_HP:
+ handle_functor_name("<<hp>>");
+ handle_zero_arity_args();
+ break;
+
+ case MR_TYPECTOR_REP_CURFR:
+ handle_functor_name("<<curfr>>");
+ handle_zero_arity_args();
+ break;
+
+ case MR_TYPECTOR_REP_MAXFR:
+ handle_functor_name("<<maxfr>>");
+ handle_zero_arity_args();
+ break;
+
+ case MR_TYPECTOR_REP_REDOFR:
+ handle_functor_name("<<redofr>>");
+ handle_zero_arity_args();
+ break;
+
+ case MR_TYPECTOR_REP_REDOIP:
+ handle_functor_name("<<redoip>>");
+ handle_zero_arity_args();
+ break;
+
+ case MR_TYPECTOR_REP_TRAIL_PTR:
+ handle_functor_name("<<trail_ptr>>");
+ handle_zero_arity_args();
+ break;
+
+ case MR_TYPECTOR_REP_TICKET:
+ handle_functor_name("<<ticket>>");
+ handle_zero_arity_args();
+ break;
+
+ case MR_TYPECTOR_REP_UNKNOWN: /* fallthru */
+ default:
+ MR_fatal_error(MR_STRINGIFY(EXPAND_FUNCTION_NAME)
+ ": cannot expand -- unknown data type");
+ break;
+ }
+}
+
+#undef EXTRA_ARG1
+#undef EXTRA_ARG2
+#undef EXTRA_ARGS
+#undef handle_functor_name
+#undef handle_zero_arity_args
+#undef handle_zero_arity_all_args
+#undef handle_zero_arity_chosen_arg
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
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/Mmakefile,v
retrieving revision 1.120
diff -u -b -r1.120 Mmakefile
--- tests/hard_coded/Mmakefile 2001/05/31 09:11:29 1.120
+++ tests/hard_coded/Mmakefile 2001/06/12 16:45:16
@@ -28,6 +28,7 @@
cut_test \
cycles \
cycles2 \
+ deconstruct_arg \
deep_copy \
deep_copy_bug \
deep_copy_exist \
Index: tests/hard_coded/deconstruct_arg.exp
===================================================================
RCS file: deconstruct_arg.exp
diff -N deconstruct_arg.exp
--- /dev/null Fri Dec 1 02:25:58 2000
+++ deconstruct_arg.exp Wed Jun 13 02:45:16 2001
@@ -0,0 +1,162 @@
+apple/1
+argument 0 of apple([]) is []
+argument 1 of apple([]) doesn't exist
+argument 2 of apple([]) doesn't exist
+deconstruct: functor apple arity 1
+[[]]
+limited deconstruct 3 of apple([])
+functor apple arity 1 [[]]
+
+apple/1
+argument 0 of apple([9, 5, 1]) is [9, 5, 1]
+argument 1 of apple([9, 5, 1]) doesn't exist
+argument 2 of apple([9, 5, 1]) doesn't exist
+deconstruct: functor apple arity 1
+[[9, 5, 1]]
+limited deconstruct 3 of apple([9, 5, 1])
+functor apple arity 1 [[9, 5, 1]]
+
+zop/2
+argument 0 of zop(3.30000000000000, 2.03000000000000) is 3.30000000000000
+argument 1 of zop(3.30000000000000, 2.03000000000000) is 2.03000000000000
+argument 2 of zop(3.30000000000000, 2.03000000000000) doesn't exist
+deconstruct: functor zop arity 2
+[3.30000000000000, 2.03000000000000]
+limited deconstruct 3 of zop(3.30000000000000, 2.03000000000000)
+functor zop arity 2 [3.30000000000000, 2.03000000000000]
+
+zap/3
+argument 0 of zap(50, 51.0000000000000, 52) is 50
+argument 1 of zap(50, 51.0000000000000, 52) is 51.0000000000000
+argument 2 of zap(50, 51.0000000000000, 52) is 52
+deconstruct: functor zap arity 3
+[50, 51.0000000000000, 52]
+limited deconstruct 3 of zap(50, 51.0000000000000, 52)
+functor zap arity 3 [50, 51.0000000000000, 52]
+
+zip/4
+argument 0 of zip(50, 51, 52, 53) is 50
+argument 1 of zip(50, 51, 52, 53) is 51
+argument 2 of zip(50, 51, 52, 53) is 52
+deconstruct: functor zip arity 4
+[50, 51, 52, 53]
+limited deconstruct 3 of zip(50, 51, 52, 53)
+failed
+
+wombat/0
+argument 0 of wombat doesn't exist
+argument 1 of wombat doesn't exist
+argument 2 of wombat doesn't exist
+deconstruct: functor wombat arity 0
+[]
+limited deconstruct 3 of wombat
+functor wombat arity 0 []
+
+qwerty/1
+argument 0 of qwerty(5) is 5
+argument 1 of qwerty(5) doesn't exist
+argument 2 of qwerty(5) doesn't exist
+deconstruct: functor qwerty arity 1
+[5]
+limited deconstruct 3 of qwerty(5)
+functor qwerty arity 1 [5]
+
+'a'/0
+argument 0 of a doesn't exist
+argument 1 of a doesn't exist
+argument 2 of a doesn't exist
+deconstruct: functor 'a' arity 0
+[]
+limited deconstruct 3 of a
+functor 'a' arity 0 []
+
+3.14159000000000/0
+argument 0 of 3.14159000000000 doesn't exist
+argument 1 of 3.14159000000000 doesn't exist
+argument 2 of 3.14159000000000 doesn't exist
+deconstruct: functor 3.14159000000000 arity 0
+[]
+limited deconstruct 3 of 3.14159000000000
+functor 3.14159000000000 arity 0 []
+
+4/0
+argument 0 of 4 doesn't exist
+argument 1 of 4 doesn't exist
+argument 2 of 4 doesn't exist
+deconstruct: functor 4 arity 0
+[]
+limited deconstruct 3 of 4
+functor 4 arity 0 []
+
+univ_cons/1
+argument 0 of ["hi! I\'m a univ!"] is ["hi! I\'m a univ!"]
+argument 1 of ["hi! I\'m a univ!"] doesn't exist
+argument 2 of ["hi! I\'m a univ!"] doesn't exist
+deconstruct: functor univ_cons arity 1
+[["hi! I\'m a univ!"]]
+limited deconstruct 3 of ["hi! I\'m a univ!"]
+functor univ_cons arity 1 [["hi! I\'m a univ!"]]
+
+<<predicate>>/0
+argument 0 of '<<predicate>>' doesn't exist
+argument 1 of '<<predicate>>' doesn't exist
+argument 2 of '<<predicate>>' doesn't exist
+deconstruct: functor <<predicate>> arity 0
+[]
+limited deconstruct 3 of '<<predicate>>'
+functor <<predicate>> arity 0 []
+
+{}/2
+argument 0 of {1, 'b'} is 1
+argument 1 of {1, 'b'} is 'b'
+argument 2 of {1, 'b'} doesn't exist
+deconstruct: functor {} arity 2
+[1, 'b']
+limited deconstruct 3 of {1, 'b'}
+functor {} arity 2 [1, 'b']
+
+{}/3
+argument 0 of {1, 'b', "third"} is 1
+argument 1 of {1, 'b', "third"} is 'b'
+argument 2 of {1, 'b', "third"} is "third"
+deconstruct: functor {} arity 3
+[1, 'b', "third"]
+limited deconstruct 3 of {1, 'b', "third"}
+functor {} arity 3 [1, 'b', "third"]
+
+{}/4
+argument 0 of {1, 'b', "third", {1, 2, 3, 4}} is 1
+argument 1 of {1, 'b', "third", {1, 2, 3, 4}} is 'b'
+argument 2 of {1, 'b', "third", {1, 2, 3, 4}} is "third"
+deconstruct: functor {} arity 4
+[1, 'b', "third", {1, 2, 3, 4}]
+limited deconstruct 3 of {1, 'b', "third", {1, 2, 3, 4}}
+failed
+
+<<array>>/2
+argument 0 of array([1000, 2000]) is 1000
+argument 1 of array([1000, 2000]) is 2000
+argument 2 of array([1000, 2000]) doesn't exist
+deconstruct: functor <<array>> arity 2
+[1000, 2000]
+limited deconstruct 3 of array([1000, 2000])
+functor <<array>> arity 2 [1000, 2000]
+
+<<array>>/3
+argument 0 of array([100, 200, 300]) is 100
+argument 1 of array([100, 200, 300]) is 200
+argument 2 of array([100, 200, 300]) is 300
+deconstruct: functor <<array>> arity 3
+[100, 200, 300]
+limited deconstruct 3 of array([100, 200, 300])
+functor <<array>> arity 3 [100, 200, 300]
+
+<<array>>/4
+argument 0 of array([10, 20, 30, 40]) is 10
+argument 1 of array([10, 20, 30, 40]) is 20
+argument 2 of array([10, 20, 30, 40]) is 30
+deconstruct: functor <<array>> arity 4
+[10, 20, 30, 40]
+limited deconstruct 3 of array([10, 20, 30, 40])
+failed
+
Index: tests/hard_coded/deconstruct_arg.m
===================================================================
RCS file: deconstruct_arg.m
diff -N deconstruct_arg.m
--- /dev/null Fri Dec 1 02:25:58 2000
+++ deconstruct_arg.m Wed Jun 13 02:45:16 2001
@@ -0,0 +1,125 @@
+% Test case for deconstruct and arg
+%
+% Author: zs
+
+:- module deconstruct_arg.
+:- interface.
+:- import_module io.
+
+:- pred main(io__state::di, io__state::uo) is det.
+
+:- implementation.
+
+:- import_module array, list, string, std_util.
+
+:- pred test_all(T::in, io__state::di, io__state::uo) is det.
+:- pred test_functor(T::in, io__state::di, io__state::uo) is det.
+:- pred test_arg(T::in, int::in, io__state::di, io__state::uo) is det.
+:- pred test_deconstruct(T::in, io__state::di, io__state::uo) is det.
+:- pred test_limited_deconstruct(T::in, int::in, io__state::di, io__state::uo)
+ is det.
+:- pred newline(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, int) ;
+ zip(int, int, int, int) ; zop(float, float).
+
+:- type poly(A, B) ---> poly_one(A) ; poly_two(B) ;
+ poly_three(B, A, poly(B, A)).
+
+:- type no_tag ---> qwerty(int).
+
+main -->
+ % test enumerations
+ % test_all(one), newline,
+ % test primary tags
+ test_all(apple([])), newline,
+ test_all(apple([9,5,1])), newline,
+ % test remote secondary tags
+ test_all(zop(3.3, 2.03)), newline,
+ test_all(zap(50, 51.0, 52)), newline,
+ test_all(zip(50, 51, 52, 53)), newline,
+ % test local secondary tags
+ test_all(wombat), newline,
+ % test notag
+ test_all(qwerty(5)), newline,
+ % test characters
+ test_all('a'), newline,
+ % test floats
+ test_all(3.14159), newline,
+ % test integers
+ 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, 'b'}), newline,
+ test_all({1, 'b', "third"}), newline,
+ test_all({1, 'b', "third", {1,2,3,4}}), newline,
+ % test arrays
+ test_all(array([1000, 2000])), newline,
+ test_all(array([100, 200, 300])), newline,
+ test_all(array([10, 20, 30, 40])), newline.
+
+test_all(T) -->
+ test_functor(T),
+ test_arg(T, 0),
+ test_arg(T, 1),
+ test_arg(T, 2),
+ test_deconstruct(T),
+ test_limited_deconstruct(T, 3).
+
+test_functor(T) -->
+ { functor(T, Functor, Arity) },
+ io__write_string(Functor),
+ io__write_string("/"),
+ io__write_int(Arity),
+ io__write_string("\n").
+
+test_arg(T, ArgNum) -->
+ { string__format("argument %d of ", [i(ArgNum)], Str) },
+ io__write_string(Str),
+ io__print(T),
+ ( { Argument = argument(T, ArgNum) } ->
+ io__write_string(" is "),
+ io__write_univ(Argument),
+ io__write_string("\n")
+ ;
+ io__write_string(" doesn't exist\n")
+ ).
+
+test_deconstruct(T) -->
+ { deconstruct(T, Functor, Arity, Arguments) },
+ { string__format("deconstruct: functor %s arity %d\n",
+ [s(Functor), i(Arity)], Str) },
+ io__write_string(Str),
+ io__write_string("["),
+ io__write_list(Arguments, ", ", io__print),
+ io__write_string("]\n").
+
+test_limited_deconstruct(T, Limit) -->
+ { string__format("limited deconstruct %d of ", [i(Limit)], Str) },
+ io__write_string(Str),
+ io__print(T),
+ io__write_string("\n"),
+ ( { limited_deconstruct(T, Limit, Functor, Arity, Arguments) } ->
+ { string__format("functor %s arity %d ",
+ [s(Functor), i(Arity)], Str2) },
+ io__write_string(Str2),
+ io__write_string("["),
+ io__write_list(Arguments, ", ", io__print),
+ io__write_string("]\n")
+ ;
+ io__write_string("failed\n")
+ ).
+
+newline -->
+ io__write_char('\n').
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/tabling
cvs diff: Diffing tests/term
cvs diff: Diffing tests/valid
cvs diff: Diffing tests/warnings
cvs diff: Diffing tools
cvs diff: Diffing trace
cvs diff: Diffing util
--------------------------------------------------------------------------
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