Patchwork [Ada] Handle others better for string aggregates

login
register
mail settings
Submitter Arnaud Charlet
Date April 11, 2013, 9:32 a.m.
Message ID <20130411093250.GA18845@adacore.com>
Download mbox | patch
Permalink /patch/235651/
State New
Headers show

Comments

Arnaud Charlet - April 11, 2013, 9:32 a.m.
This patch improves the handling of an aggregate like (others => 'A')
where the bounds are known, and the effect is almost like a string
literal except that it is not static.

The following test:

     1. package NonSOthers2 is
     2.    B  : constant String (1 .. 6) := (others => 'A');
     3.    DH : constant String (1 .. 8) := B & "BB";
     4.    X : Integer;
     5.    pragma Export (C, X, Link_Name => DH);
                                             |
        >>> argument for pragma "Export" must be a static expression
        >>> "DH" is not a static constant (RM 4.9(5))

     6. end;

correctly flags line 5, since an others aggregate is still not-static.
But with this patch installed, the declaration for line 3 is otherwise
similar to the use of a string literal. If this test is compiled with
-gnatG, the output contains the line:

   dh : constant string (1 .. 8) := "AAAAAABB";

showing this improved handling

Tested on x86_64-pc-linux-gnu, committed on trunk

2013-04-11  Robert Dewar  <dewar@adacore.com>

	* exp_aggr.adb (Expand_N_Aggregate): Add circuit for handling
	others for string literal case. Also add big ??? comment about
	this new code, which should be redundant, but is not.
	* sem_eval.adb (Eval_Concatenation): Handle non-static case
	properly (Eval_String_Literal): Handle non-static literal properly

Patch

Index: exp_aggr.adb
===================================================================
--- exp_aggr.adb	(revision 197743)
+++ exp_aggr.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2013, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -59,6 +59,7 @@ 
 with Sinfo;    use Sinfo;
 with Snames;   use Snames;
 with Stand;    use Stand;
+with Stringt;  use Stringt;
 with Targparm; use Targparm;
 with Tbuild;   use Tbuild;
 with Uintp;    use Uintp;
@@ -5160,9 +5161,100 @@ 
 
    procedure Expand_N_Aggregate (N : Node_Id) is
    begin
+      --  Record aggregate case
+
       if Is_Record_Type (Etype (N)) then
          Expand_Record_Aggregate (N);
+
+      --  Array aggregate case
+
       else
+         --  A special case, if we have a string subtype with bounds 1 .. N,
+         --  where N is known at compile time, and the aggregate is of the
+         --  form (others => 'x'), and N is less than 80 (an arbitrary limit
+         --  for now), then replace the aggregate by the equivalent string
+         --  literal (but do not mark it as static since it is not!)
+
+         --  Note: this entire circuit is redundant with respect to code in
+         --  Expand_Array_Aggregate that collapses others choices to positional
+         --  form, but there are two problems with that circuit:
+
+         --    a) It is limited to very small cases due to ill-understood
+         --       interations with bootstrapping. That limit is removed by
+         --       use of the No_Implicit_Loops restriction.
+
+         --    b) It erroneously ends up with the resulting expressions being
+         --       considered static when they are not. For example, the
+         --       following test should fail:
+
+         --           pragma Restrictions (No_Implicit_Loops);
+         --           package NonSOthers4 is
+         --              B  : constant String (1 .. 6) := (others => 'A');
+         --              DH : constant String (1 .. 8) := B & "BB";
+         --              X : Integer;
+         --              pragma Export (C, X, Link_Name => DH);
+         --           end;
+
+         --       But it succeeds (DH looks static to pragma Export)
+
+         --    To be sorted out! ???
+
+         if Present (Component_Associations (N)) then
+            declare
+               CA : constant Node_Id := First (Component_Associations (N));
+               MX : constant         := 80;
+
+            begin
+               if Nkind (First (Choices (CA))) = N_Others_Choice
+                 and then Nkind (Expression (CA)) = N_Character_Literal
+               then
+                  declare
+                     T  : constant Entity_Id := Etype (N);
+                     X  : constant Node_Id   := First_Index (T);
+                     EC : constant Node_Id   := Expression (CA);
+                     CV : constant Uint      := Char_Literal_Value (EC);
+                     CC : constant Int       := UI_To_Int (CV);
+
+                  begin
+                     if Nkind (X) = N_Range
+                       and then Compile_Time_Known_Value (Low_Bound (X))
+                       and then Expr_Value (Low_Bound (X)) = 1
+                       and then Compile_Time_Known_Value (High_Bound (X))
+                     then
+                        declare
+                           Hi : constant Uint := Expr_Value (High_Bound (X));
+
+                        begin
+                           if Hi <= MX then
+                              Start_String;
+
+                              for J in 1 .. UI_To_Int (Hi) loop
+                                 Store_String_Char (Char_Code (CC));
+                              end loop;
+
+                              Rewrite (N,
+                                Make_String_Literal (Sloc (N),
+                                  Strval => End_String));
+
+                              if CC >= Int (2 ** 16) then
+                                 Set_Has_Wide_Wide_Character (N);
+                              elsif CC >= Int (2 ** 8) then
+                                 Set_Has_Wide_Character (N);
+                              end if;
+
+                              Analyze_And_Resolve (N, T);
+                              Set_Is_Static_Expression (N, False);
+                              return;
+                           end if;
+                        end;
+                     end if;
+                  end;
+               end if;
+            end;
+         end if;
+
+         --  Not that special case, so normal expansion of array aggregate
+
          Expand_Array_Aggregate (N);
       end if;
    exception
