mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2026-04-15 17:33:38 +00:00
Code Issues Projects Releases Wiki Activity
Files
019ea41ec48b68191a91f65ea8a097a752275ade
mercury/library/rtti_implementation.m
Zoltan Somogyi 36e8833145 Add a new option, --warn-unused-types. 
When set, this option tells the compiler to generate warnings
about locally-defined types that are neither used in the module
nor exported to any other module.

compiler/options.m:
    Add the new option.

compiler/unused_types.m:
    New module to implement the new option.

compiler/mercury_compile_front_end.m:
    Invoke the new module, unless the presence of previous errors
    would make its warnings just a distraction.

compiler/check_hlds.m:
    Include the new module.

compiler/notes/compiler_design.html:
    Document the new module.

compiler/typecheck_error_wrong_type.m:
    Simplify some code.

browser/declarative_tree.m:
compiler/accumulator.m:
compiler/du_type_layout.m:
compiler/intermod.m:
compiler/mode_errors.m:
compiler/parse_inst_mode_defn.m:
compiler/polyhedron.m:
compiler/split_parse_tree_src.m:
compiler/tag_switch_util.m:
compiler/typecheck_error_unify.m:
compiler/unneeded_code.m:
deep_profiler/mdprof_test.m:
library/getopt.m:
library/getopt_io.m:
    Delete unused types reported by the new option.

library/rtti_implementation.m:
    Comment out unused type reported by the new option. This type was exported
    to both Java and C#, but this diff comments it out because neither language
    the Java or the C# runtime system seems to use the exported versions
    either. (Bootcheck in both java and csharp grades worked, with the
    same number of test case failures as before.) We do not delete it,
    because it may be useful in the future.

tests/warnings/help_text.err_exp:
    Expect the documentation of the new option.

tests/invalid_nodepend/Mmakefile:
    Specify --warn-unused-types for two test cases to test that the compiler
    does NOT generate warnings about unused types in the presence of previous
    errors.

tests/warnings/abstract_type_decl.err_exp:
tests/warnings/bug412.err_exp:
tests/warnings/warn_dead_procs.err_exp:
    Expect the new warnings for unused types.

tests/warnings/Mmakefile:
    Specify --warn-unused-types for the three test cases listed above.
2026-02-15 11:26:34 +11:00

5746 lines
192 KiB
Mathematica
Raw Blame History

