Skip to content

R
riscv-gcc-1
Commit 8133b9d1 by Ed Schonberg Committed by Arnaud Charlet
Options

atree.ads, atree.adb (New_Copy_Tree): If hash table is being used and itype is visited... 

2007-08-14  Ed Schonberg  <schonberg@adacore.com>
	    Robert Dewar  <dewar@adacore.com>

	* atree.ads, atree.adb (New_Copy_Tree): If hash table is being used and
	itype is visited, make an entry into table to link associated node and
	new itype.
	Add comments and correct harmless error in Build_NCT_Hash_Tables
	(Array_Aggr_Subtype): Associate each itype created for an index type to
	the corresponding range construct, and not to the aggregate itself. to
	maintain a one-to-one correspondence between itype and its associated
	node, to prevent errors when complex expression is copied.
	Fix mishandling of multiple levels of parens

	* sem_aggr.adb: Create a limited view of an incomplete type, to make
	treatment of limited views uniform for all visible declarations in a
	limited_withed package.
	(New_Copy_Tree): If hash table is being used and itype is visited,
	make an entry into table to link associated node and new itype.
	(Resolve_Record_Aggregate): Do not add an others box association for a
	discriminated record component that has only discriminants, when there
	is a box association for the component itself.

	* par-ch4.adb: Fix mishandling of multiple levels of parens

