%-----------------------------------------------------------------------------% % Copyright (C) 2002-2003 The University of Melbourne. % This file may only be copied under the terms of the GNU Library General % Public License - see the file COPYING.LIB in the Mercury distribution. %-----------------------------------------------------------------------------% % File: deconstruct.m. % Main author: zs. % Stability: low. %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- module deconstruct. :- interface. :- import_module std_util, list. % Values of type noncanon_handling are intended to control how % predicates that deconstruct terms behave when they find that % the term they are about to deconstruct is of a noncanonical type, % i.e. of a type in which a single logical value may have more than one % concrete representation. % % The value `do_not_allow' means that in such circumstances the % predicate should abort. % % The value `canonicalize' means that in such circumstances the % predicate should return a constant giving the identity of the type, % regardless of the actual value of the term. % % The value `include_details_cc' means that in such circumstances % the predicate should proceed as if the term were of a canonical type. % Use of this option requires a committed choice context. :- type noncanon_handling ---> do_not_allow ; canonicalize ; include_details_cc. :- inst do_not_allow ---> do_not_allow. :- inst canonicalize ---> canonicalize. :- inst include_details_cc ---> include_details_cc. :- inst canonicalize_or_do_not_allow ---> do_not_allow ; canonicalize. % functor, argument and deconstruct and their variants take any type % (including univ), and return representation information for that type. % % The string representation of the functor that these predicates % return is: % % - for user defined types with standard equality, the functor % that is given in the type definition. For lists, this means % the functors [|]/2 and []/0 are used, even if the list uses % the [....] shorthand. % - for user-defined types with user-defined equality, the % functor will be of the form <>, except % with include_details_cc, in which case the type will be % handled as if it had standard equality. % - for integers, the string is a base 10 number; % positive integers have no sign. % - for floats, the string is a floating point, base 10 number; % positive floating point numbers have no sign. % - for strings, the string, inside double quotation marks % - for characters, the character inside single quotation marks % - for predicates, the string <>, and for functions, % the string <>, except with include_details_cc, % in which case it will be the predicate or function name. % (The predicate or function name will be artificial for % predicate and function values created by lambda expressions.) % - for tuples, the string {}. % - for arrays, the string <>. % % The arity that these predicates return is: % % - for user defined types with standard equality, the arity % of the functor. % - for user defined types with user-defined equality, zero, % except with include_details_cc, in which case the type % will be handled as if it had standard equality. % - for integers, zero. % - for floats, zero. % - for strings, zero. % - for characters, zero. % - for predicates and functions, zero, except with % include_details_cc, in which case it will be the number of % arguments hidden in the closure. % - for tuples, the number of elements in the tuple. % - for arrays, the number of elements in the array. % % Note that in the current University of Melbourne implementation, % the implementations of these predicates depart from the above % specification in that with --high-level-code, they do not % deconstruct predicate- and function-valued terms even with % include_details_cc; instead, they return <> or % <> (in both cases with arity zero) as appropriate. % functor(Data, NonCanon, Functor, Arity) % % Given a data item (Data), binds Functor to a string % representation of the functor and Arity to the arity of this % data item. % :- pred functor(T, noncanon_handling, string, int). :- mode functor(in, in(do_not_allow), out, out) is det. :- mode functor(in, in(canonicalize), out, out) is det. :- mode functor(in, in(include_details_cc), out, out) is cc_multi. :- mode functor(in, in, out, out) is cc_multi. % arg(Data, NonCanon, Index, Argument) % % Given a data item (Data) and an argument index (Index), starting % at 0 for the first argument, binds Argument to that argument of % the functor of the data item. If the argument index is out of range % -- that is, greater than or equal to the arity of the functor or % lower than 0 -- then the call fails. % % Note that this predicate only returns an answer when NonCanon is % do_not_allow or canonicalize. If you need the include_details_cc % behaviour use deconstruct__arg_cc/3. % :- some [ArgT] pred arg(T, noncanon_handling, int, ArgT). :- mode arg(in, in(do_not_allow), in, out) is semidet. :- mode arg(in, in(canonicalize), in, out) is semidet. :- mode arg(in, in(canonicalize_or_do_not_allow), in, out) is semidet. % arg_cc/3 is similar to arg/4, except that it % handles arguments with non-canonical types. % See the documentation of std_util__arg_cc. :- pred arg_cc(T, int, std_util__maybe_arg). :- mode arg_cc(in, in, out) is cc_multi. % named_arg(Data, NonCanon, Name, Argument) % % Same as arg/4, except the chosen argument is specified by giving % its name rather than its position. If Data has no argument with that % name, named_arg fails. % :- some [ArgT] pred named_arg(T, noncanon_handling, string, ArgT). :- mode named_arg(in, in(do_not_allow), in, out) is semidet. :- mode named_arg(in, in(canonicalize), in, out) is semidet. :- mode named_arg(in, in(canonicalize_or_do_not_allow), in, out) is semidet. % named_arg_cc/3 is similar to named_arg/4, except that it % handles arguments with non-canonical types. :- pred named_arg_cc(T, string, std_util__maybe_arg) is cc_multi. :- mode named_arg_cc(in, in, out) is cc_multi. % det_arg(Data, NonCanon, Index, Argument) % % Same as arg/4, except that for cases where % arg/4 would fail, det_arg/4 will abort. % :- some [ArgT] pred det_arg(T, noncanon_handling, int, ArgT). :- mode det_arg(in, in(do_not_allow), in, out) is det. :- mode det_arg(in, in(canonicalize), in, out) is det. :- mode det_arg(in, in(include_details_cc), in, out) is cc_multi. :- mode det_arg(in, in, in, out) is cc_multi. % det_named_arg(Data, NonCanon, Name, Argument) % % Same as named_arg/4, except that for cases where % named_arg/4 would fail, det_named_arg/4 will abort. % :- some [ArgT] pred det_named_arg(T, noncanon_handling, string, ArgT). :- mode det_named_arg(in, in(do_not_allow), in, out) is det. :- mode det_named_arg(in, in(canonicalize), in, out) is det. :- mode det_named_arg(in, in(include_details_cc), in, out) is cc_multi. :- mode det_named_arg(in, in, in, out) is cc_multi. % deconstruct(Data, NonCanon, Functor, Arity, Arguments) % % Given a data item (Data), binds Functor to a string % representation of the functor, Arity to the arity of this data % item, and Arguments to a list of arguments of the functor. % The arguments in the list are each of type univ. % % The cost of calling deconstruct depends greatly on how many arguments % Data has. If Data is an array, then each element of the array is % considered one of its arguments. Therefore calling deconstruct % on large arrays can take a very large amount of memory and a very % long time. If you call deconstruct in a situation in which you may % pass it a large array, you should probably use limited_deconstruct % instead. % :- pred deconstruct(T, noncanon_handling, string, int, list(univ)). :- mode deconstruct(in, in(do_not_allow), out, out, out) is det. :- mode deconstruct(in, in(canonicalize), out, out, out) is det. :- mode deconstruct(in, in(include_details_cc), out, out, out) is cc_multi. :- mode deconstruct(in, in, out, out, out) is cc_multi. % limited_deconstruct(Data, NonCanon, MaxArity, % Functor, Arity, Arguments) % % limited_deconstruct works like deconstruct, but if the arity of T is % greater than MaxArity, limited_deconstruct fails. This is useful in % avoiding bad performance in cases where Data may be a large array. % % Note that this predicate only returns an answer when NonCanon is % do_not_allow or canonicalize. If you need the include_details_cc % behaviour use deconstruct__limited_deconstruct_cc/3. % :- pred limited_deconstruct(T, noncanon_handling, int, string, int, list(univ)). :- mode limited_deconstruct(in, in(do_not_allow), in, out, out, out) is semidet. :- mode limited_deconstruct(in, in(canonicalize), in, out, out, out) is semidet. % See the documentation of std_util__limited_deconstruct_cc. :- pred limited_deconstruct_cc(T, int, maybe({string, int, list(univ)})). :- mode limited_deconstruct_cc(in, in, out) is cc_multi. :- implementation. :- interface. % The rest of the interface is for use by implementors only. :- type functor_tag_info ---> functor_integer(int) ; functor_float(float) ; functor_string(string) ; functor_enum(int) ; functor_local(int, int) ; functor_remote(int, int, list(univ)) ; functor_unshared(int, list(univ)) ; functor_notag(univ) ; functor_equiv(univ). % get_functor_info is a variant of deconstruct for use by the compiler, % specifically prog_rep.m and static_term.m. It differs from % deconstruct in two main ways. First, instead of returning the % function symbol, it returns implementation information about % its tag. Second, it succeeds for just the kinds of terms needed % to represent procedure bodies for ordinary procedures. For the time % being, these are procedures that do not involve higher order code % or tabling. :- pred get_functor_info(univ::in, functor_tag_info::out) is semidet. %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- implementation. :- import_module int, require, rtti_implementation. :- pragma foreign_import_module("C", std_util). %-----------------------------------------------------------------------------% :- pragma foreign_decl("C", " #include ""mercury_deconstruct.h"" #include ""mercury_deconstruct_macros.h"" "). %-----------------------------------------------------------------------------% % XXX The no-inline pragmas are necessary because when it inlines a predicate % defined by foreign_procs, the compiler does not preserve the names of the % typeinfo variables. Thus these foreign_proc's references to TypeInfo_for_T % will refer to an undefined variable. :- pragma no_inline(functor/4). :- pragma no_inline(arg/4). :- pragma no_inline(named_arg/4). :- pragma no_inline(deconstruct/5). :- pragma no_inline(limited_deconstruct/6). %-----------------------------------------------------------------------------% functor(Term, NonCanon, Functor, Arity) :- ( NonCanon = do_not_allow, functor_dna(Term, Functor, Arity) ; NonCanon = canonicalize, functor_can(Term, Functor, Arity) ; NonCanon = include_details_cc, functor_idcc(Term, Functor, Arity) ). arg(Term, NonCanon, Index, Argument) :- ( NonCanon = do_not_allow, univ_arg_dna(Term, Index, Univ) ; NonCanon = canonicalize, univ_arg_can(Term, Index, Univ) ; NonCanon = include_details_cc, error("deconstruct__arg called with include_details_cc") ), Argument = univ_value(Univ). arg_cc(Term, Index, MaybeArg) :- univ_arg_idcc(Term, Index, dummy_univ, Univ, Success), ( Success \= 0 -> MaybeArg = 'new arg'(univ_value(Univ)) ; MaybeArg = std_util__no_arg ). named_arg(Term, NonCanon, Name, Argument) :- ( NonCanon = do_not_allow, univ_named_arg_dna(Term, Name, Univ) ; NonCanon = canonicalize, univ_named_arg_can(Term, Name, Univ) ; NonCanon = include_details_cc, error("deconstruct__named_arg called with include_details_cc") ), Argument = univ_value(Univ). named_arg_cc(Term, Name, MaybeArg) :- univ_named_arg_idcc(Term, Name, dummy_univ, Univ, Success), ( Success \= 0 -> MaybeArg = 'new arg'(univ_value(Univ)) ; MaybeArg = std_util__no_arg ). % This is a dummy value of type `univ'. % It is used only to ensure that the C interface procedure % univ_named_arg_idcc doesn't return an uninitialized % (or otherwise bogus) univ value. :- func dummy_univ = univ. dummy_univ = univ(0). det_arg(Term, NonCanon, Index, Argument) :- ( NonCanon = do_not_allow, ( univ_arg_dna(Term, Index, Univ0) -> Univ = Univ0 ; error("det_arg: argument number out of range") ) ; NonCanon = canonicalize, ( univ_arg_can(Term, Index, Univ0) -> Univ = Univ0 ; error("det_arg: argument number out of range") ) ; NonCanon = include_details_cc, univ_arg_idcc(Term, Index, dummy_univ, Univ0, Success), ( Success \= 0 -> Univ = Univ0 ; error("det_arg: argument number out of range") ) ), Argument = univ_value(Univ). det_named_arg(Term, NonCanon, Name, Argument) :- ( ( NonCanon = do_not_allow, univ_named_arg_dna(Term, Name, Univ) ; NonCanon = canonicalize, univ_named_arg_can(Term, Name, Univ) ; NonCanon = include_details_cc, univ_named_arg_idcc(Term, Name, dummy_univ, Univ0, Success), ( Success \= 0 -> Univ = Univ0 ; error("det_named_arg: no argument with that name") ) ) -> Argument = univ_value(Univ) ; error("det_named_arg: no argument with that name") ). deconstruct(Term, NonCanon, Functor, Arity, Arguments) :- ( NonCanon = do_not_allow, deconstruct_dna(Term, Functor, Arity, Arguments) ; NonCanon = canonicalize, deconstruct_can(Term, Functor, Arity, Arguments) ; NonCanon = include_details_cc, deconstruct_idcc(Term, Functor, Arity, Arguments) ). limited_deconstruct(Term, NonCanon, MaxArity, Functor, Arity, Arguments) :- ( NonCanon = do_not_allow, limited_deconstruct_dna(Term, MaxArity, Functor, Arity, Arguments) ; NonCanon = canonicalize, limited_deconstruct_can(Term, MaxArity, Functor, Arity, Arguments) ; NonCanon = include_details_cc, error("limited_deconstruct called with include_details_cc") ). limited_deconstruct_cc(Term, MaxArity, MaybeResult) :- limited_deconstruct_idcc(Term, MaxArity, Functor, Arity, Arguments), ( Arity =< MaxArity -> MaybeResult = yes({Functor, Arity, Arguments}) ; MaybeResult = no ). %-----------------------------------------------------------------------------% :- pred functor_dna(T::in, string::out, int::out) is det. :- pred functor_can(T::in, string::out, int::out) is det. :- pred functor_idcc(T::in, string::out, int::out) is cc_multi. :- pragma foreign_proc("C", functor_dna(Term::in, Functor::out, Arity::out), [will_not_call_mercury, thread_safe, promise_pure], "{ #define TYPEINFO_ARG TypeInfo_for_T #define TERM_ARG Term #define FUNCTOR_ARG Functor #define ARITY_ARG Arity #define NONCANON MR_NONCANON_ABORT #include ""mercury_ml_functor_body.h"" #undef TYPEINFO_ARG #undef TERM_ARG #undef FUNCTOR_ARG #undef ARITY_ARG #undef NONCANON }"). :- pragma foreign_proc("C", functor_can(Term::in, Functor::out, Arity::out), [will_not_call_mercury, thread_safe, promise_pure], "{ #define TYPEINFO_ARG TypeInfo_for_T #define TERM_ARG Term #define FUNCTOR_ARG Functor #define ARITY_ARG Arity #define NONCANON MR_NONCANON_ALLOW #include ""mercury_ml_functor_body.h"" #undef TYPEINFO_ARG #undef TERM_ARG #undef FUNCTOR_ARG #undef ARITY_ARG #undef NONCANON }"). :- pragma foreign_proc("C", functor_idcc(Term::in, Functor::out, Arity::out), [will_not_call_mercury, thread_safe, promise_pure], "{ #define TYPEINFO_ARG TypeInfo_for_T #define TERM_ARG Term #define FUNCTOR_ARG Functor #define ARITY_ARG Arity #define NONCANON MR_NONCANON_CC #include ""mercury_ml_functor_body.h"" #undef TYPEINFO_ARG #undef TERM_ARG #undef FUNCTOR_ARG #undef ARITY_ARG #undef NONCANON }"). functor_dna(Term::in, Functor::out, Arity::out) :- rtti_implementation__deconstruct(Term, do_not_allow, Functor, Arity, _Arguments). functor_can(Term::in, Functor::out, Arity::out) :- rtti_implementation__deconstruct(Term, canonicalize, Functor, Arity, _Arguments). functor_idcc(Term::in, Functor::out, Arity::out) :- rtti_implementation__deconstruct(Term, include_details_cc, Functor, Arity, _Arguments). %-----------------------------------------------------------------------------% % XXX These predicates return univs instead of existentially typed arguments % in order to work around the typechecking bug reported on 30 Jan, 2002 % to the mercury-bugs mailing list, and which has sourceforge bug id 512581: % currently we don't support implementations in multiple languages % for procedures with existentially typed arguments. :- pred univ_arg_dna(T::in, int::in, univ::out) is semidet. :- pred univ_arg_can(T::in, int::in, univ::out) is semidet. % univ_arg_idcc(Term, N, DummyUniv, Argument, Success): % Attempt to extract the Nth field of (the current % representation of) Term. If there is such a field, % return Success=1 and return the field in Argument. % If there is not, return Success=0 and Argument=DummyUniv. :- pred univ_arg_idcc(T::in, int::in, univ::in, univ::out, int::out) is cc_multi. :- pred univ_named_arg_dna(T::in, string::in, univ::out) is semidet. :- pred univ_named_arg_can(T::in, string::in, univ::out) is semidet. % univ_named_arg_idcc(Term, Name, DummyUniv, Univ, Success): % Attempt to extract the field of (the current representation of) % Term specified by Name. If there is such a field, % return Success=1 and return the field in Univ. % If there is not, return Success=0 and Univ=DummyUniv. :- pred univ_named_arg_idcc(T::in, string::in, univ::in, univ::out, int::out) is cc_multi. :- pragma foreign_proc("C", univ_arg_dna(Term::in, Index::in, Argument::out), [will_not_call_mercury, thread_safe, promise_pure], "{ #define TYPEINFO_ARG TypeInfo_for_T #define TERM_ARG Term #define SELECTOR_ARG Index #define SELECTED_ARG Argument #define SELECTED_TYPE_INFO TypeInfo_for_ArgT #define NONCANON MR_NONCANON_ABORT #define SAVE_SUCCESS #include ""mercury_ml_arg_body.h"" #undef TYPEINFO_ARG #undef TERM_ARG #undef SELECTOR_ARG #undef SELECTED_ARG #undef SELECTED_TYPE_INFO #undef NONCANON #undef SAVE_SUCCESS }"). :- pragma foreign_proc("C", univ_arg_can(Term::in, Index::in, Argument::out), [will_not_call_mercury, thread_safe, promise_pure], "{ #define TYPEINFO_ARG TypeInfo_for_T #define TERM_ARG Term #define SELECTOR_ARG Index #define SELECTED_ARG Argument #define SELECTED_TYPE_INFO TypeInfo_for_ArgT #define NONCANON MR_NONCANON_ALLOW #define SAVE_SUCCESS #include ""mercury_ml_arg_body.h"" #undef TYPEINFO_ARG #undef TERM_ARG #undef SELECTOR_ARG #undef SELECTED_ARG #undef SELECTED_TYPE_INFO #undef NONCANON #undef SAVE_SUCCESS }"). :- pragma foreign_proc("C", univ_arg_idcc(Term::in, Index::in, DummyUniv::in, Argument::out, Success::out), [will_not_call_mercury, thread_safe, promise_pure], "{ #define TYPEINFO_ARG TypeInfo_for_T #define TERM_ARG Term #define SELECTOR_ARG Index #define SELECTED_ARG Argument #define SELECTED_TYPE_INFO TypeInfo_for_ArgT #define NONCANON MR_NONCANON_CC #include ""mercury_ml_arg_body.h"" #undef TYPEINFO_ARG #undef TERM_ARG #undef SELECTOR_ARG #undef SELECTED_ARG #undef SELECTED_TYPE_INFO #undef NONCANON if (success) { Success = 1; } else { Success = 0; Argument = DummyUniv; } }"). :- pragma foreign_proc("C", univ_named_arg_dna(Term::in, Name::in, Argument::out), [will_not_call_mercury, thread_safe, promise_pure], "{ #define TYPEINFO_ARG TypeInfo_for_T #define TERM_ARG Term #define SELECTOR_ARG (MR_ConstString) Name #define SELECTED_ARG Argument #define SELECTED_TYPE_INFO TypeInfo_for_ArgT #define NONCANON MR_NONCANON_ABORT #define SELECT_BY_NAME #define SAVE_SUCCESS #include ""mercury_ml_arg_body.h"" #undef TYPEINFO_ARG #undef TERM_ARG #undef SELECTOR_ARG #undef SELECTED_ARG #undef SELECTED_TYPE_INFO #undef NONCANON #undef SELECT_BY_NAME #undef SAVE_SUCCESS }"). :- pragma foreign_proc("C", univ_named_arg_can(Term::in, Name::in, Argument::out), [will_not_call_mercury, thread_safe, promise_pure], "{ #define TYPEINFO_ARG TypeInfo_for_T #define TERM_ARG Term #define SELECTOR_ARG (MR_ConstString) Name #define SELECTED_ARG Argument #define SELECTED_TYPE_INFO TypeInfo_for_ArgT #define NONCANON MR_NONCANON_ALLOW #define SELECT_BY_NAME #define SAVE_SUCCESS #include ""mercury_ml_arg_body.h"" #undef TYPEINFO_ARG #undef TERM_ARG #undef SELECTOR_ARG #undef SELECTED_ARG #undef SELECTED_TYPE_INFO #undef NONCANON #undef SELECT_BY_NAME #undef SAVE_SUCCESS }"). :- pragma foreign_proc("C", univ_named_arg_idcc(Term::in, Name::in, DummyUniv::in, Argument::out, Success::out), [will_not_call_mercury, thread_safe, promise_pure], "{ #define TYPEINFO_ARG TypeInfo_for_T #define TERM_ARG Term #define SELECTOR_ARG (MR_ConstString) Name #define SELECTED_ARG Argument #define SELECTED_TYPE_INFO TypeInfo_for_ArgT #define NONCANON MR_NONCANON_CC #define SELECT_BY_NAME #include ""mercury_ml_arg_body.h"" #undef TYPEINFO_ARG #undef TERM_ARG #undef SELECTOR_ARG #undef SELECTED_ARG #undef SELECTED_TYPE_INFO #undef NONCANON #undef SELECT_BY_NAME if (success) { Success = 1; } else { Success = 0; Argument = DummyUniv; } }"). % XXX These Mercury implementations are all inefficient, % since they unnecessarily construct the list of univs % for all the arguments, rather than just constructing % one univ for the argument selected. univ_arg_dna(Term::in, Index::in, Arg::out) :- rtti_implementation__deconstruct(Term, do_not_allow, _Functor, _Arity, Arguments), list__index0(Arguments, Index, Arg). univ_arg_can(Term::in, Index::in, Arg::out) :- rtti_implementation__deconstruct(Term, canonicalize, _Functor, _Arity, Arguments), list__index0(Arguments, Index, Arg). univ_arg_idcc(Term::in, Index::in, DummyUniv::in, Argument::out, Success::out) :- rtti_implementation__deconstruct(Term, include_details_cc, _Functor, _Arity, Arguments), ( list__index0(Arguments, Index, Arg) -> Argument = Arg, Success = 1 ; Argument = DummyUniv, Success = 0 ). %-----------------------------------------------------------------------------% :- pred deconstruct_dna(T::in, string::out, int::out, list(univ)::out) is det. :- pred deconstruct_can(T::in, string::out, int::out, list(univ)::out) is det. :- pred deconstruct_idcc(T::in, string::out, int::out, list(univ)::out) is cc_multi. :- pred limited_deconstruct_dna(T::in, int::in, string::out, int::out, list(univ)::out) is semidet. :- pred limited_deconstruct_can(T::in, int::in, string::out, int::out, list(univ)::out) is semidet. :- pred limited_deconstruct_idcc(T::in, int::in, string::out, int::out, list(univ)::out) is cc_multi. :- pragma foreign_proc("C", deconstruct_dna(Term::in, Functor::out, Arity::out, Arguments::out), [will_not_call_mercury, thread_safe, promise_pure], "{ #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 #define NONCANON MR_NONCANON_ABORT #include ""mercury_ml_deconstruct_body.h"" #undef EXPAND_INFO_TYPE #undef EXPAND_INFO_CALL #undef TYPEINFO_ARG #undef TERM_ARG #undef FUNCTOR_ARG #undef ARITY_ARG #undef ARGUMENTS_ARG #undef NONCANON }"). :- pragma foreign_proc("C", deconstruct_can(Term::in, Functor::out, Arity::out, Arguments::out), [will_not_call_mercury, thread_safe, promise_pure], "{ #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 #define NONCANON MR_NONCANON_ALLOW #include ""mercury_ml_deconstruct_body.h"" #undef EXPAND_INFO_TYPE #undef EXPAND_INFO_CALL #undef TYPEINFO_ARG #undef TERM_ARG #undef FUNCTOR_ARG #undef ARITY_ARG #undef ARGUMENTS_ARG #undef NONCANON }"). :- pragma foreign_proc("C", deconstruct_idcc(Term::in, Functor::out, Arity::out, Arguments::out), [will_not_call_mercury, thread_safe, promise_pure], "{ #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 #define NONCANON MR_NONCANON_CC #include ""mercury_ml_deconstruct_body.h"" #undef EXPAND_INFO_TYPE #undef EXPAND_INFO_CALL #undef TYPEINFO_ARG #undef TERM_ARG #undef FUNCTOR_ARG #undef ARITY_ARG #undef ARGUMENTS_ARG #undef NONCANON }"). :- pragma foreign_proc("C", limited_deconstruct_dna(Term::in, MaxArity::in, Functor::out, Arity::out, Arguments::out), [will_not_call_mercury, thread_safe, promise_pure], "{ #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 #define NONCANON MR_NONCANON_ABORT #define SAVE_SUCCESS #include ""mercury_ml_deconstruct_body.h"" #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 #undef NONCANON #undef SAVE_SUCCESS }"). :- pragma foreign_proc("C", limited_deconstruct_can(Term::in, MaxArity::in, Functor::out, Arity::out, Arguments::out), [will_not_call_mercury, thread_safe, promise_pure], "{ #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 #define NONCANON MR_NONCANON_ALLOW #define SAVE_SUCCESS #include ""mercury_ml_deconstruct_body.h"" #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 #undef NONCANON #undef SAVE_SUCCESS }"). :- pragma foreign_proc("C", limited_deconstruct_idcc(Term::in, MaxArity::in, Functor::out, Arity::out, Arguments::out), [will_not_call_mercury, thread_safe, promise_pure], "{ #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 #define NONCANON MR_NONCANON_CC #include ""mercury_ml_deconstruct_body.h"" #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 #undef NONCANON if (!success) { /* ** Fill in some dummy values, to ensure that we don't ** try to return uninitialized memory to Mercury. ** It doesn't matter what we put here, except that ** we must have Arity > MaxArity. The casts cast away ** const. */ Arity = MaxArity + 1; Functor = (MR_String) (MR_Integer) """"; Arguments = MR_list_empty(); } }"). deconstruct_dna(Term::in, Functor::out, Arity::out, Arguments::out) :- rtti_implementation__deconstruct(Term, do_not_allow, Functor, Arity, Arguments). deconstruct_can(Term::in, Functor::out, Arity::out, Arguments::out) :- rtti_implementation__deconstruct(Term, canonicalize, Functor, Arity, Arguments). deconstruct_idcc(Term::in, Functor::out, Arity::out, Arguments::out) :- rtti_implementation__deconstruct(Term, include_details_cc, Functor, Arity, Arguments). % XXX The Mercury implementations of all of these limited_* procedures % are inefficient -- they construct Functor and Arguments even in % the case when Arity > MaxArity. limited_deconstruct_dna(Term::in, MaxArity::in, Functor::out, Arity::out, Arguments::out) :- rtti_implementation__deconstruct(Term, do_not_allow, Functor, Arity, Arguments), Arity =< MaxArity. limited_deconstruct_can(Term::in, MaxArity::in, Functor::out, Arity::out, Arguments::out) :- rtti_implementation__deconstruct(Term, canonicalize, Functor, Arity, Arguments), Arity =< MaxArity. limited_deconstruct_idcc(Term::in, _MaxArity::in, Functor::out, Arity::out, Arguments::out) :- % For this one, the caller checks Arity =< MaxArity. rtti_implementation__deconstruct(Term, include_details_cc, Functor, Arity, Arguments). %-----------------------------------------------------------------------------% get_functor_info(Univ, FunctorInfo) :- ( univ_to_type(Univ, Int) -> FunctorInfo = functor_integer(Int) ; univ_to_type(Univ, Float) -> FunctorInfo = functor_float(Float) ; univ_to_type(Univ, String) -> FunctorInfo = functor_string(String) ; get_enum_functor_info(Univ, Enum) -> FunctorInfo = functor_enum(Enum) % % XXX we should handle reserved_addr types here % ; get_du_functor_info(Univ, Where, Ptag, Sectag, Args) -> ( Where = 0 -> FunctorInfo = functor_unshared(Ptag, Args) ; Where > 0 -> FunctorInfo = functor_remote(Ptag, Sectag, Args) ; FunctorInfo = functor_local(Ptag, Sectag) ) ; get_notag_functor_info(Univ, ExpUniv) -> FunctorInfo = functor_notag(ExpUniv) ; get_equiv_functor_info(Univ, ExpUniv) -> FunctorInfo = functor_equiv(ExpUniv) ; fail ). % Given a value of an arbitrary type, succeed if its type is defined % as a notag type, and return a univ which bundles up the value % with the type of the single function symbol of the notag type. :- pred get_notag_functor_info(univ::in, univ::out) is semidet. :- pragma foreign_proc("C", get_notag_functor_info(Univ::in, ExpUniv::out), [will_not_call_mercury, thread_safe, promise_pure], "{ MR_TypeInfo type_info; MR_TypeInfo exp_type_info; MR_TypeCtorInfo type_ctor_info; const MR_NotagFunctorDesc *functor_desc; MR_Word value; MR_unravel_univ(Univ, type_info, value); type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info); switch (MR_type_ctor_rep(type_ctor_info)) { case MR_TYPECTOR_REP_NOTAG: case MR_TYPECTOR_REP_NOTAG_USEREQ: functor_desc = MR_type_ctor_functors(type_ctor_info). MR_functors_notag; exp_type_info = MR_pseudo_type_info_is_ground( functor_desc->MR_notag_functor_arg_type); MR_new_univ_on_hp(ExpUniv, exp_type_info, value); SUCCESS_INDICATOR = MR_TRUE; break; case MR_TYPECTOR_REP_NOTAG_GROUND: case MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ: functor_desc = MR_type_ctor_functors(type_ctor_info). MR_functors_notag; exp_type_info = MR_create_type_info( MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info), functor_desc->MR_notag_functor_arg_type); MR_new_univ_on_hp(ExpUniv, exp_type_info, value); SUCCESS_INDICATOR = MR_TRUE; break; default: SUCCESS_INDICATOR = MR_FALSE; break; } }"). % Given a value of an arbitrary type, succeed if its type is defined % as an equivalence type, and return a univ which bundles up the value % with the equivalent type. (I.e. this removes one layer of equivalence % from the type stored in the univ.) :- pred get_equiv_functor_info(univ::in, univ::out) is semidet. :- pragma foreign_proc("C", get_equiv_functor_info(Univ::in, ExpUniv::out), [will_not_call_mercury, thread_safe, promise_pure], "{ MR_TypeInfo type_info; MR_TypeInfo exp_type_info; MR_TypeCtorInfo type_ctor_info; MR_Word value; MR_unravel_univ(Univ, type_info, value); type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info); switch (MR_type_ctor_rep(type_ctor_info)) { case MR_TYPECTOR_REP_EQUIV: exp_type_info = MR_pseudo_type_info_is_ground( MR_type_ctor_layout(type_ctor_info).MR_layout_equiv); MR_new_univ_on_hp(ExpUniv, exp_type_info, value); SUCCESS_INDICATOR = MR_TRUE; break; case MR_TYPECTOR_REP_EQUIV_GROUND: exp_type_info = MR_create_type_info( MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info), MR_type_ctor_layout(type_ctor_info).MR_layout_equiv); MR_new_univ_on_hp(ExpUniv, exp_type_info, value); SUCCESS_INDICATOR = MR_TRUE; break; default: SUCCESS_INDICATOR = MR_FALSE; break; } }"). % Given a value of an arbitrary type, succeed if it is an enum type, % and return the integer value corresponding to the value. :- pred get_enum_functor_info(univ::in, int::out) is semidet. :- pragma foreign_proc("C", get_enum_functor_info(Univ::in, Enum::out), [will_not_call_mercury, thread_safe, promise_pure], "{ MR_TypeInfo type_info; MR_TypeCtorInfo type_ctor_info; MR_Word value; MR_unravel_univ(Univ, type_info, value); type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info); switch (MR_type_ctor_rep(type_ctor_info)) { case MR_TYPECTOR_REP_ENUM: case MR_TYPECTOR_REP_ENUM_USEREQ: Enum = (MR_Integer) value; SUCCESS_INDICATOR = MR_TRUE; break; default: SUCCESS_INDICATOR = MR_FALSE; break; } }"). % Given a value of an arbitrary type, succeed if it is a general du type % (i.e. non-enum, non-notag du type), and return the top function symbol's % arguments as well as its tag information: an indication of where the % secondary tag is (-1 for local secondary tag, 0 for nonexistent secondary % tag, and 1 for remote secondary tag), as well as the primary and % secondary tags themselves (the secondary tag argument will be meaningful % only if the secondary tag exists, of course). :- pred get_du_functor_info(univ::in, int::out, int::out, int::out, list(univ)::out) is semidet. :- pragma foreign_proc("C", get_du_functor_info(Univ::in, Where::out, Ptag::out, Sectag::out, Args::out), [will_not_call_mercury, thread_safe, promise_pure], "{ MR_TypeInfo type_info; MR_TypeCtorInfo type_ctor_info; const MR_DuPtagLayout *ptag_layout; const MR_DuFunctorDesc *functor_desc; MR_Word value; MR_Word *arg_vector; int i; MR_unravel_univ(Univ, type_info, value); type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info); switch (MR_type_ctor_rep(type_ctor_info)) { case MR_TYPECTOR_REP_DU: case MR_TYPECTOR_REP_DU_USEREQ: SUCCESS_INDICATOR = MR_TRUE; Ptag = MR_tag(value); ptag_layout = &MR_type_ctor_layout(type_ctor_info). MR_layout_du[Ptag]; switch(ptag_layout->MR_sectag_locn) { case MR_SECTAG_LOCAL: Where = -1; Sectag = MR_unmkbody(value); Args = MR_list_empty(); break; case MR_SECTAG_REMOTE: case MR_SECTAG_NONE: if (ptag_layout->MR_sectag_locn == MR_SECTAG_NONE) { Where = 0; arg_vector = (MR_Word *) MR_body(value, Ptag); Sectag = 0; } else { Where = 1; arg_vector = (MR_Word *) MR_body(value, Ptag); Sectag = arg_vector[0]; arg_vector++; } functor_desc = ptag_layout->MR_sectag_alternatives[Sectag]; if (functor_desc->MR_du_functor_exist_info != NULL) { SUCCESS_INDICATOR = MR_FALSE; break; } Args = MR_list_empty_msg(MR_PROC_LABEL); for (i = functor_desc->MR_du_functor_orig_arity - 1; i >= 0; i--) { MR_Word arg; MR_TypeInfo arg_type_info; if (MR_arg_type_may_contain_var(functor_desc, i)) { arg_type_info = MR_create_type_info_maybe_existq( MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR( type_info), functor_desc->MR_du_functor_arg_types[i], arg_vector, functor_desc); } else { arg_type_info = MR_pseudo_type_info_is_ground( functor_desc->MR_du_functor_arg_types[i]); } MR_new_univ_on_hp(arg, arg_type_info, arg_vector[i]); Args = MR_univ_list_cons_msg(arg, Args, MR_PROC_LABEL); } break; case MR_SECTAG_VARIABLE: MR_fatal_error( ""get_du_functor_info: unexpected variable""); default: MR_fatal_error( ""get_du_functor_info: unknown sectag locn""); } break; default: SUCCESS_INDICATOR = MR_FALSE; break; } }").