[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