[m-rev.] for review: pragma foreign_export_enum
Julien Fischer
juliensf at csse.unimelb.edu.au
Tue Jul 24 16:59:02 AEST 2007
Estimated hours taken: 30
Branches: main
Add a new pragma, foreign_export_enum, that allows the names of constructors
of Mercury enumeration types to be exported across the foreign language
interface and referred to by code in the foreign language.
The new pragma is intended to be used to avoid a situation that frequently
occurs when creating Mercury bindings to foreign language libraries, namely
arguments and return values being passed across the foreign language boundary
as small integers. Exporting the names of enumeration values to foreign
languages should make this task less error prone and more portable.
Using the new construct programmers can either specify a foreign language name
for each enumeration constructor, or since this is tedious, there is also a
default mapping defined for each foreign language that should work in most
cases for that language. (In the cases where it does not work the compiler
requires the programmer to provide a valid name.)
Currently, pragma foreign_export_enum is only supported by the C backends.
compiler/prog_data.m:
compiler/prog_item.m:
Add a new item to the parse tree for representing
foreign_export_enum pragmas.
compiler/prog_io_pragma.m:
Parse the new pragma.
compiler/module_qual.m:
Handle foreign_export_enum pragmas.
Add a predicate to for module qualifying type_ctors, i.e. a
type identified by it's sym_name and arity, for use by the
above.
compiler/mercury_to_mercury.m:
Write out foreign_export_enum pragmas.
compiler/hlds_module.m:
Add a type to represent exported enumerations.
Add a field to the module_info to hold information about
exported enumerations. Add access procedures for this.
compiler/make_hlds_passes.m:
compiler/add_pragma.m:
Handle foreign_export_enum pragmas: generate the set of foreign names
for each of the constructors of an enumeration type and check that
their validity in the foreign language. Attach this information to
the HLDS.
compiler/export.m:
Output #defined constants for C foreign_export_enum pragmas in
.mh files.
compiler/mlds.m:
Add an MLDS specific representation of exported enumerations.
compiler/ml_type_gen.m:
Convert the HLDS representation of exported enumerations into
an MLDS specific one.
compiler/mlds_to_c.m:
Output #defined constants for C foreign_export_enum pragmas in
.mih files.
compiler/ml_code_gen.m:
compiler/ml_elim_nested.m:
compiler/ml_tailcall.m:
compiler/mlds_to_gcc.m:
compiler/mlds_to_il.m:
compiler/mlds_to_ilasm.m:
compiler/mlds_to_java.m:
compiler/mlds_to_managed.m:
Conform to the above changes to the MLDS.
compiler/mercury_compile.m:
Pass the list of export enumerations to the code that writes
out .mh files.
compiler/c_util.m:
Add a predicate that tests if a string is a valid C identifier.
compiler/modules.m:
compiler/recompilation.version.m:
Conform to the above changes.
doc/reference_manual.texi:
Document the new pragma.
tests/hard_coded/Mmakefile:
tests/hard_coded/ee_dummy.{m,exp}:
tests/hard_coded/ee_valid.{m,exp}:
Test valid uses of foreign_export_enum pragmas.
tests/invalid/Mmakefile:
tests/invalid/Mercury.options:
tests/invalid/ee_invalid.{m,err_exp}:
Check we generate error messages for invalid
foreign_export_enum pragmas.
NEWS:
Announce the new pragma.
vim/syntax/mercury.vim:
Highlight the new syntax.
Julien.
Index: NEWS
===================================================================
RCS file: /home/mercury1/repository/mercury/NEWS,v
retrieving revision 1.470
diff -u -r1.470 NEWS
--- NEWS 20 Jul 2007 01:21:58 -0000 1.470
+++ NEWS 24 Jul 2007 06:38:04 -0000
@@ -3,6 +3,8 @@
Changes to the Mercury language:
+* A new pragma, foreign_export_enum, allows the constructors of Merucry
+ 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
@@ -229,6 +231,22 @@
Changes to the Mercury language:
+* 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.
+
+ For example, given the type
+
+ :- type status ---> ok ; error.
+
+ the declaration
+
+ :- pragma foreign_export_enum("C", status/0, [prefix("STATUS_")]).
+
+ allows code in C foreign_proc and foreign_code pragma bodies to refer
+ to the value `ok' via the name `STATUS_ok' and to the value `error'
+ via the name `STATUS_error'.
+
* The restriction on typeclass instances that all type variables appearing in
the range of a functional dependency must be monomorphic has been relaxed.
We now support cases where the type variables in the range are determined
Index: compiler/add_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/add_pragma.m,v
retrieving revision 1.66
diff -u -r1.66 add_pragma.m
--- compiler/add_pragma.m 14 Jul 2007 02:32:40 -0000 1.66
+++ compiler/add_pragma.m 23 Jul 2007 07:42:27 -0000
@@ -36,6 +36,11 @@
:- pred add_pragma_reserve_tag(sym_name::in, arity::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_foreign_export_enum(foreign_language::in, sym_name::in,
+ arity::in, export_enum_attributes::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,
@@ -126,9 +131,11 @@
:- implementation.
:- import_module backend_libs.
+:- import_module backend_libs.c_util.
:- import_module backend_libs.foreign.
:- import_module backend_libs.rtti.
:- import_module check_hlds.mode_util.
+:- import_module check_hlds.type_util.
:- import_module hlds.hlds_args.
:- import_module hlds.code_model.
:- import_module hlds.hlds_data.
@@ -168,6 +175,7 @@
:- import_module transform_hlds.term_util.
:- import_module bag.
+:- import_module bimap.
:- import_module bool.
:- import_module int.
:- import_module list.
@@ -218,6 +226,10 @@
% Handle pragma foreign procs later on (when we process clauses).
Pragma = pragma_foreign_proc(_, _, _, _, _, _, _)
;
+ % Handle pragma foregin_export_enum (after we have added all the
+ % types).
+ Pragma = pragma_foreign_export_enum(_, _, _, _, _)
+ ;
% Handle pragma tabled decls later on (when we process clauses).
Pragma = pragma_tabled(_, _, _, _, _, _)
;
@@ -583,6 +595,357 @@
%-----------------------------------------------------------------------------%
+add_pragma_foreign_export_enum(Lang, TypeName, TypeArity, Attributes,
+ Overrides, _ImportStatus, Context, !ModuleInfo, !Specs) :-
+ TypeCtor = type_ctor(TypeName, TypeArity),
+ module_info_get_type_table(!.ModuleInfo, TypeDefnTable),
+ ContextPieces = [
+ words("In"), fixed("`pragma foreign_export_enum'"),
+ words("declaration for"),
+ sym_name_and_arity(TypeName / TypeArity), suffix(":"), nl
+ ],
+ (
+ % Emit an error message for export_num 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(TypeDefnTable, TypeCtor, TypeDefn) ->
+ get_type_defn_body(TypeDefn, TypeBody),
+ (
+ ( TypeBody = hlds_eqv_type(_)
+ ; TypeBody = hlds_abstract_type(_)
+ ; TypeBody = hlds_solver_type(_, _)
+ ; TypeBody = hlds_foreign_type(_)
+ ),
+ MaybeSeverity = yes(severity_error),
+ ErrorPieces = [
+ words("error: "),
+ sym_name_and_arity(TypeName / TypeArity),
+ words("is not an enumeration type"),
+ suffix(".")
+ ]
+ ;
+ % XXX How should we handle IsForeignType here?
+ TypeBody = hlds_du_type(Ctors, _TagValues, IsEnumOrDummy, _MaybeUserEq,
+ _ReservedTag, _IsForeignType),
+ (
+ % We cannot rely on the ctor tag values here being correct
+ % (because we may yet encounter a reserve_tag pragma that changes
+ % them), so we ignore them until MLDS or LLDS code generation.
+ %
+ ( IsEnumOrDummy = is_enum
+ ; IsEnumOrDummy = is_dummy
+ ),
+ Attributes = export_enum_attributes(MaybePrefix),
+ (
+ MaybePrefix = yes(Prefix)
+ ;
+ MaybePrefix = no,
+ Prefix = ""
+ ),
+ build_overrides_map(TypeName, Context, ContextPieces, Overrides,
+ MaybeOverridesMap, !Specs),
+ (
+ MaybeOverridesMap = yes(OverridesMap),
+ build_export_enum_name_map(ContextPieces, Lang, TypeName,
+ TypeArity, Context, Prefix, OverridesMap, Ctors, MaybeMapping,
+ !Specs),
+ (
+ MaybeMapping = yes(Mapping),
+ ExportedEnum = exported_enum_info(Lang, Context, TypeCtor, Mapping),
+ module_info_get_exported_enums(!.ModuleInfo, ExportedEnums0),
+ ExportedEnums = [ ExportedEnum | ExportedEnums0 ],
+ module_info_set_exported_enums(ExportedEnums, !ModuleInfo)
+ ;
+ MaybeMapping = no
+ ),
+ ErrorPieces = [],
+ MaybeSeverity = no
+ ;
+ MaybeOverridesMap = no,
+ ErrorPieces = [],
+ MaybeSeverity = no
+ )
+ ;
+ IsEnumOrDummy = not_enum_or_dummy,
+ MaybeSeverity = yes(severity_error),
+ % XXX Maybe we should add a verbose error message that
+ % identifies the non-zero arity constructors.
+ ErrorPieces = [
+ words("error: "),
+ sym_name_and_arity(TypeName / TypeArity),
+ words("is not an enumeration type."),
+ words("It has one more non-zero arity"),
+ words("constructors.")
+ ]
+ )
+ )
+ ;
+ % This case 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_export_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_overrides_map(sym_name::in, prog_context::in,
+ format_components::in, assoc_list(sym_name, string)::in,
+ maybe(map(sym_name, string))::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
+
+build_overrides_map(TypeName, Context, ContextPieces, OverridesList0,
+ MaybeOverridesMap, !Specs) :-
+ ( sym_name_get_module_name(TypeName, ModuleName0) ->
+ ModuleName = ModuleName0
+ ;
+ unexpected(this_file,
+ "unqualified type name while building override map")
+ ),
+ %
+ % Strip off module qualifiers that match those of the type
+ % being exported. We leave those that do not match so that
+ % they can be reported as errors later.
+ %
+ StripQualifiers = (func(Name0) = Name :-
+ (
+ Name0 = qualified(ModuleQualifier, UnqualName),
+ ( ModuleQualifier = ModuleName ->
+ Name = unqualified(UnqualName)
+ ;
+ Name = Name0
+ )
+ ;
+ Name0 = unqualified(_),
+ Name = Name0
+ )
+ ),
+ OverridesList = assoc_list.map_keys_only(StripQualifiers,
+ OverridesList0),
+ ( bimap.from_assoc_list(OverridesList, OverridesMap0) ->
+ OverridesMap = bimap.forward_map(OverridesMap0),
+ MaybeOverridesMap = yes(OverridesMap)
+ ;
+ MaybeOverridesMap = no,
+ % XXX we should report exactly why it is not a bijective.
+ ErrorPieces = [
+ words("error: "),
+ words("the user-specified mapping between Mercury and"),
+ words("foreign names does not form a bijection.")
+ ],
+ Msg = simple_msg(Context, [always(ContextPieces ++ ErrorPieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
+ ).
+
+:- pred build_export_enum_name_map(format_components::in,
+ foreign_language::in, sym_name::in, arity::in, prog_context::in,
+ string::in, map(sym_name, string)::in, list(constructor)::in,
+ maybe(map(sym_name, string))::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
+
+build_export_enum_name_map(ContextPieces, Lang, TypeName, TypeArity, Context, Prefix,
+ Overrides0, Ctors, MaybeMapping, !Specs) :-
+ (
+ TypeName = qualified(TypeModuleQual, _)
+
+ ;
+ % The type name should have been module qualified by now.
+ TypeName = unqualified(_),
+ unexpected(this_file, "unqualified type name for foreign_export_enum")
+ ),
+
+ list.foldl3(add_ctor_to_name_map(Lang, Prefix, TypeModuleQual),
+ Ctors, Overrides0, Overrides, map.init, NameMap, [], BadCtors),
+ %
+ % Check for any remaining user-specified renamings that didn't
+ % match the constructors of the type and report and error
+ % for them.
+ %
+ ( not map.is_empty(Overrides) ->
+ InvalidRenamingPieces = [
+ words("user-specified foreign names for constructors"),
+ words("that do not match match any of the constructors of"),
+ sym_name_and_arity(TypeName / TypeArity), suffix(".")
+ ],
+ InvalidRenamings = map.keys(Overrides),
+ InvalidRenamingComponents =
+ list.map((func(S) = [sym_name(S)]), InvalidRenamings),
+ InvalidRenamingList = component_list_to_line_pieces(
+ InvalidRenamingComponents, [nl]),
+ InvalidRenamingVerbosePieces = [
+ words("The following"),
+ words(choose_number(InvalidRenamings,
+ "constructor does", "constructors do")),
+ words("not match"), suffix(":"), nl_indent_delta(2)
+ ] ++ InvalidRenamingList,
+ InvalidRenamingMsg = simple_msg(Context,
+ [
+ always(ContextPieces ++ InvalidRenamingPieces),
+ verbose_only(InvalidRenamingVerbosePieces)
+ ]),
+ InvalidRenamingSpec = error_spec(severity_error,
+ phase_parse_tree_to_hlds, [InvalidRenamingMsg]),
+ list.cons(InvalidRenamingSpec, !Specs),
+ MaybeMapping = no
+ % NOTE: in the presence of this error we do not report if
+ % contructors could not be converted to names in the foreign
+ % langugage.
+ ;
+ (
+ BadCtors = [],
+ check_name_map_for_conflicts(Context, ContextPieces, NameMap,
+ MaybeMapping, !Specs)
+ ;
+ BadCtors = [_ | _],
+ (
+ Lang = lang_c,
+ What = "C identifiers."
+ ;
+ ( Lang = lang_csharp
+ ; Lang = lang_java
+ ; Lang = lang_il
+ ; Lang = lang_erlang
+ ),
+ sorry(this_file,
+ "foreign_export_enum pragma for unsupported language")
+ ),
+ BadCtorsErrorPieces = [
+ words("error: not all the constructors of the type"),
+ sym_name_and_arity(TypeName / TypeArity),
+ words("can be converted into valid " ++ What)
+ ],
+ list.sort(BadCtors, SortedBadCtors),
+ BadCtorComponents = list.map((func(S) = [sym_name(S)]),
+ SortedBadCtors),
+ BadCtorsList = component_list_to_line_pieces(
+ BadCtorComponents, [nl]),
+ BadCtorsVerboseErrorPieces = [
+ words("The following"),
+ words(choose_number(BadCtors, "constructor",
+ "constructors")),
+ words("cannot be converted:"), nl_indent_delta(2)
+ ] ++ BadCtorsList,
+ BadCtorsMsg = simple_msg(Context,
+ [
+ always(ContextPieces ++ BadCtorsErrorPieces),
+ verbose_only(BadCtorsVerboseErrorPieces)
+ ]),
+ BadCtorsSpec = error_spec(severity_error,
+ phase_parse_tree_to_hlds, [BadCtorsMsg]),
+ list.cons(BadCtorsSpec, !Specs),
+ MaybeMapping = no
+ )
+ ).
+
+ % Check that the mapping from foreign names to Mercury names is not
+ % one-to-many.
+ %
+:- pred check_name_map_for_conflicts(prog_context::in, format_components::in,
+ map(sym_name, string)::in, maybe(map(sym_name, string))::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
+
+check_name_map_for_conflicts(Context, ContextPieces, NameMap,
+ MaybeNameMap, !Specs) :-
+ NamesAndForeignNames = map.to_assoc_list(NameMap),
+ ( bimap.from_assoc_list(NamesAndForeignNames, _) ->
+ MaybeNameMap = yes(NameMap)
+ ;
+
+ MaybeNameMap = no,
+ % XXX we should report exactly why it is not bijective.
+ ErrorPieces = [
+ words("error: the mapping between Mercury and foreign names"),
+ words("does not form a bijection.")
+ ],
+ Msg = simple_msg(Context, [always(ContextPieces ++ ErrorPieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
+ ).
+
+ % add_ctor_to_name_map(ForeignLanguage, Overrides, Prefix, Ctor, !Map,
+ % !BadCtors):
+ %
+:- pred add_ctor_to_name_map(foreign_language::in,
+ string::in, sym_name::in, constructor::in,
+ map(sym_name, string)::in, map(sym_name, string)::out,
+ map(sym_name, string)::in, map(sym_name, string)::out,
+ list(sym_name)::in, list(sym_name)::out) is det.
+
+add_ctor_to_name_map(Lang, Prefix, _TypeModQual, Ctor, !Overrides, !NameMap,
+ !BadCtors) :-
+ CtorSymName = Ctor ^ cons_name,
+ (
+ % All of the constructor sym_names should be module qualified by now.
+ % We unqualify them before inserting them into the mapping since
+ % the code in export.m expects that to be done.
+ %
+ CtorSymName = qualified(_, _),
+ UnqualCtorName = unqualify_name(CtorSymName),
+ UnqualSymName = unqualified(UnqualCtorName)
+ ;
+ CtorSymName = unqualified(_),
+ unexpected(this_file, "unqualified constructor name")
+ ),
+ %
+ % If the user specified a name for this constructor then use that.
+ %
+ ( map.remove(!.Overrides, UnqualSymName, ForeignName0, !:Overrides) ->
+ ForeignName1 = ForeignName0
+ ;
+ % Otherwise try to derive a name automatically from the
+ % constructor name.
+ ForeignName1 = UnqualCtorName
+ ),
+ ForeignName = Prefix ++ ForeignName1,
+ (
+ Lang = lang_c,
+ IsValidForeignName = pred_to_bool(is_valid_c_identifier(ForeignName))
+ ;
+ ( Lang = lang_csharp
+ ; Lang = lang_java
+ ; Lang = lang_il
+ ; Lang = lang_erlang
+ ),
+ sorry(this_file, "foreign_export_enum for language other than C")
+ ),
+ (
+ IsValidForeignName = yes,
+ svmap.det_insert(UnqualSymName, ForeignName, !NameMap)
+ ;
+ IsValidForeignName = no,
+ list.cons(UnqualSymName, !BadCtors)
+ ).
+
+%-----------------------------------------------------------------------------%
+
:- 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/c_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/c_util.m,v
retrieving revision 1.36
diff -u -r1.36 c_util.m
--- compiler/c_util.m 17 Jul 2007 23:48:26 -0000 1.36
+++ compiler/c_util.m 18 Jul 2007 07:25:41 -0000
@@ -25,10 +25,11 @@
:- import_module char.
:- import_module io.
:- import_module list.
+
%-----------------------------------------------------------------------------%
%
-% Line numbering.
-
+% Line numbering
+%
% set_line_num(FileName, LineNum):
%
% Emit a #line directive to set the specified filename and linenumber
@@ -45,7 +46,8 @@
%-----------------------------------------------------------------------------%
%
-% String and character handling.
+% String and character handling
+%
% Print out a string suitably escaped for use as a C string literal.
% This doesn't actually print out the enclosing double quotes --
@@ -80,7 +82,8 @@
%-----------------------------------------------------------------------------%
%
-% Float literals.
+% Float literals
+%
% Convert a float to a string suitable for use as a C (or Java, or IL)
% floating point literal.
@@ -94,7 +97,7 @@
%-----------------------------------------------------------------------------%
%
-% Operators.
+% Operators
%
% The following predicates all take as input an operator, and return the name
% of the corresponding C operator that can be used to implement it.
@@ -132,6 +135,14 @@
io::di, io::uo) is det.
%-----------------------------------------------------------------------------%
+%
+% Utility predicates for working with C code
+%
+ % Succeeds iff the given string is a valid C identifier.
+ %
+:- pred is_valid_c_identifier(string::in) is semidet.
+
+%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
@@ -191,7 +202,8 @@
%-----------------------------------------------------------------------------%
%
-% String and character handling.
+% String and character handling
+%
output_quoted_string(S, !IO) :-
output_quoted_string(0, length(S), S, !IO).
@@ -341,7 +353,7 @@
%-----------------------------------------------------------------------------%
%
-% Floating point literals.
+% Floating point literals
%
% XXX These routines do not yet handle infinities and NaNs properly.
@@ -358,7 +370,8 @@
%-----------------------------------------------------------------------------%
%
-% Operators.
+% Operators
+%
unary_prefix_op(mktag, "MR_mktag").
unary_prefix_op(tag, "MR_tag").
@@ -454,3 +467,10 @@
convert_bool_to_string(yes) = "yes".
%-----------------------------------------------------------------------------%
+
+is_valid_c_identifier(S) :-
+ string.first_char(S, Start, Rest),
+ char.is_alpha_or_underscore(Start),
+ string.is_all_alnum_or_underscore(Rest).
+
+%-----------------------------------------------------------------------------%
Index: compiler/export.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/export.m,v
retrieving revision 1.111
diff -u -r1.111 export.m
--- compiler/export.m 14 Jul 2007 02:32:41 -0000 1.111
+++ compiler/export.m 15 Jul 2007 12:43:21 -0000
@@ -7,7 +7,7 @@
%-----------------------------------------------------------------------------%
%
% File: export.m.
-% Main author: dgj.
+% Main author: dgj, juliensf.
%
% This module defines predicates to produce the functions which are
% exported to a foreign language via a `pragma foreign_export' declaration.
@@ -50,8 +50,8 @@
% Produce an interface file containing declarations for the exported
% foreign functions (if required in this foreign language).
%
-:- pred produce_header_file(foreign_export_decls::in, module_name::in,
- io::di, io::uo) is det.
+:- pred produce_header_file(module_info::in, foreign_export_decls::in,
+ module_name::in, io::di, io::uo) is det.
%-----------------------------------------------------------------------------%
@@ -91,6 +91,7 @@
:- import_module check_hlds.type_util.
:- import_module hlds.arg_info.
:- import_module hlds.code_model.
+:- import_module hlds.hlds_data.
:- import_module hlds.hlds_pred.
:- import_module hlds.pred_table.
:- import_module libs.compiler_util.
@@ -626,14 +627,18 @@
).
%-----------------------------------------------------------------------------%
+%
+% Code to create the .mh files
+%
% This procedure is used for both the MLDS and LLDS back-ends.
-produce_header_file(ForeignExportDecls, ModuleName, !IO) :-
+produce_header_file(ModuleInfo, ForeignExportDecls, ModuleName, !IO) :-
% We always produce a .mh file because with intermodule optimization
% enabled the .o file depends on all the .mh files of the imported modules
% so we always need to produce a .mh file even if it contains nothing.
ForeignExportDecls = foreign_export_decls(ForeignDecls, C_ExportDecls),
+ module_info_get_exported_enums(ModuleInfo, ExportedEnums),
HeaderExt = ".mh",
module_name_to_file_name(ModuleName, HeaderExt, yes, FileName, !IO),
io.open_output(FileName ++ ".tmp", Result, !IO),
@@ -676,6 +681,7 @@
io.write_strings([
"#ifndef ", decl_guard(ModuleName), "\n",
"#define ", decl_guard(ModuleName), "\n"], !IO),
+ list.foldl(output_exported_enum(ModuleInfo), ExportedEnums, !IO),
list.foldl(output_foreign_decl(yes(foreign_decl_is_exported)),
ForeignDecls, !IO),
io.write_string("\n#endif\n", !IO),
@@ -750,6 +756,79 @@
;
true
).
+
+%-----------------------------------------------------------------------------%
+%
+% Code for writing out foreign exported enumerations
+%
+
+% For C/C++ we emit a #defined constant for constructor exported from an
+% enumeration.
+
+:- pred output_exported_enum(module_info::in, exported_enum_info::in,
+ io::di, io::uo) is det.
+
+output_exported_enum(ModuleInfo, ExportedEnumInfo, !IO) :-
+ ExportedEnumInfo = exported_enum_info(_Lang, Context, TypeCtor,
+ NameMapping),
+ module_info_get_type_table(ModuleInfo, TypeTable),
+ map.lookup(TypeTable, TypeCtor, TypeDefn),
+ get_type_defn_body(TypeDefn, TypeBody),
+ (
+ ( TypeBody = hlds_eqv_type(_)
+ ; TypeBody = hlds_foreign_type(_)
+ ; TypeBody = hlds_solver_type(_, _)
+ ; TypeBody = hlds_abstract_type(_)
+ ),
+ unexpected(this_file, "invalid type for foreign_export_enum")
+ ;
+ TypeBody = hlds_du_type(Ctors, TagValues, IsEnumOrDummy,
+ _MaybeUserEq, _ReservedTag, _IsForeignType),
+ (
+ IsEnumOrDummy = not_enum_or_dummy,
+ unexpected(this_file, "d.u. is not an enumeration.")
+ ;
+ ( IsEnumOrDummy = is_enum
+ ; IsEnumOrDummy = is_dummy
+ ),
+ list.foldl(foreign_const_name_and_tag(NameMapping, TagValues),
+ Ctors, [], ForeignNamesAndTags0),
+ % We reverse the list so the constants are printed out in order.
+ list.reverse(ForeignNamesAndTags0, ForeignNamesAndTags),
+ term.context_file(Context, File),
+ term.context_line(Context, Line),
+ c_util.set_line_num(File, Line, !IO),
+ io.write_list(ForeignNamesAndTags, "\n",
+ output_exported_enum_2(ModuleInfo), !IO),
+ io.nl(!IO),
+ c_util.reset_line_num(!IO)
+ )
+ ).
+
+:- pred output_exported_enum_2(module_info::in, pair(string, int)::in,
+ io::di, io::uo) is det.
+
+output_exported_enum_2(_, ConstName - Tag, !IO) :-
+ io.format("#define %s %d", [s(ConstName), i(Tag)], !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.
+
+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
+ ;
+ unexpected(this_file, "enum constant requires an int tag")
+ ),
+ % Sanity check.
+ expect(unify(Arity, 0), this_file, "enum constant arity != 0"),
+ UnqualifiedCtorName = unqualified(unqualify_name(QualifiedCtorName)),
+ map.lookup(Mapping, UnqualifiedCtorName, ForeignName),
+ list.cons(ForeignName - Tag, !NamesAndTags).
%-----------------------------------------------------------------------------%
Index: compiler/hlds_module.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_module.m,v
retrieving revision 1.151
diff -u -r1.151 hlds_module.m
--- compiler/hlds_module.m 8 Jun 2007 00:47:09 -0000 1.151
+++ compiler/hlds_module.m 12 Jul 2007 07:36:18 -0000
@@ -202,6 +202,19 @@
%-----------------------------------------------------------------------------%
%
+% Types for foreign exported enumerations
+%
+
+:- type exported_enum_info
+ ---> exported_enum_info(
+ foreign_language,
+ prog_context,
+ type_ctor,
+ map(sym_name, string)
+ ).
+
+%-----------------------------------------------------------------------------%
+%
% Various predicates for manipulating the module_info data structure
%
@@ -500,6 +513,12 @@
:- pred module_info_get_interface_module_specifiers(module_info::in,
set(module_name)::out) is det.
+:- pred module_info_get_exported_enums(module_info::in,
+ list(exported_enum_info)::out) is det.
+
+:- pred module_info_set_exported_enums(list(exported_enum_info)::in,
+ module_info::in, module_info::out) is det.
+
:- pred module_info_get_event_set(module_info::in, event_set::out) is det.
:- pred module_info_set_event_set(event_set::in,
@@ -770,6 +789,10 @@
% All the directly imported module specifiers in the interface.
% (Used by unused_imports analysis).
interface_module_specifiers :: set(module_specifier),
+
+ % Enumeration types that have been exported to a foreign
+ % language.
+ exported_enums :: list(exported_enum_info),
event_set :: event_set
).
@@ -815,7 +838,7 @@
MM_TablingInfo, map.init, counter.init(1), ImportedModules,
IndirectlyImportedModules, TypeSpecInfo, NoTagTypes, no, [],
init_analysis_info(mmc), [], [],
- map.init, used_modules_init, set.init, EventSet),
+ map.init, used_modules_init, set.init, [], EventSet),
ModuleInfo = module_info(ModuleSubInfo, PredicateTable, Requests,
UnifyPredMap, QualifierInfo, Types, Insts, Modes, Ctors,
ClassTable, InstanceTable, AssertionTable, ExclusiveTable,
@@ -842,8 +865,9 @@
module_info_get_maybe_recompilation_info(MI, MI ^ maybe_recompilation_info).
%-----------------------------------------------------------------------------%
-
- % Various predicates which modify the module_info data structure.
+%
+% Various predicates which modify the module_info data structure.
+%
module_info_set_predicate_table(PT, MI, MI ^ predicate_table := PT).
module_info_set_proc_requests(PR, MI, MI ^ proc_requests := PR).
@@ -863,9 +887,10 @@
MI ^ maybe_recompilation_info := I).
%-----------------------------------------------------------------------------%
-
- % Various predicates which access the module_sub_info data structure
- % via the module_info structure.
+%
+% Various predicates which access the module_sub_info data structure
+% via the module_info structure.
+%
module_info_get_name(MI, MI ^ sub_info ^ module_name).
module_info_get_globals(MI, MI ^ sub_info ^ globals).
@@ -906,6 +931,7 @@
module_info_get_used_modules(MI, MI ^ sub_info ^ used_modules).
module_info_get_interface_module_specifiers(MI,
MI ^ sub_info ^ interface_module_specifiers).
+module_info_get_exported_enums(MI, MI ^ sub_info ^ exported_enums).
module_info_get_event_set(MI, MI ^ sub_info ^ event_set).
% XXX There is some debate as to whether duplicate initialise directives
@@ -969,9 +995,10 @@
).
%-----------------------------------------------------------------------------%
-
- % Various predicates which modify the module_sub_info data structure
- % via the module_info structure.
+%
+% Various predicates which modify the module_sub_info data structure
+% via the module_info structure.
+%
module_info_set_globals(NewVal, MI,
MI ^ sub_info ^ globals := NewVal).
@@ -1046,6 +1073,8 @@
module_info_get_used_modules(MI, UsedModules0),
list.foldl(add_all_modules(visibility_public),
Modules, UsedModules0, UsedModules).
+module_info_set_exported_enums(ExportedEnums, MI,
+ MI ^ sub_info ^ exported_enums := ExportedEnums).
%-----------------------------------------------------------------------------%
Index: compiler/make_hlds_passes.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds_passes.m,v
retrieving revision 1.69
diff -u -r1.69 make_hlds_passes.m
--- compiler/make_hlds_passes.m 12 Jun 2007 06:53:57 -0000 1.69
+++ compiler/make_hlds_passes.m 12 Jul 2007 13:03:46 -0000
@@ -1065,6 +1065,11 @@
add_pragma_reserve_tag(TypeName, TypeArity, !.Status, Context,
!ModuleInfo, !Specs)
;
+ Pragma = pragma_foreign_export_enum(Lang, TypeName, TypeArity,
+ Attributes, Overrides),
+ add_pragma_foreign_export_enum(Lang, TypeName, TypeArity, Attributes,
+ Overrides, !.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_compile.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.444
diff -u -r1.444 mercury_compile.m
--- compiler/mercury_compile.m 14 Jul 2007 02:32:44 -0000 1.444
+++ compiler/mercury_compile.m 15 Jul 2007 12:43:22 -0000
@@ -1600,7 +1600,8 @@
% referred to by foreign_export pragmas.
%
export.get_foreign_export_decls(!.HLDS, ExportDecls),
- export.produce_header_file(ExportDecls, ModuleName, !IO)
+ export.produce_header_file(!.HLDS, ExportDecls, ModuleName,
+ !IO)
;
( Target = target_java
; Target = target_il
@@ -1748,7 +1749,7 @@
mlds_has_main(MLDS) =
(
- MLDS = mlds(_, _, _, Defns, _, _),
+ MLDS = mlds(_, _, _, Defns, _, _, _),
defns_contain_main(Defns)
->
has_main
@@ -4579,7 +4580,7 @@
Verbose, Stats, !IO),
C_InterfaceInfo = foreign_interface_info(_, _, _, _, C_ExportDecls, _),
- export.produce_header_file(C_ExportDecls, ModuleName, !IO),
+ export.produce_header_file(HLDS, C_ExportDecls, ModuleName, !IO),
% Finally we invoke the C compiler to compile it.
globals.lookup_bool_option(Globals, target_code_only, TargetCodeOnly),
@@ -4939,10 +4940,10 @@
NewTypeClassInfoRttiData], RttiData),
RttiDefns = rtti_data_list_to_mlds(HLDS, RttiData),
MLDS0 = mlds(ModuleName, ForeignCode, Imports, Defns0, InitPreds,
- FinalPreds),
+ FinalPreds, ExportedEnums),
list.append(RttiDefns, Defns0, Defns),
- MLDS = mlds(ModuleName, ForeignCode, Imports, Defns,
- InitPreds, FinalPreds).
+ MLDS = mlds(ModuleName, ForeignCode, Imports, Defns, InitPreds,
+ FinalPreds, ExportedEnums).
%-----------------------------------------------------------------------------%
%
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.316
diff -u -r1.316 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m 7 May 2007 05:21:32 -0000 1.316
+++ compiler/mercury_to_mercury.m 24 Jul 2007 06:07:03 -0000
@@ -407,6 +407,7 @@
:- import_module parse_tree.prog_util.
:- import_module recompilation.version.
+:- import_module assoc_list.
:- import_module int.
:- import_module lexer.
:- import_module map.
@@ -598,6 +599,11 @@
ExportName),
mercury_format_pragma_foreign_export(Lang, Pred, PredOrFunc, ModeList,
ExportName, !IO)
+ ;
+ Pragma = pragma_foreign_export_enum(Lang, TypeName, TypeArity,
+ Attributes, Overrides),
+ mercury_format_pragma_foreign_export_enum(Lang, TypeName, TypeArity,
+ Attributes, Overrides, !IO)
;
Pragma = pragma_obsolete(Pred, Arity),
mercury_output_pragma_decl(Pred, Arity, pf_predicate, "obsolete", no,
@@ -3604,12 +3610,68 @@
add_string(C_Function, !U),
add_string(""").\n", !U).
+%-----------------------------------------------------------------------------%
+
+:- pred mercury_format_pragma_foreign_export_enum(foreign_language::in,
+ sym_name::in, arity::in, export_enum_attributes::in,
+ assoc_list(sym_name, string)::in, U::di, U::uo) is det <= output(U).
+
+mercury_format_pragma_foreign_export_enum(Lang, TypeName, TypeArity,
+ Attributes, Overrides, !U) :-
+ add_string(":- pragma foreign_export_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_pragma_foreign_export_enum_attributes(Attributes, !U),
+ add_string(", ", !U),
+ mercury_format_pragma_foreign_export_enum_overrides(Overrides, !U),
+ add_string(").\n", !U).
+
+:- pred mercury_format_pragma_foreign_export_enum_attributes(
+ export_enum_attributes::in, U::di, U::uo) is det <= output(U).
+
+mercury_format_pragma_foreign_export_enum_attributes(Attributes, !U) :-
+ MaybePrefix = Attributes ^ ee_attr_prefix,
+ add_string("[", !U),
+ (
+ MaybePrefix = no
+ ;
+ MaybePrefix = yes(Prefix),
+ add_string("prefix(", !U),
+ add_quoted_string(Prefix, !U),
+ add_char(')', !U)
+ ),
+ add_string("]", !U).
+
+:- pred mercury_format_pragma_foreign_export_enum_overrides(
+ assoc_list(sym_name, string)::in, U::di, U::uo) is det <= output(U).
+
+mercury_format_pragma_foreign_export_enum_overrides(Overrides, !U) :-
+ add_char('[', !U),
+ add_list(Overrides, ",",
+ mercury_format_pragma_foreign_export_enum_override, !U),
+ add_char(']', !U).
+
+:- pred mercury_format_pragma_foreign_export_enum_override(
+ 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),
+ add_string(" - ", !U),
+ add_quoted_string(ForeignName, !U).
+
+%-----------------------------------------------------------------------------%
+
:- pred mercury_format_pragma_foreign_export(foreign_language::in,
sym_name::in, pred_or_func::in, list(mer_mode)::in, string::in,
U::di, U::uo) is det <= output(U).
mercury_format_pragma_foreign_export(Lang, Name, PredOrFunc, ModeList,
- ExportName, !U) :-
+ ExportName, !U) :-
varset.init(Varset), % The varset isn't really used.
InstInfo = simple_inst_info(Varset),
add_string(":- pragma foreign_export(", !U),
@@ -3677,8 +3739,8 @@
%-----------------------------------------------------------------------------%
- % write a term to standard output.
-
+ % Write a term to standard output.
+ %
mercury_output_term(VarSet, AppendVarnums, Term, !IO) :-
mercury_output_term_nq(VarSet, AppendVarnums, not_next_to_graphic_token,
Term, !IO).
@@ -4316,8 +4378,9 @@
%-----------------------------------------------------------------------------%
-% Succeed if the sym_name describes a builtin inst.
+ % Succeed if the sym_name describes a builtin inst.
+ %
:- pred builtin_inst_name(sym_name::in, list(inst_var)::in) is semidet.
builtin_inst_name(unqualified(Name), Args0) :-
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.200
diff -u -r1.200 ml_code_gen.m
--- compiler/ml_code_gen.m 14 Jul 2007 02:32:45 -0000 1.200
+++ compiler/ml_code_gen.m 15 Jul 2007 12:43:22 -0000
@@ -805,10 +805,11 @@
ml_gen_foreign_code(ModuleInfo, ForeignCode, !IO),
ml_gen_imports(ModuleInfo, Imports),
ml_gen_defns(ModuleInfo, Defns, !IO),
+ ml_gen_exported_enums(ModuleInfo, ExportedEnums, !IO),
module_info_user_init_pred_c_names(ModuleInfo, InitPreds),
module_info_user_final_pred_c_names(ModuleInfo, FinalPreds),
MLDS = mlds(ModuleName, ForeignCode, Imports, Defns,
- InitPreds, FinalPreds).
+ InitPreds, FinalPreds, ExportedEnums).
:- pred ml_gen_foreign_code(module_info::in,
map(foreign_language, mlds_foreign_code)::out,
Index: compiler/ml_elim_nested.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_elim_nested.m,v
retrieving revision 1.91
diff -u -r1.91 ml_elim_nested.m
--- compiler/ml_elim_nested.m 15 Jun 2007 12:12:29 -0000 1.91
+++ compiler/ml_elim_nested.m 12 Jul 2007 04:45:34 -0000
@@ -463,7 +463,7 @@
ml_elim_nested(Action, MLDS0, MLDS, !IO) :-
globals.io_get_globals(Globals, !IO),
MLDS0 = mlds(ModuleName, ForeignCode, Imports, Defns0, InitPreds,
- FinalPreds),
+ FinalPreds, ExportedEnums),
MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
OuterVars = [],
DefnsList = list.map(
@@ -477,7 +477,7 @@
% of constants.
Defns = list.remove_dups(Defns1),
MLDS = mlds(ModuleName, ForeignCode, Imports, Defns, InitPreds,
- FinalPreds).
+ FinalPreds, ExportedEnums).
% Either eliminated nested functions:
% Hoist out any nested function occurring in a single mlds_defn.
Index: compiler/ml_tailcall.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_tailcall.m,v
retrieving revision 1.44
diff -u -r1.44 ml_tailcall.m
--- compiler/ml_tailcall.m 1 Dec 2006 15:04:08 -0000 1.44
+++ compiler/ml_tailcall.m 12 Jul 2007 04:47:44 -0000
@@ -526,7 +526,8 @@
:- pred nontailcall_in_mlds(mlds::in, tailcall_warning::out) is nondet.
nontailcall_in_mlds(MLDS, Warning) :-
- MLDS = mlds(ModuleName, _ForeignCode, _Imports, Defns, _InitPreds, _),
+ MLDS = mlds(ModuleName, _ForeignCode, _Imports, Defns, _InitPreds,
+ _FinalPreds, _ExportedEnums),
MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
nontailcall_in_defns(MLDS_ModuleName, Defns, Warning).
Index: compiler/ml_type_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_type_gen.m,v
retrieving revision 1.65
diff -u -r1.65 ml_type_gen.m
--- compiler/ml_type_gen.m 7 May 2007 05:21:32 -0000 1.65
+++ compiler/ml_type_gen.m 24 Jul 2007 06:54:04 -0000
@@ -75,6 +75,14 @@
%
:- pred ml_tag_uses_base_class(cons_tag::in) is semidet.
+
+ % Exported enumeration info in the HLDS is converted into an MLDS
+ % specific representation. The target specific code generators may
+ % further transform it.
+ %
+:- pred ml_gen_exported_enums(module_info::in, mlds_exported_enums::out,
+ io::di, io::uo) is det.
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -92,11 +100,13 @@
:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_util.
+:- import_module assoc_list.
:- import_module bool.
:- import_module int.
:- import_module list.
:- import_module map.
:- import_module maybe.
+:- import_module pair.
:- import_module set.
:- import_module term.
@@ -1000,6 +1010,61 @@
MLDS_DeclFlags = init_decl_flags(Access, PerInstance,
Virtuality, Finality, Constness, Abstractness).
+%----------------------------------------------------------------------------%
+
+ml_gen_exported_enums(ModuleInfo, MLDS_ExportedEnums, !IO) :-
+ module_info_get_exported_enums(ModuleInfo, ExportedEnumInfo),
+ module_info_get_type_table(ModuleInfo, TypeTable),
+ list.map_foldl(ml_gen_exported_enum(ModuleInfo, TypeTable),
+ ExportedEnumInfo, MLDS_ExportedEnums, !IO).
+
+:- pred ml_gen_exported_enum(module_info::in, type_table::in,
+ exported_enum_info::in, mlds_exported_enum::out, io::di, io::uo) is det.
+
+ml_gen_exported_enum(_ModuleInfo, TypeTable, ExportedEnumInfo,
+ MLDS_ExportedEnum, !IO) :-
+ ExportedEnumInfo = exported_enum_info(Lang, Context, TypeCtor, Mapping),
+ map.lookup(TypeTable, TypeCtor, TypeDefn),
+ get_type_defn_body(TypeDefn, TypeBody),
+ (
+ ( TypeBody = hlds_eqv_type(_)
+ ; TypeBody = hlds_foreign_type(_)
+ ; TypeBody = hlds_solver_type(_, _)
+ ; TypeBody = hlds_abstract_type(_)
+ ),
+ unexpected(this_file, "ml_gen_exported_enum - invalid type (2).")
+ ;
+ TypeBody = hlds_du_type(Ctors, TagValues, _IsEnumOrDummy, _MaybeUserEq,
+ _ReservedTag, _IsForeignType),
+ list.foldl(generate_foreign_enum_constant(Mapping, TagValues),
+ Ctors, [], NamesAndTags),
+ MLDS_ExportedEnum = mlds_exported_enum(Lang, Context,
+ mlds_native_int_type, NamesAndTags)
+ ).
+
+:- pred generate_foreign_enum_constant(map(sym_name, string)::in,
+ cons_tag_values::in, constructor::in,
+ assoc_list(string, mlds_entity_defn)::in,
+ assoc_list(string, mlds_entity_defn)::out) is det.
+
+generate_foreign_enum_constant(Mapping, TagValues, Ctor, !NamesAndTags) :-
+ Ctor = ctor(_, _, QualName, Args, _),
+ list.length(Args, Arity),
+ map.lookup(TagValues, cons(QualName, Arity), TagVal),
+ ( TagVal = int_tag(Int) ->
+ ConstValue = const(mlconst_int(Int))
+ ;
+ unexpected(this_file, "enum constant requires an int tag")
+ ),
+ % Sanity check.
+ expect(unify(Arity, 0), this_file, "enum constant arity != 0"),
+ EntityDefn = mlds_data(mlds_native_int_type, init_obj(ConstValue),
+ gc_no_stmt),
+ UnqualName = unqualify_name(QualName),
+ UnqualSymName = unqualified(UnqualName),
+ map.lookup(Mapping, UnqualSymName, ForeignName),
+ list.cons(ForeignName - EntityDefn, !NamesAndTags).
+
%-----------------------------------------------------------------------------%
:- func this_file = string.
Index: compiler/mlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds.m,v
retrieving revision 1.150
diff -u -r1.150 mlds.m
--- compiler/mlds.m 15 Jun 2007 12:12:30 -0000 1.150
+++ compiler/mlds.m 12 Jul 2007 05:25:04 -0000
@@ -344,6 +344,7 @@
:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_foreign.
+:- import_module assoc_list.
:- import_module bool.
:- import_module list.
:- import_module map.
@@ -381,7 +382,8 @@
% XXX These only work for the C backend because initialisers
% and finalisers do not (yet) work for the other backends.
init_preds :: list(string),
- final_preds :: list(string)
+ final_preds :: list(string),
+ exported_enums :: list(mlds_exported_enum)
).
:- func mlds_get_module_name(mlds) = mercury_module_name.
@@ -1716,6 +1718,21 @@
:- func flip_initial_case_of_final_part(sym_name) = sym_name.
%-----------------------------------------------------------------------------%
+
+:- type mlds_exported_enums == list(mlds_exported_enum).
+
+:- type mlds_exported_enum
+ ---> mlds_exported_enum(
+ foreign_language, % For sanity checking.
+ prog_context,
+ mlds_type, % Type of the constants (hard coded as
+ % 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.
+ ).
+
+%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
Index: compiler/mlds_to_c.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_c.m,v
retrieving revision 1.218
diff -u -r1.218 mlds_to_c.m
--- compiler/mlds_to_c.m 17 Jul 2007 23:48:27 -0000 1.218
+++ compiler/mlds_to_c.m 18 Jul 2007 07:25:42 -0000
@@ -157,7 +157,7 @@
mlds_output_hdr_file(Indent, MLDS, !IO) :-
MLDS = mlds(ModuleName, AllForeignCode, Imports, Defns, InitPreds,
- FinalPreds),
+ FinalPreds, ExportEnums),
mlds_output_hdr_start(Indent, ModuleName, !IO),
io.nl(!IO),
mlds_output_hdr_imports(Indent, Imports, !IO),
@@ -167,6 +167,8 @@
ForeignCode = mlds_get_c_foreign_code(AllForeignCode),
mlds_output_c_hdr_decls(MLDS_ModuleName, Indent, ForeignCode, !IO),
io.nl(!IO),
+ mlds_output_export_enums(ExportEnums, Indent, !IO),
+ io.nl(!IO),
% The header file must contain _definitions_ of all public types, but only
% _declarations_ of all public variables, constants, and functions.
@@ -263,7 +265,7 @@
mlds_output_src_file(Indent, MLDS, !IO) :-
MLDS = mlds(ModuleName, AllForeignCode, Imports, Defns,
- InitPreds, FinalPreds),
+ InitPreds, FinalPreds, _ExportEnums),
ForeignCode = mlds_get_c_foreign_code(AllForeignCode),
EnvVarNameSet = mlds_get_env_var_names(Defns),
@@ -1205,6 +1207,51 @@
),
Params = mlds_func_params(InputArgs, [ReturnArgType]).
+:- pred mlds_output_export_enums(list(mlds_exported_enum)::in, indent::in,
+ io::di, io::uo) is det.
+
+mlds_output_export_enums(ExportedEnums, Indent, !IO) :-
+ list.foldl(mlds_output_export_enum(Indent), ExportedEnums, !IO).
+
+:- pred mlds_output_export_enum(indent::in, mlds_exported_enum::in,
+ io::di, io::uo) is det.
+
+mlds_output_export_enum(_Indent, ExportedEnum, !IO) :-
+ ExportedEnum = mlds_exported_enum(Lang, Context, _Type,
+ NamesAndTags0),
+ (
+ Lang = lang_c,
+ output_context(mlds_make_context(Context), !IO),
+ % We reverse the list so the constants are printed out in order.
+ list.reverse(NamesAndTags0, NamesAndTags),
+ list.foldl(mlds_output_exported_enum_constant, NamesAndTags, !IO)
+ ;
+ ( Lang = lang_csharp
+ ; Lang = lang_java
+ ; Lang = lang_il
+ ; Lang = lang_erlang
+ )
+ ).
+
+:- pred mlds_output_exported_enum_constant(pair(string, mlds_entity_defn)::in,
+ io::di, io::uo) is det.
+
+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)
+ ;
+ unexpected(this_file,
+ "bad entity_defn for exported enumeration value.")
+ ).
+
%-----------------------------------------------------------------------------%
%
% Code to output declarations and definitions
Index: compiler/mlds_to_gcc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_gcc.m,v
retrieving revision 1.131
diff -u -r1.131 mlds_to_gcc.m
--- compiler/mlds_to_gcc.m 2 Jul 2007 05:30:29 -0000 1.131
+++ compiler/mlds_to_gcc.m 12 Jul 2007 04:54:21 -0000
@@ -238,7 +238,7 @@
mlds_to_gcc__compile_to_asm(MLDS, ContainsCCode) -->
% XXX We need to handle initialise declarations properly here.
{ MLDS = mlds(ModuleName, AllForeignCode, Imports, Defns0,
- InitPreds, FinalPreds) },
+ InitPreds, FinalPreds, ExportedEnums) },
%
% Handle output of any foreign code (C, Ada, Fortran, etc.)
@@ -291,7 +291,7 @@
% to create the .mih file, and if necessary the .c file.
{ ForeignMLDS = mlds(ModuleName, AllForeignCode, Imports,
list__map(make_public, ForeignDefns), InitPreds,
- FinalPreds) },
+ FinalPreds, ExportedEnums) },
mlds_to_c__output_c_file(ForeignMLDS, "")
),
%
Index: compiler/mlds_to_il.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_il.m,v
retrieving revision 1.186
diff -u -r1.186 mlds_to_il.m
--- compiler/mlds_to_il.m 14 Jul 2007 02:32:46 -0000 1.186
+++ compiler/mlds_to_il.m 15 Jul 2007 12:43:23 -0000
@@ -280,7 +280,7 @@
generate_il(MLDS, Version, ILAsm, ForeignLangs, !IO) :-
% XXX initialise declarations NYI for IL backend
- mlds(MercuryModuleName, ForeignCode, Imports, Defns, _, _) =
+ mlds(MercuryModuleName, ForeignCode, Imports, Defns, _, _, _) =
transform_mlds(MLDS),
ModuleName = mercury_module_name_to_mlds(MercuryModuleName),
Index: compiler/mlds_to_ilasm.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_ilasm.m,v
retrieving revision 1.38
diff -u -r1.38 mlds_to_ilasm.m
--- compiler/mlds_to_ilasm.m 14 Jul 2007 02:32:46 -0000 1.38
+++ compiler/mlds_to_ilasm.m 15 Jul 2007 12:43:23 -0000
@@ -110,7 +110,7 @@
output_assembler(MLDS, ForeignLangs, !IO) :-
MLDS = mlds(ModuleName, _ForeignCode, _Imports, _Defns,
- _InitPreds, _FinalPreds),
+ _InitPreds, _FinalPreds, _ExportedEnums),
output_src_start(ModuleName, !IO),
io.nl(!IO),
Index: compiler/mlds_to_java.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_java.m,v
retrieving revision 1.94
diff -u -r1.94 mlds_to_java.m
--- compiler/mlds_to_java.m 14 Jul 2007 02:32:46 -0000 1.94
+++ compiler/mlds_to_java.m 15 Jul 2007 12:43:23 -0000
@@ -414,7 +414,7 @@
output_java_src_file(ModuleInfo, Indent, MLDS, !IO) :-
% Run further transformations on the MLDS.
MLDS = mlds(ModuleName, AllForeignCode, Imports, Defns0,
- _InitPreds, _FinalPreds),
+ _InitPreds, _FinalPreds, _ExportedEnums),
MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
% Find and build list of all methods which would have their addresses
Index: compiler/mlds_to_managed.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_managed.m,v
retrieving revision 1.44
diff -u -r1.44 mlds_to_managed.m
--- compiler/mlds_to_managed.m 17 Jul 2007 23:48:27 -0000 1.44
+++ compiler/mlds_to_managed.m 18 Jul 2007 07:25:42 -0000
@@ -66,7 +66,7 @@
output_csharp_code(MLDS, !IO) :-
MLDS = mlds(ModuleName, _ForeignCode, _Imports, _Defns,
- _InitPreds, _FinalPreds),
+ _InitPreds, _FinalPreds, _ExportedEnums),
output_src_start(ModuleName, !IO),
io.nl(!IO),
generate_code(MLDS, !IO),
@@ -97,7 +97,7 @@
generate_code(MLDS, !IO) :-
MLDS = mlds(ModuleName, AllForeignCode, _Imports, Defns,
- _InitPreds, _FinalPreds),
+ _InitPreds, _FinalPreds, _ExportedEnums),
ClassName = class_name(mercury_module_name_to_mlds(ModuleName),
wrapper_class_name),
io.nl(!IO),
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.156
diff -u -r1.156 module_qual.m
--- compiler/module_qual.m 19 Jan 2007 07:04:23 -0000 1.156
+++ compiler/module_qual.m 13 Jul 2007 07:01:46 -0000
@@ -1132,10 +1132,23 @@
qualify_type(kinded_type(Type0, Kind), kinded_type(Type, Kind),
!Info, !Specs) :-
qualify_type(Type0, Type, !Info, !Specs).
+
+:- pred qualify_type_ctor(type_ctor::in, type_ctor::out, mq_info::in, mq_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
- % Qualify the modes in a pragma c_code(...) decl.
- %
-:- pred qualify_pragma((pragma_type)::in, (pragma_type)::out,
+qualify_type_ctor(!TypeCtor, !Info, !Specs) :-
+ !.TypeCtor = type_ctor(SymName0, Arity),
+ ( is_builtin_atomic_type(!.TypeCtor) ->
+ SymName = SymName0
+ ;
+ TypeCtorId0 = mq_id(SymName0, Arity),
+ mq_info_get_types(!.Info, Types),
+ find_unique_match(TypeCtorId0, TypeCtorId, Types, type_id, !Info, !Specs),
+ TypeCtorId = mq_id(SymName, _)
+ ),
+ !:TypeCtor = type_ctor(SymName, Arity).
+
+:- pred qualify_pragma(pragma_type::in, pragma_type::out,
mq_info::in, mq_info::out,
list(error_spec)::in, list(error_spec)::out) is det.
@@ -1144,6 +1157,13 @@
qualify_pragma(X @ pragma_foreign_code(_, _), X, !Info, !Specs).
qualify_pragma(X @ pragma_foreign_import_module(_, _), X, !Info, !Specs).
qualify_pragma(X, Y, !Info, !Specs) :-
+ X = pragma_foreign_export_enum(Lang, TypeName0, TypeArity0, Attributes,
+ Overrides),
+ qualify_type_ctor(type_ctor(TypeName0, TypeArity0),
+ type_ctor(TypeName, TypeArity), !Info, !Specs),
+ Y = pragma_foreign_export_enum(Lang, TypeName, TypeArity, Attributes,
+ Overrides).
+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/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.435
diff -u -r1.435 modules.m
--- compiler/modules.m 14 Jul 2007 02:32:47 -0000 1.435
+++ compiler/modules.m 15 Jul 2007 12:43:23 -0000
@@ -2227,14 +2227,15 @@
% but if we do allow it, we should put it in the generated
% header file, which currently we don't.
+pragma_allowed_in_interface(pragma_foreign_code(_, _), no).
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_import_module(_, _), yes).
-pragma_allowed_in_interface(pragma_foreign_code(_, _), no).
pragma_allowed_in_interface(pragma_foreign_proc(_, _, _, _, _, _, _), no).
pragma_allowed_in_interface(pragma_inline(_, _), no).
pragma_allowed_in_interface(pragma_no_inline(_, _), no).
pragma_allowed_in_interface(pragma_obsolete(_, _), yes).
-pragma_allowed_in_interface(pragma_foreign_export(_, _, _, _, _), no).
pragma_allowed_in_interface(pragma_import(_, _, _, _, _), no).
pragma_allowed_in_interface(pragma_source_file(_), yes).
% yes, but the parser will strip out `source_file' pragmas anyway...
@@ -7923,6 +7924,7 @@
; Pragma = pragma_trailing_info(_, _, _, _, _), Reorderable = yes
; Pragma = pragma_mm_tabling_info(_, _, _, _, _), Reorderable = yes
; Pragma = pragma_foreign_export(_, _, _, _, _), Reorderable = yes
+ ; Pragma = pragma_foreign_export_enum(_, _, _, _, _), Reorderable = yes
; Pragma = pragma_fact_table(_, _, _), Reorderable = no
; Pragma = pragma_foreign_code(_, _), Reorderable = no
; Pragma = pragma_foreign_decl(_, _, _), Reorderable = no
@@ -8010,6 +8012,7 @@
; Pragma = pragma_foreign_decl(_, _, _), Reorderable = no
; Pragma = pragma_foreign_import_module(_, _), Reorderable = no
; Pragma = pragma_foreign_proc(_, _, _, _, _, _, _), Reorderable = no
+ ; Pragma = pragma_foreign_export_enum(_, _, _, _, _), Reorderable = yes
; Pragma = pragma_import(_, _, _, _, _), Reorderable = no
; Pragma = pragma_inline(_, _), Reorderable = yes
; Pragma = pragma_mode_check_clauses(_, _), Reorderable = yes
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.191
diff -u -r1.191 prog_data.m
--- compiler/prog_data.m 12 Jun 2007 06:53:57 -0000 1.191
+++ compiler/prog_data.m 13 Jul 2007 02:51:06 -0000
@@ -601,6 +601,19 @@
%-----------------------------------------------------------------------------%
%
+% Stuff for the `foreign_export_enum' pragma
+%
+
+
+:- type export_enum_attributes
+ ---> export_enum_attributes(
+ ee_attr_prefix :: maybe(string)
+ ).
+
+:- func default_export_enum_attributes = export_enum_attributes.
+
+%-----------------------------------------------------------------------------%
+%
% Type classes
%
@@ -1185,7 +1198,7 @@
:- type type_param == tvar.
% Use type_util.type_to_ctor_and_args to convert a type to a qualified
- % type_ctor and a list of arguments. Use type_util.construct_type to
+ % type_ctor and a list of arguments. Use prog_type.construct_type to
% construct a type from a type_ctor and a list of arguments.
%
:- type mer_type
@@ -2206,6 +2219,14 @@
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
+%
+% Stuff for the `foreign_export_enum' pragma
+%
+
+default_export_enum_attributes = export_enum_attributes(no).
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
:- func this_file = string.
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.125
diff -u -r1.125 prog_io_pragma.m
--- compiler/prog_io_pragma.m 14 Jul 2007 02:32:48 -0000 1.125
+++ compiler/prog_io_pragma.m 23 Jul 2007 08:08:15 -0000
@@ -213,6 +213,188 @@
parse_pragma_foreign_proc_pragma(ModuleName, "foreign_proc",
PragmaTerms, ErrorTerm, VarSet, Result).
+
+%----------------------------------------------------------------------------%
+%
+% Code for parsing foreign_export_enum pragmas
+%
+
+parse_pragma_type(_ModuleName, "foreign_export_enum", PragmaTerms, ErrorTerm,
+ _VarSet, Result) :-
+ (
+
+ (
+ PragmaTerms = [LangTerm, MercuryTypeTerm],
+ MaybeAttributesTerm = no,
+ MaybeOverridesTerm = no
+ ;
+ PragmaTerms = [LangTerm, MercuryTypeTerm, AttributesTerm],
+ MaybeAttributesTerm = yes(AttributesTerm),
+ MaybeOverridesTerm = no
+
+ ;
+ PragmaTerms = [LangTerm, MercuryTypeTerm, AttributesTerm,
+ OverridesTerm],
+ MaybeAttributesTerm = yes(AttributesTerm),
+ MaybeOverridesTerm = yes(OverridesTerm)
+ )
+ ->
+ ( parse_foreign_language(LangTerm, ForeignLanguage) ->
+ parse_export_enum_type(MercuryTypeTerm, MaybeType),
+ (
+ MaybeType = ok2(Name, Arity),
+ maybe_parse_export_enum_attributes(MaybeAttributesTerm,
+ MaybeAttributes),
+ (
+ MaybeAttributes = ok1(Attributes),
+ maybe_parse_export_enum_overrides(MaybeOverridesTerm,
+ MaybeOverrides),
+ (
+ MaybeOverrides = ok1(Overrides),
+ PragmaExportEnum = pragma_foreign_export_enum(
+ ForeignLanguage, Name, Arity, Attributes,
+ Overrides
+ ),
+ Item = item_pragma(user, PragmaExportEnum),
+ Result = ok1(Item)
+ ;
+ MaybeOverrides = error1(Errors),
+ Result = error1(Errors)
+ )
+ )
+ ;
+ MaybeType = error2(Errors),
+ Result = error1(Errors)
+ )
+ ;
+ Msg = "invalid foreign_langauge in " ++
+ "`:- pragma foreign_export_enum' declaration",
+ Result = error1([Msg - ErrorTerm])
+ )
+ ;
+ Msg = "wrong number of arguments in " ++
+ "`:- pragma foreign_export_enum' declaration",
+ Result = error1([Msg - ErrorTerm])
+ ).
+
+:- pred parse_export_enum_type(term::in,
+ maybe2(sym_name, arity)::out) is det.
+
+parse_export_enum_type(TypeTerm, Result) :-
+ ( parse_name_and_arity(TypeTerm, Name, Arity) ->
+ Result = ok2(Name, Arity)
+ ;
+ Msg = "expected name/arity for type in " ++
+ "`pragma foreign_expor_enum' declaration",
+ Result = error2([Msg - TypeTerm])
+ ).
+
+:- pred maybe_parse_export_enum_overrides(maybe(term)::in,
+ maybe1(assoc_list(sym_name, string))::out) is det.
+
+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).
+
+:- pred parse_export_enum_override(term::in,
+ maybe1(pair(sym_name, string))::out) is semidet.
+
+parse_export_enum_override(Renaming, MaybeMappingElement) :-
+ Renaming = functor(Functor, Args, _),
+ Functor = term.atom("-"),
+ Args = [CtorTerm, ForeignNameTerm],
+ ForeignNameTerm = functor(term.string(ForeignName), _, _),
+ parse_qualified_term(CtorTerm, CtorTerm, "export enum const",
+ MaybeCtorResult),
+ (
+ MaybeCtorResult = ok2(SymName, []),
+ MaybeMappingElement = ok1(SymName - ForeignName)
+ ;
+ MaybeCtorResult = error2(Errs),
+ MaybeMappingElement = error1(Errs)
+ ).
+
+:- pred maybe_parse_export_enum_attributes(maybe(term)::in,
+ maybe1(export_enum_attributes)::out) is det.
+
+maybe_parse_export_enum_attributes(no, ok1(default_export_enum_attributes)).
+maybe_parse_export_enum_attributes(yes(AttributesTerm), MaybeAttributes) :-
+ parse_export_enum_attributes(AttributesTerm, MaybeAttributes).
+
+:- type collected_export_enum_attribute
+ ---> ee_attr_prefix(maybe(string)).
+
+:- pred parse_export_enum_attributes(term::in,
+ maybe1(export_enum_attributes)::out) is det.
+
+parse_export_enum_attributes(AttributesTerm, AttributesResult) :-
+ Attributes0 = default_export_enum_attributes,
+ ConflictingAttributes = [],
+ (
+ list_term_to_term_list(AttributesTerm, AttributesTerms),
+ map_parser(parse_export_enum_attr, AttributesTerms, MaybeAttrList),
+ MaybeAttrList = ok1(CollectedAttributes)
+ ->
+ (
+ list.member(ConflictA - ConflictB, ConflictingAttributes),
+ list.member(ConflictA, CollectedAttributes),
+ list.member(ConflictB, CollectedAttributes)
+ ->
+ Msg = "conflicting attributes in attribute list",
+ AttributesResult = error1([Msg - AttributesTerm])
+ ;
+ % Check that the prefix attribute is specified at most once.
+ %
+ IsPrefixAttr = (pred(A::in) is semidet :-
+ A = ee_attr_prefix(_)
+ ),
+ list.filter(IsPrefixAttr, CollectedAttributes, PrefixAttributes),
+ (
+ ( PrefixAttributes = []
+ ; PrefixAttributes = [_]
+ ),
+ list.foldl(process_export_enum_attribute, CollectedAttributes,
+ Attributes0, Attributes),
+ AttributesResult = ok1(Attributes)
+ ;
+ PrefixAttributes = [_, _ | _],
+ Msg = "prefix attribute occurs multiple times in " ++
+ "foreign_export_enum pragma",
+ AttributesResult = error1([Msg - AttributesTerm])
+ )
+ )
+ ;
+ Msg = "malformed attributes list in foreign_export_enum pragma",
+ AttributesResult = error1([Msg - AttributesTerm])
+ ).
+
+:- pred process_export_enum_attribute(collected_export_enum_attribute::in,
+ export_enum_attributes::in, export_enum_attributes::out) is det.
+
+process_export_enum_attribute(ee_attr_prefix(MaybePrefix), _, Attributes) :-
+ Attributes = export_enum_attributes(MaybePrefix).
+
+:- pred parse_export_enum_attr(term::in,
+ maybe1(collected_export_enum_attribute)::out) is det.
+
+parse_export_enum_attr(Term, Result) :-
+ (
+ Term = functor(atom("prefix"), Args, _),
+ Args = [ ForeignNameTerm ],
+ ForeignNameTerm = functor(string(Prefix), [], _)
+ ->
+ Result = ok1(ee_attr_prefix(yes(Prefix)))
+ ;
+ Msg = "unrecongised attribute in foreign_export_enum pragma",
+ Result = error1([Msg - Term])
+ ).
+
+%----------------------------------------------------------------------------%
+%
+% Code for parsing foreign_export pragmas
+%
+
parse_pragma_type(_ModuleName, "foreign_export", PragmaTerms, ErrorTerm,
_VarSet, Result) :-
( PragmaTerms = [LangTerm, PredAndModesTerm, FunctionTerm] ->
Index: compiler/prog_item.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_item.m,v
retrieving revision 1.27
diff -u -r1.27 prog_item.m
--- compiler/prog_item.m 12 Jun 2007 06:53:57 -0000 1.27
+++ compiler/prog_item.m 12 Jul 2007 12:59:19 -0000
@@ -433,6 +433,14 @@
% whether or not the foreign code is thread-safe
% foreign function name.
)
+ ;
+ pragma_foreign_export_enum(
+ export_enum_language :: foreign_language,
+ export_enum_type_name :: sym_name,
+ export_enum_type_arity :: arity,
+ export_enum_attributes :: export_enum_attributes,
+ export_enum_overrides :: assoc_list(sym_name, string)
+ )
%
% Optimization pragmas
%
Index: compiler/recompilation.version.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/recompilation.version.m,v
retrieving revision 1.58
diff -u -r1.58 recompilation.version.m
--- compiler/recompilation.version.m 19 Jan 2007 07:04:30 -0000 1.58
+++ compiler/recompilation.version.m 12 Jul 2007 13:31:51 -0000
@@ -587,6 +587,7 @@
adjust_func_arity(PredOrFunc, Arity, list.length(Modes)).
% 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_source_file(_), no).
is_pred_pragma(pragma_unused_args(PredOrFunc, Name, Arity, _, _),
yes(yes(PredOrFunc) - Name / Arity)).
Index: doc/reference_manual.texi
===================================================================
RCS file: /home/mercury1/repository/mercury/doc/reference_manual.texi,v
retrieving revision 1.400
diff -u -r1.400 reference_manual.texi
--- doc/reference_manual.texi 20 Jul 2007 03:47:54 -0000 1.400
+++ doc/reference_manual.texi 24 Jul 2007 06:29:55 -0000
@@ -6175,7 +6175,10 @@
programming language.
* Using foreign types from Mercury:: How to use a type defined in
a different programming language
- in Mercury code.
+ in Mercury code.
+* Using Mercury enumerations in foreign code:: How to use a enumeration type
+ defined in Mercury in a
+ different programming language.
* Data passing conventions:: How Mercury types are passed to
different languages.
* Adding foreign declarations:: How to add declarations of
@@ -6918,6 +6921,83 @@
@c -----------------------------------------------------------------------
+ at node Using Mercury enumerations in foreign code
+ at section Using Mercury enumerations in foreign code
+
+Values of Mercury enumeration types can be made available to code in the
+bodies of @samp{foreign_proc} and @samp{foreign_code} pragmas via
+a declaration of the form:
+
+ at example
+:- pragma foreign_export_enum(@var{Lang}, @var{MercuryType},
+ @var{Attributes}, @var{Overrides}).
+ at end example
+
+This causes the compiler to create a symbolic name in language
+ at var{Lang} for each of the constructors of @var{MercuryType}.
+The symbolic name allows the foreign code to create a value
+corresponding to that of the constructor it represents.
+(The exact mechanism used depends upon the foreign language;
+see the language specific information below for further details.)
+
+For each foreign language there is a default mapping between the name
+of a Mercury constructor and its symbolic name in the language @var{Lang}.
+This default mapping is not required to map every valid constructor name
+to a valid name in language @var{Lang}; where it does not the programmer
+must specify a valid symbolic name.
+The programmer may also choose to map a constructor to a symbolic name
+that differs from the one supplied by the default mapping for language
+ at var{Lang}.
+ at var{Overrides} is a list whose elements are pairs of constructor names
+and strings.
+The latter specify the name that the implementation should use as the
+symbolic name in the foreign language.
+ at var{Overrides} has the following form:
+
+ at example
+[consI - "symbolI", ..., consJ - "symbolJ"]
+ at end example
+
+This can be used to provide either a valid symbolic name where the
+default mapping does not, or to override a valid symbolic name
+generated by the default mapping.
+This argument may be omitted if @var{Overrides} is empty.
+
+The argument @var{Attributes} is a list of optional attributes.
+If empty, it may be omitted from the @samp{pragma foreign_export_enum}
+declaration.
+The following attribute must be supported by all Mercury implementations.
+
+ at table @asis
+
+ at item @samp{prefix(Prefix)}
+Prefix each symbolic name, regardless of how it was generated, with
+the string @var{Prefix}.
+This occurs @emph{before} the validity of the symbolic name in the
+foreign language is checked, i.e. the effect of the @samp{prefix}
+attribute may cause an otherwise valid symbolic name to become invalid or
+vice versa.
+At most one @samp{prefix} attribute may be specified for a
+ at samp{pragma foreign_export_enum} declaration.
+
+ at end table
+
+It is an error if the mapping between constructors and symbolic names
+does not form a bijection.
+A program can contain multiple @samp{pragma foreign_export_enum}
+declarations for a single Mercury type.
+The implementation is not required to check that the symbolic names
+generated by separate @samp{pragma foreign_export_enum} declarations
+are unique.
+
+A module may contain @samp{pragma foreign_export_enum} declarations that
+refer to imported types, subject to the usual visibility restrictions.
+
+A @samp{pragma foreign_export_enum} declaration may not occur in the
+interface of module.
+
+ at c -----------------------------------------------------------------------
+
@node Adding foreign declarations
@section Adding foreign declarations
@@ -7072,11 +7152,12 @@
@subsection Interfacing with C
@menu
-* Using pragma foreign_type for C :: Declaring C types in Mercury
-* 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
-* Using pragma foreign_code for C :: Including C code in Mercury
+* 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_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
+* Using pragma foreign_code for C :: Including C code in Mercury
@end menu
@node Using pragma foreign_type for C
@@ -7126,6 +7207,27 @@
@c XXX we should eventually just move that section to here,
@c presenting it as an alternative to pragma foreign_type.
+ at node Using pragma foreign_export_enum for C
+ at subsubsection Using pragma foreign_export_enum for C
+
+For C the symbolic names generated by a @samp{pragma foreign_export_enum}
+must form valid C identifiers.
+Theses identifiers are used as the names of preprocessor macros.
+The body of each of these macros expands to a value that is identical
+to that of the constructor to which the symbolic name corresponds in
+the mapping established by the @samp{pragma foreign_export_enum}
+declaration.
+
+As noted in the @pxref{C data passing conventions}, the type of these
+values is @samp{MR_Word}.
+
+The default mapping used by @samp{pragma foreign_export_enum}
+declarations for C is to use the Mercury constructor name as the
+base of the symbolic name.
+
+ at c It would be useful if there were some documented way of mapping
+ at c these things into [0, N - 1], e.g. for array lookups.
+
@node Using pragma foreign_proc for C
@subsubsection Using pragma foreign_proc for C
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/Mmakefile,v
retrieving revision 1.325
diff -u -r1.325 Mmakefile
--- tests/hard_coded/Mmakefile 25 Jun 2007 00:58:14 -0000 1.325
+++ tests/hard_coded/Mmakefile 23 Jul 2007 04:59:35 -0000
@@ -61,6 +61,8 @@
dummy_type_construct \
dupcall_impurity \
dupcall_types_bug \
+ ee_dummy \
+ ee_valid_test \
elim_special_pred \
equality_pred_which_requires_boxing \
eqv_type_bug \
Index: tests/hard_coded/ee_dummy.exp
===================================================================
RCS file: tests/hard_coded/ee_dummy.exp
diff -N tests/hard_coded/ee_dummy.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/ee_dummy.exp 23 Jul 2007 04:58:35 -0000
@@ -0,0 +1,2 @@
+FOO_dummy_type exists.
+BAR_poly_dummy_type exists.
Index: tests/hard_coded/ee_dummy.m
===================================================================
RCS file: tests/hard_coded/ee_dummy.m
diff -N tests/hard_coded/ee_dummy.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/ee_dummy.m 23 Jul 2007 04:59:18 -0000
@@ -0,0 +1,57 @@
+% Check that foreign_export_enum for dummy types works.
+%
+:- module ee_dummy.
+:- interface.
+
+:- import_module io.
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+
+:- import_module bool.
+
+:- type dummy_type
+ ---> dummy_type.
+
+:- type poly_dummy_type(T)
+ ---> poly_dummy_type.
+
+:- pragma foreign_export_enum("C", dummy_type/0, [prefix("FOO_")]).
+:- pragma foreign_export_enum("C", poly_dummy_type/1, [prefix("BAR_")]).
+
+main(!IO) :-
+ check_dummy_type(dummy_type, DummyTypeSucceeded, !IO),
+ (
+ DummyTypeSucceeded = yes,
+ io.write_string("FOO_dummy_type exists.\n", !IO)
+ ;
+ DummyTypeSucceeded = no,
+ io.write_string("FOO_dummy_type does not exist\n", !IO)
+ ),
+ check_poly_dummy_type(poly_dummy_type, PolyDummyTypeSucceeded, !IO),
+ (
+ PolyDummyTypeSucceeded = yes,
+ io.write_string("BAR_poly_dummy_type exists.\n", !IO)
+ ;
+ PolyDummyTypeSucceeded = no,
+ io.write_string("BAR_poly_dummy_type does not exist\n", !IO)
+ ).
+
+:- pred check_dummy_type(dummy_type::in, bool::out, io::di, io::uo) is det.
+:- pragma foreign_proc("C",
+ check_dummy_type(X::in, Result::out, IO0::di, IO::uo),
+ [will_not_call_mercury, promise_pure],
+"
+ Result = (X == FOO_dummy_type) ? MR_YES : MR_NO;
+ IO = IO0;
+").
+
+:- pred check_poly_dummy_type(poly_dummy_type(dummy_type)::in, bool::out,
+ io::di, io::uo) is det.
+:- pragma foreign_proc("C",
+ check_poly_dummy_type(X::in, Result::out, IO0::di, IO::uo),
+ [will_not_call_mercury, promise_pure],
+"
+ Result = (X == BAR_poly_dummy_type) ? MR_YES : MR_NO;
+ IO = IO0;
+").
Index: tests/hard_coded/ee_valid_test.exp
===================================================================
RCS file: tests/hard_coded/ee_valid_test.exp
diff -N tests/hard_coded/ee_valid_test.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/ee_valid_test.exp 24 Jul 2007 06:34:50 -0000
@@ -0,0 +1,5 @@
+default mapping: apple = apple
+default mapping: orange = orange
+with prefix: pear = pear
+user mapping: lemon = lemon
+default mapping with quoted names: bar = 'BAR'
Index: tests/hard_coded/ee_valid_test.m
===================================================================
RCS file: tests/hard_coded/ee_valid_test.m
diff -N tests/hard_coded/ee_valid_test.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/ee_valid_test.m 24 Jul 2007 06:33:50 -0000
@@ -0,0 +1,99 @@
+% vim: ft=mercury ts=4 sw=4 et wm=0 tw=0
+:- module ee_valid_test.
+:- interface.
+
+:- import_module io.
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+
+main(!IO) :-
+ io.write_string("default mapping: apple = ", !IO),
+ io.write(get_default_apple, !IO),
+ io.nl(!IO),
+ io.write_string("default mapping: orange = ", !IO),
+ io.write(get_default_orange, !IO),
+ io.nl(!IO),
+ io.write_string("with prefix: pear = ", !IO),
+ io.write(get_prefix_pear, !IO),
+ io.nl(!IO),
+ io.write_string("user mapping: lemon = ", !IO),
+ io.write(get_user_lemon, !IO),
+ io.nl(!IO),
+ io.write_string("default mapping with quoted names: bar = ", !IO),
+ io.write(get_bar, !IO),
+ io.nl(!IO).
+
+:- type fruit
+ ---> apple
+ ; orange
+ ; pear
+ ; lemon.
+
+:- type foo
+ ---> 'FOO'
+ ; 'BAR'
+ ; 'BAZ'.
+
+ % Default mapping.
+ %
+:- pragma foreign_export_enum("C", fruit/0).
+
+ % Default mapping with prefix.
+ %
+:- pragma foreign_export_enum("C", fruit/0, [prefix("PREFIX_")]).
+
+ % User-specified mapping.
+ % Also checks that module qualifiers on constructor names are handled.
+ %
+:- pragma foreign_export_enum("C", fruit/0, [prefix("USER_")],
+ [
+ ee_valid_test.apple - "APPLE",
+ orange - "ORANGE",
+ ee_valid_test.pear - "PEAR",
+ ee_valid_test.lemon - "LEMON"
+ ]).
+
+ % Default mapping for quoted Mercury names.
+ %
+:- pragma foreign_export_enum("C", foo/0).
+
+:- func get_default_apple = fruit.
+:- pragma foreign_proc("C",
+ get_default_apple = (X::out),
+ [will_not_call_mercury, promise_pure],
+"
+ X = apple;
+").
+
+:- func get_default_orange = fruit.
+:- pragma foreign_proc("C",
+ get_default_orange = (X::out),
+ [will_not_call_mercury, promise_pure],
+"
+ X = orange;
+").
+
+:- func get_prefix_pear = fruit.
+:- pragma foreign_proc("C",
+ get_prefix_pear = (X::out),
+ [will_not_call_mercury, promise_pure],
+"
+ X = PREFIX_pear;
+").
+
+:- func get_user_lemon = fruit.
+:- pragma foreign_proc("C",
+ get_user_lemon = (X::out),
+ [will_not_call_mercury, promise_pure],
+"
+ X = USER_LEMON;
+").
+
+:- func get_bar = foo.
+:- pragma foreign_proc("C",
+ get_bar = (X::out),
+ [will_not_call_mercury, promise_pure],
+"
+ X = BAR;
+").
Index: tests/invalid/Mercury.options
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/Mercury.options,v
retrieving revision 1.23
diff -u -r1.23 Mercury.options
--- tests/invalid/Mercury.options 25 May 2007 06:45:53 -0000 1.23
+++ tests/invalid/Mercury.options 23 Jul 2007 07:51:34 -0000
@@ -17,6 +17,7 @@
MCFLAGS-children = --no-intermodule-optimization \
--no-automatic-intermodule-optimization
MCFLAGS-duplicate_modes = --verbose-error-messages
+MCFLAGS-ee_invalid = --verbose-error-messages
MCFLAGS-exported_mode = --infer-all --no-intermodule-optimization \
--no-automatic-intermodule-optimization
MCFLAGS-exported_unify = --no-intermodule-optimization \
Index: tests/invalid/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/Mmakefile,v
retrieving revision 1.217
diff -u -r1.217 Mmakefile
--- tests/invalid/Mmakefile 6 Jun 2007 01:48:13 -0000 1.217
+++ tests/invalid/Mmakefile 23 Jul 2007 07:49:20 -0000
@@ -71,6 +71,7 @@
det_errors_cc \
duplicate_modes \
duplicate_module_test \
+ ee_invalid \
erroneous_throw_promise \
error_in_list \
errors \
Index: tests/invalid/ee_invalid.err_exp
===================================================================
RCS file: tests/invalid/ee_invalid.err_exp
diff -N tests/invalid/ee_invalid.err_exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/ee_invalid.err_exp 23 Jul 2007 07:49:03 -0000
@@ -0,0 +1,49 @@
+ee_invalid.m:037: In pragma:
+ee_invalid.m:037: error: undefined type `undefined_type'/0.
+ee_invalid.m:033: In `pragma foreign_export_enum' declaration for `int'/0:
+ee_invalid.m:033: error: `int'/0 is an atomic type.
+ee_invalid.m:041: In `pragma foreign_export_enum' declaration for
+ee_invalid.m:041: `ee_invalid.foo'/1:
+ee_invalid.m:041: error: `ee_invalid.foo'/1 is not an enumeration type. It
+ee_invalid.m:041: has one more non-zero arity constructors.
+ee_invalid.m:045: In `pragma foreign_export_enum' declaration for
+ee_invalid.m:045: `ee_invalid.bar'/0:
+ee_invalid.m:045: error: `ee_invalid.bar'/0 is not an enumeration type.
+ee_invalid.m:052: In `pragma foreign_export_enum' declaration for
+ee_invalid.m:052: `ee_invalid.baz'/0:
+ee_invalid.m:052: error: `ee_invalid.baz'/0 is not an enumeration type.
+ee_invalid.m:057: In `pragma foreign_export_enum' declaration for
+ee_invalid.m:057: `ee_invalid.alphabet'/0:
+ee_invalid.m:057: user-specified foreign names for constructors that do not
+ee_invalid.m:057: match match any of the constructors of
+ee_invalid.m:057: `ee_invalid.alphabet'/0.
+ee_invalid.m:057: The following constructor does not match:
+ee_invalid.m:057: `deg'
+ee_invalid.m:061: In `pragma foreign_export_enum' declaration for
+ee_invalid.m:061: `ee_invalid.alphabet'/0:
+ee_invalid.m:061: user-specified foreign names for constructors that do not
+ee_invalid.m:061: match match any of the constructors of
+ee_invalid.m:061: `ee_invalid.alphabet'/0.
+ee_invalid.m:061: The following constructor does not match:
+ee_invalid.m:061: `foo.def'
+ee_invalid.m:066: In `pragma foreign_export_enum' declaration for
+ee_invalid.m:066: `ee_invalid.alphabet'/0:
+ee_invalid.m:066: error: the user-specified mapping between Mercury and
+ee_invalid.m:066: foreign names does not form a bijection.
+ee_invalid.m:067: In `pragma foreign_export_enum' declaration for
+ee_invalid.m:067: `ee_invalid.alphabet'/0:
+ee_invalid.m:067: error: the mapping between Mercury and foreign names does
+ee_invalid.m:067: not form a bijection.
+ee_invalid.m:068: In `pragma foreign_export_enum' declaration for
+ee_invalid.m:068: `ee_invalid.alphabet'/0:
+ee_invalid.m:068: error: the user-specified mapping between Mercury and
+ee_invalid.m:068: foreign names does not form a bijection.
+ee_invalid.m:073: In `pragma foreign_export_enum' declaration for
+ee_invalid.m:073: `ee_invalid.strange_names'/0:
+ee_invalid.m:073: error: not all the constructors of the type
+ee_invalid.m:073: `ee_invalid.strange_names'/0 can be converted into valid C
+ee_invalid.m:073: identifiers.
+ee_invalid.m:073: The following constructors cannot be converted:
+ee_invalid.m:073: `!@THIS',
+ee_invalid.m:073: `#$WON'T',
+ee_invalid.m:073: `%^WORK'
Index: tests/invalid/ee_invalid.m
===================================================================
RCS file: tests/invalid/ee_invalid.m
diff -N tests/invalid/ee_invalid.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/ee_invalid.m 23 Jul 2007 07:49:03 -0000
@@ -0,0 +1,73 @@
+% Test error messages for invalid foreign_export_enum pragmas.
+%
+:- module ee_invalid.
+:- interface.
+
+:- type foo(T) ---> foo(T).
+
+:- type bar == int.
+
+:- implementation.
+
+:- type baz ---> baz.
+:- pragma foreign_type("C", baz, "int *").
+
+:- type alphabet
+ ---> abc
+ ; def
+ ; ghi
+ ; jkl
+ ; mno
+ ; pqr
+ ; stu
+ ; vwx
+ ; yz.
+
+:- type strange_names
+ ---> '!@THIS'
+ ; '#$WON''T'
+ ; '%^WORK'.
+
+ % foreign_export_enum pragma for atomic type.
+ %
+:- pragma foreign_export_enum("C", int/0).
+
+ % foreign export_enum pragma for undefined type.
+ %
+:- pragma foreign_export_enum("C", undefined_type/0).
+
+ % foreign_export_enum pragma for non-enumeration d.u. type.
+ %
+:- pragma foreign_export_enum("C", foo/1).
+
+ % foreign_export_enum pragma for equivalence type.
+ %
+:- pragma foreign_export_enum("C", bar/0).
+
+ % foreign_export_enum pragma for foreign_type (with default
+ % Mercury definition.)
+ % We should reject these if the language of the foreign_type
+ % and foreign_export_enum pragmas is the same.
+ %
+:- pragma foreign_export_enum("C", baz/0).
+
+ % foreign_export_enum pragma where the override list refers to a
+ % constructor that is not a member of the type.
+ %
+:- pragma foreign_export_enum("C", alphabet/0, [], [abc - "ABC", deg - "DEF"]).
+
+ % Make sure we do something sensible with module-qualifiers
+ % in the override list.
+:- pragma foreign_export_enum("C", alphabet/0, [],
+ [ee_invalid.abc - "ABC", foo.def - "DEF"]).
+
+ % Check that the the mappings from Mercury -> Foreign names are a bijection.
+ %
+:- pragma foreign_export_enum("C", alphabet/0, [prefix("FOO")], [abc - "ABC", deg - "ABC"]).
+:- pragma foreign_export_enum("C", alphabet/0, [prefix("BAR")], [def - "abc"]).
+:- pragma foreign_export_enum("C", alphabet/0, [prefix("BAZ")], [abc - "ABC", abc - "DEF"]).
+
+ % Emit an error when the default mapping for a language fails and
+ % the user has not specified an alternative.
+ %
+:- pragma foreign_export_enum("C", strange_names/0).
Index: vim/syntax/mercury.vim
===================================================================
RCS file: /home/mercury1/repository/mercury/vim/syntax/mercury.vim,v
retrieving revision 1.21
diff -u -r1.21 mercury.vim
--- vim/syntax/mercury.vim 15 Jan 2007 05:40:24 -0000 1.21
+++ vim/syntax/mercury.vim 27 Jun 2007 06:16:23 -0000
@@ -50,7 +50,7 @@
syn keyword mercuryCInterface c_header_code c_code
syn keyword mercuryCInterface foreign_proc foreign_decl foreign_code
syn keyword mercuryCInterface foreign_type foreign_import_module
-syn keyword mercuryCInterface foreign_export
+syn keyword mercuryCInterface foreign_export_enum foreign_export
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