From-SVN: r127412
parent d766cee3
Showing with 378 additions and 188 deletions
gcc/ada/atree.adb
......@@ -535,6 +535,32 @@ package body Atree is
subtype NCT_Header_Num is Int range 0 .. 511;
-- Defines range of headers in hash tables (512 headers)
--------------------------
-- Paren_Count Handling --
--------------------------
-- As noted in the spec, the paren count in a sub-expression node has
-- four possible values 0,1,2, and 3. The value 3 really means 3 or more,
-- and we use an auxiliary serially scanned table to record the actual
-- count. A serial search is fine, only pathological programs will use
-- entries in this table. Normal programs won't use it at all.
type Paren_Count_Entry is record
Nod : Node_Id;
-- The node to which this count applies
Count : Nat range 3 .. Nat'Last;
-- The count of parentheses, which will be in the indicated range
end record;
package Paren_Counts is new Table.Table (
Table_Component_Type => Paren_Count_Entry,
Table_Index_Type => Int,
Table_Low_Bound => 0,
Table_Initial => 10,
Table_Increment => 200,
Table_Name => "Paren_Counts");
-----------------------
-- Local Subprograms --
-----------------------
......@@ -590,6 +616,15 @@ package body Atree is
Node_Count := Node_Count + 1;
end if;
-- Specifically copy Paren_Count to deal with creating new table entry
-- if the parentheses count is at the maximum possible value already.
if Present (Src) and then Nkind (Src) in N_Subexpr then
Set_Paren_Count (New_Id, Paren_Count (Src));
end if;
-- Set extension nodes if required
if With_Extension then
Nodes.Append (Ext1);
Nodes.Append (Ext2);
......@@ -608,7 +643,7 @@ package body Atree is
function Analyzed (N : Node_Id) return Boolean is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return Nodes.Table (N).Analyzed;
end Analyzed;
......@@ -622,7 +657,7 @@ package body Atree is
Save_Link : constant Union_Id := Nodes.Table (N).Link;
Save_CFS : constant Boolean := Nodes.Table (N).Comes_From_Source;
Save_Posted : constant Boolean := Nodes.Table (N).Error_Posted;
Par_Count : Paren_Count_Type := 0;
Par_Count : Nat := 0;
begin
if Nkind (N) in N_Subexpr then
......@@ -648,7 +683,7 @@ package body Atree is
function Comes_From_Source (N : Node_Id) return Boolean is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return Nodes.Table (N).Comes_From_Source;
end Comes_From_Source;
......@@ -675,6 +710,15 @@ package body Atree is
Nodes.Table (Destination).In_List := Save_In_List;
Nodes.Table (Destination).Link := Save_Link;
-- Specifically set Paren_Count to make sure auxiliary table entry
-- gets correctly made if the parentheses count is at the max value.
if Nkind (Destination) in N_Subexpr then
Set_Paren_Count (Destination, Paren_Count (Source));
end if;
-- Deal with copying extension nodes if present
if Has_Extension (Source) then
pragma Assert (Has_Extension (Destination));
Nodes.Table (Destination + 1) := Nodes.Table (Source + 1);
......@@ -923,7 +967,7 @@ package body Atree is
function Error_Posted (N : Node_Id) return Boolean is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return Nodes.Table (N).Error_Posted;
end Error_Posted;
......@@ -1092,6 +1136,7 @@ package body Atree is
Node_Count := 0;
Atree_Private_Part.Nodes.Init;
Orig_Nodes.Init;
Paren_Counts.Init;
-- Allocate Empty node
......@@ -1360,9 +1405,11 @@ package body Atree is
Elmt := First_Elmt (Actual_Map);
while Present (Elmt) loop
Ent := Node (Elmt);
-- Get new entity, and associate old and new
Next_Elmt (Elmt);
NCT_Assoc.Set (Ent, Node (Elmt));
Next_Elmt (Elmt);
if Is_Type (Ent) then
declare
......@@ -1371,10 +1418,17 @@ package body Atree is
begin
if Present (Anode) then
-- Enter a link between the associated node of the
-- old Itype and the new Itype, for updating later
-- when node is copied.
NCT_Itype_Assoc.Set (Anode, Node (Elmt));
end if;
end;
end if;
Next_Elmt (Elmt);
end loop;
NCT_Hash_Tables_Used := True;
......@@ -1877,6 +1931,7 @@ package body Atree is
if NCT_Hash_Tables_Used then
Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype));
if Present (Ent) then
Set_Associated_Node_For_Itype (New_Itype, Ent);
end if;
......@@ -1884,6 +1939,13 @@ package body Atree is
Ent := NCT_Itype_Assoc.Get (Old_Itype);
if Present (Ent) then
Set_Associated_Node_For_Itype (Ent, New_Itype);
-- If the hash table has no association for this Itype and
-- its associated node, enter one now.
else
NCT_Itype_Assoc.Set
(Associated_Node_For_Itype (Old_Itype), New_Itype);
end if;
-- Case of hash tables not used
......@@ -2251,11 +2313,11 @@ package body Atree is
-- Paren_Count --
-----------------
function Paren_Count (N : Node_Id) return Paren_Count_Type is
C : Paren_Count_Type := 0;
function Paren_Count (N : Node_Id) return Nat is
C : Nat := 0;
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
if Nodes.Table (N).Pflag1 then
C := C + 1;
......@@ -2265,7 +2327,22 @@ package body Atree is
C := C + 2;
end if;
return C;
-- Value of 0,1,2 returned as is
if C <= 2 then
return C;
-- Value of 3 means we search the table, and we must find an entry
else
for J in Paren_Counts.First .. Paren_Counts.Last loop
if N = Paren_Counts.Table (J).Nod then
return Paren_Counts.Table (J).Count;
end if;
end loop;
raise Program_Error;
end if;
end Paren_Count;
------------
......@@ -2375,11 +2452,10 @@ package body Atree is
-------------
procedure Rewrite (Old_Node, New_Node : Node_Id) is
Old_Error_P : constant Boolean := Nodes.Table (Old_Node).Error_Posted;
-- This fields is always preserved in the new node
Old_Paren_Count : Paren_Count_Type;
Old_Paren_Count : Nat;
Old_Must_Not_Freeze : Boolean;
-- These fields are preserved in the new node only if the new node
-- and the old node are both subexpression nodes.
......@@ -2443,7 +2519,7 @@ package body Atree is
procedure Set_Comes_From_Source (N : Node_Id; Val : Boolean) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Comes_From_Source := Val;
end Set_Comes_From_Source;
......@@ -2492,11 +2568,31 @@ package body Atree is
-- Set_Paren_Count --
---------------------
procedure Set_Paren_Count (N : Node_Id; Val : Paren_Count_Type) is
procedure Set_Paren_Count (N : Node_Id; Val : Nat) is
begin
pragma Assert (Nkind (N) in N_Subexpr);
Nodes.Table (N).Pflag1 := (Val mod 2 /= 0);
Nodes.Table (N).Pflag2 := (Val >= 2);
-- Value of 0,1,2 stored as is
if Val <= 2 then
Nodes.Table (N).Pflag1 := (Val mod 2 /= 0);
Nodes.Table (N).Pflag2 := (Val = 2);
-- Value of 3 or greater stores 3 in node and makes table entry
else
Nodes.Table (N).Pflag1 := True;
Nodes.Table (N).Pflag2 := True;
for J in Paren_Counts.First .. Paren_Counts.Last loop
if N = Paren_Counts.Table (J).Nod then
Paren_Counts.Table (J).Count := Val;
return;
end if;
end loop;
Paren_Counts.Append ((Nod => N, Count => Val));
end if;
end Set_Paren_Count;
----------------
......@@ -2673,6 +2769,7 @@ package body Atree is
Tree_Read_Int (Node_Count);
Nodes.Tree_Read;
Orig_Nodes.Tree_Read;
Paren_Counts.Tree_Read;
end Tree_Read;
----------------
......@@ -2684,6 +2781,7 @@ package body Atree is
Tree_Write_Int (Node_Count);
Nodes.Tree_Write;
Orig_Nodes.Tree_Write;
Paren_Counts.Tree_Write;
end Tree_Write;
------------------------------
......@@ -2694,31 +2792,31 @@ package body Atree is
function Field1 (N : Node_Id) return Union_Id is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return Nodes.Table (N).Field1;
end Field1;
function Field2 (N : Node_Id) return Union_Id is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return Nodes.Table (N).Field2;
end Field2;
function Field3 (N : Node_Id) return Union_Id is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return Nodes.Table (N).Field3;
end Field3;
function Field4 (N : Node_Id) return Union_Id is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return Nodes.Table (N).Field4;
end Field4;
function Field5 (N : Node_Id) return Union_Id is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return Nodes.Table (N).Field5;
end Field5;
......@@ -2862,31 +2960,31 @@ package body Atree is
function Node1 (N : Node_Id) return Node_Id is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return Node_Id (Nodes.Table (N).Field1);
end Node1;
function Node2 (N : Node_Id) return Node_Id is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return Node_Id (Nodes.Table (N).Field2);
end Node2;
function Node3 (N : Node_Id) return Node_Id is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return Node_Id (Nodes.Table (N).Field3);
end Node3;
function Node4 (N : Node_Id) return Node_Id is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return Node_Id (Nodes.Table (N).Field4);
end Node4;
function Node5 (N : Node_Id) return Node_Id is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return Node_Id (Nodes.Table (N).Field5);
end Node5;
......@@ -3030,31 +3128,31 @@ package body Atree is
function List1 (N : Node_Id) return List_Id is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return List_Id (Nodes.Table (N).Field1);
end List1;
function List2 (N : Node_Id) return List_Id is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return List_Id (Nodes.Table (N).Field2);
end List2;
function List3 (N : Node_Id) return List_Id is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return List_Id (Nodes.Table (N).Field3);
end List3;
function List4 (N : Node_Id) return List_Id is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return List_Id (Nodes.Table (N).Field4);
end List4;
function List5 (N : Node_Id) return List_Id is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return List_Id (Nodes.Table (N).Field5);
end List5;
......@@ -3071,7 +3169,7 @@ package body Atree is
end List14;
function Elist1 (N : Node_Id) return Elist_Id is
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Value : constant Union_Id := Nodes.Table (N).Field1;
begin
if Value = 0 then
......@@ -3082,7 +3180,7 @@ package body Atree is
end Elist1;
function Elist2 (N : Node_Id) return Elist_Id is
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Value : constant Union_Id := Nodes.Table (N).Field2;
begin
if Value = 0 then
......@@ -3093,7 +3191,7 @@ package body Atree is
end Elist2;
function Elist3 (N : Node_Id) return Elist_Id is
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Value : constant Union_Id := Nodes.Table (N).Field3;
begin
if Value = 0 then
......@@ -3104,7 +3202,7 @@ package body Atree is
end Elist3;
function Elist4 (N : Node_Id) return Elist_Id is
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Value : constant Union_Id := Nodes.Table (N).Field4;
begin
if Value = 0 then
......@@ -3204,24 +3302,24 @@ package body Atree is
function Name1 (N : Node_Id) return Name_Id is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return Name_Id (Nodes.Table (N).Field1);
end Name1;
function Name2 (N : Node_Id) return Name_Id is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return Name_Id (Nodes.Table (N).Field2);
end Name2;
function Str3 (N : Node_Id) return String_Id is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return String_Id (Nodes.Table (N).Field3);
end Str3;
function Uint2 (N : Node_Id) return Uint is
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
U : constant Union_Id := Nodes.Table (N).Field2;
begin
if U = 0 then
......@@ -3232,7 +3330,7 @@ package body Atree is
end Uint2;
function Uint3 (N : Node_Id) return Uint is
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
U : constant Union_Id := Nodes.Table (N).Field3;
begin
if U = 0 then
......@@ -3243,7 +3341,7 @@ package body Atree is
end Uint3;
function Uint4 (N : Node_Id) return Uint is
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
U : constant Union_Id := Nodes.Table (N).Field4;
begin
if U = 0 then
......@@ -3254,7 +3352,7 @@ package body Atree is
end Uint4;
function Uint5 (N : Node_Id) return Uint is
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
U : constant Union_Id := Nodes.Table (N).Field5;
begin
if U = 0 then
......@@ -3387,7 +3485,7 @@ package body Atree is
function Ureal3 (N : Node_Id) return Ureal is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return From_Union (Nodes.Table (N).Field3);
end Ureal3;
......@@ -3405,91 +3503,91 @@ package body Atree is
function Flag4 (N : Node_Id) return Boolean is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return Nodes.Table (N).Flag4;
end Flag4;
function Flag5 (N : Node_Id) return Boolean is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return Nodes.Table (N).Flag5;
end Flag5;
function Flag6 (N : Node_Id) return Boolean is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return Nodes.Table (N).Flag6;
end Flag6;
function Flag7 (N : Node_Id) return Boolean is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return Nodes.Table (N).Flag7;
end Flag7;
function Flag8 (N : Node_Id) return Boolean is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return Nodes.Table (N).Flag8;
end Flag8;
function Flag9 (N : Node_Id) return Boolean is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return Nodes.Table (N).Flag9;
end Flag9;
function Flag10 (N : Node_Id) return Boolean is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return Nodes.Table (N).Flag10;
end Flag10;
function Flag11 (N : Node_Id) return Boolean is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return Nodes.Table (N).Flag11;
end Flag11;
function Flag12 (N : Node_Id) return Boolean is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return Nodes.Table (N).Flag12;
end Flag12;
function Flag13 (N : Node_Id) return Boolean is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return Nodes.Table (N).Flag13;
end Flag13;
function Flag14 (N : Node_Id) return Boolean is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return Nodes.Table (N).Flag14;
end Flag14;
function Flag15 (N : Node_Id) return Boolean is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return Nodes.Table (N).Flag15;
end Flag15;
function Flag16 (N : Node_Id) return Boolean is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return Nodes.Table (N).Flag16;
end Flag16;
function Flag17 (N : Node_Id) return Boolean is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return Nodes.Table (N).Flag17;
end Flag17;
function Flag18 (N : Node_Id) return Boolean is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
return Nodes.Table (N).Flag18;
end Flag18;
......@@ -4767,37 +4865,37 @@ package body Atree is
procedure Set_Nkind (N : Node_Id; Val : Node_Kind) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Nkind := Val;
end Set_Nkind;
procedure Set_Field1 (N : Node_Id; Val : Union_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field1 := Val;
end Set_Field1;
procedure Set_Field2 (N : Node_Id; Val : Union_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field2 := Val;
end Set_Field2;
procedure Set_Field3 (N : Node_Id; Val : Union_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field3 := Val;
end Set_Field3;
procedure Set_Field4 (N : Node_Id; Val : Union_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field4 := Val;
end Set_Field4;
procedure Set_Field5 (N : Node_Id; Val : Union_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field5 := Val;
end Set_Field5;
......@@ -4941,31 +5039,31 @@ package body Atree is
procedure Set_Node1 (N : Node_Id; Val : Node_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field1 := Union_Id (Val);
end Set_Node1;
procedure Set_Node2 (N : Node_Id; Val : Node_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field2 := Union_Id (Val);
end Set_Node2;
procedure Set_Node3 (N : Node_Id; Val : Node_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field3 := Union_Id (Val);
end Set_Node3;
procedure Set_Node4 (N : Node_Id; Val : Node_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field4 := Union_Id (Val);
end Set_Node4;
procedure Set_Node5 (N : Node_Id; Val : Node_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field5 := Union_Id (Val);
end Set_Node5;
......@@ -5109,31 +5207,31 @@ package body Atree is
procedure Set_List1 (N : Node_Id; Val : List_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field1 := Union_Id (Val);
end Set_List1;
procedure Set_List2 (N : Node_Id; Val : List_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field2 := Union_Id (Val);
end Set_List2;
procedure Set_List3 (N : Node_Id; Val : List_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field3 := Union_Id (Val);
end Set_List3;
procedure Set_List4 (N : Node_Id; Val : List_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field4 := Union_Id (Val);
end Set_List4;
procedure Set_List5 (N : Node_Id; Val : List_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field5 := Union_Id (Val);
end Set_List5;
......@@ -5219,43 +5317,43 @@ package body Atree is
procedure Set_Name1 (N : Node_Id; Val : Name_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field1 := Union_Id (Val);
end Set_Name1;
procedure Set_Name2 (N : Node_Id; Val : Name_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field2 := Union_Id (Val);
end Set_Name2;
procedure Set_Str3 (N : Node_Id; Val : String_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field3 := Union_Id (Val);
end Set_Str3;
procedure Set_Uint2 (N : Node_Id; Val : Uint) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field2 := To_Union (Val);
end Set_Uint2;
procedure Set_Uint3 (N : Node_Id; Val : Uint) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field3 := To_Union (Val);
end Set_Uint3;
procedure Set_Uint4 (N : Node_Id; Val : Uint) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field4 := To_Union (Val);
end Set_Uint4;
procedure Set_Uint5 (N : Node_Id; Val : Uint) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field5 := To_Union (Val);
end Set_Uint5;
......@@ -5327,7 +5425,7 @@ package body Atree is
procedure Set_Ureal3 (N : Node_Id; Val : Ureal) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field3 := To_Union (Val);
end Set_Ureal3;
......@@ -5345,91 +5443,91 @@ package body Atree is
procedure Set_Flag4 (N : Node_Id; Val : Boolean) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag4 := Val;
end Set_Flag4;
procedure Set_Flag5 (N : Node_Id; Val : Boolean) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag5 := Val;
end Set_Flag5;
procedure Set_Flag6 (N : Node_Id; Val : Boolean) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag6 := Val;
end Set_Flag6;
procedure Set_Flag7 (N : Node_Id; Val : Boolean) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag7 := Val;
end Set_Flag7;
procedure Set_Flag8 (N : Node_Id; Val : Boolean) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag8 := Val;
end Set_Flag8;
procedure Set_Flag9 (N : Node_Id; Val : Boolean) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag9 := Val;
end Set_Flag9;
procedure Set_Flag10 (N : Node_Id; Val : Boolean) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag10 := Val;
end Set_Flag10;
procedure Set_Flag11 (N : Node_Id; Val : Boolean) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag11 := Val;
end Set_Flag11;
procedure Set_Flag12 (N : Node_Id; Val : Boolean) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag12 := Val;
end Set_Flag12;
procedure Set_Flag13 (N : Node_Id; Val : Boolean) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag13 := Val;
end Set_Flag13;
procedure Set_Flag14 (N : Node_Id; Val : Boolean) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag14 := Val;
end Set_Flag14;
procedure Set_Flag15 (N : Node_Id; Val : Boolean) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag15 := Val;
end Set_Flag15;
procedure Set_Flag16 (N : Node_Id; Val : Boolean) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag16 := Val;
end Set_Flag16;
procedure Set_Flag17 (N : Node_Id; Val : Boolean) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag17 := Val;
end Set_Flag17;
procedure Set_Flag18 (N : Node_Id; Val : Boolean) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag18 := Val;
end Set_Flag18;
......@@ -6993,42 +7091,62 @@ package body Atree is
procedure Set_Node1_With_Parent (N : Node_Id; Val : Node_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
if Val > Error then Set_Parent (Val, N); end if;
pragma Assert (N <= Nodes.Last);
if Val > Error then
Set_Parent (Val, N);
end if;
Set_Node1 (N, Val);
end Set_Node1_With_Parent;
procedure Set_Node2_With_Parent (N : Node_Id; Val : Node_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
if Val > Error then Set_Parent (Val, N); end if;
pragma Assert (N <= Nodes.Last);
if Val > Error then
Set_Parent (Val, N);
end if;
Set_Node2 (N, Val);
end Set_Node2_With_Parent;
procedure Set_Node3_With_Parent (N : Node_Id; Val : Node_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
if Val > Error then Set_Parent (Val, N); end if;
pragma Assert (N <= Nodes.Last);
if Val > Error then
Set_Parent (Val, N);
end if;
Set_Node3 (N, Val);
end Set_Node3_With_Parent;
procedure Set_Node4_With_Parent (N : Node_Id; Val : Node_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
if Val > Error then Set_Parent (Val, N); end if;
pragma Assert (N <= Nodes.Last);
if Val > Error then
Set_Parent (Val, N);
end if;
Set_Node4 (N, Val);
end Set_Node4_With_Parent;
procedure Set_Node5_With_Parent (N : Node_Id; Val : Node_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
if Val > Error then Set_Parent (Val, N); end if;
pragma Assert (N <= Nodes.Last);
if Val > Error then
Set_Parent (Val, N);
end if;
Set_Node5 (N, Val);
end Set_Node5_With_Parent;
procedure Set_List1_With_Parent (N : Node_Id; Val : List_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
if Val /= No_List and then Val /= Error_List then
Set_Parent (Val, N);
end if;
......@@ -7037,7 +7155,7 @@ package body Atree is
procedure Set_List2_With_Parent (N : Node_Id; Val : List_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
if Val /= No_List and then Val /= Error_List then
Set_Parent (Val, N);
end if;
......@@ -7046,7 +7164,7 @@ package body Atree is
procedure Set_List3_With_Parent (N : Node_Id; Val : List_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
if Val /= No_List and then Val /= Error_List then
Set_Parent (Val, N);
end if;
......@@ -7055,7 +7173,7 @@ package body Atree is
procedure Set_List4_With_Parent (N : Node_Id; Val : List_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
if Val /= No_List and then Val /= Error_List then
Set_Parent (Val, N);
end if;
......@@ -7064,7 +7182,7 @@ package body Atree is
procedure Set_List5_With_Parent (N : Node_Id; Val : List_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
pragma Assert (N <= Nodes.Last);
if Val /= No_List and then Val /= Error_List then
Set_Parent (Val, N);
end if;
......
gcc/ada/atree.ads
......@@ -94,12 +94,11 @@ package Atree is
-- Rewrite_Ins A flag set if a node is marked as a rewrite inserted
-- node as a result of a call to Mark_Rewrite_Insertion.
-- Paren_Count A 2-bit count used on expression nodes to indicate
-- the level of parentheses. Up to 3 levels can be
-- accomodated. Anything more than 3 levels is treated
-- as 3 levels (conformance tests that complain about
-- this are hereby deemed pathological!). Set to zero
-- for non-subexpression nodes.
-- Paren_Count A 2-bit count used in sub-expression nodes to indicate
-- the level of parentheses. The settings are 0,1,2 and
-- 3 for many. If the value is 3, then an auxiliary table
-- is used to indicate the real value. Set to zero for
-- non-subexpression nodes.
-- Comes_From_Source
-- This flag is present in all nodes. It is set if the
......@@ -203,10 +202,6 @@ package Atree is
-- Elist7-Elist28, Uint7-Uint28, Ureal7-Ureal28). Note that not all
-- these functions are defined, only the ones that are actually used.
type Paren_Count_Type is mod 4;
for Paren_Count_Type'Size use 2;
-- Type used for Paren_Count field
function Last_Node_Id return Node_Id;
pragma Inline (Last_Node_Id);
-- Returns Id of last allocated node Id
......@@ -548,7 +543,7 @@ package Atree is
-- The result returned by Traverse is Abandon if processing was terminated
-- by a call to Process returning Abandon, otherwise it is OK (meaning that
-- all calls to process returned either OK or Skip).
-- all calls to process returned either OK, OK_Orig, or Skip).
generic
with function Process (N : Node_Id) return Traverse_Result is <>;
......@@ -579,7 +574,7 @@ package Atree is
function Sloc (N : Node_Id) return Source_Ptr;
pragma Inline (Sloc);
function Paren_Count (N : Node_Id) return Paren_Count_Type;
function Paren_Count (N : Node_Id) return Nat;
pragma Inline (Paren_Count);
function Parent (N : Node_Id) return Node_Id;
......@@ -623,7 +618,7 @@ package Atree is
procedure Set_Sloc (N : Node_Id; Val : Source_Ptr);
pragma Inline (Set_Sloc);
procedure Set_Paren_Count (N : Node_Id; Val : Paren_Count_Type);
procedure Set_Paren_Count (N : Node_Id; Val : Nat);
pragma Inline (Set_Paren_Count);
procedure Set_Parent (N : Node_Id; Val : Node_Id);
......
gcc/ada/par-ch4.adb
......@@ -69,7 +69,7 @@ package body Ch4 is
procedure Bad_Range_Attribute (Loc : Source_Ptr) is
begin
Error_Msg ("range attribute cannot be used in expression", Loc);
Error_Msg ("range attribute cannot be used in expression!", Loc);
Resync_Expression;
end Bad_Range_Attribute;
......@@ -1267,18 +1267,14 @@ package body Ch4 is
then
Error_Msg
("|parentheses not allowed for range attribute", Lparen_Sloc);
Scan; -- past right paren
return Expr_Node;
end if;
-- Bump paren count of expression, note that if the paren count
-- is already at the maximum, then we leave it alone. This will
-- cause some failures in pathalogical conformance tests, which
-- we do not shed a tear over!
-- Bump paren count of expression
if Expr_Node /= Error then
if Paren_Count (Expr_Node) /= Paren_Count_Type'Last then
Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1);
end if;
Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1);
end if;
T_Right_Paren; -- past right paren (error message if none)
......@@ -1577,11 +1573,13 @@ package body Ch4 is
-- called in all contexts where a right parenthesis cannot legitimately
-- follow an expression.
-- Error recovery: can raise Error_Resync
-- Error recovery: can not raise Error_Resync
function P_Expression_No_Right_Paren return Node_Id is
Expr : constant Node_Id := P_Expression;
begin
return No_Right_Paren (P_Expression);
Check_No_Right_Paren;
return Expr;
end P_Expression_No_Right_Paren;
----------------------------------------
......@@ -1805,7 +1803,10 @@ package body Ch4 is
else
if Token = Tok_Double_Asterisk then
if Style_Check then Style.Check_Exponentiation_Operator; end if;
if Style_Check then
Style.Check_Exponentiation_Operator;
end if;
Node2 := New_Node (N_Op_Expon, Token_Ptr);
Scan; -- past **
Set_Left_Opnd (Node2, Node1);
......@@ -1818,7 +1819,11 @@ package body Ch4 is
exit when Token not in Token_Class_Mulop;
Tokptr := Token_Ptr;
Node2 := New_Node (P_Multiplying_Operator, Tokptr);
if Style_Check then Style.Check_Binary_Operator; end if;
if Style_Check then
Style.Check_Binary_Operator;
end if;
Scan; -- past operator
Set_Left_Opnd (Node2, Node1);
Set_Right_Opnd (Node2, P_Factor);
......@@ -1830,7 +1835,11 @@ package body Ch4 is
exit when Token not in Token_Class_Binary_Addop;
Tokptr := Token_Ptr;
Node2 := New_Node (P_Binary_Adding_Operator, Tokptr);
if Style_Check then Style.Check_Binary_Operator; end if;
if Style_Check then
Style.Check_Binary_Operator;
end if;
Scan; -- past operator
Set_Left_Opnd (Node2, Node1);
Set_Right_Opnd (Node2, P_Term);
......@@ -1849,7 +1858,11 @@ package body Ch4 is
if Token in Token_Class_Unary_Addop then
Tokptr := Token_Ptr;
Node1 := New_Node (P_Unary_Adding_Operator, Tokptr);
if Style_Check then Style.Check_Unary_Plus_Or_Minus; end if;
if Style_Check then
Style.Check_Unary_Plus_Or_Minus;
end if;
Scan; -- past operator
Set_Right_Opnd (Node1, P_Term);
Set_Op_Name (Node1);
......@@ -1951,6 +1964,39 @@ package body Ch4 is
Attr_Node : Node_Id;
begin
-- We don't just want to roar ahead and call P_Simple_Expression
-- here, since we want to handle the case of a parenthesized range
-- attribute cleanly.
if Token = Tok_Left_Paren then
declare
Lptr : constant Source_Ptr := Token_Ptr;
Scan_State : Saved_Scan_State;
begin
Save_Scan_State (Scan_State);
Scan; -- past left paren
Sexpr := P_Simple_Expression;
if Token = Tok_Apostrophe then
Attr_Node := P_Range_Attribute_Reference (Sexpr);
Expr_Form := EF_Range_Attr;
if Token = Tok_Right_Paren then
Scan; -- scan past right paren if present
end if;
Error_Msg ("parentheses not allowed for range attribute", Lptr);
return Attr_Node;
end if;
Restore_Scan_State (Scan_State);
end;
end if;
-- Here after dealing with parenthesized range attribute
Sexpr := P_Simple_Expression;
if Token = Tok_Apostrophe then
......@@ -2007,7 +2053,11 @@ package body Ch4 is
begin
if Token = Tok_Abs then
Node1 := New_Node (N_Op_Abs, Token_Ptr);
if Style_Check then Style.Check_Abs_Not; end if;
if Style_Check then
Style.Check_Abs_Not;
end if;
Scan; -- past ABS
Set_Right_Opnd (Node1, P_Primary);
Set_Op_Name (Node1);
......@@ -2015,7 +2065,11 @@ package body Ch4 is
elsif Token = Tok_Not then
Node1 := New_Node (N_Op_Not, Token_Ptr);
if Style_Check then Style.Check_Abs_Not; end if;
if Style_Check then
Style.Check_Abs_Not;
end if;
Scan; -- past NOT
Set_Right_Opnd (Node1, P_Primary);
Set_Op_Name (Node1);
......@@ -2116,7 +2170,18 @@ package body Ch4 is
-- Left paren, starts aggregate or parenthesized expression
when Tok_Left_Paren =>
return P_Aggregate_Or_Paren_Expr;
declare
Expr : constant Node_Id := P_Aggregate_Or_Paren_Expr;
begin
if Nkind (Expr) = N_Attribute_Reference
and then Attribute_Name (Expr) = Name_Range
then
Bad_Range_Attribute (Sloc (Expr));
end if;
return Expr;
end;
-- Allocator
......@@ -2174,7 +2239,10 @@ package body Ch4 is
function P_Logical_Operator return Node_Kind is
begin
if Token = Tok_And then
if Style_Check then Style.Check_Binary_Operator; end if;
if Style_Check then
Style.Check_Binary_Operator;
end if;
Scan; -- past AND
if Token = Tok_Then then
......@@ -2185,7 +2253,10 @@ package body Ch4 is
end if;
elsif Token = Tok_Or then
if Style_Check then Style.Check_Binary_Operator; end if;
if Style_Check then
Style.Check_Binary_Operator;
end if;
Scan; -- past OR
if Token = Tok_Else then
......@@ -2196,7 +2267,10 @@ package body Ch4 is
end if;
else -- Token = Tok_Xor
if Style_Check then Style.Check_Binary_Operator; end if;
if Style_Check then
Style.Check_Binary_Operator;
end if;
Scan; -- past XOR
return N_Op_Xor;
end if;
......@@ -2235,7 +2309,11 @@ package body Ch4 is
end if;
Op_Kind := Relop_Node (Token);
if Style_Check then Style.Check_Binary_Operator; end if;
if Style_Check then
Style.Check_Binary_Operator;
end if;
Scan; -- past operator token
if Prev_Token = Tok_Not then
......
gcc/ada/sem_aggr.adb
......@@ -39,11 +39,9 @@ with Namet; use Namet;
with Nmake; use Nmake;
with Nlists; use Nlists;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
......@@ -88,7 +86,7 @@ package body Sem_Aggr is
-- E_Component/E_Discriminant entity in the record case, in which case the
-- type of the component will be used for the test. If Typ is any other
-- kind of entity, the call is ignored. Expr is the component node in the
-- aggregate which is an explicit occurrence of NULL. An error will be
-- aggregate which is known to have a null value. A warning message will be
-- issued if the component is null excluding.
--
-- It would be better to pass the proper type for Typ ???
......@@ -639,9 +637,11 @@ package body Sem_Aggr is
Index_Typ : Entity_Id;
begin
-- Construct the Index subtype
-- Construct the Index subtype, and associate it with the range
-- construct that generates it.
Index_Typ := Create_Itype (Subtype_Kind (Ekind (Index_Base)), N);
Index_Typ :=
Create_Itype (Subtype_Kind (Ekind (Index_Base)), Aggr_Range (J));
Set_Etype (Index_Typ, Index_Base);
......@@ -684,32 +684,15 @@ package body Sem_Aggr is
Set_Is_Internal (Itype, True);
Init_Size_Align (Itype);
-- Handle aggregate initializing statically allocated dispatch table
if Static_Dispatch_Tables
and then VM_Target = No_VM
and then RTU_Loaded (Ada_Tags)
-- Avoid circularity when rebuilding the compiler
and then Cunit_Entity (Get_Source_Unit (N)) /= RTU_Entity (Ada_Tags)
and then (Etype (N) = RTE (RE_Address_Array)
or else
Base_Type (Etype (N)) = RTE (RE_Tag_Table))
then
Set_Size_Known_At_Compile_Time (Itype);
-- A simple optimization: purely positional aggregates of static
-- components should be passed to gigi unexpanded whenever possible,
-- and regardless of the staticness of the bounds themselves. Subse-
-- quent checks in exp_aggr verify that type is not packed, etc.
else
Set_Size_Known_At_Compile_Time (Itype,
Is_Fully_Positional
and then Comes_From_Source (N)
and then Size_Known_At_Compile_Time (Component_Type (Typ)));
end if;
Set_Size_Known_At_Compile_Time (Itype,
Is_Fully_Positional
and then Comes_From_Source (N)
and then Size_Known_At_Compile_Time (Component_Type (Typ)));
-- We always need a freeze node for a packed array subtype, so that
-- we can build the Packed_Array_Type corresponding to the subtype.
......@@ -1022,7 +1005,7 @@ package body Sem_Aggr is
Pkind = N_Procedure_Call_Statement or else
Pkind = N_Generic_Association or else
Pkind = N_Formal_Object_Declaration or else
Pkind = N_Return_Statement or else
Pkind = N_Simple_Return_Statement or else
Pkind = N_Object_Declaration or else
Pkind = N_Component_Declaration or else
Pkind = N_Parameter_Specification or else
......@@ -1719,7 +1702,7 @@ package body Sem_Aggr is
-- Ada 2005 (AI-231)
if Ada_Version >= Ada_05
and then Nkind (Expression (Assoc)) = N_Null
and then Known_Null (Expression (Assoc))
then
Check_Can_Never_Be_Null (Etype (N), Expression (Assoc));
end if;
......@@ -1851,7 +1834,7 @@ package body Sem_Aggr is
-- Ada 2005 (AI-231)
if Ada_Version >= Ada_05
and then Nkind (Expr) = N_Null
and then Known_Null (Expr)
then
Check_Can_Never_Be_Null (Etype (N), Expr);
end if;
......@@ -1869,7 +1852,7 @@ package body Sem_Aggr is
-- Ada 2005 (AI-231)
if Ada_Version >= Ada_05
and then Nkind (Assoc) = N_Null
and then Known_Null (Assoc)
then
Check_Can_Never_Be_Null (Etype (N), Expression (Assoc));
end if;
......@@ -2401,7 +2384,7 @@ package body Sem_Aggr is
-- Ada 2005 (AI-231)
if Ada_Version >= Ada_05
and then Nkind (Expression (Assoc)) = N_Null
and then Known_Null (Expression (Assoc))
then
Check_Can_Never_Be_Null (Compon, Expression (Assoc));
end if;
......@@ -2731,7 +2714,7 @@ package body Sem_Aggr is
-- Ada 2005 (AI-231)
if Ada_Version >= Ada_05
and then Nkind (Positional_Expr) = N_Null
and then Known_Null (Positional_Expr)
then
Check_Can_Never_Be_Null (Discrim, Positional_Expr);
end if;
......@@ -2969,7 +2952,7 @@ package body Sem_Aggr is
-- Ada 2005 (AI-231)
if Ada_Version >= Ada_05
and then Nkind (Positional_Expr) = N_Null
and then Known_Null (Positional_Expr)
then
Check_Can_Never_Be_Null (Component, Positional_Expr);
end if;
......@@ -3052,7 +3035,7 @@ package body Sem_Aggr is
then
-- We build a partially initialized aggregate with the
-- values of the discriminants and box initialization
-- for the rest.
-- for the rest, if other components are present.
declare
Loc : constant Source_Ptr := Sloc (N);
......@@ -3085,13 +3068,29 @@ package body Sem_Aggr is
Next_Elmt (Discr_Elmt);
end loop;
Append
(Make_Component_Association (Loc,
Choices =>
New_List (Make_Others_Choice (Loc)),
Expression => Empty,
Box_Present => True),
Component_Associations (Expr));
declare
Comp : Entity_Id;
begin
-- Look for a component that is not a discriminant
-- before creating an others box association.
Comp := First_Component (Ctyp);
while Present (Comp) loop
if Ekind (Comp) = E_Component then
Append
(Make_Component_Association (Loc,
Choices =>
New_List (Make_Others_Choice (Loc)),
Expression => Empty,
Box_Present => True),
Component_Associations (Expr));
exit;
end if;
Next_Component (Comp);
end loop;
end;
Add_Association
(Component => Component,
......@@ -3271,7 +3270,7 @@ package body Sem_Aggr is
pragma Assert
(Ada_Version >= Ada_05
and then Present (Expr)
and then Nkind (Expr) = N_Null);
and then Known_Null (Expr));
case Ekind (Typ) is
when E_Array_Type =>
......@@ -3295,7 +3294,7 @@ package body Sem_Aggr is
Insert_Action
(Compile_Time_Constraint_Error
(Expr,
"(Ada 2005) NULL not allowed in null-excluding components?"),
"(Ada 2005) null not allowed in null-excluding component?"),
Make_Raise_Constraint_Error (Sloc (Expr),
Reason => CE_Access_Check_Failed));
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment