[m-rev.] for review: `uppercase' attribute for pragma foreign_export_enum

[Julien Fischer]

Estimated hours taken: 1.5
Branches: main

Add a new attribute to foreign_export_enum pragmas, `uppercase', that
converts the alphabetic characters in a Mercury enumeration constant
into uppercase when generating the foreign language constant name.
(Note that user supplied names for foreign constants are not affected
by this attribute - presumably if the programmer wanted those names
to be uppercase they would have done so themselves.)

compiler/prog_io_pragma.m:
compiler/prog_data.m:
 	Parse the new attribute.

compiler/add_pragma.m:
 	If the new attribute is present then apply the conversion
 	to the constructor names when generating the foreign
 	names.

doc/reference_manual.texi:
 	Document the new attribute.

tests/hard_coded/Makefile:
tests/hard_coded/uc_export_enum.m:
tests/hard_coded/uc_export_enum.exp:
 	Test the new attribute.

Julien.

Index: compiler/add_pragma.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_pragma.m,v
retrieving revision 1.81
diff -u -r1.81 add_pragma.m
--- compiler/add_pragma.m	15 Feb 2008 02:26:53 -0000	1.81
+++ compiler/add_pragma.m	27 Feb 2008 07:31:52 -0000
@@ -671,7 +671,8 @@
                      ; DuTypeKind = du_type_kind_foreign_enum(_)
                      ; DuTypeKind = du_type_kind_direct_dummy
                      ),
