%-----------------------------------------------------------------------------% % Copyright (C) 1994-2004 The University of Melbourne. % This file may only be copied under the terms of the GNU Library General % Public License - see the file COPYING.LIB in the Mercury distribution. %-----------------------------------------------------------------------------% % File: std_util.m. % Main author: fjh. % Stability: medium. % This file is intended for all the useful standard utilities % that don't belong elsewhere, like in C. %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- module std_util. :- interface. :- import_module list, set, bool. :- import_module type_desc. %-----------------------------------------------------------------------------% % The universal type `univ'. % An object of type `univ' can hold the type and value of an object of any % other type. :- type univ. % type_to_univ(Object, Univ): % true iff the type stored in `Univ' is the same as the type % of `Object', and the value stored in `Univ' is equal to the % value of `Object'. % % Operational, the forwards mode converts an object to type `univ', % while the reverse mode converts the value stored in `Univ' % to the type of `Object', but fails if the type stored in `Univ' % does not match the type of `Object'. % :- pred type_to_univ(T, univ). :- mode type_to_univ(di, uo) is det. :- mode type_to_univ(in, out) is det. :- mode type_to_univ(out, in) is semidet. % univ_to_type(Univ, Object) :- type_to_univ(Object, Univ). % :- pred univ_to_type(univ, T). :- mode univ_to_type(in, out) is semidet. :- mode univ_to_type(out, in) is det. :- mode univ_to_type(uo, di) is det. % The function univ/1 provides the same % functionality as type_to_univ/2. % univ(Object) = Univ :- type_to_univ(Object, Univ). % :- func univ(T) = univ. :- mode univ(in) = out is det. :- mode univ(di) = uo is det. :- mode univ(out) = in is semidet. % det_univ_to_type(Univ, Object): % the same as the forwards mode of univ_to_type, but % abort if univ_to_type fails. % :- pred det_univ_to_type(univ, T). :- mode det_univ_to_type(in, out) is det. % univ_type(Univ): % returns the type_desc for the type stored in `Univ'. % :- func univ_type(univ) = type_desc__type_desc. % univ_value(Univ): % returns the value of the object stored in Univ. :- some [T] func univ_value(univ) = T. %-----------------------------------------------------------------------------% % The "maybe" type. :- type maybe(T) ---> no ; yes(T). :- inst maybe(I) ---> no ; yes(I). :- type maybe_error ---> ok ; error(string). :- type maybe_error(T) ---> ok(T) ; error(string). :- inst maybe_error(I) ---> ok(I) ; error(ground). % map_maybe(P, yes(Value0), yes(Value)) :- P(Value, Value). % map_maybe(_, no, no). % :- pred map_maybe(pred(T, U), maybe(T), maybe(U)). :- mode map_maybe(pred(in, out) is det, in, out) is det. :- mode map_maybe(pred(in, out) is semidet, in, out) is semidet. :- mode map_maybe(pred(in, out) is multi, in, out) is multi. :- mode map_maybe(pred(in, out) is nondet, in, out) is nondet. % map_maybe(F, yes(Value)) = yes(F(Value)). % map_maybe(_, no) = no. % :- func map_maybe(func(T) = U, maybe(T)) = maybe(U). % fold_maybe(P, yes(Value), Acc0, Acc) :- P(Value, Acc0, Acc). % fold_maybe(_, no, Acc, Acc). :- pred fold_maybe(pred(T, U, U), maybe(T), U, U). :- mode fold_maybe(pred(in, in, out) is det, in, in, out) is det. :- mode fold_maybe(pred(in, in, out) is semidet, in, in, out) is semidet. :- mode fold_maybe(pred(in, di, uo) is det, in, di, uo) is det. % fold_maybe(F, yes(Value), Acc0) = F(Acc0). % fold_maybe(_, no, Acc) = Acc. :- func fold_maybe(func(T, U) = U, maybe(T), U) = U. % map_fold_maybe(P, yes(Value0), yes(Value), Acc0, Acc) :- % P(Value, Value, Acc0, Acc). % map_fold_maybe(_, no, no, Acc, Acc). % :- pred map_fold_maybe(pred(T, U, Acc, Acc), maybe(T), maybe(U), Acc, Acc). :- mode map_fold_maybe(pred(in, out, in, out) is det, in, out, in, out) is det. :- mode map_fold_maybe(pred(in, out, di, uo) is det, in, out, di, uo) is det. % As above, but with two accumulators. :- pred map_fold2_maybe(pred(T, U, Acc1, Acc1, Acc2, Acc2), maybe(T), maybe(U), Acc1, Acc1, Acc2, Acc2). :- mode map_fold2_maybe(pred(in, out, in, out, in, out) is det, in, out, in, out, in, out) is det. :- mode map_fold2_maybe(pred(in, out, in, out, di, uo) is det, in, out, in, out, di, uo) is det. %-----------------------------------------------------------------------------% % The "unit" type - stores no information at all. :- type unit ---> unit. :- type unit(T) ---> unit1. %-----------------------------------------------------------------------------% % The "pair" type. Useful for many purposes. :- type pair(T1, T2) ---> (T1 - T2). :- type pair(T) == pair(T,T). :- inst pair(I1, I2) ---> (I1 - I2). :- inst pair(I) == pair(I,I). % Return the first element of the pair. :- pred fst(pair(X,Y)::in, X::out) is det. :- func fst(pair(X,Y)) = X. % Return the second element of the pair. :- pred snd(pair(X,Y)::in, Y::out) is det. :- func snd(pair(X,Y)) = Y. :- func pair(T1, T2) = pair(T1, T2). %-----------------------------------------------------------------------------% % solutions/2 collects all the solutions to a predicate and % returns them as a list in sorted order, with duplicates removed. % solutions_set/2 returns them as a set. % unsorted_solutions/2 returns them as an unsorted list with possible % duplicates; since there are an infinite number of such lists, % this must be called from a context in which only a single solution % is required. :- pred solutions(pred(T), list(T)). :- mode solutions(pred(out) is multi, out(non_empty_list)) is det. :- mode solutions(pred(out) is nondet, out) is det. :- func solutions(pred(T)) = list(T). :- mode solutions(pred(out) is multi) = out(non_empty_list) is det. :- mode solutions(pred(out) is nondet) = out is det. :- pred solutions_set(pred(T), set(T)). :- mode solutions_set(pred(out) is multi, out) is det. :- mode solutions_set(pred(out) is nondet, out) is det. :- func solutions_set(pred(T)) = set(T). :- mode solutions_set(pred(out) is multi) = out is det. :- mode solutions_set(pred(out) is nondet) = out is det. :- pred unsorted_solutions(pred(T), list(T)). :- mode unsorted_solutions(pred(out) is multi, out(non_empty_list)) is cc_multi. :- mode unsorted_solutions(pred(out) is nondet, out) is cc_multi. :- func aggregate(pred(T), func(T, U) = U, U) = U. :- mode aggregate(pred(out) is multi, func(in, in) = out is det, in) = out is det. :- mode aggregate(pred(out) is nondet, func(in, in) = out is det, in) = out is det. %-----------------------------------------------------------------------------% % aggregate/4 generates all the solutions to a predicate, % sorts them and removes duplicates, then applies an accumulator % predicate to each solution in turn: % % aggregate(Generator, Accumulator, Acc0, Acc) <=> % solutions(Generator, Solutions), % list__foldl(Accumulator, Solutions, Acc0, Acc). % :- pred aggregate(pred(T), pred(T, U, U), U, U). :- mode aggregate(pred(out) is multi, pred(in, in, out) is det, in, out) is det. :- mode aggregate(pred(out) is multi, pred(in, di, uo) is det, di, uo) is det. :- mode aggregate(pred(out) is nondet, pred(in, di, uo) is det, di, uo) is det. :- mode aggregate(pred(out) is nondet, pred(in, in, out) is det, in, out) is det. % aggregate2/6 generates all the solutions to a predicate, % sorts them and removes duplicates, then applies an accumulator % predicate to each solution in turn: % % aggregate2(Generator, Accumulator, AccA0, AccA, AccB0, AccB) <=> % solutions(Generator, Solutions), % list__foldl2(Accumulator, Solutions, AccA0, AccA, AccB0, AccB). % :- pred aggregate2(pred(T), pred(T, U, U, V, V), U, U, V, V). :- mode aggregate2(pred(out) is multi, pred(in, in, out, in, out) is det, in, out, in, out) is det. :- mode aggregate2(pred(out) is multi, pred(in, in, out, di, uo) is det, in, out, di, uo) is det. :- mode aggregate2(pred(out) is nondet, pred(in, in, out, di, uo) is det, in, out, di, uo) is det. :- mode aggregate2(pred(out) is nondet, pred(in, in, out, in, out) is det, in, out, in, out) is det. % unsorted_aggregate/4 generates all the solutions to a predicate % and applies an accumulator predicate to each solution in turn. % Declaratively, the specification is as follows: % % unsorted_aggregate(Generator, Accumulator, Acc0, Acc) <=> % unsorted_solutions(Generator, Solutions), % list__foldl(Accumulator, Solutions, Acc0, Acc). % % Operationally, however, unsorted_aggregate/4 will call the % Accumulator for each solution as it is obtained, rather than % first building a list of all the solutions. :- pred unsorted_aggregate(pred(T), pred(T, U, U), U, U). :- mode unsorted_aggregate(pred(out) is multi, pred(in, in, out) is det, in, out) is cc_multi. :- mode unsorted_aggregate(pred(out) is multi, pred(in, di, uo) is det, di, uo) is cc_multi. :- mode unsorted_aggregate(pred(out) is multi, pred(in, di, uo) is cc_multi, di, uo) is cc_multi. :- mode unsorted_aggregate(pred(muo) is multi, pred(mdi, di, uo) is det, di, uo) is cc_multi. :- mode unsorted_aggregate(pred(out) is nondet, pred(in, di, uo) is det, di, uo) is cc_multi. :- mode unsorted_aggregate(pred(out) is nondet, pred(in, di, uo) is cc_multi, di, uo) is cc_multi. :- mode unsorted_aggregate(pred(out) is nondet, pred(in, in, out) is det, in, out) is cc_multi. :- mode unsorted_aggregate(pred(muo) is nondet, pred(mdi, di, uo) is det, di, uo) is cc_multi. % This is a generalization of unsorted_aggregate which allows the % iteration to stop before all solutions have been found. % Declaratively, the specification is as follows: % % do_while(Generator, Filter) --> % { unsorted_solutions(Generator, Solutions) }, % do_while_2(Solutions, Filter). % % do_while_2([], _) --> []. % do_while_2([X|Xs], Filter) --> % Filter(X, More), % (if { More = yes } then % do_while_2(Xs, Filter) % else % { true } % ). % % Operationally, however, do_while/4 will call the Filter % predicate for each solution as it is obtained, rather than % first building a list of all the solutions. % :- pred do_while(pred(T), pred(T, bool, T2, T2), T2, T2). :- mode do_while(pred(out) is multi, pred(in, out, in, out) is det, in, out) is cc_multi. :- mode do_while(pred(out) is multi, pred(in, out, di, uo) is det, di, uo) is cc_multi. :- mode do_while(pred(out) is multi, pred(in, out, di, uo) is cc_multi, di, uo) is cc_multi. :- mode do_while(pred(out) is nondet, pred(in, out, in, out) is det, in, out) is cc_multi. :- mode do_while(pred(out) is nondet, pred(in, out, di, uo) is det, di, uo) is cc_multi. :- mode do_while(pred(out) is nondet, pred(in, out, di, uo) is cc_multi, di, uo) is cc_multi. %-----------------------------------------------------------------------------% % General purpose higher-order programming constructs. % compose(F, G, X) = F(G(X)) % % Function composition. % XXX It would be nice to have infix `o' or somesuch for this. :- func compose(func(T2) = T3, func(T1) = T2, T1) = T3. % converse(F, X, Y) = F(Y, X) :- func converse(func(T1, T2) = T3, T2, T1) = T3. % pow(F, N, X) = F^N(X) % % Function exponentiation. :- func pow(func(T) = T, int, T) = T. % The identity function. % :- func id(T) = T. %-----------------------------------------------------------------------------% % maybe_pred(Pred, X, Y) takes a closure Pred which transforms an % input semideterministically. If calling the closure with the input % X succeeds, Y is bound to `yes(Z)' where Z is the output of the % call, or to `no' if the call fails. % :- pred maybe_pred(pred(T1, T2), T1, maybe(T2)). :- mode maybe_pred(pred(in, out) is semidet, in, out) is det. :- func maybe_func(func(T1) = T2, T1) = maybe(T2). :- mode maybe_func(func(in) = out is semidet, in) = out is det. %-----------------------------------------------------------------------------% % isnt(Pred, X) <=> not Pred(X) % % This is useful in higher order programming, e.g. % Odds = list__filter(odd, Xs) % Evens = list__filter(isnt(odd), Xs) % :- pred isnt(pred(T), T). :- mode isnt(pred(in) is semidet, in) is semidet. %-----------------------------------------------------------------------------% % `semidet_succeed' is exactly the same as `true', except that % the compiler thinks that it is semi-deterministic. You can % use calls to `semidet_succeed' to suppress warnings about % determinism declarations which could be stricter. % Similarly, `semidet_fail' is like `fail' except that its % determinism is semidet rather than failure, and % `cc_multi_equal(X,Y)' is the same as `X=Y' except that it % is cc_multi rather than det. :- pred semidet_succeed is semidet. :- pred semidet_fail is semidet. :- pred cc_multi_equal(T, T). :- mode cc_multi_equal(di, uo) is cc_multi. :- mode cc_multi_equal(in, out) is cc_multi. %-----------------------------------------------------------------------------% % The `type_desc' and `type_ctor_desc' types: these % provide access to type information. % A type_desc represents a type, e.g. `list(int)'. % A type_ctor_desc represents a type constructor, e.g. `list/1'. :- type type_desc == type_desc__type_desc. :- type type_ctor_desc == type_desc__type_ctor_desc. % Type_info and type_ctor_info are the old names for type_desc and % type_ctor_desc. They should not be used by new software. :- type type_info == type_desc__type_desc. :- type type_ctor_info == type_desc__type_ctor_desc. % (Note: it is not possible for the type of a variable to be an % unbound type variable; if there are no constraints on a type % variable, then the typechecker will use the type `void'. % `void' is a special (builtin) type that has no constructors. % There is no way of creating an object of type `void'. % `void' is not considered to be a discriminated union, so % get_functor/5 and construct/3 will fail if used upon a value % of this type.) % The function type_of/1 returns a representation of the type % of its argument. % :- func type_of(T) = type_desc__type_desc. :- mode type_of(unused) = out is det. % The predicate has_type/2 is basically an existentially typed % inverse to the function type_of/1. It constrains the type % of the first argument to be the type represented by the % second argument. :- some [T] pred has_type(T::unused, type_desc__type_desc::in) is det. % type_name(Type) returns the name of the specified type % (e.g. type_name(type_of([2,3])) = "list:list(int)"). % Any equivalence types will be fully expanded. % Builtin types (those defined in builtin.m) will % not have a module qualifier. % :- func type_name(type_desc__type_desc) = string. % type_ctor_and_args(Type, TypeCtor, TypeArgs): % True iff `TypeCtor' is a representation of the top-level % type constructor for `Type', and `TypeArgs' is a list % of the corresponding type arguments to `TypeCtor', % and `TypeCtor' is not an equivalence type. % % For example, type_ctor_and_args(type_of([2,3]), TypeCtor, % TypeArgs) will bind `TypeCtor' to a representation of the % type constructor list/1, and will bind `TypeArgs' to the list % `[Int]', where `Int' is a representation of the type `int'. % % Note that the requirement that `TypeCtor' not be an % equivalence type is fulfilled by fully expanding any % equivalence types. For example, if you have a declaration % `:- type foo == bar.', then type_ctor_and_args/3 will always % return a representation of type constructor `bar/0', not `foo/0'. % (If you don't want them expanded, you can use the reverse mode % of make_type/2 instead.) % :- pred type_ctor_and_args(type_desc__type_desc, type_desc__type_ctor_desc, list(type_desc__type_desc)). :- mode type_ctor_and_args(in, out, out) is det. % type_ctor(Type) = TypeCtor :- % type_ctor_and_args(Type, TypeCtor, _). % :- func type_ctor(type_desc__type_desc) = type_desc__type_ctor_desc. % type_args(Type) = TypeArgs :- % type_ctor_and_args(Type, _, TypeArgs). % :- func type_args(type_desc__type_desc) = list(type_desc__type_desc). % type_ctor_name(TypeCtor) returns the name of specified % type constructor. % (e.g. type_ctor_name(type_ctor(type_of([2,3]))) = "list"). % :- func type_ctor_name(type_desc__type_ctor_desc) = string. % type_ctor_module_name(TypeCtor) returns the module name of specified % type constructor. % (e.g. type_ctor_module_name(type_ctor(type_of(2))) = "builtin"). % :- func type_ctor_module_name(type_desc__type_ctor_desc) = string. % type_ctor_arity(TypeCtor) returns the arity of specified % type constructor. % (e.g. type_ctor_arity(type_ctor(type_of([2,3]))) = 1). % :- func type_ctor_arity(type_desc__type_ctor_desc) = int. % type_ctor_name_and_arity(TypeCtor, ModuleName, TypeName, Arity) :- % Name = type_ctor_name(TypeCtor), % ModuleName = type_ctor_module_name(TypeCtor), % Arity = type_ctor_arity(TypeCtor). % :- pred type_ctor_name_and_arity(type_desc__type_ctor_desc::in, string::out, string::out, int::out) is det. % make_type(TypeCtor, TypeArgs) = Type: % True iff `Type' is a type constructed by applying % the type constructor `TypeCtor' to the type arguments % `TypeArgs'. % % Operationally, the forwards mode returns the type formed by % applying the specified type constructor to the specified % argument types, or fails if the length of TypeArgs is not the % same as the arity of TypeCtor. The reverse mode returns a % type constructor and its argument types, given a type_desc; % the type constructor returned may be an equivalence type % (and hence this reverse mode of make_type/2 may be more useful % for some purposes than the type_ctor/1 function). % :- func make_type(type_desc__type_ctor_desc, list(type_desc__type_desc)) = type_desc__type_desc. :- mode make_type(in, in) = out is semidet. :- mode make_type(out, out) = in is cc_multi. % det_make_type(TypeCtor, TypeArgs): % % Returns the type formed by applying the specified type % constructor to the specified argument types. Aborts if the % length of `TypeArgs' is not the same as the arity of `TypeCtor'. % :- func det_make_type(type_desc__type_ctor_desc, list(type_desc__type_desc)) = type_desc__type_desc. :- mode det_make_type(in, in) = out is det. %-----------------------------------------------------------------------------% % num_functors(TypeInfo) % % Returns the number of different functors for the top-level % type constructor of the type specified by TypeInfo, or -1 % if the type is not a discriminated union type. % % The functors of a discriminated union type are numbered from % zero to N-1, where N is the value returned by num_functors. % The functors are numbered in lexicographic order. If two % functors have the same name, the one with the lower arity % will have the lower number. % :- func num_functors(type_desc__type_desc) = int. % get_functor(Type, FunctorNumber, FunctorName, Arity, ArgTypes) % % Binds FunctorName and Arity to the name and arity of functor number % FunctorNumber for the specified type, and binds ArgTypes to the % type_descs for the types of the arguments of that functor. % Fails if the type is not a discriminated union type, or if % FunctorNumber is out of range. % :- pred get_functor(type_desc__type_desc::in, int::in, string::out, int::out, list(type_desc__type_desc)::out) is semidet. % get_functor(Type, FunctorNumber, FunctorName, Arity, ArgTypes, % ArgNames) % % Binds FunctorName and Arity to the name and arity of functor number % FunctorNumber for the specified type, ArgTypes to the type_descs % for the types of the arguments of that functor, and ArgNames to the % field name of each functor argument, if any. Fails if the type is % not a discriminated union type, or if FunctorNumber is out of range. % :- pred get_functor(type_desc__type_desc::in, int::in, string::out, int::out, list(type_desc__type_desc)::out, list(maybe(string))::out) is semidet. % get_functor_ordinal(Type, I, Ordinal) % % Returns Ordinal, where Ordinal is the position in declaration order % for the specified type of the function symbol that is in position I % in lexicographic order. Fails if the type is not a discriminated % union type, or if I is out of range. :- pred get_functor_ordinal(type_desc__type_desc::in, int::in, int::out) is semidet. % construct(TypeInfo, I, Args) = Term % % Returns a term of the type specified by TypeInfo whose functor % is functor number I of the type given by TypeInfo, and whose % arguments are given by Args. Fails if the type is not a % discriminated union type, or if I is out of range, or if the % number of arguments supplied doesn't match the arity of the selected % functor, or if the types of the arguments do not match % the expected argument types of that functor. % :- func construct(type_desc__type_desc, int, list(univ)) = univ. :- mode construct(in, in, in) = out is semidet. % construct_tuple(Args) = Term % % Returns a tuple whose arguments are given by Args. :- func construct_tuple(list(univ)) = univ. %-----------------------------------------------------------------------------% :- type maybe_arg ---> some [T] arg(T) ; no_arg. % functor, argument and deconstruct and their variants take any type % (including univ), and return representation information for that type. % % The string representation of the functor that these predicates % return is: % % - for user defined types, the functor that is given % in the type definition. For lists, this % means the functors [|]/2 and []/0 are used, even if % the list uses the [....] shorthand. % - for integers, the string is a base 10 number, % positive integers have no sign. % - for floats, the string is a floating point, % base 10 number, positive floating point numbers have % no sign. % - for strings, the string, inside double quotation marks % - for characters, the character inside single quotation marks % - for predicates, the string <> % - for functions, the string <> % - for tuples, the string {} % - for arrays, the string <> % % The arity that these predicates return is: % % - for user defined types, the arity of the functor. % - for integers, zero. % - for floats, zero. % - for strings, zero. % - for characters, zero. % - for predicates and functions, zero; we do not return the % number of arguments expected by the predicate or function. % - for tuples, the number of elements in the tuple. % - for arrays, the number of elements in the array. % functor(Data, Functor, Arity) % % Given a data item (Data), binds Functor to a string % representation of the functor and Arity to the arity of this % data item. (Aborts if the type of Data is a type with a % non-canonical representation, i.e. one for which there is a % user-defined equality predicate.) % % Functor_cc succeeds even if the first argument is of a % non-canonical type. % :- pred functor(T::in, string::out, int::out) is det. :- pred functor_cc(T::in, string::out, int::out) is cc_multi. % arg(Data, ArgumentIndex) = Argument % argument(Data, ArgumentIndex) = ArgumentUniv % % Given a data item (Data) and an argument index % (ArgumentIndex), starting at 0 for the first argument, binds % Argument to that argument of the functor of the data item. If % the argument index is out of range -- that is, greater than or % equal to the arity of the functor or lower than 0 -- then % the call fails. For argument/2 the argument returned has the % type univ, which can store any type. For arg/2, if the % argument has the wrong type, then the call fails. % (Both abort if the type of Data is a type with a non-canonical % representation, i.e. one for which there is a user-defined % equality predicate.) % % arg_cc and argument_cc succeed even if the first argument is % of a non-canonical type. They both encode the possible % non-existence of an argument at the requested location by using % a maybe type. % :- func arg(T::in, int::in) = (ArgT::out) is semidet. :- pred arg_cc(T::in, int::in, maybe_arg::out) is cc_multi. :- func argument(T::in, int::in) = (univ::out) is semidet. :- pred argument_cc(T::in, int::in, maybe(univ)::out) is cc_multi. % named_argument(Data, ArgumentName) = ArgumentUniv % % Same as argument/2, except the chosen argument is specified by giving % its name rather than its position. If Data has no argument with that % name, named_argument fails. % % named_argument_cc succeeds even if the first argument is % of a non-canonical type. % :- func named_argument(T::in, string::in) = (univ::out) is semidet. :- pred named_argument_cc(T::in, string::in, maybe(univ)::out) is cc_multi. % det_arg(Data, ArgumentIndex) = Argument % det_argument(Data, ArgumentIndex) = ArgumentUniv % % Same as arg/2 and argument/2 respectively, except that % for cases where arg/2 or argument/2 would fail, % det_arg/2 or det_argument/2 will abort. % % det_arg_cc and det_argument_cc succeed even if the first argument is % of a non-canonical type. % :- func det_arg(T::in, int::in) = (ArgT::out) is det. :- pred det_arg_cc(T::in, int::in, ArgT::out) is cc_multi. :- func det_argument(T::in, int::in) = (univ::out) is det. :- pred det_argument_cc(T::in, int::in, univ::out) is cc_multi. % det_named_argument(Data, ArgumentName) = ArgumentUniv % % Same as named_argument/2, except that for cases where % named_argument/2 would fail, det_named_argument/2 will abort. % :- func det_named_argument(T::in, string::in) = (univ::out) is det. :- pred det_named_argument_cc(T::in, string::in, univ::out) is cc_multi. % deconstruct(Data, Functor, Arity, Arguments) % % Given a data item (Data), binds Functor to a string % representation of the functor, Arity to the arity of this data % item, and Arguments to a list of arguments of the functor. % The arguments in the list are each of type univ. % (Aborts if the type of Data is a type with a non-canonical % representation, i.e. one for which there is a user-defined % equality predicate.) % % The cost of calling deconstruct depends greatly on how many arguments % Data has. If Data is an array, then each element of the array is % considered one of its arguments. Therefore calling deconstruct % on large arrays can take a very large amount of memory and a very % long time. If you call deconstruct in a situation in which you may % pass it a large array, you should probably use limited_deconstruct % instead. % % deconstruct_cc succeeds even if the first argument is % of a non-canonical type. % :- pred deconstruct(T::in, string::out, int::out, list(univ)::out) is det. :- pred deconstruct_cc(T::in, string::out, int::out, list(univ)::out) is cc_multi. % limited_deconstruct(Data, MaxArity, Functor, Arity, Arguments) % % limited_deconstruct works like deconstruct, but if the arity of T is % greater than MaxArity, limited_deconstruct fails. This is useful in % avoiding bad performance in cases where Data may be a large array. % % limited_deconstruct_cc succeeds even if the first argument is % of a non-canonical type. limited_deconstruct_cc encodes the % possible failure of the predicate by using a maybe type. % :- pred limited_deconstruct(T::in, int::in, string::out, int::out, list(univ)::out) is semidet. :- pred limited_deconstruct_cc(T::in, int::in, maybe({string, int, list(univ)})::out) is cc_multi. %-----------------------------------------------------------------------------% :- implementation. :- interface. % The rest of the interface is for use by implementors only. % dynamic_cast(X, Y) succeeds with Y = X iff X has the same % ground type as Y (so this may succeed if Y is of type % list(int), say, but not if Y is of type list(T)). % :- pred dynamic_cast(T1::in, T2::out) is semidet. %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- implementation. :- import_module require, set, int, string, bool. :- import_module construct, deconstruct. :- use_module private_builtin. % for the `heap_pointer' type. % XXX This should not be necessary, but the current compiler is broken in that % it puts foreign_proc clauses into deconstruct.opt without also putting the % foreign_decl they require into deconstruct.opt as well. :- pragma foreign_decl("C", " #include ""mercury_deconstruct.h"" #include ""mercury_deconstruct_macros.h"" "). %-----------------------------------------------------------------------------% map_maybe(_, no, no). map_maybe(P, yes(T0), yes(T)) :- P(T0, T). map_maybe(_, no) = no. map_maybe(F, yes(T)) = yes(F(T)). fold_maybe(P, yes(Value), Acc0, Acc) :- P(Value, Acc0, Acc). fold_maybe(_, no, Acc, Acc). fold_maybe(F, yes(Value), Acc0) = F(Value, Acc0). fold_maybe(_, no, Acc) = Acc. map_fold_maybe(_, no, no, Acc, Acc). map_fold_maybe(P, yes(T0), yes(T), Acc0, Acc) :- P(T0, T, Acc0, Acc). map_fold2_maybe(_, no, no, A, A, B, B). map_fold2_maybe(P, yes(T0), yes(T), A0, A, B0, B) :- P(T0, T, A0, A, B0, B). /**** Is this really useful? % for use in lambda expressions where the type of functor '-' is ambiguous :- pred pair(X, Y, pair(X, Y)). :- mode pair(in, in, out) is det. :- mode pair(out, out, in) is det. pair(X, Y, X-Y). ****/ fst(X-_Y) = X. fst(P,X) :- X = fst(P). snd(_X-Y) = Y. snd(P,X) :- X = snd(P). maybe_pred(Pred, X, Y) :- ( call(Pred, X, Z) -> Y = yes(Z) ; Y = no ). %-----------------------------------------------------------------------------% /* ** This section defines builtin_aggregate/4 which takes a closure of type ** pred(T) in which the remaining argument is output, and backtracks over ** solutions for this, using the second argument to aggregate them however the ** user wishes. This is basically a generalization of solutions/2. */ :- pred builtin_aggregate(pred(T), pred(T, U, U), U, U). :- mode builtin_aggregate(pred(out) is multi, pred(in, in, out) is det, in, out) is det. /* really cc_multi */ :- mode builtin_aggregate(pred(out) is multi, pred(in, di, uo) is det, di, uo) is det. /* really cc_multi */ :- mode builtin_aggregate(pred(out) is multi, pred(in, di, uo) is cc_multi, di, uo) is det. /* really cc_multi */ :- mode builtin_aggregate(pred(muo) is multi, pred(mdi, di, uo) is det, di, uo) is det. /* really cc_multi */ :- mode builtin_aggregate(pred(out) is nondet, pred(in, di, uo) is det, di, uo) is det. /* really cc_multi */ :- mode builtin_aggregate(pred(out) is nondet, pred(in, di, uo) is cc_multi, di, uo) is det. /* really cc_multi */ :- mode builtin_aggregate(pred(out) is nondet, pred(in, in, out) is det, in, out) is det. /* really cc_multi */ :- mode builtin_aggregate(pred(muo) is nondet, pred(mdi, di, uo) is det, di, uo) is det. /* really cc_multi */ /* ** If we're doing heap reclamation on failure, then ** in order to implement any sort of code that requires terms to survive ** backtracking, we need to (deeply) copy them out of the heap and into some ** other area before backtracking. The obvious thing to do then is just call ** the generator predicate, let it run to completion, and copy its result into ** another memory area (call it the solutions heap) before forcing ** backtracking. When we get the next solution, we do the same, this time ** passing the previous collection (which is still on the solutions heap) to ** the collector predicate. If the result of this operation contains the old ** collection as a part, then the deep copy operation is smart enough ** not to copy again. So this could be pretty efficient. ** ** But what if the collector predicate does something that copies the previous ** collection? Then on each solution, we'll copy the previous collection to ** the heap, and then deep copy it back to the solution heap. This means ** copying solutions order N**2 times, where N is the number of solutions. So ** this isn't as efficient as we hoped. ** ** So we use a slightly different approach. When we find a solution, we deep ** copy it to the solution heap. Then, before calling the collector code, we ** sneakily swap the runtime system's notion of which is the heap and which is ** the solutions heap. This ensures that any terms are constructed on the ** solutions heap. When this is complete, we swap them back, and force the ** engine to backtrack to get the next solution. And so on. After we've ** gotten the last solution, we do another deep copy to move the solution back ** to the 'real' heap, and reset the solutions heap pointer (which of course ** reclaims all the garbage of the collection process). ** ** Note that this will work with recursive calls to builtin_aggregate as ** well. If the recursive invocation occurs in the generator pred, there can ** be no problem because by the time the generator succeeds, the inner ** do_ call will have completed, copied its result from the solutions heap, ** and reset the solutions heap pointer. If the recursive invocation happens ** in the collector pred, then it will happen when the heap and solutions heap ** are 'swapped.' This will work out fine, because the real heap isn't needed ** while the collector pred is executing, and by the time the nested do_ is ** completed, the 'real' heap pointer will have been reset. ** ** If the collector predicate throws an exception while they are swapped, ** then the code for builtin_throw/1 will unswap the heaps. ** So we don't need to create our own exception handlers to here to ** cover that case. ** ** If we're not doing heap reclamation on failure (as is currently the ** case when using conservative GC), then all of the heap-swapping ** and copying operations are no-ops, so we get a "zero-copy" solution. */ % Note that the code for builtin_aggregate is very similar to the code % for do_while (below). :- pragma promise_pure(builtin_aggregate/4). builtin_aggregate(GeneratorPred, CollectorPred, Accumulator0, Accumulator) :- % Save some of the Mercury virtual machine registers impure get_registers(HeapPtr, SolutionsHeapPtr, TrailPtr), % Initialize the accumulator % /* Mutvar := Accumulator0 */ impure new_mutvar(Accumulator0, Mutvar), ( % Get a solution GeneratorPred(Answer0), % Check that the generator didn't leave any % delayed goals outstanding impure check_for_floundering(TrailPtr), % Update the accumulator % /* MutVar := CollectorPred(MutVar) */ impure swap_heap_and_solutions_heap, impure partial_deep_copy(HeapPtr, Answer0, Answer), impure get_mutvar(Mutvar, Acc0), impure non_cc_call(CollectorPred, Answer, Acc0, Acc1), impure set_mutvar(Mutvar, Acc1), impure swap_heap_and_solutions_heap, % Force backtracking, so that we get the next solution. % This will automatically reset the heap and trail. fail ; % There are no more solutions. % So now we just need to copy the final value % of the accumulator from the solutions heap % back onto the ordinary heap, and then we can % reset the solutions heap pointer. % We also need to discard the trail ticket % created by get_registers/3. % /* Accumulator := MutVar */ impure get_mutvar(Mutvar, Accumulator1), impure partial_deep_copy(SolutionsHeapPtr, Accumulator1, Accumulator), impure reset_solutions_heap(SolutionsHeapPtr), impure discard_trail_ticket ). % The code for do_while/4 is essentially the same as the code for % builtin_aggregate (above). See the detailed comments above. % % XXX It would be nice to avoid the code duplication here, % but it is a bit tricky -- we can't just use a lambda expression, % because we'd need to specify the mode, but we want it to work % for multiple modes. An alternative would be to use a typeclass, % but typeclasses still don't work in `jump' or `fast' grades. :- pragma promise_pure(do_while/4). do_while(GeneratorPred, CollectorPred, Accumulator0, Accumulator) :- impure get_registers(HeapPtr, SolutionsHeapPtr, TrailPtr), impure new_mutvar(Accumulator0, Mutvar), ( GeneratorPred(Answer0), impure check_for_floundering(TrailPtr), impure swap_heap_and_solutions_heap, impure partial_deep_copy(HeapPtr, Answer0, Answer), impure get_mutvar(Mutvar, Acc0), impure non_cc_call(CollectorPred, Answer, More, Acc0, Acc1), impure set_mutvar(Mutvar, Acc1), impure swap_heap_and_solutions_heap, % if More = yes, then backtrack for the next solution. % if More = no, then we're done. More = no ; true ), impure get_mutvar(Mutvar, Accumulator1), impure partial_deep_copy(SolutionsHeapPtr, Accumulator1, Accumulator), impure reset_solutions_heap(SolutionsHeapPtr), impure discard_trail_ticket. % This is the same as call/4, except that it is not cc_multi % even when the called predicate is cc_multi. :- impure pred non_cc_call(pred(T, Acc, Acc), T, Acc, Acc). :- mode non_cc_call(pred(in, in, out) is det, in, in, out) is det. :- mode non_cc_call(pred(in, di, uo) is det, in, di, uo) is det. :- mode non_cc_call(pred(in, di, uo) is cc_multi, in, di, uo) is det. :- mode non_cc_call(pred(mdi, di, uo) is det, mdi, di, uo) is det. non_cc_call(P::pred(in, in, out) is det, X::in, Acc0::in, Acc::out) :- P(X, Acc0, Acc). non_cc_call(P::pred(in, di, uo) is cc_multi, X::in, Acc0::di, Acc::uo) :- impure builtin__get_one_solution_io( (pred({}::out, di, uo) is cc_multi --> P(X)), _, Acc0, Acc). non_cc_call(P::pred(in, di, uo) is det, X::in, Acc0::di, Acc::uo) :- P(X, Acc0, Acc). non_cc_call(P::pred(mdi, di, uo) is det, X::mdi, Acc0::di, Acc::uo) :- P(X, Acc0, Acc). % This is the same as call/5, except that it is not cc_multi % even when the called predicate is cc_multi. :- impure pred non_cc_call(pred(T1, T2, Acc, Acc), T1, T2, Acc, Acc). :- mode non_cc_call(pred(in, out, in, out) is det, in, out, in, out) is det. :- mode non_cc_call(pred(in, out, di, uo) is det, in, out, di, uo) is det. :- mode non_cc_call(pred(in, out, di, uo) is cc_multi, in, out, di, uo) is det. non_cc_call(P::pred(in, out, di, uo) is det, X::in, More::out, Acc0::di, Acc::uo) :- P(X, More, Acc0, Acc). non_cc_call(P::pred(in, out, in, out) is det, X::in, More::out, Acc0::in, Acc::out) :- P(X, More, Acc0, Acc). non_cc_call(P::pred(in, out, di, uo) is cc_multi, X::in, More::out, Acc0::di, Acc::uo) :- impure builtin__get_one_solution_io( (pred(M::out, di, uo) is cc_multi --> P(X, M)), More, Acc0, Acc). :- type heap_ptr == private_builtin__heap_pointer. :- type trail_ptr ---> trail_ptr(c_pointer). % % Save the state of the Mercury heap and trail registers, % for later use in partial_deep_copy/3 and reset_solutions_heap/1. % Note that this allocates a trail ticket; % you need to dispose of it properly when you're finished with it, % e.g. by calling discard_trail_ticket/0. % :- impure pred get_registers(heap_ptr::out, heap_ptr::out, trail_ptr::out) is det. :- pragma foreign_proc("C", get_registers(HeapPtr::out, SolutionsHeapPtr::out, TrailPtr::out), [will_not_call_mercury, thread_safe], " /* save heap states */ #ifdef MR_RECLAIM_HP_ON_FAILURE HeapPtr = (MR_Word) MR_hp; SolutionsHeapPtr = (MR_Word) MR_sol_hp; #else HeapPtr = SolutionsHeapPtr = 0; #endif /* save trail state */ #ifdef MR_USE_TRAIL MR_store_ticket(TrailPtr); #else TrailPtr = 0; #endif "). :- pragma foreign_proc("C#", get_registers(HeapPtr::out, SolutionsHeapPtr::out, TrailPtr::out), [will_not_call_mercury, thread_safe], " /* ** For .NET we always use the MS garbage collector, ** so we don't have to worry here about heap reclamation on failure. */ HeapPtr = null; SolutionsHeapPtr = null; #if MR_USE_TRAIL /* XXX trailing not yet implemented for the MLDS back-end */ mercury.runtime.Errors.SORRY(""foreign code for get_registers""); #else TrailPtr = null; #endif "). :- pragma foreign_proc("Java", get_registers(HeapPtr::out, SolutionsHeapPtr::out, TrailPtr::out), [will_not_call_mercury, thread_safe], " /* ** Java has a builtin garbage collector, ** so we don't have to worry here about heap reclamation on failure. */ HeapPtr = null; SolutionsHeapPtr = null; /* XXX No trailing for the Java back-end. */ TrailPtr = null; "). :- impure pred check_for_floundering(trail_ptr::in) is det. :- pragma foreign_proc("C", check_for_floundering(TrailPtr::in), [will_not_call_mercury, thread_safe], " #ifdef MR_USE_TRAIL /* check for outstanding delayed goals (``floundering'') */ MR_reset_ticket(TrailPtr, MR_solve); #endif "). :- pragma foreign_proc("C#", check_for_floundering(_TrailPtr::in), [will_not_call_mercury, thread_safe], " #if MR_USE_TRAIL mercury.runtime.Errors.SORRY( ""foreign code for check_for_floundering""); #endif "). :- pragma foreign_proc("Java", check_for_floundering(_TrailPtr::in), [will_not_call_mercury, thread_safe], " /* XXX No trailing for the Java back-end, so take no action. */ "). % % Discard the topmost trail ticket. % :- impure pred discard_trail_ticket is det. :- pragma foreign_proc("C", discard_trail_ticket, [will_not_call_mercury, thread_safe], " #ifdef MR_USE_TRAIL MR_discard_ticket(); #endif "). :- pragma foreign_proc("C#", discard_trail_ticket, [will_not_call_mercury, thread_safe], " #if MR_USE_TRAIL mercury.runtime.Errors.SORRY( ""foreign code for discard_trail_ticket""); #endif "). :- pragma foreign_proc("Java", discard_trail_ticket, [will_not_call_mercury, thread_safe], " /* XXX No trailing for the Java back-end, so take no action. */ "). % % Swap the heap with the solutions heap % :- impure pred swap_heap_and_solutions_heap is det. :- pragma foreign_proc("C", swap_heap_and_solutions_heap, [will_not_call_mercury, thread_safe], "{ #ifdef MR_RECLAIM_HP_ON_FAILURE MR_MemoryZone *temp_zone; MR_Word *temp_hp; temp_zone = MR_ENGINE(MR_eng_heap_zone); MR_ENGINE(MR_eng_heap_zone) = MR_ENGINE(MR_eng_solutions_heap_zone); MR_ENGINE(MR_eng_solutions_heap_zone) = temp_zone; temp_hp = MR_hp; MR_hp = MR_sol_hp; MR_sol_hp = temp_hp; #endif }"). :- pragma foreign_proc("C#", swap_heap_and_solutions_heap, [will_not_call_mercury, thread_safe], " // // For the .NET back-end, we use the system heap, rather // than defining our own heaps. So we don't need to // worry about swapping them. Hence do nothing here. // "). :- pragma foreign_proc("Java", swap_heap_and_solutions_heap, [will_not_call_mercury, thread_safe], " /* ** For the Java back-end, as for the .NET back-end, we don't define ** our own heaps. So take no action here. */ "). % % partial_deep_copy(SolutionsHeapPtr, OldVal, NewVal): % Make a copy of all of the parts of OldVar that occur between % SolutionsHeapPtr and the top of the current solutions heap. % :- impure pred partial_deep_copy(heap_ptr, T, T) is det. :- mode partial_deep_copy(in, di, uo) is det. :- mode partial_deep_copy(in, mdi, muo) is det. :- mode partial_deep_copy(in, in, out) is det. :- pragma foreign_decl("C", " #include ""mercury_deep_copy.h"" #ifndef MR_RECLAIM_HP_ON_FAILURE /* for conservative GC, shallow copies suffice */ #define MR_PARTIAL_DEEP_COPY(SolutionsHeapPtr, \\ OldVar, NewVal, TypeInfo_for_T) \\ do { \\ NewVal = OldVal; \\ } while (0) #else /* ** Note that we need to save/restore the MR_hp register, if it ** is transient, before/after calling MR_deep_copy(). */ #define MR_PARTIAL_DEEP_COPY(SolutionsHeapPtr, \\ OldVar, NewVal, TypeInfo_for_T) \\ do { \\ MR_save_transient_hp(); \\ NewVal = MR_deep_copy(OldVal, (MR_TypeInfo) TypeInfo_for_T,\\ (const MR_Word *) SolutionsHeapPtr, \\ MR_ENGINE(MR_eng_solutions_heap_zone)->top); \\ MR_restore_transient_hp(); \\ } while (0) #endif "). :- pragma foreign_proc("C", partial_deep_copy(SolutionsHeapPtr::in, OldVal::in, NewVal::out), [will_not_call_mercury, thread_safe, promise_pure], " MR_PARTIAL_DEEP_COPY(SolutionsHeapPtr, OldVal, NewVal, TypeInfo_for_T); "). :- pragma foreign_proc("C", partial_deep_copy(SolutionsHeapPtr::in, OldVal::mdi, NewVal::muo), [will_not_call_mercury, thread_safe, promise_pure], " MR_PARTIAL_DEEP_COPY(SolutionsHeapPtr, OldVal, NewVal, TypeInfo_for_T); "). :- pragma foreign_proc("C", partial_deep_copy(SolutionsHeapPtr::in, OldVal::di, NewVal::uo), [will_not_call_mercury, thread_safe, promise_pure], " MR_PARTIAL_DEEP_COPY(SolutionsHeapPtr, OldVal, NewVal, TypeInfo_for_T); "). :- pragma foreign_proc("C#", partial_deep_copy(_SolutionsHeapPtr::in, OldVal::in, NewVal::out), [will_not_call_mercury, thread_safe, promise_pure], " // // For the IL back-end, we don't do heap reclamation on failure, // so we don't need to worry about making deep copies here. // Shallow copies will suffice. // NewVal = OldVal; "). :- pragma foreign_proc("C#", partial_deep_copy(_SolutionsHeapPtr::in, OldVal::mdi, NewVal::muo), [will_not_call_mercury, thread_safe, promise_pure], " NewVal = OldVal; "). :- pragma foreign_proc("C#", partial_deep_copy(_SolutionsHeapPtr::in, OldVal::di, NewVal::uo), [will_not_call_mercury, thread_safe, promise_pure], " NewVal = OldVal; "). :- pragma foreign_proc("Java", partial_deep_copy(_SolutionsHeapPtr::in, OldVal::in, NewVal::out), [will_not_call_mercury, thread_safe, promise_pure], " /* ** For the Java back-end, as for the .NET implementation, ** we don't do heap reclamation on failure, ** so we don't need to worry about making deep copies here. ** Shallow copies will suffice. */ NewVal = OldVal; "). :- pragma foreign_proc("Java", partial_deep_copy(_SolutionsHeapPtr::in, OldVal::mdi, NewVal::muo), [will_not_call_mercury, thread_safe, promise_pure], " NewVal = OldVal; "). :- pragma foreign_proc("Java", partial_deep_copy(_SolutionsHeapPtr::in, OldVal::di, NewVal::uo), [will_not_call_mercury, thread_safe, promise_pure], " NewVal = OldVal; "). % % reset_solutions_heap(SolutionsHeapPtr): % Reset the solutions heap pointer to the specified value, % thus deallocating everything allocated on the solutions % heap since that value was obtained via get_registers/3. % :- impure pred reset_solutions_heap(heap_ptr::in) is det. :- pragma foreign_proc("C", reset_solutions_heap(SolutionsHeapPtr::in), [will_not_call_mercury, thread_safe], " #ifdef MR_RECLAIM_HP_ON_FAILURE MR_sol_hp = (MR_Word *) SolutionsHeapPtr; #endif "). :- pragma foreign_proc("C#", reset_solutions_heap(_SolutionsHeapPtr::in), [will_not_call_mercury, thread_safe], " // // For the IL back-end, we don't have a separate `solutions heap'. // Hence this operation is a NOP. // "). :- pragma foreign_proc("Java", reset_solutions_heap(_SolutionsHeapPtr::in), [will_not_call_mercury, thread_safe], " /* As above, we take no action. */ "). %-----------------------------------------------------------------------------% %%% :- module mutvar. %%% :- interface. % A non-backtrackably destructively modifiable reference type :- type mutvar(T). % Create a new mutvar given a term for it to reference. :- impure pred new_mutvar(T, mutvar(T)). :- mode new_mutvar(in, out) is det. :- mode new_mutvar(di, uo) is det. % Get the value currently referred to by a reference. :- impure pred get_mutvar(mutvar(T), T) is det. :- mode get_mutvar(in, uo) is det. % XXX this is a work-around /* XXX `ui' modes don't work yet :- mode get_mutvar(in, uo) is det. :- mode get_mutvar(ui, uo) is det. % unsafe, but we use it safely */ % destructively modify a reference to refer to a new object. :- impure pred set_mutvar(mutvar(T), T) is det. :- mode set_mutvar(in, in) is det. /* XXX `ui' modes don't work yet :- pred set_mutvar(ui, di) is det. */ %%% :- implementation. % This type is a builtin-in type whose operations are implemented in C. :- type mutvar(T) ---> mutvar(private_builtin.ref(T)). :- pragma inline(new_mutvar/2). :- pragma inline(get_mutvar/2). :- pragma inline(set_mutvar/2). :- pragma foreign_proc("C", new_mutvar(X::in, Ref::out), [will_not_call_mercury, thread_safe], " MR_offset_incr_hp_msg(Ref, MR_SIZE_SLOT_SIZE, MR_SIZE_SLOT_SIZE + 1, MR_PROC_LABEL, ""std_util:mutvar/1""); MR_define_size_slot(0, Ref, 1); * (MR_Word *) Ref = X; "). :- pragma foreign_proc("C", new_mutvar(X::di, Ref::uo), [will_not_call_mercury, thread_safe], " MR_offset_incr_hp_msg(Ref, MR_SIZE_SLOT_SIZE, MR_SIZE_SLOT_SIZE + 1, MR_PROC_LABEL, ""std_util:mutvar/1""); MR_define_size_slot(0, Ref, 1); * (MR_Word *) Ref = X; "). :- pragma foreign_proc("C", get_mutvar(Ref::in, X::uo), [will_not_call_mercury, thread_safe], " X = * (MR_Word *) Ref; "). :- pragma foreign_proc("C", set_mutvar(Ref::in, X::in), [will_not_call_mercury, thread_safe], " *(MR_Word *) Ref = X; "). :- pragma foreign_proc("C#", new_mutvar(X::in, Ref::out), [will_not_call_mercury, thread_safe], " Ref = new object[1]; Ref[0] = X; "). :- pragma foreign_proc("C#", new_mutvar(X::di, Ref::uo), [will_not_call_mercury, thread_safe], " Ref = new object[1]; Ref[0] = X; "). :- pragma foreign_proc("C#", get_mutvar(Ref::in, X::uo), [will_not_call_mercury, thread_safe], " X = Ref[0]; "). :- pragma foreign_proc("C#", set_mutvar(Ref::in, X::in), [will_not_call_mercury, thread_safe], " Ref[0] = X; "). :- pragma foreign_code("Java", " public static class Mutvar { public Object object; public Mutvar(Object init) { object = init; } } "). :- pragma foreign_type(java, mutvar(T), "mercury.std_util.Mutvar"). :- pragma foreign_proc("Java", new_mutvar(X::in, Ref::out), [will_not_call_mercury, thread_safe], " Ref = new mercury.std_util.Mutvar(X); "). :- pragma foreign_proc("Java", new_mutvar(X::di, Ref::uo), [will_not_call_mercury, thread_safe], " Ref = new mercury.std_util.Mutvar(X); "). :- pragma foreign_proc("Java", get_mutvar(Ref::in, X::uo), [will_not_call_mercury, thread_safe], " X = Ref.object; "). :- pragma foreign_proc("Java", set_mutvar(Ref::in, X::in), [will_not_call_mercury, thread_safe], " Ref.object = X; "). %%% end_module mutvar. %-----------------------------------------------------------------------------% solutions(Pred, List) :- builtin_solutions(Pred, UnsortedList), list__sort_and_remove_dups(UnsortedList, List). solutions_set(Pred, Set) :- builtin_solutions(Pred, List), set__list_to_set(List, Set). unsorted_solutions(Pred, List) :- builtin_solutions(Pred, UnsortedList), cc_multi_equal(UnsortedList, List). :- pred builtin_solutions(pred(T), list(T)). :- mode builtin_solutions(pred(out) is multi, out) is det. /* really cc_multi */ :- mode builtin_solutions(pred(out) is nondet, out) is det. /* really cc_multi */ builtin_solutions(Generator, UnsortedList) :- builtin_aggregate(Generator, cons, [], UnsortedList). :- pred cons(T::in, list(T)::in, list(T)::out) is det. cons(H, T, [H|T]). %-----------------------------------------------------------------------------% aggregate(Generator, Accumulator, Acc0, Acc) :- solutions(Generator, Solutions), list__foldl(Accumulator, Solutions, Acc0, Acc). aggregate2(Generator, Accumulator, Acc0, Acc) --> { solutions(Generator, Solutions) }, list__foldl2(Accumulator, Solutions, Acc0, Acc). unsorted_aggregate(Generator, Accumulator, Acc0, Acc) :- builtin_aggregate(Generator, Accumulator, Acc0, Acc1), cc_multi_equal(Acc1, Acc). %-----------------------------------------------------------------------------% % semidet_succeed and semidet_fail, implemented using the C interface % to make sure that the compiler doesn't issue any determinism warnings % for them. :- pragma foreign_proc("C", semidet_succeed, [will_not_call_mercury, thread_safe, promise_pure], "SUCCESS_INDICATOR = MR_TRUE;"). :- pragma foreign_proc("C", semidet_fail, [will_not_call_mercury, thread_safe, promise_pure], "SUCCESS_INDICATOR = MR_FALSE;"). :- pragma foreign_proc("C", cc_multi_equal(X::in, Y::out), [will_not_call_mercury, thread_safe, promise_pure], "Y = X;"). :- pragma foreign_proc("C", cc_multi_equal(X::di, Y::uo), [will_not_call_mercury, thread_safe, promise_pure], "Y = X;"). :- pragma foreign_proc("C#", semidet_succeed, [will_not_call_mercury, thread_safe, promise_pure], "SUCCESS_INDICATOR = true;"). :- pragma foreign_proc("C#", semidet_fail, [will_not_call_mercury, thread_safe, promise_pure], "SUCCESS_INDICATOR = false;"). :- pragma foreign_proc("C#", cc_multi_equal(X::in, Y::out), [will_not_call_mercury, thread_safe, promise_pure], "Y = X;"). :- pragma foreign_proc("C#", cc_multi_equal(X::di, Y::uo), [will_not_call_mercury, thread_safe, promise_pure], "Y = X;"). :- pragma foreign_proc("Java", cc_multi_equal(X::in, Y::out), [will_not_call_mercury, thread_safe, promise_pure], "Y = X;"). :- pragma foreign_proc("Java", cc_multi_equal(X::di, Y::uo), [will_not_call_mercury, thread_safe, promise_pure], "Y = X;"). % We can't just use "true" and "fail" here, because that provokes warnings % from determinism analysis, and the library is compiled with --halt-at-warn. % So instead we use 0+0 = (or \=) 0. % This is guaranteed to succeed or fail (respectively), % and with a bit of luck will even get optimized by constant propagation. % But this optimization won't happen until after determinism analysis, % which doesn't know anything about integer arithmetic, % so this code won't provide a warning from determinism analysis. semidet_succeed :- 0 + 0 = 0. semidet_fail :- 0 + 0 \= 0. :- pragma promise_pure(cc_multi_equal/2). cc_multi_equal(X, X). %-----------------------------------------------------------------------------% % We call the constructor for univs `univ_cons' to avoid ambiguity % with the univ/1 function which returns a univ. :- type univ ---> some [T] univ_cons(T). univ_to_type(Univ, X) :- type_to_univ(X, Univ). univ(X) = Univ :- type_to_univ(X, Univ). det_univ_to_type(Univ, X) :- ( type_to_univ(X0, Univ) -> X = X0 ; UnivTypeName = type_desc__type_name(univ_type(Univ)), ObjectTypeName = type_desc__type_name(type_desc__type_of(X)), string__append_list(["det_univ_to_type: conversion failed\\n", "\tUniv Type: ", UnivTypeName, "\\n\tObject Type: ", ObjectTypeName], ErrorString), error(ErrorString) ). univ_value(univ_cons(X)) = X. :- pragma promise_pure(type_to_univ/2). type_to_univ(T::di, Univ::uo) :- Univ0 = 'new univ_cons'(T), unsafe_promise_unique(Univ0, Univ). type_to_univ(T::in, Univ::out) :- Univ0 = 'new univ_cons'(T), unsafe_promise_unique(Univ0, Univ). type_to_univ(T::out, Univ::in) :- Univ = univ_cons(T0), private_builtin__typed_unify(T0, T). univ_type(Univ) = type_desc__type_of(univ_value(Univ)). :- pred construct_univ(T, univ). :- mode construct_univ(in, out) is det. :- pragma export(construct_univ(in, out), "ML_construct_univ"). construct_univ(X, Univ) :- Univ = univ(X). :- some [T] pred unravel_univ(univ, T). :- mode unravel_univ(in, out) is det. :- pragma export(unravel_univ(in, out), "ML_unravel_univ"). unravel_univ(Univ, X) :- univ_value(Univ) = X. dynamic_cast(X, Y) :- univ_to_type(univ(X), Y). %-----------------------------------------------------------------------------% % The actual code of these predicates and functions is now in % the file type_desc.m. type_of(Value) = type_desc__type_of(Value). has_type(Arg, TypeInfo) :- type_desc__has_type(Arg, TypeInfo). type_name(Type) = type_desc__type_name(Type). type_args(Type) = type_desc__type_args(Type). type_ctor_name(TypeCtor) = type_desc__type_ctor_name(TypeCtor). type_ctor_module_name(TypeCtor) = type_desc__type_ctor_module_name(TypeCtor). type_ctor_arity(TypeCtor) = type_desc__type_ctor_arity(TypeCtor). det_make_type(TypeCtor, ArgTypes) = type_desc__det_make_type(TypeCtor, ArgTypes). type_ctor(TypeInfo) = type_desc__type_ctor(TypeInfo). type_ctor_and_args(TypeDesc, TypeCtorDesc, ArgTypes) :- type_desc__type_ctor_and_args(TypeDesc, TypeCtorDesc, ArgTypes). make_type(TypeCtorDesc, ArgTypes) = type_desc__make_type(TypeCtorDesc, ArgTypes). type_ctor_name_and_arity(TypeCtorDesc, TypeCtorModuleName, TypeCtorName, TypeCtorArity) :- type_desc__type_ctor_name_and_arity(TypeCtorDesc, TypeCtorModuleName, TypeCtorName, TypeCtorArity). %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% % The actual code of these predicates and functions is now in % the file construct.m. num_functors(TypeInfo) = construct__num_functors(TypeInfo). get_functor(TypeDesc, FunctorNumber, FunctorName, Arity, TypeInfoList) :- construct__get_functor(TypeDesc, FunctorNumber, FunctorName, Arity, TypeInfoList). get_functor(TypeDesc, FunctorNumber, FunctorName, Arity, TypeInfoList, ArgNameList) :- construct__get_functor(TypeDesc, FunctorNumber, FunctorName, Arity, TypeInfoList, ArgNameList). get_functor_ordinal(TypeDesc, FunctorNumber, Ordinal) :- construct__get_functor_ordinal(TypeDesc, FunctorNumber, Ordinal). construct(TypeDesc, FunctorNumber, ArgList) = construct__construct(TypeDesc, FunctorNumber, ArgList). construct_tuple(Args) = construct__construct_tuple(Args). %-----------------------------------------------------------------------------% % The actual code of these predicates and functions is now in % the file deconstruct.m. functor(Term, Functor, Arity) :- deconstruct__functor(Term, canonicalize, Functor, Arity). functor_cc(Term, Functor, Arity) :- deconstruct__functor(Term, include_details_cc, Functor, Arity). arg(Term, Index) = Argument :- deconstruct__arg(Term, canonicalize, Index, Argument0), private_builtin__typed_unify(Argument0, Argument). arg_cc(Term, Index, Argument) :- deconstruct__arg_cc(Term, Index, Argument). argument(Term, Index) = ArgumentUniv :- deconstruct__arg(Term, canonicalize, Index, Argument), type_to_univ(Argument, ArgumentUniv). argument_cc(Term, Index, MaybeArgumentUniv) :- deconstruct__arg_cc(Term, Index, MaybeArgument), ( MaybeArgument = arg(Argument), type_to_univ(Argument, ArgumentUniv), MaybeArgumentUniv = yes(ArgumentUniv) ; MaybeArgument = no_arg, MaybeArgumentUniv = no ). named_argument(Term, Name) = ArgumentUniv :- deconstruct__named_arg(Term, canonicalize, Name, Argument), type_to_univ(Argument, ArgumentUniv). named_argument_cc(Term, Name, MaybeArgumentUniv) :- deconstruct__named_arg_cc(Term, Name, MaybeArgument), ( MaybeArgument = arg(Argument), type_to_univ(Argument, ArgumentUniv), MaybeArgumentUniv = yes(ArgumentUniv) ; MaybeArgument = no_arg, MaybeArgumentUniv = no ). deconstruct(Term, Functor, Arity, Arguments) :- deconstruct__deconstruct(Term, canonicalize, Functor, Arity, Arguments). deconstruct_cc(Term, Functor, Arity, Arguments) :- deconstruct__deconstruct(Term, include_details_cc, Functor, Arity, Arguments). limited_deconstruct(Term, MaxArity, Functor, Arity, Arguments) :- deconstruct__limited_deconstruct(Term, canonicalize, MaxArity, Functor, Arity, Arguments). limited_deconstruct_cc(Term, MaxArity, Result) :- deconstruct__limited_deconstruct_cc(Term, MaxArity, Result). det_arg(Type, Index) = Argument :- deconstruct__det_arg(Type, canonicalize, Index, Argument0), ( private_builtin__typed_unify(Argument0, Argument1) -> Argument = Argument1 ; error("det_arg: argument has wrong type") ). det_arg_cc(Type, Index, Argument) :- deconstruct__det_arg(Type, include_details_cc, Index, Argument0), ( private_builtin__typed_unify(Argument0, Argument1) -> Argument = Argument1 ; error("det_arg_cc: argument has wrong type") ). det_argument(Type, Index) = ArgumentUniv :- deconstruct__det_arg(Type, canonicalize, Index, Argument), type_to_univ(Argument, ArgumentUniv). det_argument_cc(Type, Index, ArgumentUniv) :- deconstruct__det_arg(Type, include_details_cc, Index, Argument), type_to_univ(Argument, ArgumentUniv). det_named_argument(Type, Name) = ArgumentUniv :- deconstruct__det_named_arg(Type, canonicalize, Name, Argument), type_to_univ(Argument, ArgumentUniv). det_named_argument_cc(Type, Name, ArgumentUniv) :- deconstruct__det_named_arg(Type, include_details_cc, Name, Argument), type_to_univ(Argument, ArgumentUniv). %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% % Ralph Becket 24/04/99 % Function forms added. pair(X, Y) = X-Y. maybe_func(PF, X) = ( if Y = PF(X) then yes(Y) else no ). compose(F, G, X) = F(G(X)). converse(F, X, Y) = F(Y, X). pow(F, N, X) = ( if N = 0 then X else pow(F, N - 1, F(X)) ). isnt(P, X) :- not P(X). id(X) = X. solutions(P) = S :- solutions(P, S). solutions_set(P) = S :- solutions_set(P, S). aggregate(P, F, Acc0) = Acc :- aggregate(P, (pred(X::in, A0::in, A::out) is det :- A = F(X, A0)), Acc0, Acc). %------------------------------------------------------------------------------% %------------------------------------------------------------------------------%