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 <de...@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
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);
