[m-rev.] for review: some more rtti for java
Peter Wang
novalazy at gmail.com
Wed Jan 20 12:35:40 AEDT 2010
Branches: main
Implement some RTTI procedures for Java:
get_functor_ordinal/2,
get_functor_lex/2,
type_ctor/2,
pseudo_type_ctor_and_args/3,
make_type/2
Make type_desc/type_ctor_desc/pseudo_type_desc into synonyms for type_info/etc.,
mainly to simplify the hand-written RTTI handling functions. Previously the
*_desc types were represented by *Desc wrapper classes.
compiler/mlds_to_java.m:
compiler/builtin_lib_types.m:
Map *_desc types to TypeInfo_Struct, TypeCtorInfo_Struct,
PseudoTypeInfo_Struct. We cannot simply use
`:- pragma foreign_type("Java", ...)' in the library as the compiler
will complain about missing type definitions for other language
backends.
library/construct.m:
Implement get_functor_ordinal, get_functor_lex for Java backend.
Conform to removal of *Desc classes.
library/rtti_implementation.m:
Implement get_functor_ordinal, get_functor_lex,
pseudo_type_ctor_and_args for Java backend.
Handle existentially quantified arguments in get_functor_du.
Make type_info/type_ctor_info comparison procedures compare module
names before constructor names, to match MR_compare_type_info,
MR_compare_type_ctor_info.
library/type_desc.m:
Implement type_ctor, pseudo_type_ctor_and_args, make_type on Java
backend.
Conform to removal of *Desc wrapper classes.
java/runtime/TypeCtorInfo_Struct.java:
Add constructor for variable arity type constructors.
java/runtime/TypeCtorRep.java:
Delete unused constants.
diff --git a/compiler/builtin_lib_types.m b/compiler/builtin_lib_types.m
index dd14a7b..8e3ff75 100644
--- a/compiler/builtin_lib_types.m
+++ b/compiler/builtin_lib_types.m
@@ -35,6 +35,9 @@
:- func sample_typeclass_info_type = mer_type.
:- func type_info_type = mer_type.
:- func type_ctor_info_type = mer_type.
+:- func type_desc_type = mer_type.
+:- func pseudo_type_desc_type = mer_type.
+:- func type_ctor_desc_type = mer_type.
:- func comparison_result_type = mer_type.
:- func io_state_type = mer_type.
:- func io_io_type = mer_type.
@@ -145,6 +148,18 @@ type_ctor_info_type = defined_type(Name, [], kind_star) :-
BuiltinModule = mercury_private_builtin_module,
Name = qualified(BuiltinModule, "type_ctor_info").
+type_desc_type = defined_type(Name, [], kind_star) :-
+ Module = mercury_std_lib_module_name(unqualified("type_desc")),
+ Name = qualified(Module, "type_desc").
+
+pseudo_type_desc_type = defined_type(Name, [], kind_star) :-
+ Module = mercury_std_lib_module_name(unqualified("type_desc")),
+ Name = qualified(Module, "pseudo_type_desc").
+
+type_ctor_desc_type = defined_type(Name, [], kind_star) :-
+ Module = mercury_std_lib_module_name(unqualified("type_desc")),
+ Name = qualified(Module, "type_ctor_desc").
+
comparison_result_type = defined_type(Name, [], kind_star) :-
BuiltinModule = mercury_public_builtin_module,
Name = qualified(BuiltinModule, "comparison_result").
diff --git a/compiler/mlds_to_java.m b/compiler/mlds_to_java.m
index 84437da..593da87 100644
--- a/compiler/mlds_to_java.m
+++ b/compiler/mlds_to_java.m
@@ -2996,7 +2996,7 @@ output_type(Info, Style, MLDS_Type, !IO) :-
% We need to handle type_info (etc.) types specially --
% they get mapped to types in the runtime rather than
% in private_builtin.
- hand_defined_type(CtorCat, SubstituteName)
+ hand_defined_type(Type, CtorCat, SubstituteName)
->
io.write_string(SubstituteName, !IO)
;
@@ -3254,26 +3254,38 @@ type_category_is_array(CtorCat) = IsArray :-
IsArray = is_array
).
- % hand_defined_type(Type, SubstituteName):
+ % hand_defined_type(Type, CtorCat, SubstituteName):
%
% We need to handle type_info (etc.) types specially -- they get mapped
% to types in the runtime rather than in private_builtin.
%
-:- pred hand_defined_type(type_ctor_category::in, string::out) is semidet.
+:- pred hand_defined_type(mer_type::in, type_ctor_category::in, string::out)
+ is semidet.
-hand_defined_type(ctor_cat_system(Kind), SubstituteName) :-
+hand_defined_type(Type, CtorCat, SubstituteName) :-
(
- Kind = cat_system_type_info,
+ CtorCat = ctor_cat_system(cat_system_type_info),
SubstituteName = "jmercury.runtime.TypeInfo_Struct"
;
- Kind = cat_system_type_ctor_info,
+ CtorCat = ctor_cat_system(cat_system_type_ctor_info),
SubstituteName = "jmercury.runtime.TypeCtorInfo_Struct"
;
- Kind = cat_system_typeclass_info,
+ CtorCat = ctor_cat_system(cat_system_typeclass_info),
SubstituteName = "/* typeclass_info */ java.lang.Object[]"
;
- Kind = cat_system_base_typeclass_info,
+ CtorCat = ctor_cat_system(cat_system_base_typeclass_info),
SubstituteName = "/* base_typeclass_info */ java.lang.Object[]"
+ ;
+ CtorCat = ctor_cat_user(cat_user_general),
+ ( Type = type_desc_type ->
+ SubstituteName = "jmercury.runtime.TypeInfo_Struct"
+ ; Type = pseudo_type_desc_type ->
+ SubstituteName = "jmercury.runtime.PseudoTypeInfo"
+ ; Type = type_ctor_desc_type ->
+ SubstituteName = "jmercury.runtime.TypeCtorInfo_Struct"
+ ;
+ fail
+ )
).
%-----------------------------------------------------------------------------%
@@ -4024,8 +4036,8 @@ output_atomic_stmt(Info, Indent, AtomicStmt, Context, !IO) :-
(
MaybeCtorName = yes(QualifiedCtorId),
\+ (
- Type = mercury_type(_, CtorCat, _),
- hand_defined_type(CtorCat, _)
+ Type = mercury_type(MerType, CtorCat, _),
+ hand_defined_type(MerType, CtorCat, _)
)
->
output_type(Info, normal_style, Type, !IO),
diff --git a/java/runtime/TypeCtorInfo_Struct.java b/java/runtime/TypeCtorInfo_Struct.java
index c2dc547..788ded1 100644
--- a/java/runtime/TypeCtorInfo_Struct.java
+++ b/java/runtime/TypeCtorInfo_Struct.java
@@ -30,6 +30,27 @@ public class TypeCtorInfo_Struct extends PseudoTypeInfo
{
}
+ // Constructor for variable arity type_ctor_infos,
+ // i.e. predicates, functions and tuples.
+ public TypeCtorInfo_Struct(TypeCtorInfo_Struct other, int arity)
+ {
+ this.init(
+ arity,
+ other.type_ctor_version,
+ other.type_ctor_num_ptags,
+ other.type_ctor_rep.value,
+ other.unify_pred,
+ other.compare_pred,
+ other.type_ctor_module_name,
+ other.type_ctor_name,
+ other.type_functors,
+ other.type_layout,
+ other.type_ctor_num_functors,
+ other.type_ctor_flags,
+ other.type_functor_number_map
+ );
+ }
+
public void init(
int type_arity, int version, int num_ptags, int rep,
Object unify_proc, Object compare_proc,
diff --git a/java/runtime/TypeCtorRep.java b/java/runtime/TypeCtorRep.java
index b1ec0ec..3f95156 100644
--- a/java/runtime/TypeCtorRep.java
+++ b/java/runtime/TypeCtorRep.java
@@ -8,53 +8,8 @@ package jmercury.runtime;
public class TypeCtorRep implements java.io.Serializable {
- // Constants
-
- public static final int MR_TYPECTOR_REP_ENUM = 0;
- public static final int MR_TYPECTOR_REP_ENUM_USEREQ = 1;
- public static final int MR_TYPECTOR_REP_DU = 2;
- public static final int MR_TYPECTOR_REP_DU_USEREQ = 3;
- public static final int MR_TYPECTOR_REP_NOTAG = 4;
- public static final int MR_TYPECTOR_REP_NOTAG_USEREQ = 5;
- public static final int MR_TYPECTOR_REP_EQUIV = 6;
- public static final int MR_TYPECTOR_REP_FUNC = 7;
- public static final int MR_TYPECTOR_REP_INT = 8;
- public static final int MR_TYPECTOR_REP_CHAR = 9;
- public static final int MR_TYPECTOR_REP_FLOAT = 10;
- public static final int MR_TYPECTOR_REP_STRING = 11;
- public static final int MR_TYPECTOR_REP_PRED = 12;
- public static final int MR_TYPECTOR_REP_UNIV = 13;
- public static final int MR_TYPECTOR_REP_SUBGOAL = 14;
- public static final int MR_TYPECTOR_REP_C_POINTER = 15;
- public static final int MR_TYPECTOR_REP_TYPEINFO = 16;
- public static final int MR_TYPECTOR_REP_TYPECLASSINFO = 17;
- public static final int MR_TYPECTOR_REP_ARRAY = 18;
- public static final int MR_TYPECTOR_REP_SUCCIP = 19;
- public static final int MR_TYPECTOR_REP_HP = 20;
- public static final int MR_TYPECTOR_REP_CURFR = 21;
- public static final int MR_TYPECTOR_REP_MAXFR = 22;
- public static final int MR_TYPECTOR_REP_REDOFR = 23;
- public static final int MR_TYPECTOR_REP_REDOIP = 24;
- public static final int MR_TYPECTOR_REP_TRAIL_PTR = 25;
- public static final int MR_TYPECTOR_REP_TICKET = 26;
- public static final int MR_TYPECTOR_REP_NOTAG_GROUND = 27;
- public static final int MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ = 28;
- public static final int MR_TYPECTOR_REP_EQUIV_GROUND = 29;
- public static final int MR_TYPECTOR_REP_TUPLE = 30;
- public static final int MR_TYPECTOR_REP_RESERVED_ADDR = 31;
- public static final int MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ = 32;
- public static final int MR_TYPECTOR_REP_TYPECTORINFO = 33;
- public static final int MR_TYPECTOR_REP_BASETYPECLASSINFO = 34;
- public static final int MR_TYPECTOR_REP_TYPEDESC = 35;
- public static final int MR_TYPECTOR_REP_TYPECTORDESC = 36;
- public static final int MR_TYPECTOR_REP_FOREIGN = 37;
- public static final int MR_TYPECTOR_REP_REFERENCE = 38;
- public static final int MR_TYPECTOR_REP_STABLE_C_POINTER = 39;
- public static final int MR_TYPECTOR_REP_STABLE_FOREIGN = 40;
- public static final int MR_TYPECTOR_REP_PSEUDOTYPEDESC = 41;
- public static final int MR_TYPECTOR_REP_DUMMY = 42;
- public static final int MR_TYPECTOR_REP_UNKNOWN = 43;
-
+ // Constants are in private_builtin.m, named MR_TYPECTOR_REP_*.
+
// Instance variable for TypeCtorRep objects.
public int value;
diff --git a/library/construct.m b/library/construct.m
index 107cae2..fe65efe 100644
--- a/library/construct.m
+++ b/library/construct.m
@@ -181,21 +181,24 @@ get_functor_with_names(TypeDesc, I, Functor, Arity,
int::out, list(pseudo_type_desc)::out) is semidet.
get_functor_internal(TypeDesc, FunctorNumber, FunctorName, Arity,
- MaybeTypeDescList) :-
+ PseudoTypeDescList) :-
( erlang_rtti_implementation.is_erlang_backend ->
erlang_rtti_implementation.get_functor(TypeDesc, FunctorNumber,
- FunctorName, Arity, TypeDescList)
+ FunctorName, Arity, TypeDescList),
+ % XXX This old comment is wrong now:
+ % The backends in which we use this definition of this predicate don't
+ % yet support function symbols with existential types, which is the
+ % only kind of function symbol in which we may want to return unbound.
+ PseudoTypeDescList = list.map(type_desc_to_pseudo_type_desc,
+ TypeDescList)
;
type_desc_to_type_info(TypeDesc, TypeInfo),
rtti_implementation.type_info_get_functor(TypeInfo, FunctorNumber,
- FunctorName, Arity, TypeInfoList),
- type_info_list_to_type_desc_list(TypeInfoList, TypeDescList)
- ),
-
- % The backends in which we use this definition of this predicate
- % don't yet support function symbols with existential types, which is
- % the only kind of function symbol in which we may want to return unbound.
- MaybeTypeDescList = list.map(type_desc_to_pseudo_type_desc, TypeDescList).
+ FunctorName, Arity, PseudoTypeInfoList),
+ % Assumes they have the same representation.
+ private_builtin.unsafe_type_cast(PseudoTypeInfoList,
+ PseudoTypeDescList)
+ ).
:- pragma foreign_proc("C",
get_functor_internal(TypeDesc::in, FunctorNumber::in, FunctorName::out,
@@ -260,21 +263,24 @@ get_functor_internal(TypeDesc, FunctorNumber, FunctorName, Arity,
is semidet.
get_functor_with_names_internal(TypeDesc, FunctorNumber, FunctorName, Arity,
- MaybeTypeDescList, Names) :-
+ PseudoTypeDescList, Names) :-
( erlang_rtti_implementation.is_erlang_backend ->
erlang_rtti_implementation.get_functor_with_names(TypeDesc,
- FunctorNumber, FunctorName, Arity, TypeDescList, Names)
+ FunctorNumber, FunctorName, Arity, TypeDescList, Names),
+ % XXX This old comment is wrong now:
+ % The backends in which we use this definition of this predicate don't
+ % yet support function symbols with existential types, which is the
+ % only kind of function symbol in which we may want to return unbound.
+ PseudoTypeDescList = list.map(type_desc_to_pseudo_type_desc,
+ TypeDescList)
;
type_desc_to_type_info(TypeDesc, TypeInfo),
rtti_implementation.type_info_get_functor_with_names(TypeInfo,
- FunctorNumber, FunctorName, Arity, TypeInfoList, Names),
- type_info_list_to_type_desc_list(TypeInfoList, TypeDescList)
- ),
-
- % The backends in which we use this definition of this predicate
- % don't yet support function symbols with existential types, which is
- % the only kind of function symbol in which we may want to return unbound.
- MaybeTypeDescList = list.map(type_desc_to_pseudo_type_desc, TypeDescList).
+ FunctorNumber, FunctorName, Arity, PseudoTypeInfoList, Names),
+ % Assumes they have the same representation.
+ private_builtin.unsafe_type_cast(PseudoTypeInfoList,
+ PseudoTypeDescList)
+ ).
:- pragma foreign_proc("C",
get_functor_with_names_internal(TypeDesc::in, FunctorNumber::in,
@@ -390,7 +396,9 @@ get_functor_ordinal(TypeDesc, FunctorNumber, Ordinal) :-
erlang_rtti_implementation.get_functor_ordinal(TypeDesc, FunctorNumber,
Ordinal)
;
- private_builtin.sorry("get_functor_ordinal/3")
+ type_desc_to_type_info(TypeDesc, TypeInfo),
+ rtti_implementation.type_info_get_functor_ordinal(TypeInfo,
+ FunctorNumber, Ordinal)
).
:- pragma foreign_proc("C",
@@ -490,7 +498,9 @@ get_functor_lex(TypeDesc, Ordinal) = FunctorNumber :-
erlang_rtti_implementation.get_functor_lex(TypeDesc, Ordinal,
FunctorNumber)
;
- private_builtin.sorry("get_functor_lex/3")
+ type_desc_to_type_info(TypeDesc, TypeInfo),
+ rtti_implementation.type_info_get_functor_lex(TypeInfo, Ordinal,
+ FunctorNumber)
).
:- pragma foreign_proc("C",
diff --git a/library/rtti_implementation.m b/library/rtti_implementation.m
index 36a5b54..a19ad80 100644
--- a/library/rtti_implementation.m
+++ b/library/rtti_implementation.m
@@ -46,6 +46,7 @@
% abstract types.
:- type type_info.
:- type type_ctor_info.
+:- type pseudo_type_info.
:- func get_type_info(T::unused) = (type_info::out) is det.
@@ -56,12 +57,20 @@
:- 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_ctor_name_and_arity(type_ctor_info::in,
string::out, string::out, int::out) is det.
+:- 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.
+
:- func construct(type_info, int, list(univ)) = univ is semidet.
:- func construct_tuple_2(list(univ), list(type_info), int) = univ.
@@ -79,10 +88,16 @@
:- 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(type_info)::out) is semidet.
+ list(pseudo_type_info)::out) is semidet.
:- pred type_info_get_functor_with_names(type_info::in, int::in, string::out,
- int::out, list(type_info)::out, list(string)::out) is semidet.
+ 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.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -186,6 +201,7 @@
import jmercury.runtime.DuFunctorDesc;
import jmercury.runtime.EnumFunctorDesc;
+ import jmercury.runtime.PseudoTypeInfo;
import jmercury.runtime.TypeCtorInfo_Struct;
import jmercury.runtime.TypeInfo_Struct;
").
@@ -264,20 +280,20 @@ type_info_num_functors(TypeInfo, NumFunctors) :-
).
type_info_get_functor(TypeInfo, FunctorNumber, FunctorName, Arity,
- TypeInfoList) :-
+ PseudoTypeInfoList) :-
get_functor_impl(TypeInfo, FunctorNumber, FunctorName, Arity,
- TypeInfoList, _Names).
+ PseudoTypeInfoList, _Names).
type_info_get_functor_with_names(TypeInfo, FunctorNumber, FunctorName, Arity,
- TypeInfoList, Names) :-
+ PseudoTypeInfoList, Names) :-
get_functor_impl(TypeInfo, FunctorNumber, FunctorName, Arity,
- TypeInfoList, Names).
+ PseudoTypeInfoList, Names).
:- pred get_functor_impl(type_info::in, int::in, string::out, int::out,
- list(type_info)::out, list(string)::out) is semidet.
+ list(pseudo_type_info)::out, list(string)::out) is semidet.
get_functor_impl(TypeInfo, FunctorNumber,
- FunctorName, Arity, TypeInfoList, Names) :-
+ FunctorName, Arity, PseudoTypeInfoList, Names) :-
type_info_num_functors(TypeInfo, NumFunctors),
FunctorNumber >= 0,
FunctorNumber < NumFunctors,
@@ -290,14 +306,14 @@ get_functor_impl(TypeInfo, FunctorNumber,
; TypeCtorRep = tcr_reserved_addr_usereq
),
get_functor_du(TypeCtorRep, TypeInfo, TypeCtorInfo,
- FunctorNumber, FunctorName, Arity, TypeInfoList, Names)
+ FunctorNumber, FunctorName, Arity, PseudoTypeInfoList, Names)
;
( TypeCtorRep = tcr_enum
; TypeCtorRep = tcr_enum_usereq
; TypeCtorRep = tcr_dummy
),
get_functor_enum(TypeCtorRep, TypeCtorInfo,
- FunctorNumber, FunctorName, Arity, TypeInfoList, Names)
+ FunctorNumber, FunctorName, Arity, PseudoTypeInfoList, Names)
;
( TypeCtorRep = tcr_notag
; TypeCtorRep = tcr_notag_usereq
@@ -305,19 +321,20 @@ get_functor_impl(TypeInfo, FunctorNumber,
; TypeCtorRep = tcr_notag_ground_usereq
),
get_functor_notag(TypeCtorRep, TypeCtorInfo,
- FunctorNumber, FunctorName, Arity, TypeInfoList, Names)
+ FunctorNumber, FunctorName, Arity, PseudoTypeInfoList, Names)
;
( TypeCtorRep = tcr_equiv_ground
; TypeCtorRep = tcr_equiv
),
NewTypeInfo = collapse_equivalences(TypeInfo),
get_functor_impl(NewTypeInfo, FunctorNumber,
- FunctorName, Arity, TypeInfoList, Names)
+ FunctorName, Arity, PseudoTypeInfoList, Names)
;
TypeCtorRep = tcr_tuple,
FunctorName = "{}",
Arity = get_var_arity_typeinfo_arity(TypeInfo),
- TypeInfoList = iterate(1, Arity, var_arity_type_info_index(TypeInfo)),
+ PseudoTypeInfoList = iterate(1, Arity,
+ var_arity_type_info_index_as_pti(TypeInfo)),
Names = list.duplicate(Arity, null_string)
;
( TypeCtorRep = tcr_subgoal
@@ -359,29 +376,22 @@ get_functor_impl(TypeInfo, FunctorNumber,
:- pred get_functor_du(type_ctor_rep::in(du), type_info::in,
type_ctor_info::in, int::in, string::out, int::out,
- list(type_info)::out, list(string)::out) is semidet.
+ list(pseudo_type_info)::out, list(string)::out) is det.
get_functor_du(TypeCtorRep, TypeInfo, TypeCtorInfo, FunctorNumber,
- FunctorName, Arity, TypeDescList, Names) :-
+ FunctorName, Arity, PseudoTypeInfoList, Names) :-
TypeFunctors = get_type_ctor_functors(TypeCtorInfo),
DuFunctorDesc = TypeFunctors ^ du_functor_desc(TypeCtorRep, FunctorNumber),
- % XXX We don't handle functors with existentially quantified arguments.
- not get_du_functor_exist_info(DuFunctorDesc, _),
-
FunctorName = DuFunctorDesc ^ du_functor_name,
Arity = DuFunctorDesc ^ du_functor_arity,
ArgTypes = DuFunctorDesc ^ du_functor_arg_types,
- F = (func(I) = ArgTypeInfo :-
+ F = (func(I) = ArgPseudoTypeInfo :-
PseudoTypeInfo = get_pti_from_arg_types(ArgTypes, I),
- % XXX we can pass 0 instead of an instance of the functor because
- % that is only needed for functors with existentially quantified
- % arguments.
- get_arg_type_info(TypeInfo, PseudoTypeInfo, 0, DuFunctorDesc,
- ArgTypeInfo)
+ ArgPseudoTypeInfo = create_pseudo_type_info(TypeInfo, PseudoTypeInfo)
),
- TypeDescList = iterate(0, Arity - 1, F),
+ PseudoTypeInfoList = iterate(0, Arity - 1, F),
( get_du_functor_arg_names(DuFunctorDesc, ArgNames) ->
Names = iterate(0, Arity - 1, arg_names_index(ArgNames))
@@ -389,26 +399,74 @@ get_functor_du(TypeCtorRep, TypeInfo, TypeCtorInfo, FunctorNumber,
Names = list.duplicate(Arity, null_string)
).
+%-----------------------------------------------------------------------------%
+
+ % 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 :-
+ ( is_exist_pseudo_type_info(PseudoTypeInfo, _VarNum) ->
+ ArgPseudoTypeInfo = PseudoTypeInfo
+ ; is_univ_pseudo_type_info(PseudoTypeInfo, VarNum) ->
+ % In some cases we may need to call var_arity_type_info_index_as_pti.
+ ArgPseudoTypeInfo = type_info_index_as_pti(TypeInfo, VarNum)
+ ; pseudo_type_ctor_and_args(PseudoTypeInfo, TypeCtorInfo, Args0) ->
+ 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)
+ ;
+ error("create_pseudo_type_info")
+ ).
+
+:- func make_type_info(type_ctor_info, int, list(pseudo_type_info)) =
+ type_info.
+
+:- 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 lst = Args;
+ while (!list.is_empty(lst)) {
+ as[i] = (PseudoTypeInfo) 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").
+
+%-----------------------------------------------------------------------------%
+
:- pred get_functor_enum(type_ctor_rep::in(enum), type_ctor_info::in, int::in,
- string::out, int::out, list(type_info)::out, list(string)::out) is det.
+ string::out, int::out, list(pseudo_type_info)::out, list(string)::out)
+ is det.
get_functor_enum(TypeCtorRep, TypeCtorInfo, FunctorNumber, FunctorName, Arity,
- TypeDescList, Names) :-
+ PseudoTypeInfoList, Names) :-
TypeFunctors = get_type_functors(TypeCtorInfo),
EnumFunctorDesc = get_enum_functor_desc(TypeCtorRep, FunctorNumber,
TypeFunctors),
FunctorName = EnumFunctorDesc ^ enum_functor_name,
Arity = 0,
- TypeDescList = [],
+ PseudoTypeInfoList = [],
Names = [].
:- pred get_functor_notag(type_ctor_rep::in(notag), type_ctor_info::in,
- int::in, string::out, int::out, list(type_info)::out, list(string)::out)
- is det.
+ int::in, string::out, int::out, list(pseudo_type_info)::out,
+ list(string)::out) is det.
get_functor_notag(TypeCtorRep, TypeCtorInfo, FunctorNumber, FunctorName, Arity,
- TypeInfoList, Names) :-
+ PseudoTypeInfoList, Names) :-
TypeFunctors = get_type_ctor_functors(TypeCtorInfo),
NoTagFunctorDesc = TypeFunctors ^
notag_functor_desc(TypeCtorRep, FunctorNumber),
@@ -419,18 +477,108 @@ get_functor_notag(TypeCtorRep, TypeCtorInfo, FunctorNumber, FunctorName, Arity,
ArgType = NoTagFunctorDesc ^ notag_functor_arg_type,
ArgName = NoTagFunctorDesc ^ notag_functor_arg_name,
- TypeInfoList = [ArgType],
+ PseudoTypeInfoList = [ArgType],
Names = [ArgName].
%-----------------------------------------------------------------------------%
+
+type_info_get_functor_ordinal(TypeInfo, FunctorNum, Ordinal) :-
+ TypeCtorInfo = get_type_ctor_info(TypeInfo),
+ TypeCtorRep = get_type_ctor_rep(TypeCtorInfo),
+ (
+ ( TypeCtorRep = tcr_enum
+ ; TypeCtorRep = tcr_enum_usereq
+ ),
+ TypeFunctors = get_type_functors(TypeCtorInfo),
+ EnumFunctorDesc = get_enum_functor_desc(TypeCtorRep, FunctorNum,
+ TypeFunctors),
+ Ordinal = enum_functor_ordinal(EnumFunctorDesc)
+ ;
+ ( TypeCtorRep = tcr_foreign_enum
+ ; TypeCtorRep = tcr_foreign_enum_usereq
+ ),
+ % XXX todo
+ fail
+ ;
+ ( 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 = du_functor_ordinal(DuFunctorDesc)
+ ;
+ ( TypeCtorRep = tcr_equiv
+ ; TypeCtorRep = tcr_equiv_ground
+ ; TypeCtorRep = tcr_func
+ ; TypeCtorRep = tcr_pred
+ ; TypeCtorRep = tcr_int
+ ; 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),
+ TypeCtorRep = get_type_ctor_rep(TypeCtorInfo),
+ % XXX This special case seems like it should be not necessary.
+ ( TypeCtorRep = tcr_tuple ->
+ Ordinal = 0,
+ FunctorNumber = 0
+ ;
+ type_ctor_search_functor_number_map(TypeCtorInfo, Ordinal,
+ FunctorNumber)
+ ).
+
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("Java",
get_type_info(_T::unused) = (TypeInfo::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
- // XXX why is the cast needed here?
- TypeInfo = (jmercury.runtime.TypeInfo_Struct) TypeInfo_for_T;
+ TypeInfo = TypeInfo_for_T;
").
:- pragma foreign_proc("C#",
@@ -493,32 +641,32 @@ generic_compare(Res, X, Y) :-
result_call_4(ComparePred, Res, X, Y)
; Arity = 1 ->
result_call_5(ComparePred, Res,
- type_info_index(TypeInfo, 1), X, Y)
+ type_info_index_as_ti(TypeInfo, 1), X, Y)
; Arity = 2 ->
result_call_6(ComparePred, Res,
- type_info_index(TypeInfo, 1),
- type_info_index(TypeInfo, 2),
+ type_info_index_as_ti(TypeInfo, 1),
+ type_info_index_as_ti(TypeInfo, 2),
X, Y)
; Arity = 3 ->
result_call_7(ComparePred, Res,
- type_info_index(TypeInfo, 1),
- type_info_index(TypeInfo, 2),
- type_info_index(TypeInfo, 3),
+ type_info_index_as_ti(TypeInfo, 1),
+ type_info_index_as_ti(TypeInfo, 2),
+ type_info_index_as_ti(TypeInfo, 3),
X, Y)
; Arity = 4 ->
result_call_8(ComparePred, Res,
- type_info_index(TypeInfo, 1),
- type_info_index(TypeInfo, 2),
- type_info_index(TypeInfo, 3),
- type_info_index(TypeInfo, 4),
+ 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)
; Arity = 5 ->
result_call_9(ComparePred, Res,
- type_info_index(TypeInfo, 1),
- type_info_index(TypeInfo, 2),
- type_info_index(TypeInfo, 3),
- type_info_index(TypeInfo, 4),
- type_info_index(TypeInfo, 5),
+ 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)
;
error("compare/3: type arity > 5 not supported")
@@ -544,33 +692,33 @@ generic_unify(X, Y) :-
semidet_call_3(UnifyPred, X, Y)
; Arity = 1 ->
semidet_call_4(UnifyPred,
- type_info_index(TypeInfo, 1),
+ type_info_index_as_ti(TypeInfo, 1),
X, Y)
; Arity = 2 ->
semidet_call_5(UnifyPred,
- type_info_index(TypeInfo, 1),
- type_info_index(TypeInfo, 2),
+ type_info_index_as_ti(TypeInfo, 1),
+ type_info_index_as_ti(TypeInfo, 2),
X, Y)
; Arity = 3 ->
semidet_call_6(UnifyPred,
- type_info_index(TypeInfo, 1),
- type_info_index(TypeInfo, 2),
- type_info_index(TypeInfo, 3),
+ type_info_index_as_ti(TypeInfo, 1),
+ type_info_index_as_ti(TypeInfo, 2),
+ type_info_index_as_ti(TypeInfo, 3),
X, Y)
; Arity = 4 ->
semidet_call_7(UnifyPred,
- type_info_index(TypeInfo, 1),
- type_info_index(TypeInfo, 2),
- type_info_index(TypeInfo, 3),
- type_info_index(TypeInfo, 4),
+ 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)
; Arity = 5 ->
semidet_call_8(UnifyPred,
- type_info_index(TypeInfo, 1),
- type_info_index(TypeInfo, 2),
- type_info_index(TypeInfo, 3),
- type_info_index(TypeInfo, 4),
- type_info_index(TypeInfo, 5),
+ 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)
;
error("unify/2: type arity > 5 not supported")
@@ -590,7 +738,7 @@ unify_tuple_pos(Loc, TupleArity, TypeInfo, TermA, TermB) :-
( Loc > TupleArity ->
true
;
- ArgTypeInfo = var_arity_type_info_index(TypeInfo, Loc),
+ ArgTypeInfo = var_arity_type_info_index_as_ti(TypeInfo, Loc),
SubTermA = get_tuple_subterm(ArgTypeInfo, TermA, Loc - 1),
SubTermB = get_tuple_subterm(ArgTypeInfo, TermB, Loc - 1),
@@ -615,7 +763,7 @@ compare_tuple_pos(Loc, TupleArity, TypeInfo, Result, TermA, TermB) :-
( Loc > TupleArity ->
Result = (=)
;
- ArgTypeInfo = var_arity_type_info_index(TypeInfo, Loc),
+ ArgTypeInfo = var_arity_type_info_index_as_ti(TypeInfo, Loc),
SubTermA = get_tuple_subterm(ArgTypeInfo, TermA, Loc - 1),
SubTermB = get_tuple_subterm(ArgTypeInfo, TermB, Loc - 1),
@@ -914,17 +1062,15 @@ compare_collapsed_type_infos(Res, TypeInfo1, TypeInfo2) :-
TypeCtorInfo1 = get_type_ctor_info(TypeInfo1),
TypeCtorInfo2 = get_type_ctor_info(TypeInfo2),
- % The comparison here is arbitrary. In the past we just compared pointers
- % to the type_ctor_infos.
- compare(NameRes, TypeCtorInfo1 ^ type_ctor_name,
- TypeCtorInfo2 ^ type_ctor_name),
+ % cf. MR_compare_type_info
+ compare(ModNameRes, TypeCtorInfo1 ^ type_ctor_module_name,
+ TypeCtorInfo2 ^ type_ctor_module_name),
(
- NameRes = (=),
- compare(ModNameRes,
- TypeCtorInfo1 ^ type_ctor_module_name,
- TypeCtorInfo2 ^ type_ctor_module_name),
+ ModNameRes = (=),
+ compare(NameRes, TypeCtorInfo1 ^ type_ctor_name,
+ TypeCtorInfo2 ^ type_ctor_name),
(
- ModNameRes = (=),
+ NameRes = (=),
( type_ctor_is_variable_arity(TypeCtorInfo1) ->
Arity1 = get_var_arity_typeinfo_arity(TypeInfo1),
Arity2 = get_var_arity_typeinfo_arity(TypeInfo2),
@@ -943,16 +1089,50 @@ compare_collapsed_type_infos(Res, TypeInfo1, TypeInfo2) :-
Res = (=)
)
;
- ( ModNameRes = (<)
- ; ModNameRes = (>)
+ ( NameRes = (<)
+ ; NameRes = (>)
),
- Res = ModNameRes
+ Res = NameRes
)
;
- ( NameRes = (<)
- ; NameRes = (>)
+ ( ModNameRes = (<)
+ ; ModNameRes = (>)
),
- Res = NameRes
+ Res = ModNameRes
+ ).
+
+:- pred compare_type_ctor_infos(comparison_result::out,
+ type_ctor_info::in, type_ctor_info::in) is det.
+
+:- 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_var_arity_typeinfos(int::in, int::in,
@@ -962,8 +1142,8 @@ compare_var_arity_typeinfos(Loc, Arity, Result, TypeInfoA, TypeInfoB) :-
( Loc > Arity ->
Result = (=)
;
- SubTypeInfoA = var_arity_type_info_index(TypeInfoA, Loc),
- SubTypeInfoB = var_arity_type_info_index(TypeInfoB, Loc),
+ 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),
(
@@ -1040,10 +1220,10 @@ type_ctor_and_args(TypeInfo0, TypeCtorInfo, TypeArgs) :-
type_ctor_is_variable_arity(TypeCtorInfo)
->
Arity = get_var_arity_typeinfo_arity(TypeInfo),
- TypeArgs = iterate(1, Arity, var_arity_type_info_index(TypeInfo))
+ TypeArgs = iterate(1, Arity, var_arity_type_info_index_as_ti(TypeInfo))
;
Arity = type_ctor_arity(TypeCtorInfo),
- TypeArgs = iterate(1, Arity, type_info_index(TypeInfo))
+ TypeArgs = iterate(1, Arity, type_info_index_as_ti(TypeInfo))
).
:- func iterate(int, int, (func(int) = T)) = list(T).
@@ -1059,6 +1239,64 @@ iterate(Start, Max, Func) = Results :-
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
+:- 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 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;
+ }
+ succeeded = true;
+ } else {
+ /* Fail if input is a variable. */
+ TypeCtorInfo = null;
+ ArgPseudoTypeInfos = null;
+ succeeded = false;
+ }
+").
+
+pseudo_type_ctor_and_args(_, _, _) :-
+ private_builtin.sorry("pseudo_type_ctor_and_args/3").
+
+:- 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;
+ succeeded = (VarNum >= 0 && VarNum <= last_univ_quant_varnum);
+").
+
+is_univ_pseudo_type_info(_, _) :-
+ private_builtin.sorry("is_univ_pseudo_type_info/2").
+
+:- 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;
+ succeeded = (VarNum >= first_exist_quant_varnum);
+").
+
+is_exist_pseudo_type_info(_, _) :-
+ private_builtin.sorry("is_exist_pseudo_type_info/2").
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
:- pragma foreign_code("Java", "
private static Object[]
@@ -1956,14 +2194,13 @@ high_level_data :-
get_arg_type_info(TypeInfoParams, PseudoTypeInfo, Term, FunctorDesc,
ArgTypeInfo) :-
( pseudo_type_info_is_variable(PseudoTypeInfo, VarNum) ->
- get_type_info_for_var(TypeInfoParams, VarNum, Term, FunctorDesc,
- ArgTypeInfo)
+ get_type_info_for_var(TypeInfoParams, VarNum, Term,
+ FunctorDesc, ArgTypeInfo)
;
CastTypeInfo = type_info_from_pseudo_type_info(PseudoTypeInfo),
TypeCtorInfo = get_type_ctor_info(CastTypeInfo),
( type_ctor_is_variable_arity(TypeCtorInfo) ->
- % XXX This branch seems to be unreachable.
- Arity = pseudotypeinfo_get_higher_order_arity(CastTypeInfo),
+ Arity = type_info_get_higher_order_arity(CastTypeInfo),
StartRegionSize = 2
;
Arity = TypeCtorInfo ^ type_ctor_arity,
@@ -1990,12 +2227,18 @@ get_arg_type_info_2(TypeInfoParams, TypeInfo, Term, FunctorDesc,
true
).
- % XXX This is completely unimplemented.
- %
-:- func pseudotypeinfo_get_higher_order_arity(type_info) = int.
+:- func type_info_get_higher_order_arity(type_info) = int.
+
+:- pragma foreign_proc("Java",
+ type_info_get_higher_order_arity(PseudoTypeInfo::in) = (Arity::out),
+ [will_not_call_mercury, promise_pure, thread_safe, may_not_duplicate],
+"
+ TypeInfo_Struct ti = (TypeInfo_Struct) PseudoTypeInfo;
+ Arity = ti.args.length;
+").
-pseudotypeinfo_get_higher_order_arity(_) = 1 :-
- det_unimplemented("pseudotypeinfo_get_higher_order_arity").
+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.
@@ -2074,8 +2317,9 @@ get_pti_from_type_info_index(_, _, _, _) :-
get_type_info_for_var(TypeInfo, VarNum, Term, FunctorDesc, ArgTypeInfo) :-
( type_variable_is_univ_quant(VarNum) ->
- ArgTypeInfo = type_info_index(TypeInfo, VarNum)
+ ArgTypeInfo = type_info_index_as_ti(TypeInfo, VarNum)
;
+ % Existentially qualified.
( get_du_functor_exist_info(FunctorDesc, ExistInfo0) ->
ExistInfo = ExistInfo0
;
@@ -2162,7 +2406,9 @@ get_subterm(_, _, _, _, _) = -1 :-
if (FunctorDesc.du_functor_arg_names != null) {
fieldName = FunctorDesc.du_functor_arg_names[Index];
}
- if (fieldName == null) {
+ if (fieldName != null) {
+ fieldName = ML_name_mangle(fieldName);
+ } else {
// The F<i> field variables are numbered from 1.
int i = 1 + Index + ExtraArgs;
fieldName = ""F"" + i;
@@ -2267,13 +2513,16 @@ last_univ_quant_varnum = 512.
first_exist_quant_varnum = 513.
+:- pragma foreign_code("Java", "
+private static final int last_univ_quant_varnum = 512;
+private static final int first_exist_quant_varnum = 513;
+").
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
%
% XXX we have only implemented the .NET backend for the low-level data case.
-:- func get_type_ctor_info(type_info) = type_ctor_info is det.
-
:- pragma foreign_code("C#", "
// The field numbers of the contents of type_infos.
@@ -2726,58 +2975,100 @@ typeclass_info_type_info(TypeClassInfo, Index) = TypeInfo :-
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
-:- func var_arity_type_info_index(type_info, int) = type_info.
+:- func var_arity_type_info_index_as_ti(type_info, int) = type_info.
+:- func var_arity_type_info_index_as_pti(type_info, int) = pseudo_type_info.
-var_arity_type_info_index(TypeInfo, Index) =
- type_info_index(TypeInfo, Index + 1).
+var_arity_type_info_index_as_ti(TypeInfo, Index) =
+ type_info_index_as_ti(TypeInfo, Index + 1).
- % The generic definition of var_arity_type_info_index assumes that
- % variable arity type_infos store the arity in the first word but that's
- % not true for the jmercury.runtime.TypeInfo_Struct in Java.
+var_arity_type_info_index_as_pti(TypeInfo, Index) =
+ type_info_index_as_pti(TypeInfo, Index + 1).
+
+ % 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's not true for the jmercury.runtime.TypeInfo_Struct in Java.
%
- % Keep this in sync with the Java version of type_info_index.
+ % Keep this in sync with the Java version of type_info_index_as_ti/pti.
%
:- pragma foreign_proc("Java",
- var_arity_type_info_index(TypeInfo::in, VarNum::in)
+ 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;
+ assert VarNum > 0;
TypeInfoAtIndex =
(jmercury.runtime.TypeInfo_Struct) TypeInfo.args[VarNum - 1];
").
-:- func type_info_index(type_info, int) = type_info.
+:- 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];
+").
-type_info_index(TypeInfo, _) = TypeInfo :-
+:- func type_info_index_as_ti(type_info, int) = type_info.
+:- func type_info_index_as_pti(type_info, int) = pseudo_type_info.
+
+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").
+type_info_index_as_pti(TypeInfo, _) = PseudoTypeInfo :-
+ det_unimplemented("type_info_index_as_pti"),
+ private_builtin.unsafe_type_cast(TypeInfo, PseudoTypeInfo).
+
+:- pragma foreign_proc("C#",
+ type_info_index_as_ti(TypeInfo::in, Index::in) = (TypeInfoAtIndex::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ TypeInfoAtIndex = (object[]) TypeInfo[Index];
+").
+
:- pragma foreign_proc("C#",
- type_info_index(TypeInfo::in, Index::in) = (TypeInfoAtIndex::out),
+ type_info_index_as_pti(TypeInfo::in, Index::in) = (TypeInfoAtIndex::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
TypeInfoAtIndex = (object[]) TypeInfo[Index];
").
- % Keep this in sync with the Java version of var_arity_type_info_index.
+ % Keep this in sync with the Java version of
+ % var_arity_type_info_index_as_ti/pti and type_info_index_as_ti/pti.
%
:- pragma foreign_proc("Java",
- type_info_index(TypeInfo::in, VarNum::in) = (TypeInfoAtIndex::out),
+ 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;
+ assert VarNum > 0;
TypeInfoAtIndex =
(jmercury.runtime.TypeInfo_Struct) 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];
+").
+
:- pred set_type_info_index(int::in, int::in, type_info::in,
type_info::di, type_info::uo) is det.
@@ -3078,6 +3369,26 @@ type_ctor_num_functors(_) = _ :-
% 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 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];
+ succeeded = true;
+ } else {
+ FunctorNumber = -1;
+ succeeded = false;
+ }
+").
+
+type_ctor_search_functor_number_map(_, _, _) :-
+ private_builtin.sorry("type_ctor_search_functor_number_map/3").
+
%-----------------------------------------------------------------------------%
%
% TypeFunctors
@@ -3368,19 +3679,16 @@ notag_functor_name(NoTagFunctorDesc) = NoTagFunctorDesc ^ unsafe_index(0).
Name = NotagFunctorDesc.no_tag_functor_name;
").
- % XXX This is a bug. This function should actually return a PseudoTypeInfo.
- % The Java code below should work once this is corrected.
- %
-:- func notag_functor_arg_type(notag_functor_desc) = type_info.
+:- func notag_functor_arg_type(notag_functor_desc) = pseudo_type_info.
notag_functor_arg_type(NoTagFunctorDesc) = NoTagFunctorDesc ^ unsafe_index(1).
-% :- 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;
-% ").
+:- 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.
diff --git a/library/type_desc.m b/library/type_desc.m
index 50c2cd3..c2303e3 100644
--- a/library/type_desc.m
+++ b/library/type_desc.m
@@ -227,12 +227,6 @@
:- pred type_info_list_to_type_desc_list(
list(rtti_implementation.type_info)::in, list(type_desc)::out) is det.
-:- pred type_ctor_desc_to_type_ctor_info(type_ctor_desc::in,
- rtti_implementation.type_ctor_info::out) is det.
-
-:- pred type_ctor_info_to_type_ctor_desc(
- rtti_implementation.type_ctor_info::in, type_ctor_desc::out) is det.
-
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -251,6 +245,25 @@
#include ""mercury_type_desc.h""
").
+% The Java backend substitutes:
+%
+% type_desc == jmercury.runtime.TypeInfo_Struct
+% pseudo_type_desc == jmercury.runtime.PseudoTypeDesc
+% type_ctor_desc == jmercury.runtime.TypeCtorInfo_Struct
+%
+% We can't use `:- pragma foreign_type' because the compiler will complain
+% that non-Java grades are missing type definitions.
+
+:- pragma foreign_decl("Java", local, "
+/*
+** Any foreign_procs which use the unqualified names should be marked
+** `may_not_duplicate' so as not to be written to .opt files.
+*/
+import jmercury.runtime.PseudoTypeInfo;
+import jmercury.runtime.TypeCtorInfo_Struct;
+import jmercury.runtime.TypeInfo_Struct;
+").
+
%-----------------------------------------------------------------------------%
type_desc_to_type_info(TypeDesc, TypeInfo) :-
@@ -260,13 +273,6 @@ type_desc_to_type_info(TypeDesc, TypeInfo) :-
error("type_desc_to_type_info/2")
).
-:- pragma foreign_proc("Java",
- type_desc_to_type_info(TypeDesc::in, TypeInfo::out),
- [will_not_call_mercury, promise_pure, thread_safe],
-"
- TypeInfo = TypeDesc.type_info();
-").
-
type_info_to_type_desc(TypeInfo, TypeDesc) :-
( type_info_desc_same_representation ->
private_builtin.unsafe_type_cast(TypeInfo, TypeDesc)
@@ -274,13 +280,6 @@ type_info_to_type_desc(TypeInfo, TypeDesc) :-
error("type_info_to_type_desc/2")
).
-:- pragma foreign_proc("Java",
- type_info_to_type_desc(TypeInfo::in, TypeDesc::out),
- [will_not_call_mercury, promise_pure, thread_safe],
-"
- TypeDesc = new type_desc.Type_desc_0(TypeInfo);
-").
-
type_info_list_to_type_desc_list(TypeInfoList, TypeDescList) :-
( type_info_desc_same_representation ->
private_builtin.unsafe_type_cast(TypeInfoList, TypeDescList)
@@ -288,6 +287,9 @@ type_info_list_to_type_desc_list(TypeInfoList, TypeDescList) :-
list.map(type_info_to_type_desc, TypeInfoList, TypeDescList)
).
+:- pred type_ctor_desc_to_type_ctor_info(type_ctor_desc::in,
+ rtti_implementation.type_ctor_info::out) is det.
+
type_ctor_desc_to_type_ctor_info(TypeCtorDesc, TypeCtorInfo) :-
( type_info_desc_same_representation ->
private_builtin.unsafe_type_cast(TypeCtorDesc, TypeCtorInfo)
@@ -295,39 +297,21 @@ type_ctor_desc_to_type_ctor_info(TypeCtorDesc, TypeCtorInfo) :-
error("type_ctor_desc_to_type_ctor_info/2")
).
-:- pragma foreign_proc("Java",
- type_ctor_desc_to_type_ctor_info(TypeCtorDesc::in, TypeCtorInfo::out),
- [will_not_call_mercury, promise_pure, thread_safe],
-"
- TypeCtorInfo = TypeCtorDesc.type_ctor_info();
-").
+:- pred pseudo_type_desc_to_pseudo_type_info(pseudo_type_desc::in,
+ rtti_implementation.pseudo_type_info::out) is det.
-type_ctor_info_to_type_ctor_desc(TypeCtorInfo, TypeCtorDesc) :-
+pseudo_type_desc_to_pseudo_type_info(PseudoTypeDesc, PseudoTypeInfo) :-
( type_info_desc_same_representation ->
- private_builtin.unsafe_type_cast(TypeCtorInfo, TypeCtorDesc)
+ private_builtin.unsafe_type_cast(PseudoTypeDesc, PseudoTypeInfo)
;
- error("type_ctor_info_to_type_ctor_desc/2")
+ error("pseudo_type_desc_to_pseudo_type_info/2")
).
-:- pragma foreign_proc("Java",
- type_ctor_info_to_type_ctor_desc(TypeCtorInfo::in, TypeCtorDesc::out),
- [will_not_call_mercury, promise_pure, thread_safe],
-"
- TypeCtorDesc = new type_desc.Type_ctor_desc_0(TypeCtorInfo);
-").
-
:- pred type_info_desc_same_representation is semidet.
type_info_desc_same_representation :-
semidet_true.
-:- pragma foreign_proc("Java",
- type_info_desc_same_representation,
- [will_not_call_mercury, promise_pure, thread_safe],
-"
- succeeded = false;
-").
-
%-----------------------------------------------------------------------------%
% We need to call the rtti_implementation module -- so that we get the
@@ -452,7 +436,8 @@ is_univ_pseudo_type_desc(PTD, N) :-
( erlang_rtti_implementation.is_erlang_backend ->
erlang_rtti_implementation.is_univ_pseudo_type_desc(PTD, N)
;
- private_builtin.sorry("is_univ_pseudo_type_desc")
+ pseudo_type_desc_to_pseudo_type_info(PTD, PTI),
+ rtti_implementation.is_univ_pseudo_type_info(PTI, N)
).
:- pred is_exist_pseudo_type_desc(pseudo_type_desc::in, int::out) is semidet.
@@ -479,7 +464,8 @@ is_exist_pseudo_type_desc(PTD, N) :-
( erlang_rtti_implementation.is_erlang_backend ->
erlang_rtti_implementation.is_exist_pseudo_type_desc(PTD, N)
;
- private_builtin.sorry("is_exist_pseudo_type_desc")
+ pseudo_type_desc_to_pseudo_type_info(PTD, PTI),
+ rtti_implementation.is_exist_pseudo_type_info(PTI, N)
).
:- pragma foreign_proc("C",
@@ -522,38 +508,6 @@ ground_pseudo_type_desc_to_type_desc_det(PseudoTypeDesc) = TypeDesc :-
error("ground_pseudo_type_desc_to_type_desc_det: not ground")
).
-:- pragma foreign_proc("Java",
- ground_pseudo_type_desc_to_type_desc(PseudoTypeDesc::in) = (TypeDesc::out),
- [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail],
-"
- Pseudo_type_desc_0 ptd = PseudoTypeDesc;
-
- if (ptd.struct instanceof jmercury.runtime.TypeInfo_Struct) {
- TypeDesc = new Type_desc_0(
- (jmercury.runtime.TypeInfo_Struct) ptd.struct);
- succeeded = true;
- } else {
- TypeDesc = null;
- succeeded = false;
- }
-").
-
-:- pragma foreign_proc("Java",
- ground_pseudo_type_desc_to_type_desc_det(PseudoTypeDesc::in)
- = (TypeDesc::out),
- [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail],
-"
- Pseudo_type_desc_0 ptd = PseudoTypeDesc;
-
- if (ptd.struct instanceof jmercury.runtime.TypeInfo_Struct) {
- TypeDesc = new Type_desc_0(
- (jmercury.runtime.TypeInfo_Struct) ptd.struct);
- } else {
- throw new java.lang.Error(
- ""ground_pseudo_type_desc_to_type_desc_det/2 not implemented"");
- }
-").
-
:- pragma foreign_proc("C",
type_of(_Value::unused) = (TypeInfo::out),
[will_not_call_mercury, thread_safe, promise_pure, will_not_modify_trail,
@@ -586,8 +540,7 @@ ground_pseudo_type_desc_to_type_desc_det(PseudoTypeDesc) = TypeDesc :-
type_of(_Value::unused) = (TypeInfo::out),
[will_not_call_mercury, thread_safe, promise_pure],
"
- TypeInfo = new type_desc.Type_desc_0(
- (jmercury.runtime.TypeInfo_Struct) TypeInfo_for_T);
+ TypeInfo = TypeInfo_for_T;
").
:- pragma foreign_proc("Erlang",
@@ -615,7 +568,7 @@ ground_pseudo_type_desc_to_type_desc_det(PseudoTypeDesc) = TypeDesc :-
has_type(_Arg::unused, TypeInfo::in),
[will_not_call_mercury, thread_safe, promise_pure],
"
- TypeInfo_for_T = TypeInfo.type_info();
+ TypeInfo_for_T = TypeInfo;
").
:- pragma foreign_proc("Erlang",
@@ -750,7 +703,9 @@ type_ctor(TypeDesc) = TypeCtorDesc :-
( erlang_rtti_implementation.is_erlang_backend ->
erlang_rtti_implementation.type_ctor_desc(TypeDesc, TypeCtorDesc)
;
- private_builtin.sorry("type_ctor/1")
+ type_desc_to_type_info(TypeDesc, TypeInfo),
+ TypeCtorInfo = rtti_implementation.get_type_ctor_info(TypeInfo),
+ make_type_ctor_desc(TypeInfo, TypeCtorInfo, TypeCtorDesc)
).
:- pragma foreign_proc("C",
@@ -776,6 +731,9 @@ type_ctor(TypeDesc) = TypeCtorDesc :-
}
}").
+pseudo_type_ctor(_) = _ :-
+ private_builtin.sorry("pseudo_type_ctor/1").
+
:- pragma foreign_proc("C",
type_ctor_and_args(TypeDesc::in, TypeCtorDesc::out, ArgTypes::out),
[will_not_call_mercury, thread_safe, promise_pure, will_not_modify_trail],
@@ -792,27 +750,6 @@ type_ctor(TypeDesc) = TypeCtorDesc :-
MR_restore_transient_registers();
}").
-:- pragma foreign_proc("Java",
- type_ctor_and_args(TypeDesc::in, TypeCtorDesc::out, ArgTypes::out),
- [may_call_mercury, thread_safe, promise_pure, terminates],
-"
- java.lang.Object [] result =
- rtti_implementation.type_ctor_and_args_3_p_0(TypeDesc.type_info());
-
- TypeCtorDesc = new Type_ctor_desc_0(
- (jmercury.runtime.TypeCtorInfo_Struct) result[0]);
- ArgTypes = (list.List_1) result[1];
-
- // Convert list from jmercury.runtime.TypeInfo_Struct to type_desc_0
- list.List_1 type_list = ArgTypes;
- while (type_list.data_tag == 1) {
- ((list.List_1.F_cons_2) type_list).F1 =
- new type_desc.Type_desc_0((jmercury.runtime.TypeInfo_Struct)
- ((list.List_1.F_cons_2) type_list).F1);
- type_list = (list.List_1) ((list.List_1.F_cons_2) type_list).F2;
- }
-").
-
type_ctor_and_args(TypeDesc, TypeCtorDesc, ArgTypeDescs) :-
( erlang_rtti_implementation.is_erlang_backend ->
erlang_rtti_implementation.type_ctor_desc_and_args(TypeDesc,
@@ -821,7 +758,7 @@ type_ctor_and_args(TypeDesc, TypeCtorDesc, ArgTypeDescs) :-
type_desc_to_type_info(TypeDesc, TypeInfo),
rtti_implementation.type_ctor_and_args(TypeInfo, TypeCtorInfo,
ArgTypeInfos),
- type_ctor_info_to_type_ctor_desc(TypeCtorInfo, TypeCtorDesc),
+ make_type_ctor_desc(TypeInfo, TypeCtorInfo, TypeCtorDesc),
type_info_list_to_type_desc_list(ArgTypeInfos, ArgTypeDescs)
).
@@ -843,14 +780,89 @@ type_ctor_and_args(TypeDesc, TypeCtorDesc, ArgTypeDescs) :-
SUCCESS_INDICATOR = success;
}").
-pseudo_type_ctor_and_args(PTD, TC, Args) :-
+pseudo_type_ctor_and_args(PseudoTypeDesc, TypeCtorDesc, ArgPseudoTypeDescs) :-
( erlang_rtti_implementation.is_erlang_backend ->
- erlang_rtti_implementation.pseudo_type_ctor_and_args(PTD, TC, Args)
+ erlang_rtti_implementation.pseudo_type_ctor_and_args(PseudoTypeDesc,
+ TypeCtorDesc, ArgPseudoTypeDescs)
;
- private_builtin.sorry("pseudo_type_ctor_and_args")
+ pseudo_type_desc_to_pseudo_type_info(PseudoTypeDesc, PseudoTypeInfo),
+ rtti_implementation.pseudo_type_ctor_and_args(PseudoTypeInfo,
+ TypeCtorInfo, ArgPseudoTypeInfos),
+ Arity = list.length(ArgPseudoTypeInfos),
+ make_type_ctor_desc_with_arity(Arity, TypeCtorInfo, TypeCtorDesc),
+ private_builtin.unsafe_type_cast(ArgPseudoTypeInfos,
+ ArgPseudoTypeDescs)
).
-% This is the forwards mode of make_type/2: given a type constructor and
+%-----------------------------------------------------------------------------%
+
+ % Make a type_info_desc from a type_ctor_info. A type_info_desc is
+ % different to a type_ctor_info in the case of variable arity types,
+ % i.e. predicates, functions and tuples.
+ %
+ % The C implementation uses small integers to encode variable arity
+ % type_ctor_infos (see mercury_type_desc.h). In the Java backend we simply
+ % allocate new TypeCtorInfo_Struct objects and set the `arity' field.
+ % Two equivalent type_ctor_descs may have different addresses.
+ %
+:- pred make_type_ctor_desc(rtti_implementation.type_info::in,
+ rtti_implementation.type_ctor_info::in, type_ctor_desc::out) is det.
+
+:- pragma foreign_proc("Java",
+ make_type_ctor_desc(TypeInfo::in, TypeCtorInfo::in, TypeCtorDesc::out),
+ [will_not_call_mercury, promise_pure, thread_safe,
+ may_not_duplicate],
+"
+ TypeCtorInfo_Struct tci = TypeCtorInfo;
+
+ /* Handle variable arity types. */
+ switch (tci.type_ctor_rep.value) {
+ case private_builtin.MR_TYPECTOR_REP_PRED:
+ case private_builtin.MR_TYPECTOR_REP_FUNC:
+ case private_builtin.MR_TYPECTOR_REP_TUPLE:
+ tci = new TypeCtorInfo_Struct(tci, TypeInfo.args.length);
+ break;
+ default:
+ break;
+ }
+
+ TypeCtorDesc = tci;
+").
+
+make_type_ctor_desc(_, _, _) :-
+ private_builtin.sorry("make_type_ctor_desc/3").
+
+:- pred make_type_ctor_desc_with_arity(int::in,
+ rtti_implementation.type_ctor_info::in, type_ctor_desc::out) is det.
+
+:- pragma foreign_proc("Java",
+ make_type_ctor_desc_with_arity(Arity::in, TypeCtorInfo::in,
+ TypeCtorDesc::out),
+ [will_not_call_mercury, promise_pure, thread_safe,
+ may_not_duplicate],
+"
+ TypeCtorInfo_Struct tci = TypeCtorInfo;
+
+ /* Handle variable arity types. */
+ switch (tci.type_ctor_rep.value) {
+ case private_builtin.MR_TYPECTOR_REP_PRED:
+ case private_builtin.MR_TYPECTOR_REP_FUNC:
+ case private_builtin.MR_TYPECTOR_REP_TUPLE:
+ tci = new TypeCtorInfo_Struct(tci, Arity);
+ break;
+ default:
+ break;
+ }
+
+ TypeCtorDesc = tci;
+").
+
+make_type_ctor_desc_with_arity(_, _, _) :-
+ private_builtin.sorry("make_type_ctor_desc_with_arity/3").
+
+%-----------------------------------------------------------------------------%
+
+% This is the forwards mode of make_type/1: given a type constructor and
% a list of argument types, check that the length of the argument types
% matches the arity of the type constructor, and if so, use the type
% constructor to construct a new type with the specified arguments.
@@ -891,6 +903,32 @@ pseudo_type_ctor_and_args(PTD, TC, Args) :-
}
}").
+:- pragma foreign_proc("Java",
+ make_type(TypeCtorDesc::in, ArgTypes::in) = (TypeDesc::out),
+ [will_not_call_mercury, thread_safe, will_not_modify_trail,
+ may_not_duplicate],
+"{
+ PseudoTypeInfo[] as = new PseudoTypeInfo[TypeCtorDesc.arity];
+
+ succeeded = true;
+ list.List_1 arg_types = ArgTypes;
+ for (int i = 0; i < TypeCtorDesc.arity; i++) {
+ if (list.is_empty(arg_types)) {
+ succeeded = false;
+ break;
+ }
+ as[i] = (TypeInfo_Struct) list.det_head(arg_types);
+ arg_types = list.det_tail(arg_types);
+ }
+
+ if (succeeded) {
+ TypeDesc = new TypeInfo_Struct();
+ TypeDesc.init(TypeCtorDesc, as);
+ } else {
+ TypeDesc = null;
+ }
+}").
+
/*
** This is the reverse mode of make_type: given a type,
** split it up into a type constructor and a list of
@@ -918,11 +956,11 @@ make_type(TypeCtorDesc::in, ArgTypes::in) = (TypeDesc::out) :-
erlang_rtti_implementation.make_type_desc(TypeCtorDesc, ArgTypes,
TypeDesc)
;
- private_builtin.sorry("make_type/2")
+ private_builtin.sorry("make_type(in, in) = out")
).
make_type(_TypeCtorDesc::out, _ArgTypes::out) = (_TypeDesc::in) :-
- private_builtin.sorry("make_type/2").
+ private_builtin.sorry("make_type(out, out) = in").
:- pragma foreign_proc("C",
type_ctor_name_and_arity(TypeCtorDesc::in, TypeCtorModuleName::out,
@@ -958,21 +996,8 @@ make_type(_TypeCtorDesc::out, _ArgTypes::out) = (_TypeDesc::in) :-
}
}").
-:- pragma foreign_proc("Java",
- type_ctor_name_and_arity(TypeCtorDesc::in, TypeCtorModuleName::out,
- TypeCtorName::out, TypeCtorArity::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"
- Object[] result = rtti_implementation.
- type_ctor_name_and_arity_4_p_0(TypeCtorDesc.type_ctor_info());
-
- TypeCtorModuleName = (java.lang.String) result[0];
- TypeCtorName = (java.lang.String) result[1];
- TypeCtorArity = ((java.lang.Integer) result[2]).intValue();
-").
-
-type_ctor_name_and_arity(TypeCtorDesc::in, ModuleName::out,
- TypeCtorName::out, TypeCtorArity::out) :-
+type_ctor_name_and_arity(TypeCtorDesc, ModuleName, TypeCtorName,
+ TypeCtorArity) :-
( erlang_rtti_implementation.is_erlang_backend ->
erlang_rtti_implementation.type_ctor_desc_name_and_arity(TypeCtorDesc,
ModuleName, TypeCtorName, TypeCtorArity)
@@ -1005,84 +1030,44 @@ get_type_info_for_type_info = TypeDesc :-
%-----------------------------------------------------------------------------%
:- pragma foreign_code("Java", "
- // XXX Why can't we just use the jmercury.runtime.* classes?
-
- public static class Pseudo_type_desc_0 {
- final protected jmercury.runtime.PseudoTypeInfo struct;
-
- public Pseudo_type_desc_0(jmercury.runtime.PseudoTypeInfo init) {
- struct = init;
- }
- }
-
- public static class Type_desc_0 extends Pseudo_type_desc_0 {
- public Type_desc_0(jmercury.runtime.TypeInfo_Struct init) {
- super(init);
- }
-
- public jmercury.runtime.TypeInfo_Struct type_info() {
- return (jmercury.runtime.TypeInfo_Struct) this.struct;
- }
- }
-
- public static class Type_ctor_desc_0 extends Pseudo_type_desc_0 {
- public Type_ctor_desc_0(jmercury.runtime.TypeCtorInfo_Struct init) {
- super(init);
- }
-
- public jmercury.runtime.TypeCtorInfo_Struct type_ctor_info() {
- return (jmercury.runtime.TypeCtorInfo_Struct) this.struct;
- }
- }
-
public static boolean
- __Unify____type_desc_0_0(type_desc.Type_desc_0 x, type_desc.Type_desc_0 y)
+ __Unify____type_desc_0_0(TypeInfo_Struct x, TypeInfo_Struct y)
{
- return x.type_info().unify(y.type_info());
+ return x.unify(y);
}
public static boolean
- __Unify____type_ctor_desc_0_0(type_desc.Type_ctor_desc_0 x,
- type_desc.Type_ctor_desc_0 y)
+ __Unify____type_ctor_desc_0_0(TypeCtorInfo_Struct x, TypeCtorInfo_Struct y)
{
- return x.type_ctor_info().unify(y.type_ctor_info());
+ return x.unify(y);
}
public static builtin.Comparison_result_0
- __Compare____type_desc_0_0(type_desc.Type_desc_0 x,
- type_desc.Type_desc_0 y)
+ __Compare____type_desc_0_0(TypeInfo_Struct x, TypeInfo_Struct y)
{
- return rtti_implementation.ML_compare_type_infos(
- x.type_info(), y.type_info());
+ return rtti_implementation.ML_compare_type_infos(x, y);
}
public static builtin.Comparison_result_0
- __Compare____type_ctor_desc_0_0(type_desc.Type_ctor_desc_0 x,
- type_desc.Type_ctor_desc_0 y)
+ __Compare____type_ctor_desc_0_0(TypeCtorInfo_Struct x,
+ TypeCtorInfo_Struct y)
{
- // stub only
- throw new java.lang.Error
- (""compare/3 for type_ctor_desc type not implemented"");
+ return rtti_implementation.ML_compare_type_ctor_infos(x, y);
}
public static boolean
- __Unify____pseudo_type_desc_0_0(type_desc.Pseudo_type_desc_0 x,
- type_desc.Pseudo_type_desc_0 y)
+ __Unify____pseudo_type_desc_0_0(PseudoTypeInfo x, PseudoTypeInfo y)
{
- // stub only
- throw new java.lang.Error(
- ""__Unify____type_ctor_desc_0_0 not implemented"");
+ return x.unify(y);
}
public static builtin.Comparison_result_0
- __Compare____pseudo_type_desc_0_0(type_desc.Pseudo_type_desc_0 x,
- type_desc.Pseudo_type_desc_0 y)
+ __Compare____pseudo_type_desc_0_0(PseudoTypeInfo x, PseudoTypeInfo y)
{
// stub only
throw new java.lang.Error(
""__Compare____pseudo_type_desc_0_0 not implemented"");
}
-
").
:- pragma foreign_code("Erlang", "
--------------------------------------------------------------------------
mercury-reviews mailing list
Post messages to: mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions: mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------
More information about the reviews
mailing list