This fixes several errors in the handling of the pragmas Independent
and Independent_Components. The implementation now matches the RM
definition 100%. The following compiles without errors:
1. package Independ is
2. type A1 is array (1 .. 10) of Integer;
3. pragma Independent_Components (A1);
4.
5. type A2 is array (1 .. 10) of Integer
6. with Independent_Components;
7.
8. A3 : array (1 .. 10) of Integer;
9. pragma Independent_Components (A3);
10.
11. A4 : array (1 .. 10) of Integer
12. with Independent_Components;
13.
14. type R1 is record
15. X, Y : Integer;
16. end record;
17. pragma Independent_Components (R1);
18.
19. type R2 is record
20. X, Y : Integer;
21. end record
22. with Independent_Components;
23.
24. type R3 is record
25. X, Y : Integer;
26. pragma Independent (X);
27. end record;
28.
29. type R4 is record
30. X : Integer with Independent;
31. Y : Integer;
32. end record;
33. end;
The following test compiles with the errors shown
1. package Independ2 is
2. type A1 is array (1 .. 10) of Boolean;
3. for A1'Component_Size use 1;
4. pragma Independent_Components (A1);
|
>>> independent components cannot be guaranteed for "A1"
5.
6. type A2 is array (1 .. 10) of Boolean
7. with Independent_Components,
|
>>> independent components cannot be guaranteed for "A2"
8. Component_Size => 1;
9.
10. type R1 is record
11. X, Y : Boolean;
12. end record;
13. pragma Independent_Components (R1);
|
>>> independent components cannot be guaranteed for "R1"
>>> because of Component_Clause at line 15
14. for R1 use record
15. X at 0 range 0 .. 0;
16. Y at 0 range 1 .. 1;
17. end record;
18.
19. type R2 is record
20. X, Y : Boolean;
21. end record
22. with Independent_Components;
|
>>> independent components cannot be guaranteed for "R2"
>>> because of Component_Clause at line 24
23. for R2 use record
24. X at 0 range 0 .. 0;
25. Y at 0 range 1 .. 1;
26. end record;
27.
28. type R3 is record
29. X, Y : Boolean;
30. pragma Independent (X);
|
>>> independence cannot be guaranteed for "X"
>>> because of Component_Clause at line 33
31. end record;
32. for R3 use record
33. X at 0 range 0 .. 0;
34. Y at 0 range 1 .. 1;
35. end record;
36.
37. type R4 is record
38. X : Boolean with Independent;
|
>>> independence cannot be guaranteed for "X"
>>> because of Component_Clause at line 42
39. Y : Boolean;
40. end record;
41. for R4 use record
42. X at 0 range 0 .. 0;
43. Y at 0 range 1 .. 1;
44. end record;
45. end;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-06-11 Robert Dewar <de...@adacore.com>
* einfo.adb (Is_Independent): New flag.
* einfo.ads (Is_Independent): New flag.
(Has_Independent_Components): Clean up and fix comments.
* sem_prag.adb (Fix_Error): Deal with changing argument
[of] to entity [for].
(Analyze_Pragma, case Independent): Set Is_Independent flag
(Analyze_Pragma, case Independent_Components): Set Is_Independent flag
in all components of specified record.
Index: einfo.adb
===================================================================
--- einfo.adb (revision 211445)
+++ einfo.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, 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- --
@@ -558,12 +558,12 @@
-- SPARK_Pragma_Inherited Flag265
-- SPARK_Aux_Pragma_Inherited Flag266
-- Has_Shift_Operator Flag267
+ -- Is_Independent Flag268
-- (unused) Flag1
-- (unused) Flag2
-- (unused) Flag3
- -- (unused) Flag268
-- (unused) Flag269
-- (unused) Flag270
@@ -1476,8 +1476,8 @@
function Has_Independent_Components (Id : E) return B is
begin
- pragma Assert (Is_Object (Id) or else Is_Type (Id));
- return Flag34 (Id);
+ pragma Assert (Is_Array_Type (Id) or else Is_Record_Type (Id));
+ return Flag34 (Base_Type (Id));
end Has_Independent_Components;
function Has_Inheritable_Invariants (Id : E) return B is
@@ -2077,6 +2077,12 @@
return Flag24 (Id);
end Is_Imported;
+ function Is_Independent (Id : E) return B is
+ begin
+ pragma Assert (Ekind (Id) = E_Component);
+ return Flag268 (Id);
+ end Is_Independent;
+
function Is_Inlined (Id : E) return B is
begin
return Flag11 (Id);
@@ -4177,7 +4183,8 @@
procedure Set_Has_Independent_Components (Id : E; V : B := True) is
begin
- pragma Assert (Is_Object (Id) or else Is_Type (Id));
+ pragma Assert ((Is_Array_Type (Id) or else Is_Record_Type (Id))
+ and then Is_Base_Type (Id));
Set_Flag34 (Id, V);
end Set_Has_Independent_Components;
@@ -4811,6 +4818,12 @@
Set_Flag24 (Id, V);
end Set_Is_Imported;
+ procedure Set_Is_Independent (Id : E; V : B := True) is
+ begin
+ pragma Assert (Ekind_In (Id, E_Component, E_Void));
+ Set_Flag268 (Id, V);
+ end Set_Is_Independent;
+
procedure Set_Is_Inlined (Id : E; V : B := True) is
begin
Set_Flag11 (Id, V);
@@ -8181,6 +8194,7 @@
W ("Has_Gigi_Rep_Item", Flag82 (Id));
W ("Has_Homonym", Flag56 (Id));
W ("Has_Implicit_Dereference", Flag251 (Id));
+ W ("Has_Independent_Components", Flag34 (Id));
W ("Has_Inheritable_Invariants", Flag248 (Id));
W ("Has_Initial_Value", Flag219 (Id));
W ("Has_Invariants", Flag232 (Id));
@@ -8283,6 +8297,7 @@
W ("Is_Immediately_Visible", Flag7 (Id));
W ("Is_Implementation_Defined", Flag254 (Id));
W ("Is_Imported", Flag24 (Id));
+ W ("Is_Independent", Flag268 (Id));
W ("Is_Inlined", Flag11 (Id));
W ("Is_Instantiated", Flag126 (Id));
W ("Is_Interface", Flag186 (Id));
Index: einfo.ads
===================================================================
--- einfo.ads (revision 211454)
+++ einfo.ads (working copy)
@@ -1581,9 +1581,11 @@
-- Implicit_Dereference. Set also on the discriminant named in the aspect
-- clause, to simplify type resolution.
--- Has_Independent_Components (Flag34)
--- Defined in objects and types. Set if the aspect Independent_Components
--- applies (as set by coresponding pragma or aspect specification).
+-- Has_Independent_Components (Flag34) [base type only]
+-- Defined in types. Set if the aspect Independent_Components applies
+-- (in the base type only), if corresponding pragma or aspect applies.
+-- In the case of an object of anonymous array type, the flag is set on
+-- the created array type.
-- Has_Inheritable_Invariants (Flag248)
-- Defined in all type entities. Set in private types from which one
@@ -2415,6 +2417,11 @@
-- Is_Incomplete_Type (synthesized)
-- Applies to all entities, true for incomplete types and subtypes
+-- Is_Independent (Flag268)
+-- Defined in record components. Set if a valid pragma or aspect
+-- Independent applies to the component, or if a valid pragma or aspect
+-- Independent_Components applies to the enclosing record type.
+
-- Is_Inlined (Flag11)
-- Defined in all entities. Set for functions and procedures which are
-- to be inlined. For subprograms created during expansion, this flag
@@ -5350,6 +5357,7 @@
-- Has_Biased_Representation (Flag139)
-- Has_Per_Object_Constraint (Flag154)
-- Is_Atomic (Flag85)
+ -- Is_Independent (Flag268)
-- Is_Tag (Flag78)
-- Is_Volatile (Flag16)
-- Treat_As_Volatile (Flag41)
@@ -5379,7 +5387,6 @@
-- Has_Atomic_Components (Flag86)
-- Has_Biased_Representation (Flag139)
-- Has_Completion (Flag26) (constants only)
- -- Has_Independent_Components (Flag34) (base type only)
-- Has_Thunks (Flag228) (constants only)
-- Has_Size_Clause (Flag29)
-- Has_Up_Level_Access (Flag215)
@@ -6089,7 +6096,6 @@
-- Has_Alignment_Clause (Flag46)
-- Has_Atomic_Components (Flag86)
-- Has_Biased_Representation (Flag139)
- -- Has_Independent_Components (Flag34) (base type only)
-- Has_Initial_Value (Flag219)
-- Has_Size_Clause (Flag29)
-- Has_Up_Level_Access (Flag215)
@@ -6589,6 +6595,7 @@
function Is_Immediately_Visible (Id : E) return B;
function Is_Implementation_Defined (Id : E) return B;
function Is_Imported (Id : E) return B;
+ function Is_Independent (Id : E) return B;
function Is_Inlined (Id : E) return B;
function Is_Instantiated (Id : E) return B;
function Is_Interface (Id : E) return B;
@@ -7217,6 +7224,7 @@
procedure Set_Is_Immediately_Visible (Id : E; V : B := True);
procedure Set_Is_Implementation_Defined (Id : E; V : B := True);
procedure Set_Is_Imported (Id : E; V : B := True);
+ procedure Set_Is_Independent (Id : E; V : B := True);
procedure Set_Is_Inlined (Id : E; V : B := True);
procedure Set_Is_Instantiated (Id : E; V : B := True);
procedure Set_Is_Interface (Id : E; V : B := True);
@@ -7979,6 +7987,7 @@
pragma Inline (Is_Imported);
pragma Inline (Is_Incomplete_Or_Private_Type);
pragma Inline (Is_Incomplete_Type);
+ pragma Inline (Is_Independent);
pragma Inline (Is_Inlined);
pragma Inline (Is_Instantiated);
pragma Inline (Is_Integer_Type);
@@ -8426,6 +8435,7 @@
pragma Inline (Set_Is_Immediately_Visible);
pragma Inline (Set_Is_Implementation_Defined);
pragma Inline (Set_Is_Imported);
+ pragma Inline (Set_Is_Independent);
pragma Inline (Set_Is_Inlined);
pragma Inline (Set_Is_Instantiated);
pragma Inline (Set_Is_Interface);
Index: sem_prag.adb
===================================================================
--- sem_prag.adb (revision 211459)
+++ sem_prag.adb (working copy)
@@ -3219,15 +3219,28 @@
-- procedure identified by Name, returns it if it exists, otherwise
-- errors out and uses Arg as the pragma argument for the message.
- procedure Fix_Error (Msg : in out String);
- -- This is called prior to issuing an error message. Msg is a string
- -- that typically contains the substring "pragma". If the pragma comes
- -- from an aspect, each such "pragma" substring is replaced with the
- -- characters "aspect", and Error_Msg_Name_1 is set to the name of the
- -- aspect (which may be different from the pragma name). If the current
- -- pragma results from rewriting another pragma, then Error_Msg_Name_1
- -- is set to the original pragma name.
+ function Fix_Error (Msg : String) return String;
+ -- This is called prior to issuing an error message. Msg is the normal
+ -- error message issued in the pragma case. This routine checks for the
+ -- case of a pragma coming from an aspect in the source, and returns a
+ -- message suitable for the aspect case as follows:
+ --
+ -- Each substring "pragma" is replaced by "aspect"
+ --
+ -- If "argument of" is at the start of the error message text, it is
+ -- replaced by "entity for".
+ --
+ -- If "argument" is at the start of the error message text, it is
+ -- replaced by "entity".
+ --
+ -- So for example, "argument of pragma X must be discrete type"
+ -- returns "entity for aspect X must be a discrete type".
+ -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
+ -- be different from the pragma name). If the current pragma results
+ -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
+ -- original pragma name.
+
procedure Gather_Associations
(Names : Name_List;
Args : out Args_List);
@@ -3746,12 +3759,11 @@
Error_Msg_Name_1 := Pname;
declare
- Msg : String :=
+ Msg : constant String :=
"argument for pragma% must be a identifier or "
& "static string expression!";
begin
- Fix_Error (Msg);
- Flag_Non_Static_Expr (Msg, Argx);
+ Flag_Non_Static_Expr (Fix_Error (Msg), Argx);
raise Pragma_Exit;
end;
end if;
@@ -4419,15 +4431,9 @@
else
Error_Msg_Name_1 := Pname;
-
- declare
- Msg : String :=
- "argument for pragma% must be a static expression!";
- begin
- Fix_Error (Msg);
- Flag_Non_Static_Expr (Msg, Expr);
- end;
-
+ Flag_Non_Static_Expr
+ (Fix_Error ("argument for pragma% must be a static expression!"),
+ Expr);
raise Pragma_Exit;
end if;
end Check_Expr_Is_Static_Expression;
@@ -5822,11 +5828,9 @@
------------------
procedure Error_Pragma (Msg : String) is
- MsgF : String := Msg;
begin
Error_Msg_Name_1 := Pname;
- Fix_Error (MsgF);
- Error_Msg_N (MsgF, N);
+ Error_Msg_N (Fix_Error (Msg), N);
raise Pragma_Exit;
end Error_Pragma;
@@ -5835,20 +5839,16 @@
----------------------
procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
- MsgF : String := Msg;
begin
Error_Msg_Name_1 := Pname;
- Fix_Error (MsgF);
- Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
+ Error_Msg_N (Fix_Error (Msg), Get_Pragma_Arg (Arg));
raise Pragma_Exit;
end Error_Pragma_Arg;
procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
- MsgF : String := Msg1;
begin
Error_Msg_Name_1 := Pname;
- Fix_Error (MsgF);
- Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
+ Error_Msg_N (Fix_Error (Msg1), Get_Pragma_Arg (Arg));
Error_Pragma_Arg (Msg2, Arg);
end Error_Pragma_Arg;
@@ -5857,11 +5857,9 @@
----------------------------
procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
- MsgF : String := Msg;
begin
Error_Msg_Name_1 := Pname;
- Fix_Error (MsgF);
- Error_Msg_N (MsgF, Arg);
+ Error_Msg_N (Fix_Error (Msg), Arg);
raise Pragma_Exit;
end Error_Pragma_Arg_Ident;
@@ -5870,12 +5868,10 @@
----------------------
procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
- MsgF : String := Msg;
begin
Error_Msg_Name_1 := Pname;
- Fix_Error (MsgF);
- Error_Msg_Sloc := Sloc (Ref);
- Error_Msg_NE (MsgF, N, Ref);
+ Error_Msg_Sloc := Sloc (Ref);
+ Error_Msg_NE (Fix_Error (Msg), N, Ref);
raise Pragma_Exit;
end Error_Pragma_Ref;
@@ -6006,7 +6002,11 @@
-- Fix_Error --
---------------
- procedure Fix_Error (Msg : in out String) is
+ function Fix_Error (Msg : String) return String is
+ Res : String (Msg'Range) := Msg;
+ Res_Last : Natural := Msg'Last;
+ J : Natural;
+
begin
-- If we have a rewriting of another pragma, go to that pragma
@@ -6022,16 +6022,47 @@
-- Change appearence of "pragma" in message to "aspect"
- for J in Msg'First .. Msg'Last - 5 loop
- if Msg (J .. J + 5) = "pragma" then
- Msg (J .. J + 5) := "aspect";
+ J := Res'First;
+ while J <= Res_Last - 5 loop
+ if Res (J .. J + 5) = "pragma" then
+ Res (J .. J + 5) := "aspect";
+ J := J + 6;
+
+ else
+ J := J + 1;
end if;
end loop;
+ -- Change "argument of" at start of message to "entity for"
+
+ if Res'Length > 11
+ and then Res (Res'First .. Res'First + 10) = "argument of"
+ then
+ Res (Res'First .. Res'First + 9) := "entity for";
+ Res (Res'First + 10 .. Res_Last - 1) :=
+ Res (Res'First + 11 .. Res_Last);
+ Res_Last := Res_Last - 1;
+ end if;
+
+ -- Change "argument" at start of message to "entity"
+
+ if Res'Length > 8
+ and then Res (Res'First .. Res'First + 7) = "argument"
+ then
+ Res (Res'First .. Res'First + 5) := "entity";
+ Res (Res'First + 6 .. Res_Last - 2) :=
+ Res (Res'First + 8 .. Res_Last);
+ Res_Last := Res_Last - 2;
+ end if;
+
-- Get name from corresponding aspect
Error_Msg_Name_1 := Original_Aspect_Name (N);
end if;
+
+ -- Return possibly modified message
+
+ return Res (Res'First .. Res_Last);
end Fix_Error;
-------------------------
@@ -14974,13 +15005,11 @@
-- Independent --
-----------------
- -- pragma Independent (LOCAL_NAME);
+ -- pragma Independent (record_component_LOCAL_NAME);
when Pragma_Independent => Independent : declare
E_Id : Node_Id;
E : Entity_Id;
- D : Node_Id;
- K : Node_Kind;
begin
Check_Ada_83_Warning;
@@ -14995,38 +15024,32 @@
end if;
E := Entity (E_Id);
- D := Declaration_Node (E);
- K := Nkind (D);
+ -- Check we have a record component. We have not yet setup
+ -- components fully, so identify by syntactic structure.
+
+ if Nkind (Declaration_Node (E)) /= N_Component_Declaration then
+ Error_Pragma_Arg
+ ("argument for pragma% must be record component", Arg1);
+ end if;
+
-- Check duplicate before we chain ourselves
Check_Duplicate_Pragma (E);
- -- Check appropriate entity
+ -- Chain pragma
- if Is_Type (E) then
- if Rep_Item_Too_Early (E, N)
- or else
- Rep_Item_Too_Late (E, N)
- then
- return;
- else
- Check_First_Subtype (Arg1);
- end if;
-
- elsif K = N_Object_Declaration
- or else (K = N_Component_Declaration
- and then Original_Record_Component (E) = E)
+ if Rep_Item_Too_Early (E, N)
+ or else
+ Rep_Item_Too_Late (E, N)
then
- if Rep_Item_Too_Late (E, N) then
- return;
- end if;
-
- else
- Error_Pragma_Arg
- ("inappropriate entity for pragma%", Arg1);
+ return;
end if;
+ -- Set flag in component
+
+ Set_Is_Independent (E);
+
Independence_Checks.Append ((N, E));
end Independent;
@@ -15043,6 +15066,7 @@
E : Entity_Id;
D : Node_Id;
K : Node_Kind;
+ C : Node_Id;
begin
Check_Ada_83_Warning;
@@ -15077,16 +15101,26 @@
if K = N_Full_Type_Declaration
and then (Is_Array_Type (E) or else Is_Record_Type (E))
then
- Independence_Checks.Append ((N, E));
+ Independence_Checks.Append ((N, Base_Type (E)));
Set_Has_Independent_Components (Base_Type (E));
+ -- For record type, set all components independent
+
+ if Is_Record_Type (E) then
+ C := First_Component (E);
+ while Present (C) loop
+ Set_Is_Independent (C);
+ Next_Component (C);
+ end loop;
+ end if;
+
elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
and then Nkind (D) = N_Object_Declaration
and then Nkind (Object_Definition (D)) =
N_Constrained_Array_Definition
then
- Independence_Checks.Append ((N, E));
- Set_Has_Independent_Components (E);
+ Independence_Checks.Append ((N, Base_Type (Etype (E))));
+ Set_Has_Independent_Components (Base_Type (Etype (E)));
else
Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
@@ -17426,8 +17460,15 @@
Check_No_Identifiers;
Check_Arg_Count (1);
Check_Arg_Is_Local_Name (Arg1);
+ Type_Id := Get_Pragma_Arg (Assoc);
- Type_Id := Get_Pragma_Arg (Assoc);
+ if not Is_Entity_Name (Type_Id)
+ or else not Is_Type (Entity (Type_Id))
+ then
+ Error_Pragma_Arg
+ ("argument for pragma% must be type or subtype", Arg1);
+ end if;
+
Find_Type (Type_Id);
Typ := Entity (Type_Id);
@@ -19650,13 +19691,12 @@
--------------------------------
procedure Check_Library_Level_Entity (E : Entity_Id) is
- MsgF : String := "incorrect placement of pragma%";
+ MsgF : constant String := "incorrect placement of pragma%";
begin
if not Is_Library_Level_Entity (E) then
Error_Msg_Name_1 := Pname;
- Fix_Error (MsgF);
- Error_Msg_N (MsgF, N);
+ Error_Msg_N (Fix_Error (MsgF), N);
if Ekind_In (E, E_Generic_Package,
E_Package,