-                    Attributes = export_enum_attributes(MaybePrefix),
+                    Attributes = export_enum_attributes(MaybePrefix,
+                        MakeUpperCase),
                      (
                          MaybePrefix = yes(Prefix)
                      ;
@@ -683,7 +684,7 @@
                      (
                          MaybeOverridesMap = yes(OverridesMap),
                          build_export_enum_name_map(ContextPieces, Lang,
-                            TypeName, TypeArity, Context, Prefix,
+                            TypeName, TypeArity, Context, Prefix, MakeUpperCase,
                              OverridesMap, Ctors, MaybeMapping, !Specs),
                          (
                              MaybeMapping = yes(Mapping),
@@ -790,12 +791,12 @@

  :- 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,
+    string::in, bool::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) :-
+        Context, Prefix, MakeUpperCase, Overrides0, Ctors, MaybeMapping, !Specs) :-
      (
          TypeName = qualified(TypeModuleQual, _)
      ;
@@ -804,7 +805,8 @@
          unexpected(this_file, "unqualified type name for foreign_export_enum")
      ),

-    list.foldl3(add_ctor_to_name_map(Lang, Prefix, TypeModuleQual),
+    list.foldl3(
+        add_ctor_to_name_map(Lang, Prefix, MakeUpperCase, TypeModuleQual),
          Ctors, Overrides0, Overrides, map.init, NameMap, [], BadCtors),
      %
      % Check for any remaining user-specified renamings that didn't
@@ -915,13 +917,13 @@
      %   !BadCtors):
      %
  :- pred add_ctor_to_name_map(foreign_language::in,
-    string::in, sym_name::in, constructor::in,
+    string::in, bool::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) :-
+add_ctor_to_name_map(Lang, Prefix, MakeUpperCase, _TypeModQual, Ctor,
+        !Overrides, !NameMap, !BadCtors) :-
      CtorSymName = Ctor ^ cons_name,
      (
          % All of the constructor sym_names should be module qualified by now.
@@ -943,7 +945,13 @@
      ;
          % Otherwise try to derive a name automatically from the
          % constructor name.
-        ForeignName1 = UnqualCtorName
+        (
+            MakeUpperCase = yes,
+            ForeignName1 = string.to_upper(UnqualCtorName)
+        ;
+            MakeUpperCase = no,
+            ForeignName1 = UnqualCtorName
+        )
      ),
      ForeignName = Prefix ++ ForeignName1,
      (
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.206
diff -u -r1.206 prog_data.m
--- compiler/prog_data.m	15 Feb 2008 08:31:59 -0000	1.206
+++ compiler/prog_data.m	27 Feb 2008 07:31:52 -0000
@@ -617,10 +617,10 @@
  % Stuff for the `foreign_export_enum' pragma
  %

-
  :- type export_enum_attributes
      --->    export_enum_attributes(
-                ee_attr_prefix :: maybe(string)
+                ee_attr_prefix :: maybe(string),
+                ee_attr_upper  :: bool
              ).

  :- func default_export_enum_attributes = export_enum_attributes.
@@ -2313,7 +2313,7 @@
  % Stuff for the `foreign_export_enum' pragma
  %

-default_export_enum_attributes = export_enum_attributes(no).
+default_export_enum_attributes = export_enum_attributes(no, no).

  %-----------------------------------------------------------------------------%
  %-----------------------------------------------------------------------------%
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.133
diff -u -r1.133 prog_io_pragma.m
--- compiler/prog_io_pragma.m	15 Feb 2008 02:26:57 -0000	1.133
+++ compiler/prog_io_pragma.m	27 Feb 2008 07:31:52 -0000
@@ -506,7 +506,8 @@
      parse_export_enum_attributes(AttributesTerm, MaybeAttributes).

  :- type collected_export_enum_attribute
-    --->    ee_attr_prefix(maybe(string)).
+    --->    ee_attr_prefix(maybe(string))
+    ;       ee_attr_upper(bool).

  :- pred parse_export_enum_attributes(term::in,
      maybe1(export_enum_attributes)::out) is det.
@@ -554,8 +555,14 @@
  :- 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).
+process_export_enum_attribute(ee_attr_prefix(MaybePrefix), !Attributes) :-
+    % We have already checked that the prefix attribute is not specified
+    % multiple times so it is safe to ignore it in the input here.
+    !.Attributes = export_enum_attributes(_, MakeUpperCase),
+    !:Attributes = export_enum_attributes(MaybePrefix, MakeUpperCase).
+process_export_enum_attribute(ee_attr_upper(MakeUpperCase), !Attributes) :-
+    !.Attributes = export_enum_attributes(MaybePrefix, _),
+    !:Attributes = export_enum_attributes(MaybePrefix, MakeUpperCase).

  :- pred parse_export_enum_attr(term::in,
      maybe1(collected_export_enum_attribute)::out) is det.
@@ -568,6 +575,10 @@
      ->
          Result = ok1(ee_attr_prefix(yes(Prefix)))
      ;
+        Term = functor(atom("uppercase"), [], _)
+    ->
+        Result = ok1(ee_attr_upper(yes))
+    ;
          Msg = "unrecognised attribute in foreign_export_enum pragma",
          Result = error1([Msg - Term])
      ).
Index: doc/reference_manual.texi
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/doc/reference_manual.texi,v
retrieving revision 1.422
diff -u -r1.422 reference_manual.texi
--- doc/reference_manual.texi	1 Feb 2008 05:45:28 -0000	1.422
+++ doc/reference_manual.texi	27 Feb 2008 07:31:52 -0000
@@ -7026,22 +7026,35 @@
  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.
+The following attributes must be supported by all Mercury implementations.

  @table @asis

  @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
  @samp{pragma foreign_export_enum} declaration.

+ at item @samp{uppercase}
+Convert any alphabetic characters in a Mercury constructor name
+to uppercase when generating the symbolic name using the default
+mapping.
+Symbolic names specified by the programmer using @var{Overrides}
+are not affected by this attribute.
+If the @samp{prefix} attribute is also specified, then the prefix
+is added to the symbolic name @emph{after} the conversion to
+uppercase has been performed, i.e. the characters in the prefix
+are not affected by the @samp{uppercase} attribute.
+
  @end table

