mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2026-04-18 19:03:45 +00:00
Code Issues Projects Releases Wiki Activity
Files
083d376e6598628362ee91c2da170febd83590f4
mercury/library/type_desc.m
Zoltan Somogyi 6508c312f6 Fix indentation.
2022-10-11 16:01:46 +11:00

1060 lines
37 KiB
Mathematica
Raw Blame History

%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 2002-2007, 2009-2012 The University of Melbourne.
% Copyright (C) 2013-2022 The Mercury team.
% This file is distributed under the terms specified in COPYING.LIB.
%---------------------------------------------------------------------------%
%
% File: type_desc.m.
% Main author: fjh, zs.
% Stability: low.
%
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- module type_desc.
:- interface.
:- import_module list.
%---------------------------------------------------------------------------%
% The `type_desc', `pseudo_type_desc' and `type_ctor_desc' types
% provide access to type information.
% A type_desc represents a type, e.g. `list(int)'.
% A pseudo_type_desc represents a type that possibly contains type
% variables, e.g. `list(T)'.
% A type_ctor_desc represents a type constructor, e.g. `list/1'.
%
:- type type_desc.
:- type pseudo_type_desc.
:- type type_ctor_desc.
% The possibly nonground type represented by a pseudo_type_desc
% is either a type constructor applied to zero or more
% pseudo_type_descs, or a type variable. If the latter, the
% type variable may be either universally or existentially quantified.
% In either case, the type is identified by an integer, which has no
% meaning beyond the fact that two type variables will be represented
% by identical integers if and only if they are the same type variable.
% Existentially quantified type variables may have type class
% constraints placed on them, but for now we can't return these.
%
:- type pseudo_type_rep
---> bound(type_ctor_desc, list(pseudo_type_desc))
; univ_tvar(int)
; exist_tvar(int).
:- pred pseudo_type_desc_is_ground(pseudo_type_desc::in) is semidet.
% This function allows the caller to look into the structure
% of the given pseudo_type_desc.
%
:- func pseudo_type_desc_to_rep(pseudo_type_desc) = pseudo_type_rep.
% Convert a type_desc, which by definition describes a ground type,
% to a pseudo_type_desc.
%
:- func type_desc_to_pseudo_type_desc(type_desc) = pseudo_type_desc.
% Convert a pseudo_type_desc describing a ground type to a type_desc.
% If the pseudo_type_desc describes a non-ground type, fail.
%
:- func ground_pseudo_type_desc_to_type_desc(pseudo_type_desc) = type_desc
is semidet.
:- pred ground_pseudo_type_desc_to_type_desc(pseudo_type_desc::in,
type_desc::out) is semidet.
% Convert a pseudo_type_desc describing a ground type to a type_desc.
% Throw an exception if the pseudo_type_desc describes a non-ground type.
%
:- func det_ground_pseudo_type_desc_to_type_desc(pseudo_type_desc) = type_desc.
%---------------------------------------------------------------------------%
% The function type_of/1 returns a representation of the type
% of its argument.
%
% (Note: it is not possible for the type of a variable to be an unbound
% type variable; if there are no constraints on a type variable, then the
% typechecker will use the type `void'. `void' is a special (builtin) type
% that has no constructors. There is no way of creating an object of
% type `void'. `void' is not considered to be a discriminated union, so
% get_functor/5 and construct/3 will fail if used upon a value of
% this type.)
%
:- func type_of(T::unused) = (type_desc::out) is det.
% The predicate has_type/2 is basically an existentially typed inverse
% to the function type_of/1. It constrains the type of the first argument
% to be the type represented by the second argument.
%
:- some [T] pred has_type(T::unused, type_desc::in) is det.
% The predicate same_type/2 ensures type identity of the two arguments.
%
:- pred same_type(T::unused, T::unused) is det.
% type_name(Type) returns the name of the specified type
% (e.g. type_name(type_of([2,3])) = "list.list(int)").
% Any equivalence types will be fully expanded.
% Builtin types (those defined in builtin.m) will not have
% a module qualifier.
%
:- func type_name(type_desc) = string.
% type_ctor_and_args(Type, TypeCtor, TypeArgs):
%
% True iff TypeCtor is a representation of the top-level type constructor
% for Type, and TypeArgs is a list of the corresponding type arguments
% to TypeCtor, and TypeCtor is not an equivalence type.
%
% For example, type_ctor_and_args(type_of([2,3]), TypeCtor, TypeArgs)
% will bind TypeCtor to a representation of the type constructor list/1,
% and will bind TypeArgs to the list `[Int]', where Int is a
% representation of the type `int'.
%
% Note that the requirement that TypeCtor not be an equivalence type
% is fulfilled by fully expanding any equivalence types. For example,
% if you have a declaration `:- type foo == bar.', then
% type_ctor_and_args/3 will always return a representation of type
% constructor `bar/0', not `foo/0'. (If you don't want them expanded,
% you can use the reverse mode of make_type/2 instead.)
%
:- pred type_ctor_and_args(type_desc::in,
type_ctor_desc::out, list(type_desc)::out) is det.
% pseudo_type_ctor_and_args(Type, TypeCtor, TypeArgs):
%
% True iff TypeCtor is a representation of the top-level type constructor
% for Type, and TypeArgs is a list of the corresponding type arguments
% to TypeCtor, and TypeCtor is not an equivalence type.
%
% Similar to type_ctor_and_args, but works on pseudo_type_infos.
% Fails if the input pseudo_type_info is a variable.
%
:- pred pseudo_type_ctor_and_args(pseudo_type_desc::in,
type_ctor_desc::out, list(pseudo_type_desc)::out) is semidet.
% type_ctor(Type) = TypeCtor :-
% type_ctor_and_args(Type, TypeCtor, _).
%
:- func type_ctor(type_desc) = type_ctor_desc.
% pseudo_type_ctor(Type) = TypeCtor :-
% pseudo_type_ctor_and_args(Type, TypeCtor, _).
%
:- func pseudo_type_ctor(pseudo_type_desc) = type_ctor_desc is semidet.
% type_args(Type) = TypeArgs :-
% type_ctor_and_args(Type, _, TypeArgs).
%
:- func type_args(type_desc) = list(type_desc).
% pseudo_type_args(Type) = TypeArgs :-
% pseudo_type_ctor_and_args(Type, _, TypeArgs).
%
:- func pseudo_type_args(pseudo_type_desc) = list(pseudo_type_desc) is semidet.
% type_ctor_name(TypeCtor) returns the name of specified type constructor.
% (e.g. type_ctor_name(type_ctor(type_of([2,3]))) = "list").
%
:- func type_ctor_name(type_ctor_desc) = string.
% type_ctor_module_name(TypeCtor) returns the module name of specified
% type constructor.
% (e.g. type_ctor_module_name(type_ctor(type_of(2))) = "builtin").
%
:- func type_ctor_module_name(type_ctor_desc) = string.
% type_ctor_arity(TypeCtor) returns the arity of specified
% type constructor.
% (e.g. type_ctor_arity(type_ctor(type_of([2,3]))) = 1).
%
:- func type_ctor_arity(type_ctor_desc) = int.
% type_ctor_name_and_arity(TypeCtor, ModuleName, TypeName, Arity) :-
% Name = type_ctor_name(TypeCtor),
% ModuleName = type_ctor_module_name(TypeCtor),
% Arity = type_ctor_arity(TypeCtor).
%
:- pred type_ctor_name_and_arity(type_ctor_desc::in,
string::out, string::out, int::out) is det.
% make_type(TypeCtor, TypeArgs) = Type:
%
% True iff Type is a type constructed by applying the type constructor
% TypeCtor to the type arguments TypeArgs.
%
% Operationally, the forwards mode returns the type formed by applying
% the specified type constructor to the specified argument types, or fails
% if the length of TypeArgs is not the same as the arity of TypeCtor.
% The reverse mode returns a type constructor and its argument types,
% given a type_desc; the type constructor returned may be an equivalence
% type (and hence this reverse mode of make_type/2 may be more useful
% for some purposes than the type_ctor/1 function).
%
:- func make_type(type_ctor_desc, list(type_desc)) = type_desc.
:- mode make_type(in, in) = out is semidet.
:- mode make_type(out, out) = in is cc_multi.
% det_make_type(TypeCtor, TypeArgs):
%
% Returns the type formed by applying the specified type constructor
% to the specified argument types. Throws an exception if the length of
% TypeArgs is not the same as the arity of TypeCtor.
%
:- func det_make_type(type_ctor_desc, list(type_desc)) = type_desc.
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- implementation.
% Everything below here is not intended to be part of the public interface,
% and will not be included in the Mercury library reference manual.
:- interface.
:- use_module rtti_implementation.
% The following predicates are exported for construct.m.
:- pred type_desc_to_type_info(type_desc::in,
rtti_implementation.type_info::out) is det.
:- pred type_info_to_type_desc(rtti_implementation.type_info::in,
type_desc::out) is det.
:- pred type_info_list_to_type_desc_list(
list(rtti_implementation.type_info)::in, list(type_desc)::out) is det.
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- implementation.
:- import_module require.
:- import_module string.
:- pragma foreign_decl("C", "
#include ""mercury_heap.h"" // for MR_incr_hp_msg() etc.
#include ""mercury_misc.h"" // for MR_fatal_error()
#include ""mercury_string.h"" // for MR_make_aligned_string()
#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;
").
%---------------------------------------------------------------------------%
pseudo_type_desc_is_ground(PseudoTypeDesc) :-
pseudo_type_ctor_and_args(PseudoTypeDesc, _TypeCtor, ArgPseudos),
list.all_true(pseudo_type_desc_is_ground, ArgPseudos).
pseudo_type_desc_to_rep(PseudoTypeDesc) = PseudoTypeRep :-
( if pseudo_type_ctor_and_args(PseudoTypeDesc, TypeCtor, ArgPseudos) then
PseudoTypeRep = bound(TypeCtor, ArgPseudos)
else if is_exist_pseudo_type_desc(PseudoTypeDesc, UnivNum) then
PseudoTypeRep = exist_tvar(UnivNum)
else if is_univ_pseudo_type_desc(PseudoTypeDesc, UnivNum) then
PseudoTypeRep = univ_tvar(UnivNum)
else
error($pred, "internal error")
).
:- pred is_univ_pseudo_type_desc(pseudo_type_desc::in, int::out) is semidet.
:- pragma foreign_proc("C",
is_univ_pseudo_type_desc(PseudoTypeDesc::in, TypeVarNum::out),
[will_not_call_mercury, thread_safe, promise_pure, will_not_modify_trail,
no_sharing],
"
MR_PseudoTypeInfo pseudo_type_info;
pseudo_type_info = (MR_PseudoTypeInfo) PseudoTypeDesc;
if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(pseudo_type_info) &&
MR_TYPE_VARIABLE_IS_UNIV_QUANT(pseudo_type_info))
{
TypeVarNum = (MR_Integer) pseudo_type_info;
SUCCESS_INDICATOR = MR_TRUE;
} else {
SUCCESS_INDICATOR = MR_FALSE;
}
").
is_univ_pseudo_type_desc(PTD, N) :-
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.
:- pragma foreign_proc("C",
is_exist_pseudo_type_desc(PseudoTypeDesc::in, TypeVarNum::out),
[will_not_call_mercury, thread_safe, promise_pure, will_not_modify_trail,
no_sharing],
"
MR_PseudoTypeInfo pseudo_type_info;
pseudo_type_info = (MR_PseudoTypeInfo) PseudoTypeDesc;
if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(pseudo_type_info) &&
MR_TYPE_VARIABLE_IS_EXIST_QUANT(pseudo_type_info))
{
TypeVarNum = (MR_Integer) pseudo_type_info;
SUCCESS_INDICATOR = MR_TRUE;
} else {
SUCCESS_INDICATOR = MR_FALSE;
}
").
is_exist_pseudo_type_desc(PTD, N) :-
pseudo_type_desc_to_pseudo_type_info(PTD, PTI),
rtti_implementation.is_exist_pseudo_type_info(PTI, N).
%---------------------------------------------------------------------------%
:- pred pseudo_type_desc_to_pseudo_type_info(pseudo_type_desc::in,
rtti_implementation.pseudo_type_info::out) is det.
:- pragma consider_used(pred(pseudo_type_desc_to_pseudo_type_info/2)).
pseudo_type_desc_to_pseudo_type_info(PseudoTypeDesc, PseudoTypeInfo) :-
( if type_info_desc_same_representation then
private_builtin.unsafe_type_cast(PseudoTypeDesc, PseudoTypeInfo)
else
error("pseudo_type_desc_to_pseudo_type_info/2")
).
:- pred type_info_desc_same_representation is semidet.
type_info_desc_same_representation :-
semidet_true.
%---------------------------------------------------------------------------%
:- pragma foreign_proc("C",
type_desc_to_pseudo_type_desc(TypeDesc::in) = (PseudoTypeDesc::out),
[will_not_call_mercury, thread_safe, promise_pure, will_not_modify_trail],
"
PseudoTypeDesc = TypeDesc;
").
:- pragma foreign_proc("C#",
type_desc_to_pseudo_type_desc(TypeDesc::in) = (PseudoTypeDesc::out),
[will_not_call_mercury, thread_safe, promise_pure, will_not_modify_trail],
"
PseudoTypeDesc = TypeDesc;
").
:- pragma foreign_proc("Java",
type_desc_to_pseudo_type_desc(TypeDesc::in) = (PseudoTypeDesc::out),
[will_not_call_mercury, thread_safe, promise_pure, will_not_modify_trail],
"
PseudoTypeDesc = TypeDesc;
").
type_desc_to_pseudo_type_desc(_TypeDesc) = _PseudoTypeDesc :-
% The backends in which we use this definition of this predicate
% don't yet support pseudo_type_descs.
private_builtin.sorry("type_desc_to_pseudo_type_desc").
ground_pseudo_type_desc_to_type_desc(PseudoTypeDesc) = TypeDesc :-
ground_pseudo_type_desc_to_type_desc(PseudoTypeDesc, TypeDesc).
ground_pseudo_type_desc_to_type_desc(PseudoTypeDesc, TypeDesc) :-
( if pseudo_type_desc_is_ground(PseudoTypeDesc) then
private_builtin.unsafe_type_cast(PseudoTypeDesc, TypeDesc)
else
fail
).
det_ground_pseudo_type_desc_to_type_desc(PseudoTypeDesc) = TypeDesc :-
( if pseudo_type_desc_is_ground(PseudoTypeDesc) then
private_builtin.unsafe_type_cast(PseudoTypeDesc, TypeDesc)
else
error($pred, "not ground")
).
%---------------------------------------------------------------------------%
%
% Code for type manipulation.
%
:- pragma foreign_proc("C",
type_of(_Value::unused) = (TypeInfo::out),
[will_not_call_mercury, thread_safe, promise_pure, will_not_modify_trail,
no_sharing],
"{
TypeInfo = TypeInfo_for_T;
// We used to collapse equivalences for efficiency here, but that is not
// always desirable, due to the reverse mode of make_type/2, and efficiency
// of type_infos probably isn't very important anyway.
#if 0
MR_save_transient_registers();
TypeInfo = (MR_Word) MR_collapse_equivalences(
(MR_TypeInfo) TypeInfo_for_T);
MR_restore_transient_registers();
#endif
}").
:- pragma foreign_proc("C#",
type_of(_Value::unused) = (TypeInfo::out),
[will_not_call_mercury, thread_safe, promise_pure],
"
TypeInfo = TypeInfo_for_T;
").
:- pragma foreign_proc("Java",
type_of(_Value::unused) = (TypeInfo::out),
[will_not_call_mercury, thread_safe, promise_pure],
"
TypeInfo = TypeInfo_for_T;
").
:- pragma foreign_proc("C",
has_type(_Arg::unused, TypeInfo::in),
[will_not_call_mercury, thread_safe, promise_pure, no_sharing],
"
TypeInfo_for_T = TypeInfo;
").
:- pragma foreign_proc("C#",
has_type(_Arg::unused, TypeInfo::in),
[will_not_call_mercury, thread_safe, promise_pure],
"
TypeInfo_for_T = TypeInfo;
").
:- pragma foreign_proc("Java",
has_type(_Arg::unused, TypeInfo::in),
[will_not_call_mercury, thread_safe, promise_pure],
"
TypeInfo_for_T = TypeInfo;
").
same_type(_, _).
% Export this function in order to use it in runtime/mercury_trace_external.c
:- pragma foreign_export("C", type_name(in) = out, "ML_type_name").
type_name(Type) = TypeName :-
type_ctor_and_args(Type, TypeCtor, ArgTypes),
type_ctor_name_and_arity(TypeCtor, ModuleName, Name, Arity),
( if Arity = 0 then
UnqualifiedTypeName = Name
else
( if ModuleName = "builtin", Name = "{}" then
type_arg_names(ArgTypes, ArgTypeNames),
TupleArgTypeNames = ["{" | ArgTypeNames] ++ ["}"],
string.append_list(TupleArgTypeNames, UnqualifiedTypeName)
else
( if ModuleName = "builtin", Name = "func" then
det_split_last(ArgTypes, NonReturnArgTypes, ReturnArgType),
ReturnArgTypeName = type_name(ReturnArgType),
(
NonReturnArgTypes = [],
TypeNameStrs = ["((func) = ", ReturnArgTypeName, ")"]
;
NonReturnArgTypes = [HeadArgType | TailArgTypes],
type_arg_names_lag(HeadArgType, TailArgTypes,
NonReturnArgTypeNames),
TypeNameStrs = [Name, "(" | NonReturnArgTypeNames]
++ [") = ", ReturnArgTypeName]
)
else
type_arg_names(ArgTypes, ArgTypeNames),
TypeNameStrs = [Name, "(" | ArgTypeNames] ++ [")"]
),
string.append_list(TypeNameStrs, UnqualifiedTypeName)
)
),
( if ModuleName = "builtin" then
TypeName = UnqualifiedTypeName
else
string.append_list([ModuleName, ".", UnqualifiedTypeName], TypeName)
).
% Turn the types into a list of strings representing an argument list,
% adding commas as separators as required. For example:
% ["TypeName1", ",", "TypeName2"].
%
:- pred type_arg_names(list(type_desc)::in, list(string)::out) is det.
type_arg_names([], []).
type_arg_names([Type | Types], ArgNames) :-
type_arg_names_lag(Type, Types, ArgNames).
:- pred type_arg_names_lag(type_desc::in, list(type_desc)::in,
list(string)::out) is det.
type_arg_names_lag(HeadType, TailTypes, Names) :-
HeadName = type_name(HeadType),
(
TailTypes = [],
Names = [HeadName]
;
TailTypes = [HeadTailType | TailTailTypes],
type_arg_names_lag(HeadTailType, TailTailTypes, TailNames),
Names = [HeadName, ", " | TailNames]
).
%---------------------------------------------------------------------------%
:- 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],
"{
MR_TypeCtorDesc type_ctor_desc;
MR_TypeInfo type_info;
MR_save_transient_registers();
type_info = (MR_TypeInfo) TypeDesc;
MR_type_ctor_and_args(type_info, MR_TRUE, &type_ctor_desc, &ArgTypes);
TypeCtorDesc = (MR_Word) type_ctor_desc;
MR_restore_transient_registers();
}").
type_ctor_and_args(TypeDesc, TypeCtorDesc, ArgTypeDescs) :-
type_desc_to_type_info(TypeDesc, TypeInfo),
rtti_implementation.type_ctor_and_args(TypeInfo, TypeCtorInfo,
ArgTypeInfos),
make_type_ctor_desc(TypeInfo, TypeCtorInfo, TypeCtorDesc),
type_info_list_to_type_desc_list(ArgTypeInfos, ArgTypeDescs).
:- pragma foreign_proc("C",
pseudo_type_ctor_and_args(PseudoTypeDesc::in, TypeCtorDesc::out,
ArgPseudoTypeInfos::out),
[will_not_call_mercury, thread_safe, promise_pure, will_not_modify_trail],
"{
MR_TypeCtorDesc type_ctor_desc;
MR_PseudoTypeInfo pseudo_type_info;
MR_bool success;
pseudo_type_info = (MR_PseudoTypeInfo) PseudoTypeDesc;
MR_save_transient_registers();
success = MR_pseudo_type_ctor_and_args(pseudo_type_info, MR_TRUE,
&type_ctor_desc, &ArgPseudoTypeInfos);
TypeCtorDesc = (MR_Word) type_ctor_desc;
MR_restore_transient_registers();
SUCCESS_INDICATOR = success;
}").
pseudo_type_ctor_and_args(PseudoTypeDesc, TypeCtorDesc, ArgPseudoTypeDescs) :-
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).
%---------------------------------------------------------------------------%
:- pragma no_determinism_warning(func(pseudo_type_ctor/1)).
:- pragma foreign_proc("C",
type_ctor(TypeInfo::in) = (TypeCtor::out),
[will_not_call_mercury, thread_safe, promise_pure, will_not_modify_trail],
"{
MR_TypeCtorInfo type_ctor_info;
MR_TypeInfo type_info;
MR_save_transient_registers();
type_info = MR_collapse_equivalences((MR_TypeInfo) TypeInfo);
MR_restore_transient_registers();
type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
TypeCtor = (MR_Word) MR_make_type_ctor_desc(type_info, type_ctor_info);
}").
type_ctor(TypeDesc) = TypeCtorDesc :-
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",
pseudo_type_ctor(PseudoTypeInfo::in) = (TypeCtor::out),
[will_not_call_mercury, thread_safe, promise_pure, will_not_modify_trail],
"{
MR_TypeCtorInfo type_ctor_info;
MR_PseudoTypeInfo pseudo_type_info;
MR_save_transient_registers();
pseudo_type_info = MR_collapse_equivalences_pseudo(
(MR_PseudoTypeInfo) PseudoTypeInfo);
MR_restore_transient_registers();
if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(pseudo_type_info)) {
SUCCESS_INDICATOR = MR_FALSE;
} else {
type_ctor_info = MR_PSEUDO_TYPEINFO_GET_TYPE_CTOR_INFO(
pseudo_type_info);
TypeCtor = (MR_Word) MR_make_type_ctor_desc_pseudo(pseudo_type_info,
type_ctor_info);
SUCCESS_INDICATOR = MR_TRUE;
}
}").
pseudo_type_ctor(_) = _ :-
private_builtin.sorry("pseudo_type_ctor/1").
%---------------------------------------------------------------------------%
type_args(Type) = ArgTypes :-
type_ctor_and_args(Type, _TypeCtor, ArgTypes).
pseudo_type_args(PseudoType) = ArgPseudoTypes :-
pseudo_type_ctor_and_args(PseudoType, _TypeCtor, ArgPseudoTypes).
type_ctor_name(TypeCtor) = Name :-
type_ctor_name_and_arity(TypeCtor, _ModuleName, Name, _Arity).
type_ctor_module_name(TypeCtor) = ModuleName :-
type_ctor_name_and_arity(TypeCtor, ModuleName, _Name, _Arity).
type_ctor_arity(TypeCtor) = Arity :-
type_ctor_name_and_arity(TypeCtor, _ModuleName, _Name, Arity).
%---------------------------------------------------------------------------%
% 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 consider_used(pred(make_type_ctor_desc/3)).
:- pragma foreign_proc("C#",
make_type_ctor_desc(TypeInfo::in, TypeCtorInfo::in, TypeCtorDesc::out),
[will_not_call_mercury, promise_pure, thread_safe, may_not_duplicate],
"
runtime.TypeCtorInfo_Struct tci = TypeCtorInfo;
// Handle variable arity types.
switch (tci.type_ctor_rep) {
case runtime.TypeCtorRep.MR_TYPECTOR_REP_PRED:
case runtime.TypeCtorRep.MR_TYPECTOR_REP_FUNC:
case runtime.TypeCtorRep.MR_TYPECTOR_REP_TUPLE:
tci = new runtime.TypeCtorInfo_Struct(tci, TypeInfo.args.Length);
break;
default:
break;
}
TypeCtorDesc = tci;
").
:- 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 jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_PRED:
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_FUNC:
case jmercury.runtime.TypeCtorRep.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 consider_used(pred(make_type_ctor_desc_with_arity/3)).
:- pragma foreign_proc("C#",
make_type_ctor_desc_with_arity(Arity::in, TypeCtorInfo::in,
TypeCtorDesc::out),
[will_not_call_mercury, promise_pure, thread_safe, may_not_duplicate],
"
runtime.TypeCtorInfo_Struct tci = TypeCtorInfo;
// Handle variable arity types.
switch (tci.type_ctor_rep) {
case runtime.TypeCtorRep.MR_TYPECTOR_REP_PRED:
case runtime.TypeCtorRep.MR_TYPECTOR_REP_FUNC:
case runtime.TypeCtorRep.MR_TYPECTOR_REP_TUPLE:
tci = new runtime.TypeCtorInfo_Struct(tci, Arity);
break;
default:
break;
}
TypeCtorDesc = tci;
").
:- 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 jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_PRED:
case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_FUNC:
case jmercury.runtime.TypeCtorRep.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").
%---------------------------------------------------------------------------%
:- pragma foreign_proc("C",
type_ctor_name_and_arity(TypeCtorDesc::in, TypeCtorModuleName::out,
TypeCtorName::out, TypeCtorArity::out),
[will_not_call_mercury, thread_safe, promise_pure, will_not_modify_trail],
"{
MR_TypeCtorDesc type_ctor_desc;
type_ctor_desc = (MR_TypeCtorDesc) TypeCtorDesc;
if (MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(type_ctor_desc)) {
TypeCtorModuleName = (MR_String) (MR_Word)
MR_TYPECTOR_DESC_GET_VA_MODULE_NAME(type_ctor_desc);
TypeCtorName = (MR_String) (MR_Word)
MR_TYPECTOR_DESC_GET_VA_NAME(type_ctor_desc);
TypeCtorArity = MR_TYPECTOR_DESC_GET_VA_ARITY(type_ctor_desc);
} else {
MR_TypeCtorInfo type_ctor_info;
type_ctor_info =
MR_TYPECTOR_DESC_GET_FIXED_ARITY_TYPE_CTOR_INFO(type_ctor_desc);
// We cast away the const-ness of the module and type names,
// because MR_String is defined as char *, not const char *.
TypeCtorModuleName = (MR_String) (MR_Integer)
MR_type_ctor_module_name(type_ctor_info);
TypeCtorName = (MR_String) (MR_Integer)
MR_type_ctor_name(type_ctor_info);
TypeCtorArity = type_ctor_info->MR_type_ctor_arity;
}
}").
type_ctor_name_and_arity(TypeCtorDesc, ModuleName, TypeCtorName,
TypeCtorArity) :-
type_ctor_desc_to_type_ctor_info(TypeCtorDesc, TypeCtorInfo),
rtti_implementation.type_ctor_name_and_arity(TypeCtorInfo,
ModuleName, TypeCtorName, TypeCtorArity).
:- pred type_ctor_desc_to_type_ctor_info(type_ctor_desc::in,
rtti_implementation.type_ctor_info::out) is det.
:- pragma consider_used(pred(type_ctor_desc_to_type_ctor_info/2)).
type_ctor_desc_to_type_ctor_info(TypeCtorDesc, TypeCtorInfo) :-
( if type_info_desc_same_representation then
private_builtin.unsafe_type_cast(TypeCtorDesc, TypeCtorInfo)
else
error("type_ctor_desc_to_type_ctor_info/2")
).
%---------------------------------------------------------------------------%
:- pragma promise_equivalent_clauses(func(make_type/2)).
:- pragma no_determinism_warning(func(make_type/2)).
make_type(_TypeCtorDesc::in, _ArgTypes::in) = (_TypeDesc::out) :-
private_builtin.sorry("make_type(in, in) = out").
make_type(_TypeCtorDesc::out, _ArgTypes::out) = (_TypeDesc::in) :-
private_builtin.sorry("make_type(out, out) = in").
% This is the forwards mode of make_type/2: 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.
:- pragma foreign_proc("C",
make_type(TypeCtorDesc::in, ArgTypes::in) = (TypeDesc::out),
[promise_pure, will_not_call_mercury, thread_safe, will_not_modify_trail],
"{
MR_TypeCtorDesc type_ctor_desc;
MR_TypeCtorInfo type_ctor_info;
MR_Word arg_type;
int list_length;
int arity;
type_ctor_desc = (MR_TypeCtorDesc) TypeCtorDesc;
if (MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(type_ctor_desc)) {
arity = MR_TYPECTOR_DESC_GET_VA_ARITY(type_ctor_desc);
} else {
type_ctor_info =
MR_TYPECTOR_DESC_GET_FIXED_ARITY_TYPE_CTOR_INFO(type_ctor_desc);
arity = type_ctor_info->MR_type_ctor_arity;
}
arg_type = ArgTypes;
for (list_length = 0; ! MR_list_is_empty(arg_type); list_length++) {
arg_type = MR_list_tail(arg_type);
}
if (list_length != arity) {
SUCCESS_INDICATOR = MR_FALSE;
} else {
MR_save_transient_registers();
TypeDesc = (MR_Word) MR_make_type(arity, type_ctor_desc, ArgTypes);
MR_restore_transient_registers();
SUCCESS_INDICATOR = MR_TRUE;
}
}").
:- pragma foreign_proc("C#",
make_type(TypeCtorDesc::in, ArgTypes::in) = (TypeDesc::out),
[promise_pure, will_not_call_mercury, thread_safe, will_not_modify_trail,
may_not_duplicate],
"{
runtime.PseudoTypeInfo[] args =
new runtime.PseudoTypeInfo[TypeCtorDesc.arity];
SUCCESS_INDICATOR = true;
list.List_1 arg_types = ArgTypes;
for (int i = 0; i < TypeCtorDesc.arity; i++) {
if (list.is_empty(arg_types)) {
SUCCESS_INDICATOR = false;
break;
}
args[i] = (runtime.PseudoTypeInfo) list.det_head(arg_types);
arg_types = list.det_tail(arg_types);
}
if (SUCCESS_INDICATOR) {
TypeDesc = new runtime.TypeInfo_Struct();
TypeDesc.init(TypeCtorDesc, args);
} else {
TypeDesc = null;
}
}").
:- pragma foreign_proc("Java",
make_type(TypeCtorDesc::in, ArgTypes::in) = (TypeDesc::out),
[promise_pure, will_not_call_mercury, thread_safe, will_not_modify_trail,
may_not_duplicate],
"{
PseudoTypeInfo[] as = new PseudoTypeInfo[TypeCtorDesc.arity];
SUCCESS_INDICATOR = true;
list.List_1<TypeInfo_Struct> arg_types = ArgTypes;
for (int i = 0; i < TypeCtorDesc.arity; i++) {
if (list.is_empty(arg_types)) {
SUCCESS_INDICATOR = false;
break;
}
as[i] = list.det_head(arg_types);
arg_types = list.det_tail(arg_types);
}
if (SUCCESS_INDICATOR) {
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 arguments.
:- pragma foreign_proc("C",
make_type(TypeCtorDesc::out, ArgTypes::out) = (TypeDesc::in),
[promise_pure, will_not_call_mercury, thread_safe, will_not_modify_trail],
"{
MR_TypeCtorDesc type_ctor_desc;
MR_TypeInfo type_info;
MR_save_transient_registers();
type_info = (MR_TypeInfo) TypeDesc;
MR_type_ctor_and_args(type_info, MR_FALSE, &type_ctor_desc, &ArgTypes);
TypeCtorDesc = (MR_Word) type_ctor_desc;
MR_restore_transient_registers();
}").
det_make_type(TypeCtor, ArgTypes) = Type :-
( if make_type(TypeCtor, ArgTypes) = NewType then
Type = NewType
else
error($pred, "make_type/2 failed (wrong arity)")
).
%---------------------------------------------------------------------------%
% This function returns the type_info for the builtin type "typeinfo"
% itself. It is intended for use from C code, since Mercury code can access
% this type_info easily enough even without this predicate.
%
% XXX This code relies on the type "type_desc" being the same type
% as the builtin type "typeinfo".
%
:- func get_type_info_for_type_info = type_desc.
:- pragma foreign_export("C", get_type_info_for_type_info = out,
"ML_get_type_info_for_type_info").
get_type_info_for_type_info = TypeDesc :-
Type = type_of(1),
TypeDesc = type_of(Type).
%---------------------------------------------------------------------------%
:- pragma foreign_code("C#", "
public static bool
__Unify____type_desc_0_0(
runtime.TypeInfo_Struct x,
runtime.TypeInfo_Struct y)
{
return x.Equals(y);
}
public static bool
__Unify____type_ctor_desc_0_0(
runtime.TypeCtorInfo_Struct x,
runtime.TypeCtorInfo_Struct y)
{
return x.Equals(y);
}
public static builtin.Comparison_result_0
__Compare____type_desc_0_0(
runtime.TypeInfo_Struct x,
runtime.TypeInfo_Struct y)
{
return rtti_implementation.ML_compare_type_infos(x, y);
}
public static builtin.Comparison_result_0
__Compare____type_ctor_desc_0_0(
runtime.TypeCtorInfo_Struct x,
runtime.TypeCtorInfo_Struct y)
{
return rtti_implementation.ML_compare_type_ctor_infos(x, y);
}
public static bool
__Unify____pseudo_type_desc_0_0(
runtime.PseudoTypeInfo x,
runtime.PseudoTypeInfo y)
{
return x.Equals(y);
}
public static builtin.Comparison_result_0
__Compare____pseudo_type_desc_0_0(
runtime.PseudoTypeInfo x,
runtime.PseudoTypeInfo y)
{
return rtti_implementation.ML_compare_pseudo_type_infos(x, y);
}
").
:- pragma foreign_code("Java", "
public static boolean
__Unify____type_desc_0_0(TypeInfo_Struct x, TypeInfo_Struct y)
{
return x.unify(y);
}
public static boolean
__Unify____type_ctor_desc_0_0(TypeCtorInfo_Struct x, TypeCtorInfo_Struct y)
{
return x.unify(y);
}
public static builtin.Comparison_result_0
__Compare____type_desc_0_0(TypeInfo_Struct x, TypeInfo_Struct y)
{
return rtti_implementation.ML_compare_type_infos(x, y);
}
public static builtin.Comparison_result_0
__Compare____type_ctor_desc_0_0(TypeCtorInfo_Struct x,
TypeCtorInfo_Struct y)
{
return rtti_implementation.ML_compare_type_ctor_infos(x, y);
}
public static boolean
__Unify____pseudo_type_desc_0_0(PseudoTypeInfo x, PseudoTypeInfo y)
{
return x.unify(y);
}
public static builtin.Comparison_result_0
__Compare____pseudo_type_desc_0_0(PseudoTypeInfo x, PseudoTypeInfo y)
{
return rtti_implementation.ML_compare_pseudo_type_infos(x, y);
}
").
%---------------------------------------------------------------------------%
type_desc_to_type_info(TypeDesc, TypeInfo) :-
( if type_info_desc_same_representation then
private_builtin.unsafe_type_cast(TypeDesc, TypeInfo)
else
error("type_desc_to_type_info/2")
).
type_info_to_type_desc(TypeInfo, TypeDesc) :-
( if type_info_desc_same_representation then
private_builtin.unsafe_type_cast(TypeInfo, TypeDesc)
else
error("type_info_to_type_desc/2")
).
type_info_list_to_type_desc_list(TypeInfoList, TypeDescList) :-
( if type_info_desc_same_representation then
private_builtin.unsafe_type_cast(TypeInfoList, TypeDescList)
else
list.map(type_info_to_type_desc, TypeInfoList, TypeDescList)
).
%---------------------------------------------------------------------------%
:- end_module type_desc.
%---------------------------------------------------------------------------%
Reference in New Issue View Git Blame Copy Permalink