%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 2001-2007, 2009-2011 The University of Melbourne.
% Copyright (C) 2014-2026 The Mercury team.
% This file is distributed under the terms specified in COPYING.LIB.
%---------------------------------------------------------------------------%
%
% File: rtti_implementation.m.
% Main author: trd, petdr, wangp.
% Stability: medium.
%
% This file is intended to provide portable RTTI functionality by implementing
% most of Mercury's RTTI functionality in Mercury.
%
% This is simpler than writing large amounts of low-level C code, and is much
% easier to maintain and port to new platforms.
%
% This module is not complete, the majority of the functionality is
% implemented, but the following still needs to be implemented
% * functionality required to support construct.construct
% * functionality required to support type_desc.type_ctor
% * currently we recognise RTTI for higher order types, however
% we don't interpret that RTTI fully.
%
% The plan is to migrate most of the Mercury level data structures in
% compiler/rtti.m here, and to interpret them, instead of relying on access
% to C level data structures.
%
% At least, that may have been the plan at some point. Currently this module
% is used for the Java and C# backends only.
%
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- module rtti_implementation.
:- interface.
:- import_module deconstruct.
:- import_module list.
:- import_module univ.
%---------------------------------------------------------------------------%
:- pred generic_unify(T::in, T::in) is semidet.
:- pred generic_compare(comparison_result::out, T::in, T::in) is det.
%---------------------------------------------------------------------------%
% Our type_info, pseudo_type_info and type_ctor_info implementations
% are all abstract types.
:- type type_info.
:- type type_ctor_info.
:- type pseudo_type_info.
%---------------------------------------------------------------------------%
%
% Operations on type_infos.
%
:- func get_type_info(T::unused) = (type_info::out) is det.
:- pred compare_type_infos(comparison_result::out,
type_info::in, type_info::in) is det.
:- func get_type_ctor_info(type_info) = type_ctor_info.
:- pred type_ctor_and_args(type_info::in, type_ctor_info::out,
list(type_info)::out) is det.
:- pred type_info_num_functors(type_info::in, int::out) is semidet.
:- pred type_info_get_functor(type_info::in, int::in, string::out, int::out,
list(pseudo_type_info)::out) is semidet.
:- pred type_info_get_functor_with_names(type_info::in, int::in, string::out,
int::out, list(pseudo_type_info)::out, list(string)::out) is semidet.
:- pred type_info_get_functor_ordinal(type_info::in, int::in, int::out)
is semidet.
:- pred type_info_get_functor_lex(type_info::in, int::in, int::out)
is semidet.
%---------------------------------------------------------------------------%
%
% Operations on type_ctor_infos.
%
:- pred type_ctor_name_and_arity(type_ctor_info::in,
string::out, string::out, int::out) is det.
%---------------------------------------------------------------------------%
%
% Operations on pseudo_type_infos.
%
:- pred pseudo_type_ctor_and_args(pseudo_type_info::in,
type_ctor_info::out, list(pseudo_type_info)::out) is semidet.
:- pred is_univ_pseudo_type_info(pseudo_type_info::in, int::out) is semidet.
:- pred is_exist_pseudo_type_info(pseudo_type_info::in, int::out) is semidet.
%---------------------------------------------------------------------------%
%
% Constructing terms.
%
:- func construct(type_info, int, list(univ)) = univ is semidet.
:- func construct_tuple_2(list(univ), list(type_info), int) = univ.
%---------------------------------------------------------------------------%
%
% Deconstructing terms.
%
:- pred deconstruct(T, noncanon_handling, string, int, int, list(univ)).
:- mode deconstruct(in, in(do_not_allow), out, out, out, out) is det.
:- mode deconstruct(in, in(canonicalize), out, out, out, out) is det.
:- mode deconstruct(in, in(include_details_cc), out, out, out, out)
is cc_multi.
:- mode deconstruct(in, in, out, out, out, out) is cc_multi.
:- pred functor_number_cc(T::in, int::out, int::out) is cc_nondet.
:- pred univ_named_arg(T, noncanon_handling, string, univ).
:- mode univ_named_arg(in, in(do_not_allow), in, out) is semidet.
:- mode univ_named_arg(in, in(canonicalize), in, out) is semidet.
:- mode univ_named_arg(in, in(include_details_cc), in, out)
is semidet. % conceptually committed-choice
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- implementation.
:- import_module array.
:- import_module bitmap.
:- import_module bool.
:- import_module char.
:- import_module int.
:- import_module int16.
:- import_module int32.
:- import_module maybe.
:- import_module require.
:- import_module string.
:- import_module term_io.
:- import_module type_desc.
%---------------------------------------------------------------------------%
% It is convenient to represent the type_ctor_rep as a Mercury
% enumeration, so we can switch on the values.
%
% The type_ctor_rep needs to be kept up to date with the real
% definition in runtime/mercury_type_info.h.
%
:- type type_ctor_rep
---> tcr_enum
; tcr_enum_usereq
; tcr_du
; tcr_du_usereq
; tcr_notag
; tcr_notag_usereq
; tcr_equiv
; tcr_func
; tcr_int
; tcr_uint
; tcr_char
; tcr_float
; tcr_string
; tcr_pred
; tcr_subgoal
; tcr_void
; tcr_c_pointer
; tcr_typeinfo
; tcr_typeclassinfo
; tcr_array
; tcr_succip
; tcr_hp
; tcr_curfr
; tcr_maxfr
; tcr_redofr
; tcr_redoip
; tcr_trail_ptr
; tcr_ticket
; tcr_notag_ground
; tcr_notag_ground_usereq
; tcr_equiv_ground
; tcr_tuple
; tcr_reserved_addr
; tcr_reserved_addr_usereq
; tcr_type_ctor_info
; tcr_base_typeclass_info
; tcr_type_desc
; tcr_type_ctor_desc
; tcr_foreign
; tcr_reference
; tcr_stable_c_pointer
; tcr_stable_foreign
; tcr_pseudo_type_desc
; tcr_dummy
; tcr_bitmap
; tcr_foreign_enum
; tcr_foreign_enum_usereq
; tcr_int8
; tcr_uint8
; tcr_int16
; tcr_uint16
; tcr_int32
; tcr_uint32
; tcr_int64
; tcr_uint64
; tcr_unknown.
% We keep all the other types abstract.
:- type type_ctor_info ---> type_ctor_info(c_pointer).
:- pragma foreign_type("C#", type_ctor_info,
"runtime.TypeCtorInfo_Struct").
:- pragma foreign_type("Java", type_ctor_info,
"jmercury.runtime.TypeCtorInfo_Struct").
:- type type_info ---> type_info(c_pointer).
:- pragma foreign_type("C#", type_info, "runtime.TypeInfo_Struct").
:- pragma foreign_type("Java", type_info, "jmercury.runtime.TypeInfo_Struct").
:- type type_layout ---> type_layout(c_pointer).
:- pragma foreign_type("C#", type_layout, "runtime.TypeLayout").
:- pragma foreign_type("Java", type_layout, "jmercury.runtime.TypeLayout").
:- type pseudo_type_info ---> pseudo_type_info(c_pointer).
:- pragma foreign_type("C#", pseudo_type_info,
"runtime.PseudoTypeInfo").
:- pragma foreign_type("Java", pseudo_type_info,
"jmercury.runtime.PseudoTypeInfo").
:- type typeclass_info ---> typeclass_info(c_pointer).
:- pragma foreign_type("C#", typeclass_info, "object[]").
:- pragma foreign_type("Java", typeclass_info, "java.lang.Object[]").
:- pragma foreign_decl("C#", local,
"
using mercury.runtime;
").
:- pragma foreign_decl("Java", local,
"
import java.lang.reflect.Constructor;
import java.lang.reflect.Field;
import java.lang.reflect.InvocationTargetException;
import jmercury.runtime.DuFunctorDesc;
import jmercury.runtime.EnumFunctorDesc;
import jmercury.runtime.ForeignEnumFunctorDesc;
import jmercury.runtime.PseudoTypeInfo;
import jmercury.runtime.Ref;
import jmercury.runtime.TypeCtorInfo_Struct;
import jmercury.runtime.TypeInfo_Struct;
").
:- pragma foreign_code("Java",
"
public static final Type_ctor_rep_0[] static_type_ctor_rep = new
Type_ctor_rep_0[jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_MAX];
static {
for (int i = 0;
i < jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_MAX;
i++)
{
static_type_ctor_rep[i] = new Type_ctor_rep_0(i);
}
}
").
%---------------------------------------------------------------------------%
generic_unify(X, Y) :-
TypeInfo = get_type_info(X),
TypeCtorInfo = get_type_ctor_info(TypeInfo),
TypeCtorRep = get_type_ctor_rep(TypeCtorInfo),
( if
TypeCtorRep = tcr_tuple
then
unify_tuple(TypeInfo, X, Y)
else if
( TypeCtorRep = tcr_pred ; TypeCtorRep = tcr_func )
then
unexpected($pred, "unimplemented: higher order unification")
else
Arity = TypeCtorInfo ^ type_ctor_arity,
UnifyPred = TypeCtorInfo ^ type_ctor_unify_pred,
( if Arity = 0 then
semidet_call_3(UnifyPred, X, Y)
else if Arity = 1 then
semidet_call_4(UnifyPred,
type_info_index_as_ti(TypeInfo, 1),
X, Y)
else if Arity = 2 then
semidet_call_5(UnifyPred,
type_info_index_as_ti(TypeInfo, 1),
type_info_index_as_ti(TypeInfo, 2),
X, Y)
else if Arity = 3 then
semidet_call_6(UnifyPred,
type_info_index_as_ti(TypeInfo, 1),
type_info_index_as_ti(TypeInfo, 2),
type_info_index_as_ti(TypeInfo, 3),
X, Y)
else if Arity = 4 then
semidet_call_7(UnifyPred,
type_info_index_as_ti(TypeInfo, 1),
type_info_index_as_ti(TypeInfo, 2),
type_info_index_as_ti(TypeInfo, 3),
type_info_index_as_ti(TypeInfo, 4),
X, Y)
else if Arity = 5 then
semidet_call_8(UnifyPred,
type_info_index_as_ti(TypeInfo, 1),
type_info_index_as_ti(TypeInfo, 2),
type_info_index_as_ti(TypeInfo, 3),
type_info_index_as_ti(TypeInfo, 4),
type_info_index_as_ti(TypeInfo, 5),
X, Y)
else
error("unify/2: type arity > 5 not supported")
)
).
generic_compare(Res, X, Y) :-
TypeInfo = get_type_info(X),
TypeCtorInfo = get_type_ctor_info(TypeInfo),
TypeCtorRep = get_type_ctor_rep(TypeCtorInfo),
( if
TypeCtorRep = tcr_tuple
then
compare_tuple(TypeInfo, Res, X, Y)
else if
( TypeCtorRep = tcr_pred ; TypeCtorRep = tcr_func )
then
unexpected($pred, "unimplemented: higher order comparisons")
else
Arity = TypeCtorInfo ^ type_ctor_arity,
ComparePred = TypeCtorInfo ^ type_ctor_compare_pred,
( if Arity = 0 then
result_call_4(ComparePred, Res, X, Y)
else if Arity = 1 then
result_call_5(ComparePred, Res,
type_info_index_as_ti(TypeInfo, 1), X, Y)
else if Arity = 2 then
result_call_6(ComparePred, Res,
type_info_index_as_ti(TypeInfo, 1),
type_info_index_as_ti(TypeInfo, 2),
X, Y)
else if Arity = 3 then
result_call_7(ComparePred, Res,
type_info_index_as_ti(TypeInfo, 1),
type_info_index_as_ti(TypeInfo, 2),
type_info_index_as_ti(TypeInfo, 3),
X, Y)
else if Arity = 4 then
result_call_8(ComparePred, Res,
type_info_index_as_ti(TypeInfo, 1),
type_info_index_as_ti(TypeInfo, 2),
type_info_index_as_ti(TypeInfo, 3),
type_info_index_as_ti(TypeInfo, 4),
X, Y)
else if Arity = 5 then
result_call_9(ComparePred, Res,
type_info_index_as_ti(TypeInfo, 1),
type_info_index_as_ti(TypeInfo, 2),
type_info_index_as_ti(TypeInfo, 3),
type_info_index_as_ti(TypeInfo, 4),
type_info_index_as_ti(TypeInfo, 5),
X, Y)
else
error("compare/3: type arity > 5 not supported")
)
).
%---------------------%
:- pred unify_tuple(type_info::in, T::in, T::in) is semidet.
unify_tuple(TypeInfo, TermA, TermB) :-
Arity = get_var_arity_typeinfo_arity(TypeInfo),
unify_tuple_pos(1, Arity, TypeInfo, TermA, TermB).
:- pred unify_tuple_pos(int::in, int::in, type_info::in, T::in, T::in)
is semidet.
unify_tuple_pos(Loc, TupleArity, TypeInfo, TermA, TermB) :-
( if Loc > TupleArity then
true
else
ArgTypeInfo = var_arity_type_info_index_as_ti(TypeInfo, Loc),
% XXX just count from 0
get_tuple_subterm(TermA, Loc - 1, ArgTypeInfo, SubTermA),
get_tuple_subterm(TermB, Loc - 1, ArgTypeInfo, SubTermB),
private_builtin.unsafe_type_cast(SubTermB, CastSubTermB),
generic_unify(SubTermA, CastSubTermB),
unify_tuple_pos(Loc + 1, TupleArity, TypeInfo, TermA, TermB)
).
%---------------------%
:- pred compare_tuple(type_info::in, comparison_result::out, T::in, T::in)
is det.
compare_tuple(TypeInfo, Result, TermA, TermB) :-
Arity = get_var_arity_typeinfo_arity(TypeInfo),
compare_tuple_pos(1, Arity, TypeInfo, Result, TermA, TermB).
:- pred compare_tuple_pos(int::in, int::in, type_info::in,
comparison_result::out, T::in, T::in) is det.
compare_tuple_pos(Loc, TupleArity, TypeInfo, Result, TermA, TermB) :-
( if Loc > TupleArity then
Result = (=)
else
ArgTypeInfo = var_arity_type_info_index_as_ti(TypeInfo, Loc),
% XXX just count from 0
get_tuple_subterm(TermA, Loc - 1, ArgTypeInfo, SubTermA),
get_tuple_subterm(TermB, Loc - 1, ArgTypeInfo, SubTermB),
private_builtin.unsafe_type_cast(SubTermB, CastSubTermB),
generic_compare(SubResult, SubTermA, CastSubTermB),
(
SubResult = (=),
compare_tuple_pos(Loc + 1, TupleArity, TypeInfo, Result,
TermA, TermB)
;
( SubResult = (<)
; SubResult = (>)
),
Result = SubResult
)
).
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- pragma foreign_proc("Java",
get_type_info(_T::unused) = (TypeInfo::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
TypeInfo = TypeInfo_for_T;
").
:- pragma foreign_proc("C#",
get_type_info(_T::unused) = (TypeInfo::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
TypeInfo = TypeInfo_for_T;
").
:- pragma foreign_proc("C",
get_type_info(_T::unused) = (TypeInfo::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
TypeInfo = TypeInfo_for_T;
").
get_type_info(_) = _ :-
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
private_builtin.sorry("get_type_info").
%---------------------------------------------------------------------------%
:- pragma foreign_export("C#", compare_type_infos(out, in, in),
"ML_compare_type_infos").
:- pragma foreign_export("Java", compare_type_infos(out, in, in),
"ML_compare_type_infos").
compare_type_infos(Res, TypeInfo1, TypeInfo2) :-
( if same_pointer_value(TypeInfo1, TypeInfo2) then
Res = (=)
else
NewTypeInfo1 = collapse_equivalences(TypeInfo1),
NewTypeInfo2 = collapse_equivalences(TypeInfo2),
( if same_pointer_value(NewTypeInfo1, NewTypeInfo2) then
Res = (=)
else
compare_collapsed_type_infos(Res, NewTypeInfo1, NewTypeInfo2)
)
).
:- pred compare_collapsed_type_infos(comparison_result::out,
type_info::in, type_info::in) is det.
compare_collapsed_type_infos(Res, TypeInfo1, TypeInfo2) :-
TypeCtorInfo1 = get_type_ctor_info(TypeInfo1),
TypeCtorInfo2 = get_type_ctor_info(TypeInfo2),
% cf. MR_compare_type_info
compare(ModNameRes, TypeCtorInfo1 ^ type_ctor_module_name,
TypeCtorInfo2 ^ type_ctor_module_name),
(
ModNameRes = (=),
compare(NameRes, TypeCtorInfo1 ^ type_ctor_name,
TypeCtorInfo2 ^ type_ctor_name),
(
NameRes = (=),
( if type_ctor_is_variable_arity(TypeCtorInfo1) then
Arity1 = get_var_arity_typeinfo_arity(TypeInfo1),
Arity2 = get_var_arity_typeinfo_arity(TypeInfo2),
compare(ArityRes, Arity1, Arity2),
(
ArityRes = (=),
compare_var_arity_type_info_args(1, Arity1, Res,
TypeInfo1, TypeInfo2)
;
( ArityRes = (<)
; ArityRes = (>)
),
Res = ArityRes
)
else
Arity1 = type_ctor_arity(TypeCtorInfo1),
Arity2 = type_ctor_arity(TypeCtorInfo2),
compare(ArityRes, Arity1, Arity2),
(
ArityRes = (=),
compare_type_info_args(1, Arity1, Res,
TypeInfo1, TypeInfo2)
;
( ArityRes = (<)
; ArityRes = (>)
),
Res = ArityRes
)
)
;
( NameRes = (<)
; NameRes = (>)
),
Res = NameRes
)
;
( ModNameRes = (<)
; ModNameRes = (>)
),
Res = ModNameRes
).
:- pred compare_type_ctor_infos(comparison_result::out,
type_ctor_info::in, type_ctor_info::in) is det.
:- pragma foreign_export("C#", compare_type_ctor_infos(out, in, in),
"ML_compare_type_ctor_infos").
:- pragma foreign_export("Java", compare_type_ctor_infos(out, in, in),
"ML_compare_type_ctor_infos").
compare_type_ctor_infos(Res, TypeCtorInfo1, TypeCtorInfo2) :-
% cf. MR_compare_type_ctor_info
compare(ModNameRes,
TypeCtorInfo1 ^ type_ctor_module_name,
TypeCtorInfo2 ^ type_ctor_module_name),
(
ModNameRes = (=),
compare(NameRes,
TypeCtorInfo1 ^ type_ctor_name,
TypeCtorInfo2 ^ type_ctor_name),
(
NameRes = (=),
Arity1 = type_ctor_arity(TypeCtorInfo1),
Arity2 = type_ctor_arity(TypeCtorInfo2),
compare(Res, Arity1, Arity2)
;
( NameRes = (<)
; NameRes = (>)
),
Res = NameRes
)
;
( ModNameRes = (<)
; ModNameRes = (>)
),
Res = ModNameRes
).
:- pred compare_type_info_args(int::in, int::in, comparison_result::out,
type_info::in, type_info::in) is det.
compare_type_info_args(Loc, Arity, Result, TypeInfoA, TypeInfoB) :-
( if Loc > Arity then
Result = (=)
else
SubTypeInfoA = type_info_index_as_ti(TypeInfoA, Loc),
SubTypeInfoB = type_info_index_as_ti(TypeInfoB, Loc),
compare_collapsed_type_infos(SubResult, SubTypeInfoA, SubTypeInfoB),
(
SubResult = (=),
compare_type_info_args(Loc + 1, Arity, Result,
TypeInfoA, TypeInfoB)
;
( SubResult = (<)
; SubResult = (>)
),
Result = SubResult
)
).
:- pred compare_var_arity_type_info_args(int::in, int::in,
comparison_result::out, type_info::in, type_info::in) is det.
compare_var_arity_type_info_args(Loc, Arity, Result, TypeInfoA, TypeInfoB) :-
( if Loc > Arity then
Result = (=)
else
SubTypeInfoA = var_arity_type_info_index_as_ti(TypeInfoA, Loc),
SubTypeInfoB = var_arity_type_info_index_as_ti(TypeInfoB, Loc),
compare_collapsed_type_infos(SubResult, SubTypeInfoA, SubTypeInfoB),
(
SubResult = (=),
compare_var_arity_type_info_args(Loc + 1, Arity, Result,
TypeInfoA, TypeInfoB)
;
( SubResult = (<)
; SubResult = (>)
),
Result = SubResult
)
).
:- pred type_ctor_is_variable_arity(type_ctor_info::in) is semidet.
type_ctor_is_variable_arity(TypeCtorInfo) :-
TypeCtorRep = get_type_ctor_rep(TypeCtorInfo),
( TypeCtorRep = tcr_pred
; TypeCtorRep = tcr_func
; TypeCtorRep = tcr_tuple
).
:- pred compare_pseudo_type_infos(comparison_result::out,
pseudo_type_info::in, pseudo_type_info::in) is det.
:- pragma consider_used(pred(compare_pseudo_type_infos/3)).
:- pragma foreign_export("C#", compare_pseudo_type_infos(out, in, in),
"ML_compare_pseudo_type_infos").
:- pragma foreign_export("Java", compare_pseudo_type_infos(out, in, in),
"ML_compare_pseudo_type_infos").
compare_pseudo_type_infos(Res, PTI1, PTI2) :-
% Try to optimize a common case:
% If type_info addresses are equal, they must represent the same type.
( if same_pointer_value(PTI1, PTI2) then
Res = (=)
else
% Otherwise, we need to expand equivalence types, if any.
NewPTI1 = collapse_equivalences_pseudo(PTI1),
NewPTI2 = collapse_equivalences_pseudo(PTI2),
% Perhaps they are equal now...
( if same_pointer_value(NewPTI1, NewPTI2) then
Res = (=)
else
% Handle the comparison if either pseudo_type_info is a variable.
% Any non-variable is greater than a variable.
( if
pseudo_type_info_is_variable(NewPTI1, VarNum1),
pseudo_type_info_is_variable(NewPTI2, VarNum2)
then
compare(Res, VarNum1, VarNum2)
else if
pseudo_type_info_is_variable(NewPTI1, _)
then
Res = (<)
else if
pseudo_type_info_is_variable(NewPTI2, _)
then
Res = (>)
else if
% Otherwise find the type_ctor_infos, and compare those.
pseudo_type_ctor_and_args(NewPTI1, TypeCtorInfo1, Args1),
pseudo_type_ctor_and_args(NewPTI2, TypeCtorInfo2, Args2)
then
compare_type_ctor_infos(ResTCI, TypeCtorInfo1, TypeCtorInfo2),
(
ResTCI = (<),
Res = (<)
;
ResTCI = (>),
Res = (>)
;
ResTCI = (=),
list.length(Args1, NumArgs1),
list.length(Args2, NumArgs2),
compare(ResNumArgs, NumArgs1, NumArgs2),
(
ResNumArgs = (<),
Res = (<)
;
ResNumArgs = (>),
Res = (>)
;
ResNumArgs = (=),
compare_pseudo_type_info_args(Res, Args1, Args2)
)
)
else
unexpected($pred, "impossible pseudo_type_infos")
)
)
).
:- pred compare_pseudo_type_info_args(comparison_result::out,
list(pseudo_type_info)::in, list(pseudo_type_info)::in) is det.
compare_pseudo_type_info_args(Res, Args1, Args2) :-
(
Args1 = [],
Args2 = [],
Res = (=)
;
Args1 = [H1 | T1],
Args2 = [H2 | T2],
compare_pseudo_type_infos(ResPTI, H1, H2),
(
ResPTI = (<),
Res = (<)
;
ResPTI = (>),
Res = (>)
;
ResPTI = (=),
compare_pseudo_type_info_args(Res, T1, T2)
)
;
Args1 = [_ | _],
Args2 = [],
unexpected($pred, "argument list mismatch")
;
Args1 = [],
Args2 = [_ | _],
unexpected($pred, "argument list mismatch")
).
%---------------------------------------------------------------------------%
:- func collapse_equivalences(type_info) = type_info.
:- pragma foreign_export("C#", collapse_equivalences(in) = out,
"ML_collapse_equivalences").
:- pragma foreign_export("Java", collapse_equivalences(in) = out,
"ML_collapse_equivalences").
collapse_equivalences(TypeInfo) = NewTypeInfo :-
TypeCtorInfo = get_type_ctor_info(TypeInfo),
TypeCtorRep = get_type_ctor_rep(TypeCtorInfo),
( if
% Look past equivalences.
( TypeCtorRep = tcr_equiv_ground
; TypeCtorRep = tcr_equiv
)
then
TypeLayout = get_type_layout(TypeCtorInfo),
EquivTypeInfo = get_layout_equiv(TypeLayout),
NewTypeInfo = collapse_equivalences(EquivTypeInfo)
else
NewTypeInfo = TypeInfo
).
:- func collapse_equivalences_pseudo(pseudo_type_info) = pseudo_type_info.
collapse_equivalences_pseudo(PTI) = NewPTI :-
( if
pseudo_type_ctor_and_args(PTI, TypeCtorInfo, _Args),
TypeCtorRep = get_type_ctor_rep(TypeCtorInfo),
% Look past equivalences.
( TypeCtorRep = tcr_equiv_ground
; TypeCtorRep = tcr_equiv
)
then
TypeLayout = get_type_layout(TypeCtorInfo),
EquivTypeInfo = get_layout_equiv(TypeLayout),
NewPTI0 = create_pseudo_type_info(EquivTypeInfo, PTI),
NewPTI = collapse_equivalences_pseudo(NewPTI0)
else
NewPTI = PTI
).
:- func get_layout_equiv(type_layout) = type_info.
:- pragma no_determinism_warning(func(get_layout_equiv/1)).
:- pragma foreign_proc("C#",
get_layout_equiv(TypeLayout::in) = (TypeInfo::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
runtime.PseudoTypeInfo pti = TypeLayout.layout_equiv();
TypeInfo = runtime.TypeInfo_Struct.maybe_new(pti);
").
:- pragma foreign_proc("Java",
get_layout_equiv(TypeLayout::in) = (TypeInfo::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
jmercury.runtime.PseudoTypeInfo pti = TypeLayout.layout_equiv();
TypeInfo = jmercury.runtime.TypeInfo_Struct.maybe_new(pti);
").
get_layout_equiv(_) = _ :-
private_builtin.sorry("get_layout_equiv").
%---------------------------------------------------------------------------%
:- pragma foreign_proc("C#",
get_type_ctor_info(TypeInfo::in) = (TypeCtorInfo::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
TypeCtorInfo = TypeInfo.type_ctor;
").
:- pragma foreign_proc("Java",
get_type_ctor_info(TypeInfo::in) = (TypeCtorInfo::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
TypeCtorInfo = TypeInfo.type_ctor;
").
:- pragma foreign_proc("C",
get_type_ctor_info(TypeInfo::in) = (TypeCtorInfo::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
TypeCtorInfo = (MR_Word) MR_TYPEINFO_GET_TYPE_CTOR_INFO(
(MR_TypeInfo) TypeInfo);
").
get_type_ctor_info(_) = _ :-
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
private_builtin.sorry("get_type_ctor_info").
%---------------------------------------------------------------------------%
type_ctor_and_args(TypeInfo0, TypeCtorInfo, TypeArgs) :-
TypeInfo = collapse_equivalences(TypeInfo0),
TypeCtorInfo = get_type_ctor_info(TypeInfo),
( if type_ctor_is_variable_arity(TypeCtorInfo) then
Arity = get_var_arity_typeinfo_arity(TypeInfo),
TypeArgs = iterate(1, Arity, var_arity_type_info_index_as_ti(TypeInfo))
else
Arity = type_ctor_arity(TypeCtorInfo),
TypeArgs = iterate(1, Arity, type_info_index_as_ti(TypeInfo))
).
%---------------------------------------------------------------------------%
type_info_num_functors(TypeInfo, NumFunctors) :-
% See MR_get_num_functors in runtime/mercury_construct.c
TypeCtorInfo = get_type_ctor_info(TypeInfo),
TypeCtorRep = get_type_ctor_rep(TypeCtorInfo),
require_complete_switch [TypeCtorRep]
(
( TypeCtorRep = tcr_du
; TypeCtorRep = tcr_du_usereq
; TypeCtorRep = tcr_reserved_addr
; TypeCtorRep = tcr_reserved_addr_usereq
; TypeCtorRep = tcr_enum
; TypeCtorRep = tcr_enum_usereq
; TypeCtorRep = tcr_foreign_enum
; TypeCtorRep = tcr_foreign_enum_usereq
),
NumFunctors = TypeCtorInfo ^ type_ctor_num_functors
;
( TypeCtorRep = tcr_dummy
; TypeCtorRep = tcr_notag
; TypeCtorRep = tcr_notag_usereq
; TypeCtorRep = tcr_notag_ground
; TypeCtorRep = tcr_notag_ground_usereq
; TypeCtorRep = tcr_tuple
),
NumFunctors = 1
;
( TypeCtorRep = tcr_equiv_ground
; TypeCtorRep = tcr_equiv
),
NewTypeInfo = collapse_equivalences(TypeInfo),
type_info_num_functors(NewTypeInfo, NumFunctors)
;
( TypeCtorRep = tcr_subgoal
; TypeCtorRep = tcr_int
; TypeCtorRep = tcr_uint
; TypeCtorRep = tcr_int8
; TypeCtorRep = tcr_uint8
; TypeCtorRep = tcr_int16
; TypeCtorRep = tcr_uint16
; TypeCtorRep = tcr_int32
; TypeCtorRep = tcr_uint32
; TypeCtorRep = tcr_int64
; TypeCtorRep = tcr_uint64
; TypeCtorRep = tcr_char
; TypeCtorRep = tcr_float
; TypeCtorRep = tcr_string
; TypeCtorRep = tcr_bitmap
; TypeCtorRep = tcr_func
; TypeCtorRep = tcr_pred
; TypeCtorRep = tcr_void
; TypeCtorRep = tcr_c_pointer
; TypeCtorRep = tcr_stable_c_pointer
; TypeCtorRep = tcr_typeinfo
; TypeCtorRep = tcr_type_ctor_info
; TypeCtorRep = tcr_type_desc
; TypeCtorRep = tcr_pseudo_type_desc
; TypeCtorRep = tcr_type_ctor_desc
; TypeCtorRep = tcr_typeclassinfo
; TypeCtorRep = tcr_base_typeclass_info
; TypeCtorRep = tcr_array
; TypeCtorRep = tcr_succip
; TypeCtorRep = tcr_hp
; TypeCtorRep = tcr_curfr
; TypeCtorRep = tcr_maxfr
; TypeCtorRep = tcr_redofr
; TypeCtorRep = tcr_redoip
; TypeCtorRep = tcr_trail_ptr
; TypeCtorRep = tcr_ticket
; TypeCtorRep = tcr_foreign
; TypeCtorRep = tcr_stable_foreign
; TypeCtorRep = tcr_reference
),
fail
;
TypeCtorRep = tcr_unknown,
unexpected($pred, "unknown type_ctor_rep")
).
%---------------------------------------------------------------------------%
type_info_get_functor(TypeInfo, FunctorNumber, FunctorName, Arity,
PseudoTypeInfoList) :-
get_functor_impl(TypeInfo, FunctorNumber, FunctorName, Arity,
PseudoTypeInfoList, _Names).
type_info_get_functor_with_names(TypeInfo, FunctorNumber, FunctorName, Arity,
PseudoTypeInfoList, Names) :-
get_functor_impl(TypeInfo, FunctorNumber, FunctorName, Arity,
PseudoTypeInfoList, Names).
:- pred get_functor_impl(type_info::in, int::in, string::out, int::out,
list(pseudo_type_info)::out, list(string)::out) is semidet.
get_functor_impl(TypeInfo, FunctorNumber,
FunctorName, Arity, PseudoTypeInfoList, Names) :-
type_info_num_functors(TypeInfo, NumFunctors),
FunctorNumber >= 0,
FunctorNumber < NumFunctors,
TypeCtorInfo = get_type_ctor_info(TypeInfo),
TypeCtorRep = get_type_ctor_rep(TypeCtorInfo),
require_complete_switch [TypeCtorRep]
(
( TypeCtorRep = tcr_du
; TypeCtorRep = tcr_du_usereq
; TypeCtorRep = tcr_reserved_addr
; TypeCtorRep = tcr_reserved_addr_usereq
),
get_functor_du(TypeCtorRep, TypeInfo, TypeCtorInfo,
FunctorNumber, FunctorName, Arity, PseudoTypeInfoList, Names)
;
( TypeCtorRep = tcr_enum
; TypeCtorRep = tcr_enum_usereq
; TypeCtorRep = tcr_dummy
),
get_functor_enum(TypeCtorRep, TypeCtorInfo,
FunctorNumber, FunctorName, Arity, PseudoTypeInfoList, Names)
;
( TypeCtorRep = tcr_foreign_enum
; TypeCtorRep = tcr_foreign_enum_usereq
),
get_functor_foreign_enum(TypeCtorRep, TypeCtorInfo,
FunctorNumber, FunctorName, Arity, PseudoTypeInfoList, Names)
;
( TypeCtorRep = tcr_notag
; TypeCtorRep = tcr_notag_usereq
; TypeCtorRep = tcr_notag_ground
; TypeCtorRep = tcr_notag_ground_usereq
),
get_functor_notag(TypeCtorRep, TypeCtorInfo,
FunctorNumber, FunctorName, Arity, PseudoTypeInfoList, Names)
;
( TypeCtorRep = tcr_equiv_ground
; TypeCtorRep = tcr_equiv
),
NewTypeInfo = collapse_equivalences(TypeInfo),
get_functor_impl(NewTypeInfo, FunctorNumber,
FunctorName, Arity, PseudoTypeInfoList, Names)
;
TypeCtorRep = tcr_tuple,
FunctorName = "{}",
Arity = get_var_arity_typeinfo_arity(TypeInfo),
PseudoTypeInfoList = iterate(1, Arity,
var_arity_type_info_index_as_pti(TypeInfo)),
Names = list.duplicate(Arity, null_string)
;
( TypeCtorRep = tcr_subgoal
; TypeCtorRep = tcr_int
; TypeCtorRep = tcr_uint
; TypeCtorRep = tcr_int8
; TypeCtorRep = tcr_uint8
; TypeCtorRep = tcr_int16
; TypeCtorRep = tcr_uint16
; TypeCtorRep = tcr_int32
; TypeCtorRep = tcr_uint32
; TypeCtorRep = tcr_int64
; TypeCtorRep = tcr_uint64
; TypeCtorRep = tcr_char
; TypeCtorRep = tcr_float
; TypeCtorRep = tcr_string
; TypeCtorRep = tcr_bitmap
; TypeCtorRep = tcr_func
; TypeCtorRep = tcr_pred
; TypeCtorRep = tcr_void
; TypeCtorRep = tcr_c_pointer
; TypeCtorRep = tcr_stable_c_pointer
; TypeCtorRep = tcr_typeinfo
; TypeCtorRep = tcr_type_ctor_info
; TypeCtorRep = tcr_type_desc
; TypeCtorRep = tcr_pseudo_type_desc
; TypeCtorRep = tcr_type_ctor_desc
; TypeCtorRep = tcr_typeclassinfo
; TypeCtorRep = tcr_base_typeclass_info
; TypeCtorRep = tcr_array
; TypeCtorRep = tcr_succip
; TypeCtorRep = tcr_hp
; TypeCtorRep = tcr_curfr
; TypeCtorRep = tcr_maxfr
; TypeCtorRep = tcr_redofr
; TypeCtorRep = tcr_redoip
; TypeCtorRep = tcr_trail_ptr
; TypeCtorRep = tcr_ticket
; TypeCtorRep = tcr_foreign
; TypeCtorRep = tcr_stable_foreign
; TypeCtorRep = tcr_reference
),
fail
;
TypeCtorRep = tcr_unknown,
unexpected($pred, "unknown type_ctor_rep")
).
%---------------------%
:- pred get_functor_du(type_ctor_rep::in(du), type_info::in,
type_ctor_info::in, int::in, string::out, int::out,
list(pseudo_type_info)::out, list(string)::out) is det.
get_functor_du(TypeCtorRep, TypeInfo, TypeCtorInfo, FunctorNumber,
FunctorName, Arity, PseudoTypeInfoList, Names) :-
TypeFunctors = get_type_ctor_functors(TypeCtorInfo),
DuFunctorDesc = TypeFunctors ^ du_functor_desc(TypeCtorRep, FunctorNumber),
FunctorName = DuFunctorDesc ^ du_functor_name,
Arity = int16.to_int(DuFunctorDesc ^ du_functor_arity),
ArgTypes = DuFunctorDesc ^ du_functor_arg_types,
F =
( func(I) = ArgPseudoTypeInfo :-
PseudoTypeInfo = get_pti_from_arg_types(ArgTypes, I),
ArgPseudoTypeInfo =
create_pseudo_type_info(TypeInfo, PseudoTypeInfo)
),
PseudoTypeInfoList = iterate(0, Arity - 1, F),
( if get_du_functor_arg_names(DuFunctorDesc, ArgNames) then
Names = iterate(0, Arity - 1, arg_names_index(ArgNames))
else
Names = list.duplicate(Arity, null_string)
).
%---------------------%
:- pred get_functor_enum(type_ctor_rep::in(enum), type_ctor_info::in, int::in,
string::out, int::out, list(pseudo_type_info)::out, list(string)::out)
is det.
get_functor_enum(TypeCtorRep, TypeCtorInfo, FunctorNumber, FunctorName, Arity,
PseudoTypeInfoList, Names) :-
TypeFunctors = get_type_ctor_functors(TypeCtorInfo),
EnumFunctorDesc = get_enum_functor_desc(TypeCtorRep, FunctorNumber,
TypeFunctors),
FunctorName = EnumFunctorDesc ^ enum_functor_name,
Arity = 0,
PseudoTypeInfoList = [],
Names = [].
%---------------------%
:- pred get_functor_foreign_enum(type_ctor_rep::in(foreign_enum),
type_ctor_info::in, int::in, string::out, int::out,
list(pseudo_type_info)::out, list(string)::out) is det.
get_functor_foreign_enum(TypeCtorRep, TypeCtorInfo, FunctorNumber,
FunctorName, Arity, PseudoTypeInfoList, Names) :-
TypeFunctors = get_type_ctor_functors(TypeCtorInfo),
ForeignEnumFunctorDesc = get_foreign_enum_functor_desc(TypeCtorRep,
FunctorNumber, TypeFunctors),
FunctorName = ForeignEnumFunctorDesc ^ foreign_enum_functor_name,
Arity = 0,
PseudoTypeInfoList = [],
Names = [].
%---------------------%
:- pred get_functor_notag(type_ctor_rep::in(notag), type_ctor_info::in,
int::in, string::out, int::out, list(pseudo_type_info)::out,
list(string)::out) is det.
get_functor_notag(TypeCtorRep, TypeCtorInfo, FunctorNumber, FunctorName, Arity,
PseudoTypeInfoList, Names) :-
TypeFunctors = get_type_ctor_functors(TypeCtorInfo),
NoTagFunctorDesc = TypeFunctors ^
notag_functor_desc(TypeCtorRep, FunctorNumber),
FunctorName = NoTagFunctorDesc ^ notag_functor_name,
Arity = 1,
ArgType = NoTagFunctorDesc ^ notag_functor_arg_type,
ArgName = NoTagFunctorDesc ^ notag_functor_arg_name,
PseudoTypeInfoList = [ArgType],
Names = [ArgName].
%---------------------%
:- func get_var_arity_typeinfo_arity(type_info) = int.
:- pragma no_determinism_warning(func(get_var_arity_typeinfo_arity/1)).
:- pragma foreign_proc("Java",
get_var_arity_typeinfo_arity(TypeInfo::in) = (Arity::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
if (TypeInfo.args == null) {
Arity = 0;
} else {
Arity = TypeInfo.args.length;
}
").
:- pragma foreign_proc("C#",
get_var_arity_typeinfo_arity(TypeInfo::in) = (Arity::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
if (TypeInfo.args == null) {
Arity = 0;
} else {
Arity = TypeInfo.args.Length;
}
").
get_var_arity_typeinfo_arity(_) = _ :-
private_builtin.sorry("get_var_arity_typeinfo_arity").
%---------------------------------------------------------------------------%
% Unlike get_arg_type_info, existentially quantified type variables are
% simply returned with no attempt to extract the type infos from terms.
% cf. MR_create_pseudo_type_info
%
:- func create_pseudo_type_info(type_info, pseudo_type_info)
= pseudo_type_info.
create_pseudo_type_info(TypeInfo, PseudoTypeInfo) = ArgPseudoTypeInfo :-
( if is_exist_pseudo_type_info(PseudoTypeInfo, _VarNum) then
ArgPseudoTypeInfo = PseudoTypeInfo
else if is_univ_pseudo_type_info(PseudoTypeInfo, VarNum) then
% In some cases we may need to call var_arity_type_info_index_as_pti.
ArgPseudoTypeInfo = type_info_index_as_pti(TypeInfo, VarNum)
else if pseudo_type_ctor_and_args(PseudoTypeInfo, TypeCtorInfo, Args0) then
Args = list.map(create_pseudo_type_info(TypeInfo), Args0),
NewTypeInfo = make_type_info(TypeCtorInfo, list.length(Args), Args),
private_builtin.unsafe_type_cast(NewTypeInfo, ArgPseudoTypeInfo)
else
unexpected($pred, "create_pseudo_type_info")
).
:- func make_type_info(type_ctor_info, int, list(pseudo_type_info)) =
type_info.
:- pragma no_determinism_warning(func(make_type_info/3)).
:- pragma foreign_proc("C#",
make_type_info(TypeCtorInfo::in, Arity::in, Args::in) = (TypeInfo::out),
[will_not_call_mercury, promise_pure, thread_safe, may_not_duplicate],
"
PseudoTypeInfo[] args = new PseudoTypeInfo[Arity];
int i = 0;
list.List_1 lst = Args;
while (!list.is_empty(lst)) {
args[i] = (PseudoTypeInfo) list.det_head(lst);
lst = list.det_tail(lst);
i++;
}
TypeInfo = new TypeInfo_Struct();
TypeInfo.init(TypeCtorInfo, Arity, args);
").
:- pragma foreign_proc("Java",
make_type_info(TypeCtorInfo::in, Arity::in, Args::in) = (TypeInfo::out),
[will_not_call_mercury, promise_pure, thread_safe, may_not_duplicate],
"
PseudoTypeInfo[] as = new PseudoTypeInfo[Arity];
int i = 0;
list.List_1<PseudoTypeInfo> lst = Args;
while (!list.is_empty(lst)) {
as[i] = list.det_head(lst);
lst = list.det_tail(lst);
i++;
}
TypeInfo = new TypeInfo_Struct();
TypeInfo.init(TypeCtorInfo, Arity, as);
").
make_type_info(_, _, _) = _ :-
private_builtin.sorry("make_type_info/3").
%---------------------------------------------------------------------------%
type_info_get_functor_ordinal(TypeInfo, FunctorNum, Ordinal) :-
TypeCtorInfo = get_type_ctor_info(TypeInfo),
TypeCtorRep = get_type_ctor_rep(TypeCtorInfo),
require_complete_switch [TypeCtorRep]
(
( TypeCtorRep = tcr_enum
; TypeCtorRep = tcr_enum_usereq
),
TypeFunctors = get_type_ctor_functors(TypeCtorInfo),
EnumFunctorDesc = get_enum_functor_desc(TypeCtorRep, FunctorNum,
TypeFunctors),
EnumValue = enum_functor_value(EnumFunctorDesc),
index_or_search_enum_functor_ordinal(TypeCtorInfo, EnumValue, Ordinal)
;
( TypeCtorRep = tcr_foreign_enum
; TypeCtorRep = tcr_foreign_enum_usereq
),
TypeFunctors = get_type_ctor_functors(TypeCtorInfo),
ForeignEnumFunctorDesc = get_foreign_enum_functor_desc(TypeCtorRep,
FunctorNum, TypeFunctors),
Ordinal = foreign_enum_functor_ordinal(ForeignEnumFunctorDesc)
;
( TypeCtorRep = tcr_dummy
; TypeCtorRep = tcr_notag
; TypeCtorRep = tcr_notag_usereq
; TypeCtorRep = tcr_notag_ground
; TypeCtorRep = tcr_notag_ground_usereq
; TypeCtorRep = tcr_tuple
),
FunctorNum = 0,
Ordinal = 0
;
( TypeCtorRep = tcr_du
; TypeCtorRep = tcr_du_usereq
; TypeCtorRep = tcr_reserved_addr
; TypeCtorRep = tcr_reserved_addr_usereq
),
TypeFunctors = get_type_ctor_functors(TypeCtorInfo),
DuFunctorDesc = TypeFunctors ^ du_functor_desc(TypeCtorRep,
FunctorNum),
Ordinal = int32.to_int(du_functor_ordinal(DuFunctorDesc))
;
( TypeCtorRep = tcr_equiv
; TypeCtorRep = tcr_equiv_ground
; TypeCtorRep = tcr_func
; TypeCtorRep = tcr_pred
; TypeCtorRep = tcr_int
; TypeCtorRep = tcr_uint
; TypeCtorRep = tcr_int8
; TypeCtorRep = tcr_uint8
; TypeCtorRep = tcr_int16
; TypeCtorRep = tcr_uint16
; TypeCtorRep = tcr_int32
; TypeCtorRep = tcr_uint32
; TypeCtorRep = tcr_int64
; TypeCtorRep = tcr_uint64
; TypeCtorRep = tcr_float
; TypeCtorRep = tcr_char
; TypeCtorRep = tcr_string
; TypeCtorRep = tcr_bitmap
; TypeCtorRep = tcr_subgoal
; TypeCtorRep = tcr_void
; TypeCtorRep = tcr_c_pointer
; TypeCtorRep = tcr_stable_c_pointer
; TypeCtorRep = tcr_typeinfo
; TypeCtorRep = tcr_type_ctor_info
; TypeCtorRep = tcr_typeclassinfo
; TypeCtorRep = tcr_base_typeclass_info
; TypeCtorRep = tcr_type_desc
; TypeCtorRep = tcr_type_ctor_desc
; TypeCtorRep = tcr_pseudo_type_desc
; TypeCtorRep = tcr_array
; TypeCtorRep = tcr_reference
; TypeCtorRep = tcr_succip
; TypeCtorRep = tcr_hp
; TypeCtorRep = tcr_curfr
; TypeCtorRep = tcr_maxfr
; TypeCtorRep = tcr_redofr
; TypeCtorRep = tcr_redoip
; TypeCtorRep = tcr_trail_ptr
; TypeCtorRep = tcr_ticket
; TypeCtorRep = tcr_foreign
; TypeCtorRep = tcr_stable_foreign
; TypeCtorRep = tcr_unknown
),
fail
).
%---------------------------------------------------------------------------%
type_info_get_functor_lex(TypeInfo0, Ordinal, FunctorNumber) :-
TypeInfo = collapse_equivalences(TypeInfo0),
TypeCtorInfo = get_type_ctor_info(TypeInfo),
type_ctor_search_functor_number_map(TypeCtorInfo, Ordinal, FunctorNumber).
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
% Implement generic calls -- we could use call/N but then we would
% have to create a real closure.
%
% We first give "unimplemented" definitions in Mercury, which will be
% used by default.
%
% NOTE: semidet_call_* and result_call_* are declared as no-typeinfo
% builtins.
:- type unify_or_compare_pred
---> unify_or_compare_pred.
:- pragma foreign_type("C#", unify_or_compare_pred, "object").
:- pragma foreign_type("Java", unify_or_compare_pred,
"jmercury.runtime.MethodPtr").
% We override the Mercury definitions in the Java and .NET backends.
%---------------------%
:- pred semidet_call_3(P::in, T::in, U::in) is semidet.
:- pragma foreign_proc("C#",
semidet_call_3(Pred::in, X::in, Y::in),
[will_not_call_mercury, promise_pure, thread_safe],
"
runtime.MethodPtr2_r1<object, object, bool> pred
= (runtime.MethodPtr2_r1<object, object, bool>) Pred;
SUCCESS_INDICATOR = pred(X, Y);
").
:- pragma foreign_proc("Java",
semidet_call_3(Pred::in, X::in, Y::in),
[will_not_call_mercury, promise_pure, thread_safe],
"
jmercury.runtime.MethodPtr2 P = (jmercury.runtime.MethodPtr2) Pred;
SUCCESS_INDICATOR = (Boolean) P.call___0_0(X, Y);
").
semidet_call_3(_, _, _) :-
semidet_unimplemented("semidet_call_3").
%---------------------%
:- pred semidet_call_4(P::in, A::in, T::in, U::in) is semidet.
:- pragma foreign_proc("C#",
semidet_call_4(Pred::in, A::in, X::in, Y::in),
[will_not_call_mercury, promise_pure, thread_safe],
"
runtime.MethodPtr3_r1<object, object, object, bool> pred
= (runtime.MethodPtr3_r1<object, object, object, bool>) Pred;
SUCCESS_INDICATOR = pred(A, X, Y);
").
:- pragma foreign_proc("Java",
semidet_call_4(Pred::in, A::in, X::in, Y::in),
[will_not_call_mercury, promise_pure, thread_safe],
"
jmercury.runtime.MethodPtr3 P = (jmercury.runtime.MethodPtr3) Pred;
SUCCESS_INDICATOR = (Boolean) P.call___0_0(A, X, Y);
").
semidet_call_4(_, _, _, _) :-
semidet_unimplemented("semidet_call_4").
%---------------------%
:- pred semidet_call_5(P::in, A::in, B::in, T::in, U::in) is semidet.
:- pragma foreign_proc("C#",
semidet_call_5(Pred::in, A::in, B::in, X::in, Y::in),
[will_not_call_mercury, promise_pure, thread_safe],
"
runtime.MethodPtr4_r1<object, object, object, object, bool> pred
= (runtime.MethodPtr4_r1<object, object, object, object, bool>) Pred;
SUCCESS_INDICATOR = pred(A, B, X, Y);
").
:- pragma foreign_proc("Java",
semidet_call_5(Pred::in, A::in, B::in, X::in, Y::in),
[will_not_call_mercury, promise_pure, thread_safe],
"
jmercury.runtime.MethodPtr4 P = (jmercury.runtime.MethodPtr4) Pred;
SUCCESS_INDICATOR = (Boolean) P.call___0_0(A, B, X, Y);
").
semidet_call_5(_, _, _, _, _) :-
semidet_unimplemented("semidet_call_5").
%---------------------%
:- pred semidet_call_6(P::in, A::in, B::in, C::in, T::in, U::in) is semidet.
:- pragma foreign_proc("C#",
semidet_call_6(Pred::in, A::in, B::in, C::in, X::in, Y::in),
[will_not_call_mercury, promise_pure, thread_safe],
"
runtime.MethodPtr5_r1<object, object, object, object, object, bool> pred
= (runtime.MethodPtr5_r1<object, object, object, object, object, bool>)
Pred;
SUCCESS_INDICATOR = pred(A, B, C, X, Y);
").
:- pragma foreign_proc("Java",
semidet_call_6(Pred::in, A::in, B::in, C::in, X::in, Y::in),
[will_not_call_mercury, promise_pure, thread_safe],
"
jmercury.runtime.MethodPtr5 P = (jmercury.runtime.MethodPtr5) Pred;
SUCCESS_INDICATOR = (Boolean) P.call___0_0(A, B, C, X, Y);
").
semidet_call_6(_, _, _, _, _, _) :-
semidet_unimplemented("semidet_call_6").
%---------------------%
:- pred semidet_call_7(P::in, A::in, B::in, C::in, D::in, T::in, U::in)
is semidet.
:- pragma foreign_proc("C#",
semidet_call_7(Pred::in, A::in, B::in, C::in, D::in, X::in, Y::in),
[will_not_call_mercury, promise_pure, thread_safe],
"
runtime.MethodPtr6_r1<object, object, object, object, object, object, bool>
pred
= (runtime.MethodPtr6_r1<object, object, object, object, object,
object, bool>) Pred;
SUCCESS_INDICATOR = pred(A, B, C, D, X, Y);
").
:- pragma foreign_proc("Java",
semidet_call_7(Pred::in, A::in, B::in, C::in, D::in, X::in, Y::in),
[will_not_call_mercury, promise_pure, thread_safe],
"
jmercury.runtime.MethodPtr6 P = (jmercury.runtime.MethodPtr6) Pred;
SUCCESS_INDICATOR = (Boolean) P.call___0_0(A, B, C, D, X, Y);
").
semidet_call_7(_, _, _, _, _, _, _) :-
semidet_unimplemented("semidet_call_7").
%---------------------%
:- pred semidet_call_8(P::in, A::in, B::in, C::in, D::in, E::in, T::in, U::in)
is semidet.
:- pragma foreign_proc("C#",
semidet_call_8(Pred::in, A::in, B::in, C::in, D::in, E::in,
X::in, Y::in),
[will_not_call_mercury, promise_pure, thread_safe],
"
runtime.MethodPtr7_r1<object, object, object, object, object, object,
object, bool> pred =
(runtime.MethodPtr7_r1<object, object, object, object, object, object,
object, bool>) Pred;
SUCCESS_INDICATOR = pred(A, B, C, D, E, X, Y);
").
:- pragma foreign_proc("Java",
semidet_call_8(Pred::in, A::in, B::in, C::in, D::in, E::in, X::in, Y::in),
[will_not_call_mercury, promise_pure, thread_safe],
"
jmercury.runtime.MethodPtr7 P = (jmercury.runtime.MethodPtr7) Pred;
SUCCESS_INDICATOR = (Boolean) P.call___0_0(A, B, C, D, E, X, Y);
").
semidet_call_8(_, _, _, _, _, _, _, _) :-
semidet_unimplemented("semidet_call_8").
%---------------------%
:- pred result_call_4(P::in, comparison_result::out,
T::in, U::in) is det.
:- pragma foreign_proc("C#",
result_call_4(Pred::in, Res::out, X::in, Y::in),
[will_not_call_mercury, promise_pure, thread_safe],
"
// XXX C# should the return type be object of Comparison_result_0?
// Indeed; this is causing unnecessary boxing.
runtime.MethodPtr2_r1<object, object, object> pred
= (runtime.MethodPtr2_r1<object, object, object>) Pred;
Res = (builtin.Comparison_result_0) pred(X, Y);
").
:- pragma foreign_proc("Java",
result_call_4(Pred::in, Res::out, X::in, Y::in),
[will_not_call_mercury, promise_pure, thread_safe],
"
jmercury.runtime.MethodPtr2 P = (jmercury.runtime.MethodPtr2) Pred;
Res = (builtin.Comparison_result_0) P.call___0_0(X, Y);
").
result_call_4(_, (=), _, _) :-
det_unimplemented("result_call_4").
%---------------------%
:- pred result_call_5(P::in, comparison_result::out,
A::in, T::in, U::in) is det.
:- pragma foreign_proc("C#",
result_call_5(Pred::in, Res::out, A::in, X::in, Y::in),
[will_not_call_mercury, promise_pure, thread_safe],
"
runtime.MethodPtr3_r1<object, object, object, object> pred
= (runtime.MethodPtr3_r1<object, object, object, object>) Pred;
Res = (builtin.Comparison_result_0) pred(A, X, Y);
").
:- pragma foreign_proc("Java",
result_call_5(Pred::in, Res::out, A::in, X::in, Y::in),
[will_not_call_mercury, promise_pure, thread_safe],
"
jmercury.runtime.MethodPtr3 P = (jmercury.runtime.MethodPtr3) Pred;
Res = (builtin.Comparison_result_0) P.call___0_0(A, X, Y);
").
result_call_5(_, (=), _, _, _) :-
det_unimplemented("comparison_result").
%---------------------%
:- pred result_call_6(P::in, comparison_result::out,
A::in, B::in, T::in, U::in) is det.
:- pragma foreign_proc("C#",
result_call_6(Pred::in, Res::out, A::in, B::in, X::in, Y::in),
[will_not_call_mercury, promise_pure, thread_safe],
"
runtime.MethodPtr4_r1<object, object, object, object, object> pred
= (runtime.MethodPtr4_r1<object, object, object, object, object>) Pred;
Res = (builtin.Comparison_result_0) pred(A, B, X, Y);
").
:- pragma foreign_proc("Java",
result_call_6(Pred::in, Res::out, A::in, B::in, X::in, Y::in),
[will_not_call_mercury, promise_pure, thread_safe],
"
jmercury.runtime.MethodPtr4 P = (jmercury.runtime.MethodPtr4) Pred;
Res = (builtin.Comparison_result_0) P.call___0_0(A, B, X, Y);
").
result_call_6(_, (=), _, _, _, _) :-
det_unimplemented("comparison_result").
%---------------------%
:- pred result_call_7(P::in, comparison_result::out,
A::in, B::in, C::in, T::in, U::in) is det.
:- pragma foreign_proc("C#",
result_call_7(Pred::in, Res::out, A::in, B::in, C::in, X::in, Y::in),
[will_not_call_mercury, promise_pure, thread_safe],
"
runtime.MethodPtr5_r1<object, object, object, object, object, object> pred
= (runtime.MethodPtr5_r1<object, object, object, object, object,
object>) Pred;
Res = (builtin.Comparison_result_0) pred(A, B, C, X, Y);
").
:- pragma foreign_proc("Java",
result_call_7(Pred::in, Res::out, A::in, B::in, C::in, X::in, Y::in),
[will_not_call_mercury, promise_pure, thread_safe],
"
jmercury.runtime.MethodPtr5 P = (jmercury.runtime.MethodPtr5) Pred;
Res = (builtin.Comparison_result_0) P.call___0_0(A, B, C, X, Y);
").
result_call_7(_, (=), _, _, _, _, _) :-
det_unimplemented("comparison_result").
%---------------------%
:- pred result_call_8(P::in, comparison_result::out,
A::in, B::in, C::in, D::in, T::in, U::in) is det.
:- pragma foreign_proc("C#",
result_call_8(Pred::in, Res::out, A::in, B::in, C::in, D::in, X::in,
Y::in),
[will_not_call_mercury, promise_pure, thread_safe],
"
runtime.MethodPtr6_r1<object, object, object, object, object, object,
object> pred
= (runtime.MethodPtr6_r1<object, object, object, object, object,
object, object>) Pred;
Res = (builtin.Comparison_result_0) pred(A, B, C, D, X, Y);
").
:- pragma foreign_proc("Java",
result_call_8(Pred::in, Res::out, A::in, B::in, C::in, D::in, X::in,
Y::in),
[will_not_call_mercury, promise_pure, thread_safe],
"
jmercury.runtime.MethodPtr6 P = (jmercury.runtime.MethodPtr6) Pred;
Res = (builtin.Comparison_result_0) P.call___0_0(A, B, C, D, X, Y);
").
result_call_8(_, (=), _, _, _, _, _, _) :-
det_unimplemented("comparison_result").
%---------------------%
:- pred result_call_9(P::in, comparison_result::out,
A::in, B::in, C::in, D::in, E::in, T::in, U::in) is det.
:- pragma foreign_proc("C#",
result_call_9(Pred::in, Res::out, A::in, B::in, C::in, D::in, E::in,
X::in, Y::in),
[will_not_call_mercury, promise_pure, thread_safe],
"
runtime.MethodPtr7_r1<object, object, object, object, object, object,
object, object> pred
= (runtime.MethodPtr7_r1<object, object, object, object, object,
object, object, object>) Pred;
Res = (builtin.Comparison_result_0) pred(A, B, C, D, E, X, Y);
").
:- pragma foreign_proc("Java",
result_call_9(Pred::in, Res::out, A::in, B::in, C::in, D::in, E::in,
X::in, Y::in),
[will_not_call_mercury, promise_pure, thread_safe],
"
jmercury.runtime.MethodPtr7 P = (jmercury.runtime.MethodPtr7) Pred;
Res = (builtin.Comparison_result_0) P.call___0_0(A, B, C, D, E, X, Y);
").
result_call_9(_, (=), _, _, _, _, _, _, _) :-
det_unimplemented("result_call_9").
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
type_ctor_name_and_arity(TypeCtorInfo, ModuleName, Name, Arity) :-
ModuleName = type_ctor_module_name(TypeCtorInfo),
Name = type_ctor_name(TypeCtorInfo),
Arity = type_ctor_arity(TypeCtorInfo).
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- pragma no_determinism_warning(pred(pseudo_type_ctor_and_args/3)).
:- pragma foreign_proc("C#",
pseudo_type_ctor_and_args(PseudoTypeInfo::in, TypeCtorInfo::out,
ArgPseudoTypeInfos::out),
[will_not_call_mercury, promise_pure, thread_safe, may_not_duplicate],
"
if (PseudoTypeInfo.variable_number == -1) {
if (PseudoTypeInfo is TypeCtorInfo_Struct) {
TypeCtorInfo = (TypeCtorInfo_Struct) PseudoTypeInfo;
ArgPseudoTypeInfos = list.empty_list();
} else {
TypeInfo_Struct ti = (TypeInfo_Struct) PseudoTypeInfo;
TypeCtorInfo = ti.type_ctor;
list.List_1 lst = list.empty_list();
if (ti.args != null) {
for (int i = ti.args.Length - 1; i >= 0; i--) {
lst = list.cons(ti.args[i], lst);
}
}
ArgPseudoTypeInfos = lst;
}
SUCCESS_INDICATOR = true;
} else {
// Fail if input is a variable.
TypeCtorInfo = null;
ArgPseudoTypeInfos = null;
SUCCESS_INDICATOR = false;
}
").
:- pragma foreign_proc("Java",
pseudo_type_ctor_and_args(PseudoTypeInfo::in, TypeCtorInfo::out,
ArgPseudoTypeInfos::out),
[will_not_call_mercury, promise_pure, thread_safe, may_not_duplicate],
"
if (PseudoTypeInfo.variable_number == -1) {
if (PseudoTypeInfo instanceof TypeCtorInfo_Struct) {
TypeCtorInfo = (TypeCtorInfo_Struct) PseudoTypeInfo;
ArgPseudoTypeInfos = list.empty_list();
} else {
TypeInfo_Struct ti = (TypeInfo_Struct) PseudoTypeInfo;
TypeCtorInfo = ti.type_ctor;
list.List_1<PseudoTypeInfo> lst = list.empty_list();
if (ti.args != null) {
for (int i = ti.args.length - 1; i >= 0; i--) {
lst = list.cons(ti.args[i], lst);
}
}
ArgPseudoTypeInfos = lst;
}
SUCCESS_INDICATOR = true;
} else {
// Fail if input is a variable.
TypeCtorInfo = null;
ArgPseudoTypeInfos = null;
SUCCESS_INDICATOR = false;
}
").
pseudo_type_ctor_and_args(_, _, _) :-
private_builtin.sorry("pseudo_type_ctor_and_args/3").
%---------------------%
:- pragma no_determinism_warning(pred(is_univ_pseudo_type_info/2)).
:- pragma foreign_proc("C#",
is_univ_pseudo_type_info(PseudoTypeInfo::in, VarNum::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
VarNum = PseudoTypeInfo.variable_number;
SUCCESS_INDICATOR =
(VarNum >= 0 && VarNum <= rtti_implementation.last_univ_quant_varnum);
").
:- pragma foreign_proc("Java",
is_univ_pseudo_type_info(PseudoTypeInfo::in, VarNum::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
VarNum = PseudoTypeInfo.variable_number;
SUCCESS_INDICATOR =
(VarNum >= 0 && VarNum <= rtti_implementation.last_univ_quant_varnum);
").
is_univ_pseudo_type_info(_, _) :-
private_builtin.sorry("is_univ_pseudo_type_info/2").
%---------------------%
:- pragma no_determinism_warning(pred(is_exist_pseudo_type_info/2)).
:- pragma foreign_proc("C#",
is_exist_pseudo_type_info(PseudoTypeInfo::in, VarNum::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
VarNum = PseudoTypeInfo.variable_number;
SUCCESS_INDICATOR =
(VarNum >= rtti_implementation.first_exist_quant_varnum);
").
:- pragma foreign_proc("Java",
is_exist_pseudo_type_info(PseudoTypeInfo::in, VarNum::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
VarNum = PseudoTypeInfo.variable_number;
SUCCESS_INDICATOR =
(VarNum >= rtti_implementation.first_exist_quant_varnum);
").
is_exist_pseudo_type_info(_, _) :-
private_builtin.sorry("is_exist_pseudo_type_info/2").
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- pragma foreign_code("C#",
"
private static bool
ML_construct(runtime.TypeInfo_Struct TypeInfo, int FunctorNumber,
list.List_1 ArgList, out univ.Univ_0 Term)
{
// If type_info is an equivalence type, expand it.
TypeInfo = ML_collapse_equivalences(TypeInfo);
object new_data = null;
// XXX catch exceptions
{
runtime.TypeCtorInfo_Struct tc = TypeInfo.type_ctor;
switch (tc.type_ctor_rep) {
case runtime.TypeCtorRep.MR_TYPECTOR_REP_ENUM:
case runtime.TypeCtorRep.MR_TYPECTOR_REP_ENUM_USEREQ:
runtime.EnumFunctorDesc[] functors_enum =
tc.type_functors.functors_enum();
if (FunctorNumber >= 0 && FunctorNumber < functors_enum.Length)
{
new_data = ML_construct_static_member(tc,
functors_enum[FunctorNumber].enum_functor_value);
}
break;
case runtime.TypeCtorRep.MR_TYPECTOR_REP_FOREIGN_ENUM:
case runtime.TypeCtorRep.MR_TYPECTOR_REP_FOREIGN_ENUM_USEREQ:
runtime.ForeignEnumFunctorDesc[] functors_foreign_enum =
tc.type_functors.functors_foreign_enum();
if (
FunctorNumber >= 0 &&
FunctorNumber < functors_foreign_enum.Length
) {
new_data = ML_construct_static_member(tc,
functors_foreign_enum[FunctorNumber].foreign_enum_functor_value);
}
break;
case runtime.TypeCtorRep.MR_TYPECTOR_REP_NOTAG:
case runtime.TypeCtorRep.MR_TYPECTOR_REP_NOTAG_USEREQ:
case runtime.TypeCtorRep.MR_TYPECTOR_REP_NOTAG_GROUND:
case runtime.TypeCtorRep.MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ:
case runtime.TypeCtorRep.MR_TYPECTOR_REP_RESERVED_ADDR:
case runtime.TypeCtorRep.MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ:
// These don't exist in the C# backend yet.
break;
case runtime.TypeCtorRep.MR_TYPECTOR_REP_DU:
case runtime.TypeCtorRep.MR_TYPECTOR_REP_DU_USEREQ:
runtime.DuFunctorDesc[] functor_descs =
tc.type_functors.functors_du();
if (FunctorNumber >= 0 && FunctorNumber < functor_descs.Length)
{
runtime.DuFunctorDesc functor_desc =
functor_descs[FunctorNumber];
if (functor_desc.du_functor_subtype_info !=
runtime.FunctorSubtypeInfo.MR_FUNCTOR_SUBTYPE_NONE)
{
runtime.Errors.SORRY(""construction of terms "" +
""containing subtype constraints"");
}
new_data = ML_construct_du(tc, functor_desc, ArgList);
}
break;
case runtime.TypeCtorRep.MR_TYPECTOR_REP_TUPLE:
int arity = TypeInfo.args.Length;
new_data = ML_univ_list_to_array(ArgList, arity);
break;
case runtime.TypeCtorRep.MR_TYPECTOR_REP_DUMMY:
if (FunctorNumber == 0 && ArgList is list.List_1.F_nil_0) {
new_data = ML_construct_static_member(tc, 0);
}
break;
case runtime.TypeCtorRep.MR_TYPECTOR_REP_INT:
// ints don't have functor ordinals.
throw new System.Exception(
""cannot construct int with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_INT8:
// int8s don't have functor ordinals.
throw new System.Exception(
""cannot construct int8 with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_INT16:
// int16s don't have functor ordinals.
throw new System.Exception(
""cannot construct int16 with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_INT32:
// int32s don't have functor ordinals.
throw new System.Exception(
""cannot construct int32 with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_INT64:
// int64s don't have functor ordinals.
throw new System.Exception(
""cannot construct int64 with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_UINT:
// uints don't have functor ordinals.
throw new System.Exception(
""cannot construct uint with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_UINT8:
// uint8s don't have functor ordinals.
throw new System.Exception(
""cannot construct uint8 with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_UINT16:
// uint16s don't have functor ordinals.
throw new System.Exception(
""cannot construct uint16 with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_UINT32:
// uint32s don't have functor ordinals.
throw new System.Exception(
""cannot construct uint32 with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_UINT64:
// uint64s don't have functor ordinals.
throw new System.Exception(
""cannot construct uint64 with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_FLOAT:
// floats don't have functor ordinals.
throw new System.Exception(
""cannot construct float with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_CHAR:
// chars don't have functor ordinals.
throw new System.Exception(
""cannot construct chars with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_STRING:
// strings don't have functor ordinals.
throw new System.Exception(
""cannot construct strings with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_BITMAP:
// bitmaps don't have functor ordinals.
throw new System.Exception(
""cannot construct bitmaps with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_EQUIV:
case runtime.TypeCtorRep.MR_TYPECTOR_REP_EQUIV_GROUND:
// These should be eliminated above.
throw new System.Exception(
""equiv type in construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_VOID:
// These should be eliminated above.
throw new System.Exception(
""cannot construct void values with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_FUNC:
throw new System.Exception(
""cannot construct functions with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_PRED:
throw new System.Exception(
""cannot construct predicates with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_SUBGOAL:
throw new System.Exception(
""cannot construct subgoals with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_TYPEDESC:
throw new System.Exception(
""cannot construct type_descs with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_TYPECTORDESC:
throw new System.Exception(
""cannot construct type_descs with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_PSEUDOTYPEDESC:
throw new System.Exception(
""cannot construct pseudotype_descs with "" +
""construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_TYPEINFO:
throw new System.Exception(
""cannot construct type_infos with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_TYPECTORINFO:
throw new System.Exception(
""cannot construct type_ctor_infos with "" +
""construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_TYPECLASSINFO:
throw new System.Exception(
""cannot construct type_class_infos with "" +
""construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_BASETYPECLASSINFO:
throw new System.Exception(
""cannot construct base_type_class_infos "" +
""with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_SUCCIP:
throw new System.Exception(
""cannot construct succips with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_HP:
throw new System.Exception(
""cannot construct hps with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_CURFR:
throw new System.Exception(
""cannot construct curfrs with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_MAXFR:
throw new System.Exception(
""cannot construct maxfrs with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_REDOFR:
throw new System.Exception(
""cannot construct redofrs with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_REDOIP:
throw new System.Exception(
""cannot construct redoips with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_TRAIL_PTR:
throw new System.Exception(
""cannot construct trail_ptrs with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_TICKET:
throw new System.Exception(
""cannot construct tickets with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_C_POINTER:
case runtime.TypeCtorRep.MR_TYPECTOR_REP_STABLE_C_POINTER:
throw new System.Exception(
""cannot construct c_pointers with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_ARRAY:
throw new System.Exception(
""cannot construct arrays with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_REFERENCE:
throw new System.Exception(
""cannot construct references with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_FOREIGN:
case runtime.TypeCtorRep.MR_TYPECTOR_REP_STABLE_FOREIGN:
throw new System.Exception(
""cannot construct values of foreign types "" +
""with construct.construct"");
case runtime.TypeCtorRep.MR_TYPECTOR_REP_UNKNOWN:
throw new System.Exception(
""cannot construct values of unknown types "" +
""with construct.construct"");
default:
throw new System.Exception(
""bad type_ctor_rep in construct.construct"");
}
}
if (new_data != null) {
Term = new univ.Univ_0(TypeInfo, new_data);
return true;
} else {
Term = null;
return false;
}
}
private static object
ML_construct_du(runtime.TypeCtorInfo_Struct tc,
runtime.DuFunctorDesc functor_desc, list.List_1 arg_list)
{
TypeCtorInfo_Struct base_tc = tc.type_ctor_base;
if (base_tc != null) {
// For subtypes, we must derive the class and field names from the
// base type ctor.
byte ptag = functor_desc.du_functor_primary;
DuPtagLayout ptag_layout =
base_tc.index_or_search_ptag_layout(ptag);
int sectag = functor_desc.du_functor_secondary;
if (sectag == -1) {
sectag = 0;
}
DuFunctorDesc base_functor_desc =
ptag_layout.index_or_search_sectag_functor(sectag);
return ML_construct_du_2(base_tc, base_functor_desc, arg_list);
} else {
return ML_construct_du_2(tc, functor_desc, arg_list);
}
}
private static object
ML_construct_du_2(runtime.TypeCtorInfo_Struct tc,
runtime.DuFunctorDesc functor_desc, list.List_1 arg_list)
{
string typename;
System.Type type;
if (tc.type_ctor_num_functors == 1) {
typename =
""mercury."" + ML_name_mangle(tc.type_ctor_module_name)
+ ""+"" + ML_flipInitialCase(ML_name_mangle(tc.type_ctor_name))
+ ""_"" + tc.arity;
} else {
typename =
""mercury."" + ML_name_mangle(tc.type_ctor_module_name)
+ ""+"" + ML_flipInitialCase(ML_name_mangle(tc.type_ctor_name))
+ ""_"" + tc.arity
+ ""+"" + ML_flipInitialCase(ML_name_mangle(
functor_desc.du_functor_name))
+ ""_"" + functor_desc.du_functor_orig_arity;
}
type = ML_search_type(typename);
int arity = functor_desc.du_functor_orig_arity;
object[] args = ML_univ_list_to_array(arg_list, arity);
if (args == null) {
// Argument list length doesn't match arity.
return null;
}
// XXX C# catch exceptions
return System.Activator.CreateInstance(type, args);
}
private static object[]
ML_univ_list_to_array(list.List_1 lst, int arity)
{
object[] args = new object[arity];
for (int i = 0; i < arity; i++) {
TypeInfo_Struct ti;
univ.ML_unravel_univ(out ti,
(univ.Univ_0) list.det_head(lst), out args[i]);
lst = list.det_tail(lst);
}
if (list.is_empty(lst)) {
return args;
} else {
return null;
}
}
private static object
ML_construct_static_member(runtime.TypeCtorInfo_Struct tc, int i)
{
// For subtypes, we must derive the class name from the base type ctor.
if (tc.type_ctor_base != null) {
tc = tc.type_ctor_base;
}
string typename =
""mercury."" + ML_name_mangle(tc.type_ctor_module_name)
+ ""+"" + ML_flipInitialCase(ML_name_mangle(tc.type_ctor_name))
+ ""_"" + tc.arity;
System.Type type = ML_search_type(typename);
return System.Enum.ToObject(type, i);
}
private static System.Type
ML_search_type(string typename)
{
// Do we need to optimise this? e.g. search the current assembly,
// then that which contains the standard library, or cache old results.
System.Reflection.Assembly[] av =
System.AppDomain.CurrentDomain.GetAssemblies();
foreach (System.Reflection.Assembly a in av) {
System.Type t = a.GetType(typename);
if (t != null) {
return t;
}
}
return null;
}
// XXX fix name
private static string
ML_flipInitialCase(string s)
{
if (s.Length > 0) {
char first = s[0];
string rest = s.Substring(1);
if (System.Char.IsLower(first)) {
return System.Char.ToUpper(first) + rest;
}
if (System.Char.IsUpper(first)) {
return System.Char.ToLower(first) + rest;
}
}
return s;
}
// Duplicated and modified from Java version.
private static string
ML_name_mangle(string s)
{
bool all_ok = true;
if (s.Length < 1) {
all_ok = false;
}
if (all_ok && System.Char.IsDigit(s, 0)) {
all_ok = false;
}
if (all_ok) {
foreach (char c in s) {
if ((c >= 'A' && c <= 'Z') ||
(c >= 'a' && c <= 'z') ||
(c >= '0' && c <= '9') ||
(c == '_'))
{
// do nothing
} else {
all_ok = false;
break;
}
}
}
if (all_ok) {
if (s.StartsWith(""f_"")) {
return ""f__"" + s.Substring(2);
} else {
return s;
}
}
// This is from prog_foreign.name_conversion_table.
if (s.Equals(""\\\\="")) return ""f_not_equal"";
if (s.Equals("">="")) return ""f_greater_or_equal"";
if (s.Equals(""=<"")) return ""f_less_or_equal"";
if (s.Equals(""="")) return ""f_equal"";
if (s.Equals(""<"")) return ""f_less_than"";
if (s.Equals("">"")) return ""f_greater_than"";
if (s.Equals(""-"")) return ""f_minus"";
if (s.Equals(""+"")) return ""f_plus"";
if (s.Equals(""*"")) return ""f_times"";
if (s.Equals(""/"")) return ""f_slash"";
if (s.Equals("","")) return ""f_comma"";
if (s.Equals("";"")) return ""f_semicolon"";
if (s.Equals(""!"")) return ""f_cut"";
if (s.Equals(""{}"")) return ""f_tuple"";
if (s.Equals(""[|]"")) return ""f_cons"";
if (s.Equals(""[]"")) return ""f_nil"";
System.Text.StringBuilder sb = new System.Text.StringBuilder(""f"");
foreach (char c in s.ToCharArray()) {
sb.Append('_');
sb.Append((int) c);
}
return sb.ToString();
}
private static object[]
ML_list_to_array(list.List_1 lst, int arity)
{
object[] array = new object[arity];
for (int i = 0; i < arity; i++) {
array[i] = list.det_head(lst);
lst = list.det_tail(lst);
}
return array;
}
").
:- pragma foreign_code("Java",
"
private static Object[]
ML_construct(TypeInfo_Struct TypeInfo, int FunctorNumber,
list.List_1<univ.Univ_0> ArgList)
{
// If type_info is an equivalence type, expand it.
TypeInfo = ML_collapse_equivalences(TypeInfo);
Object new_data = null;
try {
final jmercury.runtime.TypeCtorInfo_Struct tc = TypeInfo.type_ctor;
switch (tc.type_ctor_rep.value) {
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_ENUM:
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_ENUM_USEREQ:
EnumFunctorDesc[] functors_enum =
tc.type_functors.functors_enum();
if (FunctorNumber >= 0 && FunctorNumber < functors_enum.length)
{
new_data = ML_construct_static_member(tc,
functors_enum[FunctorNumber].enum_functor_value);
}
break;
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_FOREIGN_ENUM:
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_FOREIGN_ENUM_USEREQ:
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_NOTAG:
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_NOTAG_USEREQ:
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_NOTAG_GROUND:
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ:
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_RESERVED_ADDR:
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ:
// These don't exist in the Java backend yet.
break;
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_DU:
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_DU_USEREQ:
DuFunctorDesc[] functor_descs = tc.type_functors.functors_du();
if (FunctorNumber >= 0 && FunctorNumber < functor_descs.length)
{
DuFunctorDesc functor_desc = functor_descs[FunctorNumber];
if (functor_desc.du_functor_subtype_info.value !=
private_builtin.MR_FUNCTOR_SUBTYPE_NONE)
{
throw new Error(""not yet implemented: construction ""
+ ""of terms containing subtype constraints"");
}
new_data = ML_construct_du(tc, functor_desc, ArgList);
}
break;
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_TUPLE:
int arity = TypeInfo.args.length;
new_data = ML_univ_list_to_array(ArgList, arity);
break;
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_DUMMY:
if (FunctorNumber == 0 &&
ArgList instanceof list.List_1.F_nil_0)
{
new_data = ML_construct_static_member(tc, 0);
}
break;
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_INT:
// ints don't have functor ordinals.
throw new Error(
""cannot construct int with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_INT8:
// int8s don't have functor ordinals.
throw new Error(
""cannot construct int8 with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_INT16:
// int16s don't have functor ordinals.
throw new Error(
""cannot construct int16 with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_INT32:
// int32s don't have functor ordinals.
throw new Error(
""cannot construct int32 with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_INT64:
// int64s don't have functor ordinals.
throw new Error(
""cannot construct int64 with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_UINT:
// ints don't have functor ordinals.
throw new Error(
""cannot construct uint with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_UINT8:
// uint8s don't have functor ordinals.
throw new Error(
""cannot construct uint8 with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_UINT16:
// uint16s don't have functor ordinals.
throw new Error(
""cannot construct uint16 with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_UINT32:
// uint32s don't have functor ordinals.
throw new Error(
""cannot construct uint32 with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_UINT64:
// uint64s don't have functor ordinals.
throw new Error(
""cannot construct uint64 with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_FLOAT:
// floats don't have functor ordinals.
throw new Error(
""cannot construct float with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_CHAR:
// chars don't have functor ordinals.
throw new Error(
""cannot construct chars with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_STRING:
// strings don't have functor ordinals.
throw new Error(
""cannot construct strings with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_BITMAP:
// bitmaps don't have functor ordinals.
throw new Error(
""cannot construct bitmaps with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_EQUIV:
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_EQUIV_GROUND:
// These should be eliminated above.
throw new Error(""equiv type in construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_VOID:
// These should be eliminated above.
throw new Error(
""cannot construct void values with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_FUNC:
throw new Error(
""cannot construct functions with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_PRED:
throw new Error(
""cannot construct predicates with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_SUBGOAL:
throw new Error(
""cannot construct subgoals with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_TYPEDESC:
throw new Error(
""cannot construct type_descs with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_TYPECTORDESC:
throw new Error(
""cannot construct type_descs with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_PSEUDOTYPEDESC:
throw new Error(
""cannot construct pseudotype_descs with "" +
""construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_TYPEINFO:
throw new Error(
""cannot construct type_infos with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_TYPECTORINFO:
throw new Error(
""cannot construct type_ctor_infos with "" +
""construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_TYPECLASSINFO:
throw new Error(
""cannot construct type_class_infos with "" +
""construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_BASETYPECLASSINFO:
throw new Error(
""cannot construct base_type_class_infos "" +
""with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_SUCCIP:
throw new Error(
""cannot construct succips with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_HP:
throw new Error(
""cannot construct hps with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_CURFR:
throw new Error(
""cannot construct curfrs with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_MAXFR:
throw new Error(
""cannot construct maxfrs with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_REDOFR:
throw new Error(
""cannot construct redofrs with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_REDOIP:
throw new Error(
""cannot construct redoips with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_TRAIL_PTR:
throw new Error(
""cannot construct trail_ptrs with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_TICKET:
throw new Error(
""cannot construct tickets with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_C_POINTER:
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_STABLE_C_POINTER:
throw new Error(
""cannot construct c_pointers with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_ARRAY:
throw new Error(
""cannot construct arrays with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_REFERENCE:
throw new Error(
""cannot construct references with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_FOREIGN:
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_STABLE_FOREIGN:
throw new Error(
""cannot construct values of foreign types "" +
""with construct.construct"");
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_UNKNOWN:
throw new Error(
""cannot construct values of unknown types "" +
""with construct.construct"");
default:
throw new Error(""bad type_ctor_rep in construct.construct"");
}
} catch (ClassNotFoundException e) {
throw new Error(e.getMessage());
} catch (NoSuchFieldException e) {
throw new Error(e.getMessage());
} catch (IllegalAccessException e) {
throw new Error(e.getMessage());
} catch (InstantiationException e) {
throw new Error(e.getMessage());
} catch (InvocationTargetException e) {
throw new Error(e.getMessage());
}
boolean succeeded;
Object Term;
if (new_data != null) {
succeeded = true;
Term = new univ.Univ_0(TypeInfo, new_data);
} else {
succeeded = false;
Term = null;
}
return new Object[] { succeeded, Term };
}
private static Object
ML_construct_du(TypeCtorInfo_Struct tc, DuFunctorDesc functor_desc,
list.List_1<univ.Univ_0> arg_list)
throws ClassNotFoundException, NoSuchFieldException,
IllegalAccessException, InstantiationException,
InvocationTargetException
{
final jmercury.runtime.TypeCtorInfo_Struct base_tc = tc.type_ctor_base;
if (base_tc != null) {
// For subtypes, we must derive the class and field names from the
// base type ctor.
byte ptag = functor_desc.du_functor_primary;
jmercury.runtime.DuPtagLayout ptag_layout =
base_tc.index_or_search_ptag_layout(ptag);
int sectag = functor_desc.du_functor_secondary;
if (sectag == -1) {
sectag = 0;
}
jmercury.runtime.DuFunctorDesc base_functor_desc =
ptag_layout.index_or_search_sectag_functor(sectag);
return ML_construct_du_2(base_tc, base_functor_desc, arg_list);
} else {
return ML_construct_du_2(tc, functor_desc, arg_list);
}
}
private static Object
ML_construct_du_2(TypeCtorInfo_Struct tc, DuFunctorDesc functor_desc,
list.List_1<univ.Univ_0> arg_list)
throws
ClassNotFoundException, NoSuchFieldException,
IllegalAccessException, InstantiationException,
InvocationTargetException
{
String clsname;
if (tc.type_ctor_num_functors == 1) {
clsname = ""jmercury."" + ML_name_mangle(tc.type_ctor_module_name)
+ ""$"" + ML_flipInitialCase(ML_name_mangle(tc.type_ctor_name))
+ ""_"" + tc.arity;
} else {
String mangled_mod_name = ML_name_mangle(tc.type_ctor_module_name);
String mangled_ctor_name = ML_name_mangle(tc.type_ctor_name) +
""_"" + tc.arity;
String mangled_functor_name;
if (tc.type_ctor_name.equals(functor_desc.du_functor_name) &&
tc.arity == functor_desc.du_functor_orig_arity)
{
mangled_functor_name =
ML_name_mangle(""mr_"" + functor_desc.du_functor_name) +
""_"" + functor_desc.du_functor_orig_arity;
} else {
mangled_functor_name =
ML_name_mangle(functor_desc.du_functor_name) +
""_"" + functor_desc.du_functor_orig_arity;
}
clsname = ""jmercury."" + mangled_mod_name + ""$"" +
ML_flipInitialCase(mangled_ctor_name) + ""$"" +
ML_flipInitialCase(mangled_functor_name);
}
final Class<?> cls = Class.forName(clsname);
final int arity = functor_desc.du_functor_orig_arity;
final Object[] args = ML_univ_list_to_array(arg_list, arity);
if (args == null) {
// Argument list length doesn't match arity.
return null;
}
for (Constructor ctor : cls.getConstructors()) {
Class<?>[] param_types = ctor.getParameterTypes();
if (param_types.length == arity) {
try {
return ctor.newInstance(args);
} catch (IllegalArgumentException e) {
// e.g. argument type mismatch
return null;
}
}
}
throw new Error(
""construct.construct: could not find constructor for functor"");
}
private static Object[]
ML_univ_list_to_array(list.List_1<univ.Univ_0> lst, int arity)
{
final Object[] args = new Object[arity];
final Ref<TypeInfo_Struct> ti_ref = new Ref<TypeInfo_Struct>();
final Ref<Object> obj_ref = new Ref<Object>();
for (int i = 0; i < arity; i++) {
univ.ML_unravel_univ(ti_ref, list.det_head(lst), obj_ref);
args[i] = obj_ref.val;
lst = list.det_tail(lst);
}
if (list.is_empty(lst)) {
return args;
} else {
return null;
}
}
private static Object
ML_construct_static_member(TypeCtorInfo_Struct tc, int i)
throws ClassNotFoundException, NoSuchFieldException,
IllegalAccessException
{
// For subtypes, we must derive the class name from the base type ctor.
if (tc.type_ctor_base != null) {
tc = tc.type_ctor_base;
}
Class<?> cls = Class.forName(
""jmercury."" + ML_name_mangle(tc.type_ctor_module_name)
+ ""$"" + ML_flipInitialCase(ML_name_mangle(tc.type_ctor_name))
+ ""_"" + tc.arity);
String field_name = ""K"" + i;
Field field = cls.getField(field_name);
return field.get(cls);
}
// XXX fix name
private static String
ML_flipInitialCase(String s)
{
if (s.length() > 0) {
char first = s.charAt(0);
String rest = s.substring(1);
if (Character.isLowerCase(first)) {
return Character.toString(Character.toUpperCase(first)) + rest;
}
if (Character.isUpperCase(first)) {
return Character.toString(Character.toLowerCase(first)) + rest;
}
}
return s;
}
private static String
ML_name_mangle(String s)
{
if (s.matches(""[A-Za-z_][A-Za-z0-9_]*"")) {
if (s.startsWith(""f_"")) {
return ""f__"" + s.substring(2);
} else {
return s;
}
}
// This is from prog_foreign.name_conversion_table.
if (s.equals(""\\\\="")) return ""f_not_equal"";
if (s.equals("">="")) return ""f_greater_or_equal"";
if (s.equals(""=<"")) return ""f_less_or_equal"";
if (s.equals(""="")) return ""f_equal"";
if (s.equals(""<"")) return ""f_less_than"";
if (s.equals("">"")) return ""f_greater_than"";
if (s.equals(""-"")) return ""f_minus"";
if (s.equals(""+"")) return ""f_plus"";
if (s.equals(""*"")) return ""f_times"";
if (s.equals(""/"")) return ""f_slash"";
if (s.equals("","")) return ""f_comma"";
if (s.equals("";"")) return ""f_semicolon"";
if (s.equals(""!"")) return ""f_cut"";
if (s.equals(""{}"")) return ""f_tuple"";
if (s.equals(""[|]"")) return ""f_cons"";
if (s.equals(""[]"")) return ""f_nil"";
StringBuilder sb = new StringBuilder(""f"");
for (int i = 0; i < s.length(); i++) {
sb.append('_');
sb.append(s.codePointAt(i));
}
return sb.toString();
}
private static Object[]
ML_list_to_array(list.List_1 lst, int arity)
{
final Object[] array = new Object[arity];
for (int i = 0; i < arity; i++) {
array[i] = list.det_head(lst);
lst = list.det_tail(lst);
}
return array;
}
").
:- pragma no_determinism_warning(func(construct/3)).
:- pragma foreign_proc("C#",
construct(TypeInfo::in, FunctorNumber::in, ArgList::in) = (Term::out),
[will_not_call_mercury, promise_pure, thread_safe, may_not_duplicate],
"
SUCCESS_INDICATOR = ML_construct(TypeInfo, FunctorNumber, ArgList,
out Term);
").
:- pragma foreign_proc("Java",
construct(TypeInfo::in, FunctorNumber::in, ArgList::in) = (Term::out),
[will_not_call_mercury, promise_pure, thread_safe, may_not_duplicate],
"
Object[] rc = ML_construct(TypeInfo, FunctorNumber, ArgList);
SUCCESS_INDICATOR = (Boolean) rc[0];
Term = (univ.Univ_0) rc[1];
").
construct(_, _, _) = _ :-
private_builtin.sorry("construct/3").
%---------------------------------------------------------------------------%
:- pragma no_determinism_warning(func(construct_tuple_2/3)).
:- pragma foreign_proc("C#",
construct_tuple_2(Args::in, ArgTypes::in, Arity::in) = (Tuple::out),
[will_not_call_mercury, promise_pure, thread_safe,
may_not_duplicate],
"
list.List_1 args_list = Args;
object[] args_array = new object[Arity];
for (int i = 0; i < Arity; i++) {
TypeInfo_Struct ti_tmp;
univ.ML_unravel_univ(out ti_tmp,
(univ.Univ_0) list.det_head(args_list), out args_array[i]);
args_list = list.det_tail(args_list);
}
object[] args = ML_list_to_array(ArgTypes, Arity);
runtime.TypeInfo_Struct ti = new TypeInfo_Struct();
ti.init(builtin.builtin__type_ctor_info_tuple_0, args);
Tuple = univ.ML_construct_univ(ti, args_array);
").
:- pragma foreign_proc("Java",
construct_tuple_2(Args::in, ArgTypes::in, Arity::in) = (Tuple::out),
[will_not_call_mercury, promise_pure, thread_safe,
may_not_duplicate],
"
list.List_1<univ.Univ_0> args_list = Args;
Object[] args_array = new Object[Arity];
Ref<TypeInfo_Struct> ti_ref = new Ref<TypeInfo_Struct>();
Ref<Object> obj_ref = new Ref<Object>();
for (int i = 0; i < Arity; i++) {
univ.ML_unravel_univ(ti_ref, list.det_head(args_list), obj_ref);
args_array[i] = obj_ref.val;
args_list = list.det_tail(args_list);
}
Object[] args = ML_list_to_array(ArgTypes, Arity);
TypeInfo_Struct ti = new TypeInfo_Struct();
ti.init(builtin.builtin__type_ctor_info_tuple_0, args);
Tuple = univ.ML_construct_univ(ti, args_array);
").
construct_tuple_2(_Args, _ArgTypes, _Arity) = _ :-
private_builtin.sorry("construct_tuple_2/3").
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
deconstruct(Term, NonCanon, Functor, FunctorNumber, Arity, Arguments) :-
TypeInfo = get_type_info(Term),
TypeCtorInfo = get_type_ctor_info(TypeInfo),
TypeCtorRep = get_type_ctor_rep(TypeCtorInfo),
deconstruct_2(Term, TypeInfo, TypeCtorInfo, TypeCtorRep, NonCanon,
Functor, Ordinal, Arity, Arguments),
( if
Ordinal >= 0,
type_ctor_search_functor_number_map(TypeCtorInfo, Ordinal,
FunctorNumber0)
then
FunctorNumber = FunctorNumber0
else
FunctorNumber = 0
).
functor_number_cc(Term, FunctorNumber, Arity) :-
TypeInfo = get_type_info(Term),
TypeCtorInfo = get_type_ctor_info(TypeInfo),
TypeCtorRep = get_type_ctor_rep(TypeCtorInfo),
promise_equivalent_solutions [Ordinal, Arity] (
deconstruct_2(Term, TypeInfo, TypeCtorInfo, TypeCtorRep,
include_details_cc, _Functor, Ordinal, Arity, _Arguments)
),
Ordinal >= 0,
type_ctor_search_functor_number_map(TypeCtorInfo, Ordinal, FunctorNumber0),
cc_multi_equal(FunctorNumber0, FunctorNumber).
:- pred deconstruct_2(T, type_info, type_ctor_info, type_ctor_rep,
noncanon_handling, string, int, int, list(univ)).
:- mode deconstruct_2(in, in, in, in, in(do_not_allow), out, out, out, out)
is det.
:- mode deconstruct_2(in, in, in, in, in(canonicalize), out, out, out, out)
is det.
:- mode deconstruct_2(in, in, in, in, in(include_details_cc), out, out, out,
out) is cc_multi.
:- mode deconstruct_2(in, in, in, in, in, out, out, out, out) is cc_multi.
deconstruct_2(Term, TypeInfo, TypeCtorInfo, TypeCtorRep, NonCanon,
Functor, Ordinal, Arity, Arguments) :-
% Code to perform deconstructions (XXX not yet complete).
%
% There are many cases to implement here, only the ones that were
% immediately useful (e.g. called by io.write) have been implemented
% so far.
(
TypeCtorRep = tcr_enum_usereq,
handle_usereq_type(Term, TypeInfo, TypeCtorInfo, TypeCtorRep,
NonCanon, Functor, Ordinal, Arity, Arguments)
;
TypeCtorRep = tcr_enum,
EnumValue = unsafe_get_enum_value(Term),
det_index_or_search_enum_functor_ordinal(TypeCtorInfo, EnumValue,
Ordinal),
index_enum_functor_desc(TypeCtorInfo, Ordinal, EnumFunctorDesc),
Functor = enum_functor_name(EnumFunctorDesc),
Arity = 0,
Arguments = []
;
TypeCtorRep = tcr_foreign_enum,
TypeFunctors = get_type_ctor_functors(TypeCtorInfo),
ForeignEnumFunctorDesc = foreign_enum_functor_desc(TypeCtorRep,
unsafe_get_foreign_enum_value(Term), TypeFunctors),
Functor = foreign_enum_functor_name(ForeignEnumFunctorDesc),
Ordinal = foreign_enum_functor_ordinal(ForeignEnumFunctorDesc),
Arity = 0,
Arguments = []
;
TypeCtorRep = tcr_foreign_enum_usereq,
handle_usereq_type(Term, TypeInfo, TypeCtorInfo, TypeCtorRep,
NonCanon, Functor, Ordinal, Arity, Arguments)
;
TypeCtorRep = tcr_dummy,
Ordinal = 0,
index_enum_functor_desc(TypeCtorInfo, Ordinal, EnumFunctorDesc),
Functor = enum_functor_name(EnumFunctorDesc),
Arity = 0,
Arguments = []
;
TypeCtorRep = tcr_du_usereq,
handle_usereq_type(Term, TypeInfo, TypeCtorInfo, TypeCtorRep,
NonCanon, Functor, Ordinal, Arity, Arguments)
;
TypeCtorRep = tcr_du,
PTag = get_primary_tag(Term),
det_index_or_search_ptag_layout(TypeCtorInfo, PTag, PTagEntry),
SecTagLocn = PTagEntry ^ sectag_locn,
(
(
SecTagLocn = stag_none,
index_sectag_functor(PTagEntry, 0, FunctorDesc)
;
SecTagLocn = stag_none_direct_arg,
index_sectag_functor(PTagEntry, 0, FunctorDesc)
;
SecTagLocn = stag_remote,
SecTag = get_remote_secondary_tag(Term),
det_index_or_search_sectag_functor(PTagEntry, SecTag,
FunctorDesc)
),
Functor = FunctorDesc ^ du_functor_name,
Ordinal = int32.to_int(FunctorDesc ^ du_functor_ordinal),
Arity = int16.to_int(FunctorDesc ^ du_functor_arity),
Arguments = iterate(0, Arity - 1,
get_arg_univ(Term, TypeInfo, SecTagLocn, FunctorDesc))
;
SecTagLocn = stag_local_rest_of_word,
Functor = "some_du_local_sectag",
% XXX incomplete
Ordinal = -1,
Arity = 0,
Arguments = []
;
SecTagLocn = stag_variable,
Functor = "some_du_variable_sectag",
Ordinal = -1,
Arity = 0,
Arguments = []
)
;
TypeCtorRep = tcr_notag_usereq,
handle_usereq_type(Term, TypeInfo, TypeCtorInfo, TypeCtorRep, NonCanon,
Functor, Ordinal, Arity, Arguments)
;
TypeCtorRep = tcr_notag,
% XXX incomplete
Functor = "some_notag",
Ordinal = -1,
Arity = 0,
Arguments = []
;
TypeCtorRep = tcr_notag_ground_usereq,
handle_usereq_type(Term, TypeInfo, TypeCtorInfo, TypeCtorRep, NonCanon,
Functor, Ordinal, Arity, Arguments)
;
TypeCtorRep = tcr_notag_ground,
% XXX incomplete
Functor = "some_notag_ground",
Ordinal = -1,
Arity = 0,
Arguments = []
;
TypeCtorRep = tcr_equiv_ground,
NewTypeInfo = collapse_equivalences(TypeInfo),
NewTypeCtorInfo = get_type_ctor_info(NewTypeInfo),
NewTypeCtorRep = get_type_ctor_rep(NewTypeCtorInfo),
deconstruct_2(Term, NewTypeInfo, NewTypeCtorInfo, NewTypeCtorRep,
NonCanon, Functor, Ordinal, Arity, Arguments)
;
% XXX noncanonical term
TypeCtorRep = tcr_func,
Functor = "<<function>>",
Ordinal = -1,
Arity = 0,
Arguments = []
;
TypeCtorRep = tcr_equiv,
% XXX incomplete
Functor = "some_equiv",
Ordinal = -1,
Arity = 0,
Arguments = []
;
TypeCtorRep = tcr_int,
det_dynamic_cast(Term, Int),
Functor = string.int_to_string(Int),
Ordinal = -1,
Arity = 0,
Arguments = []
;
TypeCtorRep = tcr_uint,
det_dynamic_cast(Term, UInt),
Functor = string.uint_to_string(UInt) ++ "u",
Ordinal = -1,
Arity = 0,
Arguments = []
;
TypeCtorRep = tcr_int8,
det_dynamic_cast(Term, Int8),
Functor = string.int8_to_string(Int8) ++ "i8",
Ordinal = -1,
Arity = 0,
Arguments = []
;
TypeCtorRep = tcr_uint8,
det_dynamic_cast(Term, UInt8),
Functor = string.uint8_to_string(UInt8) ++ "u8",
Ordinal = -1,
Arity = 0,
Arguments = []
;
TypeCtorRep = tcr_int16,
det_dynamic_cast(Term, Int16),
Functor = string.int16_to_string(Int16) ++ "i16",
Ordinal = -1,
Arity = 0,
Arguments = []
;
TypeCtorRep = tcr_uint16,
det_dynamic_cast(Term, UInt16),
Functor = string.uint16_to_string(UInt16) ++ "u16",
Ordinal = -1,
Arity = 0,
Arguments = []
;
TypeCtorRep = tcr_int32,
det_dynamic_cast(Term, Int32),
Functor = string.int32_to_string(Int32) ++ "i32",
Ordinal = -1,
Arity = 0,
Arguments = []
;
TypeCtorRep = tcr_uint32,
det_dynamic_cast(Term, UInt32),
Functor = string.uint32_to_string(UInt32) ++ "u32",
Ordinal = -1,
Arity = 0,
Arguments = []
;
TypeCtorRep = tcr_int64,
det_dynamic_cast(Term, Int64),
Functor = string.int64_to_string(Int64) ++ "i64",
Ordinal = -1,
Arity = 0,
Arguments = []
;
TypeCtorRep = tcr_uint64,
det_dynamic_cast(Term, UInt64),
Functor = string.uint64_to_string(UInt64) ++ "u64",
Ordinal = -1,
Arity = 0,
Arguments = []
;
% Changes here may need to reflected in the handling of
% MR_TYPCTOR_REP_CHAR in runtime/mercury_ml_expand_body.h.
TypeCtorRep = tcr_char,
det_dynamic_cast(Term, Char),
( if quote_special_escape_char(Char, EscapedChar) then
Functor = EscapedChar
else if
char.is_control(Char)
then
char.to_int(Char, Int),
string.int_to_base_string(Int, 8, OctalString0),
string.pad_left(OctalString0, '0', 3, OctalString),
Functor = "'\\" ++ OctalString ++ "\\'"
else if
char.is_surrogate(Char)
then
unexpected($pred, "attempt to deconstruct surrogate code point")
else
Functor = string.from_char_list(['\'', Char, '\''])
),
Ordinal = -1,
Arity = 0,
Arguments = []
;
TypeCtorRep = tcr_float,
det_dynamic_cast(Term, Float),
Functor = float_to_string(Float),
Ordinal = -1,
Arity = 0,
Arguments = []
;
TypeCtorRep = tcr_string,
det_dynamic_cast(Term, String),
Functor = term_io.quoted_string(String),
Ordinal = -1,
Arity = 0,
Arguments = []
;
TypeCtorRep = tcr_bitmap,
det_dynamic_cast(Term, Bitmap),
String = bitmap.to_string(Bitmap),
Functor = "\"" ++ String ++ "\"",
Ordinal = -1,
Arity = 0,
Arguments = []
;
% XXX noncanonical term
TypeCtorRep = tcr_pred,
Functor = "<<predicate>>",
Ordinal = -1,
Arity = 0,
Arguments = []
;
TypeCtorRep = tcr_tuple,
type_ctor_and_args(TypeInfo, _TypeCtorInfo, TypeArgs),
Functor = "{}",
Ordinal = 0,
Arity = get_var_arity_typeinfo_arity(TypeInfo),
list.map_foldl(
( pred(ArgTypeInfo::in, Univ::out, Index::in, Next::out) is det :-
get_tuple_subterm(Term, Index, ArgTypeInfo, SubTerm),
Univ = univ(SubTerm),
Next = Index + 1
), TypeArgs, Arguments, 0, _)
;
% XXX noncanonical term
TypeCtorRep = tcr_subgoal,
Functor = "<<subgoal>>",
Ordinal = -1,
Arity = 0,
Arguments = []
;
% There is no way to create values of type `void', so this
% should never happen.
TypeCtorRep = tcr_void,
unexpected($pred, "cannot deconstruct void types")
;
TypeCtorRep = tcr_c_pointer,
det_dynamic_cast(Term, CPtr),
Functor = string.c_pointer_to_string(CPtr),
Ordinal = -1,
Arity = 0,
Arguments = []
;
TypeCtorRep = tcr_stable_c_pointer,
det_dynamic_cast(Term, CPtr),
Functor = "stable_" ++ string.c_pointer_to_string(CPtr),
Ordinal = -1,
Arity = 0,
Arguments = []
;
TypeCtorRep = tcr_array,
% Constrain the T in array(T) to the correct element type.
type_ctor_and_args(type_of(Term), _, Args),
( if Args = [ElemType] then
has_type(Elem, ElemType),
same_array_elem_type(Array, Elem)
else
unexpected($pred, "array without a type_ctor arg")
),
det_dynamic_cast(Term, Array),
Functor = "<<array>>",
Ordinal = -1,
Arity = array.size(Array),
Arguments = array.foldr(
(func(Elem, List) = [univ(Elem) | List]),
Array, [])
;
(
TypeCtorRep = tcr_succip,
Functor = "<<succip>>"
;
TypeCtorRep = tcr_hp,
Functor = "<<hp>>"
;
TypeCtorRep = tcr_curfr,
Functor = "<<curfr>>"
;
TypeCtorRep = tcr_maxfr,
Functor = "<<maxfr>>"
;
TypeCtorRep = tcr_redofr,
Functor = "<<redofr>>"
;
TypeCtorRep = tcr_redoip,
Functor = "<<redoip>>"
;
TypeCtorRep = tcr_trail_ptr,
Functor = "<<trail_ptr>>"
;
TypeCtorRep = tcr_ticket,
Functor = "<<ticket>>"
),
Ordinal = -1,
Arity = 0,
Arguments = []
;
% XXX FIXME!!!
TypeCtorRep = tcr_reserved_addr,
Functor = "some_reserved_addr",
Ordinal = -1,
Arity = 0,
Arguments = []
;
TypeCtorRep = tcr_reserved_addr_usereq,
handle_usereq_type(Term, TypeInfo, TypeCtorInfo, TypeCtorRep, NonCanon,
Functor, Ordinal, Arity, Arguments)
;
% XXX inconsistent: <<xxx>> vs some_xxx
(
% XXX noncanonical term
TypeCtorRep = tcr_typeinfo,
Functor = "some_typeinfo"
;
% XXX noncanonical term
TypeCtorRep = tcr_typeclassinfo,
Functor = "<<typeclassinfo>>"
;
% XXX noncanonical term
TypeCtorRep = tcr_type_ctor_info,
Functor = "some_typectorinfo"
;
% XXX noncanonical term
TypeCtorRep = tcr_base_typeclass_info,
Functor = "<<basetypeclassinfo>>"
;
% XXX noncanonical term
TypeCtorRep = tcr_type_desc,
Functor = "some_type_desc"
;
% XXX noncanonical term
TypeCtorRep = tcr_pseudo_type_desc,
Functor = "some_pseudo_type_desc"
;
% XXX noncanonical term
TypeCtorRep = tcr_type_ctor_desc,
Functor = "some_type_ctor_desc"
),
Ordinal = -1,
Arity = 0,
Arguments = []
;
(
TypeCtorRep = tcr_foreign,
TypeCtorName = TypeCtorInfo ^ type_ctor_name,
TargetLangRep = get_target_lang_rep(Term),
string.format("<<foreign(%s, %s)>>",
[s(TypeCtorName), s(TargetLangRep)], Functor)
;
TypeCtorRep = tcr_stable_foreign,
Functor = "<<stable_foreign>>"
),
Ordinal = -1,
Arity = 0,
Arguments = []
;
% XXX noncanonical term
TypeCtorRep = tcr_reference,
Functor = "<<reference>>",
Ordinal = -1,
Arity = 0,
Arguments = []
;
TypeCtorRep = tcr_unknown,
unexpected($pred, "unknown type_ctor rep")
).
%---------------------------------------------------------------------------%
univ_named_arg(Term, NonCanon, Name, Argument) :-
TypeInfo = get_type_info(Term),
TypeCtorInfo = get_type_ctor_info(TypeInfo),
TypeCtorRep = get_type_ctor_rep(TypeCtorInfo),
univ_named_arg_2(Term, TypeInfo, TypeCtorInfo, TypeCtorRep, NonCanon, Name,
MaybeArgument),
MaybeArgument = yes(Argument).
:- pred univ_named_arg_2(T, type_info, type_ctor_info, type_ctor_rep,
noncanon_handling, string, maybe(univ)).
:- mode univ_named_arg_2(in, in, in, in, in(do_not_allow), in, out) is det.
:- mode univ_named_arg_2(in, in, in, in, in(canonicalize), in, out) is det.
:- mode univ_named_arg_2(in, in, in, in, in(include_details_cc), in, out)
is det.
univ_named_arg_2(Term, TypeInfo, TypeCtorInfo, TypeCtorRep, NonCanon, Name,
MaybeArgument) :-
(
TypeCtorRep = tcr_du_usereq,
(
NonCanon = do_not_allow,
unexpected($pred, "attempt to deconstruct noncanonical term")
;
NonCanon = canonicalize,
MaybeArgument = no
;
NonCanon = include_details_cc,
univ_named_arg_2(Term, TypeInfo, TypeCtorInfo, tcr_du, NonCanon,
Name, MaybeArgument)
)
;
TypeCtorRep = tcr_du,
PTag = get_primary_tag(Term),
det_index_or_search_ptag_layout(TypeCtorInfo, PTag, PTagEntry),
SecTagLocn = PTagEntry ^ sectag_locn,
(
(
SecTagLocn = stag_none,
index_sectag_functor(PTagEntry, 0, FunctorDesc)
;
SecTagLocn = stag_none_direct_arg,
index_sectag_functor(PTagEntry, 0, FunctorDesc)
;
SecTagLocn = stag_remote,
SecTag = get_remote_secondary_tag(Term),
det_index_or_search_sectag_functor(PTagEntry, SecTag,
FunctorDesc)
),
Arity = int16.to_int(FunctorDesc ^ du_functor_arity),
( if
get_du_functor_arg_names(FunctorDesc, Names),
search_arg_names(Names, 0, Arity, Name, Index)
then
ArgUniv = get_arg_univ(Term, TypeInfo, SecTagLocn, FunctorDesc,
Index),
MaybeArgument = yes(ArgUniv)
else
MaybeArgument = no
)
;
SecTagLocn = stag_local_rest_of_word,
MaybeArgument = no
;
SecTagLocn = stag_variable,
MaybeArgument = no
)
;
( TypeCtorRep = tcr_enum
; TypeCtorRep = tcr_enum_usereq
; TypeCtorRep = tcr_notag
; TypeCtorRep = tcr_notag_usereq
; TypeCtorRep = tcr_equiv
; TypeCtorRep = tcr_func
; TypeCtorRep = tcr_int
; TypeCtorRep = tcr_uint
; TypeCtorRep = tcr_int8
; TypeCtorRep = tcr_uint8
; TypeCtorRep = tcr_int16
; TypeCtorRep = tcr_uint16
; TypeCtorRep = tcr_int32
; TypeCtorRep = tcr_uint32
; TypeCtorRep = tcr_int64
; TypeCtorRep = tcr_uint64
; TypeCtorRep = tcr_char
; TypeCtorRep = tcr_float
; TypeCtorRep = tcr_string
; TypeCtorRep = tcr_pred
; TypeCtorRep = tcr_subgoal
; TypeCtorRep = tcr_c_pointer
; TypeCtorRep = tcr_typeinfo
; TypeCtorRep = tcr_typeclassinfo
; TypeCtorRep = tcr_array
; TypeCtorRep = tcr_succip
; TypeCtorRep = tcr_hp
; TypeCtorRep = tcr_curfr
; TypeCtorRep = tcr_maxfr
; TypeCtorRep = tcr_redofr
; TypeCtorRep = tcr_redoip
; TypeCtorRep = tcr_trail_ptr
; TypeCtorRep = tcr_ticket
; TypeCtorRep = tcr_notag_ground
; TypeCtorRep = tcr_notag_ground_usereq
; TypeCtorRep = tcr_equiv_ground
; TypeCtorRep = tcr_tuple
; TypeCtorRep = tcr_reserved_addr
; TypeCtorRep = tcr_reserved_addr_usereq
; TypeCtorRep = tcr_type_ctor_info
; TypeCtorRep = tcr_base_typeclass_info
; TypeCtorRep = tcr_type_desc
; TypeCtorRep = tcr_type_ctor_desc
; TypeCtorRep = tcr_foreign
; TypeCtorRep = tcr_reference
; TypeCtorRep = tcr_stable_c_pointer
; TypeCtorRep = tcr_stable_foreign
; TypeCtorRep = tcr_pseudo_type_desc
; TypeCtorRep = tcr_dummy
; TypeCtorRep = tcr_bitmap
; TypeCtorRep = tcr_foreign_enum
; TypeCtorRep = tcr_foreign_enum_usereq
),
MaybeArgument = no
;
TypeCtorRep = tcr_void,
unexpected($pred, "cannot deconstruct void types")
;
TypeCtorRep = tcr_unknown,
unexpected($pred, "unknown type_ctor rep")
).
%---------------------------------------------------------------------------%
% Note: the code here is similar (but not identical) to escape_char
% in mercury_term_lexer.m, and the places listed there.
% Any changes here may require similar changes there.
%
:- pred quote_special_escape_char(character::in, string::out) is semidet.
quote_special_escape_char('\a', "'\\a'").
quote_special_escape_char('\b', "'\\b'").
quote_special_escape_char('\e', "'\\e'").
quote_special_escape_char('\f', "'\\f'").
quote_special_escape_char('\n', "'\\n'").
quote_special_escape_char('\r', "'\\r'").
quote_special_escape_char('\t', "'\\t'").
quote_special_escape_char('\v', "'\\v'").
quote_special_escape_char('\\', "'\\\\'").
quote_special_escape_char('\'', "'\\''").
:- pred det_dynamic_cast(T::in, U::out) is det.
det_dynamic_cast(Term, Actual) :-
type_to_univ(Term, Univ),
det_univ_to_type(Univ, Actual).
:- pred same_array_elem_type(array(T)::unused, T::unused) is det.
same_array_elem_type(_, _).
%---------------------------------------------------------------------------%
:- inst usereq for type_ctor_rep/0
---> tcr_enum_usereq
; tcr_foreign_enum_usereq
; tcr_du_usereq
; tcr_notag_usereq
; tcr_notag_ground_usereq
; tcr_reserved_addr_usereq.
% Part of deconstruct_2.
%
:- pred handle_usereq_type(T, type_info, type_ctor_info, type_ctor_rep,
noncanon_handling, string, int, int, list(univ)).
:- mode handle_usereq_type(in, in, in, in(usereq),
in(do_not_allow), out, out, out, out) is erroneous.
:- mode handle_usereq_type(in, in, in, in(usereq),
in(canonicalize), out, out, out, out) is det.
:- mode handle_usereq_type(in, in, in, in(usereq),
in(include_details_cc), out, out, out, out) is cc_multi.
:- mode handle_usereq_type(in, in, in, in(usereq),
in, out, out, out, out) is cc_multi.
handle_usereq_type(Term, TypeInfo, TypeCtorInfo, TypeCtorRep, NonCanon,
Functor, Ordinal, Arity, Arguments) :-
(
NonCanon = do_not_allow,
unexpected($pred, "attempt to deconstruct noncanonical term")
;
NonCanon = canonicalize,
Functor = expand_type_name(TypeCtorInfo, yes),
Ordinal = -1, % not supported anyway
Arity = 0,
Arguments = []
;
NonCanon = include_details_cc,
(
TypeCtorRep = tcr_enum_usereq,
BaseTypeCtorRep = tcr_enum
;
TypeCtorRep = tcr_foreign_enum_usereq,
BaseTypeCtorRep = tcr_foreign_enum
;
TypeCtorRep = tcr_du_usereq,
BaseTypeCtorRep = tcr_du
;
TypeCtorRep = tcr_notag_usereq,
BaseTypeCtorRep = tcr_notag
;
TypeCtorRep = tcr_notag_ground_usereq,
BaseTypeCtorRep = tcr_notag_ground
;
TypeCtorRep = tcr_reserved_addr_usereq,
BaseTypeCtorRep = tcr_reserved_addr
),
deconstruct_2(Term, TypeInfo, TypeCtorInfo, BaseTypeCtorRep, NonCanon,
Functor, Ordinal, Arity, Arguments)
).
% MR_expand_type_name from mercury_deconstruct.c
%
:- func expand_type_name(type_ctor_info, bool) = string.
expand_type_name(TypeCtorInfo, Wrap) = Name :-
(
Wrap = yes,
LeftWrapper = "<<",
RightWrapper = ">>"
;
Wrap = no,
LeftWrapper = "",
RightWrapper = ""
),
Name = string.format("%s%s.%s/%d%s",
[s(LeftWrapper),
s(TypeCtorInfo ^ type_ctor_module_name),
s(TypeCtorInfo ^ type_ctor_name),
i(TypeCtorInfo ^ type_ctor_arity),
s(RightWrapper)]).
%---------------------------------------------------------------------------%
% Retrieve an argument number from a term, given the functor descriptor.
%
:- some [ArgT] pred get_arg(T::in, type_info::in, sectag_locn::in,
du_functor_desc::in, int::in, ArgT::out) is det.
get_arg(Term, TypeInfo, SecTagLocn, FunctorDesc, Index, Arg) :-
( if get_du_functor_exist_info(FunctorDesc, ExistInfo) then
NumExtraArgs0 =
int16.to_int(exist_info_typeinfos_plain(ExistInfo)) +
int16.to_int(exist_info_tcis(ExistInfo))
else
NumExtraArgs0 = 0
),
ArgTypes = FunctorDesc ^ du_functor_arg_types,
PseudoTypeInfo = get_pti_from_arg_types(ArgTypes, Index),
get_arg_type_info(Term, TypeInfo, FunctorDesc, PseudoTypeInfo,
ArgTypeInfo),
( if
( SecTagLocn = stag_none
; SecTagLocn = stag_none_direct_arg
; high_level_data
)
then
NumExtraArgs = NumExtraArgs0
else
NumExtraArgs = NumExtraArgs0 + 1
),
get_subterm(Term, TypeInfo, FunctorDesc, Index, NumExtraArgs,
ArgTypeInfo, Arg).
:- func get_arg_univ(T, type_info, sectag_locn, du_functor_desc, int) = univ.
get_arg_univ(Term, TypeInfo, SecTagLocn, FunctorDesc, Index) = Univ :-
get_arg(Term, TypeInfo, SecTagLocn, FunctorDesc, Index, Arg),
type_to_univ(Arg, Univ).
%---------------------%
:- pred get_arg_type_info(T::in, type_info::in, du_functor_desc::in,
pseudo_type_info::in, type_info::out) is det.
get_arg_type_info(Term, TypeInfoParams, FunctorDesc, PseudoTypeInfo,
ArgTypeInfo) :-
( if pseudo_type_info_is_variable(PseudoTypeInfo, VarNum) then
get_type_info_for_var(TypeInfoParams, VarNum, Term,
FunctorDesc, ArgTypeInfo)
else
CastTypeInfo = type_info_from_pseudo_type_info(PseudoTypeInfo),
TypeCtorInfo = get_type_ctor_info(CastTypeInfo),
( if type_ctor_is_variable_arity(TypeCtorInfo) then
Arity = type_info_get_higher_order_arity(CastTypeInfo),
StartRegionSize = 2
else
Arity = TypeCtorInfo ^ type_ctor_arity,
StartRegionSize = 1
),
ArgTypeInfo0 = new_type_info(CastTypeInfo, Arity),
get_arg_type_info_2(TypeInfoParams, CastTypeInfo, Term, FunctorDesc,
StartRegionSize, 0, Arity, ArgTypeInfo0, ArgTypeInfo)
).
:- pred get_arg_type_info_2(type_info::in, type_info::in, T::in,
du_functor_desc::in, int::in, int::in, int::in,
type_info::di, type_info::uo) is det.
get_arg_type_info_2(TypeInfoParams, TypeInfo, Term, FunctorDesc,
Offset, I, Max, !ArgTypeInfo) :-
( if I < Max then
get_pti_from_type_info_index(TypeInfo, Offset, I, PTI),
get_arg_type_info(Term, TypeInfoParams, FunctorDesc, PTI, ETypeInfo),
set_type_info_index(Offset, I, ETypeInfo, !ArgTypeInfo),
get_arg_type_info_2(TypeInfoParams, TypeInfo, Term, FunctorDesc,
Offset, I + 1, Max, !ArgTypeInfo)
else
true
).
%---------------------%
:- func type_info_get_higher_order_arity(type_info) = int.
:- pragma foreign_proc("C#",
type_info_get_higher_order_arity(PseudoTypeInfo::in) = (Arity::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
runtime.TypeInfo_Struct ti = (runtime.TypeInfo_Struct) PseudoTypeInfo;
Arity = ti.args.Length;
").
:- pragma foreign_proc("Java",
type_info_get_higher_order_arity(PseudoTypeInfo::in) = (Arity::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
jmercury.runtime.TypeInfo_Struct ti =
(jmercury.runtime.TypeInfo_Struct) PseudoTypeInfo;
Arity = ti.args.length;
").
type_info_get_higher_order_arity(_) = 1 :-
det_unimplemented("type_info_get_higher_order_arity").
%---------------------%
% Make a new type-info with the given arity, using the given type_info
% as the basis.
%
:- func new_type_info(type_info::in, int::in) = (type_info::uo) is det.
new_type_info(TypeInfo, _) = NewTypeInfo :-
unsafe_promise_unique(TypeInfo, NewTypeInfo),
det_unimplemented("new_type_info").
:- pragma foreign_proc("C#",
new_type_info(OldTypeInfo::in, _Arity::in) = (NewTypeInfo::uo),
[will_not_call_mercury, promise_pure, thread_safe],
"
NewTypeInfo = OldTypeInfo.copy();
").
:- pragma foreign_proc("Java",
new_type_info(OldTypeInfo::in, _Arity::in) = (NewTypeInfo::uo),
[will_not_call_mercury, promise_pure, thread_safe],
"
NewTypeInfo = OldTypeInfo.copy();
").
%---------------------%
% Get the pseudo-typeinfo at the given index from the argument types.
%
:- func get_pti_from_arg_types(arg_types, int) = pseudo_type_info.
:- pragma no_determinism_warning(func(get_pti_from_arg_types/2)).
get_pti_from_arg_types(_, _) = _ :-
sorry($module, "get_pti_from_arg_types").
:- pragma foreign_proc("Java",
get_pti_from_arg_types(ArgTypes::in, Index::in) = (ArgTypeInfo::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
ArgTypeInfo = ArgTypes[Index];
").
:- pragma foreign_proc("C#",
get_pti_from_arg_types(ArgTypes::in, Index::in) = (ArgTypeInfo::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
ArgTypeInfo = ArgTypes[Index];
").
%---------------------%
% Get the pseudo-typeinfo at the given index from a type-info.
%
:- pred get_pti_from_type_info_index(type_info::in, int::in, int::in,
pseudo_type_info::out) is det.
:- pragma no_determinism_warning(pred(get_pti_from_type_info_index/4)).
get_pti_from_type_info_index(_, _, _, _) :-
private_builtin.sorry("get_pti_from_type_info_index").
:- pragma foreign_proc("C#",
get_pti_from_type_info_index(TypeInfo::in, _Offset::in, Index::in,
PTI::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
PTI = TypeInfo.args[Index];
").
:- pragma foreign_proc("Java",
get_pti_from_type_info_index(TypeInfo::in, _Offset::in, Index::in,
PTI::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
PTI = TypeInfo.args[Index];
").
%---------------------%
% Get the type info for a particular type variable number
% (it might be in the type_info or in the term itself).
%
:- pred get_type_info_for_var(type_info::in, int::in, T::in,
du_functor_desc::in, type_info::out) is det.
get_type_info_for_var(TypeInfo, VarNum, Term, FunctorDesc, ArgTypeInfo) :-
( if type_variable_is_univ_quant(VarNum) then
ArgTypeInfo = type_info_index_as_ti(TypeInfo, VarNum)
else
% Existentially qualified.
( if get_du_functor_exist_info(FunctorDesc, ExistInfo0) then
ExistInfo = ExistInfo0
else
unexpected($pred, "no exist_info")
),
% We count variables from one so we need to add 1.
ExistVarNum = VarNum - first_exist_quant_varnum + 1,
ExistLocn = typeinfo_locns_index(ExistVarNum, ExistInfo),
Slot = ExistLocn ^ exist_arg_num,
Offset = int16.to_int(ExistLocn ^ exist_offset_in_tci),
( if Offset < 0 then
ArgTypeInfo = get_type_info_from_term(Term, Slot)
else
TypeClassInfo = get_typeclass_info_from_term(Term, Slot),
ArgTypeInfo = typeclass_info_type_info(TypeClassInfo, Offset)
)
).
%---------------------%
% An unchecked cast to type_info (for pseudo-typeinfos).
%
:- func type_info_from_pseudo_type_info(pseudo_type_info) = type_info.
type_info_from_pseudo_type_info(PseudoTypeInfo) = TypeInfo :-
private_builtin.unsafe_type_cast(PseudoTypeInfo, TypeInfo).
:- pragma foreign_proc("C#",
type_info_from_pseudo_type_info(PseudoTypeInfo::in) = (TypeInfo::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
runtime.TypeCtorInfo_Struct tci =
PseudoTypeInfo as runtime.TypeCtorInfo_Struct;
if (tci != null) {
TypeInfo = new runtime.TypeInfo_Struct(tci);
} else {
TypeInfo = (runtime.TypeInfo_Struct) PseudoTypeInfo;
}
").
:- pragma foreign_proc("Java",
type_info_from_pseudo_type_info(PseudoTypeInfo::in) = (TypeInfo::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
if (PseudoTypeInfo instanceof jmercury.runtime.TypeCtorInfo_Struct) {
TypeInfo = new jmercury.runtime.TypeInfo_Struct(
(jmercury.runtime.TypeCtorInfo_Struct) PseudoTypeInfo);
} else {
TypeInfo = (jmercury.runtime.TypeInfo_Struct) PseudoTypeInfo;
}
").
%---------------------%
:- some [ArgT] pred get_subterm(T::in, type_info::in, du_functor_desc::in,
int::in, int::in, type_info::in, ArgT::out) is det.
get_subterm(_, _, _, _, _, _, -1) :-
det_unimplemented("get_subterm").
:- pragma foreign_proc("C#",
get_subterm(Term::in, TypeInfo::in, FunctorDesc::in,
Index::in, NumExtraArgs::in, ArgTypeInfo::in, Arg::out),
[will_not_call_mercury, promise_pure, thread_safe, may_not_duplicate],
"
// Mention TypeInfo_for_U to avoid a warning.
Arg = ML_get_subterm(Term, TypeInfo, FunctorDesc, Index, NumExtraArgs);
TypeInfo_for_ArgT = ArgTypeInfo;
").
:- pragma foreign_proc("Java",
get_subterm(Term::in, TypeInfo::in, FunctorDesc::in,
Index::in, NumExtraArgs::in, ArgTypeInfo::in, Arg::out),
[will_not_call_mercury, promise_pure, thread_safe, may_not_duplicate],
"
// Mention TypeInfo_for_T to avoid a warning.
// Currently we use reflection to extract the field.
// It probably would be more efficient to generate
// a method for each class to return its n'th field.
Arg = ML_get_subterm(Term, TypeInfo, FunctorDesc, Index, NumExtraArgs);
assert Arg != null;
TypeInfo_for_ArgT = ArgTypeInfo;
").
:- pragma foreign_code("C#",
"
private static object
ML_get_subterm(object term,
TypeInfo_Struct type_info,
DuFunctorDesc functor_desc,
int index, int num_extra_args)
{
if (term is object[]) {
int i = index + num_extra_args;
return ((object[]) term)[i];
} else {
return ML_get_subterm_non_array(term, type_info, functor_desc,
index, num_extra_args);
}
}
private static object
ML_get_subterm_non_array(object term,
TypeInfo_Struct type_info,
DuFunctorDesc functor_desc,
int index, int num_extra_args)
{
TypeCtorInfo_Struct base_tc = type_info.type_ctor.type_ctor_base;
string field_name;
if (base_tc != null) {
// For subtypes, we need to get the corresponding DuFunctorDesc
// from the base type ctor.
DuFunctorDesc base_functor_desc =
ML_get_functor_desc_by_tags(base_tc,
functor_desc.du_functor_primary,
functor_desc.du_functor_secondary);
field_name =
ML_get_field_name_by_index(base_functor_desc,
index, num_extra_args);
} else {
field_name =
ML_get_field_name_by_index(functor_desc,
index, num_extra_args);
}
return ML_get_subterm_by_field_name(term, field_name);
}
private static DuFunctorDesc
ML_get_functor_desc_by_tags(TypeCtorInfo_Struct base_tc,
byte ptag, int sectag)
{
DuPtagLayout ptag_layout = base_tc.index_or_search_ptag_layout(ptag);
if (sectag == -1) {
sectag = 0;
}
return ptag_layout.index_or_search_sectag_functor(sectag);
}
private static string
ML_get_field_name_by_index(DuFunctorDesc functor_desc,
int index, int num_extra_args)
{
// Look up the field name if it exists, otherwise recreate the field
// name that would have been used.
string field_name = null;
if (functor_desc.du_functor_arg_names != null) {
field_name = functor_desc.du_functor_arg_names[index];
}
if (field_name != null) {
field_name = ML_name_mangle(field_name);
} else {
// The F<i> field variables are numbered from 1.
int i = 1 + index + num_extra_args;
field_name = ""F"" + i;
}
return field_name;
}
private static object
ML_get_subterm_by_field_name(object term, string field_name)
{
System.Reflection.FieldInfo f = term.GetType().GetField(field_name);
if (f == null) {
throw new System.Exception(""no such field: "" + field_name);
}
return f.GetValue(term);
}
").
:- pragma foreign_code("Java",
"
private static Object
ML_get_subterm(Object term,
jmercury.runtime.TypeInfo_Struct type_info,
jmercury.runtime.DuFunctorDesc functor_desc,
int index, int num_extra_args)
{
if (term instanceof Object[]) {
int i = index + num_extra_args;
return ((Object[]) term)[i];
} else {
return ML_get_subterm_non_array(term, type_info, functor_desc,
index, num_extra_args);
}
}
private static Object
ML_get_subterm_non_array(Object term,
jmercury.runtime.TypeInfo_Struct type_info,
jmercury.runtime.DuFunctorDesc functor_desc,
int index, int num_extra_args)
{
jmercury.runtime.TypeCtorInfo_Struct base_tc =
type_info.type_ctor.type_ctor_base;
String field_name;
if (base_tc != null) {
// For subtypes, we need to get the corresponding DuFunctorDesc in
// the base type ctor.
jmercury.runtime.DuFunctorDesc base_functor_desc =
ML_get_functor_desc_by_tags(base_tc,
functor_desc.du_functor_primary,
functor_desc.du_functor_secondary);
field_name =
ML_get_field_name_by_index(base_functor_desc,
index, num_extra_args);
} else {
field_name =
ML_get_field_name_by_index(functor_desc,
index, num_extra_args);
}
return ML_get_subterm_by_field_name(term, field_name);
}
private static jmercury.runtime.DuFunctorDesc
ML_get_functor_desc_by_tags(jmercury.runtime.TypeCtorInfo_Struct base_tc,
byte ptag, int sectag)
{
jmercury.runtime.DuPtagLayout ptag_layout =
base_tc.index_or_search_ptag_layout(ptag);
if (sectag == -1) {
sectag = 0;
}
return ptag_layout.index_or_search_sectag_functor(sectag);
}
private static String
ML_get_field_name_by_index(jmercury.runtime.DuFunctorDesc functor_desc,
int index, int num_extra_args)
{
// Look up the field name if it exists, otherwise recreate the field
// name that would have been used.
String field_name = null;
if (functor_desc.du_functor_arg_names != null) {
field_name = functor_desc.du_functor_arg_names[index];
}
if (field_name != null) {
field_name = ML_name_mangle(field_name);
} else {
// The F<i> field variables are numbered from 1.
int i = 1 + index + num_extra_args;
field_name = ""F"" + i;
}
return field_name;
}
private static Object
ML_get_subterm_by_field_name(Object term, String field_name)
{
try {
Field f = term.getClass().getDeclaredField(field_name);
return f.get(term);
} catch (IllegalAccessException e) {
throw new Error(e);
} catch (NoSuchFieldException e) {
throw new Error(e);
}
}
").
%---------------------%
:- some [ArgT] pred get_tuple_subterm(T::in, int::in, type_info::in, ArgT::out)
is det.
:- pragma no_determinism_warning(pred(get_tuple_subterm/4)).
get_tuple_subterm(_, _, _, -1) :-
private_builtin.sorry("get_tuple_subterm").
:- pragma foreign_proc("C#",
get_tuple_subterm(Term::in, Index::in, ArgTypeInfo::in, Arg::out),
[will_not_call_mercury, promise_pure, thread_safe, tabled_for_io],
"
Arg = ((object[]) Term)[Index];
TypeInfo_for_ArgT = ArgTypeInfo;
").
:- pragma foreign_proc("Java",
get_tuple_subterm(Term::in, Index::in, ArgTypeInfo::in, Arg::out),
[will_not_call_mercury, promise_pure, thread_safe, tabled_for_io],
"
Arg = ((Object[]) Term)[Index];
TypeInfo_for_ArgT = ArgTypeInfo;
").
%---------------------%
% Test whether a (pseudo-) type info is variable.
% The argument type is pseudo_type_info, because when we call this,
% we have a pseudo_type_info but aren't sure if it is actually
% a variable or a type_info.
%
:- pred pseudo_type_info_is_variable(pseudo_type_info::in, int::out)
is semidet.
pseudo_type_info_is_variable(_, -1) :-
semidet_unimplemented("pseudo_type_info_is_variable").
:- pragma foreign_proc("C#",
pseudo_type_info_is_variable(TypeInfo::in, VarNum::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
VarNum = TypeInfo.variable_number;
SUCCESS_INDICATOR = (VarNum != -1);
").
:- pragma foreign_proc("Java",
pseudo_type_info_is_variable(TypeInfo::in, VarNum::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
VarNum = TypeInfo.variable_number;
SUCCESS_INDICATOR = (VarNum != -1);
// Variables number from one, not zero.
// This is in keeping with mercury_type_info.h.
assert VarNum != 0;
").
%---------------------%
% Tests for universal and existentially quantified variables.
% (The existential version is not used.)
%
:- pred type_variable_is_univ_quant(int::in) is semidet.
% :- pred type_variable_is_exist_quant(int::in) is semidet.
% In keeping with mercury_type_info.h.
type_variable_is_univ_quant(X) :- X =< last_univ_quant_varnum.
% type_variable_is_exist_quant(X) :- X >= first_exist_quant_varnum.
:- func last_univ_quant_varnum = int.
last_univ_quant_varnum = 512.
:- func first_exist_quant_varnum = int.
first_exist_quant_varnum = 513.
:- pragma foreign_code("C#", "
public const int last_univ_quant_varnum = 512;
public const int first_exist_quant_varnum = 513;
").
:- pragma foreign_code("Java", "
public static final int last_univ_quant_varnum = 512;
public static final int first_exist_quant_varnum = 513;
").
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- pred same_pointer_value(T::in, T::in) is semidet.
same_pointer_value(X, Y) :-
same_pointer_value_untyped(X, Y).
:- pred same_pointer_value_untyped(T::in, U::in) is semidet.
:- pragma foreign_proc("C#",
same_pointer_value_untyped(T1::in, T2::in),
[will_not_call_mercury, promise_pure, thread_safe],
"
SUCCESS_INDICATOR = (T1 == T2);
").
:- pragma foreign_proc("C",
same_pointer_value_untyped(T1::in, T2::in),
[will_not_call_mercury, promise_pure, thread_safe],
"
SUCCESS_INDICATOR = (T1 == T2);
").
:- pragma foreign_proc("Java",
same_pointer_value_untyped(T1::in, T2::in),
[will_not_call_mercury, promise_pure, thread_safe],
"
SUCCESS_INDICATOR = (T1 == T2);
").
same_pointer_value_untyped(_, _) :-
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
private_builtin.sorry("same_pointer_value_untyped").
%---------------------------------------------------------------------------%
:- func get_target_lang_rep(T) = string.
:- pragma foreign_proc("C",
get_target_lang_rep(Term::in) = (S::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
// This should be kept in sync with the MR_TYEPCTOR_REP_FOREIGN
// case in runtime/mercury_ml_expand_body.h.
char buf[256];
MR_snprintf(buf, 256, ""%p"", (void *) Term);
MR_make_aligned_string_copy(S, buf);
").
:- pragma foreign_proc("C#",
get_target_lang_rep(Term::in) = (S::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
if (Term == null) {
S = ""null"";
} else {
S = Term.ToString();
}
").
:- pragma foreign_proc("Java",
get_target_lang_rep(Term::in) = (S::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
if (Term == null) {
S = ""null"";
} else {
S = Term.toString();
}
").
get_target_lang_rep(_) = "some_foreign_value".
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- func get_primary_tag(T) = uint8.
:- pragma foreign_proc("C#",
get_primary_tag(_X::in) = (Tag::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
// For the C# backend, there is never a primary tag.
Tag = 0;
").
:- pragma foreign_proc("Java",
get_primary_tag(_X::in) = (Tag::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
// For the Java backend, there is never a primary tag.
Tag = 0;
").
get_primary_tag(_) = 0u8 :-
det_unimplemented("get_primary_tag").
%---------------------------------------------------------------------------%
:- func get_remote_secondary_tag(T) = int.
:- pragma foreign_proc("C#",
get_remote_secondary_tag(X::in) = (Tag::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Tag = (int) X.GetType().GetField(""data_tag"").GetValue(X);
").
:- pragma foreign_proc("Java",
get_remote_secondary_tag(X::in) = (Tag::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
// If there is a secondary tag, it will be in a member called
// `data_tag', which we obtain by reflection.
try {
Tag = X.getClass().getField(""data_tag"").getInt(X);
}
catch (java.lang.Exception e) {
throw new java.lang.RuntimeException(
""get_remote_secondary_tag: `data_tag' not "" +
""found"");
}
").
get_remote_secondary_tag(_) = 0 :-
det_unimplemented("get_remote_secondary_tag").
%---------------------------------------------------------------------------%
:- type sectag_locn
---> stag_none
; stag_none_direct_arg
; stag_local_rest_of_word
% We now use rtti_implementation.m for the C# and Java grades.
% Type representations do not use stag_local_bits in those grades.
% ; stag_local_bits
; stag_remote
; stag_variable.
% This type is not used (yet?).
% :- type du_sectag_alternatives ---> du_sectag_alternatives(c_pointer).
% :- pragma foreign_type("C#", du_sectag_alternatives,
% "runtime.DuFunctorDesc[]").
% :- pragma foreign_type("Java", du_sectag_alternatives,
% "jmercury.runtime.DuFunctorDesc[]").
% XXX just use the same names as the C runtime
:- type ptag_entry ---> ptag_entry(c_pointer).
:- pragma foreign_type("C#", ptag_entry, "runtime.DuPtagLayout").
:- pragma foreign_type("Java", ptag_entry, "jmercury.runtime.DuPtagLayout").
:- type arg_types ---> arg_types(c_pointer).
:- pragma foreign_type("C#", arg_types, "runtime.PseudoTypeInfo[]").
:- pragma foreign_type("Java", arg_types, "jmercury.runtime.PseudoTypeInfo[]").
:- type arg_names ---> arg_names(c_pointer).
:- pragma foreign_type("C#", arg_names, "string[]").
:- pragma foreign_type("Java", arg_names, "java.lang.String[]").
:- type exist_info ---> exist_info(c_pointer).
:- pragma foreign_type("C#", exist_info, "runtime.DuExistInfo").
:- pragma foreign_type("Java", exist_info, "jmercury.runtime.DuExistInfo").
:- type typeinfo_locn ---> typeinfo_locn(c_pointer).
:- pragma foreign_type("C#", typeinfo_locn, "runtime.DuExistLocn").
:- pragma foreign_type("Java", typeinfo_locn, "jmercury.runtime.DuExistLocn").
%---------------------%
:- pred det_index_or_search_ptag_layout(type_ctor_info::in, uint8::in,
ptag_entry::out) is det.
det_index_or_search_ptag_layout(TypeCtorInfo, PTag, PTagEntry) :-
( if index_or_search_ptag_layout(TypeCtorInfo, PTag, PTagEntry0) then
PTagEntry = PTagEntry0
else
unexpected($pred, "no functor for ptag")
).
:- pred index_or_search_ptag_layout(type_ctor_info::in, uint8::in,
ptag_entry::out) is semidet.
:- pragma no_determinism_warning(pred(index_or_search_ptag_layout/3)).
index_or_search_ptag_layout(_, _, _) :-
private_builtin.sorry("index_or_search_ptag_layout").
:- pragma foreign_proc("C#",
index_or_search_ptag_layout(TypeCtorInfo::in, PTag::in, PTagEntry::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
PTagEntry = TypeCtorInfo.index_or_search_ptag_layout(PTag);
SUCCESS_INDICATOR = (PTagEntry != null);
").
:- pragma foreign_proc("Java",
index_or_search_ptag_layout(TypeCtorInfo::in, PTag::in, PTagEntry::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
PTagEntry = TypeCtorInfo.index_or_search_ptag_layout(PTag);
SUCCESS_INDICATOR = (PTagEntry != null);
").
%---------------------%
:- func sectag_locn(ptag_entry) = sectag_locn.
:- pragma no_determinism_warning(func(sectag_locn/1)).
sectag_locn(_) = _ :-
private_builtin.sorry("sectag_locn").
:- pragma foreign_proc("C#",
sectag_locn(PTagEntry::in) = (SectagLocn::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
SectagLocn = (Sectag_locn_0) PTagEntry.sectag_locn;
").
:- pragma foreign_proc("Java",
sectag_locn(PTagEntry::in) = (SectagLocn::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
jmercury.runtime.Sectag_Locn SL_struct = PTagEntry.sectag_locn;
SectagLocn = new rtti_implementation.Sectag_locn_0(SL_struct.value);
").
%---------------------%
:- pred index_sectag_functor(ptag_entry::in, int::in, du_functor_desc::out)
is det.
:- pragma no_determinism_warning(pred(index_sectag_functor/3)).
index_sectag_functor(_, _, _) :-
private_builtin.sorry("index_sectag_functor").
:- pragma foreign_proc("C#",
index_sectag_functor(PTagEntry::in, SecTag::in, FunctorDesc::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
FunctorDesc = PTagEntry.sectag_alternatives[SecTag];
").
:- pragma foreign_proc("Java",
index_sectag_functor(PTagEntry::in, SecTag::in, FunctorDesc::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
FunctorDesc = PTagEntry.sectag_alternatives[SecTag];
").
%---------------------%
:- pred det_index_or_search_sectag_functor(ptag_entry::in, int::in,
du_functor_desc::out) is det.
det_index_or_search_sectag_functor(PTagEntry, SecTag, FunctorDesc) :-
( if index_or_search_sectag_functor(PTagEntry, SecTag, FunctorDesc0) then
FunctorDesc = FunctorDesc0
else
unexpected($pred, "no functor for sectag")
).
:- pred index_or_search_sectag_functor(ptag_entry::in, int::in,
du_functor_desc::out) is semidet.
:- pragma no_determinism_warning(pred(index_or_search_sectag_functor/3)).
index_or_search_sectag_functor(_, _, _) :-
private_builtin.sorry("index_or_search_sectag_alternatives").
:- pragma foreign_proc("C#",
index_or_search_sectag_functor(PTagEntry::in, SecTag::in,
FunctorDesc::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
FunctorDesc = PTagEntry.index_or_search_sectag_functor(SecTag);
SUCCESS_INDICATOR = (FunctorDesc != null);
").
:- pragma foreign_proc("Java",
index_or_search_sectag_functor(PTagEntry::in, SecTag::in,
FunctorDesc::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
FunctorDesc = PTagEntry.index_or_search_sectag_functor(SecTag);
SUCCESS_INDICATOR = (FunctorDesc != null);
").
%---------------------%
:- func typeinfo_locns_index(int, exist_info) = typeinfo_locn.
:- pragma no_determinism_warning(func(typeinfo_locns_index/2)).
typeinfo_locns_index(_, _) = _ :-
private_builtin.sorry("typeinfo_locns_index").
:- pragma foreign_proc("C#",
typeinfo_locns_index(VarNum::in, ExistInfo::in) = (TypeInfoLocn::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
// Variables count from one.
TypeInfoLocn = ExistInfo.exist_typeinfo_locns[VarNum - 1];
").
:- pragma foreign_proc("Java",
typeinfo_locns_index(VarNum::in, ExistInfo::in) = (TypeInfoLocn::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
// Variables count from one.
TypeInfoLocn = ExistInfo.exist_typeinfo_locns[VarNum - 1];
").
%---------------------%
:- func exist_info_typeinfos_plain(exist_info) = int16.
exist_info_typeinfos_plain(_) = -1i16 :-
det_unimplemented("exist_info_typeinfos_plain").
:- pragma foreign_proc("C#",
exist_info_typeinfos_plain(ExistInfo::in) = (TypeInfosPlain::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
TypeInfosPlain = ExistInfo.exist_typeinfos_plain;
").
:- pragma foreign_proc("Java",
exist_info_typeinfos_plain(ExistInfo::in) = (TypeInfosPlain::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
TypeInfosPlain = ExistInfo.exist_typeinfos_plain;
").
%---------------------%
:- func exist_info_tcis(exist_info) = int16.
exist_info_tcis(_) = -1i16 :-
det_unimplemented("exist_info_tcis").
:- pragma foreign_proc("C#",
exist_info_tcis(ExistInfo::in) = (TCIs::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
TCIs = ExistInfo.exist_tcis;
").
:- pragma foreign_proc("Java",
exist_info_tcis(ExistInfo::in) = (TCIs::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
TCIs = ExistInfo.exist_tcis;
").
%---------------------%
:- func exist_arg_num(typeinfo_locn) = int16.
exist_arg_num(_) = -1i16 :-
det_unimplemented("exist_arg_num").
:- pragma foreign_proc("C#",
exist_arg_num(TypeInfoLocn::in) = (ArgNum::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
ArgNum = TypeInfoLocn.exist_arg_num;
").
:- pragma foreign_proc("Java",
exist_arg_num(TypeInfoLocn::in) = (ArgNum::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
ArgNum = TypeInfoLocn.exist_arg_num;
").
%---------------------%
:- func exist_offset_in_tci(typeinfo_locn) = int16.
exist_offset_in_tci(_) = -1i16 :-
det_unimplemented("exist_offset_in_tci").
:- pragma foreign_proc("C#",
exist_offset_in_tci(TypeInfoLocn::in) = (ArgNum::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
ArgNum = TypeInfoLocn.exist_offset_in_tci;
").
:- pragma foreign_proc("Java",
exist_offset_in_tci(TypeInfoLocn::in) = (ArgNum::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
ArgNum = TypeInfoLocn.exist_offset_in_tci;
").
%---------------------%
:- func get_type_info_from_term(U, int16) = type_info.
:- pragma no_determinism_warning(func(get_type_info_from_term/2)).
get_type_info_from_term(_, _) = _ :-
private_builtin.sorry("get_type_info_from_term").
:- pragma foreign_proc("C#",
get_type_info_from_term(Term::in, Index::in) = (TypeInfo::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
if (Term is object[]) {
TypeInfo = (runtime.TypeInfo_Struct) ((object[]) Term)[Index];
} else {
// The F<i> field variables are numbered from 1.
string fieldName = ""F"" + (1 + Index);
System.Reflection.FieldInfo f = Term.GetType().GetField(fieldName);
if (f == null) {
throw new System.Exception(""no such field: "" + fieldName);
}
TypeInfo = (runtime.TypeInfo_Struct) f.GetValue(Term);
}
").
:- pragma foreign_proc("Java",
get_type_info_from_term(Term::in, Index::in) = (TypeInfo::out),
[will_not_call_mercury, promise_pure, thread_safe, may_not_duplicate],
"
if (Term instanceof Object[]) {
TypeInfo = (jmercury.runtime.TypeInfo_Struct) ((Object[]) Term)[Index];
} else {
try {
// The F<i> field variables are numbered from 1.
int i = 1 + Index;
Field f = Term.getClass().getDeclaredField(""F"" + i);
TypeInfo = (jmercury.runtime.TypeInfo_Struct) f.get(Term);
} catch (IllegalAccessException e) {
throw new Error(e);
} catch (NoSuchFieldException e) {
throw new Error(e);
}
}
").
%---------------------%
:- func get_typeclass_info_from_term(U, int16) = typeclass_info.
:- pragma no_determinism_warning(func(get_typeclass_info_from_term/2)).
get_typeclass_info_from_term(_, _) = _ :-
private_builtin.sorry("get_type_info_from_term").
:- pragma foreign_proc("C#",
get_typeclass_info_from_term(Term::in, Index::in) = (TypeClassInfo::out),
[will_not_call_mercury, promise_pure, thread_safe, may_not_duplicate],
"
if (Term is object[]) {
TypeClassInfo = /*typeclass_info*/ (object[]) ((object[]) Term)[Index];
} else {
// The F<i> field variables are numbered from 1.
string fieldName = ""F"" + (1 + Index);
System.Reflection.FieldInfo f = Term.GetType().GetField(fieldName);
if (f == null) {
throw new System.Exception(""no such field: "" + fieldName);
}
TypeClassInfo = /*typeclass_info*/ (object[]) f.GetValue(Term);
}
").
:- pragma foreign_proc("Java",
get_typeclass_info_from_term(Term::in, Index::in) = (TypeClassInfo::out),
[will_not_call_mercury, promise_pure, thread_safe, may_not_duplicate],
"
if (Term instanceof Object[]) {
TypeClassInfo = /*typeclass_info*/ (Object[]) ((Object[]) Term)[Index];
} else {
try {
// The F<i> field variables are numbered from 1.
int i = 1 + Index;
Field f = Term.getClass().getDeclaredField(""F"" + i);
TypeClassInfo = /*typeclass_info*/ (Object[]) f.get(Term);
} catch (IllegalAccessException e) {
throw new Error(e);
} catch (NoSuchFieldException e) {
throw new Error(e);
}
}
").
%---------------------%
:- func typeclass_info_type_info(typeclass_info, int) = type_info.
typeclass_info_type_info(TypeClassInfo, Index) = TypeInfo :-
private_builtin.unsafe_type_cast(TypeClassInfo, PrivateTypeClassInfo),
private_builtin.type_info_from_typeclass_info(PrivateTypeClassInfo, Index,
PrivateTypeInfo),
private_builtin.unsafe_type_cast(PrivateTypeInfo, TypeInfo).
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
%
% The generic definitions of var_arity_type_info_index_as_ti/pti assume
% that variable arity type_infos store the arity in the first word but
% that is not true for the jmercury.runtime.TypeInfo_Struct in Java.
%
% Keep this in sync with the Java version of type_info_index_as_ti/pti.
%
:- func var_arity_type_info_index_as_ti(type_info, int) = type_info.
:- pragma foreign_proc("C#",
var_arity_type_info_index_as_ti(TypeInfo::in, VarNum::in)
= (TypeInfoAtIndex::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
TypeInfoAtIndex = (runtime.TypeInfo_Struct) TypeInfo.args[VarNum - 1];
").
:- pragma foreign_proc("Java",
var_arity_type_info_index_as_ti(TypeInfo::in, VarNum::in)
= (TypeInfoAtIndex::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
assert TypeInfo.args != null;
// Variable numbers count from one.
assert VarNum > 0;
TypeInfoAtIndex =
(jmercury.runtime.TypeInfo_Struct) TypeInfo.args[VarNum - 1];
").
var_arity_type_info_index_as_ti(TypeInfo, Index) =
type_info_index_as_ti(TypeInfo, Index + 1).
%---------------------%
:- func var_arity_type_info_index_as_pti(type_info, int) = pseudo_type_info.
:- pragma foreign_proc("C#",
var_arity_type_info_index_as_pti(TypeInfo::in, VarNum::in)
= (PseudoTypeInfoAtIndex::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
PseudoTypeInfoAtIndex = TypeInfo.args[VarNum - 1];
").
:- pragma foreign_proc("Java",
var_arity_type_info_index_as_pti(TypeInfo::in, VarNum::in)
= (PseudoTypeInfoAtIndex::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
assert TypeInfo.args != null;
// Variable numbers count from one.
assert VarNum > 0;
PseudoTypeInfoAtIndex = TypeInfo.args[VarNum - 1];
").
var_arity_type_info_index_as_pti(TypeInfo, Index) =
type_info_index_as_pti(TypeInfo, Index + 1).
%---------------------%
:- func type_info_index_as_ti(type_info, int) = type_info.
:- pragma foreign_proc("C#",
type_info_index_as_ti(TypeInfo::in, VarNum::in) = (TypeInfoAtIndex::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
TypeInfoAtIndex = (runtime.TypeInfo_Struct) TypeInfo.args[VarNum - 1];
").
:- pragma foreign_proc("Java",
type_info_index_as_ti(TypeInfo::in, VarNum::in) = (TypeInfoAtIndex::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
assert TypeInfo.variable_number == -1;
assert TypeInfo.args != null;
// Variable numbers count from one.
assert VarNum > 0;
TypeInfoAtIndex =
(jmercury.runtime.TypeInfo_Struct) TypeInfo.args[VarNum - 1];
").
type_info_index_as_ti(TypeInfo, _) = TypeInfo :-
% This is an "unimplemented" definition in Mercury, which will be
% used by default.
det_unimplemented("type_info_index").
%---------------------%
:- func type_info_index_as_pti(type_info, int) = pseudo_type_info.
:- pragma foreign_proc("C#",
type_info_index_as_pti(TypeInfo::in, VarNum::in) = (PseudoTypeInfo::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
PseudoTypeInfo = TypeInfo.args[VarNum - 1];
").
:- pragma foreign_proc("Java",
type_info_index_as_pti(TypeInfo::in, VarNum::in) = (PseudoTypeInfo::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
assert TypeInfo.variable_number == -1;
assert TypeInfo.args != null;
// Variable numbers count from one.
assert VarNum > 0;
PseudoTypeInfo = TypeInfo.args[VarNum - 1];
").
type_info_index_as_pti(TypeInfo, _) = PseudoTypeInfo :-
det_unimplemented("type_info_index_as_pti"),
private_builtin.unsafe_type_cast(TypeInfo, PseudoTypeInfo).
%---------------------%
:- pred set_type_info_index(int::in, int::in, type_info::in,
type_info::di, type_info::uo) is det.
:- pragma foreign_proc("C#",
set_type_info_index(_Offset::in, Index::in, Value::in,
TypeInfo0::di, TypeInfo::uo),
[will_not_call_mercury, promise_pure, thread_safe],
"
TypeInfo0.args[Index] = Value;
TypeInfo = TypeInfo0;
").
:- pragma foreign_proc("Java",
set_type_info_index(_Offset::in, Index::in, Value::in,
TypeInfo0::di, TypeInfo::uo),
[will_not_call_mercury, promise_pure, thread_safe],
"
TypeInfo0.args[Index] = Value;
TypeInfo = TypeInfo0;
").
set_type_info_index(_, _, _, TypeInfo, TypeInfo) :-
det_unimplemented("set_type_info_index").
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- func type_ctor_arity(type_ctor_info) = int.
:- pragma foreign_proc("C#",
type_ctor_arity(TypeCtorInfo::in) = (Arity::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Arity = TypeCtorInfo.arity;
").
:- pragma foreign_proc("Java",
type_ctor_arity(TypeCtorInfo::in) = (Arity::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Arity = TypeCtorInfo.arity;
").
:- pragma foreign_proc("C",
type_ctor_arity(TypeCtorInfo::in) = (Arity::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
MR_TypeCtorInfo tci = (MR_TypeCtorInfo) TypeCtorInfo;
Arity = tci->MR_type_ctor_arity;
").
type_ctor_arity(_) = _ :-
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
private_builtin.sorry("type_ctor_arity").
%---------------------------------------------------------------------------%
:- func type_ctor_unify_pred(type_ctor_info) = unify_or_compare_pred.
:- pragma foreign_proc("C#",
type_ctor_unify_pred(TypeCtorInfo::in) = (UnifyPred::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
UnifyPred = TypeCtorInfo.unify_pred;
").
:- pragma foreign_proc("C",
type_ctor_unify_pred(TypeCtorInfo::in) = (UnifyPred::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
MR_TypeCtorInfo tci;
tci = (MR_TypeCtorInfo) TypeCtorInfo;
UnifyPred = (MR_Integer) tci->MR_type_ctor_unify_pred;
").
:- pragma foreign_proc("Java",
type_ctor_unify_pred(TypeCtorInfo::in) = (UnifyPred::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
UnifyPred = TypeCtorInfo.unify_pred;
").
type_ctor_unify_pred(_) = unify_or_compare_pred :-
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
private_builtin.sorry("type_ctor_unify_pred").
%---------------------------------------------------------------------------%
:- func type_ctor_compare_pred(type_ctor_info) = unify_or_compare_pred.
:- pragma foreign_proc("C#",
type_ctor_compare_pred(TypeCtorInfo::in) = (ComparePred::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
ComparePred = TypeCtorInfo.compare_pred;
").
:- pragma foreign_proc("C",
type_ctor_compare_pred(TypeCtorInfo::in) = (ComparePred::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
MR_TypeCtorInfo tci;
tci = (MR_TypeCtorInfo) TypeCtorInfo;
ComparePred = (MR_Integer) tci->MR_type_ctor_compare_pred;
").
:- pragma foreign_proc("Java",
type_ctor_compare_pred(TypeCtorInfo::in) = (ComparePred::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
ComparePred = TypeCtorInfo.compare_pred;
").
type_ctor_compare_pred(_) = unify_or_compare_pred :-
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
private_builtin.sorry("type_ctor_compare_pred").
%---------------------------------------------------------------------------%
:- func get_type_ctor_rep(type_ctor_info) = type_ctor_rep.
:- pragma foreign_proc("C#",
get_type_ctor_rep(TypeCtorInfo::in) = (TypeCtorRep::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
TypeCtorRep = (Type_ctor_rep_0) TypeCtorInfo.type_ctor_rep;
").
:- pragma foreign_proc("Java",
get_type_ctor_rep(TypeCtorInfo::in) = (TypeCtorRep::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
TypeCtorRep = rtti_implementation.static_type_ctor_rep[
TypeCtorInfo.type_ctor_rep.value];
").
:- pragma foreign_proc("C",
get_type_ctor_rep(TypeCtorInfo::in) = (TypeCtorRep::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
MR_TypeCtorInfo tci = (MR_TypeCtorInfo) TypeCtorInfo;
TypeCtorRep = MR_type_ctor_rep(tci);
").
get_type_ctor_rep(_) = _ :-
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
private_builtin.sorry("type_ctor_rep").
%---------------------------------------------------------------------------%
:- func type_ctor_module_name(type_ctor_info) = string.
:- pragma foreign_proc("C#",
type_ctor_module_name(TypeCtorInfo::in) = (Name::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Name = TypeCtorInfo.type_ctor_module_name;
").
:- pragma foreign_proc("Java",
type_ctor_module_name(TypeCtorInfo::in) = (Name::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Name = TypeCtorInfo.type_ctor_module_name;
").
:- pragma foreign_proc("C",
type_ctor_module_name(TypeCtorInfo::in) = (Name::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
MR_TypeCtorInfo tci = (MR_TypeCtorInfo) TypeCtorInfo;
Name = (MR_String) MR_type_ctor_module_name(tci);
").
type_ctor_module_name(_) = _ :-
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
private_builtin.sorry("type_ctor_module_name").
%---------------------------------------------------------------------------%
:- func type_ctor_name(type_ctor_info) = string.
:- pragma foreign_proc("C#",
type_ctor_name(TypeCtorInfo::in) = (Name::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
if (TypeCtorInfo.type_ctor_rep
== runtime.TypeCtorRep.MR_TYPECTOR_REP_TUPLE) {
Name = ""{}"";
} else {
Name = TypeCtorInfo.type_ctor_name;
}
").
:- pragma foreign_proc("Java",
type_ctor_name(TypeCtorInfo::in) = (Name::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
if (TypeCtorInfo.type_ctor_rep.value
== jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_TUPLE) {
Name = ""{}"";
} else {
Name = TypeCtorInfo.type_ctor_name;
}
").
:- pragma foreign_proc("C",
type_ctor_name(TypeCtorInfo::in) = (Name::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
MR_TypeCtorInfo tci = (MR_TypeCtorInfo) TypeCtorInfo;
Name = (MR_String) MR_type_ctor_name(tci);
").
type_ctor_name(_) = _ :-
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
private_builtin.sorry("type_ctor_name").
%---------------------------------------------------------------------------%
:- func get_type_ctor_functors(type_ctor_info) = type_functors.
:- pragma no_determinism_warning(func(get_type_ctor_functors/1)).
:- pragma foreign_proc("C#",
get_type_ctor_functors(TypeCtorInfo::in) = (Functors::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Functors = TypeCtorInfo.type_functors;
").
:- pragma foreign_proc("Java",
get_type_ctor_functors(TypeCtorInfo::in) = (Functors::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Functors = TypeCtorInfo.type_functors;
").
get_type_ctor_functors(_) = _ :-
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
private_builtin.sorry("get_type_ctor_functors").
%---------------------------------------------------------------------------%
:- func get_type_layout(type_ctor_info) = type_layout.
:- pragma no_determinism_warning(func(get_type_layout/1)).
:- pragma foreign_proc("C#",
get_type_layout(TypeCtorInfo::in) = (TypeLayout::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
TypeLayout = TypeCtorInfo.type_layout;
").
:- pragma foreign_proc("Java",
get_type_layout(TypeCtorInfo::in) = (TypeLayout::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
TypeLayout = TypeCtorInfo.type_layout;
").
:- pragma foreign_proc("C",
get_type_layout(TypeCtorInfo::in) = (TypeLayout::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
MR_TypeCtorInfo tci = (MR_TypeCtorInfo) TypeCtorInfo;
TypeLayout = (MR_Word) &(MR_type_ctor_layout(tci));
").
get_type_layout(_) = _ :-
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
private_builtin.sorry("get_type_layout").
%---------------------------------------------------------------------------%
:- func type_ctor_num_functors(type_ctor_info) = int.
:- pragma no_determinism_warning(func(type_ctor_num_functors/1)).
:- pragma foreign_proc("C#",
type_ctor_num_functors(TypeCtorInfo::in) = (NumFunctors::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
NumFunctors = TypeCtorInfo.type_ctor_num_functors;
").
:- pragma foreign_proc("Java",
type_ctor_num_functors(TypeCtorInfo::in) = (NumFunctors::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
NumFunctors = TypeCtorInfo.type_ctor_num_functors;
").
type_ctor_num_functors(_) = _ :-
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
private_builtin.sorry("type_ctor_num_functors").
%---------------------------------------------------------------------------%
:- pred type_ctor_search_functor_number_map(type_ctor_info::in,
int::in, int::out) is semidet.
:- pragma no_determinism_warning(pred(type_ctor_search_functor_number_map/3)).
:- pragma foreign_proc("C#",
type_ctor_search_functor_number_map(TypeCtorInfo::in, Ordinal::in,
FunctorNumber::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
if (Ordinal >= 0 && Ordinal < TypeCtorInfo.type_ctor_num_functors) {
FunctorNumber = TypeCtorInfo.type_functor_number_map[Ordinal];
SUCCESS_INDICATOR = true;
} else if (Ordinal == 0 && TypeCtorInfo.type_ctor_num_functors == -1) {
// This is for tuples.
FunctorNumber = 0;
SUCCESS_INDICATOR = true;
} else {
FunctorNumber = -1;
SUCCESS_INDICATOR = false;
}
").
:- pragma foreign_proc("Java",
type_ctor_search_functor_number_map(TypeCtorInfo::in, Ordinal::in,
FunctorNumber::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
if (Ordinal >= 0 && Ordinal < TypeCtorInfo.type_ctor_num_functors) {
FunctorNumber = TypeCtorInfo.type_functor_number_map[Ordinal];
SUCCESS_INDICATOR = true;
} else if (Ordinal == 0 && TypeCtorInfo.type_ctor_num_functors == -1) {
// This is for tuples.
FunctorNumber = 0;
SUCCESS_INDICATOR = true;
} else {
FunctorNumber = -1;
SUCCESS_INDICATOR = false;
}
").
type_ctor_search_functor_number_map(_, _, _) :-
private_builtin.sorry("type_ctor_search_functor_number_map/3").
%---------------------------------------------------------------------------%
%
% TypeFunctors
%
:- type type_functors ---> type_functors(c_pointer).
:- pragma foreign_type("C#", type_functors,
"runtime.TypeFunctors").
:- pragma foreign_type("Java", type_functors,
"jmercury.runtime.TypeFunctors").
:- type du_functor_desc ---> du_functor_desc(c_pointer).
:- pragma foreign_type("C#", du_functor_desc,
"runtime.DuFunctorDesc").
:- pragma foreign_type("Java", du_functor_desc,
"jmercury.runtime.DuFunctorDesc").
:- type enum_functor_desc ---> enum_functor_desc(c_pointer).
:- pragma foreign_type("C#", enum_functor_desc,
"runtime.EnumFunctorDesc").
:- pragma foreign_type("Java", enum_functor_desc,
"jmercury.runtime.EnumFunctorDesc").
:- type foreign_enum_functor_desc ---> foreign_enum_functor_desc(c_pointer).
:- pragma foreign_type("C#", foreign_enum_functor_desc,
"runtime.ForeignEnumFunctorDesc").
:- pragma foreign_type("Java", foreign_enum_functor_desc,
"jmercury.runtime.ForeignEnumFunctorDesc").
:- type notag_functor_desc ---> notag_functor_desc(c_pointer).
:- pragma foreign_type("C#", notag_functor_desc,
"runtime.NotagFunctorDesc").
:- pragma foreign_type("Java", notag_functor_desc,
"jmercury.runtime.NotagFunctorDesc").
:- inst du for type_ctor_rep/0
---> tcr_du
; tcr_du_usereq
; tcr_reserved_addr
; tcr_reserved_addr_usereq.
:- inst enum for type_ctor_rep/0
---> tcr_enum
; tcr_enum_usereq
; tcr_dummy.
:- inst foreign_enum for type_ctor_rep/0
---> tcr_foreign_enum
; tcr_foreign_enum_usereq.
:- inst notag for type_ctor_rep/0
---> tcr_notag
; tcr_notag_usereq
; tcr_notag_ground
; tcr_notag_ground_usereq.
%---------------------%
:- func du_functor_desc(type_ctor_rep, int, type_functors) = du_functor_desc.
:- mode du_functor_desc(in(du), in, in) = out is det.
du_functor_desc(_, Num, TypeFunctors) = DuFunctorDesc :-
DuFunctorDesc = TypeFunctors ^ unsafe_index(Num).
:- pragma foreign_proc("C#",
du_functor_desc(_TypeCtorRep::in(du), X::in, TypeFunctors::in) =
(DuFunctorDesc::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
DuFunctorDesc = TypeFunctors.functors_du()[X];
").
:- pragma foreign_proc("Java",
du_functor_desc(_TypeCtorRep::in(du), X::in, TypeFunctors::in) =
(DuFunctorDesc::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
DuFunctorDesc = TypeFunctors.functors_du()[X];
").
%---------------------%
:- func du_functor_name(du_functor_desc) = string.
du_functor_name(DuFunctorDesc) = DuFunctorDesc ^ unsafe_index(0).
:- pragma foreign_proc("C#",
du_functor_name(DuFunctorDesc::in) = (Name::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Name = DuFunctorDesc.du_functor_name;
").
:- pragma foreign_proc("Java",
du_functor_name(DuFunctorDesc::in) = (Name::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Name = DuFunctorDesc.du_functor_name;
").
%---------------------%
:- func du_functor_arity(du_functor_desc) = int16.
du_functor_arity(DuFunctorDesc) = DuFunctorDesc ^ unsafe_index(1).
:- pragma foreign_proc("C#",
du_functor_arity(DuFunctorDesc::in) = (Arity::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Arity = DuFunctorDesc.du_functor_orig_arity;
").
:- pragma foreign_proc("Java",
du_functor_arity(DuFunctorDesc::in) = (Arity::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Arity = DuFunctorDesc.du_functor_orig_arity;
").
%---------------------%
:- func du_functor_ordinal(du_functor_desc) = int32.
du_functor_ordinal(DuFunctorDesc) = DuFunctorDesc ^ unsafe_index(6).
:- pragma foreign_proc("C#",
du_functor_ordinal(DuFunctorDesc::in) = (Ordinal::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Ordinal = DuFunctorDesc.du_functor_ordinal;
").
:- pragma foreign_proc("Java",
du_functor_ordinal(DuFunctorDesc::in) = (Ordinal::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Ordinal = DuFunctorDesc.du_functor_ordinal;
").
%---------------------%
:- func du_functor_arg_types(du_functor_desc) = arg_types.
du_functor_arg_types(DuFunctorDesc) = DuFunctorDesc ^ unsafe_index(7).
:- pragma foreign_proc("C#",
du_functor_arg_types(DuFunctorDesc::in) = (ArgTypes::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
ArgTypes = DuFunctorDesc.du_functor_arg_types;
").
:- pragma foreign_proc("Java",
du_functor_arg_types(DuFunctorDesc::in) = (ArgTypes::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
ArgTypes = DuFunctorDesc.du_functor_arg_types;
").
%---------------------%
:- pred get_du_functor_arg_names(du_functor_desc::in, arg_names::out)
is semidet.
get_du_functor_arg_names(DuFunctorDesc, ArgNames) :-
ArgNames = DuFunctorDesc ^ unsafe_index(8),
not null(ArgNames).
:- pragma foreign_proc("C#",
get_du_functor_arg_names(DuFunctorDesc::in, ArgNames::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
ArgNames = DuFunctorDesc.du_functor_arg_names;
SUCCESS_INDICATOR = (ArgNames != null);
").
:- pragma foreign_proc("Java",
get_du_functor_arg_names(DuFunctorDesc::in, ArgNames::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
ArgNames = DuFunctorDesc.du_functor_arg_names;
SUCCESS_INDICATOR = (ArgNames != null);
").
%---------------------%
:- func arg_names_index(arg_names, int) = string.
:- pragma no_determinism_warning(func(arg_names_index/2)).
:- pragma foreign_proc("C#",
arg_names_index(ArgNames::in, Index::in) = (Name::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Name = ArgNames[Index];
").
:- pragma foreign_proc("Java",
arg_names_index(ArgNames::in, Index::in) = (Name::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Name = ArgNames[Index];
").
arg_names_index(_, _) = _ :-
private_builtin.sorry("arg_names_index/2").
%---------------------%
:- pred search_arg_names(arg_names::in, int::in, int::in, string::in, int::out)
is semidet.
search_arg_names(ArgNames, I, Arity, Name, Index) :-
I < Arity,
( if arg_names_index(ArgNames, I) = Name then
Index = I
else
search_arg_names(ArgNames, I + 1, Arity, Name, Index)
).
%---------------------%
:- pred get_du_functor_exist_info(du_functor_desc::in, exist_info::out)
is semidet.
get_du_functor_exist_info(DuFunctorDesc, ExistInfo) :-
ExistInfo = DuFunctorDesc ^ unsafe_index(9),
not null(ExistInfo).
:- pragma foreign_proc("C#",
get_du_functor_exist_info(DuFunctorDesc::in, ExistInfo::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
ExistInfo = DuFunctorDesc.du_functor_exist_info;
SUCCESS_INDICATOR = (ExistInfo != null);
").
:- pragma foreign_proc("Java",
get_du_functor_exist_info(DuFunctorDesc::in, ExistInfo::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
ExistInfo = DuFunctorDesc.du_functor_exist_info;
SUCCESS_INDICATOR = (ExistInfo != null);
").
%---------------------%
:- func get_enum_functor_desc(type_ctor_rep::in(enum), int::in,
type_functors::in) = (enum_functor_desc::out) is det.
get_enum_functor_desc(_, Num, TypeFunctors) = EnumFunctorDesc :-
EnumFunctorDesc = TypeFunctors ^ unsafe_index(Num).
:- pragma foreign_proc("C#",
get_enum_functor_desc(_TypeCtorRep::in(enum), X::in, TypeFunctors::in) =
(EnumFunctorDesc::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
EnumFunctorDesc = (TypeFunctors.functors_enum())[X];
").
:- pragma foreign_proc("Java",
get_enum_functor_desc(_TypeCtorRep::in(enum), X::in, TypeFunctors::in) =
(EnumFunctorDesc::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
EnumFunctorDesc = (TypeFunctors.functors_enum())[X];
").
%---------------------%
:- pred index_enum_functor_desc(type_ctor_info::in, int::in,
enum_functor_desc::out) is det.
:- pragma no_determinism_warning(pred(index_enum_functor_desc/3)).
index_enum_functor_desc(_, _, _) :-
private_builtin.sorry("index_enum_functor_desc").
:- pragma foreign_proc("C#",
index_enum_functor_desc(TypeCtorInfo::in, Ordinal::in,
EnumFunctorDesc::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
EnumFunctorDesc = TypeCtorInfo.type_layout.layout_enum()[Ordinal];
").
:- pragma foreign_proc("Java",
index_enum_functor_desc(TypeCtorInfo::in, Ordinal::in,
EnumFunctorDesc::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
EnumFunctorDesc = TypeCtorInfo.type_layout.layout_enum()[Ordinal];
").
%---------------------%
:- pred det_index_or_search_enum_functor_ordinal(type_ctor_info::in, int::in,
int::out) is det.
det_index_or_search_enum_functor_ordinal(TypeCtorInfo, EnumValue, Ordinal) :-
( if
index_or_search_enum_functor_ordinal(TypeCtorInfo, EnumValue,
Ordinal0)
then
Ordinal = Ordinal0
else
unexpected($pred, "no functor for enum value")
).
:- pred index_or_search_enum_functor_ordinal(type_ctor_info::in, int::in,
int::out) is semidet.
:- pragma no_determinism_warning(pred(index_or_search_enum_functor_ordinal/3)).
index_or_search_enum_functor_ordinal(_, _, _) :-
private_builtin.sorry("index_or_search_enum_functor_ordinal").
:- pragma foreign_proc("C#",
index_or_search_enum_functor_ordinal(TypeCtorInfo::in, EnumValue::in,
Ordinal::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Ordinal = TypeCtorInfo.index_or_search_enum_functor_ordinal(EnumValue);
SUCCESS_INDICATOR = (Ordinal >= 0);
").
:- pragma foreign_proc("Java",
index_or_search_enum_functor_ordinal(TypeCtorInfo::in, EnumValue::in,
Ordinal::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Ordinal = TypeCtorInfo.index_or_search_enum_functor_ordinal(EnumValue);
SUCCESS_INDICATOR = (Ordinal >= 0);
").
%---------------------%
:- func enum_functor_name(enum_functor_desc) = string.
enum_functor_name(EnumFunctorDesc) = EnumFunctorDesc ^ unsafe_index(0).
:- pragma foreign_proc("C#",
enum_functor_name(EnumFunctorDesc::in) = (Name::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Name = EnumFunctorDesc.enum_functor_name;
").
:- pragma foreign_proc("Java",
enum_functor_name(EnumFunctorDesc::in) = (Name::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Name = EnumFunctorDesc.enum_functor_name;
").
%---------------------%
:- func enum_functor_value(enum_functor_desc) = int.
:- pragma no_determinism_warning(func(enum_functor_value/1)).
enum_functor_value(_) = _ :-
private_builtin.sorry("enum_functor_value").
:- pragma foreign_proc("C#",
enum_functor_value(EnumFunctorDesc::in) = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = EnumFunctorDesc.enum_functor_value;
").
:- pragma foreign_proc("Java",
enum_functor_value(EnumFunctorDesc::in) = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = EnumFunctorDesc.enum_functor_value;
").
%---------------------%
:- func get_foreign_enum_functor_desc(type_ctor_rep, int, type_functors)
= foreign_enum_functor_desc.
:- mode get_foreign_enum_functor_desc(in(foreign_enum), in, in) = out is det.
:- pragma no_determinism_warning(func(get_foreign_enum_functor_desc/3)).
get_foreign_enum_functor_desc(_, _, _) = _ :-
private_builtin.sorry("get_foreign_enum_functor_desc").
:- pragma foreign_proc("C#",
get_foreign_enum_functor_desc(_TypeCtorRep::in(foreign_enum), X::in,
TypeFunctors::in) = (ForeignEnumFunctorDesc::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
ForeignEnumFunctorDesc = TypeFunctors.functors_foreign_enum()[X];
").
:- pragma foreign_proc("Java",
get_foreign_enum_functor_desc(_TypeCtorRep::in(foreign_enum), X::in,
TypeFunctors::in) = (ForeignEnumFunctorDesc::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
ForeignEnumFunctorDesc = TypeFunctors.functors_foreign_enum()[X];
").
%---------------------%
:- func foreign_enum_functor_desc(type_ctor_rep, int, type_functors)
= foreign_enum_functor_desc.
:- mode foreign_enum_functor_desc(in(foreign_enum), in, in) = out is det.
:- pragma no_determinism_warning(func(foreign_enum_functor_desc/3)).
foreign_enum_functor_desc(_, _, _) = _ :-
private_builtin.sorry("foreign_enum_functor_desc").
:- pragma foreign_proc("C#",
foreign_enum_functor_desc(_TypeCtorRep::in(foreign_enum), X::in,
TypeFunctors::in) = (ForeignEnumFunctorDesc::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
ForeignEnumFunctorDesc = null;
foreach (ForeignEnumFunctorDesc desc
in TypeFunctors.functors_foreign_enum())
{
if (desc.foreign_enum_functor_value == X) {
ForeignEnumFunctorDesc = desc;
break;
}
}
").
:- pragma foreign_proc("Java",
foreign_enum_functor_desc(_TypeCtorRep::in(foreign_enum), X::in,
TypeFunctors::in) = (ForeignEnumFunctorDesc::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
ForeignEnumFunctorDesc = null;
for (ForeignEnumFunctorDesc desc : TypeFunctors.functors_foreign_enum()) {
if (desc.foreign_enum_functor_value == X) {
ForeignEnumFunctorDesc = desc;
break;
}
}
").
%---------------------%
:- func foreign_enum_functor_name(foreign_enum_functor_desc) = string.
foreign_enum_functor_name(ForeignEnumFunctorDesc) =
ForeignEnumFunctorDesc ^ unsafe_index(0).
:- pragma foreign_proc("C#",
foreign_enum_functor_name(ForeignEnumFunctorDesc::in) = (Name::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Name = ForeignEnumFunctorDesc.foreign_enum_functor_name;
").
:- pragma foreign_proc("Java",
foreign_enum_functor_name(ForeignEnumFunctorDesc::in) = (Name::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Name = ForeignEnumFunctorDesc.foreign_enum_functor_name;
").
%---------------------%
:- func foreign_enum_functor_ordinal(foreign_enum_functor_desc) = int.
foreign_enum_functor_ordinal(_) = -1.
:- pragma foreign_proc("C#",
foreign_enum_functor_ordinal(ForeignEnumFunctorDesc::in) = (Ordinal::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Ordinal = ForeignEnumFunctorDesc.foreign_enum_functor_ordinal;
").
:- pragma foreign_proc("Java",
foreign_enum_functor_ordinal(ForeignEnumFunctorDesc::in) = (Ordinal::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Ordinal = ForeignEnumFunctorDesc.foreign_enum_functor_ordinal;
").
%---------------------%
:- func notag_functor_desc(type_ctor_rep, int, type_functors)
= notag_functor_desc.
:- mode notag_functor_desc(in(notag), in, in) = out is det.
notag_functor_desc(_, Num, TypeFunctors) = NoTagFunctorDesc :-
NoTagFunctorDesc = TypeFunctors ^ unsafe_index(Num).
:- pragma foreign_proc("C#",
notag_functor_desc(_TypeCtorRep::in(notag), _X::in, TypeFunctors::in) =
(NotagFunctorDesc::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
NotagFunctorDesc = TypeFunctors.functors_notag();
").
:- pragma foreign_proc("Java",
notag_functor_desc(_TypeCtorRep::in(notag), _X::in, TypeFunctors::in) =
(NotagFunctorDesc::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
NotagFunctorDesc = TypeFunctors.functors_notag();
").
%---------------------%
:- func notag_functor_name(notag_functor_desc) = string.
notag_functor_name(NoTagFunctorDesc) = NoTagFunctorDesc ^ unsafe_index(0).
:- pragma foreign_proc("C#",
notag_functor_name(NotagFunctorDesc::in) = (Name::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Name = NotagFunctorDesc.no_tag_functor_name;
").
:- pragma foreign_proc("Java",
notag_functor_name(NotagFunctorDesc::in) = (Name::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Name = NotagFunctorDesc.no_tag_functor_name;
").
%---------------------%
:- func notag_functor_arg_type(notag_functor_desc) = pseudo_type_info.
notag_functor_arg_type(NoTagFunctorDesc) = NoTagFunctorDesc ^ unsafe_index(1).
:- pragma foreign_proc("C#",
notag_functor_arg_type(NotagFunctorDesc::in) = (ArgType::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
ArgType = NotagFunctorDesc.no_tag_functor_arg_type;
").
:- pragma foreign_proc("Java",
notag_functor_arg_type(NotagFunctorDesc::in) = (ArgType::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
ArgType = NotagFunctorDesc.no_tag_functor_arg_type;
").
%---------------------%
:- func notag_functor_arg_name(notag_functor_desc) = string.
:- pragma no_determinism_warning(func(notag_functor_arg_name/1)).
notag_functor_arg_name(NoTagFunctorDesc) = NoTagFunctorDesc ^ unsafe_index(2).
:- pragma foreign_proc("C#",
notag_functor_arg_name(NotagFunctorDesc::in) = (ArgName::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
ArgName = NotagFunctorDesc.no_tag_functor_arg_name;
").
:- pragma foreign_proc("Java",
notag_functor_arg_name(NotagFunctorDesc::in) = (ArgName::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
ArgName = NotagFunctorDesc.no_tag_functor_arg_name;
").
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
% XXX get rid of this
:- func unsafe_index(int, T) = U.
:- pragma consider_used(func(unsafe_index/2)).
:- pragma no_determinism_warning(func(unsafe_index/2)).
:- pragma foreign_proc("C#",
unsafe_index(_Num::in, _Array::in) = (Item::out),
[will_not_call_mercury, thread_safe, promise_pure],
"
Item = null;
").
unsafe_index(_, _) = _ :-
private_builtin.sorry("rtti_implementation.unsafe_index").
%---------------------------------------------------------------------------%
% XXX get rid of this
:- pred null(T::in) is semidet.
:- pragma no_determinism_warning(pred(null/1)).
:- pragma consider_used(pred(null/1)).
:- pragma foreign_proc("C",
null(S::in),
[will_not_call_mercury, thread_safe, promise_pure],
"
SUCCESS_INDICATOR = ((void *) S == NULL);
").
:- pragma foreign_proc("C#",
null(S::in),
[will_not_call_mercury, thread_safe, promise_pure],
"
SUCCESS_INDICATOR = (S == null);
").
:- pragma foreign_proc("Java",
null(S::in),
[will_not_call_mercury, thread_safe, promise_pure],
"
SUCCESS_INDICATOR = (S == null);
").
null(_) :-
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
private_builtin.sorry("rtti_implementation.null/1").
%---------------------------------------------------------------------------%
% XXX get rid of this
:- func null_string = string.
:- pragma foreign_proc("C",
null_string = (Str::out),
[will_not_call_mercury, thread_safe, promise_pure],
"
Str = NULL;
").
:- pragma foreign_proc("C#",
null_string = (Str::out),
[will_not_call_mercury, thread_safe, promise_pure],
"
Str = null;
").
:- pragma foreign_proc("Java",
null_string = (Str::out),
[will_not_call_mercury, thread_safe, promise_pure],
"
Str = null;
").
null_string = _ :-
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
private_builtin.sorry("rtti_implementation.null_string/0").
%---------------------------------------------------------------------------%
:- func unsafe_get_enum_value(T) = int.
:- pragma no_determinism_warning(func(unsafe_get_enum_value/1)).
:- pragma foreign_proc("C#",
unsafe_get_enum_value(Enum::in) = (Value::out),
[will_not_call_mercury, thread_safe, promise_pure],
"
Value = (int) Enum;
").
:- pragma foreign_proc("Java",
unsafe_get_enum_value(Enum::in) = (Value::out),
[will_not_call_mercury, thread_safe, promise_pure],
"
try {
Value = Enum.getClass().getField(""MR_value"").getInt(Enum);
}
catch (java.lang.Exception e) {
throw new java.lang.RuntimeException(
""unsafe_get_enum_value/1 called on an "" +
""object which is not of enumerated type."");
}
").
unsafe_get_enum_value(_) = _ :-
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
private_builtin.sorry("rtti_implementation.unsafe_get_enum_value/1").
%---------------------------------------------------------------------------%
:- func unsafe_get_foreign_enum_value(T) = int.
:- pragma no_determinism_warning(func(unsafe_get_foreign_enum_value/1)).
:- pragma foreign_proc("C#",
unsafe_get_foreign_enum_value(T::in) = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe, tabled_for_io],
"
Value = (int) T;
").
unsafe_get_foreign_enum_value(_) = _ :-
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
% XXX We cannot provide a Java version of this until mlds_to_java_*.m
% are updated to support foreign enumerations.
private_builtin.sorry(
"rtti_implementation.unsafe_get_foreign_enum_value/1").
%---------------------------------------------------------------------------%
:- func iterate(int, int, (func(int) = T)) = list(T).
iterate(Start, Max, Func) = Results :-
( if Start =< Max then
Res = Func(Start),
Results = [Res | iterate(Start + 1, Max, Func)]
else
Results = []
).
%---------------------------------------------------------------------------%
:- pred high_level_data is semidet.
:- pragma foreign_proc("Java",
high_level_data,
[will_not_call_mercury, promise_pure, thread_safe],
"
SUCCESS_INDICATOR = true;
").
:- pragma foreign_proc("C#",
high_level_data,
[will_not_call_mercury, promise_pure, thread_safe],
"
SUCCESS_INDICATOR = true;
").
high_level_data :-
( if semidet_succeed then
private_builtin.sorry("high_level_data")
else
semidet_succeed
).
%---------------------------------------------------------------------------%
:- pred semidet_unimplemented(string::in) is semidet.
:- pragma consider_used(pred(semidet_unimplemented/1)).
semidet_unimplemented(S) :-
( if semidet_succeed then
sorry($module, S)
else
semidet_succeed
).
:- pred det_unimplemented(string::in) is det.
:- pragma consider_used(pred(det_unimplemented/1)).
det_unimplemented(S) :-
( if semidet_succeed then
sorry($module, S)
else
true
).
%---------------------------------------------------------------------------%
:- end_module rtti_implementation.
%---------------------------------------------------------------------------%
Reference in New Issue View Git Blame Copy Permalink