+The implementation does not check the validity of a symbolic name
+in the foreign language until after the effects of any attributes
+have been applied.
+This means that attributes may cause an otherwise valid symbolic name
+to become invalid or vice versa.
+
  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}
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/hard_coded/Mmakefile,v
retrieving revision 1.340
diff -u -r1.340 Mmakefile
--- tests/hard_coded/Mmakefile	1 Feb 2008 05:45:29 -0000	1.340
+++ tests/hard_coded/Mmakefile	27 Feb 2008 07:31:53 -0000
@@ -242,6 +242,7 @@
  	type_spec_ho_term \
  	type_spec_modes \
  	type_to_term_bug \
+	uc_export_enum \
  	unicode_test \
  	unify_existq_cons \
  	unify_expression \
Index: tests/hard_coded/uc_export_enum.exp
===================================================================
RCS file: tests/hard_coded/uc_export_enum.exp
diff -N tests/hard_coded/uc_export_enum.exp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/uc_export_enum.exp	27 Feb 2008 07:31:53 -0000
@@ -0,0 +1,3 @@
+test_uc - succeeded.
+test_lc - succeeded.
+test_or - succeeded.
Index: tests/hard_coded/uc_export_enum.m
===================================================================
RCS file: tests/hard_coded/uc_export_enum.m
diff -N tests/hard_coded/uc_export_enum.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/uc_export_enum.m	27 Feb 2008 07:31:53 -0000
@@ -0,0 +1,85 @@
+% vim: ft=mercury ts=4 sw=4 et
+% Check the `uppercase' attribute with foreign_export_enum pragmas.
+
+:- module uc_export_enum.
+:- interface.
+
+:- import_module io.
+:- pred main(io::di, io::uo) is det.
+
+%----------------------------------------------------------------------------%
+%----------------------------------------------------------------------------%
+
+:- implementation.
+
+main(!IO) :-
+    test_uc(UC),
+    ( UC = foo ->
+        io.write_string("test_uc - succeeded.\n", !IO)
+    ;
+        io.write_string("test_uc - failed.\n", !IO)
+    ),
+    test_lc(LC),
+    ( LC = foo ->
+        io.write_string("test_lc - succeeded.\n", !IO)
+    ;
+        io.write_string("test_lc - failed.\n", !IO)
+    ),
+    test_or(X, Y, Z),
+    ( X = foo, Y = bar, Z = baz ->
+        io.write_string("test_or - succeeded.\n", !IO)
+    ;
+        io.write_string("test_or - failed.\n", !IO)
+    ).
+
+:- pred test_uc(foo::out) is det.
+:- pragma foreign_proc("C",
+    test_uc(X::out),
+    [will_not_call_mercury, promise_pure],
+"
+    X = UC_foo_FOO;
+").
+
+:- pred test_lc(foo::out) is det.
+:- pragma foreign_proc("C",
+    test_lc(X::out),
+    [will_not_call_mercury, promise_pure],
+"
+    X = LC_foo_foo;
+").
+
+:- pred test_or(foo::out, foo::out, foo::out) is det.
+:- pragma foreign_proc("C",
+    test_or(X::out, Y::out, Z::out),
+    [will_not_call_mercury, promise_pure],
+"
+    X = OR_foo_lowercase_foo;
+    Y = OR_foo_mixed1234_bAr;
+    Z = OR_foo_BAZ;
+").
+
+%----------------------------------------------------------------------------%
+
+:- type foo
+    --->    foo
+    ;       bar
+    ;       baz.
+
+    % Check that uppercase applies only the constructors and not to the prefix.
+    %
+:- pragma foreign_export_enum("C", foo/0, [prefix("UC_foo_"), uppercase]).
+
+    % Check that uppercase applies only when the uppercase attribute is specified.
+    %
+:- pragma foreign_export_enum("C", foo/0, [prefix("LC_foo_")]).
+
+    % Check that the uppercase attribute does not apply to user supplied foreign
+    % names.
+    %
+:- pragma foreign_export_enum("C", foo/0, [prefix("OR_foo_"), uppercase], [
+    foo - "lowercase_foo",
+    bar  - "mixed1234_bAr"
+]).
+
+%----------------------------------------------------------------------------%
+%----------------------------------------------------------------------------%

--------------------------------------------------------------------------
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
--------------------------------------------------------------------------