Index: sem_eval.adb
===================================================================
--- sem_eval.adb	(revision 197743)
+++ sem_eval.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2013, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -1932,20 +1932,17 @@ 
 
          Set_Is_Static_Expression (N, Stat);
 
-         if Stat then
+         --  If left operand is the empty string, the result is the
+         --  right operand, including its bounds if anomalous.
 
-            --  If left operand is the empty string, the result is the
-            --  right operand, including its bounds if anomalous.
+         if Left_Len = 0
+           and then Is_Array_Type (Etype (Right))
+           and then Etype (Right) /= Any_String
+         then
+            Set_Etype (N, Etype (Right));
+         end if;
 
-            if Left_Len = 0
-              and then Is_Array_Type (Etype (Right))
-              and then Etype (Right) /= Any_String
-            then
-               Set_Etype (N, Etype (Right));
-            end if;
-
-            Fold_Str (N, Folded_Val, Static => True);
-         end if;
+         Fold_Str (N, Folded_Val, Static => Stat);
       end;
    end Eval_Concatenation;
 
@@ -3411,11 +3408,12 @@ 
       --  is too long, or it is null, and the lower bound is type'First. In
       --  either case it is the upper bound that is out of range of the index
       --  type.
-
       if Ada_Version >= Ada_95 then
          if Root_Type (Bas) = Standard_String
               or else
             Root_Type (Bas) = Standard_Wide_String
+              or else
+            Root_Type (Bas) = Standard_Wide_Wide_String
          then
             Xtp := Standard_Positive;
          else
@@ -3428,24 +3426,54 @@ 
             Lo := Type_Low_Bound (Etype (First_Index (Typ)));
          end if;
 
+         --  Check for string too long
+
          Len := String_Length (Strval (N));
 
          if UI_From_Int (Len) > String_Type_Len (Bas) then
-            Apply_Compile_Time_Constraint_Error
-              (N, "string literal too long for}", CE_Length_Check_Failed,
-               Ent => Bas,
-               Typ => First_Subtype (Bas));
 
+            --  Issue message. Note that this message is a warning if the
+            --  string literal is not marked as static (happens in some cases
+            --  of folding strings known at compile time, but not static).
+            --  Furthermore in such cases, we reword the message, since there
+            --  is no string literal in the source program!
+
+            if Is_Static_Expression (N) then
+               Apply_Compile_Time_Constraint_Error
+                 (N, "string literal too long for}", CE_Length_Check_Failed,
+                  Ent => Bas,
+                  Typ => First_Subtype (Bas));
+            else
+               Apply_Compile_Time_Constraint_Error
+                 (N, "string value too long for}", CE_Length_Check_Failed,
+                  Ent  => Bas,
+                  Typ  => First_Subtype (Bas),
+                  Warn => True);
+            end if;
+
+         --  Test for null string not allowed
+
          elsif Len = 0
            and then not Is_Generic_Type (Xtp)
            and then
              Expr_Value (Lo) = Expr_Value (Type_Low_Bound (Base_Type (Xtp)))
          then
-            Apply_Compile_Time_Constraint_Error
-              (N, "null string literal not allowed for}",
-               CE_Length_Check_Failed,
-               Ent => Bas,
-               Typ => First_Subtype (Bas));
+            --  Same specialization of message
+
+            if Is_Static_Expression (N) then
+               Apply_Compile_Time_Constraint_Error
+                 (N, "null string literal not allowed for}",
+                  CE_Length_Check_Failed,
+                  Ent => Bas,
+                  Typ => First_Subtype (Bas));
+            else
+               Apply_Compile_Time_Constraint_Error
+                 (N, "null string value not allowed for}",
+                  CE_Length_Check_Failed,
+                  Ent  => Bas,
+                  Typ  => First_Subtype (Bas),
+                  Warn => True);
+            end if;
          end if;
       end if;
    end Eval_String_Literal;
@@ -4091,7 +4119,7 @@ 
       --  Note that we have to reset Is_Static_Expression both after the
       --  analyze step (because Resolve will evaluate the literal, which
       --  will cause semantic errors if it is marked as static), and after
-      --  the Resolve step (since Resolve in some cases sets this flag).
+      --  the Resolve step (since Resolve in some cases resets this flag).
 
       Analyze (N);
       Set_Is_Static_Expression (N, Static);