[m-rev.] diff: add erlang implementation of construct rtti routines
Peter Ross
pro at missioncriticalit.com
Wed Jul 25 13:10:01 AEST 2007
Hi,
===================================================================
Estimated hours taken: 8
Branches: main
Add erlang implementations of construct rtti routines.
library/construct.m:
Call the erlang_rtti_implementation version of predicates.
library/deconstruct.m:
Move is_erlang_backend to erlang_rtti_implementation.
library/erlang_rtti_implementation.m:
Implement num_functors, get_functor and get_functor_with_names.
library/rtti_implementation.m:
Add an erlang version of unsafe_cast as it is used by construct.
Index: library/construct.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/construct.m,v
retrieving revision 1.35
diff -u -r1.35 construct.m
--- library/construct.m 13 Feb 2007 01:58:52 -0000 1.35
+++ library/construct.m 25 Jul 2007 03:04:52 -0000
@@ -117,6 +117,10 @@
:- import_module require.
+% For use by the Erlang backends.
+%
+:- use_module erlang_rtti_implementation.
+
% For use by the Java and IL backends.
%
:- use_module rtti_implementation.
@@ -145,7 +149,12 @@
SUCCESS_INDICATOR = (Functors >= 0);
}").
-num_functors(TypeDesc) = rtti_implementation.num_functors(TypeDesc).
+num_functors(TypeDesc) =
+ ( erlang_rtti_implementation.is_erlang_backend ->
+ erlang_rtti_implementation.num_functors(TypeDesc)
+ ;
+ rtti_implementation.num_functors(TypeDesc)
+ ).
get_functor(TypeInfo, FunctorNumber, FunctorName, Arity,
PseudoTypeInfoList) :-
@@ -163,8 +172,14 @@
get_functor_internal(TypeInfo, FunctorNumber, FunctorName, Arity,
MaybeTypeInfoList) :-
- rtti_implementation.get_functor(TypeInfo, FunctorNumber,
- FunctorName, Arity, TypeInfoList),
+ ( erlang_rtti_implementation.is_erlang_backend ->
+ erlang_rtti_implementation.get_functor(TypeInfo, FunctorNumber,
+ FunctorName, Arity, TypeInfoList)
+ ;
+ rtti_implementation.get_functor(TypeInfo, FunctorNumber,
+ FunctorName, Arity, TypeInfoList)
+ ),
+
% 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.
@@ -234,8 +249,14 @@
get_functor_with_names_internal(TypeDesc, FunctorNumber, FunctorName, Arity,
MaybeTypeInfoList, Names) :-
- rtti_implementation.get_functor_with_names(TypeDesc, FunctorNumber,
- FunctorName, Arity, TypeInfoList, Names),
+ ( erlang_rtti_implementation.is_erlang_backend ->
+ erlang_rtti_implementation.get_functor_with_names(TypeDesc, FunctorNumber,
+ FunctorName, Arity, TypeInfoList, Names)
+ ;
+ rtti_implementation.get_functor_with_names(TypeDesc, FunctorNumber,
+ FunctorName, Arity, TypeInfoList, Names)
+ ),
+
% 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.
Index: library/deconstruct.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/deconstruct.m,v
retrieving revision 1.45
diff -u -r1.45 deconstruct.m
--- library/deconstruct.m 4 Jun 2007 07:55:37 -0000 1.45
+++ library/deconstruct.m 25 Jul 2007 03:04:52 -0000
@@ -1009,16 +1009,6 @@
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
-:- pred is_erlang_backend is semidet.
-
-:- pragma foreign_proc("Erlang", is_erlang_backend,
- [will_not_call_mercury, thread_safe, promise_pure], "
- SUCCESS_INDICATOR = true
-").
-
-is_erlang_backend :-
- semidet_fail.
-
:- pred local_deconstruct(T, noncanon_handling, string, int, list(univ)).
:- mode local_deconstruct(in, in(do_not_allow), out, out, out) is det.
:- mode local_deconstruct(in, in(canonicalize), out, out, out) is det.
@@ -1026,7 +1016,7 @@
:- mode local_deconstruct(in, in, out, out, out) is cc_multi.
local_deconstruct(T, H, F, A, As) :-
- ( is_erlang_backend ->
+ ( erlang_rtti_implementation.is_erlang_backend ->
erlang_rtti_implementation.deconstruct(T, H, F, A, As)
;
rtti_implementation.deconstruct(T, H, F, A, As)
Index: library/erlang_rtti_implementation.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/erlang_rtti_implementation.m,v
retrieving revision 1.13
diff -u -r1.13 erlang_rtti_implementation.m
--- library/erlang_rtti_implementation.m 12 Jul 2007 01:28:48 -0000 1.13
+++ library/erlang_rtti_implementation.m 25 Jul 2007 03:04:52 -0000
@@ -21,6 +21,7 @@
:- import_module deconstruct.
:- import_module list.
+:- import_module type_desc.
:- import_module univ.
:- type type_info.
@@ -54,6 +55,19 @@
:- mode deconstruct(in, in, out, out, out) is cc_multi.
%-----------------------------------------------------------------------------%
+%
+% Implementations for use from construct.
+
+:- func num_functors(type_desc.type_desc) = int is semidet.
+
+:- pred get_functor(type_desc.type_desc::in, int::in, string::out, int::out,
+ list(type_desc.type_desc)::out) is semidet.
+
+:- pred get_functor_with_names(type_desc.type_desc::in, int::in, string::out,
+ int::out, list(type_desc.type_desc)::out, list(string)::out)
+ is semidet.
+
+%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
@@ -606,7 +620,7 @@
get_du_functor_arg(TypeInfo, Functor, Term, Loc) = Univ :-
ArgInfo = list.index1_det(Functor ^ edu_arg_infos, Loc),
-
+
MaybePTI = ArgInfo ^ du_arg_type,
Info = yes({TypeInfo, yes({Functor, Term})}),
ArgTypeInfo = type_info(Info, MaybePTI),
@@ -652,6 +666,184 @@
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
+num_functors(TypeDesc) = NumFunctors :-
+ num_functors(unsafe_cast(TypeDesc), yes(NumFunctors)).
+
+:- pred num_functors(type_info::in, maybe(int)::out) is det.
+
+num_functors(TypeInfo, MaybeNumFunctors) :-
+ TypeCtorInfo = TypeInfo ^ type_ctor_info_evaled,
+ TypeCtorRep = TypeCtorInfo ^ type_ctor_rep,
+ (
+ TypeCtorRep = etcr_du,
+ FunctorReps = TypeCtorInfo ^ type_ctor_functors,
+ MaybeNumFunctors = yes(list.length(FunctorReps))
+ ;
+ ( TypeCtorRep = etcr_dummy
+ ; TypeCtorRep = etcr_tuple
+ ),
+ MaybeNumFunctors = yes(1)
+ ;
+ TypeCtorRep = etcr_list,
+ MaybeNumFunctors = yes(2)
+ ;
+ ( TypeCtorRep = etcr_array
+ ; TypeCtorRep = etcr_eqv
+ ; TypeCtorRep = etcr_int
+ ; TypeCtorRep = etcr_float
+ ; TypeCtorRep = etcr_char
+ ; TypeCtorRep = etcr_string
+ ; TypeCtorRep = etcr_void
+ ; TypeCtorRep = etcr_stable_c_pointer
+ ; TypeCtorRep = etcr_c_pointer
+ ; TypeCtorRep = etcr_pred
+ ; TypeCtorRep = etcr_func
+ ; TypeCtorRep = etcr_ref
+ ; TypeCtorRep = etcr_type_desc
+ ; TypeCtorRep = etcr_pseudo_type_desc
+ ; TypeCtorRep = etcr_type_ctor_desc
+ ; TypeCtorRep = etcr_type_info
+ ; TypeCtorRep = etcr_type_ctor_info
+ ; TypeCtorRep = etcr_typeclass_info
+ ; TypeCtorRep = etcr_base_typeclass_info
+ ; TypeCtorRep = etcr_foreign
+ ),
+ MaybeNumFunctors = no
+ ;
+ ( TypeCtorRep = etcr_hp
+ ; TypeCtorRep = etcr_subgoal
+ ; TypeCtorRep = etcr_ticket
+ ),
+ error("num_functors: type_ctor_rep not handled")
+ ).
+
+%-----------------------------------------------------------------------------%
+
+get_functor(TypeDesc, FunctorNum, Name, Arity, ArgTypes) :-
+ get_functor_with_names(TypeDesc, FunctorNum, Name, Arity, ArgTypes, _).
+
+get_functor_with_names(TypeDesc, FunctorNum, Name, Arity, ArgTypes, ArgNames) :-
+ MaybeResult = get_functor_with_names(unsafe_cast(TypeDesc), FunctorNum),
+ MaybeResult = yes({Name, Arity, ArgTypeInfos, ArgNames}),
+ ArgTypes = list.map(unsafe_cast, ArgTypeInfos).
+
+:- func get_functor_with_names(type_info, int) =
+ maybe({string, int, list(type_info), list(string)}).
+
+get_functor_with_names(TypeInfo, NumFunctor) = Result :-
+ TypeCtorInfo = TypeInfo ^ type_ctor_info_evaled,
+ TypeCtorRep = TypeCtorInfo ^ type_ctor_rep,
+ (
+ TypeCtorRep = etcr_du,
+ FunctorReps = TypeCtorInfo ^ type_ctor_functors,
+ ( list.index0(FunctorReps, NumFunctor, FunctorRep) ->
+ MaybeExistInfo = FunctorRep ^ edu_exist_info,
+ (
+ MaybeExistInfo = yes(_),
+ Result = no
+ ;
+ MaybeExistInfo = no,
+ ArgInfos = FunctorRep ^ edu_arg_infos,
+
+ list.foldl2(
+ (pred(ArgInfo::in, T0::in, T::out, N0::in, N::out) is det :-
+ MaybePTI = ArgInfo ^ du_arg_type,
+ Info = yes({TypeInfo, no : pti_info(int)}),
+ ArgTypeInfo = type_info(Info, MaybePTI),
+ T = [ArgTypeInfo | T0],
+
+ MaybeArgName = ArgInfo ^ du_arg_name,
+ (
+ MaybeArgName = yes(ArgName)
+ ;
+ MaybeArgName = no,
+ ArgName = ""
+ ),
+ N = [ArgName | N0]
+ ), ArgInfos, [], RevArgTypes, [], RevArgNames),
+
+ Name = FunctorRep ^ edu_name,
+ Arity = FunctorRep ^ edu_orig_arity,
+ ArgTypes = list.reverse(RevArgTypes),
+ ArgNames = list.reverse(RevArgNames),
+ Result = yes({Name, Arity, ArgTypes, ArgNames})
+ )
+ ;
+ Result = no
+ )
+ ;
+ TypeCtorRep = etcr_dummy,
+ Name = TypeCtorInfo ^ type_ctor_dummy_functor_name,
+ Arity = 0,
+ ArgTypes = [],
+ ArgNames = [],
+ Result = yes({Name, Arity, ArgTypes, ArgNames})
+ ;
+ TypeCtorRep = etcr_tuple,
+ type_ctor_and_args(TypeInfo, _TypeCtorInfo, ArgTypes),
+ Name = "{}",
+ Arity = list.length(ArgTypes),
+ ArgNames = list.duplicate(Arity, ""),
+ Result = yes({Name, Arity, ArgTypes, ArgNames})
+ ;
+ TypeCtorRep = etcr_list,
+ ( NumFunctor = 1 ->
+ Name = "[]",
+ Arity = 0,
+ ArgTypes = [],
+ ArgNames = [],
+ Result = yes({Name, Arity, ArgTypes, ArgNames})
+
+ ; NumFunctor = 2 ->
+ ArgTypeInfo = TypeInfo ^ type_info_index(1),
+
+ Name = "[|]",
+ Arity = 2,
+ ArgTypes = [ArgTypeInfo, TypeInfo],
+ ArgNames = ["", ""],
+ Result = yes({Name, Arity, ArgTypes, ArgNames})
+ ;
+ Result = no
+ )
+ ;
+ ( TypeCtorRep = etcr_array
+ ; TypeCtorRep = etcr_eqv
+ ; TypeCtorRep = etcr_int
+ ; TypeCtorRep = etcr_float
+ ; TypeCtorRep = etcr_char
+ ; TypeCtorRep = etcr_string
+ ; TypeCtorRep = etcr_void
+ ; TypeCtorRep = etcr_stable_c_pointer
+ ; TypeCtorRep = etcr_c_pointer
+ ; TypeCtorRep = etcr_pred
+ ; TypeCtorRep = etcr_func
+ ; TypeCtorRep = etcr_ref
+ ; TypeCtorRep = etcr_type_desc
+ ; TypeCtorRep = etcr_pseudo_type_desc
+ ; TypeCtorRep = etcr_type_ctor_desc
+ ; TypeCtorRep = etcr_type_info
+ ; TypeCtorRep = etcr_type_ctor_info
+ ; TypeCtorRep = etcr_typeclass_info
+ ; TypeCtorRep = etcr_base_typeclass_info
+ ; TypeCtorRep = etcr_foreign
+ ),
+ Result = no
+ ;
+ ( TypeCtorRep = etcr_hp
+ ; TypeCtorRep = etcr_subgoal
+ ; TypeCtorRep = etcr_ticket
+ ),
+ error("num_functors: type_ctor_rep not handled")
+ ).
+
+
+
+
+
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
:- pragma foreign_decl("Erlang", "
% These are macros for efficiency.
@@ -1454,6 +1646,21 @@
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
+:- interface.
+:- pred is_erlang_backend is semidet.
+:- implementation.
+
+:- pragma foreign_proc("Erlang", is_erlang_backend,
+ [will_not_call_mercury, thread_safe, promise_pure], "
+ SUCCESS_INDICATOR = true
+").
+
+is_erlang_backend :-
+ semidet_fail.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
:- func this_file = string.
this_file = "erlang_rtti_implementation.m".
Index: library/rtti_implementation.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/rtti_implementation.m,v
retrieving revision 1.79
diff -u -r1.79 rtti_implementation.m
--- library/rtti_implementation.m 17 Jul 2007 06:22:52 -0000 1.79
+++ library/rtti_implementation.m 25 Jul 2007 03:04:52 -0000
@@ -2301,6 +2301,13 @@
VarOut = VarIn;
").
+:- pragma foreign_proc("Erlang",
+ unsafe_cast(VarIn::in) = (VarOut::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ VarOut = VarIn
+").
+
unsafe_cast(_) = _ :-
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
--------------------------------------------------------------------------
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