[m-rev.] for review: foreign enumerations
Julien Fischer
juliensf at csse.unimelb.edu.au
Thu Aug 9 18:28:50 AEST 2007
The changes to RTTI and tabling are for review by Zoltan.
The rest is for review by anyone.
Estimated hours taken: 50
Branches: main
Add support for foreign enumerations to Mercury. These allow the
programmer to assign foreign language values as the representation of
enumeration constructors.
e.g.
:- type status
---> optimal
; infeasible
; unbounded
; unknown.
:- pragma foreign_enum("C", status/0, [
optimal - "STATUS_OPTIMAL",
infeasible - "STATUS_INFEASIBLE",
unbounded - "STATUS_UNBOUNDED",
unknown - "STATUS_UNKNOWN"
]).
The advantage of this is that when values of type status/0 are passed to
foreign code (C in this case) no translation is necessary. This should
simplify the task of writing bindings to foreign language libraries.
Unification and comparison for foreign enumerations are the usual
unification and comparison for enumeration types, except that the default
ordering on them is determined by the foreign representation of the
constructors. User-defined equality and comparison work also work.
on foreign enumeration types.
In order to implement foreign enumerations we have to introduce two
new type_ctor representations. The existing ones for enum type do not
work since they use the value of an enumeration constructor to perform
table lookups in the RTTI data structures. For foreign enumerations
we need to perform a linear search at the corresponding points. This
means that some RTTI operations related to deconstruction are more
expensive.
The dummy type optimisation is not applied to foreign enumerations as
the code generators currently initialise the arguments of non-builtin
dummy type foreign_proc arguments to zero. For unit foreign enumerations
they should be initialised to the correct foreign value. (This is could be
implemented but in practice it's probably not going to be worth it.)
Currently, foreign enumerations are only supported by the C backends.
compiler/prog_io_pragma.m:
Parse foreign_enum pragmas.
Generalise the code used to parse association lists of sym_names
and strings since this is now used by the code to parse foreign_enum
pragmas as well as that for foreign_export_enum pragmas.
Fix a typo: s/foreign_expor_enum/foreign_export_enum/
compiler/prog_item.m:
Represent foreign_enum pragmas in the parse tree.
compiler/prog_type.m:
Add a new type category for foreign enumerations.
compiler/modules.m:
Add any foreign_enum pragmas for enumeration types defined in the
interface of a module to the interface files.
Output foreign_import_module pragmas in the interface file
if any foreign_enum pragmas are included in it. This ensures that
the contents that any foreign declarations that are needed by the
foreign_enum pragmas are visible.
compiler/make_hlds_passes.m:
compiler/add_pragma.m:
Add pragma foreign_enum items to the HLDS after all the types
have been added. As they are added, error check them.
Change the constructor tag values of foreign enum types to their
foreign values.
compiler/module_qual.m:
Module qualify pragma foreign_enum items.
compiler/mercury_to_mercury.m:
Output foreign_enum pragmas.
Generalise some of the existing code for writing out association
lists in foreign_export_enum pragmas for use with foreign_enum
pragmas as well.
compiler/hlds_data.m:
Add the alternative `is_foreign_type' to the type enum_or_dummy/0.
Add new type of cons_tag, foreign_tag, whose values are directly
embedded in the target language.
compiler/intermod.m:
Write out any foreign_enum pragmas for opt_exported types.
(The XXX concerning attaching language information to foreign tags
will be addressed in a subsequent change.)
compiler/llds.m:
compiler/mlds.m:
Support new kinds of rval constants: llconst_foreign and
mlconst_foreign respectively. Both of these represent tag values
as strings that are intended to be directly embedded in the target
language.
compiler/llds_out.m:
Add code to write out the new kind of rval_const.
s/Integer/MR_Integer/ in a spot.
s/Float/MR_Float/ in a spot.
compiler/rtti.m:
compiler/rtti_out.m:
compiler/rtti_to_mlds.m:
compiler/type_ctor_info.m:
Add support the RTTI required by foreign enums.
compiler/switch_util.m:
Handle switches on foreign_enums as-per normal enumerations.
compiler/table_gen.m:
Tabling of foreign_enums is also like normal enumerations.
compiler/type_util.m:
Add a predicate that tests whether a type is a foreign enumeration.
compiler/unify_gen.m:
compiler/unify_proc.m:
compiler/ml_unify_gen.m:
Handle unification and comparison of foreign enumeration values.
They are treated like normal enumerations for the purposes of
implementing these operations.
compiler/ml_type_gen.m:
Handle foreign enumerations when generating the MLDS representation
of enumerations.
compiler/ml_util.m:
Add a function to create an initializer for an object with a
foreign tag.
compiler/mlds_to_c.m:
Handle mlconst_foreign/1 rval constants.
compiler/bytecode_gen.m:
compiler/dupproc.m:
compiler/erl_rtti.m:
compiler/exception_analysis.m:
compiler/export.m:
compiler/exprn_aux.m:
compiler/global_data.m:
compiler/hlds_out.m:
compiler/higher_order.m:
compiler/inst_match.m:
compiler/jumpopt.m:
compiler/llds_to_x86_64.m:
compiler/ml_code_util.m:
compiler/mlds_to_gcc.m:
compiler/mlds_to_il.m:
compiler/mlds_to_java.m:
compiler/mlds_to_managed.m:
compiler/opt_debug.m:
compiler/opt_util.m:
compiler/polymorphism.m:
compiler/recompilation.version.m:
compiler/term_norm.m:
compiler/trailing_analysis.m:
Conform to the above changes.
doc/reference_manual.texi:
Document the new pragma.
Fix some typos: s/pramga/pragma/, s/behavior/behaviour/
library/construct.m:
Handle the two new type_ctor reps.
Break an over-long line.
library/rtti_implementation.m:
Support the two new type_ctor reps.
(XXX The Java versions of some of this cannot be implemented until
support for foreign enumerations is added to mlds_to_java.m.)
Reformat the inst usereq/0 and extend it to include foreign enums.
runtime/mercury_type_info.h:
Add two new type_ctor reps. One for foreign enumerations and
another for foreign enumerations with user equality.
Define new types (and extend existing ones) in order to support
RTTI for foreign enumerations.
runtime/mercury_unify_compare_body.h:
Implement generic unify and compare for foreign enumerations.
(It is the same as that for regular enumerations.)
runtime/mercury_construct.[ch]:
runtime/mercury_deconstruct.h:
Handle (de)construction of foreign enumeration values.
runtime/mercury_deep_copy_body.h:
Implement deep copy for foreign enumerations.
runtime/mercury_table_type_body.h:
runtime/mercury_term_size.c:
Handle the new type_ctor representations.
java/runtime/ForeignEnumFunctorDesc.java:
Add a Java version of the MR_ForeignEnumFuntorDesc structure.
(Note: this is untested, as the java grade runtime doesn't work
anyway.)
java/runtime/TypeFunctors.java:
Add a constructor method for foreign enumerations.
(Likewise, untested.)
NEWS:
Announce pragma foreign_enum.
vim/syntax/mercury.vim:
Highlight the new pragma appropriately.
tests/hard_coded/.cvsignore:
Ignore executables generated by the new tests.
Ignore a bunch of other files create by the Mercury compiler.
tests/hard_coded/Mmakefile:
tests/hard_coded/foreign_enum_rtti.{m,exp}:
Test RTTI for foreign enumerations.
tests/hard_coded/foreign_enum_dummy.{m,exp}:
Check that dummy type optimisation is disabled for foreign
enumerations.
tests/hard_coded/Mercury.options:
tests/hard_coded/foreign_enum_mod1.{m,exp}:
tests/hard_coded/foreign_enum_mod2.m:
Test that foreign_enum pragmas are hoisted into interface files
and that they are handled correctly in optimization interfaces.
tests/invalid/Mercury.options:
tests/invalid/Mmakefile:
tests/invalid/foreign_enum_import.{m,err_exp}:
tests/invalid/foreign_enum_invalid.{m,err_exp}:
Test that errors in foreign_enum pragmas are reported.
tests/tabling/Mmakefile:
tests/hard_coded/table_foreign_enum.{m,exp}:
Test case for tabling of foreign enumerations.
Julien.
Index: NEWS
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/NEWS,v
retrieving revision 1.474
diff -u -r1.474 NEWS
--- NEWS 3 Aug 2007 05:18:37 -0000 1.474
+++ NEWS 9 Aug 2007 08:26:44 -0000
@@ -3,8 +3,10 @@
Changes to the Mercury language:
+* A new pragma, foreign_enum, allows the constructors of Mercury
+ enumeration types to be assigned values from foreign language code.
* A new pragma, foreign_export_enum, allows the constructors of Mercury
- enumeration types, to be referred to in foreign language code.
+ enumeration types to be referred to in foreign language code.
* Some of the restrictions on typeclass instances have been relaxed, allowing
support for polymorphic instances with functional dependencies.
* We now support trace goals, which can be used to print progress messages or
@@ -243,6 +245,27 @@
Changes to the Mercury language:
+* The new pragma, foreign_enum, can be used to establish a
+ mapping between values in a foreign language and the constructors
+ of a Mercury enumeration type. This can be useful when writing
+ Mercury bindings to foreign code libraries.
+
+ For example,
+
+ :- type matrix_mode
+ ---> texture
+ ; modelview
+ ; projection.
+
+ :- pragma foreign_enum("C", matrix_mode/0, [
+ texture - "GL_TEXTURE"
+ modelview - "GL_MODELVIEW"
+ projection - "GL_PROJECTION"
+ ]).
+
+ When passed to C foreign clauses values of type matrix_mode/0 will have
+ the corresponding C value specified by the foreign_enum pragma.
+
* The new pragma, foreign_export_enum, can be used to establish a
mapping between the constructors of a Mercury enumeration type and
a symbolic name for values of that type in the foreign language.
Index: compiler/add_pragma.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_pragma.m,v
retrieving revision 1.68
diff -u -r1.68 add_pragma.m
--- compiler/add_pragma.m 1 Aug 2007 07:23:28 -0000 1.68
+++ compiler/add_pragma.m 9 Aug 2007 08:26:44 -0000
@@ -42,6 +42,11 @@
import_status::in, prog_context::in, module_info::in, module_info::out,
list(error_spec)::in, list(error_spec)::out) is det.
+:- pred add_pragma_foreign_enum(foreign_language::in, sym_name::in,
+ arity::in, assoc_list(sym_name, string)::in, import_status::in,
+ prog_context::in, module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
+
:- pred add_pragma_type_spec(pragma_type::in(pragma_type_spec),
term.context::in, module_info::in, module_info::out,
qual_info::in, qual_info::out,
@@ -230,6 +235,9 @@
% types).
Pragma = pragma_foreign_export_enum(_, _, _, _, _)
;
+ % Likewise for pragma foreign_enum.
+ Pragma = pragma_foreign_enum(_, _, _, _)
+ ;
% Handle pragma tabled decls later on (when we process clauses).
Pragma = pragma_tabled(_, _, _, _, _, _)
;
@@ -605,7 +613,7 @@
sym_name_and_arity(TypeName / TypeArity), suffix(":"), nl
],
(
- % Emit an error message for foreign_export_num pragmas for the
+ % Emit an error message for foreign_export_enum pragmas for the
% builtin atomic types.
TypeArity = 0,
( TypeName = unqualified("character")
@@ -631,7 +639,7 @@
; TypeBody = hlds_foreign_type(_)
),
MaybeSeverity = yes(severity_error),
- ErrorPieces = [
+ ErrorPieces = [
words("error: "),
sym_name_and_arity(TypeName / TypeArity),
words("is not an enumeration type"),
@@ -643,6 +651,7 @@
_MaybeUserEq, _ReservedTag, _IsForeignType),
(
( IsEnumOrDummy = is_enum
+ ; IsEnumOrDummy = is_foreign_enum
; IsEnumOrDummy = is_dummy
),
Attributes = export_enum_attributes(MaybePrefix),
@@ -656,9 +665,9 @@
ContextPieces, Overrides, MaybeOverridesMap, !Specs),
(
MaybeOverridesMap = yes(OverridesMap),
- build_export_enum_name_map(ContextPieces, Lang, TypeName,
- TypeArity, Context, Prefix, OverridesMap, Ctors,
- MaybeMapping, !Specs),
+ build_export_enum_name_map(ContextPieces, Lang,
+ TypeName, TypeArity, Context, Prefix,
+ OverridesMap, Ctors, MaybeMapping, !Specs),
(
MaybeMapping = yes(Mapping),
ExportedEnum = exported_enum_info(Lang, Context,
@@ -774,7 +783,6 @@
Context, Prefix, Overrides0, Ctors, MaybeMapping, !Specs) :-
(
TypeName = qualified(TypeModuleQual, _)
-
;
% The type name should have been module qualified by now.
TypeName = unqualified(_),
@@ -877,7 +885,6 @@
( bimap.from_assoc_list(NamesAndForeignNames, _) ->
MaybeNameMap = yes(NameMap)
;
-
MaybeNameMap = no,
% XXX we should report exactly why it is not bijective.
ErrorPieces = [
@@ -945,6 +952,325 @@
%-----------------------------------------------------------------------------%
+add_pragma_foreign_enum(Lang, TypeName, TypeArity, ForeignTagValues,
+ ImportStatus, Context, !ModuleInfo, !Specs) :-
+ TypeCtor = type_ctor(TypeName, TypeArity),
+ module_info_get_type_table(!.ModuleInfo, TypeTable0),
+ ContextPieces = [
+ words("In"), fixed("`pragma foreign_enum'"),
+ words("declaration for"),
+ sym_name_and_arity(TypeName / TypeArity), suffix(":"), nl
+ ],
+ (
+ % Emit an error message for foreign_enum pragmas for the
+ % builtin atomic types.
+ TypeArity = 0,
+ ( TypeName = unqualified("character")
+ ; TypeName = unqualified("float")
+ ; TypeName = unqualified("int")
+ ; TypeName = unqualified("string")
+ )
+ ->
+ MaybeSeverity = yes(severity_error),
+ ErrorPieces = [
+ words("error: "),
+ sym_name_and_arity(TypeName / TypeArity),
+ words("is an atomic type"),
+ suffix(".")
+ ]
+ ; map.search(TypeTable0, TypeCtor, TypeDefn0) ->
+ get_type_defn_body(TypeDefn0, TypeBody0),
+ (
+ ( TypeBody0 = hlds_eqv_type(_)
+ ; TypeBody0 = hlds_abstract_type(_)
+ ; TypeBody0 = hlds_solver_type(_, _)
+ ; TypeBody0 = hlds_foreign_type(_)
+ ),
+ MaybeSeverity = yes(severity_error),
+ ErrorPieces = [
+ words("error: "),
+ sym_name_and_arity(TypeName / TypeArity),
+ words("is not an enumeration type"),
+ suffix(".")
+ ]
+ ;
+ TypeBody0 = hlds_du_type(Ctors, OldTagValues, IsEnumOrDummy0,
+ MaybeUserEq, ReservedTag, IsForeignType),
+ %
+ % Work out what language's foreign_enum pragma we should be
+ % looking at for the the current compilation target language.
+ %
+ module_info_get_globals(!.ModuleInfo, Globals),
+ globals.get_target(Globals, TargetLanguage),
+ LangForForeignEnums =
+ target_lang_to_foreign_enum_lang(TargetLanguage),
+ (
+ ( IsEnumOrDummy0 = is_dummy
+ ; IsEnumOrDummy0 = is_enum
+ ),
+ get_type_defn_status(TypeDefn0, TypeStatus),
+ % Either both the type and the pragma are defined in this
+ % module or they are both imported. Any other combination
+ % is illegal.
+ IsTypeLocal = status_defined_in_this_module(TypeStatus),
+ (
+ (
+ IsTypeLocal = yes,
+ ( ImportStatus = status_local
+ ; ImportStatus = status_exported_to_submodules
+ )
+ ;
+ IsTypeLocal = no,
+ status_is_imported(ImportStatus) = yes
+ )
+ ->
+ % XXX We should also check that this type is not
+ % the subject of a reserved tag pragma.
+ IsEnumOrDummy = is_foreign_enum,
+ build_foreign_enum_tag_map(Context, ContextPieces,
+ TypeName, ForeignTagValues, MaybeForeignTagMap,
+ !Specs),
+ (
+ LangForForeignEnums = Lang,
+ MaybeForeignTagMap = yes(ForeignTagMap)
+ ->
+ map.foldl2(make_foreign_tag(ForeignTagMap),
+ OldTagValues, map.init, TagValues, [],
+ UnmappedCtors),
+ (
+ UnmappedCtors = [],
+ TypeBody = hlds_du_type(Ctors, TagValues,
+ IsEnumOrDummy, MaybeUserEq, ReservedTag,
+ IsForeignType),
+ set_type_defn_body(TypeBody, TypeDefn0,
+ TypeDefn),
+ svmap.set(TypeCtor, TypeDefn, TypeTable0,
+ TypeTable),
+ module_info_set_type_table(TypeTable,
+ !ModuleInfo)
+ ;
+ UnmappedCtors = [_ | _],
+ add_foreign_enum_unmapped_ctors_error(Context,
+ ContextPieces, UnmappedCtors, !Specs)
+ )
+ ;
+ % If there are no matching foreign_enum pragmas for
+ % this target language then don't do anything.
+ true
+ ),
+ MaybeSeverity = no,
+ ErrorPieces = []
+ ;
+ ImportStatus = status_exported
+ ->
+ add_foreign_enum_pragma_in_interface_error(Context,
+ TypeName, TypeArity, !Specs),
+ MaybeSeverity = no,
+ ErrorPieces = []
+ ;
+ MaybeSeverity = yes(severity_error),
+ ErrorPieces = [
+ words("error: "),
+ sym_name_and_arity(TypeName / TypeArity),
+ words("is not defined in this module.")
+ ]
+ )
+ ;
+ IsEnumOrDummy0 = is_foreign_enum,
+ ( LangForForeignEnums \= Lang ->
+ MaybeSeverity = no,
+ ErrorPieces = []
+ ;
+ MaybeSeverity = yes(severity_error),
+ ErrorPieces = [
+ words("error: "),
+ sym_name_and_arity(TypeName / TypeArity),
+ words("has multiple foreign_enum pragmas.")
+ ]
+ )
+ ;
+ IsEnumOrDummy0 = not_enum_or_dummy,
+ MaybeSeverity = yes(severity_error),
+ ErrorPieces = [
+ words("error: "),
+ sym_name_and_arity(TypeName / TypeArity),
+ words("is not an enumeration type"),
+ suffix(".")
+ ]
+ )
+ )
+ ;
+ % This else-branch corresponds to an undefined type. We do not
+ % issue an error message for it here since module qualification
+ % will have already done so.
+ MaybeSeverity = no,
+ ErrorPieces = []
+ ),
+ (
+ ErrorPieces = []
+ ;
+ ErrorPieces = [_ | _],
+ (
+ MaybeSeverity = yes(Severity)
+ ;
+ MaybeSeverity = no,
+ unexpected(this_file, "add_foreign_enum: no severity")
+ ),
+ Msg = simple_msg(Context, [always(ContextPieces ++ ErrorPieces)]),
+ Spec = error_spec(Severity, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
+ ).
+
+:- pred build_foreign_enum_tag_map(prog_context::in, format_components::in,
+ sym_name::in, assoc_list(sym_name, string)::in,
+ maybe(map(sym_name, string))::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
+
+build_foreign_enum_tag_map(Context, ContextPieces, TypeName, ForeignTagValues0,
+ MaybeForeignTagMap, !Specs) :-
+ ( sym_name_get_module_name(TypeName, TypeModuleName0) ->
+ TypeModuleName = TypeModuleName0
+ ;
+ unexpected(this_file,
+ "unqualified type name while processing foreign tags.")
+ ),
+ list.map_foldl(fixup_foreign_tag_val_qualification(TypeModuleName),
+ ForeignTagValues0, ForeignTagValues1, [], BadCtors),
+ (
+ BadCtors = [],
+ ( bimap.from_assoc_list(ForeignTagValues1, ForeignTagValues) ->
+ ForeignTagMap = ForeignTagValues ^ forward_map,
+ MaybeForeignTagMap = yes(ForeignTagMap)
+ ;
+ add_foreign_enum_bijection_error(Context, ContextPieces, !Specs),
+ MaybeForeignTagMap = no
+ )
+ ;
+ BadCtors = [_ | _],
+ MaybeForeignTagMap = no
+ ).
+
+ % The construtor names we get from the parse tree may be unqualified
+ % but the ones we match against in the HLDS are not. Module qualify
+ % them.
+ %
+ % XXX module_qual.m should really be doing this rather than add_pragam.m.
+ %
+:- pred fixup_foreign_tag_val_qualification(module_name::in,
+ pair(sym_name, string)::in, pair(sym_name, string)::out,
+ list(sym_name)::in, list(sym_name)::out) is det.
+
+fixup_foreign_tag_val_qualification(TypeModuleName, !NamesAndTags,
+ !BadCtors) :-
+ !.NamesAndTags = CtorSymName0 - ForeignTag,
+ (
+ CtorSymName0 = unqualified(Name),
+ CtorSymName = qualified(TypeModuleName, Name)
+ ;
+ CtorSymName0 = qualified(CtorModuleName, Name),
+ ( match_sym_name(CtorModuleName, TypeModuleName) ->
+ CtorSymName = qualified(TypeModuleName, Name)
+ ;
+ !:BadCtors = [ CtorSymName0 | !.BadCtors],
+ CtorSymName = CtorSymName0
+ )
+ ),
+ !:NamesAndTags = CtorSymName - ForeignTag.
+
+ % For a given target language work out which language's foreign_enum
+ % pragma we should be looking at.
+ %
+:- func target_lang_to_foreign_enum_lang(compilation_target)
+ = foreign_language.
+
+target_lang_to_foreign_enum_lang(target_c) = lang_c.
+target_lang_to_foreign_enum_lang(target_il) = lang_il.
+target_lang_to_foreign_enum_lang(target_java) = lang_java.
+target_lang_to_foreign_enum_lang(target_asm) =
+ sorry(this_file, "pragma foreign_enum and --target `asm'.").
+target_lang_to_foreign_enum_lang(target_x86_64) =
+ sorry(this_file, "pragma foreign_enum and --target `x86_64'.").
+target_lang_to_foreign_enum_lang(target_erlang) = lang_erlang.
+
+:- pred make_foreign_tag(map(sym_name, string)::in,
+ cons_id::in, cons_tag::in,
+ cons_tag_values::in, cons_tag_values::out,
+ list(sym_name)::in, list(sym_name)::out) is det.
+
+make_foreign_tag(ForeignTagMap, ConsId, _, !ConsTagValues, !UnmappedCtors) :-
+ ( ConsId = cons(ConsSymName0, 0) ->
+ ConsSymName = ConsSymName0
+ ;
+ unexpected(this_file, "non arity zero enumeration constant.")
+ ),
+ ( map.search(ForeignTagMap, ConsSymName, ForeignTagValue) ->
+ ForeignTag = foreign_tag(ForeignTagValue),
+ svmap.set(ConsId, ForeignTag, !ConsTagValues)
+ ;
+ !:UnmappedCtors = [ConsSymName | !.UnmappedCtors]
+ ).
+
+:- pred add_foreign_enum_unmapped_ctors_error(prog_context::in,
+ list(format_component)::in,
+ list(sym_name)::in(non_empty_list),
+ list(error_spec)::in, list(error_spec)::out) is det.
+
+add_foreign_enum_unmapped_ctors_error(Context, ContextPieces, UnmappedCtors0,
+ !Specs) :-
+ ErrorPieces = [
+ words("error: not all constructors have a foreign value.")
+ ],
+ list.sort(UnmappedCtors0, UnmappedCtors),
+ CtorComponents = list.map((func(S) = [sym_name(S)]), UnmappedCtors),
+ CtorList = component_list_to_line_pieces(CtorComponents, [nl]),
+ DoOrDoes = choose_number(UnmappedCtors,
+ "constructor does not have a foreign value",
+ "constructors do not have foreign values"),
+ VerboseErrorPieces = [
+ words("The following"), words(DoOrDoes),
+ nl_indent_delta(2)
+ ] ++ CtorList,
+ Msg = simple_msg(Context,
+ [
+ always(ContextPieces ++ ErrorPieces),
+ verbose_only(VerboseErrorPieces)
+ ]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds,
+ [Msg]),
+ list.cons(Spec, !Specs).
+
+:- pred add_foreign_enum_bijection_error(prog_context::in,
+ format_components::in, list(error_spec)::in, list(error_spec)::out)
+ is det.
+
+add_foreign_enum_bijection_error(Context, ContextPieces, !Specs) :-
+ ErrorPieces = [
+ words("error: "),
+ words("the mapping between Mercury enumeration values and"),
+ words("foreign values does not form a bijection.")
+ ],
+ Msg = simple_msg(Context, [always(ContextPieces ++ ErrorPieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ list.cons(Spec, !Specs).
+
+:- pred add_foreign_enum_pragma_in_interface_error(prog_context::in,
+ sym_name::in, arity::in, list(error_spec)::in, list(error_spec)::out)
+ is det.
+
+add_foreign_enum_pragma_in_interface_error(Context, TypeName, TypeArity,
+ !Specs) :-
+ ErrorPieces = [
+ words("Error: "),
+ words("`pragma foreign_enum' declaration for"),
+ sym_name_and_arity(TypeName / TypeArity),
+ words("in module interface.")
+ ],
+ Msg = simple_msg(Context, [always(ErrorPieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ list.cons(Spec, !Specs).
+
+%-----------------------------------------------------------------------------%
+
:- pred add_pragma_unused_args(pred_or_func::in, sym_name::in, arity::in,
mode_num::in, list(int)::in, prog_context::in,
module_info::in, module_info::out,
Index: compiler/bytecode_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/bytecode_gen.m,v
retrieving revision 1.113
diff -u -r1.113 bytecode_gen.m
--- compiler/bytecode_gen.m 7 Aug 2007 07:09:46 -0000 1.113
+++ compiler/bytecode_gen.m 9 Aug 2007 08:26:44 -0000
@@ -553,6 +553,9 @@
TypeCategory = type_cat_enum,
TestId = enum_test
;
+ TypeCategory = type_cat_foreign_enum,
+ sorry(this_file, "foreign enums with bytecode backend")
+ ;
TypeCategory = type_cat_higher_order,
unexpected(this_file, "higher_order_type in simple_test")
;
@@ -777,6 +780,8 @@
unexpected(this_file, "string_tag cons tag " ++
"for non-string_constant cons id").
map_cons_tag(int_tag(IntVal), byte_enum_tag(IntVal)).
+map_cons_tag(foreign_tag(_), _) :-
+ sorry(this_file, "bytecode with foreign tags").
map_cons_tag(float_tag(_), _) :-
unexpected(this_file, "float_tag cons tag " ++
"for non-float_constant cons id").
Index: compiler/dupproc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/dupproc.m,v
retrieving revision 1.20
diff -u -r1.20 dupproc.m
--- compiler/dupproc.m 31 Jul 2007 01:56:34 -0000 1.20
+++ compiler/dupproc.m 9 Aug 2007 08:26:44 -0000
@@ -419,6 +419,9 @@
Const = llconst_int(_),
StdConst = Const
;
+ Const = llconst_foreign(_, _),
+ StdConst = Const
+ ;
Const = llconst_float(_),
StdConst = Const
;
Index: compiler/erl_rtti.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/erl_rtti.m,v
retrieving revision 1.14
diff -u -r1.14 erl_rtti.m
--- compiler/erl_rtti.m 9 Jul 2007 04:48:44 -0000 1.14
+++ compiler/erl_rtti.m 9 Aug 2007 08:26:44 -0000
@@ -136,6 +136,8 @@
;
erlang_du(list.map(convert_enum_functor, Functors))
).
+erlang_type_ctor_details_2(foreign_enum(_, _, _, _, _)) =
+ sorry(this_file, "NYI foreign enumerations for Erlang.").
erlang_type_ctor_details_2(du(_, Functors, _, _, _)) =
erlang_du(list.map(convert_du_functor, Functors)).
erlang_type_ctor_details_2(reserved(_, _, _, _, _, _)) =
Index: compiler/exception_analysis.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/exception_analysis.m,v
retrieving revision 1.39
diff -u -r1.39 exception_analysis.m
--- compiler/exception_analysis.m 7 Aug 2007 07:09:52 -0000 1.39
+++ compiler/exception_analysis.m 9 Aug 2007 08:26:44 -0000
@@ -889,6 +889,14 @@
;
type_will_not_throw
).
+check_type_2(ModuleInfo, Type, type_cat_foreign_enum) =
+ ( type_has_user_defined_equality_pred(ModuleInfo, Type, _UnifyCompare) ->
+ % XXX This is very conservative.
+ type_may_throw
+ ;
+ type_will_not_throw
+ ).
+
check_type_2(ModuleInfo, Type, type_cat_user_ctor) =
check_user_type(ModuleInfo, Type).
Index: compiler/export.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/export.m,v
retrieving revision 1.113
diff -u -r1.113 export.m
--- compiler/export.m 7 Aug 2007 07:09:52 -0000 1.113
+++ compiler/export.m 9 Aug 2007 08:26:44 -0000
@@ -789,6 +789,7 @@
unexpected(this_file, "d.u. is not an enumeration.")
;
( IsEnumOrDummy = is_enum
+ ; IsEnumOrDummy = is_foreign_enum
; IsEnumOrDummy = is_dummy
),
list.foldl(foreign_const_name_and_tag(NameMapping, TagValues),
@@ -805,23 +806,57 @@
)
).
-:- pred output_exported_enum_2(module_info::in, pair(string, int)::in,
- io::di, io::uo) is det.
+ % The tags for exported enumerations will either be integers (for normal
+ % enumerations) or strings (for foreign enumerations.)
+ %
+:- type exported_enum_tag_rep
+ ---> ee_tag_rep_int(int)
+ ; ee_tag_rep_string(string).
+
+:- pred output_exported_enum_2(module_info::in,
+ pair(string, exported_enum_tag_rep)::in, io::di, io::uo) is det.
output_exported_enum_2(_, ConstName - Tag, !IO) :-
- io.format("#define %s %d", [s(ConstName), i(Tag)], !IO).
+ (
+ Tag = ee_tag_rep_int(RawIntTag),
+ io.format("#define %s %d", [s(ConstName), i(RawIntTag)], !IO)
+ ;
+ Tag = ee_tag_rep_string(RawStrTag),
+ io.format("#define %s %s", [s(ConstName), s(RawStrTag)], !IO)
+ ).
:- pred foreign_const_name_and_tag(map(sym_name, string)::in,
cons_tag_values::in, constructor::in,
- assoc_list(string, int)::in, assoc_list(string, int)::out) is det.
+ assoc_list(string, exported_enum_tag_rep)::in,
+ assoc_list(string, exported_enum_tag_rep)::out) is det.
foreign_const_name_and_tag(Mapping, TagValues, Ctor, !NamesAndTags) :-
Ctor = ctor(_, _, QualifiedCtorName, Args, _),
list.length(Args, Arity),
map.lookup(TagValues, cons(QualifiedCtorName, Arity), TagVal),
- ( TagVal = int_tag(Tag0) ->
- Tag = Tag0
- ;
+ (
+ TagVal = int_tag(IntTag),
+ Tag = ee_tag_rep_int(IntTag)
+ ;
+ TagVal = foreign_tag(ForeignTag),
+ Tag = ee_tag_rep_string(ForeignTag)
+ ;
+ ( TagVal = string_tag(_)
+ ; TagVal = float_tag(_)
+ ; TagVal = pred_closure_tag(_, _, _)
+ ; TagVal = type_ctor_info_tag(_, _, _)
+ ; TagVal = base_typeclass_info_tag(_, _, _)
+ ; TagVal = tabling_info_tag(_, _)
+ ; TagVal = deep_profiling_proc_layout_tag(_, _)
+ ; TagVal = table_io_decl_tag(_, _)
+ ; TagVal = single_functor_tag
+ ; TagVal = unshared_tag(_)
+ ; TagVal = shared_remote_tag(_, _)
+ ; TagVal = shared_local_tag(_, _)
+ ; TagVal = no_tag
+ ; TagVal = reserved_address_tag(_)
+ ; TagVal = shared_with_reserved_addresses_tag(_, _)
+ ),
unexpected(this_file, "enum constant requires an int tag")
),
% Sanity check.
Index: compiler/exprn_aux.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/exprn_aux.m,v
retrieving revision 1.83
diff -u -r1.83 exprn_aux.m
--- compiler/exprn_aux.m 31 Jul 2007 01:56:35 -0000 1.83
+++ compiler/exprn_aux.m 9 Aug 2007 08:26:44 -0000
@@ -146,6 +146,7 @@
const_is_constant(llconst_true, _, yes).
const_is_constant(llconst_false, _, yes).
const_is_constant(llconst_int(_), _, yes).
+const_is_constant(llconst_foreign(_, _), _, yes).
const_is_constant(llconst_float(_), ExprnOpts, IsConst) :-
ExprnOpts = nlg_asm_sgt_ubf(_NLG, _ASM, StaticGroundTerms, UnboxedFloat),
(
Index: compiler/global_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/global_data.m,v
retrieving revision 1.33
diff -u -r1.33 global_data.m
--- compiler/global_data.m 31 Jul 2007 01:56:35 -0000 1.33
+++ compiler/global_data.m 9 Aug 2007 08:26:44 -0000
@@ -1145,6 +1145,7 @@
( Const0 = llconst_true
; Const0 = llconst_false
; Const0 = llconst_int(_)
+ ; Const0 = llconst_foreign(_, _)
; Const0 = llconst_float(_)
; Const0 = llconst_string(_)
; Const0 = llconst_multi_string(_)
Index: compiler/higher_order.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/higher_order.m,v
retrieving revision 1.168
diff -u -r1.168 higher_order.m
--- compiler/higher_order.m 7 Aug 2007 07:09:54 -0000 1.168
+++ compiler/higher_order.m 9 Aug 2007 08:26:44 -0000
@@ -2327,7 +2327,9 @@
unexpected(this_file,
"tuple type in find_builtin_type_with_equivalent_compare")
;
- TypeCategory = type_cat_enum,
+ ( TypeCategory = type_cat_enum
+ ; TypeCategory = type_cat_foreign_enum
+ ),
construct_type(type_ctor(unqualified("int"), 0), [], EqvType),
NeedIntCast = yes
;
Index: compiler/hlds_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.114
diff -u -r1.114 hlds_data.m
--- compiler/hlds_data.m 9 Jul 2007 13:28:35 -0000 1.114
+++ compiler/hlds_data.m 9 Aug 2007 08:26:44 -0000
@@ -156,6 +156,7 @@
% An `hlds_type_body' holds the body of a type definition:
% du = discriminated union, eqv_type = equivalence type (a type defined
% to be equivalent to some other type), and solver_type.
+ %
:- type hlds_type_body
---> hlds_du_type(
% The ctors for this type.
@@ -185,6 +186,7 @@
:- type enum_or_dummy
---> is_enum
; is_dummy
+ ; is_foreign_enum
; not_enum_or_dummy.
:- type foreign_type_body
@@ -199,6 +201,7 @@
% Foreign types may have user-defined equality and comparison
% preds, but not solver_type_details.
+ %
:- type foreign_type_lang_data(T)
---> foreign_type_lang_data(
T,
@@ -210,12 +213,14 @@
% union type is represented. For each functor in the d.u. type, it gives
% a cons_tag which specifies how that functor and its arguments are
% represented.
+ %
:- type cons_tag_values == map(cons_id, cons_tag).
% A `cons_tag' specifies how a functor and its arguments (if any) are
% represented. Currently all values are represented as a single word;
% values which do not fit into a word are represented by a (possibly
% tagged) pointer to memory on the heap.
+ %
:- type cons_tag
---> string_tag(string)
% Strings are represented using the MR_string_const() macro;
@@ -231,6 +236,12 @@
% This means the constant is represented just as a word containing
% the specified integer value. This is used for enumerations and
% character constants as well as for int constants.
+
+ ; foreign_tag(string)
+ % This means the constant is represented by the string which is
+ % embedded directly in the target language. This is used for
+ % foreign enumerations, i.e. those enumeration types that are the
+ % subject of a foreign_enum pramga.
; pred_closure_tag(pred_id, proc_id, lambda_eval_method)
% Higher-order pred closures tags. These are represented as
@@ -376,6 +387,7 @@
get_primary_tag(string_tag(_)) = no.
get_primary_tag(float_tag(_)) = no.
get_primary_tag(int_tag(_)) = no.
+get_primary_tag(foreign_tag(_)) = no.
get_primary_tag(pred_closure_tag(_, _, _)) = no.
get_primary_tag(type_ctor_info_tag(_, _, _)) = no.
get_primary_tag(base_typeclass_info_tag(_, _, _)) = no.
@@ -384,8 +396,8 @@
get_primary_tag(table_io_decl_tag(_, _)) = no.
get_primary_tag(single_functor_tag) = yes(0).
get_primary_tag(unshared_tag(PrimaryTag)) = yes(PrimaryTag).
-get_primary_tag(shared_remote_tag(PrimaryTag, _SecondaryTag)) =
- yes(PrimaryTag).
+get_primary_tag(shared_remote_tag(PrimaryTag, _SecondaryTag))
+ = yes(PrimaryTag).
get_primary_tag(shared_local_tag(PrimaryTag, _)) = yes(PrimaryTag).
get_primary_tag(no_tag) = no.
get_primary_tag(reserved_address_tag(_)) = no.
@@ -395,6 +407,7 @@
get_secondary_tag(string_tag(_)) = no.
get_secondary_tag(float_tag(_)) = no.
get_secondary_tag(int_tag(_)) = no.
+get_secondary_tag(foreign_tag(_)) = no.
get_secondary_tag(pred_closure_tag(_, _, _)) = no.
get_secondary_tag(type_ctor_info_tag(_, _, _)) = no.
get_secondary_tag(base_typeclass_info_tag(_, _, _)) = no.
@@ -403,8 +416,8 @@
get_secondary_tag(table_io_decl_tag(_, _)) = no.
get_secondary_tag(single_functor_tag) = no.
get_secondary_tag(unshared_tag(_)) = no.
-get_secondary_tag(shared_remote_tag(_PrimaryTag, SecondaryTag)) =
- yes(SecondaryTag).
+get_secondary_tag(shared_remote_tag(_PrimaryTag, SecondaryTag))
+ = yes(SecondaryTag).
get_secondary_tag(shared_local_tag(_, _)) = no.
get_secondary_tag(no_tag) = no.
get_secondary_tag(reserved_address_tag(_)) = no.
@@ -514,7 +527,7 @@
% An `hlds_inst_defn' holds the information we need to store
% about inst definitions such as
% :- inst list_skel(I) = bound([] ; [I | list_skel(I)].
-
+ %
:- type hlds_inst_defn
---> hlds_inst_defn(
inst_varset :: inst_varset,
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.429
diff -u -r1.429 hlds_out.m
--- compiler/hlds_out.m 7 Aug 2007 07:09:55 -0000 1.429
+++ compiler/hlds_out.m 9 Aug 2007 08:26:44 -0000
@@ -3281,6 +3281,10 @@
write_indent(Indent, !IO),
io.write_string("/* enumeration */\n", !IO)
;
+ EnumDummy = is_foreign_enum,
+ write_indent(Indent, !IO),
+ io.write_string("/* foreign enumeration */\n", !IO)
+ ;
EnumDummy = is_dummy,
write_indent(Indent, !IO),
io.write_string("/* dummy */\n", !IO)
Index: compiler/inst_match.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/inst_match.m,v
retrieving revision 1.80
diff -u -r1.80 inst_match.m
--- compiler/inst_match.m 19 Jan 2007 07:04:15 -0000 1.80
+++ compiler/inst_match.m 9 Aug 2007 08:26:44 -0000
@@ -2051,6 +2051,7 @@
type_may_contain_solver_type_2(type_cat_higher_order) = no.
type_may_contain_solver_type_2(type_cat_tuple) = yes.
type_may_contain_solver_type_2(type_cat_enum) = no.
+type_may_contain_solver_type_2(type_cat_foreign_enum) = no.
type_may_contain_solver_type_2(type_cat_dummy) = no.
type_may_contain_solver_type_2(type_cat_variable) = yes.
type_may_contain_solver_type_2(type_cat_type_info) = no.
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.221
diff -u -r1.221 intermod.m
--- compiler/intermod.m 14 Jul 2007 02:32:42 -0000 1.221
+++ compiler/intermod.m 9 Aug 2007 08:26:44 -0000
@@ -16,8 +16,8 @@
% - The pred/mode declarations for local predicates that the
% above clauses use.
% - Non-exported types, insts and modes used by the above
-% - Pragma reserve_tag or foreign_type declarations for any types
-% output due to the line above
+% - Pragma reserve_tag, foreign_enum, or foreign_type declarations for
+% any types output due to the line above
% - :- import_module declarations to import stuff used by the above.
% - pragma declarations for the exported preds.
% - pragma foreign_header declarations if any pragma_foreign_code
@@ -1356,8 +1356,59 @@
Context, !IO)
;
true
+ ),
+ (
+ Body = hlds_du_type(_, ConsTagVals, EnumOrDummy, _, _, _),
+ EnumOrDummy = is_foreign_enum
+ ->
+ % XXX This language information should be attached to the type.
+ % It doesn't actually matter too much while we don't support
+ % foreign_enum pragmas for languages other than the target languages.
+ globals.io_get_target(TargetLanguage, !IO),
+ (
+ TargetLanguage = target_c,
+ Lang = lang_c
+ ;
+ TargetLanguage = target_il,
+ Lang = lang_il
+ ;
+ TargetLanguage = target_erlang,
+ Lang = lang_erlang
+ ;
+ TargetLanguage = target_java,
+ Lang = lang_java
+ ;
+ ( TargetLanguage = target_asm
+ ; TargetLanguage = target_x86_64
+ ),
+ sorry(this_file, "foreign enum and target_{asm,x86_64}")
+ ),
+ map.foldl(gather_foreign_enum_value_pair, ConsTagVals, [],
+ ForeignEnumVals),
+ Pragma = pragma_foreign_enum(Lang, Name, Arity, ForeignEnumVals),
+ Item = item_pragma(user, Pragma),
+ mercury_output_item(Item, Context, !IO)
+ ;
+ true
).
+:- pred gather_foreign_enum_value_pair(cons_id::in, cons_tag::in,
+ assoc_list(sym_name, string)::in, assoc_list(sym_name, string)::out)
+ is det.
+
+gather_foreign_enum_value_pair(ConsId, ConsTag, !Values) :-
+ ( ConsId = cons(SymName0, 0) ->
+ SymName = SymName0
+ ;
+ unexpected(this_file, "expected enumeration constant")
+ ),
+ ( ConsTag = foreign_tag(ForeignTag0) ->
+ ForeignTag = ForeignTag0
+ ;
+ unexpected(this_file, "exepcted foreign tag")
+ ),
+ !:Values = [SymName - ForeignTag | !.Values].
+
:- pred write_modes(module_info::in, io::di, io::uo) is det.
write_modes(ModuleInfo, !IO) :-
Index: compiler/jumpopt.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/jumpopt.m,v
retrieving revision 1.105
diff -u -r1.105 jumpopt.m
--- compiler/jumpopt.m 31 Jul 2007 01:56:36 -0000 1.105
+++ compiler/jumpopt.m 9 Aug 2007 08:26:44 -0000
@@ -1037,6 +1037,7 @@
jumpopt.short_labels_const(_, llconst_true, llconst_true).
jumpopt.short_labels_const(_, llconst_false, llconst_false).
jumpopt.short_labels_const(_, llconst_int(I), llconst_int(I)).
+jumpopt.short_labels_const(_, llconst_foreign(V, T), llconst_foreign(V, T)).
jumpopt.short_labels_const(_, llconst_float(F), llconst_float(F)).
jumpopt.short_labels_const(_, llconst_string(S), llconst_string(S)).
jumpopt.short_labels_const(_, llconst_multi_string(S),
Index: compiler/llds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/llds.m,v
retrieving revision 1.351
diff -u -r1.351 llds.m
--- compiler/llds.m 31 Jul 2007 01:56:36 -0000 1.351
+++ compiler/llds.m 9 Aug 2007 08:26:44 -0000
@@ -1068,6 +1068,11 @@
---> llconst_true
; llconst_false
; llconst_int(int)
+ ; llconst_foreign(string, llds_type)
+ % A constant in the target language.
+ % It may be a #defined constant in C which is why
+ % it is represented as string.
+
; llconst_float(float)
; llconst_string(string)
; llconst_multi_string(list(string))
@@ -1398,6 +1403,7 @@
const_type(llconst_true, bool).
const_type(llconst_false, bool).
const_type(llconst_int(_), integer).
+const_type(llconst_foreign(_, Type), Type).
const_type(llconst_float(_), float).
const_type(llconst_string(_), string).
const_type(llconst_multi_string(_), string).
Index: compiler/llds_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/llds_out.m,v
retrieving revision 1.315
diff -u -r1.315 llds_out.m
--- compiler/llds_out.m 7 Aug 2007 05:51:47 -0000 1.315
+++ compiler/llds_out.m 9 Aug 2007 08:26:44 -0000
@@ -5167,13 +5167,18 @@
output_rval_const(llconst_false, !IO) :-
io.write_string("MR_FALSE", !IO).
output_rval_const(llconst_int(N), !IO) :-
- % We need to cast to (Integer) to ensure things like 1 << 32 work
- % when `Integer' is 64 bits but `int' is 32 bits.
+ % We need to cast to (MR_Integer) to ensure things like 1 << 32 work
+ % when `MR_Integer' is 64 bits but `int' is 32 bits.
output_llds_type_cast(integer, !IO),
io.write_int(N, !IO).
+output_rval_const(llconst_foreign(Value, Type), !IO) :-
+ io.write_char('(', !IO),
+ output_llds_type_cast(Type, !IO),
+ io.write_string(Value, !IO),
+ io.write_char(')', !IO).
output_rval_const(llconst_float(FloatVal), !IO) :-
- % The cast to (Float) here lets the C compiler do arithmetic in `float'
- % rather than `double' if `Float' is `float' not `double'.
+ % The cast to (MR_Float) here lets the C compiler do arithmetic in `float'
+ % rather than `double' if `MR_Float' is `float' not `double'.
output_llds_type_cast(float, !IO),
c_util.output_float_literal(FloatVal, !IO).
output_rval_const(llconst_string(String), !IO) :-
Index: compiler/llds_to_x86_64.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/llds_to_x86_64.m,v
retrieving revision 1.7
diff -u -r1.7 llds_to_x86_64.m
--- compiler/llds_to_x86_64.m 31 Jul 2007 01:56:37 -0000 1.7
+++ compiler/llds_to_x86_64.m 9 Aug 2007 08:26:44 -0000
@@ -608,6 +608,8 @@
Op = yes(operand_label("<<llconst_false>>")).
transform_rval(!RegMap, const(llconst_int(Val)), Op, no) :-
Op = yes(operand_imm(imm32(int32(Val)))).
+transform_rval(!RegMap, const(llconst_foreign(_, _)), _, _) :-
+ sorry(this_file, "x86_64 backend and foreign tags.").
transform_rval(!RegMap, const(llconst_float(_)), Op, no) :-
Op = yes(operand_label("<<llconst_float>>")).
transform_rval(!RegMap, const(llconst_string(String)), no, yes(Op)) :-
Index: compiler/make_hlds_passes.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make_hlds_passes.m,v
retrieving revision 1.70
diff -u -r1.70 make_hlds_passes.m
--- compiler/make_hlds_passes.m 25 Jul 2007 06:12:19 -0000 1.70
+++ compiler/make_hlds_passes.m 9 Aug 2007 08:26:44 -0000
@@ -27,6 +27,7 @@
% When adding an item to the HLDS we need to know both its
% import_status and whether uses of it must be module qualified.
+ %
:- type item_status
---> item_status(import_status, need_qualifier).
@@ -1070,6 +1071,10 @@
add_pragma_foreign_export_enum(Lang, TypeName, TypeArity, Attributes,
Overrides, !.Status, Context, !ModuleInfo, !Specs)
;
+ Pragma = pragma_foreign_enum(Lang, TypeName, TypeArity, TagValues),
+ add_pragma_foreign_enum(Lang, TypeName, TypeArity, TagValues,
+ !.Status, Context, !ModuleInfo, !Specs)
+ ;
Pragma = pragma_foreign_export(Lang, Name, PredOrFunc, Modes,
C_Function),
add_pragma_foreign_export(Origin, Lang, Name, PredOrFunc, Modes,
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.317
diff -u -r1.317 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m 25 Jul 2007 06:12:20 -0000 1.317
+++ compiler/mercury_to_mercury.m 9 Aug 2007 08:26:44 -0000
@@ -605,6 +605,10 @@
mercury_format_pragma_foreign_export_enum(Lang, TypeName, TypeArity,
Attributes, Overrides, !IO)
;
+ Pragma = pragma_foreign_enum(Lang, TypeName, TypeArity, Values),
+ mercury_format_pragma_foreign_enum(Lang, TypeName, TypeArity,
+ Values, !IO)
+ ;
Pragma = pragma_obsolete(Pred, Arity),
mercury_output_pragma_decl(Pred, Arity, pf_predicate, "obsolete", no,
!IO)
@@ -3627,7 +3631,7 @@
add_string(", ", !U),
mercury_format_pragma_foreign_export_enum_attributes(Attributes, !U),
add_string(", ", !U),
- mercury_format_pragma_foreign_export_enum_overrides(Overrides, !U),
+ mercury_format_sym_name_string_assoc_list(Overrides, !U),
add_string(").\n", !U).
:- pred mercury_format_pragma_foreign_export_enum_attributes(
@@ -3646,23 +3650,44 @@
),
add_string("]", !U).
-:- pred mercury_format_pragma_foreign_export_enum_overrides(
+ % Output an association list of sym_names and strings, as used
+ % by both foreign_enum and foreign_export_enum pragmas.
+ % In the output the strings will be quoted.
+ %
+:- pred mercury_format_sym_name_string_assoc_list(
assoc_list(sym_name, string)::in, U::di, U::uo) is det <= output(U).
-mercury_format_pragma_foreign_export_enum_overrides(Overrides, !U) :-
+mercury_format_sym_name_string_assoc_list(AssocList, !U) :-
add_char('[', !U),
- add_list(Overrides, ",",
- mercury_format_pragma_foreign_export_enum_override, !U),
+ add_list(AssocList, ",",
+ mercury_format_sym_name_string_pair, !U),
add_char(']', !U).
-:- pred mercury_format_pragma_foreign_export_enum_override(
+:- pred mercury_format_sym_name_string_pair(
pair(sym_name, string)::in, U::di, U::uo) is det <= output(U).
-mercury_format_pragma_foreign_export_enum_override(CtorName - ForeignName,
- !U) :-
- mercury_format_bracketed_sym_name(CtorName, next_to_graphic_token, !U),
+mercury_format_sym_name_string_pair(SymName - String, !U) :-
+ mercury_format_bracketed_sym_name(SymName, next_to_graphic_token, !U),
add_string(" - ", !U),
- add_quoted_string(ForeignName, !U).
+ add_quoted_string(String, !U).
+
+%-----------------------------------------------------------------------------%
+
+:- pred mercury_format_pragma_foreign_enum(foreign_language::in,
+ sym_name::in, arity::in, assoc_list(sym_name, string)::in,
+ U::di, U::uo) is det <= output(U).
+
+mercury_format_pragma_foreign_enum(Lang, TypeName, TypeArity,
+ Values, !U) :-
+ add_string(":- pragma foreign_enum(", !U),
+ mercury_format_foreign_language_string(Lang, !U),
+ add_string(", ", !U),
+ mercury_format_bracketed_sym_name(TypeName, next_to_graphic_token, !U),
+ add_string("/", !U),
+ add_int(TypeArity, !U),
+ add_string(", ", !U),
+ mercury_format_sym_name_string_assoc_list(Values, !U),
+ add_string(").\n", !U).
%-----------------------------------------------------------------------------%
Index: compiler/ml_code_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_code_util.m,v
retrieving revision 1.123
diff -u -r1.123 ml_code_util.m
--- compiler/ml_code_util.m 7 Aug 2007 07:09:59 -0000 1.123
+++ compiler/ml_code_util.m 9 Aug 2007 08:26:44 -0000
@@ -1593,6 +1593,7 @@
ml_must_box_field_type_category(type_cat_higher_order) = no.
ml_must_box_field_type_category(type_cat_tuple) = no.
ml_must_box_field_type_category(type_cat_enum) = no.
+ml_must_box_field_type_category(type_cat_foreign_enum) = no.
ml_must_box_field_type_category(type_cat_dummy) = no.
ml_must_box_field_type_category(type_cat_variable) = no.
ml_must_box_field_type_category(type_cat_type_info) = no.
@@ -1998,6 +1999,7 @@
ml_type_category_might_contain_pointers(type_cat_higher_order) = yes.
ml_type_category_might_contain_pointers(type_cat_tuple) = yes.
ml_type_category_might_contain_pointers(type_cat_enum) = no.
+ml_type_category_might_contain_pointers(type_cat_foreign_enum) = no.
ml_type_category_might_contain_pointers(type_cat_dummy) = no.
ml_type_category_might_contain_pointers(type_cat_variable) = yes.
ml_type_category_might_contain_pointers(type_cat_user_ctor) = yes.
Index: compiler/ml_type_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_type_gen.m,v
retrieving revision 1.66
diff -u -r1.66 ml_type_gen.m
--- compiler/ml_type_gen.m 25 Jul 2007 06:12:21 -0000 1.66
+++ compiler/ml_type_gen.m 9 Aug 2007 08:26:44 -0000
@@ -159,7 +159,9 @@
% XXX we probably shouldn't ignore _ReservedTag
ml_gen_equality_members(MaybeUserEqComp, MaybeEqualityMembers),
(
- EnumDummy = is_enum,
+ ( EnumDummy = is_foreign_enum
+ ; EnumDummy = is_enum
+ ),
ml_gen_enum_type(TypeCtor, TypeDefn, Ctors, TagValues,
MaybeEqualityMembers, !Defns)
;
@@ -1051,10 +1053,30 @@
Ctor = ctor(_, _, QualName, Args, _),
list.length(Args, Arity),
map.lookup(TagValues, cons(QualName, Arity), TagVal),
- ( TagVal = int_tag(Int) ->
+ (
+ TagVal = int_tag(Int),
ConstValue = const(mlconst_int(Int))
;
- unexpected(this_file, "enum constant requires an int tag")
+ TagVal = foreign_tag(String),
+ ConstValue = const(mlconst_foreign(String, mlds_native_int_type))
+ ;
+ ( TagVal = string_tag(_)
+ ; TagVal = float_tag(_)
+ ; TagVal = pred_closure_tag(_, _, _)
+ ; TagVal = type_ctor_info_tag(_, _, _)
+ ; TagVal = base_typeclass_info_tag(_, _, _)
+ ; TagVal = tabling_info_tag(_, _)
+ ; TagVal = deep_profiling_proc_layout_tag(_, _)
+ ; TagVal = table_io_decl_tag(_, _)
+ ; TagVal = single_functor_tag
+ ; TagVal = unshared_tag(_)
+ ; TagVal = shared_remote_tag(_, _)
+ ; TagVal = shared_local_tag(_, _)
+ ; TagVal = no_tag
+ ; TagVal = reserved_address_tag(_)
+ ; TagVal = shared_with_reserved_addresses_tag(_, _)
+ ),
+ unexpected(this_file, "enum constant requires an int or foreign tag")
),
% Sanity check.
expect(unify(Arity, 0), this_file, "enum constant arity != 0"),
Index: compiler/ml_unify_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.113
diff -u -r1.113 ml_unify_gen.m
--- compiler/ml_unify_gen.m 6 Jul 2007 02:35:22 -0000 1.113
+++ compiler/ml_unify_gen.m 9 Aug 2007 08:26:44 -0000
@@ -296,6 +296,7 @@
;
% Constants.
( Tag = int_tag(_)
+ ; Tag = foreign_tag(_)
; Tag = float_tag(_)
; Tag = string_tag(_)
; Tag = reserved_address_tag(_)
@@ -409,6 +410,8 @@
ml_gen_constant(string_tag(String), _, const(mlconst_string(String)), !Info).
ml_gen_constant(int_tag(Int), _, const(mlconst_int(Int)), !Info).
+ml_gen_constant(foreign_tag(ForeignTag), _, Rval, !Info) :-
+ Rval = const(mlconst_foreign(ForeignTag, mlds_native_int_type)).
ml_gen_constant(float_tag(Float), _, const(mlconst_float(Float)), !Info).
ml_gen_constant(shared_local_tag(Bits1, Num1), VarType, Rval, !Info) :-
ml_gen_type(!.Info, VarType, MLDS_Type),
@@ -1309,6 +1312,7 @@
(
( Tag = string_tag(_String)
; Tag = int_tag(_Int)
+ ; Tag = foreign_tag(_)
; Tag = float_tag(_Float)
; Tag = pred_closure_tag(_, _, _)
; Tag = type_ctor_info_tag(_, _, _)
@@ -1385,6 +1389,7 @@
;
( Tag = string_tag(_String)
; Tag = int_tag(_Int)
+ ; Tag = foreign_tag(_)
; Tag = float_tag(_Float)
; Tag = pred_closure_tag(_, _, _)
; Tag = type_ctor_info_tag(_, _, _)
@@ -1668,6 +1673,8 @@
binop(float_eq, Rval, const(mlconst_float(Float))).
ml_gen_tag_test_rval(int_tag(Int), _, _, Rval) =
binop(eq, Rval, const(mlconst_int(Int))).
+ml_gen_tag_test_rval(foreign_tag(ForeignVal), _, _, Rval) =
+ binop(eq, Rval, const(mlconst_foreign(ForeignVal, mlds_native_int_type))).
ml_gen_tag_test_rval(pred_closure_tag(_, _, _), _, _, _Rval) = _TestRval :-
% This should never happen, since the error will be detected
% during mode checking.
Index: compiler/ml_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_util.m,v
retrieving revision 1.56
diff -u -r1.56 ml_util.m
--- compiler/ml_util.m 19 Jan 2007 07:04:20 -0000 1.56
+++ compiler/ml_util.m 9 Aug 2007 08:26:44 -0000
@@ -180,6 +180,8 @@
:- func gen_init_string(string) = mlds_initializer.
+:- func gen_init_foreign(string) = mlds_initializer.
+
:- func gen_init_int(int) = mlds_initializer.
:- func gen_init_bool(bool) = mlds_initializer.
@@ -703,6 +705,9 @@
gen_init_int(Int) = init_obj(const(mlconst_int(Int))).
+gen_init_foreign(String) =
+ init_obj(const(mlconst_foreign(String, mlds_native_int_type))).
+
gen_init_bool(no) = init_obj(const(mlconst_false)).
gen_init_bool(yes) = init_obj(const(mlconst_true)).
Index: compiler/mlds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds.m,v
retrieving revision 1.151
diff -u -r1.151 mlds.m
--- compiler/mlds.m 25 Jul 2007 06:12:22 -0000 1.151
+++ compiler/mlds.m 9 Aug 2007 08:26:44 -0000
@@ -1572,6 +1572,7 @@
---> mlconst_true
; mlconst_false
; mlconst_int(int)
+ ; mlconst_foreign(string, mlds_type)
; mlconst_float(float)
; mlconst_string(string)
; mlconst_multi_string(list(string))
@@ -1651,9 +1652,11 @@
% just for them.)
% A tag should be a small non-negative integer.
+ %
:- type mlds_tag == int.
- % see runtime/mercury_trail.h
+ % See runtime/mercury_trail.h.
+ %
:- type mlds_reset_trail_reason
---> undo
; commit
@@ -1681,6 +1684,7 @@
% When these are different, as for specialised versions of predicates
% from `.opt' files, the defining module's name is added as a
% qualifier to the pred name.
+ %
:- type mlds_pred_label
---> mlds_user_pred_label(
pred_or_func, % predicate/function
@@ -1723,10 +1727,12 @@
:- type mlds_exported_enum
---> mlds_exported_enum(
- foreign_language, % For sanity checking.
+ foreign_language, % For sanity checking only.
prog_context,
mlds_type, % Type of the constants (hard coded as
- % mlds_native_int_type in ml_type_gen.m.)
+ % mlds_native_int_type in
+ % ml_type_gen.m.)
+
assoc_list(string, mlds_entity_defn)
% The name of each constant
% plus a value to initialize it to.
Index: compiler/mlds_to_c.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_c.m,v
retrieving revision 1.219
diff -u -r1.219 mlds_to_c.m
--- compiler/mlds_to_c.m 25 Jul 2007 06:12:22 -0000 1.219
+++ compiler/mlds_to_c.m 9 Aug 2007 08:26:44 -0000
@@ -1238,19 +1238,28 @@
mlds_output_exported_enum_constant(NameAndTag, !IO) :-
NameAndTag = Name - Tag,
- (
- Tag = mlds_data(mlds_native_int_type, Initializer, gc_no_stmt),
- Initializer = init_obj(const(mlconst_int(Value)))
- ->
- io.write_string("#define ", !IO),
- io.write_string(Name, !IO),
- io.write_string(" ", !IO),
- io.write_int(Value, !IO),
- io.nl(!IO)
+ io.write_string("#define ", !IO),
+ io.write_string(Name, !IO),
+ io.write_string(" ", !IO),
+ ( Tag = mlds_data(mlds_native_int_type, Initializer, gc_no_stmt) ->
+ (
+ Initializer = init_obj(const(mlconst_int(Value)))
+ ->
+ io.write_int(Value, !IO)
+ ;
+ Initializer = init_obj(const(mlconst_foreign(Value,
+ mlds_native_int_type)))
+ ->
+ io.write_string(Value, !IO)
+ ;
+ unexpected(this_file,
+ "tag for export enumeration is not integer or foreign")
+ )
;
unexpected(this_file,
- "bad mlds_entity_defn for exported enumeration value.")
- ).
+ "exported enumeration contstant is not mlds_data")
+ ),
+ io.nl(!IO).
%-----------------------------------------------------------------------------%
%
@@ -2289,13 +2298,11 @@
io.write_string("MR_Word", !IO)
)
;
- TypeCategory = type_cat_enum,
- mlds_output_mercury_user_type_prefix(Type, TypeCategory, !IO)
- ;
- TypeCategory = type_cat_dummy,
- mlds_output_mercury_user_type_prefix(Type, TypeCategory, !IO)
- ;
- TypeCategory = type_cat_user_ctor,
+ ( TypeCategory = type_cat_enum
+ ; TypeCategory = type_cat_dummy
+ ; TypeCategory = type_cat_foreign_enum
+ ; TypeCategory = type_cat_user_ctor
+ ),
mlds_output_mercury_user_type_prefix(Type, TypeCategory, !IO)
).
@@ -3789,6 +3796,12 @@
% when `Integer' is 64 bits but `int' is 32 bits.
io.write_string("(MR_Integer) ", !IO),
io.write_int(N, !IO).
+mlds_output_rval_const(mlconst_foreign(Value, Type), !IO) :-
+ io.write_string("((", !IO),
+ mlds_output_type(Type, !IO),
+ io.write_string(") ", !IO),
+ io.write_string(Value, !IO),
+ io.write_string(")", !IO).
mlds_output_rval_const(mlconst_float(FloatVal), !IO) :-
% The cast to (MR_Float) here lets the C compiler do arithmetic in `float'
% rather than `double' if `MR_Float' is `float' not `double'.
Index: compiler/mlds_to_gcc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_gcc.m,v
retrieving revision 1.132
diff -u -r1.132 mlds_to_gcc.m
--- compiler/mlds_to_gcc.m 25 Jul 2007 06:12:22 -0000 1.132
+++ compiler/mlds_to_gcc.m 9 Aug 2007 08:26:44 -0000
@@ -1923,6 +1923,7 @@
;
{ TypeCategory = type_cat_enum
; TypeCategory = type_cat_dummy
+ ; TypeCategory = type_cat_foreign_enum
},
% Note that the MLDS -> C back-end uses 'MR_Word' here,
% unless --high-level-data is enabled. But 'MR_Integer'
@@ -2039,6 +2040,8 @@
['MR_ConstString' - "MR_enum_functor_name",
'MR_int_least32_t' - "MR_enum_functor_ordinal"],
GCC_Type, !IO).
+build_rtti_type_name(type_ctor_foreign_enum_functor_desc(_), _, _, _) :-
+ sorry(this_file, "NYI foreign enums and asm backend.").
build_rtti_type_name(type_ctor_notag_functor_desc, GCC_Type, !IO) :-
% typedef struct {
% MR_ConstString MR_notag_functor_name;
@@ -2094,6 +2097,10 @@
!IO).
build_rtti_type_name(type_ctor_enum_value_ordered_table, gcc__ptr_type_node,
!IO).
+build_rtti_type_name(type_ctor_foreign_enum_name_ordered_table,
+ gcc__ptr_type_node, !IO).
+build_rtti_type_name(type_ctor_foreign_enum_ordinal_ordered_table,
+ gcc__ptr_type_node, !IO).
build_rtti_type_name(type_ctor_du_name_ordered_table, gcc__ptr_type_node, !IO).
build_rtti_type_name(type_ctor_du_stag_ordered_table(_), gcc__ptr_type_node,
!IO).
@@ -3662,6 +3669,9 @@
gcc__build_int(0, Expr).
build_rval_const(mlconst_int(N), _, Expr) -->
gcc__build_int(N, Expr).
+build_rval_const(mlconst_foreign(_Value, _Type), _, _) -->
+ { sorry(this_file,
+ "foreign tags not yet supported with `--target asm'") }.
build_rval_const(mlconst_float(FloatVal), _, Expr) -->
gcc__build_float(FloatVal, Expr).
build_rval_const(mlconst_string(String), _, Expr) -->
Index: compiler/mlds_to_il.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_il.m,v
retrieving revision 1.187
diff -u -r1.187 mlds_to_il.m
--- compiler/mlds_to_il.m 25 Jul 2007 06:12:22 -0000 1.187
+++ compiler/mlds_to_il.m 9 Aug 2007 08:26:44 -0000
@@ -556,6 +556,7 @@
rename_const(mlconst_true) = mlconst_true.
rename_const(mlconst_false) = mlconst_false.
rename_const(mlconst_int(I)) = mlconst_int(I).
+rename_const(mlconst_foreign(F, T)) = mlconst_foreign(F, T).
rename_const(mlconst_float(F)) = mlconst_float(F).
rename_const(mlconst_string(S)) = mlconst_string(S).
rename_const(mlconst_multi_string(S)) = mlconst_multi_string(S).
@@ -2384,6 +2385,9 @@
Const = mlconst_int(Int),
Instrs = instr_node(ldc(int32, i(Int)))
;
+ Const = mlconst_foreign(_F, _T),
+ sorry(this_file, "NYI IL backend and foreign tags.")
+ ;
Const = mlconst_float(Float),
Instrs = instr_node(ldc(float64, f(Float)))
;
@@ -3194,6 +3198,8 @@
il_object_array_type.
mlds_mercury_type_to_ilds_type(_, _, type_cat_tuple) = il_object_array_type.
mlds_mercury_type_to_ilds_type(_, _, type_cat_enum) = il_object_array_type.
+mlds_mercury_type_to_ilds_type(_, _, type_cat_foreign_enum) =
+ il_object_array_type.
mlds_mercury_type_to_ilds_type(_, _, type_cat_dummy) = il_generic_type.
mlds_mercury_type_to_ilds_type(_, _, type_cat_variable) = il_generic_type.
mlds_mercury_type_to_ilds_type(DataRep, MercuryType, type_cat_type_info) =
@@ -3710,6 +3716,8 @@
rval_const_to_type(mlconst_int(_))
= mercury_type(IntType, type_cat_int, non_foreign_type(IntType)) :-
IntType = builtin_type(builtin_type_int).
+rval_const_to_type(mlconst_foreign(_, _))
+ = sorry(this_file, "IL backend and foreign tag.").
rval_const_to_type(mlconst_float(_))
= mercury_type(FloatType, type_cat_float,
non_foreign_type(FloatType)) :-
Index: compiler/mlds_to_java.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_java.m,v
retrieving revision 1.95
diff -u -r1.95 mlds_to_java.m
--- compiler/mlds_to_java.m 25 Jul 2007 06:12:23 -0000 1.95
+++ compiler/mlds_to_java.m 9 Aug 2007 08:26:44 -0000
@@ -202,6 +202,7 @@
type_category_is_object(type_cat_higher_order) = no.
type_category_is_object(type_cat_tuple) = no.
type_category_is_object(type_cat_enum) = yes.
+type_category_is_object(type_cat_foreign_enum) = yes.
type_category_is_object(type_cat_dummy) = yes.
type_category_is_object(type_cat_variable) = yes.
type_category_is_object(type_cat_type_info) = yes.
@@ -1444,6 +1445,7 @@
get_java_type_initializer(mercury_type(_, type_cat_higher_order, _)) = "null".
get_java_type_initializer(mercury_type(_, type_cat_tuple, _)) = "null".
get_java_type_initializer(mercury_type(_, type_cat_enum, _)) = "null".
+get_java_type_initializer(mercury_type(_, type_cat_foreign_enum, _)) = "null".
get_java_type_initializer(mercury_type(_, type_cat_dummy, _)) = "null".
get_java_type_initializer(mercury_type(_, type_cat_variable, _)) = "null".
get_java_type_initializer(mercury_type(_, type_cat_user_ctor, _)) = "null".
@@ -1961,6 +1963,9 @@
TypeCategory = type_cat_enum,
output_mercury_user_type(Type, TypeCategory, !IO)
;
+ TypeCategory = type_cat_foreign_enum,
+ output_mercury_user_type(Type, TypeCategory, !IO)
+ ;
TypeCategory = type_cat_dummy,
output_mercury_user_type(Type, TypeCategory, !IO)
;
@@ -2012,6 +2017,7 @@
type_category_is_array(type_cat_higher_order) = yes.
type_category_is_array(type_cat_tuple) = yes.
type_category_is_array(type_cat_enum) = no.
+type_category_is_array(type_cat_foreign_enum) = no.
type_category_is_array(type_cat_dummy) = no.
type_category_is_array(type_cat_variable) = no.
type_category_is_array(type_cat_type_info) = no.
@@ -3285,6 +3291,11 @@
output_rval_const(mlconst_int(N), !IO) :-
io.write_int(N, !IO).
+ % XXX Should we parenthesize this?
+ %
+output_rval_const(mlconst_foreign(Value, _Type), !IO) :-
+ io.write_string(Value, !IO).
+
output_rval_const(mlconst_float(FloatVal), !IO) :-
c_util.output_float_literal(FloatVal, !IO).
Index: compiler/mlds_to_managed.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_managed.m,v
retrieving revision 1.45
diff -u -r1.45 mlds_to_managed.m
--- compiler/mlds_to_managed.m 25 Jul 2007 06:12:24 -0000 1.45
+++ compiler/mlds_to_managed.m 9 Aug 2007 08:26:44 -0000
@@ -468,6 +468,8 @@
io.write_string("0", !IO).
write_rval_const(mlconst_int(I), !IO) :-
io.write_int(I, !IO).
+write_rval_const(mlconst_foreign(Value, _Type), !IO) :-
+ io.write_string(Value, !IO).
write_rval_const(mlconst_float(F), !IO) :-
io.write_float(F, !IO).
% XXX We don't quote this correctly.
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.157
diff -u -r1.157 module_qual.m
--- compiler/module_qual.m 25 Jul 2007 06:12:24 -0000 1.157
+++ compiler/module_qual.m 9 Aug 2007 08:26:44 -0000
@@ -1164,6 +1164,11 @@
Y = pragma_foreign_export_enum(Lang, TypeName, TypeArity, Attributes,
Overrides).
qualify_pragma(X, Y, !Info, !Specs) :-
+ X = pragma_foreign_enum(Lang, TypeName0, TypeArity0, Values),
+ qualify_type_ctor(type_ctor(TypeName0, TypeArity0),
+ type_ctor(TypeName, TypeArity), !Info, !Specs),
+ Y = pragma_foreign_enum(Lang, TypeName, TypeArity, Values).
+qualify_pragma(X, Y, !Info, !Specs) :-
X = pragma_foreign_proc(Attrs0, Name, PredOrFunc, Vars0, Varset,
InstVarset, Impl),
qualify_pragma_vars(Vars0, Vars, !Info, !Specs),
Index: compiler/modules.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.436
diff -u -r1.436 modules.m
--- compiler/modules.m 25 Jul 2007 06:12:24 -0000 1.436
+++ compiler/modules.m 9 Aug 2007 08:26:44 -0000
@@ -1604,6 +1604,7 @@
set.union(NecessaryDummyTypeCtors, NecessaryEqvTypeCtors,
AllNecessaryTypeCtors),
strip_unnecessary_impl_types(AllNecessaryTypeCtors, !ImplItems),
+ strip_local_foreign_enum_pragmas(!.IntTypesMap, !ImplItems),
(
!.ImplItems = [],
Items = IntItems
@@ -2140,6 +2141,34 @@
)
),
get_modules_from_constraint_arg_types(Args, !Modules)
+ ).
+
+ % Retain only those foreign_enum pragmas that correspond to types
+ % defined in the interface of a module.
+ %
+:- pred strip_local_foreign_enum_pragmas(type_defn_map::in,
+ item_list::in, item_list::out) is det.
+
+strip_local_foreign_enum_pragmas(IntTypeMap, !ImplItems) :-
+ list.filter(foreign_enum_is_local(IntTypeMap), !ImplItems).
+
+:- pred foreign_enum_is_local(type_defn_map::in, item_and_context::in)
+ is semidet.
+
+foreign_enum_is_local(TypeDefnMap, ItemAndContext) :-
+ ItemAndContext = item_and_context(Item, _Context),
+ (
+ Item = item_pragma(_, PragmaItem),
+ PragmaItem = pragma_foreign_enum(_Lang, TypeName, TypeArity, _Values)
+ ->
+ % We only add a pragma foreign_enum pragma to the interface file
+ % if it corresponds to a type _definition_ in the interface of the
+ % module.
+ TypeCtor = type_ctor(TypeName, TypeArity),
+ map.search(TypeDefnMap, TypeCtor, Defns),
+ Defns \= [parse_tree_abstract_type(_) - _]
+ ;
+ true
).
%-----------------------------------------------------------------------------%
@@ -2218,10 +2247,10 @@
).
% pragma `obsolete', `terminates', `does_not_terminate'
-% `termination_info', `check_termination', and `reserve_tag' pragma
-% declarations are supposed to go in the interface, but all other pragma
-% declarations are implementation details only, and should go in the
-% implementation.
+% `termination_info', `check_termination', `reserve_tag' and
+% `foreign_enum' pragma declarations are supposed to go in the
+% interface, but all other pragma declarations are implementation details
+% only, and should go in the implementation.
% XXX we should allow c_header_code;
% but if we do allow it, we should put it in the generated
@@ -2231,6 +2260,7 @@
pragma_allowed_in_interface(pragma_foreign_decl(_, _, _), no).
pragma_allowed_in_interface(pragma_foreign_export(_, _, _, _, _), no).
pragma_allowed_in_interface(pragma_foreign_export_enum(_, _, _, _, _), no).
+pragma_allowed_in_interface(pragma_foreign_enum(_, _, _, _), yes).
pragma_allowed_in_interface(pragma_foreign_import_module(_, _), yes).
pragma_allowed_in_interface(pragma_foreign_proc(_, _, _, _, _, _, _), no).
pragma_allowed_in_interface(pragma_inline(_, _), no).
@@ -2352,7 +2382,8 @@
% Read in the previous version of the file.
read_mod_ignore_errors(ModuleName, Suffix,
"Reading old interface for module", yes, no,
- OldItemAndContexts, OldError, _OldIntFileName, _OldTimestamp, !IO),
+ OldItemAndContexts, OldError, _OldIntFileName, _OldTimestamp,
+ !IO),
( OldError = no_module_errors ->
MaybeOldItemAndContexts = yes(OldItemAndContexts)
;
@@ -7622,6 +7653,9 @@
get_foreign_language(Attrs)).
item_needs_foreign_imports(item_mutable(_, _, _, _, _, _), Lang) :-
foreign_language(Lang).
+item_needs_foreign_imports(item_pragma(_, pragma_foreign_enum(Lang, _, _, _)),
+ Lang) :-
+ foreign_language(Lang).
:- pred include_in_int_file_implementation(item::in) is semidet.
@@ -7637,6 +7671,8 @@
include_in_int_file_implementation(item_typeclass(_, _, _, _, _, _)).
include_in_int_file_implementation(item_pragma(_,
pragma_foreign_import_module(_, _))).
+include_in_int_file_implementation(Item) :-
+ Item = item_pragma(_, pragma_foreign_enum(_, _, _, _)).
:- pred make_abstract_defn(item::in, short_interface_kind::in, item::out)
is semidet.
@@ -7925,6 +7961,7 @@
; Pragma = pragma_mm_tabling_info(_, _, _, _, _), Reorderable = yes
; Pragma = pragma_foreign_export(_, _, _, _, _), Reorderable = yes
; Pragma = pragma_foreign_export_enum(_, _, _, _, _), Reorderable = yes
+ ; Pragma = pragma_foreign_enum(_, _, _, _), Reorderable = yes
; Pragma = pragma_fact_table(_, _, _), Reorderable = no
; Pragma = pragma_foreign_code(_, _), Reorderable = no
; Pragma = pragma_foreign_decl(_, _, _), Reorderable = no
@@ -8013,6 +8050,7 @@
; Pragma = pragma_foreign_import_module(_, _), Reorderable = no
; Pragma = pragma_foreign_proc(_, _, _, _, _, _, _), Reorderable = no
; Pragma = pragma_foreign_export_enum(_, _, _, _, _), Reorderable = yes
+ ; Pragma = pragma_foreign_enum(_, _, _, _), Reorderable = yes
; Pragma = pragma_import(_, _, _, _, _), Reorderable = no
; Pragma = pragma_inline(_, _), Reorderable = yes
; Pragma = pragma_mode_check_clauses(_, _), Reorderable = yes
Index: compiler/opt_debug.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/opt_debug.m,v
retrieving revision 1.196
diff -u -r1.196 opt_debug.m
--- compiler/opt_debug.m 31 Jul 2007 01:56:38 -0000 1.196
+++ compiler/opt_debug.m 9 Aug 2007 08:26:44 -0000
@@ -308,6 +308,7 @@
dump_const(_, llconst_false) = "false".
dump_const(_, llconst_int(I)) =
int_to_string(I).
+dump_const(_, llconst_foreign(F, _)) = F.
dump_const(_, llconst_float(F)) =
float_to_string(F).
dump_const(_, llconst_string(S)) =
@@ -370,6 +371,8 @@
dump_rtti_name(type_ctor_res_addr_functors) = "res_addr_functors".
dump_rtti_name(type_ctor_enum_functor_desc(Ordinal)) =
"enum_functor_desc_" ++ int_to_string(Ordinal).
+dump_rtti_name(type_ctor_foreign_enum_functor_desc(Ordinal)) =
+ "foreign_enum_functor_desc_" ++ int_to_string(Ordinal).
dump_rtti_name(type_ctor_notag_functor_desc) = "notag_functor_desc_".
dump_rtti_name(type_ctor_du_functor_desc(Ordinal)) =
"du_functor_desc_" ++ int_to_string(Ordinal).
@@ -378,6 +381,10 @@
dump_rtti_name(type_ctor_enum_name_ordered_table) = "enum_name_ordered_table".
dump_rtti_name(type_ctor_enum_value_ordered_table) =
"enum_value_ordered_table".
+dump_rtti_name(type_ctor_foreign_enum_name_ordered_table) =
+ "foreign_enum_name_ordered_table".
+dump_rtti_name(type_ctor_foreign_enum_ordinal_ordered_table) =
+ "foreign_enum_ordinal_ordered_table".
dump_rtti_name(type_ctor_du_name_ordered_table) = "du_name_ordered_table".
dump_rtti_name(type_ctor_du_stag_ordered_table(Ptag)) =
"du_stag_ordered_table_" ++ int_to_string(Ptag).
Index: compiler/opt_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/opt_util.m,v
retrieving revision 1.165
diff -u -r1.165 opt_util.m
--- compiler/opt_util.m 31 Jul 2007 01:56:38 -0000 1.165
+++ compiler/opt_util.m 9 Aug 2007 08:26:44 -0000
@@ -2550,6 +2550,7 @@
( Const0 = llconst_true
; Const0 = llconst_false
; Const0 = llconst_int(_)
+ ; Const0 = llconst_foreign(_, _)
; Const0 = llconst_float(_)
; Const0 = llconst_string(_)
; Const0 = llconst_multi_string(_)
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.320
diff -u -r1.320 polymorphism.m
--- compiler/polymorphism.m 7 Aug 2007 07:10:02 -0000 1.320
+++ compiler/polymorphism.m 9 Aug 2007 08:26:44 -0000
@@ -2675,6 +2675,7 @@
get_category_name(type_cat_int) = yes("int").
get_category_name(type_cat_char) = yes("int").
get_category_name(type_cat_enum) = no.
+get_category_name(type_cat_foreign_enum) = no.
get_category_name(type_cat_dummy) = no.
get_category_name(type_cat_float) = yes("float").
get_category_name(type_cat_string) = yes("string").
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.126
diff -u -r1.126 prog_io_pragma.m
--- compiler/prog_io_pragma.m 25 Jul 2007 06:12:26 -0000 1.126
+++ compiler/prog_io_pragma.m 9 Aug 2007 08:26:44 -0000
@@ -285,7 +285,7 @@
Result = ok2(Name, Arity)
;
Msg = "expected name/arity for type in " ++
- "`pragma foreign_expor_enum' declaration",
+ "`pragma foreign_export_enum' declaration",
Result = error2([Msg - TypeTerm])
).
@@ -294,25 +294,27 @@
maybe_parse_export_enum_overrides(no, ok1([])).
maybe_parse_export_enum_overrides(yes(OverridesTerm), MaybeOverrides) :-
- Msg = "not a valid mapping element",
- convert_maybe_list(OverridesTerm, parse_export_enum_override, Msg, MaybeOverrides).
+ ListMsg = "not a valid mapping element",
+ PairMsg = "exported enumeration override constructor",
+ convert_maybe_list(OverridesTerm, parse_sym_name_string_pair(PairMsg),
+ ListMsg, MaybeOverrides).
-:- pred parse_export_enum_override(term::in,
+:- pred parse_sym_name_string_pair(string::in, term::in,
maybe1(pair(sym_name, string))::out) is semidet.
-parse_export_enum_override(Renaming, MaybeMappingElement) :-
- Renaming = functor(Functor, Args, _),
+parse_sym_name_string_pair(Msg, PairTerm, MaybePair) :-
+ PairTerm = functor(Functor, Args, _),
Functor = term.atom("-"),
- Args = [CtorTerm, ForeignNameTerm],
- ForeignNameTerm = functor(term.string(ForeignName), _, _),
- parse_qualified_term(CtorTerm, CtorTerm, "export enum const",
- MaybeCtorResult),
+ Args = [SymNameTerm, StringTerm],
+ StringTerm = functor(term.string(String), _, _),
+ parse_qualified_term(SymNameTerm, SymNameTerm, Msg,
+ MaybeSymNameResult),
(
- MaybeCtorResult = ok2(SymName, []),
- MaybeMappingElement = ok1(SymName - ForeignName)
+ MaybeSymNameResult = ok2(SymName, []),
+ MaybePair = ok1(SymName - String)
;
- MaybeCtorResult = error2(Errs),
- MaybeMappingElement = error1(Errs)
+ MaybeSymNameResult = error2(Errs),
+ MaybePair = error1(Errs)
).
:- pred maybe_parse_export_enum_attributes(maybe(term)::in,
@@ -392,6 +394,52 @@
%----------------------------------------------------------------------------%
%
+% Code for parsing foreign_enum pragmas
+%
+
+parse_pragma_type(_ModuleName, "foreign_enum", PragmaTerms, ErrorTerm,
+ _VarSet, Result) :-
+ ( PragmaTerms = [LangTerm, MercuryTypeTerm, ValuesTerm] ->
+ ( parse_foreign_language(LangTerm, ForeignLanguage) ->
+ parse_export_enum_type(MercuryTypeTerm, MaybeType),
+ (
+ MaybeType = ok2(TypeName, TypeArity),
+ ListErrMsg = "not a valid mapping element",
+ PairErrMsg = "foreign_enum constructor name",
+ convert_maybe_list(ValuesTerm,
+ parse_sym_name_string_pair(PairErrMsg),
+ ListErrMsg, MaybeValues),
+ (
+ MaybeValues = ok1(Values),
+ PragmaForeignImportEnum = pragma_foreign_enum(
+ ForeignLanguage,
+ TypeName,
+ TypeArity,
+ Values
+ ),
+ Item = item_pragma(user, PragmaForeignImportEnum),
+ Result = ok1(Item)
+ ;
+ MaybeValues = error1(Errors),
+ Result = error1(Errors)
+ )
+ ;
+ MaybeType = error2(Errors),
+ Result = error1(Errors)
+ )
+ ;
+ Msg = "invalid foreign langauge in " ++
+ "`:- pragma foreign_enum' declaration",
+ Result = error1([Msg - ErrorTerm])
+ )
+ ;
+ Msg = "wrong number of arguments in " ++
+ "`:- pragma foreign_enum' declaration",
+ Result = error1([Msg - ErrorTerm])
+ ).
+
+%----------------------------------------------------------------------------%
+%
% Code for parsing foreign_export pragmas
%
@@ -1263,7 +1311,7 @@
)
->
( parse_foreign_language(LangTerm, ForeignLanguage) ->
- ( HeaderTerm = term.functor(term.string( HeaderCode), [], _) ->
+ ( HeaderTerm = term.functor(term.string(HeaderCode), [], _) ->
DeclCode = pragma_foreign_decl(ForeignLanguage, IsLocal,
HeaderCode),
Result = ok1(item_pragma(user, DeclCode))
Index: compiler/prog_item.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_item.m,v
retrieving revision 1.28
diff -u -r1.28 prog_item.m
--- compiler/prog_item.m 25 Jul 2007 06:12:26 -0000 1.28
+++ compiler/prog_item.m 9 Aug 2007 08:26:44 -0000
@@ -441,6 +441,13 @@
export_enum_attributes :: export_enum_attributes,
export_enum_overrides :: assoc_list(sym_name, string)
)
+ ;
+ pragma_foreign_enum(
+ foreign_enum_language :: foreign_language,
+ foreign_enum_type_name :: sym_name,
+ foreign_enum_type_arity :: arity,
+ foreign_enum_values :: assoc_list(sym_name, string)
+ )
%
% Optimization pragmas
%
Index: compiler/prog_type.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_type.m,v
retrieving revision 1.38
diff -u -r1.38 prog_type.m
--- compiler/prog_type.m 31 Jul 2007 07:58:42 -0000 1.38
+++ compiler/prog_type.m 9 Aug 2007 08:26:44 -0000
@@ -276,6 +276,7 @@
; type_cat_higher_order
; type_cat_tuple
; type_cat_enum
+ ; type_cat_foreign_enum
; type_cat_dummy
; type_cat_variable
; type_cat_type_info
@@ -826,6 +827,7 @@
is_introduced_type_info_type_category(type_cat_higher_order) = no.
is_introduced_type_info_type_category(type_cat_tuple) = no.
is_introduced_type_info_type_category(type_cat_enum) = no.
+is_introduced_type_info_type_category(type_cat_foreign_enum) = no.
is_introduced_type_info_type_category(type_cat_dummy) = no.
is_introduced_type_info_type_category(type_cat_variable) = no.
is_introduced_type_info_type_category(type_cat_type_info) = yes.
Index: compiler/recompilation.version.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/recompilation.version.m,v
retrieving revision 1.59
diff -u -r1.59 recompilation.version.m
--- compiler/recompilation.version.m 25 Jul 2007 06:12:26 -0000 1.59
+++ compiler/recompilation.version.m 9 Aug 2007 08:26:44 -0000
@@ -588,6 +588,7 @@
% Pragma import declarations are never used directly by Mercury code.
is_pred_pragma(pragma_import(_, _, _, _, _), no).
is_pred_pragma(pragma_foreign_export_enum(_, _, _, _, _), no).
+is_pred_pragma(pragma_foreign_enum(_, _, _, _), no).
is_pred_pragma(pragma_source_file(_), no).
is_pred_pragma(pragma_unused_args(PredOrFunc, Name, Arity, _, _),
yes(yes(PredOrFunc) - Name / Arity)).
Index: compiler/rtti.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rtti.m,v
retrieving revision 1.82
diff -u -r1.82 rtti.m
--- compiler/rtti.m 1 Jun 2007 04:12:50 -0000 1.82
+++ compiler/rtti.m 9 Aug 2007 08:26:44 -0000
@@ -182,6 +182,14 @@
enum_functor_number_mapping
:: list(int)
)
+ ; foreign_enum(
+ foreign_enum_axioms :: equality_axioms,
+ foreign_enum_functors :: list(foreign_enum_functor),
+ foreign_enum_ordinal_table :: map(int, foreign_enum_functor),
+ foreign_enum_name_table :: map(string, foreign_enum_functor),
+ foreign_enum_functor_number_mapping
+ :: list(int)
+ )
; du(
du_axioms :: equality_axioms,
du_functors :: list(du_functor),
@@ -234,6 +242,17 @@
enum_ordinal :: int
).
+ % Descriptor for a functor in a foreign enum type.
+ %
+ % This type corresponds to the C Type MR_ForeignEnumFunctorDesc.
+ %
+:- type foreign_enum_functor
+ ---> foreign_enum_functor(
+ foreign_enum_name :: string,
+ foreign_enum_ordinal :: int,
+ foreign_enum_value :: string
+ ).
+
% Descriptor for a functor in a notag type.
%
% This type corresponds to the C type MR_NotagFunctorDesc.
@@ -609,11 +628,14 @@
; type_ctor_res_addrs
; type_ctor_res_addr_functors
; type_ctor_enum_functor_desc(int) % functor ordinal
+ ; type_ctor_foreign_enum_functor_desc(int) % functor ordinal
; type_ctor_notag_functor_desc
; type_ctor_du_functor_desc(int) % functor ordinal
; type_ctor_res_functor_desc(int) % functor ordinal
; type_ctor_enum_name_ordered_table
; type_ctor_enum_value_ordered_table
+ ; type_ctor_foreign_enum_name_ordered_table
+ ; type_ctor_foreign_enum_ordinal_ordered_table
; type_ctor_du_name_ordered_table
; type_ctor_du_stag_ordered_table(int) % primary tag
; type_ctor_du_ptag_ordered_table
@@ -779,6 +801,7 @@
% functor descriptor.
%
:- func enum_functor_rtti_name(enum_functor) = ctor_rtti_name.
+:- func foreign_enum_functor_rtti_name(foreign_enum_functor) = ctor_rtti_name.
:- func du_functor_rtti_name(du_functor) = ctor_rtti_name.
:- func res_functor_rtti_name(reserved_functor) = ctor_rtti_name.
:- func maybe_res_functor_rtti_name(maybe_reserved_functor) = ctor_rtti_name.
@@ -1073,11 +1096,14 @@
ctor_rtti_name_is_exported(type_ctor_res_addrs) = no.
ctor_rtti_name_is_exported(type_ctor_res_addr_functors) = no.
ctor_rtti_name_is_exported(type_ctor_enum_functor_desc(_)) = no.
+ctor_rtti_name_is_exported(type_ctor_foreign_enum_functor_desc(_)) = no.
ctor_rtti_name_is_exported(type_ctor_notag_functor_desc) = no.
ctor_rtti_name_is_exported(type_ctor_du_functor_desc(_)) = no.
ctor_rtti_name_is_exported(type_ctor_res_functor_desc(_)) = no.
ctor_rtti_name_is_exported(type_ctor_enum_name_ordered_table) = no.
ctor_rtti_name_is_exported(type_ctor_enum_value_ordered_table) = no.
+ctor_rtti_name_is_exported(type_ctor_foreign_enum_name_ordered_table) = no.
+ctor_rtti_name_is_exported(type_ctor_foreign_enum_ordinal_ordered_table) = no.
ctor_rtti_name_is_exported(type_ctor_du_name_ordered_table) = no.
ctor_rtti_name_is_exported(type_ctor_du_stag_ordered_table(_)) = no.
ctor_rtti_name_is_exported(type_ctor_du_ptag_ordered_table) = no.
@@ -1222,6 +1248,11 @@
string.append_list([ModuleName, "__enum_functor_desc_",
TypeName, "_", A_str, "_", O_str], Str)
;
+ RttiName = type_ctor_foreign_enum_functor_desc(Ordinal),
+ string.int_to_string(Ordinal, O_str),
+ string.append_list([ModuleName, "__foreign_enum_functor_desc_",
+ TypeName, "_", A_str, "_", O_str], Str)
+ ;
RttiName = type_ctor_notag_functor_desc,
string.append_list([ModuleName, "__notag_functor_desc_",
TypeName, "_", A_str], Str)
@@ -1244,6 +1275,14 @@
string.append_list([ModuleName, "__enum_value_ordered_",
TypeName, "_", A_str], Str)
;
+ RttiName = type_ctor_foreign_enum_name_ordered_table,
+ string.append_list([ModuleName, "__foreign_enum_name_ordered_",
+ TypeName, "_", A_str], Str)
+ ;
+ RttiName = type_ctor_foreign_enum_ordinal_ordered_table,
+ string.append_list([ModuleName, "__foreign_enum_ordinal_ordered_",
+ TypeName, "_", A_str], Str)
+ ;
RttiName = type_ctor_du_name_ordered_table,
string.append_list([ModuleName, "__du_name_ordered_",
TypeName, "_", A_str], Str)
@@ -1555,6 +1594,15 @@
)
)
;
+ TypeCtorDetails = foreign_enum(TypeCtorUserEq, _, _, _, _),
+ (
+ TypeCtorUserEq = standard,
+ RepStr = "MR_TYPECTOR_REP_FOREIGN_ENUM"
+ ;
+ TypeCtorUserEq = user_defined,
+ RepStr = "MR_TYPECTOR_REP_FOREIGN_ENUM_USEREQ"
+ )
+ ;
TypeCtorDetails = du(TypeCtorUserEq, _, _, _, _),
(
TypeCtorUserEq = standard,
@@ -1689,6 +1737,7 @@
rtti_data_pseudo_type_info(type_var(0)).
type_ctor_details_num_ptags(enum(_, _, _, _, _, _)) = -1.
+type_ctor_details_num_ptags(foreign_enum(_, _, _, _, _)) = -1.
type_ctor_details_num_ptags(du(_, _, PtagMap, _, _)) = LastPtag + 1 :-
map.keys(PtagMap, Ptags),
list.last_det(Ptags, LastPtag).
@@ -1710,6 +1759,8 @@
type_ctor_details_num_functors(enum(_, Functors, _, _, _, _)) =
list.length(Functors).
+type_ctor_details_num_functors(foreign_enum(_, Functors, _, _, _)) =
+ list.length(Functors).
type_ctor_details_num_functors(du(_, Functors, _, _, _)) =
list.length(Functors).
type_ctor_details_num_functors(reserved(_, Functors, _, _, _, _)) =
@@ -1729,6 +1780,9 @@
enum_functor_rtti_name(EnumFunctor) =
type_ctor_enum_functor_desc(EnumFunctor ^ enum_ordinal).
+foreign_enum_functor_rtti_name(EnumFunctor) =
+ type_ctor_foreign_enum_functor_desc(EnumFunctor ^ foreign_enum_ordinal).
+
du_functor_rtti_name(DuFunctor) =
type_ctor_du_functor_desc(DuFunctor ^ du_ordinal).
@@ -1770,11 +1824,14 @@
ctor_rtti_name_code_addr(type_ctor_res_addrs) = no.
ctor_rtti_name_code_addr(type_ctor_res_addr_functors) = no.
ctor_rtti_name_code_addr(type_ctor_enum_functor_desc(_)) = no.
+ctor_rtti_name_code_addr(type_ctor_foreign_enum_functor_desc(_)) = no.
ctor_rtti_name_code_addr(type_ctor_notag_functor_desc) = no.
ctor_rtti_name_code_addr(type_ctor_du_functor_desc(_)) = no.
ctor_rtti_name_code_addr(type_ctor_res_functor_desc(_)) = no.
ctor_rtti_name_code_addr(type_ctor_enum_name_ordered_table) = no.
ctor_rtti_name_code_addr(type_ctor_enum_value_ordered_table) = no.
+ctor_rtti_name_code_addr(type_ctor_foreign_enum_name_ordered_table) = no.
+ctor_rtti_name_code_addr(type_ctor_foreign_enum_ordinal_ordered_table) = no.
ctor_rtti_name_code_addr(type_ctor_du_name_ordered_table) = no.
ctor_rtti_name_code_addr(type_ctor_du_stag_ordered_table(_)) = no.
ctor_rtti_name_code_addr(type_ctor_du_ptag_ordered_table) = no.
@@ -1954,6 +2011,8 @@
"ReservedAddrFunctorDescPtr", yes).
ctor_rtti_name_type(type_ctor_enum_functor_desc(_),
"EnumFunctorDesc", no).
+ctor_rtti_name_type(type_ctor_foreign_enum_functor_desc(_),
+ "ForeignEnumFunctorDesc", no).
ctor_rtti_name_type(type_ctor_notag_functor_desc,
"NotagFunctorDesc", no).
ctor_rtti_name_type(type_ctor_du_functor_desc(_),
@@ -1964,6 +2023,10 @@
"EnumFunctorDescPtr", yes).
ctor_rtti_name_type(type_ctor_enum_value_ordered_table,
"EnumFunctorDescPtr", yes).
+ctor_rtti_name_type(type_ctor_foreign_enum_name_ordered_table,
+ "ForeignEnumFunctorDescPtr", yes).
+ctor_rtti_name_type(type_ctor_foreign_enum_ordinal_ordered_table,
+ "ForeignEnumFunctorDescPtr", yes).
ctor_rtti_name_type(type_ctor_du_name_ordered_table,
"DuFunctorDescPtr", yes).
ctor_rtti_name_type(type_ctor_du_stag_ordered_table(_),
Index: compiler/rtti_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rtti_out.m,v
retrieving revision 1.73
diff -u -r1.73 rtti_out.m
--- compiler/rtti_out.m 22 May 2007 00:58:00 -0000 1.73
+++ compiler/rtti_out.m 9 Aug 2007 08:26:44 -0000
@@ -667,6 +667,20 @@
MaybeFunctorsName = yes(type_ctor_enum_name_ordered_table),
HaveFunctorNumberMap = yes
;
+ TypeCtorDetails = foreign_enum(_, ForeignEnumFunctors,
+ ForeignEnumByOrdinal, ForeignEnumByName, FunctorNumberMap),
+ list.foldl2(output_foreign_enum_functor_defn(RttiTypeCtor),
+ ForeignEnumFunctors, !DeclSet, !IO),
+ output_foreign_enum_ordinal_ordered_table(RttiTypeCtor,
+ ForeignEnumByOrdinal, !DeclSet, !IO),
+ output_foreign_enum_name_ordered_table(RttiTypeCtor, ForeignEnumByName,
+ !DeclSet, !IO),
+ output_functor_number_map(RttiTypeCtor, FunctorNumberMap,
+ !DeclSet, !IO),
+ MaybeLayoutName = yes(type_ctor_foreign_enum_ordinal_ordered_table),
+ MaybeFunctorsName = yes(type_ctor_foreign_enum_name_ordered_table),
+ HaveFunctorNumberMap = yes
+ ;
TypeCtorDetails = du(_, DuFunctors, DuByRep,
DuByName, FunctorNumberMap),
list.foldl2(output_du_functor_defn(RttiTypeCtor), DuFunctors,
@@ -748,6 +762,25 @@
io.write_int(Ordinal, !IO),
io.write_string("\n};\n", !IO).
+:- pred output_foreign_enum_functor_defn(rtti_type_ctor::in,
+ foreign_enum_functor::in, decl_set::in, decl_set::out, io::di, io::uo)
+ is det.
+
+output_foreign_enum_functor_defn(RttiTypeCtor, ForeignEnumFunctor, !DeclSet,
+ !IO) :-
+ ForeignEnumFunctor = foreign_enum_functor(FunctorName, FunctorOrdinal,
+ FunctorValue),
+ RttiId = ctor_rtti_id(RttiTypeCtor,
+ type_ctor_foreign_enum_functor_desc(FunctorOrdinal)),
+ output_generic_rtti_data_defn_start(RttiId, !DeclSet, !IO),
+ io.write_string(" = {\n\t""", !IO),
+ c_util.output_quoted_string(FunctorName, !IO),
+ io.write_string(""",\n\t", !IO),
+ io.write_int(FunctorOrdinal, !IO),
+ io.write_string(",\n\t", !IO),
+ io.write_string(FunctorValue, !IO),
+ io.write_string("\n};\n", !IO).
+
:- pred output_notag_functor_defn(rtti_type_ctor::in, notag_functor::in,
decl_set::in, decl_set::out, io::di, io::uo) is det.
@@ -1060,6 +1093,36 @@
io.write_string(" = {\n", !IO),
output_addr_of_ctor_rtti_names(RttiTypeCtor, FunctorRttiNames, !IO),
io.write_string("};\n", !IO).
+
+:- pred output_foreign_enum_ordinal_ordered_table(rtti_type_ctor::in,
+ map(int, foreign_enum_functor)::in, decl_set::in, decl_set::out,
+ io::di, io::uo) is det.
+
+output_foreign_enum_ordinal_ordered_table(RttiTypeCtor, FunctorMap,
+ !DeclSet, !IO) :-
+ Functors = map.values(FunctorMap),
+ FunctorRttiNames = list.map(foreign_enum_functor_rtti_name, Functors),
+ RttiId = ctor_rtti_id(RttiTypeCtor,
+ type_ctor_foreign_enum_ordinal_ordered_table),
+ output_generic_rtti_data_defn_start(RttiId, !DeclSet, !IO),
+ io.write_string(" = {\n", !IO),
+ output_addr_of_ctor_rtti_names(RttiTypeCtor, FunctorRttiNames, !IO),
+ io.write_string("};\n", !IO).
+
+:- pred output_foreign_enum_name_ordered_table(rtti_type_ctor::in,
+ map(string, foreign_enum_functor)::in, decl_set::in, decl_set::out,
+ io::di, io::uo) is det.
+
+output_foreign_enum_name_ordered_table(RttiTypeCtor, FunctorMap, !DeclSet,
+ !IO) :-
+ Functors = map.values(FunctorMap),
+ FunctorRttiNames = list.map(foreign_enum_functor_rtti_name, Functors),
+ output_generic_rtti_data_defn_start(
+ ctor_rtti_id(RttiTypeCtor, type_ctor_foreign_enum_name_ordered_table),
+ !DeclSet, !IO),
+ io.write_string(" = {\n", !IO),
+ output_addr_of_ctor_rtti_names(RttiTypeCtor, FunctorRttiNames, !IO),
+ io.write_string("};\n", !IO).
:- pred output_du_name_ordered_table(rtti_type_ctor::in,
map(string, map(int, du_functor))::in, decl_set::in, decl_set::out,
Index: compiler/rtti_to_mlds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rtti_to_mlds.m,v
retrieving revision 1.80
diff -u -r1.80 rtti_to_mlds.m
--- compiler/rtti_to_mlds.m 22 May 2007 00:57:59 -0000 1.80
+++ compiler/rtti_to_mlds.m 9 Aug 2007 08:26:44 -0000
@@ -525,6 +525,26 @@
type_ctor_functor_number_map),
Defns = EnumFunctorDescs ++ [ByValueDefn, ByNameDefn, NumberMapDefn]
;
+ TypeCtorDetails = foreign_enum(_, ForeignEnumFunctors,
+ ForeignEnumByOrdinal, ForeignEnumByName, FunctorNumberMap),
+ ForeignEnumFunctorDescs = list.map(
+ gen_foreign_enum_functor_desc(ModuleInfo, RttiTypeCtor),
+ ForeignEnumFunctors),
+ ByOrdinalDefn = gen_foreign_enum_ordinal_ordered_table(ModuleInfo,
+ RttiTypeCtor, ForeignEnumByOrdinal),
+ ByNameDefn = gen_foreign_enum_name_ordered_table(ModuleInfo,
+ RttiTypeCtor, ForeignEnumByName),
+ NumberMapDefn = gen_functor_number_map(RttiTypeCtor,
+ FunctorNumberMap),
+ LayoutInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
+ type_ctor_foreign_enum_ordinal_ordered_table),
+ FunctorInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
+ type_ctor_foreign_enum_name_ordered_table),
+ NumberMapInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
+ type_ctor_functor_number_map),
+ Defns = ForeignEnumFunctorDescs ++
+ [ByOrdinalDefn, ByNameDefn, NumberMapDefn]
+ ;
TypeCtorDetails = du(_, DuFunctors, DuByPtag,
DuByName, FunctorNumberMap),
DuFunctorDefnLists = list.map(
@@ -616,6 +636,21 @@
]),
rtti_id_and_init_to_defn(RttiId, Init, MLDS_Defn).
+:- func gen_foreign_enum_functor_desc(module_info, rtti_type_ctor,
+ foreign_enum_functor) = mlds_defn.
+
+gen_foreign_enum_functor_desc(_ModuleInfo, RttiTypeCtor, ForeignEnumFunctor)
+ = MLDS_Defn :-
+ ForeignEnumFunctor = foreign_enum_functor(FunctorName, Ordinal, Value),
+ RttiName = type_ctor_foreign_enum_functor_desc(Ordinal),
+ RttiId = ctor_rtti_id(RttiTypeCtor, RttiName),
+ Init = init_struct(mlds_rtti_type(item_type(RttiId)), [
+ gen_init_string(FunctorName),
+ gen_init_int(Ordinal),
+ gen_init_foreign(Value)
+ ]),
+ rtti_id_and_init_to_defn(RttiId, Init, MLDS_Defn).
+
:- func gen_notag_functor_desc(module_info, rtti_type_ctor, notag_functor)
= list(mlds_defn).
@@ -900,6 +935,32 @@
RttiName = type_ctor_enum_name_ordered_table,
rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Init, MLDS_Defn).
+:- func gen_foreign_enum_ordinal_ordered_table(module_info, rtti_type_ctor,
+ map(int, foreign_enum_functor)) = mlds_defn.
+
+gen_foreign_enum_ordinal_ordered_table(ModuleInfo, RttiTypeCtor,
+ ForeignEnumByOrdinal) = MLDS_Defn :-
+ map.values(ForeignEnumByOrdinal, Functors),
+ module_info_get_name(ModuleInfo, ModuleName),
+ FunctorRttiNames = list.map(foreign_enum_functor_rtti_name, Functors),
+ Init = gen_init_rtti_names_array(ModuleName, RttiTypeCtor,
+ FunctorRttiNames),
+ RttiName = type_ctor_foreign_enum_ordinal_ordered_table,
+ rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Init, MLDS_Defn).
+
+:- func gen_foreign_enum_name_ordered_table(module_info, rtti_type_ctor,
+ map(string, foreign_enum_functor)) = mlds_defn.
+
+gen_foreign_enum_name_ordered_table(ModuleInfo, RttiTypeCtor,
+ ForeignEnumByName) = MLDS_Defn :-
+ map.values(ForeignEnumByName, Functors),
+ module_info_get_name(ModuleInfo, ModuleName),
+ FunctorRttiNames = list.map(foreign_enum_functor_rtti_name, Functors),
+ Init = gen_init_rtti_names_array(ModuleName, RttiTypeCtor,
+ FunctorRttiNames),
+ RttiName = type_ctor_foreign_enum_name_ordered_table,
+ rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Init, MLDS_Defn).
+
:- func gen_du_ptag_ordered_table(module_info, rtti_type_ctor,
map(int, sectag_table)) = list(mlds_defn).
Index: compiler/switch_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/switch_util.m,v
retrieving revision 1.36
diff -u -r1.36 switch_util.m
--- compiler/switch_util.m 15 Oct 2006 23:26:53 -0000 1.36
+++ compiler/switch_util.m 9 Aug 2007 08:26:44 -0000
@@ -252,6 +252,7 @@
%
type_cat_to_switch_cat(type_cat_enum) = atomic_switch.
+type_cat_to_switch_cat(type_cat_foreign_enum) = atomic_switch.
type_cat_to_switch_cat(type_cat_dummy) = _ :-
% You can't have a switch without at least two arms.
unexpected(this_file, "type_cat_to_switch_cat: dummy").
@@ -276,6 +277,7 @@
switch_priority(no_tag) = 0. % should never occur
switch_priority(int_tag(_)) = 1.
+switch_priority(foreign_tag(_)) = 1.
switch_priority(reserved_address_tag(_)) = 1.
switch_priority(shared_local_tag(_, _)) = 1.
switch_priority(single_functor_tag) = 2.
@@ -390,6 +392,7 @@
; Tag = string_tag(_)
; Tag = float_tag(_)
; Tag = int_tag(_)
+ ; Tag = foreign_tag(_)
; Tag = pred_closure_tag(_, _, _)
; Tag = type_ctor_info_tag(_, _, _)
; Tag = base_typeclass_info_tag(_, _, _)
@@ -456,6 +459,7 @@
; Tag = string_tag(_)
; Tag = float_tag(_)
; Tag = int_tag(_)
+ ; Tag = foreign_tag(_)
; Tag = pred_closure_tag(_, _, _)
; Tag = type_ctor_info_tag(_, _, _)
; Tag = base_typeclass_info_tag(_, _, _)
Index: compiler/table_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/table_gen.m,v
retrieving revision 1.134
diff -u -r1.134 table_gen.m
--- compiler/table_gen.m 7 Aug 2007 07:10:06 -0000 1.134
+++ compiler/table_gen.m 9 Aug 2007 08:26:44 -0000
@@ -3338,6 +3338,7 @@
builtin_type(type_cat_base_typeclass_info) = yes.
builtin_type(type_cat_higher_order) = no.
builtin_type(type_cat_enum) = no.
+builtin_type(type_cat_foreign_enum) = no.
builtin_type(type_cat_dummy) = no.
builtin_type(type_cat_variable) = no.
builtin_type(type_cat_tuple) = no.
@@ -3370,6 +3371,7 @@
lookup_tabling_category(type_cat_base_typeclass_info, _) :-
unexpected(this_file, "lookup_tabling_category: base_typeclass_info_type").
lookup_tabling_category(type_cat_enum, no).
+lookup_tabling_category(type_cat_foreign_enum, no).
lookup_tabling_category(type_cat_higher_order, no).
lookup_tabling_category(type_cat_tuple, no).
lookup_tabling_category(type_cat_variable, no).
@@ -3379,10 +3381,11 @@
% we need to use for values of types belonging the type category given by
% the first argument. The returned value replaces CAT in
% table_save_CAT_answer and table_restore_CAT_answer.
-
+ %
:- pred type_save_category(type_category::in, string::out) is det.
type_save_category(type_cat_enum, "enum").
+type_save_category(type_cat_foreign_enum, "enum").
type_save_category(type_cat_int, "int").
type_save_category(type_cat_char, "char").
type_save_category(type_cat_string, "string").
Index: compiler/term_norm.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/term_norm.m,v
retrieving revision 1.24
diff -u -r1.24 term_norm.m
--- compiler/term_norm.m 1 Dec 2006 15:04:24 -0000 1.24
+++ compiler/term_norm.m 9 Aug 2007 08:26:44 -0000
@@ -344,6 +344,7 @@
zero_size_type_category(type_cat_higher_order, yes).
zero_size_type_category(type_cat_tuple, no).
zero_size_type_category(type_cat_enum, yes).
+zero_size_type_category(type_cat_foreign_enum, yes).
zero_size_type_category(type_cat_dummy, yes).
zero_size_type_category(type_cat_variable, no).
zero_size_type_category(type_cat_user_ctor, no).
Index: compiler/trailing_analysis.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/trailing_analysis.m,v
retrieving revision 1.26
diff -u -r1.26 trailing_analysis.m
--- compiler/trailing_analysis.m 7 Aug 2007 07:10:07 -0000 1.26
+++ compiler/trailing_analysis.m 9 Aug 2007 08:26:44 -0000
@@ -777,6 +777,8 @@
check_user_type(ModuleInfo, Type).
check_type_2(ModuleInfo, Type, type_cat_enum) =
check_user_type(ModuleInfo, Type).
+check_type_2(ModuleInfo, Type, type_cat_foreign_enum) =
+ check_user_type(ModuleInfo, Type).
check_type_2(ModuleInfo, Type, type_cat_user_ctor) =
check_user_type(ModuleInfo, Type).
Index: compiler/type_ctor_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/type_ctor_info.m,v
retrieving revision 1.88
diff -u -r1.88 type_ctor_info.m
--- compiler/type_ctor_info.m 13 Feb 2007 01:58:51 -0000 1.88
+++ compiler/type_ctor_info.m 9 Aug 2007 08:26:44 -0000
@@ -374,6 +374,10 @@
make_enum_details(Ctors, ConsTagMap, ReservedTag,
EqualityAxioms, Details)
;
+ EnumDummy = is_foreign_enum,
+ make_foreign_enum_details(Ctors, ConsTagMap, ReservedTag,
+ EqualityAxioms, Details)
+ ;
EnumDummy = is_dummy,
make_enum_details(Ctors, ConsTagMap, ReservedTag,
EqualityAxioms, Details)
@@ -629,6 +633,76 @@
svmap.det_insert(FunctorName, EnumFunctor, !NameMap).
%---------------------------------------------------------------------------%
+
+ % Make the functor and layout tables for a foreign enum type.
+ %
+:- pred make_foreign_enum_details(list(constructor)::in, cons_tag_values::in,
+ bool::in, equality_axioms::in, type_ctor_details::out) is det.
+
+make_foreign_enum_details(Ctors, ConsTagMap, ReserveTag, EqualityAxioms,
+ Details) :-
+ (
+ ReserveTag = yes,
+ unexpected(this_file, "foreign enum with reserved tag")
+ ;
+ ReserveTag = no
+ ),
+ make_foreign_enum_functors(Ctors, 0, ConsTagMap, ForeignEnumFunctors),
+ OrdinalMap0 = map.init,
+ NameMap0 = map.init,
+ list.foldl2(make_foreign_enum_maps, ForeignEnumFunctors,
+ OrdinalMap0, OrdinalMap, NameMap0, NameMap),
+ FunctorNumberMap = make_functor_number_map(Ctors),
+ Details = foreign_enum(EqualityAxioms, ForeignEnumFunctors,
+ OrdinalMap, NameMap, FunctorNumberMap).
+
+ % Create a foreign_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
+ % stored them), and that is how we return the list of rtti names of the
+ % foreign_enum_functor_desc structures; that way, it is directly usable in
+ % the type layout structure. We also return a structure that allows our
+ % caller to sort this list on functor name, which is how the type functors
+ % structure is constructed.
+ %
+:- pred make_foreign_enum_functors(list(constructor)::in,
+ int::in, cons_tag_values::in, list(foreign_enum_functor)::out) is det.
+
+make_foreign_enum_functors([], _, _, []).
+make_foreign_enum_functors([Functor | Functors], NextOrdinal0, ConsTagMap,
+ [ForeignEnumFunctor | ForeignEnumFunctors]) :-
+ Functor = ctor(ExistTvars, Constraints, SymName, FunctorArgs, _Context),
+ expect(unify(ExistTvars, []), this_file,
+ "existential arguments in functor in foreign enum"),
+ expect(unify(Constraints, []), this_file,
+ "class constraints on functor in foreign enum"),
+ list.length(FunctorArgs, Arity),
+ expect(unify(Arity, 0), this_file,
+ "functor in foreign enum has nonzero arity"),
+ ConsId = make_cons_id_from_qualified_sym_name(SymName, FunctorArgs),
+ map.lookup(ConsTagMap, ConsId, ConsTag),
+ ( ConsTag = foreign_tag(ForeignTagValue0) ->
+ ForeignTagValue = ForeignTagValue0
+ ;
+ unexpected(this_file, "non foreign tag for foreign enum functor")
+ ),
+ FunctorName = unqualify_name(SymName),
+ ForeignEnumFunctor = foreign_enum_functor(FunctorName, NextOrdinal0,
+ ForeignTagValue),
+ make_foreign_enum_functors(Functors, NextOrdinal0 + 1, ConsTagMap,
+ ForeignEnumFunctors).
+
+:- pred make_foreign_enum_maps(foreign_enum_functor::in,
+ map(int, foreign_enum_functor)::in,
+ map(int, foreign_enum_functor)::out,
+ map(string, foreign_enum_functor)::in,
+ map(string, foreign_enum_functor)::out) is det.
+
+make_foreign_enum_maps(ForeignEnumFunctor, !OrdinalMap, !NameMap) :-
+ ForeignEnumFunctor = foreign_enum_functor(FunctorName, FunctorOrdinal, _),
+ svmap.det_insert(FunctorOrdinal, ForeignEnumFunctor, !OrdinalMap),
+ svmap.det_insert(FunctorName, ForeignEnumFunctor, !NameMap).
+
+%---------------------------------------------------------------------------%
:- type tag_map == map(int,
pair(sectag_locn, map(int, ctor_rtti_name))).
@@ -763,6 +837,7 @@
( ConsTag = no_tag
; ConsTag = string_tag(_)
; ConsTag = int_tag(_)
+ ; ConsTag = foreign_tag(_)
; ConsTag = float_tag(_)
; ConsTag = pred_closure_tag(_, _, _)
; ConsTag = type_ctor_info_tag(_, _, _)
@@ -951,6 +1026,7 @@
% 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 :-
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.178
diff -u -r1.178 type_util.m
--- compiler/type_util.m 3 Jul 2007 03:15:43 -0000 1.178
+++ compiler/type_util.m 9 Aug 2007 08:26:44 -0000
@@ -116,6 +116,9 @@
% A type is a dummy type in one of two cases: either it is a builtin
% dummy type, or it has only a single function symbol of arity zero.
%
+ % Note that types that are the subject of a foreign_enum pragma cannot
+ % be dummy types.
+ %
:- pred is_dummy_argument_type(module_info::in, mer_type::in) is semidet.
% A test for types that are defined in Mercury, but whose definitions
@@ -352,6 +355,7 @@
type_category_is_atomic(type_cat_higher_order) = no.
type_category_is_atomic(type_cat_tuple) = no.
type_category_is_atomic(type_cat_enum) = yes.
+type_category_is_atomic(type_cat_foreign_enum) = yes.
type_category_is_atomic(type_cat_dummy) = yes.
type_category_is_atomic(type_cat_variable) = no.
type_category_is_atomic(type_cat_type_info) = no.
@@ -538,6 +542,8 @@
get_type_defn_body(TypeDefn, TypeBody),
Ctors = TypeBody ^ du_type_ctors,
UserEqCmp = TypeBody ^ du_type_usereq,
+ EnumOrDummy = TypeBody ^ du_type_is_enum,
+ EnumOrDummy \= is_foreign_enum,
constructor_list_represents_dummy_argument_type(Ctors, UserEqCmp)
)
;
@@ -618,6 +624,8 @@
TypeCategory = type_cat_tuple
; type_ctor_is_enumeration(TypeCtor, ModuleInfo) ->
TypeCategory = type_cat_enum
+ ; type_ctor_is_foreign_enumeration(TypeCtor, ModuleInfo) ->
+ TypeCategory = type_cat_foreign_enum
;
TypeCategory = type_cat_user_ctor
)
@@ -635,6 +643,17 @@
%-----------------------------------------------------------------------------%
+:- pred type_ctor_is_foreign_enumeration(type_ctor::in, module_info::in)
+ is semidet.
+
+type_ctor_is_foreign_enumeration(TypeCtor, ModuleInfo) :-
+ module_info_get_type_table(ModuleInfo, TypeDefnTable),
+ map.search(TypeDefnTable, TypeCtor, TypeDefn),
+ get_type_defn_body(TypeDefn, TypeBody),
+ TypeBody ^ du_type_is_enum = is_foreign_enum.
+
+%-----------------------------------------------------------------------------%
+
update_type_may_use_atomic_alloc(ModuleInfo, Type, !MayUseAtomic) :-
(
!.MayUseAtomic = may_not_use_atomic_alloc
@@ -650,6 +669,7 @@
( TypeCategory = type_cat_int
; TypeCategory = type_cat_char
; TypeCategory = type_cat_enum
+ ; TypeCategory = type_cat_foreign_enum
; TypeCategory = type_cat_dummy
; TypeCategory = type_cat_type_ctor_info
),
Index: compiler/unify_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unify_gen.m,v
retrieving revision 1.181
diff -u -r1.181 unify_gen.m
--- compiler/unify_gen.m 7 Aug 2007 07:10:08 -0000 1.181
+++ compiler/unify_gen.m 9 Aug 2007 08:26:44 -0000
@@ -280,6 +280,9 @@
ConsTag = int_tag(Int),
TestRval = binop(eq, Rval, const(llconst_int(Int)))
;
+ ConsTag = foreign_tag(ForeignVal),
+ TestRval = binop(eq, Rval, const(llconst_foreign(ForeignVal, integer)))
+ ;
ConsTag = pred_closure_tag(_, _, _),
% This should never happen, since the error will be detected
% during mode checking.
@@ -387,6 +390,11 @@
code_info.assign_const_to_var(Var, const(llconst_int(Int)), !CI),
Code = empty
;
+ ConsTag = foreign_tag(Val),
+ ForeignConst = const(llconst_foreign(Val, integer)),
+ code_info.assign_const_to_var(Var, ForeignConst, !CI),
+ Code = empty
+ ;
ConsTag = float_tag(Float),
code_info.assign_const_to_var(Var, const(llconst_float(Float)), !CI),
Code = empty
@@ -937,6 +945,7 @@
(
( Tag = string_tag(_String)
; Tag = int_tag(_Int)
+ ; Tag = foreign_tag(_)
; Tag = float_tag(_Float)
; Tag = pred_closure_tag(_, _, _)
; Tag = type_ctor_info_tag(_, _, _)
Index: compiler/unify_proc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unify_proc.m,v
retrieving revision 1.189
diff -u -r1.189 unify_proc.m
--- compiler/unify_proc.m 7 Aug 2007 07:10:08 -0000 1.189
+++ compiler/unify_proc.m 9 Aug 2007 08:26:44 -0000
@@ -779,7 +779,9 @@
(
TypeBody = hlds_du_type(Ctors, _, EnumDummy, _, _, _),
(
- EnumDummy = is_enum,
+ ( EnumDummy = is_foreign_enum
+ ; EnumDummy = is_enum
+ ),
make_simple_test(X, Y, umc_explicit, [], Goal),
quantify_clause_body([X, Y], Goal, Context, Clause, !Info)
;
@@ -859,8 +861,11 @@
TypeCategory = type_cat_enum,
unexpected(this_file, "generate_builtin_unify: enum")
;
+ TypeCategory = type_cat_foreign_enum,
+ unexpected(this_file, "generate_builtin_unify: foreign enum")
+ ;
TypeCategory = type_cat_dummy,
- unexpected(this_file, "generate_builtin_unify: enum")
+ unexpected(this_file, "generate_builtin_unify: dummy")
;
TypeCategory = type_cat_variable,
unexpected(this_file, "generate_builtin_unify: variable type")
@@ -986,7 +991,9 @@
% an integer comparison, and does not call the type's index
% predicate, so do not generate an index predicate for such
% types.
- EnumDummy = is_enum,
+ ( EnumDummy = is_enum
+ ; EnumDummy = is_foreign_enum
+ ),
unexpected(this_file,
"trying to create index proc for enum type")
;
@@ -1044,7 +1051,9 @@
(
TypeBody = hlds_du_type(Ctors0, _, EnumDummy, _, _, _),
(
- EnumDummy = is_enum,
+ ( EnumDummy = is_enum
+ ; EnumDummy = is_foreign_enum
+ ),
generate_enum_compare_proc_body(Res, X, Y, Context, Clause,
!Info)
;
@@ -1180,6 +1189,9 @@
TypeCategory = type_cat_enum,
unexpected(this_file, "generate_builtin_compare: enum type")
;
+ TypeCategory = type_cat_foreign_enum,
+ unexpected(this_file, "generate_builtin_compare: foreign enum type")
+ ;
TypeCategory = type_cat_dummy,
unexpected(this_file, "generate_builtin_compare: dummy type")
;
Index: doc/reference_manual.texi
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/doc/reference_manual.texi,v
retrieving revision 1.401
diff -u -r1.401 reference_manual.texi
--- doc/reference_manual.texi 25 Jul 2007 06:12:28 -0000 1.401
+++ doc/reference_manual.texi 9 Aug 2007 08:26:44 -0000
@@ -6179,6 +6179,9 @@
* Using Mercury enumerations in foreign code:: How to use an enumeration type
defined in Mercury in a
different programming language.
+* Using foreign enumerations in Mercury code:: How to use an enumeration type
+ defined in a foreign language
+ in Mercury code.
* Data passing conventions:: How Mercury types are passed to
different languages.
* Adding foreign declarations:: How to add declarations of
@@ -6929,7 +6932,7 @@
a declaration of the form:
@example
-:- pragma foreign_export_enum(@var{Lang}, @var{MercuryType},
+:- pragma foreign_export_enum("@var{Lang}", @var{MercuryType},
@var{Attributes}, @var{Overrides}).
@end example
@@ -6998,6 +7001,56 @@
@c -----------------------------------------------------------------------
+ at node Using foreign enumerations in Mercury code
+ at section Using foreign enumerations in Mercury code
+
+The values used to represent a Mercury enumeration type in a foreign
+language may be explicitly assigned by the programmer using a declaration
+of the form:
+
+ at example
+:- pragma foreign_enum("@var{Lang}", @var{MercuryType}, @var{CtorValues}).
+ at end example
+
+ at var{CtorValues} is a list of pairs of the form:
+
+ at example
+[
+ ctor_0 - "ForeignValue_0",
+ ctor_1 - "ForeignValue_1",
+ ...
+ ctor_N - "ForeignValue_N"
+]
+ at end example
+
+The first element of each pair is a constructor of the type @var{MercuryType},
+and the second is a value in the language @var{Lang} that will be used
+to represent that constructor.
+The mapping defined by this list of pairs must form a bijection.
+
+Mercury implementations may impose further foreign language-specific
+restrictions on the form that values used to represent enumeration
+constructors may take.
+See the language specific information below for details.
+
+The Mercury implementation is not required to check the validity of
+foreign enumeration values.
+
+A @samp{pragma foreign_enum} declaration must occur in the implementation
+section of the module that defines the type @var{MercuryType}.
+It is an error if the type @var{MercuryType} is the subject of more than
+one @samp{pragma foreign_enum} declaration for a given foreign language.
+
+Note that the default comparison for types that are the subject of a
+ at samp{pragma foreign_enum} declaration will be defined by the foreign
+values, rather than the order of the constructors in the
+type declaration (as is usually the case).
+
+ at c XXX we need to specify a behaviour when there are multiple supported
+ at c foreign languages.
+
+ at c -----------------------------------------------------------------------
+
@node Adding foreign declarations
@section Adding foreign declarations
@@ -7018,8 +7071,8 @@
Entities declared in @samp{pragma foreign_decl} declarations are
visible in @samp{pragma foreign_code}, @samp{pragma foreign_type},
-and @samp{pragma foreign_proc} declarations that specify the same foreign
-language and occur in the same Mercury module.
+ at samp{pragma foreign_proc}, and @samp{pragma foreign_enum} declarations
+that specify the same foreign language and occur in the same Mercury module.
By default, the contents of @samp{pragma foreign_decl} declarations
are also visible in the same kinds of declarations in other modules
@@ -7154,6 +7207,8 @@
@menu
* Using pragma foreign_type for C :: Declaring C types in Mercury
* Using pragma foreign_export_enum for C :: Using Mercury enumerations in C
+* Using pragma foreign_enum for C :: Assigning Mercury enumerations
+ values in C
* Using pragma foreign_proc for C :: Calling C code from Mercury
* Using pragma foreign_export for C :: Calling Mercury code from C
* Using pragma foreign_decl for C :: Including C declarations in Mercury
@@ -7229,6 +7284,13 @@
@c It would be useful if there were some documented way of mapping
@c these things into [0, N - 1], e.g. for array lookups.
+ at node Using pragma foreign_enum for C
+ at subsubsection Using pragma foreign_enum for C
+
+Foreign enumeration values in C must be constants of type @samp{MR_Integer}.
+They may be specified as either integer literals or via preprocessor macros
+that expand to integer literals.
+
@node Using pragma foreign_proc for C
@subsubsection Using pragma foreign_proc for C
@@ -7477,7 +7539,7 @@
@node Using pragma foreign_export for C#
@subsubsection Using pragma foreign_export for C#
- at samp{pramga foreign_export} is not currently supported for C#.
+ at samp{pragma foreign_export} is not currently supported for C#.
@node Using pragma foreign_decl for C#
@subsubsection Using pragma foreign_decl for C#
@@ -9500,7 +9562,7 @@
users may think the program has gone into an infinite loop:
periodically printing a progress message can give them reassurance.
Another example is a program that is
-too long-running for its behavior to be analyzed via debuggers
+too long-running for its behaviour to be analyzed via debuggers
and too complex for analysis via profilers;
a programmable logging facility generating data
for analysis by a specially-written program may be the best option.
Index: java/runtime/ForeignEnumFunctorDesc.java
===================================================================
RCS file: java/runtime/ForeignEnumFunctorDesc.java
diff -N java/runtime/ForeignEnumFunctorDesc.java
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ java/runtime/ForeignEnumFunctorDesc.java 9 Aug 2007 08:26:44 -0000
@@ -0,0 +1,20 @@
+//
+// Copyright (C) 2007 The University of Melbourne.
+// This file may only be copied under the terms of the GNU Library General
+// Public License - see the file COPYING.LIB in the Mercury distribution.
+//
+
+package mercury.runtime;
+
+public class ForeignEnumFunctorDesc {
+
+ public java.lang.String foreign_enum_functor_name;
+ public int foreign_enum_functor_ordinal;
+ public int foreign_enum_functor_value;
+
+ public ForeignEnumFunctorDesc(String name, int ordinal, int value) {
+ foreign_enum_functor_name = name;
+ foreign_enum_functor_ordinal = ordinal;
+ foreign_enum_functor_value = value
+ }
+}
Index: java/runtime/TypeFunctors.java
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/java/runtime/TypeFunctors.java,v
retrieving revision 1.2
diff -u -r1.2 TypeFunctors.java
--- java/runtime/TypeFunctors.java 1 Dec 2003 06:55:51 -0000 1.2
+++ java/runtime/TypeFunctors.java 9 Aug 2007 08:26:44 -0000
@@ -22,6 +22,9 @@
public mercury.runtime.EnumFunctorDesc[] functors_enum() {
return (mercury.runtime.EnumFunctorDesc[]) functors_init;
}
+ public mercury.runtime.ForeignFunctorDesc[] functors_foreign_enum() {
+ return (mercury.runtime.ForeignEnumFunctorDesc[]) functors_init;
+ }
public mercury.runtime.NotagFunctorDesc functors_notag() {
return (mercury.runtime.NotagFunctorDesc) functors_init;
}
Index: library/construct.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/construct.m,v
retrieving revision 1.36
diff -u -r1.36 construct.m
--- library/construct.m 25 Jul 2007 03:08:50 -0000 1.36
+++ library/construct.m 9 Aug 2007 08:26:44 -0000
@@ -250,8 +250,8 @@
get_functor_with_names_internal(TypeDesc, FunctorNumber, FunctorName, Arity,
MaybeTypeInfoList, Names) :-
( erlang_rtti_implementation.is_erlang_backend ->
- erlang_rtti_implementation.get_functor_with_names(TypeDesc, FunctorNumber,
- FunctorName, Arity, TypeInfoList, Names)
+ 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)
@@ -389,6 +389,12 @@
Ordinal = construct_info.functor_info.
enum_functor_desc->MR_enum_functor_ordinal;
break;
+
+ case MR_TYPECTOR_REP_FOREIGN_ENUM:
+ case MR_TYPECTOR_REP_FOREIGN_ENUM_USEREQ:
+ Ordinal = construct_info.functor_info.
+ foreign_enum_functor_desc->MR_foreign_enum_functor_ordinal;
+ break;
case MR_TYPECTOR_REP_DUMMY:
case MR_TYPECTOR_REP_NOTAG:
@@ -523,6 +529,12 @@
new_data = construct_info.functor_info.enum_functor_desc->
MR_enum_functor_ordinal;
break;
+
+ case MR_TYPECTOR_REP_FOREIGN_ENUM:
+ case MR_TYPECTOR_REP_FOREIGN_ENUM_USEREQ:
+ new_data = construct_info.functor_info.foreign_enum_functor_desc->
+ MR_foreign_enum_functor_value;
+ break;
case MR_TYPECTOR_REP_NOTAG:
case MR_TYPECTOR_REP_NOTAG_USEREQ:
Index: library/rtti_implementation.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/rtti_implementation.m,v
retrieving revision 1.80
diff -u -r1.80 rtti_implementation.m
--- library/rtti_implementation.m 25 Jul 2007 03:08:50 -0000 1.80
+++ library/rtti_implementation.m 9 Aug 2007 08:26:44 -0000
@@ -112,6 +112,7 @@
%
% The type_ctor_rep needs to be kept up to date with the real
% definition in runtime/mercury_type_info.h.
+ %
:- type type_ctor_rep
---> tcr_enum
; tcr_enum_usereq
@@ -157,6 +158,8 @@
; tcr_pseudo_type_desc
; tcr_dummy
; tcr_bitmap
+ ; tcr_foreign_enum
+ ; tcr_foreign_enum_usereq
; tcr_unknown.
% We keep all the other types abstract.
@@ -946,7 +949,7 @@
% There are many cases to implement here, only the ones that were
% immediately useful (e.g. called by io.write) have been implemented
% so far.
-
+ %
deconstruct_2(Term, TypeInfo, TypeCtorInfo, TypeCtorRep, NonCanon,
Functor, Arity, Arguments) :-
(
@@ -962,6 +965,18 @@
Arity = 0,
Arguments = []
;
+ TypeCtorRep = tcr_foreign_enum,
+ TypeFunctors = type_ctor_functors(TypeCtorInfo),
+ ForeignEnumFunctorDesc = foreign_enum_functor_desc(TypeCtorRep,
+ unsafe_get_foreign_enum_value(Term), TypeFunctors),
+ Functor = foreign_enum_functor_name(ForeignEnumFunctorDesc),
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = tcr_foreign_enum_usereq,
+ handle_usereq_type(Term, TypeInfo, TypeCtorInfo, TypeCtorRep,
+ NonCanon, Functor, Arity, Arguments)
+ ;
TypeCtorRep = tcr_dummy,
TypeFunctors = type_ctor_functors(TypeCtorInfo),
EnumFunctorDesc = enum_functor_desc(TypeCtorRep, 0, TypeFunctors),
@@ -1256,12 +1271,16 @@
same_array_elem_type(_, _).
-:- inst usereq == bound(tcr_enum_usereq ; tcr_du_usereq ; tcr_notag_usereq ;
- tcr_notag_ground_usereq ; tcr_reserved_addr_usereq).
+:- inst usereq
+ ---> tcr_enum_usereq
+ ; tcr_foreign_enum_usereq
+ ; tcr_du_usereq
+ ; tcr_notag_usereq
+ ; tcr_notag_ground_usereq
+ ; tcr_reserved_addr_usereq.
:- pred handle_usereq_type(T, type_info, type_ctor_info, type_ctor_rep,
- noncanon_handling, string, int, list(univ)).
-
+ noncanon_handling, string, int, list(univ)).
:- mode handle_usereq_type(in, in, in, in(usereq),
in(do_not_allow), out, out, out) is erroneous.
:- mode handle_usereq_type(in, in, in, in(usereq),
@@ -1287,6 +1306,9 @@
TypeCtorRep = tcr_enum_usereq,
BaseTypeCtorRep = tcr_enum
;
+ TypeCtorRep = tcr_foreign_enum_usereq,
+ BaseTypeCtorRep = tcr_foreign_enum
+ ;
TypeCtorRep = tcr_du_usereq,
BaseTypeCtorRep = tcr_du
;
@@ -2329,6 +2351,10 @@
:- pragma foreign_type("Java", enum_functor_desc,
"mercury.runtime.EnumFunctorDesc").
+:- type foreign_enum_functor_desc ---> foreign_enum_functor_desc(c_pointer).
+:- pragma foreign_type("Java", foreign_enum_functor_desc,
+ "mercury.runtime.ForeignEnumFunctorDesc").
+
:- type notag_functor_desc ---> notag_functor_desc(c_pointer).
:- pragma foreign_type("Java", notag_functor_desc,
"mercury.runtime.NotagFunctorDesc").
@@ -2336,6 +2362,7 @@
:- inst du == bound(tcr_du ; tcr_du_usereq ; tcr_reserved_addr ;
tcr_reserved_addr_usereq).
:- inst enum == bound(tcr_enum ; tcr_enum_usereq ; tcr_dummy).
+:- inst foreign_enum == bound(tcr_foreign_enum ; tcr_foreign_enum_usereq).
:- inst notag == bound(tcr_notag ; tcr_notag_usereq ;
tcr_notag_ground ; tcr_notag_ground_usereq).
@@ -2516,6 +2543,35 @@
%--------------------------%
+:- func foreign_enum_functor_desc(type_ctor_rep, int, type_functors)
+ = foreign_enum_functor_desc.
+:- mode foreign_enum_functor_desc(in(foreign_enum), in, in) = out is det.
+
+foreign_enum_functor_desc(_, Num, TypeFunctors) = ForeignEnumFunctorDesc :-
+ ForeignEnumFunctorDesc = TypeFunctors ^ unsafe_index(Num).
+
+:- pragma foreign_proc("Java",
+ foreign_enum_functor_desc(_TypeCtorRep::in(foreign_enum), X::in,
+ TypeFunctors::in) = (ForeignEnumFunctorDesc::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ ForeignEnumFunctorDesc = (TypeFunctors.functors_enum())[X];
+").
+
+:- func foreign_enum_functor_name(foreign_enum_functor_desc) = string.
+
+foreign_enum_functor_name(ForeignEnumFunctorDesc) =
+ ForeignEnumFunctorDesc ^ unsafe_index(0).
+
+:- pragma foreign_proc("Java",
+ foreign_enum_functor_name(ForeignEnumFunctorDesc::in) = (Name::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Name = ForeignEnumFunctorDesc.enum_functor_name;
+").
+
+ %--------------------------%
+
:- func notag_functor_desc(type_ctor_rep, int, type_functors)
= notag_functor_desc.
@@ -2669,3 +2725,17 @@
private_builtin.sorry("rtti_implementation.unsafe_get_enum_value/1").
%-----------------------------------------------------------------------------%
+
+:- func unsafe_get_foreign_enum_value(T) = int.
+
+% XXX We cannot provide a Java version of this until mlds_to_java.m is
+% updated to support foreign enumerations.
+
+unsafe_get_foreign_enum_value(_) = _ :-
+ % This version is only used for back-ends for which there is no
+ % matching foreign_proc version.
+ private_builtin.sorry(
+ "rtti_implementation.unsafe_get_foreign_enum_value/1").
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
Index: runtime/mercury_construct.c
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_construct.c,v
retrieving revision 1.16
diff -u -r1.16 mercury_construct.c
--- runtime/mercury_construct.c 13 Feb 2007 01:58:56 -0000 1.16
+++ runtime/mercury_construct.c 9 Aug 2007 08:26:44 -0000
@@ -101,6 +101,29 @@
}
return MR_TRUE;
+ case MR_TYPECTOR_REP_FOREIGN_ENUM:
+ case MR_TYPECTOR_REP_FOREIGN_ENUM_USEREQ:
+ {
+ const MR_ForeignEnumFunctorDesc *functor_desc;
+
+ if (functor_number < 0 ||
+ functor_number >= MR_type_ctor_num_functors(type_ctor_info))
+ {
+ MR_fatal_error("MR_get_functor_info: "
+ "foreign enum functor_number out of range");
+ }
+ functor_desc = MR_type_ctor_functors(type_ctor_info).
+ MR_functors_foreign_enum[functor_number];
+ construct_info->functor_info.foreign_enum_functor_desc
+ = functor_desc;
+ construct_info->functor_name =
+ functor_desc->MR_foreign_enum_functor_name;
+ construct_info->arity = 0;
+ construct_info->arg_pseudo_type_infos = NULL;
+ construct_info->arg_names = NULL;
+ }
+ return MR_TRUE;
+
case MR_TYPECTOR_REP_NOTAG:
case MR_TYPECTOR_REP_NOTAG_USEREQ:
case MR_TYPECTOR_REP_NOTAG_GROUND:
@@ -291,6 +314,8 @@
case MR_TYPECTOR_REP_ENUM:
case MR_TYPECTOR_REP_ENUM_USEREQ:
case MR_TYPECTOR_REP_DUMMY:
+ case MR_TYPECTOR_REP_FOREIGN_ENUM:
+ case MR_TYPECTOR_REP_FOREIGN_ENUM_USEREQ:
return MR_type_ctor_num_functors(type_ctor_info);
case MR_TYPECTOR_REP_NOTAG:
Index: runtime/mercury_construct.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_construct.h,v
retrieving revision 1.3
diff -u -r1.3 mercury_construct.h
--- runtime/mercury_construct.h 21 Jun 2005 03:12:02 -0000 1.3
+++ runtime/mercury_construct.h 9 Aug 2007 08:26:44 -0000
@@ -20,6 +20,7 @@
union MR_Construct_Functor_Union {
const MR_EnumFunctorDesc *enum_functor_desc;
+ const MR_ForeignEnumFunctorDesc *foreign_enum_functor_desc;
const MR_NotagFunctorDesc *notag_functor_desc;
const MR_DuFunctorDesc *du_functor_desc;
};
Index: runtime/mercury_deconstruct.c
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_deconstruct.c,v
retrieving revision 1.21
diff -u -r1.21 mercury_deconstruct.c
--- runtime/mercury_deconstruct.c 13 Feb 2007 01:58:56 -0000 1.21
+++ runtime/mercury_deconstruct.c 9 Aug 2007 08:26:44 -0000
@@ -298,6 +298,8 @@
case MR_TYPECTOR_REP_ARRAY:
case MR_TYPECTOR_REP_FOREIGN:
case MR_TYPECTOR_REP_STABLE_FOREIGN:
+ case MR_TYPECTOR_REP_FOREIGN_ENUM:
+ case MR_TYPECTOR_REP_FOREIGN_ENUM_USEREQ:
case MR_TYPECTOR_REP_UNKNOWN:
return MR_FALSE;
}
Index: runtime/mercury_deep_copy_body.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_deep_copy_body.h,v
retrieving revision 1.72
diff -u -r1.72 mercury_deep_copy_body.h
--- runtime/mercury_deep_copy_body.h 13 Feb 2007 01:58:56 -0000 1.72
+++ runtime/mercury_deep_copy_body.h 9 Aug 2007 08:26:44 -0000
@@ -103,6 +103,8 @@
case MR_TYPECTOR_REP_ENUM:
case MR_TYPECTOR_REP_ENUM_USEREQ:
+ case MR_TYPECTOR_REP_FOREIGN_ENUM:
+ case MR_TYPECTOR_REP_FOREIGN_ENUM_USEREQ:
return data; /* just a copy of the actual item */
case MR_TYPECTOR_REP_DUMMY:
Index: runtime/mercury_ml_expand_body.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_ml_expand_body.h,v
retrieving revision 1.40
diff -u -r1.40 mercury_ml_expand_body.h
--- runtime/mercury_ml_expand_body.h 13 Feb 2007 01:58:57 -0000 1.40
+++ runtime/mercury_ml_expand_body.h 9 Aug 2007 08:26:44 -0000
@@ -316,6 +316,61 @@
handle_zero_arity_args();
return;
+ case MR_TYPECTOR_REP_FOREIGN_ENUM_USEREQ:
+ if (noncanon == MR_NONCANON_ABORT) {
+ /* XXX should throw an exception */
+ MR_fatal_error(MR_STRINGIFY(EXPAND_FUNCTION_NAME)
+ ": attempt to deconstruct noncanonical term");
+ return;
+ } else if (noncanon == MR_NONCANON_ALLOW) {
+ handle_noncanonical_name(type_ctor_info);
+ handle_zero_arity_args();
+ return;
+ }
+ /* else fall through */
+
+ case MR_TYPECTOR_REP_FOREIGN_ENUM:
+ {
+ /*
+ ** For foreign enumerations we cannot use the value as index
+ ** into the type layout, since we just have to do a linear
+ ** search.
+ */
+ int i;
+ int num_functors;
+ MR_ConstString functor_name = NULL;
+ MR_int_least32_t functor_ordinal = -1;
+ MR_int_least32_t functor_value;
+
+ num_functors = MR_type_ctor_num_functors(type_ctor_info);
+
+ for (i = 0; i < num_functors; i++) {
+ functor_value = MR_type_ctor_layout(type_ctor_info).
+ MR_layout_foreign_enum[i]->MR_foreign_enum_functor_value;
+
+ if (functor_value == *data_word_ptr) {
+
+ functor_name = MR_type_ctor_layout(type_ctor_info).
+ MR_layout_foreign_enum[i]->
+ MR_foreign_enum_functor_name;
+
+ functor_ordinal = MR_type_ctor_layout(type_ctor_info).
+ MR_layout_foreign_enum[i]->
+ MR_foreign_enum_functor_ordinal;
+
+ break;
+ }
+ }
+
+ MR_assert(functor_name != NULL);
+ MR_assert(functor_ordinal != -1);
+
+ handle_functor_name(functor_name);
+ handle_type_functor_number(type_ctor_info, functor_ordinal);
+ handle_zero_arity_args();
+ }
+ return;
+
case MR_TYPECTOR_REP_DUMMY:
/*
** We must not refer to the "value" we are asked to deconstruct,
Index: runtime/mercury_table_type_body.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_table_type_body.h,v
retrieving revision 1.4
diff -u -r1.4 mercury_table_type_body.h
--- runtime/mercury_table_type_body.h 13 Feb 2007 01:58:57 -0000 1.4
+++ runtime/mercury_table_type_body.h 9 Aug 2007 08:26:44 -0000
@@ -32,7 +32,9 @@
switch (MR_type_ctor_rep(type_ctor_info)) {
case MR_TYPECTOR_REP_ENUM:
- case MR_TYPECTOR_REP_ENUM_USEREQ:
+ case MR_TYPECTOR_REP_ENUM_USEREQ:
+ case MR_TYPECTOR_REP_FOREIGN_ENUM:
+ case MR_TYPECTOR_REP_FOREIGN_ENUM_USEREQ:
MR_TABLE_ENUM(STATS, DEBUG, BACK, table_next, table,
MR_type_ctor_num_functors(type_ctor_info), data);
table = table_next;
Index: runtime/mercury_term_size.c
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_term_size.c,v
retrieving revision 1.6
diff -u -r1.6 mercury_term_size.c
--- runtime/mercury_term_size.c 18 Feb 2007 08:01:56 -0000 1.6
+++ runtime/mercury_term_size.c 9 Aug 2007 08:26:44 -0000
@@ -229,6 +229,16 @@
}
#endif
return 0;
+
+ case MR_TYPECTOR_REP_FOREIGN_ENUM:
+ case MR_TYPECTOR_REP_FOREIGN_ENUM_USEREQ:
+#ifdef MR_DEBUG_TERMSIZES
+ if (MR_heapdebug && MR_lld_print_enabled) {
+ printf("MR_term_size: foreign enum (usereq) %p\n",
+ (void *) term);
+ }
+#endif
+ return 0;
case MR_TYPECTOR_REP_INT:
#ifdef MR_DEBUG_TERM_SIZES
Index: runtime/mercury_type_info.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_type_info.h,v
retrieving revision 1.127
diff -u -r1.127 mercury_type_info.h
--- runtime/mercury_type_info.h 31 Jul 2007 07:58:44 -0000 1.127
+++ runtime/mercury_type_info.h 9 Aug 2007 08:26:44 -0000
@@ -644,6 +644,8 @@
MR_DEFINE_BUILTIN_ENUM_CONST(MR_TYPECTOR_REP_PSEUDOTYPEDESC),
MR_DEFINE_BUILTIN_ENUM_CONST(MR_TYPECTOR_REP_DUMMY),
MR_DEFINE_BUILTIN_ENUM_CONST(MR_TYPECTOR_REP_BITMAP),
+ MR_DEFINE_BUILTIN_ENUM_CONST(MR_TYPECTOR_REP_FOREIGN_ENUM),
+ MR_DEFINE_BUILTIN_ENUM_CONST(MR_TYPECTOR_REP_FOREIGN_ENUM_USEREQ),
/*
** MR_TYPECTOR_REP_UNKNOWN should remain the last alternative;
** MR_TYPE_CTOR_STATS depends on this.
@@ -715,6 +717,8 @@
"PSEUDO_TYPE_DESC", \
"DUMMY", \
"BITMAP", \
+ "FOREIGN_ENUM", \
+ "FOREIGN_ENUM_USEREQ", \
"UNKNOWN"
extern MR_ConstString MR_ctor_rep_name[];
@@ -923,6 +927,16 @@
/*---------------------------------------------------------------------------*/
typedef struct {
+ MR_ConstString MR_foreign_enum_functor_name;
+ MR_int_least32_t MR_foreign_enum_functor_ordinal;
+ MR_int_least32_t MR_foreign_enum_functor_value;
+} MR_ForeignEnumFunctorDesc;
+
+typedef const MR_ForeignEnumFunctorDesc *MR_ForeignEnumFunctorDescPtr;
+
+/*---------------------------------------------------------------------------*/
+
+typedef struct {
MR_ConstString MR_notag_functor_name;
MR_PseudoTypeInfo MR_notag_functor_arg_type;
MR_ConstString MR_notag_functor_arg_name;
@@ -981,6 +995,7 @@
**
** The intention is that if you have a word in an enum type that you want to
** interpret, you index into the array with the word.
+**
*/
typedef MR_EnumFunctorDesc **MR_EnumTypeLayout;
@@ -988,6 +1003,24 @@
/*---------------------------------------------------------------------------*/
/*
+** This type describes the function symbols in a foreign enum type.
+**
+** An MR_ForeignEnumLayout points to an array of pointers to functor
+** descriptors. There is one pointer for each of the function symbols, and
+** thus the size of the array is given by the num_functors field of the
+** type_ctor_info. The array is ordered by declaration order,
+**
+** NOTE: it is not possible to order this array by the integer value by
+** which the functor is represented since for foreign enums these
+** may be #defined constants and their actual value will not be known
+** at the time the ForeignEnumLayout structures are generated.
+*/
+
+typedef MR_ForeignEnumFunctorDesc **MR_ForeignEnumTypeLayout;
+
+/*---------------------------------------------------------------------------*/
+
+/*
** This type describes the single function symbol in a notag type.
**
** An MR_NotagLayout points to the one functor descriptor of the type.
@@ -1068,7 +1101,7 @@
/*
** This type describes the layout in any kind of discriminated union
-** type: du, enum, notag, or reserved_addr.
+** type: du, enum, foreign_enum, notag, or reserved_addr.
** In an equivalence type, it gives the identity of the equivalent-to type.
**
** The layout_init alternative is used only for static initializers,
@@ -1081,6 +1114,7 @@
const void *MR_layout_init;
MR_DuTypeLayout MR_layout_du;
MR_EnumTypeLayout MR_layout_enum;
+ MR_ForeignEnumTypeLayout MR_layout_foreign_enum;
MR_NotagTypeLayout MR_layout_notag;
MR_ReservedAddrTypeLayout MR_layout_reserved_addr;
MR_EquivLayout MR_layout_equiv;
@@ -1105,13 +1139,13 @@
/*
** This type describes the function symbols in any kind of discriminated union
-** type: du, reserved_addr, enum and notag.
+** type: du, reserved_addr, enum, foreign_enum, and notag.
**
** The pointer in the union points to either an array of pointers to functor
-** descriptors (for du and enum types), to an array of functor descriptors
-** (for reserved_addr types) or to a single functor descriptor (for notag
-** types). There is one functor descriptor for each function symbol, and thus
-** the size of the array is given by the num_functors field of the
+** descriptors (for du, enum and foreign enum types), to an array of functor
+** descriptors (for reserved_addr types) or to a single functor descriptor
+** (for notag types). There is one functor descriptor for each function symbol,
+** and thus the size of the array is given by the num_functors field of the
** type_ctor_info. Arrays are ordered on the name of the function symbol,
** and then on arity.
**
@@ -1127,6 +1161,7 @@
MR_DuFunctorDesc **MR_functors_du;
MR_MaybeResAddrFunctorDesc *MR_functors_res;
MR_EnumFunctorDesc **MR_functors_enum;
+ MR_ForeignEnumFunctorDesc **MR_functors_foreign_enum;
MR_NotagFunctorDesc *MR_functors_notag;
} MR_TypeFunctors;
Index: runtime/mercury_unify_compare_body.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_unify_compare_body.h,v
retrieving revision 1.47
diff -u -r1.47 mercury_unify_compare_body.h
--- runtime/mercury_unify_compare_body.h 17 Apr 2007 05:44:14 -0000 1.47
+++ runtime/mercury_unify_compare_body.h 9 Aug 2007 08:26:44 -0000
@@ -441,6 +441,7 @@
case MR_TYPECTOR_REP_BITMAP:
case MR_TYPECTOR_REP_FOREIGN:
case MR_TYPECTOR_REP_STABLE_FOREIGN:
+ case MR_TYPECTOR_REP_FOREIGN_ENUM_USEREQ:
/*
** In deep profiling grades, the caller of builtin.unify or
@@ -584,9 +585,11 @@
#ifdef include_compare_rep_code
case MR_TYPECTOR_REP_ENUM_USEREQ:
+ case MR_TYPECTOR_REP_FOREIGN_ENUM_USEREQ:
/* fall through */
#endif
case MR_TYPECTOR_REP_ENUM:
+ case MR_TYPECTOR_REP_FOREIGN_ENUM:
case MR_TYPECTOR_REP_INT:
case MR_TYPECTOR_REP_CHAR:
Index: tests/hard_coded/.cvsignore
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/hard_coded/.cvsignore,v
retrieving revision 1.29
diff -u -r1.29 .cvsignore
--- tests/hard_coded/.cvsignore 25 Jul 2007 06:40:17 -0000 1.29
+++ tests/hard_coded/.cvsignore 9 Aug 2007 08:26:44 -0000
@@ -1,9 +1,15 @@
*.dep
*.d
+*.date
*.dv
*.c *.out *.res
+*.int
+*.int2
*.err
*.mh
+*.mih
+*.opt
+*.optdate
*.res1
*.gz
*.c_date
@@ -41,11 +47,15 @@
existential_reordering
expand
export_test
+exported_foreign_enum
factt
factt_non
float_map
float_reg
float_rounding_bug
+foreign_enum_dummy
+foreign_enum_mod1
+foreign_enum_rtti
free_free_mode
func_and_pred
func_ctor_ambig
Index: tests/hard_coded/Mercury.options
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/hard_coded/Mercury.options,v
retrieving revision 1.26
diff -u -r1.26 Mercury.options
--- tests/hard_coded/Mercury.options 25 Jun 2007 00:58:14 -0000 1.26
+++ tests/hard_coded/Mercury.options 9 Aug 2007 08:26:44 -0000
@@ -12,6 +12,8 @@
MCFLAGS-lp = --intermodule-optimization -O3
MCFLAGS-boyer = --infer-all
MCFLAGS-float_consistency = --optimize-constant-propagation
+MCFLAGS-foreign_enum_mod1 = --intermodule-optimization
+MCFLAGS-foreign_enum_mod2 = --intermodule-optimization
MCFLAGS-func_test = --infer-all
MCFLAGS-ho_order = --optimize-higher-order
MCFLAGS-ho_order2 = --optimize-higher-order
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/hard_coded/Mmakefile,v
retrieving revision 1.328
diff -u -r1.328 Mmakefile
--- tests/hard_coded/Mmakefile 3 Aug 2007 05:18:38 -0000 1.328
+++ tests/hard_coded/Mmakefile 9 Aug 2007 08:26:44 -0000
@@ -77,6 +77,7 @@
existential_types_test \
expand \
export_test \
+ exported_foreign_enum \
external_unification_pred \
failure_unify \
field_syntax \
@@ -86,6 +87,9 @@
float_reg \
float_rounding_bug \
foreign_and_mercury \
+ foreign_enum_dummy \
+ foreign_enum_mod1 \
+ foreign_enum_rtti \
foreign_import_module \
foreign_name_mutable \
foreign_type \
Index: tests/hard_coded/exported_foreign_enum.exp
===================================================================
RCS file: tests/hard_coded/exported_foreign_enum.exp
diff -N tests/hard_coded/exported_foreign_enum.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/exported_foreign_enum.exp 9 Aug 2007 08:26:44 -0000
@@ -0,0 +1 @@
+Success.
Index: tests/hard_coded/exported_foreign_enum.m
===================================================================
RCS file: tests/hard_coded/exported_foreign_enum.m
diff -N tests/hard_coded/exported_foreign_enum.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/exported_foreign_enum.m 9 Aug 2007 08:26:44 -0000
@@ -0,0 +1,42 @@
+% Test that foreign_enums can be re-exported using pragma foreign_export_enum.
+:- module exported_foreign_enum.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+
+main(!IO) :-
+ ( test(bar) ->
+ io.write_string("Success.\n", !IO)
+ ;
+ io.write_string("ERROR.\n", !IO)
+ ).
+
+:- pred test(foo::in) is semidet.
+
+:- pragma foreign_proc("C",
+ test(X::in),
+ [will_not_call_mercury, promise_pure],
+"
+ if (X == FOO_bar) {
+ SUCCESS_INDICATOR = MR_TRUE;
+ } else {
+ SUCCESS_INDICATOR = MR_FALSE;
+ }
+").
+
+:- pragma foreign_export_enum("C", foo/0, [prefix("FOO_")]).
+
+:- type foo
+ ---> foo
+ ; bar
+ ; baz.
+
+:- pragma foreign_enum("C", foo/0, [
+ foo - "400",
+ bar - "500",
+ baz - "600"
+]).
Index: tests/hard_coded/foreign_enum_dummy.exp
===================================================================
RCS file: tests/hard_coded/foreign_enum_dummy.exp
diff -N tests/hard_coded/foreign_enum_dummy.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/foreign_enum_dummy.exp 9 Aug 2007 08:26:44 -0000
@@ -0,0 +1 @@
+Success.
Index: tests/hard_coded/foreign_enum_dummy.m
===================================================================
RCS file: tests/hard_coded/foreign_enum_dummy.m
diff -N tests/hard_coded/foreign_enum_dummy.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/foreign_enum_dummy.m 9 Aug 2007 08:26:44 -0000
@@ -0,0 +1,33 @@
+% Check that the dummy type optimisation is disabled for foreign enumerations.
+:- module foreign_enum_dummy.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+
+:- import_module bool.
+
+main(!IO) :-
+ ( test(foo) ->
+ io.write_string("Success.\n", !IO)
+ ;
+ io.write_string("Failure.\n", !IO)
+ ).
+
+:- pred test(foo::in) is semidet.
+:- pragma foreign_proc("C",
+ test(FOO::in),
+ [will_not_call_mercury, promise_pure],
+"
+ if (FOO == 561) {
+ SUCCESS_INDICATOR = MR_TRUE;
+ } else {
+ SUCCESS_INDICATOR = MR_FALSE;
+ }
+").
+
+:- type foo ---> foo.
+:- pragma foreign_enum("C", foo/0, [foo - "561"]).
Index: tests/hard_coded/foreign_enum_mod1.exp
===================================================================
RCS file: tests/hard_coded/foreign_enum_mod1.exp
diff -N tests/hard_coded/foreign_enum_mod1.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/foreign_enum_mod1.exp 9 Aug 2007 08:26:44 -0000
@@ -0,0 +1,2 @@
+The ingredients are [flour, eggs, milk]
+My instrument is piano
Index: tests/hard_coded/foreign_enum_mod1.m
===================================================================
RCS file: tests/hard_coded/foreign_enum_mod1.m
diff -N tests/hard_coded/foreign_enum_mod1.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/foreign_enum_mod1.m 9 Aug 2007 08:26:44 -0000
@@ -0,0 +1,18 @@
+:- module foreign_enum_mod1.
+:- interface.
+
+:- import_module io.
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+:- import_module list.
+:- import_module foreign_enum_mod2.
+
+main(!IO) :-
+ io.write_string("The ingredients are ", !IO),
+ List = [flour, eggs, milk],
+ io.write(List, !IO),
+ io.nl(!IO),
+ io.write_string("My instrument is ", !IO),
+ io.write(my_instrument, !IO),
+ io.nl(!IO).
Index: tests/hard_coded/foreign_enum_mod2.m
===================================================================
RCS file: tests/hard_coded/foreign_enum_mod2.m
diff -N tests/hard_coded/foreign_enum_mod2.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/foreign_enum_mod2.m 9 Aug 2007 08:26:44 -0000
@@ -0,0 +1,70 @@
+:- module foreign_enum_mod2.
+:- interface.
+
+:- type instrument.
+
+:- type ingredient
+ ---> eggs
+ ; sugar
+ ; flour
+ ; milk.
+
+:- func my_instrument = instrument.
+
+:- implementation.
+
+:- type instrument
+ ---> violin
+ ; piano
+ ; xylophone.
+
+:- type foo
+ ---> foo
+ ; bar
+ ; baz.
+
+my_instrument = piano.
+
+ % This should end up in the .int file.
+ %
+:- pragma foreign_enum("C", ingredient/0, [
+ foreign_enum_mod2.eggs - "EGGS",
+ foreign_enum_mod2.sugar - "SUGAR",
+ foreign_enum_mod2.flour - "FLOUR",
+ foreign_enum_mod2.milk - "MILK"
+]).
+
+ % As should this.
+ %
+:- pragma foreign_enum("Java", ingredient/0, [
+ eggs - "Ingredient.EGGS",
+ sugar - "Ingredient.SUGAR",
+ flour - "Ingredient.FLOUR",
+ milk - "Ingredient.MILK"
+]).
+
+ % This shouldn't since the type is not exported.
+ %
+:- pragma foreign_enum("C", foo/0, [
+ foo - "3",
+ bar - "4",
+ baz - "5"
+]).
+
+ % This shouldn't since the type is abstract.
+ %
+:- pragma foreign_enum("C", instrument/0, [
+ violin - "100",
+ piano - "200",
+ xylophone - "300"
+]).
+
+:- pragma foreign_decl("C", "
+
+#define EGGS 10
+#define SUGAR 20
+#define FLOUR 30
+#define MILK 40
+
+").
+
Index: tests/hard_coded/foreign_enum_rtti.exp
===================================================================
RCS file: tests/hard_coded/foreign_enum_rtti.exp
diff -N tests/hard_coded/foreign_enum_rtti.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/foreign_enum_rtti.exp 9 Aug 2007 08:26:44 -0000
@@ -0,0 +1,38 @@
+Checking io.write for foreign enum ...
+foo
+bar
+baz
+Checking deep copy for foreign enum ...
+[foo, bar, baz]
+Number of functors of foo/0: 3
+Checking construct.get_functor for foreign_enum ...
+functor_number_lex = 0
+ name = bar
+ arity = 0
+ no arguments
+functor_number_lex = 1
+ name = baz
+ arity = 0
+ no arguments
+functor_number_lex = 2
+ name = foo
+ arity = 0
+ no arguments
+Checking construct.get_functor_ordinal for foreign_enum ...
+ lex = 0, ordinal = 1
+ lex = 1, ordinal = 2
+ lex = 2, ordinal = 0
+Checking construct.construct for foreign_enum ...
+ univ_cons(bar)
+ univ_cons(baz)
+ univ_cons(foo)
+Checking deconstruct.deconstruct for foreign_enum ...
+ name = foo
+ arity = 0
+ no args
+ name = bar
+ arity = 0
+ no args
+ name = baz
+ arity = 0
+ no args
Index: tests/hard_coded/foreign_enum_rtti.m
===================================================================
RCS file: tests/hard_coded/foreign_enum_rtti.m
diff -N tests/hard_coded/foreign_enum_rtti.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/foreign_enum_rtti.m 9 Aug 2007 08:26:44 -0000
@@ -0,0 +1,136 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+%
+% Test RTTI foreign enum types.
+%
+%-----------------------------------------------------------------------------%
+
+:- module foreign_enum_rtti.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module construct.
+:- import_module deconstruct.
+:- import_module int.
+:- import_module list.
+:- import_module string.
+:- import_module type_desc.
+:- import_module univ.
+
+main(!IO) :-
+ io.write_string("Checking io.write for foreign enum ...\n", !IO),
+ io.write(foo, !IO),
+ io.nl(!IO),
+ io.write(bar, !IO),
+ io.nl(!IO),
+ io.write(baz, !IO),
+ io.nl(!IO),
+ io.write_string("Checking deep copy for foreign enum ...\n", !IO),
+ X = [foo, bar, baz],
+ copy(X, Y),
+ io.write(Y, !IO),
+ io.nl(!IO),
+ TypeDescForFoo = type_of(foo),
+ io.write_string("Number of functors of foo/0: ", !IO),
+ NumFunctors = det_num_functors(TypeDescForFoo),
+ io.write_int(NumFunctors, !IO),
+ io.nl(!IO),
+ io.write_string("Checking construct.get_functor for foreign_enum ...\n",
+ !IO),
+ int.fold_up(test_get_functor(TypeDescForFoo), 0, NumFunctors - 1, !IO),
+ io.write_string(
+ "Checking construct.get_functor_ordinal for foreign_enum ...\n", !IO),
+ list.foldl(check_get_functor_ordinal(TypeDescForFoo), [0, 1, 2], !IO),
+ io.write_string(
+ "Checking construct.construct for foreign_enum ...\n", !IO),
+ list.foldl(check_construct(TypeDescForFoo), [0, 1, 2], !IO),
+ io.write_string(
+ "Checking deconstruct.deconstruct for foreign_enum ...\n", !IO),
+ list.foldl(check_deconstruct, [foo, bar, baz], !IO).
+
+:- pred check_deconstruct(foo::in, io::di, io::uo) is det.
+
+check_deconstruct(Data, !IO) :-
+ deconstruct(Data, do_not_allow, Name, Arity, Args),
+ io.format(" name = %s\n", [s(Name)], !IO),
+ io.format(" arity = %d\n", [i(Arity)], !IO),
+ (
+ Args = [],
+ io.write_string(" no args\n", !IO)
+ ;
+ Args = [_ | _],
+ io.write_string("FAILED: unexpected args for foreign enum constant.\n",
+ !IO)
+ ).
+
+:- pred check_construct(type_desc::in, functor_number_lex::in,
+ io::di, io::uo) is det.
+
+check_construct(TypeDesc, LexFunctorNum, !IO) :-
+ ( Univ = construct(TypeDesc, LexFunctorNum, []) ->
+ io.write_string(" ", !IO),
+ io.write(Univ, !IO),
+ io.nl(!IO)
+ ;
+ io.write_string("FAILED: construct.construct\n", !IO)
+ ).
+
+:- pred check_get_functor_ordinal(type_desc::in, functor_number_lex::in,
+ io::di, io::uo) is det.
+
+check_get_functor_ordinal(TypeDesc, Lex, !IO) :-
+ ( Ordinal = get_functor_ordinal(TypeDesc, Lex) ->
+ io.format(" lex = %d, ordinal = %d\n", [i(Lex), i(Ordinal)], !IO)
+ ;
+ io.write_string("FAILED: get_functor_ordinal\n", !IO)
+ ).
+
+:- pred test_get_functor(type_desc::in, functor_number_lex::in,
+ io::di, io::uo) is det.
+
+test_get_functor(TypeDesc, LexFunctorNum, !IO) :-
+ io.format("functor_number_lex = %d\n", [i(LexFunctorNum)], !IO),
+ ( get_functor(TypeDesc, LexFunctorNum, Name, Arity, ArgTypes) ->
+ io.format(" name = %s\n", [s(Name)], !IO),
+ io.format(" arity = %d\n", [i(Arity)], !IO),
+ (
+ ArgTypes = [],
+ io.write_string(" no arguments\n", !IO)
+ ;
+ ArgTypes = [_ | _],
+ io.write_string("FAILED: args for foreign enum functor.\n", !IO)
+ )
+ ;
+ io.write_string("FAILED: not a d.u type.\n", !IO)
+ ).
+
+:- type foo
+ ---> foo
+ ; bar
+ ; baz.
+
+:- pragma foreign_decl("C", "
+
+ #define CONSTANT1 300
+ #define CONSTANT2 400
+ #define CONSTANT3 500
+").
+
+:- pragma foreign_enum("C", foo/0,
+ [
+ foo - "CONSTANT1",
+ bar - "CONSTANT2",
+ baz - "CONSTANT3"
+ ]).
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
Index: tests/invalid/Mercury.options
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/Mercury.options,v
retrieving revision 1.24
diff -u -r1.24 Mercury.options
--- tests/invalid/Mercury.options 25 Jul 2007 06:12:31 -0000 1.24
+++ tests/invalid/Mercury.options 9 Aug 2007 08:26:44 -0000
@@ -25,6 +25,7 @@
MCFLAGS-exported_unify3 = --no-intermodule-optimization \
--no-automatic-intermodule-optimization
MCFLAGS-foreign_decl_line_number = --no-errorcheck-only --line-numbers --compile-only
+MCFLAGS-foreign_enum_invalid = --verbose-error-messages
MCFLAGS-foreign_type_line_number = --no-errorcheck-only --line-numbers --compile-only
MCFLAGS-foreign_type_missing = --grade il --no-intermodule-optimization \
--no-automatic-intermodule-optimization
Index: tests/invalid/Mmakefile
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/Mmakefile,v
retrieving revision 1.219
diff -u -r1.219 Mmakefile
--- tests/invalid/Mmakefile 31 Jul 2007 05:02:13 -0000 1.219
+++ tests/invalid/Mmakefile 9 Aug 2007 08:26:44 -0000
@@ -84,6 +84,8 @@
external \
extra_info_prompt \
field_syntax_error \
+ foreign_enum_import \
+ foreign_enum_invalid \
foreign_purity_mismatch \
foreign_singleton \
foreign_type_2 \
Index: tests/invalid/foreign_enum_import.err_exp
===================================================================
RCS file: tests/invalid/foreign_enum_import.err_exp
diff -N tests/invalid/foreign_enum_import.err_exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/foreign_enum_import.err_exp 9 Aug 2007 08:26:44 -0000
@@ -0,0 +1,4 @@
+foreign_enum_import.m:010: In `pragma foreign_enum' declaration for
+foreign_enum_import.m:010: `bool.bool'/0:
+foreign_enum_import.m:010: error: `bool.bool'/0 is not defined in this
+foreign_enum_import.m:010: module.
Index: tests/invalid/foreign_enum_import.m
===================================================================
RCS file: tests/invalid/foreign_enum_import.m
diff -N tests/invalid/foreign_enum_import.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/foreign_enum_import.m 9 Aug 2007 08:26:44 -0000
@@ -0,0 +1,15 @@
+:- module foreign_enum_import.
+:- interface.
+
+:- import_module bool.
+
+:- func this = bool.
+
+:- implementation.
+
+:- pragma foreign_enum("C", bool.bool/0, [
+ yes - "561",
+ no - "75"
+]).
+
+this = yes.
Index: tests/invalid/foreign_enum_invalid.err_exp
===================================================================
RCS file: tests/invalid/foreign_enum_invalid.err_exp
diff -N tests/invalid/foreign_enum_invalid.err_exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/foreign_enum_invalid.err_exp 9 Aug 2007 08:26:44 -0000
@@ -0,0 +1,26 @@
+foreign_enum_invalid.m:020: Error: `pragma foreign_enum' declaration for
+foreign_enum_invalid.m:020: `foreign_enum_invalid.in_int'/0 in module
+foreign_enum_invalid.m:020: interface.
+foreign_enum_invalid.m:026: In `pragma foreign_enum' declaration for
+foreign_enum_invalid.m:026: `foreign_enum_invalid.incomplete'/0:
+foreign_enum_invalid.m:026: error: not all constructors have a foreign value.
+foreign_enum_invalid.m:026: The following constructor does not have a foreign
+foreign_enum_invalid.m:026: value
+foreign_enum_invalid.m:026: `foreign_enum_invalid.baz'
+foreign_enum_invalid.m:031: In `pragma foreign_enum' declaration for
+foreign_enum_invalid.m:031: `foreign_enum_invalid.incomplete2'/0:
+foreign_enum_invalid.m:031: error: not all constructors have a foreign value.
+foreign_enum_invalid.m:031: The following constructors do not have foreign
+foreign_enum_invalid.m:031: values
+foreign_enum_invalid.m:031: `foreign_enum_invalid.bar2',
+foreign_enum_invalid.m:031: `foreign_enum_invalid.baz2',
+foreign_enum_invalid.m:031: `foreign_enum_invalid.foo2'
+foreign_enum_invalid.m:033: In `pragma foreign_enum' declaration for
+foreign_enum_invalid.m:033: `foreign_enum_invalid.not_a_bijection'/0:
+foreign_enum_invalid.m:033: error: the mapping between Mercury enumeration
+foreign_enum_invalid.m:033: values and foreign values does not form a
+foreign_enum_invalid.m:033: bijection.
+foreign_enum_invalid.m:041: In `pragma foreign_enum' declaration for
+foreign_enum_invalid.m:041: `foreign_enum_invalid.dup_foreign_enum'/0:
+foreign_enum_invalid.m:041: error: `foreign_enum_invalid.dup_foreign_enum'/0
+foreign_enum_invalid.m:041: has multiple foreign_enum pragmas.
Index: tests/invalid/foreign_enum_invalid.m
===================================================================
RCS file: tests/invalid/foreign_enum_invalid.m
diff -N tests/invalid/foreign_enum_invalid.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/foreign_enum_invalid.m 9 Aug 2007 08:26:44 -0000
@@ -0,0 +1,41 @@
+:- module foreign_enum_invalid.
+:- interface.
+
+:- type incomplete
+ ---> foo
+ ; bar
+ ; baz.
+
+:- type incomplete2
+ ---> foo2
+ ; bar2
+ ; baz2.
+
+:- type not_a_bijection
+ ---> a
+ ; b
+ ; c.
+
+:- type in_int ---> in_int.
+:- pragma foreign_enum("C", in_int/0, [in_int - "300"]).
+
+:- type dup_foreign_enum ---> dup_foreign_enum.
+
+:- implementation.
+
+:- pragma foreign_enum("C", incomplete/0, [
+ foo - "3",
+ bar - "4"
+]).
+
+:- pragma foreign_enum("C", incomplete2/0, []).
+
+:- pragma foreign_enum("C", not_a_bijection/0, [
+ a - "30",
+ a - "40",
+ b - "50",
+ c - "60"
+]).
+
+:- pragma foreign_enum("C", dup_foreign_enum/0, [dup_foreign_enum - "400"]).
+:- pragma foreign_enum("C", dup_foreign_enum/0, [dup_foreign_enum - "500"]).
Index: tests/tabling/Mmakefile
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/tabling/Mmakefile,v
retrieving revision 1.44
diff -u -r1.44 Mmakefile
--- tests/tabling/Mmakefile 31 Jul 2007 07:58:45 -0000 1.44
+++ tests/tabling/Mmakefile 9 Aug 2007 08:26:44 -0000
@@ -19,6 +19,7 @@
loopcheck_no_loop \
loopcheck_nondet_no_loop \
oota \
+ table_foreign_enum \
table_foreign_output \
test_enum \
unused_args
Index: tests/tabling/table_foreign_enum.exp
===================================================================
RCS file: tests/tabling/table_foreign_enum.exp
diff -N tests/tabling/table_foreign_enum.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/tabling/table_foreign_enum.exp 9 Aug 2007 08:26:44 -0000
@@ -0,0 +1,2 @@
+First result: bar1501
+Second result: bar1501
Index: tests/tabling/table_foreign_enum.m
===================================================================
RCS file: tests/tabling/table_foreign_enum.m
diff -N tests/tabling/table_foreign_enum.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/tabling/table_foreign_enum.m 9 Aug 2007 08:26:44 -0000
@@ -0,0 +1,66 @@
+:- module table_foreign_enum.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+
+:- import_module string.
+
+main(!IO) :-
+ test_foreign_enum(bar, baz, Result),
+ io.write_string("First result: " ++ Result ++ "\n", !IO),
+ print_second_result(!IO).
+
+:- pragma no_inline(print_second_result/2).
+:- pred print_second_result(io::di, io::uo) is det.
+
+print_second_result(!IO) :-
+ test_foreign_enum(bar, baz, Result),
+ io.write_string("Second result: " ++ Result ++ "\n", !IO).
+
+:- pragma memo(test_foreign_enum/3).
+:- pred test_foreign_enum(foo::in, foo::in, string::out) is det.
+
+test_foreign_enum(A, B, Out) :-
+ StrA = string.string(A),
+ Number = mystery(B),
+ Out = StrA ++ int_to_string(Number).
+
+:- pragma no_inline(mystery/1).
+:- func mystery(foo) = int.
+:- pragma foreign_proc("C",
+ mystery(X::in) = (Y::out),
+ [will_not_call_mercury, promise_pure],
+"
+ static int called = 0;
+
+ if (called) {
+ fprintf(stdout, ""mystery has been called again\\n"");
+ fflush(stdout);
+ }
+
+ Y = X + 1001;
+ called = 1;
+").
+
+:- type foo
+ ---> foo
+ ; bar
+ ; baz.
+
+:- pragma foreign_decl("C", "
+
+ #define CONSTANT1 300
+ #define CONSTANT2 400
+ #define CONSTANT3 500
+").
+
+:- pragma foreign_enum("C", foo/0,
+ [
+ foo - "CONSTANT1",
+ bar - "CONSTANT2",
+ baz - "CONSTANT3"
+ ]).
Index: vim/syntax/mercury.vim
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/vim/syntax/mercury.vim,v
retrieving revision 1.22
diff -u -r1.22 mercury.vim
--- vim/syntax/mercury.vim 25 Jul 2007 06:12:32 -0000 1.22
+++ vim/syntax/mercury.vim 9 Aug 2007 08:26:44 -0000
@@ -51,6 +51,7 @@
syn keyword mercuryCInterface foreign_proc foreign_decl foreign_code
syn keyword mercuryCInterface foreign_type foreign_import_module
syn keyword mercuryCInterface foreign_export_enum foreign_export
+syn keyword mercuryCInterface foreign_enum
syn keyword mercuryCInterface may_call_mercury will_not_call_mercury
syn keyword mercuryCInterface thread_safe not_thread_safe maybe_thread_safe
syn keyword mercuryCInterface promise_pure promise_semipure
--------------------------------------------------------------------------
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