[m-rev.] for review: deconstruct by functor number
Simon Taylor
staylr at gmail.com
Fri Dec 29 16:07:32 AEDT 2006
Estimated hours taken: 20
Branches: main
Add support for deconstructing by functor number rather than name,
for use by write_binary.
library/deconstruct.m:
runtime/mercury_deconstruct.h:
runtime/mercury_deconstruct.c:
runtime/mercury_ml_expand_body.h:
runtime/mercury_ml_deconstruct_body.h:
Add predicates deconstruct.functor_number and
deconstruct.deconstruct.du, which returns a functor number
suitable for use by construct.construct rather than a functor
name.
library/construct.m:
library/term.m:
browser/term_rep.m:
Add a function get_functor_lex, which returns the lexicographic
functor number given an ordinal functor number.
Add equivalence types to make it clearer which ordering is
being used by which functor numbers.
Remove a C-ism: num_functors now fails rather than returning -1
for types without functors.
NEWS:
Document the new predicates and functions.
runtime/mercury_type_info.h:
runtime/mercury_builtin_types.c:
runtime/mercury_mcpp.h:
compiler/rtti.m:
compiler/rtti_out.m:
compiler/type_ctor_info.m:
compiler/rtti_to_mlds.m:
compiler/opt_debug.m:
Add a field to MR_TypeCtorInfo which contains a mapping from
an ordinal functor number to a lexicographic functor number
which can be passed to construct.construct.
Bump MR_RTTI_VERSION.
tests/hard_coded/expand.m:
tests/hard_coded/expand.exp:
tests/hard_coded/expand.exp2:
tests/hard_coded/construct_test.m:
tests/hard_coded/construct_test.exp:
tests/hard_coded/construct_test_exist.m:
tests/hard_coded/construct_test_exist.exp:
Test cases.
Index: NEWS
===================================================================
RCS file: /home/mercury1/repository/mercury/NEWS,v
retrieving revision 1.433
diff -u -u -r1.433 NEWS
--- NEWS 21 Dec 2006 03:00:48 -0000 1.433
+++ NEWS 28 Dec 2006 12:45:54 -0000
@@ -40,6 +40,16 @@
* The type software_error/0 has been moved from the require module into
the exception module.
+* construct.num_functors now fails rather than returning -1 for types
+ with no functors.
+
+* We have added predicates deconstruct.functor_number/3 and
+ deconstruct.deconstruct_du/4 which return functor numbers suitable
+ for use by construct.construct, rather than functor strings.
+
+* We have added a function construct.get_functor_lex/2 which converts
+ an ordinal functor number into a lexicographic functor number.
+
Changes to the Mercury compiler:
* The compiler now issues a warning when an inst declaration is not
Index: browser/term_rep.m
===================================================================
RCS file: /home/mercury1/repository/mercury/browser/term_rep.m,v
retrieving revision 1.11
diff -u -u -r1.11 term_rep.m
--- browser/term_rep.m 1 Dec 2006 15:03:44 -0000 1.11
+++ browser/term_rep.m 26 Dec 2006 03:14:50 -0000
@@ -139,8 +139,12 @@
Value = univ_value(Univ),
deconstruct(Value, include_details_cc, Functor, Arity, _Args),
Type = type_of(Value),
- find_functor(1, num_functors(Type), Type, Functor, Arity,
- MaybeFunctorNum),
+ ( NumFunctors = num_functors(Type) ->
+ find_functor(1, NumFunctors, Type, Functor, Arity,
+ MaybeFunctorNum)
+ ;
+ MaybeFunctorNum = no
+ ),
(
MaybeFunctorNum = yes(FunctorNum),
(
Index: compiler/mlds_to_gcc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_gcc.m,v
retrieving revision 1.126
diff -u -u -r1.126 mlds_to_gcc.m
--- compiler/mlds_to_gcc.m 23 Dec 2006 12:49:24 -0000 1.126
+++ compiler/mlds_to_gcc.m 26 Dec 2006 02:08:03 -0000
@@ -2157,6 +2157,8 @@
build_struct_type("MR_TypeLayout",
[gcc__ptr_type_node - "MR_layout_init"],
GCC_Type, !IO).
+build_rtti_type_name(type_ctor_functor_number_map, gcc__ptr_type_node,
+ !IO).
build_rtti_type_name(type_ctor_type_ctor_info, GCC_Type, !IO) :-
% MR_Integer MR_type_ctor_arity;
% MR_int_least8_t MR_type_ctor_version;
@@ -2170,6 +2172,7 @@
% MR_TypeLayout MR_type_ctor_layout;
% MR_int_least32_t MR_type_ctor_num_functors;
% MR_int_least16_t MR_type_ctor_flags;
+ % MR_Integer * MR_type_ctor_functor_number_map;
build_rtti_type_name(type_ctor_type_functors, MR_TypeFunctors, !IO),
build_rtti_type_name(type_ctor_type_layout, MR_TypeLayout, !IO),
build_struct_type("MR_TypeCtorInfo_Struct",
@@ -2185,7 +2188,8 @@
MR_TypeFunctors - "MR_type_ctor_functors",
MR_TypeLayout - "MR_type_ctor_layout",
'MR_int_least32_t' - "MR_type_ctor_num_functors",
- 'MR_int_least16_t' - "MR_type_ctor_flags"],
+ 'MR_int_least16_t' - "MR_type_ctor_flags",
+ gcc__ptr_type_node - "MR_type_ctor_functor_number_map"],
GCC_Type, !IO).
build_rtti_type_name(type_ctor_type_info(TypeInfo), GCC_Type, !IO) :-
build_type_info_type(TypeInfo, GCC_Type, !IO).
Index: compiler/opt_debug.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/opt_debug.m,v
retrieving revision 1.186
diff -u -u -r1.186 opt_debug.m
--- compiler/opt_debug.m 22 Dec 2006 05:37:50 -0000 1.186
+++ compiler/opt_debug.m 26 Dec 2006 02:08:03 -0000
@@ -388,6 +388,7 @@
"maybe_res_addr_functor_desc".
dump_rtti_name(type_ctor_type_layout) = "type_layout".
dump_rtti_name(type_ctor_type_functors) = "type_functors".
+dump_rtti_name(type_ctor_functor_number_map) = "functor_number_map".
dump_rtti_name(type_ctor_type_ctor_info) = "type_ctor_info".
dump_rtti_name(type_ctor_type_info(_TypeInfo)) = "type_info".
% XXX Should give more info than this for _TypeInfo.
Index: compiler/rtti.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rtti.m,v
retrieving revision 1.77
diff -u -u -r1.77 rtti.m
--- compiler/rtti.m 29 Nov 2006 05:18:10 -0000 1.77
+++ compiler/rtti.m 26 Dec 2006 06:10:07 -0000
@@ -178,13 +178,17 @@
enum_functors :: list(enum_functor),
enum_value_table :: map(int, enum_functor),
enum_name_table :: map(string, enum_functor),
- enum_is_dummy :: bool
+ enum_is_dummy :: bool,
+ enum_functor_number_mapping
+ :: list(int)
)
; du(
du_axioms :: equality_axioms,
du_functors :: list(du_functor),
du_value_table :: ptag_map,
- du_name_table :: map(string, map(int, du_functor))
+ du_name_table :: map(string, map(int, du_functor)),
+ du_functor_number_mapping
+ :: list(int)
)
; reserved(
res_axioms :: equality_axioms,
@@ -192,7 +196,9 @@
res_value_table_res :: list(reserved_functor),
res_value_table_du :: ptag_map,
res_name_table :: map(string,
- map(int, maybe_reserved_functor))
+ map(int, maybe_reserved_functor)),
+ res_functor_number_mapping
+ :: list(int)
)
; notag(
notag_axioms :: equality_axioms,
@@ -615,6 +621,7 @@
; type_ctor_res_value_ordered_table
; type_ctor_res_name_ordered_table
; type_ctor_maybe_res_addr_functor_desc
+ ; type_ctor_functor_number_map
; type_ctor_type_functors
; type_ctor_type_layout
; type_ctor_type_ctor_info
@@ -1070,6 +1077,7 @@
ctor_rtti_name_is_exported(type_ctor_res_value_ordered_table) = no.
ctor_rtti_name_is_exported(type_ctor_res_name_ordered_table) = no.
ctor_rtti_name_is_exported(type_ctor_maybe_res_addr_functor_desc) = no.
+ctor_rtti_name_is_exported(type_ctor_functor_number_map) = no.
ctor_rtti_name_is_exported(type_ctor_type_functors) = no.
ctor_rtti_name_is_exported(type_ctor_type_layout) = no.
ctor_rtti_name_is_exported(type_ctor_type_ctor_info) = yes.
@@ -1258,6 +1266,10 @@
string.append_list([ModuleName, "__maybe_res_addr_functor_desc_",
TypeName, "_", A_str], Str)
;
+ RttiName = type_ctor_functor_number_map,
+ string.append_list([ModuleName, "__functor_number_map_",
+ TypeName, "_", A_str], Str)
+ ;
RttiName = type_ctor_type_functors,
string.append_list([ModuleName, "__type_functors",
TypeName, "_", A_str], Str)
@@ -1522,7 +1534,7 @@
type_ctor_rep_to_string(TypeCtorData, RepStr) :-
TypeCtorDetails = TypeCtorData ^ tcr_rep_details,
(
- TypeCtorDetails = enum(TypeCtorUserEq, _, _, _, IsDummy),
+ TypeCtorDetails = enum(TypeCtorUserEq, _, _, _, IsDummy, _),
(
IsDummy = yes,
expect(unify(TypeCtorUserEq, standard), this_file,
@@ -1539,7 +1551,7 @@
)
)
;
- TypeCtorDetails = du(TypeCtorUserEq, _, _, _),
+ TypeCtorDetails = du(TypeCtorUserEq, _, _, _, _),
(
TypeCtorUserEq = standard,
RepStr = "MR_TYPECTOR_REP_DU"
@@ -1548,7 +1560,7 @@
RepStr = "MR_TYPECTOR_REP_DU_USEREQ"
)
;
- TypeCtorDetails = reserved(TypeCtorUserEq, _, _, _, _),
+ TypeCtorDetails = reserved(TypeCtorUserEq, _, _, _, _, _),
(
TypeCtorUserEq = standard,
RepStr = "MR_TYPECTOR_REP_RESERVED_ADDR"
@@ -1669,11 +1681,11 @@
maybe_pseudo_type_info_or_self_to_rtti_data(self) =
rtti_data_pseudo_type_info(type_var(0)).
-type_ctor_details_num_ptags(enum(_, _, _, _, _)) = -1.
-type_ctor_details_num_ptags(du(_, _, PtagMap, _)) = LastPtag + 1 :-
+type_ctor_details_num_ptags(enum(_, _, _, _, _, _)) = -1.
+type_ctor_details_num_ptags(du(_, _, PtagMap, _, _)) = LastPtag + 1 :-
map.keys(PtagMap, Ptags),
list.last_det(Ptags, LastPtag).
-type_ctor_details_num_ptags(reserved(_, _, _, PtagMap, _)) = NumPtags :-
+type_ctor_details_num_ptags(reserved(_, _, _, PtagMap, _, _)) = NumPtags :-
map.keys(PtagMap, Ptags),
(
Ptags = [],
@@ -1689,11 +1701,11 @@
type_ctor_details_num_ptags(impl_artifact(_)) = -1.
type_ctor_details_num_ptags(foreign(_)) = -1.
-type_ctor_details_num_functors(enum(_, Functors, _, _, _)) =
+type_ctor_details_num_functors(enum(_, Functors, _, _, _, _)) =
list.length(Functors).
-type_ctor_details_num_functors(du(_, Functors, _, _)) =
+type_ctor_details_num_functors(du(_, Functors, _, _, _)) =
list.length(Functors).
-type_ctor_details_num_functors(reserved(_, Functors, _, _, _)) =
+type_ctor_details_num_functors(reserved(_, Functors, _, _, _, _)) =
list.length(Functors).
type_ctor_details_num_functors(notag(_, _)) = 1.
type_ctor_details_num_functors(eqv(_)) = -1.
@@ -1763,6 +1775,7 @@
ctor_rtti_name_code_addr(type_ctor_res_value_ordered_table) = no.
ctor_rtti_name_code_addr(type_ctor_res_name_ordered_table) = no.
ctor_rtti_name_code_addr(type_ctor_maybe_res_addr_functor_desc) = no.
+ctor_rtti_name_code_addr(type_ctor_functor_number_map) = no.
ctor_rtti_name_code_addr(type_ctor_type_hashcons_pointer) = no.
ctor_rtti_name_code_addr(type_ctor_type_functors) = no.
ctor_rtti_name_code_addr(type_ctor_type_layout) = no.
@@ -1958,6 +1971,8 @@
"MaybeResAddrFunctorDesc", yes).
ctor_rtti_name_type(type_ctor_maybe_res_addr_functor_desc,
"MaybeResAddrFunctorDesc", no).
+ctor_rtti_name_type(type_ctor_functor_number_map,
+ "Integer", yes).
ctor_rtti_name_type(type_ctor_type_functors,
"TypeFunctors", no).
ctor_rtti_name_type(type_ctor_type_layout,
Index: compiler/rtti_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rtti_out.m,v
retrieving revision 1.71
diff -u -u -r1.71 rtti_out.m
--- compiler/rtti_out.m 1 Dec 2006 15:04:19 -0000 1.71
+++ compiler/rtti_out.m 28 Dec 2006 13:46:02 -0000
@@ -565,7 +565,8 @@
TypeCtorData = type_ctor_data(Version, Module, TypeName, TypeArity,
UnifyUniv, CompareUniv, Flags, TypeCtorDetails),
output_type_ctor_details_defn(RttiTypeCtor, TypeCtorDetails,
- MaybeFunctorsName, MaybeLayoutName, !DeclSet, !IO),
+ MaybeFunctorsName, MaybeLayoutName, HaveFunctorNumberMap,
+ !DeclSet, !IO),
det_univ_to_type(UnifyUniv, UnifyProcLabel),
UnifyCodeAddr = make_code_addr(UnifyProcLabel),
det_univ_to_type(CompareUniv, CompareProcLabel),
@@ -617,6 +618,16 @@
io.write_int(type_ctor_details_num_functors(TypeCtorDetails), !IO),
io.write_string(",\n\t", !IO),
io.write_int(encode_type_ctor_flags(Flags), !IO),
+ io.write_string(",\n\t", !IO),
+ (
+ HaveFunctorNumberMap = yes,
+ FunctorNumberMapRttiId =
+ ctor_rtti_id(RttiTypeCtor, type_ctor_functor_number_map),
+ output_rtti_id(FunctorNumberMapRttiId, !IO)
+ ;
+ HaveFunctorNumberMap = no,
+ io.write_string("NULL", !IO)
+ ),
% This code is commented out while the corresponding fields of the
% MR_TypeCtorInfo_Struct type are commented out.
%
@@ -635,47 +646,60 @@
:- pred output_type_ctor_details_defn(rtti_type_ctor::in,
type_ctor_details::in,
- maybe(ctor_rtti_name)::out, maybe(ctor_rtti_name)::out,
+ maybe(ctor_rtti_name)::out, maybe(ctor_rtti_name)::out, bool::out,
decl_set::in, decl_set::out, io::di, io::uo) is det.
output_type_ctor_details_defn(RttiTypeCtor, TypeCtorDetails,
- MaybeFunctorsName, MaybeLayoutName, !DeclSet, !IO) :-
+ MaybeFunctorsName, MaybeLayoutName, HaveFunctorNumberMap,
+ !DeclSet, !IO) :-
(
TypeCtorDetails = enum(_, EnumFunctors, EnumByRep, EnumByName,
- _IsDummy),
+ _IsDummy, FunctorNumberMap),
list.foldl2(output_enum_functor_defn(RttiTypeCtor), EnumFunctors,
!DeclSet, !IO),
output_enum_value_ordered_table(RttiTypeCtor, EnumByRep,
!DeclSet, !IO),
output_enum_name_ordered_table(RttiTypeCtor, EnumByName,
!DeclSet, !IO),
+ output_functor_number_map(RttiTypeCtor, FunctorNumberMap,
+ !DeclSet, !IO),
MaybeLayoutName = yes(type_ctor_enum_value_ordered_table),
- MaybeFunctorsName = yes(type_ctor_enum_name_ordered_table)
+ MaybeFunctorsName = yes(type_ctor_enum_name_ordered_table),
+ HaveFunctorNumberMap = yes
;
- TypeCtorDetails = du(_, DuFunctors, DuByRep, DuByName),
+ TypeCtorDetails = du(_, DuFunctors, DuByRep,
+ DuByName, FunctorNumberMap),
list.foldl2(output_du_functor_defn(RttiTypeCtor), DuFunctors,
!DeclSet, !IO),
output_du_ptag_ordered_table(RttiTypeCtor, DuByRep, !DeclSet, !IO),
output_du_name_ordered_table(RttiTypeCtor, DuByName, !DeclSet, !IO),
+ output_functor_number_map(RttiTypeCtor, FunctorNumberMap,
+ !DeclSet, !IO),
MaybeLayoutName = yes(type_ctor_du_ptag_ordered_table),
- MaybeFunctorsName = yes(type_ctor_du_name_ordered_table)
+ MaybeFunctorsName = yes(type_ctor_du_name_ordered_table),
+ HaveFunctorNumberMap = yes
;
TypeCtorDetails = reserved(_, MaybeResFunctors, ResFunctors,
- DuByRep, MaybeResByName),
+ DuByRep, MaybeResByName, FunctorNumberMap),
list.foldl2(output_maybe_res_functor_defn(RttiTypeCtor),
MaybeResFunctors, !DeclSet, !IO),
output_res_value_ordered_table(RttiTypeCtor, ResFunctors, DuByRep,
!DeclSet, !IO),
output_res_name_ordered_table(RttiTypeCtor, MaybeResByName,
!DeclSet, !IO),
+ output_functor_number_map(RttiTypeCtor, FunctorNumberMap,
+ !DeclSet, !IO),
MaybeLayoutName = yes(type_ctor_res_value_ordered_table),
- MaybeFunctorsName = yes(type_ctor_res_name_ordered_table)
+ MaybeFunctorsName = yes(type_ctor_res_name_ordered_table),
+ HaveFunctorNumberMap = yes
;
TypeCtorDetails = notag(_, NotagFunctor),
output_notag_functor_defn(RttiTypeCtor, NotagFunctor,
!DeclSet, !IO),
+ output_functor_number_map(RttiTypeCtor, [0], !DeclSet, !IO),
MaybeLayoutName = yes(type_ctor_notag_functor_desc),
- MaybeFunctorsName = yes(type_ctor_notag_functor_desc)
+ MaybeFunctorsName = yes(type_ctor_notag_functor_desc),
+ HaveFunctorNumberMap = yes
;
TypeCtorDetails = eqv(EqvType),
output_maybe_pseudo_type_info_defn(EqvType, !DeclSet, !IO),
@@ -689,19 +713,23 @@
LayoutName = type_ctor_pseudo_type_info(PseudoTypeInfo)
),
MaybeLayoutName = yes(LayoutName),
- MaybeFunctorsName = no
+ MaybeFunctorsName = no,
+ HaveFunctorNumberMap = no
;
TypeCtorDetails = builtin(_),
MaybeLayoutName = no,
- MaybeFunctorsName = no
+ MaybeFunctorsName = no,
+ HaveFunctorNumberMap = no
;
TypeCtorDetails = impl_artifact(_),
MaybeLayoutName = no,
- MaybeFunctorsName = no
+ MaybeFunctorsName = no,
+ HaveFunctorNumberMap = no
;
TypeCtorDetails = foreign(_),
MaybeLayoutName = no,
- MaybeFunctorsName = no
+ MaybeFunctorsName = no,
+ HaveFunctorNumberMap = no
).
%-----------------------------------------------------------------------------%
@@ -1235,6 +1263,19 @@
%-----------------------------------------------------------------------------%
+:- pred output_functor_number_map(rtti_type_ctor::in, list(int)::in,
+ decl_set::in, decl_set::out, io::di, io::uo) is det.
+
+output_functor_number_map(RttiTypeCtor, FunctorNumberMap, !DeclSet, !IO) :-
+ output_generic_rtti_data_defn_start(
+ ctor_rtti_id(RttiTypeCtor, type_ctor_functor_number_map),
+ !DeclSet, !IO),
+ io.write_string(" = {\n\t", !IO),
+ io.write_list(FunctorNumberMap, ",\n\t", io.write_int, !IO),
+ io.write_string(" };\n\t", !IO).
+
+%-----------------------------------------------------------------------------%
+
:- type data_group
---> data_group(
data_c_type :: string,
Index: compiler/rtti_to_mlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rtti_to_mlds.m,v
retrieving revision 1.78
diff -u -u -r1.78 rtti_to_mlds.m
--- compiler/rtti_to_mlds.m 23 Dec 2006 12:49:25 -0000 1.78
+++ compiler/rtti_to_mlds.m 26 Dec 2006 11:58:38 -0000
@@ -228,7 +228,7 @@
some [!Defns] (
gen_functors_layout_info(ModuleInfo, RttiTypeCtor,
- TypeCtorDetails, FunctorsInfo, LayoutInfo, !:Defns),
+ TypeCtorDetails, FunctorsInfo, LayoutInfo, NumberMapInfo, !:Defns),
% Note that gen_init_special_pred will by necessity add an extra level
% of indirection to calling the special preds. However the backend
@@ -259,7 +259,9 @@
LayoutInfo
]),
gen_init_int(NumFunctors),
- gen_init_int(encode_type_ctor_flags(Flags))
+ gen_init_int(encode_type_ctor_flags(Flags)),
+ NumberMapInfo
+
% These two are commented out while the corresponding fields of the
% MR_TypeCtorInfo_Struct type are commented out.
% gen_init_maybe(gen_init_rtti_name(RttiTypeCtor), MaybeHashCons),
@@ -500,27 +502,31 @@
:- pred gen_functors_layout_info(module_info::in, rtti_type_ctor::in,
type_ctor_details::in, mlds_initializer::out, mlds_initializer::out,
- list(mlds_defn)::out) is det.
+ mlds_initializer::out, list(mlds_defn)::out) is det.
gen_functors_layout_info(ModuleInfo, RttiTypeCtor, TypeCtorDetails,
- FunctorInit, LayoutInit, Defns) :-
+ FunctorInit, LayoutInit, NumberMapInit, Defns) :-
module_info_get_name(ModuleInfo, ModuleName),
(
TypeCtorDetails = enum(_, EnumFunctors, EnumByValue, EnumByName,
- _IsDummy),
+ _IsDummy, FunctorNumberMap),
EnumFunctorDescs = list.map(
gen_enum_functor_desc(ModuleInfo, RttiTypeCtor), EnumFunctors),
ByValueDefn = gen_enum_value_ordered_table(ModuleInfo,
RttiTypeCtor, EnumByValue),
ByNameDefn = gen_enum_name_ordered_table(ModuleInfo,
RttiTypeCtor, EnumByName),
+ NumberMapDefn = gen_functor_number_map(RttiTypeCtor, FunctorNumberMap),
LayoutInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_enum_value_ordered_table),
FunctorInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_enum_name_ordered_table),
- Defns = EnumFunctorDescs ++ [ByValueDefn, ByNameDefn]
+ NumberMapInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
+ type_ctor_functor_number_map),
+ Defns = EnumFunctorDescs ++ [ByValueDefn, ByNameDefn, NumberMapDefn]
;
- TypeCtorDetails = du(_, DuFunctors, DuByPtag, DuByName),
+ TypeCtorDetails = du(_, DuFunctors, DuByPtag,
+ DuByName, FunctorNumberMap),
DuFunctorDefnLists = list.map(
gen_du_functor_desc(ModuleInfo, RttiTypeCtor), DuFunctors),
DuFunctorDefns = list.condense(DuFunctorDefnLists),
@@ -528,14 +534,17 @@
RttiTypeCtor, DuByPtag),
ByNameDefn = gen_du_name_ordered_table(ModuleInfo,
RttiTypeCtor, DuByName),
+ NumberMapDefn = gen_functor_number_map(RttiTypeCtor, FunctorNumberMap),
LayoutInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_du_ptag_ordered_table),
FunctorInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_du_name_ordered_table),
- Defns = DuFunctorDefns ++ [ByNameDefn | ByPtagDefns]
+ NumberMapInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
+ type_ctor_functor_number_map),
+ Defns = DuFunctorDefns ++ [ByNameDefn, NumberMapDefn | ByPtagDefns]
;
TypeCtorDetails = reserved(_, MaybeResFunctors, ResFunctors,
- DuByPtag, MaybeResByName),
+ DuByPtag, MaybeResByName, FunctorNumberMap),
MaybeResFunctorDefnLists = list.map(
gen_maybe_res_functor_desc(ModuleInfo, RttiTypeCtor),
MaybeResFunctors),
@@ -544,39 +553,52 @@
RttiTypeCtor, ResFunctors, DuByPtag),
ByNameDefn = gen_maybe_res_name_ordered_table(ModuleInfo,
RttiTypeCtor, MaybeResByName),
+ NumberMapDefn = gen_functor_number_map(RttiTypeCtor, FunctorNumberMap),
LayoutInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_res_value_ordered_table),
FunctorInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_res_name_ordered_table),
- Defns = [ByNameDefn | ByValueDefns ++ MaybeResFunctorDefns]
+ NumberMapInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
+ type_ctor_functor_number_map),
+ Defns = [ByNameDefn, NumberMapDefn
+ | ByValueDefns ++ MaybeResFunctorDefns]
;
TypeCtorDetails = notag(_, NotagFunctor),
- Defns = gen_notag_functor_desc(ModuleInfo, RttiTypeCtor, NotagFunctor),
+ NumberMapDefn = gen_functor_number_map(RttiTypeCtor, [0]),
LayoutInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_notag_functor_desc),
FunctorInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
- type_ctor_notag_functor_desc)
+ type_ctor_notag_functor_desc),
+ NumberMapInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
+ type_ctor_functor_number_map),
+ Defns = [NumberMapDefn | gen_notag_functor_desc(ModuleInfo,
+ RttiTypeCtor, NotagFunctor)]
;
TypeCtorDetails = eqv(EqvType),
TypeRttiData = maybe_pseudo_type_info_to_rtti_data(EqvType),
gen_pseudo_type_info(ModuleInfo, TypeRttiData, LayoutInit, Defns),
% The type is a lie, but a safe one.
- FunctorInit = gen_init_null_pointer(mlds_generic_type)
+ FunctorInit = gen_init_null_pointer(mlds_generic_type),
+ NumberMapInit = gen_init_null_pointer(mlds_generic_type)
+
;
TypeCtorDetails = builtin(_),
Defns = [],
LayoutInit = gen_init_null_pointer(mlds_generic_type),
- FunctorInit = gen_init_null_pointer(mlds_generic_type)
+ FunctorInit = gen_init_null_pointer(mlds_generic_type),
+ NumberMapInit = gen_init_null_pointer(mlds_generic_type)
;
TypeCtorDetails = impl_artifact(_),
Defns = [],
LayoutInit = gen_init_null_pointer(mlds_generic_type),
- FunctorInit = gen_init_null_pointer(mlds_generic_type)
+ FunctorInit = gen_init_null_pointer(mlds_generic_type),
+ NumberMapInit = gen_init_null_pointer(mlds_generic_type)
;
TypeCtorDetails = foreign(_),
Defns = [],
LayoutInit = gen_init_null_pointer(mlds_generic_type),
- FunctorInit = gen_init_null_pointer(mlds_generic_type)
+ FunctorInit = gen_init_null_pointer(mlds_generic_type),
+ NumberMapInit = gen_init_null_pointer(mlds_generic_type)
).
%-----------------------------------------------------------------------------%
@@ -1070,6 +1092,14 @@
])
).
+:- func gen_functor_number_map(rtti_type_ctor, list(int)) = mlds_defn.
+
+gen_functor_number_map(RttiTypeCtor, FunctorNumberMap) =
+ MLDS_Defn :-
+ Init = gen_init_array(gen_init_int, FunctorNumberMap),
+ RttiName = type_ctor_functor_number_map,
+ rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Init, MLDS_Defn).
+
%-----------------------------------------------------------------------------%
:- func gen_init_rtti_names_array(module_name, rtti_type_ctor,
Index: compiler/type_ctor_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_ctor_info.m,v
retrieving revision 1.85
diff -u -u -r1.85 type_ctor_info.m
--- compiler/type_ctor_info.m 1 Nov 2006 06:33:22 -0000 1.85
+++ compiler/type_ctor_info.m 26 Dec 2006 02:08:03 -0000
@@ -474,7 +474,7 @@
%
:- func type_ctor_info_rtti_version = int.
-type_ctor_info_rtti_version = 9.
+type_ctor_info_rtti_version = 12.
% Construct an rtti_data for a pseudo_type_info, and also construct
% rtti_data definitions for all of the pseudo_type_infos that it references
@@ -585,7 +585,9 @@
;
IsDummy = no
),
- Details = enum(EqualityAxioms, EnumFunctors, ValueMap, NameMap, IsDummy).
+ FunctorNumberMap = make_functor_number_map(Ctors),
+ Details = enum(EqualityAxioms, EnumFunctors, ValueMap, NameMap, IsDummy,
+ FunctorNumberMap).
% Create an enum_functor structure for each functor in an enum type.
% The functors are given to us in ordinal order (since that's how the HLDS
@@ -659,17 +661,19 @@
ResFunctors = list.filter_map(is_reserved_functor, MaybeResFunctors),
list.foldl(make_du_ptag_ordered_table, DuFunctors,
map.init, DuPtagTable),
+ FunctorNumberMap = make_functor_number_map(Ctors),
(
ResFunctors = [],
list.foldl(make_du_name_ordered_table, DuFunctors,
map.init, DuNameOrderedMap),
- Details = du(EqualityAxioms, DuFunctors, DuPtagTable, DuNameOrderedMap)
+ Details = du(EqualityAxioms, DuFunctors, DuPtagTable, DuNameOrderedMap,
+ FunctorNumberMap)
;
ResFunctors = [_ | _],
list.foldl(make_res_name_ordered_table, MaybeResFunctors,
map.init, ResNameOrderedMap),
Details = reserved(EqualityAxioms, MaybeResFunctors,
- ResFunctors, DuPtagTable, ResNameOrderedMap)
+ ResFunctors, DuPtagTable, ResNameOrderedMap, FunctorNumberMap)
).
:- type maybe_reserved_rep
@@ -945,6 +949,22 @@
%---------------------------------------------------------------------------%
+ % Construct the array mapping ordinal constructor numbers
+ % to lexicographic constructor numbers.
+:- func make_functor_number_map(list(constructor)) = list(int).
+
+make_functor_number_map(Ctors) = Map :-
+ CtorNames : assoc_list(sym_name, int) =
+ list.map(
+ (func(Ctor) = Ctor ^ cons_name - length(Ctor ^ cons_args)),
+ Ctors),
+ SortedNameArityMap =
+ map.from_corresponding_lists(list.sort(CtorNames),
+ 0 `..` (length(Ctors) - 1)),
+ Map = map.apply_to_list(CtorNames, SortedNameArityMap).
+
+%---------------------------------------------------------------------------%
+
compute_contains_var_bit_vector(ArgTypes) = Vector :-
compute_contains_var_bit_vector_2(ArgTypes, 0, 0, Vector).
Index: library/construct.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/construct.m,v
retrieving revision 1.32
diff -u -u -r1.32 construct.m
--- library/construct.m 23 Oct 2006 00:32:56 -0000 1.32
+++ library/construct.m 28 Dec 2006 04:26:41 -0000
@@ -23,19 +23,22 @@
%-----------------------------------------------------------------------------%
- % num_functors(TypeInfo).
- %
- % Returns the number of different functors for the top-level
- % type constructor of the type specified by TypeInfo, or -1
- % if the type is not a discriminated union type.
- %
% The functors of a discriminated union type are numbered from
% zero to N-1, where N is the value returned by num_functors.
% The functors are numbered in lexicographic order. If two
% functors have the same name, the one with the lower arity
% will have the lower number.
%
-:- func num_functors(type_desc) = int.
+:- type functor_number_ordinal == int.
+:- type functor_number_lex == int.
+
+ % num_functors(TypeInfo).
+ %
+ % Returns the number of different functors for the top-level
+ % type constructor of the type specified by TypeInfo, or -1
+ % if the type is not a discriminated union type.
+ %
+:- func num_functors(type_desc) = int is semidet.
% get_functor(Type, FunctorNumber, FunctorName, Arity, ArgTypes).
%
@@ -45,8 +48,8 @@
% Fails if the type is not a discriminated union type, or if
% FunctorNumber is out of range.
%
-:- pred get_functor(type_desc::in, int::in, string::out, int::out,
- list(pseudo_type_desc)::out) is semidet.
+:- pred get_functor(type_desc::in, functor_number_lex::in,
+ string::out, int::out, list(pseudo_type_desc)::out) is semidet.
% get_functor_with_names(Type, FunctorNumber, FunctorName, Arity, ArgTypes,
% ArgNames).
@@ -57,17 +60,31 @@
% field name of each functor argument, if any. Fails if the type is
% not a discriminated union type, or if FunctorNumber is out of range.
%
-:- pred get_functor_with_names(type_desc::in, int::in, string::out, int::out,
- list(pseudo_type_desc)::out, list(maybe(string))::out) is semidet.
+:- pred get_functor_with_names(type_desc::in, functor_number_lex::in,
+ string::out, int::out, list(pseudo_type_desc)::out,
+ list(maybe(string))::out) is semidet.
- % get_functor_ordinal(Type, I, Ordinal).
+ % get_functor_ordinal(Type, I) = Ordinal.
%
% Returns Ordinal, where Ordinal is the position in declaration order
% for the specified type of the function symbol that is in position I
% in lexicographic order. Fails if the type is not a discriminated
% union type, or if I is out of range.
%
-:- pred get_functor_ordinal(type_desc::in, int::in, int::out) is semidet.
+:- func get_functor_ordinal(type_desc, functor_number_lex) =
+ functor_number_ordinal is semidet.
+:- pred get_functor_ordinal(type_desc::in, functor_number_lex::in,
+ functor_number_ordinal::out) is semidet.
+
+ % get_functor_lex(Type, Ordinal) = I.
+ %
+ % Returns I, where I is the position in lexicographic order for the
+ % specified type of the function symbol that is in position Ordinal
+ % in declaration order. Fails if the type is not a discriminated
+ % union type, or if Ordinal is out of range.
+ %
+:- func get_functor_lex(type_desc, functor_number_ordinal) =
+ functor_number_lex is semidet.
% construct(TypeInfo, I, Args) = Term.
%
@@ -79,8 +96,7 @@
% functor, or if the types of the arguments do not match
% the expected argument types of that functor.
%
-:- func construct(type_desc::in, int::in, list(univ)::in) = (univ::out)
- is semidet.
+:- func construct(type_desc, functor_number_lex, list(univ)) = univ is semidet.
% construct_tuple(Args) = Term.
%
@@ -111,6 +127,7 @@
MR_save_transient_registers();
Functors = MR_get_num_functors((MR_TypeInfo) TypeInfo);
MR_restore_transient_registers();
+ SUCCESS_INDICATOR = (Functors >= 0);
}").
num_functors(TypeDesc) = rtti_implementation.num_functors(TypeDesc).
@@ -305,6 +322,9 @@
succeeded = (S == null);
").
+get_functor_ordinal(TypeDesc, FunctorNumber) = Ordinal :-
+ get_functor_ordinal(TypeDesc, FunctorNumber, Ordinal).
+
:- pragma foreign_proc("C",
get_functor_ordinal(TypeDesc::in, FunctorNumber::in, Ordinal::out),
[will_not_call_mercury, thread_safe, promise_pure],
@@ -390,6 +410,41 @@
SUCCESS_INDICATOR = success;
}").
+:- pragma foreign_proc("C",
+ get_functor_lex(TypeDesc::in, Ordinal::in) = (FunctorNumber::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+ MR_TypeInfo type_info;
+ MR_TypeCtorInfo type_ctor_info;
+ MR_Construct_Info construct_info;
+ MR_bool success;
+ int num_functors;
+
+ type_info = (MR_TypeInfo) TypeDesc;
+
+ /*
+ ** Get information for this functor number and store in construct_info.
+ ** If this is a discriminated union type and if the functor number is
+ ** in range, we succeed.
+ */
+ MR_save_transient_registers();
+ type_info = MR_collapse_equivalences(type_info);
+ num_functors = MR_get_num_functors(type_info);
+ MR_restore_transient_registers();
+ type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
+ if (Ordinal < 0 || Ordinal >= num_functors
+ || type_ctor_info->MR_type_ctor_version
+ != MR_RTTI_VERSION__FUNCTOR_NUMBERS
+ || !type_ctor_info->MR_type_ctor_functor_number_map)
+ {
+ SUCCESS_INDICATOR = MR_FALSE;
+ } else {
+ FunctorNumber =
+ type_ctor_info->MR_type_ctor_functor_number_map[Ordinal];
+ SUCCESS_INDICATOR = MR_TRUE;
+ }
+}").
+
:- pragma no_inline(construct/3).
:- pragma foreign_proc("C",
construct(TypeDesc::in, FunctorNumber::in, ArgList::in) = (Term::out),
Index: library/deconstruct.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/deconstruct.m,v
retrieving revision 1.41
diff -u -u -r1.41 deconstruct.m
--- library/deconstruct.m 27 Sep 2006 09:09:37 -0000 1.41
+++ library/deconstruct.m 29 Dec 2006 03:12:42 -0000
@@ -16,6 +16,7 @@
:- module deconstruct.
:- interface.
+:- import_module construct.
:- import_module list.
:- import_module maybe.
:- import_module univ.
@@ -50,6 +51,9 @@
:- inst canonicalize_or_do_not_allow
---> do_not_allow
; canonicalize.
+:- inst do_not_allow_or_include_details_cc
+ ---> do_not_allow
+ ; include_details_cc.
% functor, argument and deconstruct and their variants take any type
% (including univ), and return representation information for that type.
@@ -117,6 +121,25 @@
:- mode functor(in, in(include_details_cc), out, out) is cc_multi.
:- mode functor(in, in, out, out) is cc_multi.
+ % functor_number(Data, FunctorNumber, Arity)
+ %
+ % Given a data item, return the number of the functor,
+ % suitable for use by construct.construct, and the arity.
+ % Fail if the item does not have a discriminated union type.
+ % Abort if the type has user-defined equality.
+ %
+:- pred functor_number(T::in, functor_number_lex::out, int::out) is semidet.
+
+ % functor_number_cc(Data, FunctorNumber, Arity)
+ %
+ % Given a data item, return the number of the functor,
+ % suitable for use by construct.construct, and the arity.
+ % Fail if the item does not have a discriminated union type.
+ % Don't abort if the type has user-defined equality.
+ %
+:- pred functor_number_cc(T::in, functor_number_lex::out,
+ int::out) is cc_nondet.
+
% arg(Data, NonCanon, Index, Argument)
%
% Given a data item (Data) and an argument index (Index), starting
@@ -203,6 +226,22 @@
:- mode deconstruct(in, in(include_details_cc), out, out, out) is cc_multi.
:- mode deconstruct(in, in, out, out, out) is cc_multi.
+ % deconstruct_du(Data, NonCanon, FunctorNumber, Arity, Arguments)
+ %
+ % Given a data item (Data) which has a discriminated union type, binds
+ % FunctorNumber to the number of the functor in lexicographic order,
+ % Arity to the arity of this data item, and Arguments to a list of
+ % arguments of the functor. The arguments in the list are each of type
+ % univ.
+ %
+ % Fails if Data does not have discriminated union type.
+ %
+:- pred deconstruct_du(T, noncanon_handling, functor_number_lex,
+ int, list(univ)).
+:- mode deconstruct_du(in, in(do_not_allow), out, out, out) is semidet.
+:- mode deconstruct_du(in, in(include_details_cc), out, out, out) is cc_nondet.
+:- mode deconstruct_du(in, in, out, out, out) is cc_nondet.
+
% limited_deconstruct(Data, NonCanon, MaxArity,
% Functor, Arity, Arguments)
%
@@ -229,8 +268,10 @@
:- implementation.
+:- import_module construct.
:- import_module int.
:- import_module require.
+:- import_module type_desc.
% For use by the Java and IL backends.
%
@@ -251,6 +292,8 @@
% will refer to an undefined variable.
:- pragma no_inline(functor/4).
+:- pragma no_inline(functor_number/3).
+:- pragma no_inline(functor_number_cc/3).
:- pragma no_inline(arg/4).
:- pragma no_inline(named_arg/4).
:- pragma no_inline(deconstruct/5).
@@ -372,13 +415,34 @@
deconstruct(Term, NonCanon, Functor, Arity, Arguments) :-
(
NonCanon = do_not_allow,
- deconstruct_dna(Term, Functor, Arity, Arguments)
+ deconstruct_dna(Term, Functor, _, Arity, Arguments)
;
NonCanon = canonicalize,
deconstruct_can(Term, Functor, Arity, Arguments)
;
NonCanon = include_details_cc,
- deconstruct_idcc(Term, Functor, Arity, Arguments)
+ deconstruct_idcc(Term, Functor, _, Arity, Arguments)
+ ).
+
+deconstruct_du(Term, NonCanon, FunctorNumber, Arity, Arguments) :-
+ ( _ = construct.num_functors(type_of(Term)) ->
+ (
+ NonCanon = do_not_allow,
+ deconstruct_dna(Term, _, FunctorNumber, Arity, Arguments)
+ ;
+ NonCanon = canonicalize,
+ error("deconstruct_du: canonicalize not supported")
+ ;
+ NonCanon = include_details_cc,
+ deconstruct_idcc(Term, _, FunctorNumber, Arity, Arguments)
+ ),
+ ( FunctorNumber >= 0 ->
+ true
+ ;
+ error("deconstruct_du: internal error (recompile needed?)")
+ )
+ ;
+ fail
).
limited_deconstruct(Term, NonCanon, MaxArity, Functor, Arity, Arguments) :-
@@ -470,6 +534,53 @@
%-----------------------------------------------------------------------------%
+:- pragma foreign_proc("C",
+ functor_number(Term::in, FunctorNumber::out, Arity::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+#define TYPEINFO_ARG TypeInfo_for_T
+#define TERM_ARG Term
+#define FUNCTOR_NUMBER_ARG FunctorNumber
+#undef FUNCTOR_ARG
+#define ARITY_ARG Arity
+#define NONCANON MR_NONCANON_ABORT
+#include ""mercury_ml_functor_body.h""
+#undef TYPEINFO_ARG
+#undef TERM_ARG
+#undef FUNCTOR_NUMBER_ARG
+#undef ARITY_ARG
+#undef NONCANON
+
+SUCCESS_INDICATOR = (FunctorNumber >= 0);
+}").
+
+:- pragma foreign_proc("C",
+ functor_number_cc(Term::in, FunctorNumber::out, Arity::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+#define TYPEINFO_ARG TypeInfo_for_T
+#define TERM_ARG Term
+#define FUNCTOR_NUMBER_ARG FunctorNumber
+#undef FUNCTOR_ARG
+#define ARITY_ARG Arity
+#define NONCANON MR_NONCANON_ALLOW
+#include ""mercury_ml_functor_body.h""
+#undef TYPEINFO_ARG
+#undef TERM_ARG
+#undef FUNCTOR_NUMBER_ARG
+#undef ARITY_ARG
+#undef NONCANON
+
+SUCCESS_INDICATOR = (FunctorNumber >= 0);
+}").
+
+functor_number(_Term::in, _FunctorNumber::out, _Arity::out) :-
+ private_builtin.sorry("deconstruct.functor_number").
+functor_number_cc(_Term::in, _FunctorNumber::out, _Arity::out) :-
+ private_builtin.sorry("deconstruct.functor_number_cc").
+
+%-----------------------------------------------------------------------------%
+
% XXX These predicates return univs instead of existentially typed arguments
% in order to work around the typechecking bug reported on 30 Jan, 2002
% to the mercury-bugs mailing list, and which has sourceforge bug id 512581:
@@ -671,10 +782,11 @@
%-----------------------------------------------------------------------------%
-:- pred deconstruct_dna(T::in, string::out, int::out, list(univ)::out) is det.
+:- pred deconstruct_dna(T::in, string::out,
+ int::out, int::out, list(univ)::out) is det.
:- pred deconstruct_can(T::in, string::out, int::out, list(univ)::out) is det.
-:- pred deconstruct_idcc(T::in, string::out, int::out, list(univ)::out)
- is cc_multi.
+:- pred deconstruct_idcc(T::in, string::out,
+ int::out, int::out, list(univ)::out) is cc_multi.
:- pred limited_deconstruct_dna(T::in, int::in,
string::out, int::out, list(univ)::out) is semidet.
@@ -684,7 +796,8 @@
string::out, int::out, list(univ)::out) is cc_multi.
:- pragma foreign_proc("C",
- deconstruct_dna(Term::in, Functor::out, Arity::out, Arguments::out),
+ deconstruct_dna(Term::in, Functor::out, FunctorNumber::out,
+ Arity::out, Arguments::out),
[will_not_call_mercury, thread_safe, promise_pure],
"{
#define EXPAND_INFO_TYPE MR_Expand_Functor_Args_Info
@@ -692,6 +805,7 @@
#define TYPEINFO_ARG TypeInfo_for_T
#define TERM_ARG Term
#define FUNCTOR_ARG Functor
+#define FUNCTOR_NUMBER_ARG FunctorNumber
#define ARITY_ARG Arity
#define ARGUMENTS_ARG Arguments
#define NONCANON MR_NONCANON_ABORT
@@ -701,6 +815,7 @@
#undef TYPEINFO_ARG
#undef TERM_ARG
#undef FUNCTOR_ARG
+#undef FUNCTOR_NUMBER_ARG
#undef ARITY_ARG
#undef ARGUMENTS_ARG
#undef NONCANON
@@ -715,6 +830,7 @@
#define TYPEINFO_ARG TypeInfo_for_T
#define TERM_ARG Term
#define FUNCTOR_ARG Functor
+#undef FUNCTOR_NUMBER_ARG
#define ARITY_ARG Arity
#define ARGUMENTS_ARG Arguments
#define NONCANON MR_NONCANON_ALLOW
@@ -730,7 +846,8 @@
}").
:- pragma foreign_proc("C",
- deconstruct_idcc(Term::in, Functor::out, Arity::out, Arguments::out),
+ deconstruct_idcc(Term::in, Functor::out, FunctorNumber::out,
+ Arity::out, Arguments::out),
[will_not_call_mercury, thread_safe, promise_pure],
"{
#define EXPAND_INFO_TYPE MR_Expand_Functor_Args_Info
@@ -738,6 +855,7 @@
#define TYPEINFO_ARG TypeInfo_for_T
#define TERM_ARG Term
#define FUNCTOR_ARG Functor
+#define FUNCTOR_NUMBER_ARG FunctorNumber
#define ARITY_ARG Arity
#define ARGUMENTS_ARG Arguments
#define NONCANON MR_NONCANON_CC
@@ -747,6 +865,7 @@
#undef TYPEINFO_ARG
#undef TERM_ARG
#undef FUNCTOR_ARG
+#undef FUNCTOR_NUMBER_ARG
#undef ARITY_ARG
#undef ARGUMENTS_ARG
#undef NONCANON
@@ -847,13 +966,17 @@
}
}").
-deconstruct_dna(Term::in, Functor::out, Arity::out, Arguments::out) :-
+deconstruct_dna(Term::in, Functor::out, FunctorNumber::out,
+ Arity::out, Arguments::out) :-
+ FunctorNumber = -1,
rtti_implementation.deconstruct(Term, do_not_allow,
Functor, Arity, Arguments).
deconstruct_can(Term::in, Functor::out, Arity::out, Arguments::out) :-
rtti_implementation.deconstruct(Term, canonicalize,
Functor, Arity, Arguments).
-deconstruct_idcc(Term::in, Functor::out, Arity::out, Arguments::out) :-
+deconstruct_idcc(Term::in, Functor::out, FunctorNumber::out,
+ Arity::out, Arguments::out) :-
+ FunctorNumber = -1,
rtti_implementation.deconstruct(Term, include_details_cc,
Functor, Arity, Arguments).
Index: library/term.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/term.m,v
retrieving revision 1.125
diff -u -u -r1.125 term.m
--- library/term.m 1 Nov 2006 06:33:37 -0000 1.125
+++ library/term.m 27 Dec 2006 01:09:38 -0000
@@ -682,8 +682,12 @@
univ_to_term(Univ, Term) :-
context_init(Context),
Type = univ_type(Univ),
- % NU-Prolog barfs on `num_functors(Type) < 0'
- ( construct.num_functors(Type) = N, N < 0 ->
+ ( construct.num_functors(Type) = _ ->
+ deconstruct(univ_value(Univ), canonicalize, FunctorString,
+ _FunctorArity, FunctorArgs),
+ univ_list_to_term_list(FunctorArgs, TermArgs),
+ Term = functor(atom(FunctorString), TermArgs, Context)
+ ;
(
type_ctor_and_args(Type, TypeCtor, TypeArgs),
TypeName = type_ctor_name(TypeCtor),
@@ -697,11 +701,6 @@
++ type_name(univ_type(Univ)) ++ "'",
error(Message)
)
- ;
- deconstruct(univ_value(Univ), canonicalize, FunctorString,
- _FunctorArity, FunctorArgs),
- univ_list_to_term_list(FunctorArgs, TermArgs),
- Term = functor(atom(FunctorString), TermArgs, Context)
).
:- pred univ_to_term_special_case(string::in, string::in,
Index: runtime/mercury_builtin_types.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_builtin_types.c,v
retrieving revision 1.18
diff -u -u -r1.18 mercury_builtin_types.c
--- runtime/mercury_builtin_types.c 14 Nov 2006 00:15:39 -0000 1.18
+++ runtime/mercury_builtin_types.c 26 Dec 2006 02:08:03 -0000
@@ -58,8 +58,10 @@
MR_TYPE_CTOR_FLAG_VARIABLE_ARITY);
MR_DEFINE_TYPE_CTOR_INFO_FLAG(builtin, func, 0, FUNC,
MR_TYPE_CTOR_FLAG_VARIABLE_ARITY);
-MR_DEFINE_TYPE_CTOR_INFO_FLAG(builtin, tuple, 0, TUPLE,
- MR_TYPE_CTOR_FLAG_VARIABLE_ARITY);
+
+static MR_Integer MR_tuple_functor_number_map[] = {0};
+MR_DEFINE_TYPE_CTOR_INFO_FLAG_FUNCTORS(builtin, tuple, 0, TUPLE,
+ MR_TYPE_CTOR_FLAG_VARIABLE_ARITY, MR_tuple_functor_number_map);
#ifndef MR_HIGHLEVEL_CODE
MR_DEFINE_TYPE_CTOR_INFO(builtin, succip, 0, SUCCIP);
Index: runtime/mercury_deconstruct.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_deconstruct.h,v
retrieving revision 1.5
diff -u -u -r1.5 mercury_deconstruct.h
--- runtime/mercury_deconstruct.h 21 Jun 2005 03:12:02 -0000 1.5
+++ runtime/mercury_deconstruct.h 26 Dec 2006 02:08:03 -0000
@@ -30,12 +30,14 @@
typedef struct {
int arity;
+ int functor_number;
MR_ConstString functor;
MR_Expand_Args_Fields args;
} MR_Expand_Functor_Args_Info;
typedef struct {
int arity;
+ int functor_number;
MR_ConstString functor;
MR_Expand_Args_Fields args;
MR_bool limit_reached;
@@ -43,6 +45,7 @@
typedef struct {
int arity;
+ int functor_number;
MR_ConstString functor_only;
} MR_Expand_Functor_Only_Info;
Index: runtime/mercury_deconstruct_macros.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_deconstruct_macros.h,v
retrieving revision 1.3
diff -u -u -r1.3 mercury_deconstruct_macros.h
--- runtime/mercury_deconstruct_macros.h 7 Jul 2004 07:11:09 -0000 1.3
+++ runtime/mercury_deconstruct_macros.h 26 Dec 2006 02:08:03 -0000
@@ -39,6 +39,11 @@
MR_make_aligned_string(var, (ei).functor_field); \
} while (0)
+#define MR_deconstruct_get_functor_number(ei, var) \
+ do { \
+ var = (ei).functor_number; \
+ } while (0)
+
#define MR_deconstruct_get_arity(ei, var) \
do { \
var = (ei).arity; \
Index: runtime/mercury_mcpp.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_mcpp.h,v
retrieving revision 1.33
diff -u -u -r1.33 mercury_mcpp.h
--- runtime/mercury_mcpp.h 29 Mar 2006 08:07:54 -0000 1.33
+++ runtime/mercury_mcpp.h 26 Dec 2006 02:08:03 -0000
@@ -127,7 +127,7 @@
#define MR_TYPECTOR_REP(a) MR_BOX_INT(mercury::runtime::Constants::a)
// XXX This is hardcoded
-#define MR_RTTI_VERSION MR_BOX_INT(9)
+#define MR_RTTI_VERSION MR_BOX_INT(12)
// XXX It is intended that we eventually define the constants in
// private_builtin.m and mercury_mcpp.cpp in terms of these #defines
Index: runtime/mercury_ml_deconstruct_body.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_ml_deconstruct_body.h,v
retrieving revision 1.5
diff -u -u -r1.5 mercury_ml_deconstruct_body.h
--- runtime/mercury_ml_deconstruct_body.h 7 Jul 2004 07:11:14 -0000 1.5
+++ runtime/mercury_ml_deconstruct_body.h 28 Dec 2006 11:05:54 -0000
@@ -33,6 +33,9 @@
** FUNCTOR_ARG Gives the name of the argument to which we assign
** the function symbol of the term.
**
+** FUNCTOR_NUMBER_ARG (optional) Gives the name of the argument to which we
+** assign the function symbol number of the term.
+**
** ARITY_ARG Gives the name of the argument to which the value of
** the arity field should be assigned.
**
@@ -89,9 +92,13 @@
max_arity_check_start
MR_deconstruct_get_functor(expand_info, functor, conststring_functor);
FUNCTOR_ARG = (MR_String) (MR_Integer) conststring_functor;
+
MR_deconstruct_get_arity(expand_info, ARITY_ARG);
MR_deconstruct_get_arg_list(expand_info, args, ARGUMENTS_ARG);
MR_deconstruct_free_allocated_arg_type_infos(expand_info, args);
+#ifdef FUNCTOR_NUMBER_ARG
+ MR_deconstruct_get_functor_number(expand_info, FUNCTOR_NUMBER_ARG);
+#endif
max_arity_check_end
#ifdef SAVE_SUCCESS
Index: runtime/mercury_ml_expand_body.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_ml_expand_body.h,v
retrieving revision 1.38
diff -u -u -r1.38 mercury_ml_expand_body.h
--- runtime/mercury_ml_expand_body.h 29 Nov 2006 05:18:24 -0000 1.38
+++ runtime/mercury_ml_expand_body.h 28 Dec 2006 11:26:22 -0000
@@ -178,6 +178,20 @@
name); \
MR_save_transient_hp(); \
} while (0)
+ #define handle_functor_number(num) \
+ do { \
+ expand_info->functor_number = (num); \
+ } while (0)
+ #define handle_type_functor_number(tci, ordinal) \
+ do { \
+ if ((tci)->MR_type_ctor_version >= \
+ MR_RTTI_VERSION__FUNCTOR_NUMBERS \
+ && (tci)->MR_type_ctor_functor_number_map) \
+ { \
+ expand_info->functor_number = \
+ (tci)->MR_type_ctor_functor_number_map[ordinal]; \
+ } \
+ } while (0)
#else /* EXPAND_FUNCTOR_FIELD */
#define handle_functor_name(name) \
((void) 0)
@@ -185,6 +199,10 @@
((void) 0)
#define handle_type_ctor_name(tci) \
((void) 0)
+ #define handle_functor_number(num) \
+ ((void) 0)
+ #define handle_type_functor_number(tci, ordinal) \
+ ((void) 0)
#endif /* EXPAND_FUNCTOR_FIELD */
/* set up macros for the common code handling zero arity terms */
@@ -267,6 +285,8 @@
expand_info->limit_reached = MR_FALSE;
#endif /* EXPAND_APPLY_LIMIT */
+ handle_functor_number(-1);
+
if (! MR_type_ctor_has_valid_rep(type_ctor_info)) {
MR_fatal_error(MR_STRINGIFY(EXPAND_FUNCTION_NAME)
": term of unknown representation");
@@ -290,6 +310,9 @@
case MR_TYPECTOR_REP_ENUM:
handle_functor_name(MR_type_ctor_layout(type_ctor_info).
MR_layout_enum[*data_word_ptr]->MR_enum_functor_name);
+ handle_type_functor_number(type_ctor_info,
+ MR_type_ctor_layout(type_ctor_info).
+ MR_layout_enum[*data_word_ptr]->MR_enum_functor_ordinal);
handle_zero_arity_args();
return;
@@ -301,6 +324,7 @@
handle_functor_name(MR_type_ctor_layout(type_ctor_info).
MR_layout_enum[0]->MR_enum_functor_name);
handle_zero_arity_args();
+ handle_functor_number(0);
return;
case MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ:
@@ -335,6 +359,9 @@
{
handle_functor_name(ra_layout->MR_ra_constants[data]->
MR_ra_functor_name);
+ handle_type_functor_number(type_ctor_info,
+ ra_layout->MR_ra_constants[data]->
+ MR_ra_functor_ordinal);
handle_zero_arity_args();
return;
}
@@ -351,6 +378,9 @@
offset = i + ra_layout->MR_ra_num_res_numeric_addrs;
handle_functor_name(ra_layout->
MR_ra_constants[offset]->MR_ra_functor_name);
+ handle_type_functor_number(type_ctor_info,
+ ra_layout->MR_ra_constants[offset]->
+ MR_ra_functor_ordinal);
handle_zero_arity_args();
/* "break" here would just exit the "for" loop */
return;
@@ -435,6 +465,8 @@
}
handle_functor_name(functor_desc->MR_du_functor_name);
+ handle_type_functor_number(type_ctor_info,
+ functor_desc->MR_du_functor_ordinal);
expand_info->arity = functor_desc->MR_du_functor_orig_arity;
#if defined(EXPAND_ARGS_FIELD) || defined(EXPAND_ONE_ARG)
@@ -537,6 +569,7 @@
case MR_TYPECTOR_REP_NOTAG:
expand_info->arity = 1;
+ handle_functor_number(0);
handle_functor_name(MR_type_ctor_layout(type_ctor_info).
MR_layout_notag->MR_notag_functor_name);
@@ -593,6 +626,7 @@
case MR_TYPECTOR_REP_NOTAG_GROUND:
expand_info->arity = 1;
+ handle_functor_number(0);
handle_functor_name(MR_type_ctor_layout(type_ctor_info).
MR_layout_notag->MR_notag_functor_name);
@@ -840,6 +874,7 @@
case MR_TYPECTOR_REP_TUPLE:
expand_info->arity = MR_TYPEINFO_GET_VAR_ARITY_ARITY(type_info);
+ handle_functor_number(0);
handle_functor_name("{}");
#ifdef EXPAND_ARGS_FIELD
@@ -1327,6 +1362,8 @@
#undef EXTRA_ARGS
#undef EXPAND_ONE_ARG
#undef handle_functor_name
+#undef handle_functor_number
+#undef handle_type_functor_number
#undef handle_noncanonical_name
#undef handle_type_ctor_name
#undef handle_zero_arity_args
Index: runtime/mercury_ml_functor_body.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_ml_functor_body.h,v
retrieving revision 1.3
diff -u -u -r1.3 mercury_ml_functor_body.h
--- runtime/mercury_ml_functor_body.h 7 Jul 2004 07:11:14 -0000 1.3
+++ runtime/mercury_ml_functor_body.h 28 Dec 2006 11:05:02 -0000
@@ -24,6 +24,9 @@
** FUNCTOR_ARG Gives the name of the argument to which we assign
** the function symbol of the term.
**
+** FUNCTOR_NUMBER_ARG Gives the name of the argument to which we assign
+** the function symbol number of the term.
+**
** ARITY_ARG Gives the name of the argument to which we assign
** the arity of the term.
**
@@ -42,6 +45,13 @@
MR_expand_functor_only(type_info, &TERM_ARG, NONCANON, &expand_info);
MR_restore_transient_registers();
+#ifdef FUNCTOR_ARG
MR_deconstruct_get_functor(expand_info, functor_only, conststring_functor);
FUNCTOR_ARG = (MR_String) (MR_Integer) conststring_functor;
+#endif
MR_deconstruct_get_arity(expand_info, ARITY_ARG);
+
+#ifdef FUNCTOR_NUMBER_ARG
+ MR_deconstruct_get_functor_number(expand_info, FUNCTOR_NUMBER_ARG);
+#endif
+
Index: runtime/mercury_type_info.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_type_info.h,v
retrieving revision 1.122
diff -u -u -r1.122 mercury_type_info.h
--- runtime/mercury_type_info.h 11 Dec 2006 03:03:14 -0000 1.122
+++ runtime/mercury_type_info.h 26 Dec 2006 11:22:43 -0000
@@ -75,7 +75,7 @@
** compiler/type_ctor_info.m and with MR_RTTI_VERSION in mercury_mcpp.h.
*/
-#define MR_RTTI_VERSION MR_RTTI_VERSION__DUMMY
+#define MR_RTTI_VERSION MR_RTTI_VERSION__FUNCTOR_NUMBERS
#define MR_RTTI_VERSION__INITIAL 2
#define MR_RTTI_VERSION__USEREQ 3
#define MR_RTTI_VERSION__CLEAN_LAYOUT 4
@@ -86,6 +86,7 @@
#define MR_RTTI_VERSION__STABLE_FOREIGN 9
#define MR_RTTI_VERSION__TYPE_INFO_ZERO 10
#define MR_RTTI_VERSION__DUMMY 11
+#define MR_RTTI_VERSION__FUNCTOR_NUMBERS 12
/*
** Check that the RTTI version is in a sensible range.
@@ -101,7 +102,7 @@
*/
#define MR_TYPE_CTOR_INFO_CHECK_RTTI_VERSION_RANGE(typector) \
- assert(typector->MR_type_ctor_version == MR_RTTI_VERSION__DUMMY)
+ assert((typector)->MR_type_ctor_version == MR_RTTI_VERSION__FUNCTOR_NUMBERS)
/*---------------------------------------------------------------------------*/
@@ -1149,6 +1150,12 @@
MR_NotagFunctorDesc *MR_functors_notag;
} MR_TypeFunctors;
+/*
+** Map from ordinal (declaration order) functor numbers to lexicographic
+** functor numbers which can be passed to construct.construct.
+*/
+typedef const MR_Integer * MR_FunctorNumberMap;
+
/*---------------------------------------------------------------------------*/
/*
@@ -1174,6 +1181,7 @@
MR_TypeLayout MR_type_ctor_layout;
MR_int_least32_t MR_type_ctor_num_functors;
MR_int_least16_t MR_type_ctor_flags;
+ MR_FunctorNumberMap MR_type_ctor_functor_number_map;
/*
** The following fields will be added later, once we can exploit them:
@@ -1367,10 +1375,10 @@
#endif /* MR_HIGHLEVEL_CODE */
-#define MR_DEFINE_TYPE_CTOR_INFO_BODY_FLAG(m, n, a, cr, u, c, f) \
+#define MR_DEFINE_TYPE_CTOR_INFO_BODY_FLAG(m, n, a, cr, u, c, f, fns) \
{ \
a, \
- MR_RTTI_VERSION__FLAG, \
+ MR_RTTI_VERSION__FUNCTOR_NUMBERS, \
-1, \
MR_PASTE2(MR_TYPECTOR_REP_, cr), \
MR_DEFINE_TYPE_CTOR_INFO_CODE(u), \
@@ -1380,18 +1388,23 @@
{ 0 }, \
{ 0 }, \
-1, \
- f \
+ f, \
+ fns \
}
-#define MR_DEFINE_TYPE_CTOR_INFO_FULL_FLAG(m, n, a, cr, u, c, f) \
+#define MR_DEFINE_TYPE_CTOR_INFO_FULL_FLAG(m, n, a, cr, u, c, f, fns) \
MR_DEFINE_TYPE_CTOR_INFO_DECLARE_ADDRS(u, c, a) \
MR_DEFINE_TYPE_CTOR_INFO_TYPE \
MR_TYPE_CTOR_INFO_NAME(m, n, a) = \
- MR_DEFINE_TYPE_CTOR_INFO_BODY_FLAG(m, n, a, cr, u, c, f)
+ MR_DEFINE_TYPE_CTOR_INFO_BODY_FLAG(m, n, a, cr, u, c, f, fns)
#define MR_DEFINE_TYPE_CTOR_INFO_FLAG(m, n, a, cr, f) \
MR_DEFINE_TYPE_CTOR_INFO_FULL_FLAG(m, n, a, cr, \
- MR_TYPE_UNIFY_FUNC(m, n, a), MR_TYPE_COMPARE_FUNC(m, n, a), f)
+ MR_TYPE_UNIFY_FUNC(m, n, a), MR_TYPE_COMPARE_FUNC(m, n, a), f, NULL)
+
+#define MR_DEFINE_TYPE_CTOR_INFO_FLAG_FUNCTORS(m, n, a, cr, f, fns) \
+ MR_DEFINE_TYPE_CTOR_INFO_FULL_FLAG(m, n, a, cr, \
+ MR_TYPE_UNIFY_FUNC(m, n, a), MR_TYPE_COMPARE_FUNC(m, n, a), f, fns)
#define MR_DEFAULT_TYPE_CTOR_INFO_FLAG 0
Index: tests/hard_coded/construct_test.exp
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/construct_test.exp,v
retrieving revision 1.4
diff -u -u -r1.4 construct_test.exp
--- tests/hard_coded/construct_test.exp 14 Dec 2004 01:07:29 -0000 1.4
+++ tests/hard_coded/construct_test.exp 28 Dec 2006 12:19:26 -0000
@@ -1,194 +1,182 @@
TESTING DISCRIMINATED UNIONS
3 functors in this type
-2 - two/0 []
-1 - three/0 []
-0 - one/0 []
+2 - two/0 [] ordinal: 1 lex: 2
+1 - three/0 [] ordinal: 2 lex: 1
+0 - one/0 [] ordinal: 0 lex: 0
3 functors in this type
-2 - two/0 []
-1 - three/0 []
-0 - one/0 []
+2 - two/0 [] ordinal: 1 lex: 2
+1 - three/0 [] ordinal: 2 lex: 1
+0 - one/0 [] ordinal: 0 lex: 0
3 functors in this type
-2 - two/0 []
-1 - three/0 []
-0 - one/0 []
+2 - two/0 [] ordinal: 1 lex: 2
+1 - three/0 [] ordinal: 2 lex: 1
+0 - one/0 [] ordinal: 0 lex: 0
2 functors in this type
-1 - banana/1 [banana_list]
-0 - apple/1 [apple_list]
+1 - banana/1 [banana_list] ordinal: 1 lex: 1
+0 - apple/1 [apple_list] ordinal: 0 lex: 0
2 functors in this type
-1 - banana/1 [banana_list]
-0 - apple/1 [apple_list]
+1 - banana/1 [banana_list] ordinal: 1 lex: 1
+0 - apple/1 [apple_list] ordinal: 0 lex: 0
11 functors in this type
-10 - zop/2 [_, _]
-9 - zoom/1 [_]
-8 - zip/2 [_, _]
-7 - zap/2 [_, _]
-6 - wombat/0 []
-5 - qux/1 [_]
-4 - quux/1 [_]
-3 - quuux/2 [_, _]
-2 - foo/0 []
-1 - bar/2 [_, _]
-0 - bar/1 [_]
+10 - zop/2 [_, _] ordinal: 10 lex: 10
+9 - zoom/1 [_] ordinal: 7 lex: 9
+8 - zip/2 [_, _] ordinal: 9 lex: 8
+7 - zap/2 [_, _] ordinal: 8 lex: 7
+6 - wombat/0 [] ordinal: 6 lex: 6
+5 - qux/1 [_] ordinal: 3 lex: 5
+4 - quux/1 [_] ordinal: 4 lex: 4
+3 - quuux/2 [_, _] ordinal: 5 lex: 3
+2 - foo/0 [] ordinal: 0 lex: 2
+1 - bar/2 [_, _] ordinal: 2 lex: 1
+0 - bar/1 [_] ordinal: 1 lex: 0
11 functors in this type
-10 - zop/2 [_, _]
-9 - zoom/1 [_]
-8 - zip/2 [_, _]
-7 - zap/2 [_, _]
-6 - wombat/0 []
-5 - qux/1 [_]
-4 - quux/1 [_]
-3 - quuux/2 [_, _]
-2 - foo/0 []
-1 - bar/2 [_, _]
-0 - bar/1 [_]
+10 - zop/2 [_, _] ordinal: 10 lex: 10
+9 - zoom/1 [_] ordinal: 7 lex: 9
+8 - zip/2 [_, _] ordinal: 9 lex: 8
+7 - zap/2 [_, _] ordinal: 8 lex: 7
+6 - wombat/0 [] ordinal: 6 lex: 6
+5 - qux/1 [_] ordinal: 3 lex: 5
+4 - quux/1 [_] ordinal: 4 lex: 4
+3 - quuux/2 [_, _] ordinal: 5 lex: 3
+2 - foo/0 [] ordinal: 0 lex: 2
+1 - bar/2 [_, _] ordinal: 2 lex: 1
+0 - bar/1 [_] ordinal: 1 lex: 0
11 functors in this type
-10 - zop/2 [_, _]
-9 - zoom/1 [_]
-8 - zip/2 [_, _]
-7 - zap/2 [_, _]
-6 - wombat/0 []
-5 - qux/1 [_]
-4 - quux/1 [_]
-3 - quuux/2 [_, _]
-2 - foo/0 []
-1 - bar/2 [_, _]
-0 - bar/1 [_]
+10 - zop/2 [_, _] ordinal: 10 lex: 10
+9 - zoom/1 [_] ordinal: 7 lex: 9
+8 - zip/2 [_, _] ordinal: 9 lex: 8
+7 - zap/2 [_, _] ordinal: 8 lex: 7
+6 - wombat/0 [] ordinal: 6 lex: 6
+5 - qux/1 [_] ordinal: 3 lex: 5
+4 - quux/1 [_] ordinal: 4 lex: 4
+3 - quuux/2 [_, _] ordinal: 5 lex: 3
+2 - foo/0 [] ordinal: 0 lex: 2
+1 - bar/2 [_, _] ordinal: 2 lex: 1
+0 - bar/1 [_] ordinal: 1 lex: 0
11 functors in this type
-10 - zop/2 [_, _]
-9 - zoom/1 [_]
-8 - zip/2 [_, _]
-7 - zap/2 [_, _]
-6 - wombat/0 []
-5 - qux/1 [_]
-4 - quux/1 [_]
-3 - quuux/2 [_, _]
-2 - foo/0 []
-1 - bar/2 [_, _]
-0 - bar/1 [_]
+10 - zop/2 [_, _] ordinal: 10 lex: 10
+9 - zoom/1 [_] ordinal: 7 lex: 9
+8 - zip/2 [_, _] ordinal: 9 lex: 8
+7 - zap/2 [_, _] ordinal: 8 lex: 7
+6 - wombat/0 [] ordinal: 6 lex: 6
+5 - qux/1 [_] ordinal: 3 lex: 5
+4 - quux/1 [_] ordinal: 4 lex: 4
+3 - quuux/2 [_, _] ordinal: 5 lex: 3
+2 - foo/0 [] ordinal: 0 lex: 2
+1 - bar/2 [_, _] ordinal: 2 lex: 1
+0 - bar/1 [_] ordinal: 1 lex: 0
11 functors in this type
-10 - zop/2 [_, _]
-9 - zoom/1 [_]
-8 - zip/2 [_, _]
-7 - zap/2 [_, _]
-6 - wombat/0 []
-5 - qux/1 [_]
-4 - quux/1 [_]
-3 - quuux/2 [_, _]
-2 - foo/0 []
-1 - bar/2 [_, _]
-0 - bar/1 [_]
+10 - zop/2 [_, _] ordinal: 10 lex: 10
+9 - zoom/1 [_] ordinal: 7 lex: 9
+8 - zip/2 [_, _] ordinal: 9 lex: 8
+7 - zap/2 [_, _] ordinal: 8 lex: 7
+6 - wombat/0 [] ordinal: 6 lex: 6
+5 - qux/1 [_] ordinal: 3 lex: 5
+4 - quux/1 [_] ordinal: 4 lex: 4
+3 - quuux/2 [_, _] ordinal: 5 lex: 3
+2 - foo/0 [] ordinal: 0 lex: 2
+1 - bar/2 [_, _] ordinal: 2 lex: 1
+0 - bar/1 [_] ordinal: 1 lex: 0
TESTING POLYMORPHISM
4 functors in this type
-3 - poly_two/1 [_]
-2 - poly_three/3 [_, poly3_field2, _]
-1 - poly_one/1 [_]
-0 - poly_four/2 [_, _]
+3 - poly_two/1 [_] ordinal: 1 lex: 3
+2 - poly_three/3 [_, poly3_field2, _] ordinal: 2 lex: 2
+1 - poly_one/1 [_] ordinal: 0 lex: 1
+0 - poly_four/2 [_, _] ordinal: 3 lex: 0
4 functors in this type
-3 - poly_two/1 [_]
-2 - poly_three/3 [_, poly3_field2, _]
-1 - poly_one/1 [_]
-0 - poly_four/2 [_, _]
+3 - poly_two/1 [_] ordinal: 1 lex: 3
+2 - poly_three/3 [_, poly3_field2, _] ordinal: 2 lex: 2
+1 - poly_one/1 [_] ordinal: 0 lex: 1
+0 - poly_four/2 [_, _] ordinal: 3 lex: 0
4 functors in this type
-3 - poly_two/1 [_]
-2 - poly_three/3 [_, poly3_field2, _]
-1 - poly_one/1 [_]
-0 - poly_four/2 [_, _]
+3 - poly_two/1 [_] ordinal: 1 lex: 3
+2 - poly_three/3 [_, poly3_field2, _] ordinal: 2 lex: 2
+1 - poly_one/1 [_] ordinal: 0 lex: 1
+0 - poly_four/2 [_, _] ordinal: 3 lex: 0
TESTING BUILTINS
--1 functors in this type
+no functors in this type
+no functors in this type
--1 functors in this type
+no functors in this type
+no functors in this type
--1 functors in this type
+no functors in this type
+no functors in this type
--1 functors in this type
+no functors in this type
+no functors in this type
--1 functors in this type
+no functors in this type
+no functors in this type
--1 functors in this type
-
-
--1 functors in this type
-
-
--1 functors in this type
-
-
--1 functors in this type
-
-
--1 functors in this type
-
-
--1 functors in this type
-
-
--1 functors in this type
+no functors in this type
+no functors in this type
1 functors in this type
-0 - {}/4 [_, _, _, _]
+0 - {}/4 [_, _, _, _] ordinal: 0 lex: 0
TESTING OTHER TYPES
1 functors in this type
-0 - var/1 [_]
+0 - var/1 [_] ordinal: 0 lex: 0
1 functors in this type
-0 - var_supply/1 [_]
+0 - var_supply/1 [_] ordinal: 0 lex: 0
1 functors in this type
-0 - var_supply/1 [_]
+0 - var_supply/1 [_] ordinal: 0 lex: 0
4 functors in this type
-3 - two/4 [_, _, _, _]
-2 - three/7 [_, _, _, _, _, _, _]
-1 - four/10 [_, _, _, _, _, _, _, _, _, _]
-0 - empty/0 []
+3 - two/4 [_, _, _, _] ordinal: 1 lex: 3
+2 - three/7 [_, _, _, _, _, _, _] ordinal: 2 lex: 2
+1 - four/10 [_, _, _, _, _, _, _, _, _, _] ordinal: 3 lex: 1
+0 - empty/0 [] ordinal: 0 lex: 0
1 functors in this type
-0 - qwerty/1 [qwerty_field]
+0 - qwerty/1 [qwerty_field] ordinal: 0 lex: 0
1 functors in this type
-0 - xyzzy/1 [f21name]
+0 - xyzzy/1 [f21name] ordinal: 0 lex: 0
About to construct three/0
Index: tests/hard_coded/construct_test.m
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/construct_test.m,v
retrieving revision 1.5
diff -u -u -r1.5 construct_test.m
--- tests/hard_coded/construct_test.m 29 Mar 2006 08:07:59 -0000 1.5
+++ tests/hard_coded/construct_test.m 28 Dec 2006 12:17:19 -0000
@@ -125,8 +125,11 @@
is det.
find_functor(TypeInfo, Functor, Arity, FunctorNumber) :-
- N = construct__num_functors(TypeInfo),
- find_functor2(TypeInfo, Functor, Arity, N, FunctorNumber).
+ ( N = construct__num_functors(TypeInfo) ->
+ find_functor2(TypeInfo, Functor, Arity, N, FunctorNumber)
+ ;
+ error("unable to find functor")
+ ).
:- pred find_functor2(type_desc__type_desc::in, string::in, int::in, int::in,
int::out) is det.
@@ -149,12 +152,15 @@
test_all(T, !IO) :-
TypeInfo = type_desc__type_of(T),
- N = construct__num_functors(TypeInfo),
- io__write_int(N, !IO),
- io__write_string(" functors in this type", !IO),
- io__nl(!IO),
- test_all_functors(TypeInfo, N, !IO),
- io__nl(!IO).
+ ( N = construct__num_functors(TypeInfo) ->
+ io__write_int(N, !IO),
+ io__write_string(" functors in this type", !IO),
+ io__nl(!IO),
+ test_all_functors(TypeInfo, N, !IO),
+ io__nl(!IO)
+ ;
+ io__write_string("no functors in this type\n", !IO)
+ ).
:- pred test_all_functors(type_desc__type_desc::in, int::in, io::di, io::uo)
is det.
@@ -173,6 +179,8 @@
test_nth_functor(TypeInfo, N, !IO) :-
io__write_int(N, !IO),
(
+ Ordinal = construct__get_functor_ordinal(TypeInfo, N),
+ Lex = construct__get_functor_lex(TypeInfo, Ordinal),
construct__get_functor_with_names(TypeInfo, N, Name, Arity,
_List, Names)
->
@@ -182,7 +190,12 @@
io__write_int(Arity, !IO),
io__write_string(" [", !IO),
io__write_list(Names, ", ", print_maybe_name, !IO),
- io__write_string("]\n", !IO)
+ io__write_string("] ", !IO),
+ io__write_string("ordinal: ", !IO),
+ io__write_int(Ordinal, !IO),
+ io__write_string(" lex: ", !IO),
+ io__write_int(Lex, !IO),
+ io__nl(!IO)
;
io__write_string(" failed ", !IO),
io__nl(!IO)
Index: tests/hard_coded/construct_test_exist.m
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/construct_test_exist.m,v
retrieving revision 1.2
diff -u -u -r1.2 construct_test_exist.m
--- tests/hard_coded/construct_test_exist.m 29 Mar 2006 08:07:59 -0000 1.2
+++ tests/hard_coded/construct_test_exist.m 27 Dec 2006 08:15:46 -0000
@@ -56,12 +56,15 @@
test_all(T, !IO) :-
TypeInfo = type_desc__type_of(T),
- N = construct__num_functors(TypeInfo),
- io__write_int(N, !IO),
- io__write_string(" functors in this type", !IO),
- io__nl(!IO),
- test_all_functors(TypeInfo, N, !IO),
- io__nl(!IO).
+ ( N = construct__num_functors(TypeInfo) ->
+ io__write_int(N, !IO),
+ io__write_string(" functors in this type", !IO),
+ io__nl(!IO),
+ test_all_functors(TypeInfo, N, !IO),
+ io__nl(!IO)
+ ;
+ io__write_string("no functors in this type\n", !IO)
+ ).
:- pred test_all_functors(type_desc__type_desc::in, int::in, io::di, io::uo)
is det.
Index: tests/hard_coded/expand.exp
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/expand.exp,v
retrieving revision 1.5
diff -u -u -r1.5 expand.exp
--- tests/hard_coded/expand.exp 13 Jan 2001 02:30:30 -0000 1.5
+++ tests/hard_coded/expand.exp 28 Dec 2006 12:07:48 -0000
@@ -1,138 +1,202 @@
TESTING DISCRIMINATED UNIONS
one/0
+0/0
no arguments
expand: functor one arity 0 arguments []
+expand: functor 0 arity 0 arguments []
two/0
+2/0
no arguments
expand: functor two arity 0 arguments []
+expand: functor 2 arity 0 arguments []
three/0
+1/0
no arguments
expand: functor three arity 0 arguments []
+expand: functor 1 arity 0 arguments []
apple/1
+0/1
argument 1 of functor apple was:[9, 5, 1]
expand: functor apple arity 1 arguments [[9, 5, 1]]
+expand: functor 0 arity 1 arguments [[9, 5, 1]]
banana/1
+1/1
argument 1 of functor banana was:[three, one, two]
expand: functor banana arity 1 arguments [[three, one, two]]
+expand: functor 1 arity 1 arguments [[three, one, two]]
zop/2
+10/2
argument 2 of functor zop was:2.03000000000000
expand: functor zop arity 2 arguments [3.30000000000000, 2.03000000000000]
+expand: functor 10 arity 2 arguments [3.30000000000000, 2.03000000000000]
zip/2
+8/2
argument 2 of functor zip was:2
expand: functor zip arity 2 arguments [3, 2]
+expand: functor 8 arity 2 arguments [3, 2]
zap/2
+7/2
argument 2 of functor zap was:-2.11100000000000
expand: functor zap arity 2 arguments [3, -2.11100000000000]
+expand: functor 7 arity 2 arguments [3, -2.11100000000000]
wombat/0
+6/0
no arguments
expand: functor wombat arity 0 arguments []
+expand: functor 6 arity 0 arguments []
foo/0
+2/0
no arguments
expand: functor foo arity 0 arguments []
+expand: functor 2 arity 0 arguments []
TESTING POLYMORPHISM
poly_two/1
+2/1
argument 1 of functor poly_two was:3
expand: functor poly_two arity 1 arguments [3]
+expand: functor 2 arity 1 arguments [3]
poly_three/3
+1/3
argument 3 of functor poly_three was:poly_one(9.11000000000000)
expand: functor poly_three arity 3 arguments [3.33000000000000, 4, poly_one(9.11000000000000)]
+expand: functor 1 arity 3 arguments [3.33000000000000, 4, poly_one(9.11000000000000)]
poly_one/1
+0/1
argument 1 of functor poly_one was:[2399.30000000000]
expand: functor poly_one arity 1 arguments [[2399.30000000000]]
+expand: functor 0 arity 1 arguments [[2399.30000000000]]
TESTING BUILTINS
""/0
+functor_number_cc failed
no arguments
expand: functor "" arity 0 arguments []
+deconstruct_du failed
"Hello, world
"/0
+functor_number_cc failed
no arguments
expand: functor "Hello, world
" arity 0 arguments []
+deconstruct_du failed
"Foo%sFoo"/0
+functor_number_cc failed
no arguments
expand: functor "Foo%sFoo" arity 0 arguments []
+deconstruct_du failed
"""/0
+functor_number_cc failed
no arguments
expand: functor """ arity 0 arguments []
+deconstruct_du failed
'a'/0
+functor_number_cc failed
no arguments
expand: functor 'a' arity 0 arguments []
+deconstruct_du failed
'&'/0
+functor_number_cc failed
no arguments
expand: functor '&' arity 0 arguments []
+deconstruct_du failed
3.14159000000000/0
+functor_number_cc failed
no arguments
expand: functor 3.14159000000000 arity 0 arguments []
+deconstruct_du failed
1.12832498300000e-21/0
+functor_number_cc failed
no arguments
expand: functor 1.12832498300000e-21 arity 0 arguments []
+deconstruct_du failed
2.23954899000000e+23/0
+functor_number_cc failed
no arguments
expand: functor 2.23954899000000e+23 arity 0 arguments []
+deconstruct_du failed
-65/0
+functor_number_cc failed
no arguments
expand: functor -65 arity 0 arguments []
+deconstruct_du failed
4/0
+functor_number_cc failed
no arguments
expand: functor 4 arity 0 arguments []
+deconstruct_du failed
univ_cons/1
+0/1
argument 1 of functor univ_cons was:["hi! I\'m a univ!"]
expand: functor univ_cons arity 1 arguments [["hi! I\'m a univ!"]]
+expand: functor 0 arity 1 arguments [["hi! I\'m a univ!"]]
<<predicate>>/0
+functor_number_cc failed
no arguments
expand: functor <<predicate>> arity 0 arguments []
+deconstruct_du failed
{}/4
+0/4
argument 4 of functor {} was:{1, 2, 3, 4}
expand: functor {} arity 4 arguments [1, 'b', "third", {1, 2, 3, 4}]
+expand: functor 0 arity 4 arguments [1, 'b', "third", {1, 2, 3, 4}]
TESTING OTHER TYPES
var/1
+0/1
argument 1 of functor var was:1
expand: functor var arity 1 arguments [1]
+expand: functor 0 arity 1 arguments [1]
var_supply/1
+0/1
argument 1 of functor var_supply was:0
expand: functor var_supply arity 1 arguments [0]
+expand: functor 0 arity 1 arguments [0]
var_supply/1
+0/1
argument 1 of functor var_supply was:1
expand: functor var_supply arity 1 arguments [1]
+expand: functor 0 arity 1 arguments [1]
empty/0
+0/0
no arguments
expand: functor empty arity 0 arguments []
+expand: functor 0 arity 0 arguments []
qwerty/1
+0/1
argument 1 of functor qwerty was:4
expand: functor qwerty arity 1 arguments [4]
+expand: functor 0 arity 1 arguments [4]
Index: tests/hard_coded/expand.exp2
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/expand.exp2,v
retrieving revision 1.2
diff -u -u -r1.2 expand.exp2
--- tests/hard_coded/expand.exp2 17 Jan 2003 05:57:05 -0000 1.2
+++ tests/hard_coded/expand.exp2 28 Dec 2006 12:11:53 -0000
@@ -1,138 +1,202 @@
TESTING DISCRIMINATED UNIONS
one/0
+0/0
no arguments
expand: functor one arity 0 arguments []
+expand: functor 0 arity 0 arguments []
two/0
+2/0
no arguments
expand: functor two arity 0 arguments []
+expand: functor 2 arity 0 arguments []
three/0
+1/0
no arguments
expand: functor three arity 0 arguments []
+expand: functor 1 arity 0 arguments []
apple/1
+0/1
argument 1 of functor apple was:[9, 5, 1]
expand: functor apple arity 1 arguments [[9, 5, 1]]
+expand: functor 0 arity 1 arguments [[9, 5, 1]]
banana/1
+1/1
argument 1 of functor banana was:[three, one, two]
expand: functor banana arity 1 arguments [[three, one, two]]
+expand: functor 1 arity 1 arguments [[three, one, two]]
zop/2
+10/2
argument 2 of functor zop was:2.03000000000000
expand: functor zop arity 2 arguments [3.30000000000000, 2.03000000000000]
+expand: functor 10 arity 2 arguments [3.30000000000000, 2.03000000000000]
zip/2
+8/2
argument 2 of functor zip was:2
expand: functor zip arity 2 arguments [3, 2]
+expand: functor 8 arity 2 arguments [3, 2]
zap/2
+7/2
argument 2 of functor zap was:-2.11100000000000
expand: functor zap arity 2 arguments [3, -2.11100000000000]
+expand: functor 7 arity 2 arguments [3, -2.11100000000000]
wombat/0
+6/0
no arguments
expand: functor wombat arity 0 arguments []
+expand: functor 6 arity 0 arguments []
foo/0
+2/0
no arguments
expand: functor foo arity 0 arguments []
+expand: functor 2 arity 0 arguments []
TESTING POLYMORPHISM
poly_two/1
+2/1
argument 1 of functor poly_two was:3
expand: functor poly_two arity 1 arguments [3]
+expand: functor 2 arity 1 arguments [3]
poly_three/3
-argument 3 of functor poly_three was.poly_one(9.11000000000000)
+1/3
+argument 3 of functor poly_three was:poly_one(9.11000000000000)
expand: functor poly_three arity 3 arguments [3.33000000000000, 4, poly_one(9.11000000000000)]
+expand: functor 1 arity 3 arguments [3.33000000000000, 4, poly_one(9.11000000000000)]
poly_one/1
+0/1
argument 1 of functor poly_one was:[2399.30000000000]
expand: functor poly_one arity 1 arguments [[2399.30000000000]]
+expand: functor 0 arity 1 arguments [[2399.30000000000]]
TESTING BUILTINS
""/0
+functor_number_cc failed
no arguments
expand: functor "" arity 0 arguments []
+deconstruct_du failed
"Hello, world
"/0
+functor_number_cc failed
no arguments
expand: functor "Hello, world
" arity 0 arguments []
+deconstruct_du failed
"Foo%sFoo"/0
+functor_number_cc failed
no arguments
expand: functor "Foo%sFoo" arity 0 arguments []
+deconstruct_du failed
"""/0
+functor_number_cc failed
no arguments
expand: functor """ arity 0 arguments []
+deconstruct_du failed
'a'/0
+functor_number_cc failed
no arguments
expand: functor 'a' arity 0 arguments []
+deconstruct_du failed
'&'/0
+functor_number_cc failed
no arguments
expand: functor '&' arity 0 arguments []
+deconstruct_du failed
3.14159000000000/0
+functor_number_cc failed
no arguments
expand: functor 3.14159000000000 arity 0 arguments []
+deconstruct_du failed
1.12832498300000e-021/0
+functor_number_cc failed
no arguments
expand: functor 1.12832498300000e-021 arity 0 arguments []
+deconstruct_du failed
2.23954899000000e+023/0
+functor_number_cc failed
no arguments
expand: functor 2.23954899000000e+023 arity 0 arguments []
+deconstruct_du failed
-65/0
+functor_number_cc failed
no arguments
expand: functor -65 arity 0 arguments []
+deconstruct_du failed
4/0
+functor_number_cc failed
no arguments
expand: functor 4 arity 0 arguments []
+deconstruct_du failed
univ_cons/1
+0/1
argument 1 of functor univ_cons was:["hi! I\'m a univ!"]
expand: functor univ_cons arity 1 arguments [["hi! I\'m a univ!"]]
+expand: functor 0 arity 1 arguments [["hi! I\'m a univ!"]]
<<predicate>>/0
+functor_number_cc failed
no arguments
expand: functor <<predicate>> arity 0 arguments []
+deconstruct_du failed
{}/4
+0/4
argument 4 of functor {} was:{1, 2, 3, 4}
expand: functor {} arity 4 arguments [1, 'b', "third", {1, 2, 3, 4}]
+expand: functor 0 arity 4 arguments [1, 'b', "third", {1, 2, 3, 4}]
TESTING OTHER TYPES
var/1
+0/1
argument 1 of functor var was:1
expand: functor var arity 1 arguments [1]
+expand: functor 0 arity 1 arguments [1]
var_supply/1
+0/1
argument 1 of functor var_supply was:0
expand: functor var_supply arity 1 arguments [0]
+expand: functor 0 arity 1 arguments [0]
var_supply/1
+0/1
argument 1 of functor var_supply was:1
expand: functor var_supply arity 1 arguments [1]
+expand: functor 0 arity 1 arguments [1]
empty/0
+0/0
no arguments
expand: functor empty arity 0 arguments []
+expand: functor 0 arity 0 arguments []
qwerty/1
+0/1
argument 1 of functor qwerty was:4
expand: functor qwerty arity 1 arguments [4]
+expand: functor 0 arity 1 arguments [4]
Index: tests/hard_coded/expand.m
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/expand.m,v
retrieving revision 1.8
diff -u -u -r1.8 expand.m
--- tests/hard_coded/expand.m 29 Mar 2006 08:08:00 -0000 1.8
+++ tests/hard_coded/expand.m 28 Dec 2006 12:04:16 -0000
@@ -6,7 +6,7 @@
:- interface.
:- import_module io.
-:- pred main(io::di, io::uo) is det.
+:- pred main(io::di, io::uo) is cc_multi.
:- implementation.
@@ -19,15 +19,17 @@
:- import_module term.
:- import_module univ.
-:- pred test_builtins(io::di, io::uo) is det.
-:- pred test_discriminated(io::di, io::uo) is det.
-:- pred test_polymorphism(io::di, io::uo) is det.
-:- pred test_other(io::di, io::uo) is det.
+:- pred test_builtins(io::di, io::uo) is cc_multi.
+:- pred test_discriminated(io::di, io::uo) is cc_multi.
+:- pred test_polymorphism(io::di, io::uo) is cc_multi.
+:- pred test_other(io::di, io::uo) is cc_multi.
:- pred newline(io::di, io::uo) is det.
:- pred test_functor(T::in, io::di, io::uo) is det.
+:- pred test_functor_number(T::in, io::di, io::uo) is cc_multi.
:- pred test_arg(T::in, io::di, io::uo) is det.
:- pred test_expand(T::in, io::di, io::uo) is det.
-:- pred test_all(T::in, io::di, io::uo) is det.
+:- pred test_expand_du(T::in, io::di, io::uo) is cc_multi.
+:- pred test_all(T::in, io::di, io::uo) is cc_multi.
:- type enum
---> one
@@ -91,8 +93,10 @@
test_all(T) -->
test_functor(T), newline,
+ test_functor_number(T), newline,
test_arg(T), newline,
- test_expand(T), newline.
+ test_expand(T), newline,
+ test_expand_du(T), newline.
test_functor(T) -->
{ functor(T, canonicalize, Functor, Arity) },
@@ -100,6 +104,15 @@
io.write_string("/"),
io.write_int(Arity).
+test_functor_number(T) -->
+ ( { functor_number_cc(T, FunctorNumber, Arity) } ->
+ io.write_int(FunctorNumber),
+ io.write_string("/"),
+ io.write_int(Arity)
+ ;
+ io.write_string("functor_number_cc failed")
+ ).
+
test_arg(T) -->
{ functor(T, canonicalize, Functor, Arity) },
(
@@ -122,6 +135,21 @@
io.write_list(Arguments, ", ", io.print),
io.write_string("]").
+test_expand_du(T) -->
+ (
+ { deconstruct_du(T, include_details_cc, FunctorNumber,
+ Arity, Arguments) }
+ ->
+ { string.format("expand: functor %d arity %d arguments ",
+ [i(FunctorNumber), i(Arity)], Str) },
+ io.write_string(Str),
+ io.write_string("["),
+ io.write_list(Arguments, ", ", io.print),
+ io.write_string("]")
+ ;
+ io.write_string("deconstruct_du failed")
+ ).
+
test_polymorphism -->
io.write_string("TESTING POLYMORPHISM\n"),
test_all(poly_two(3)), newline,
--------------------------------------------------------------------------
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