From 93f0c209778b7b51d4a7c3df2c4872e27e661f32 Mon Sep 17 00:00:00 2001 From: charlet Date: Tue, 14 Aug 2007 08:37:41 +0000 Subject: [PATCH] 2007-08-14 Ed Schonberg Robert Dewar * 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 git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@127412 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/atree.adb | 340 ++++++++++++++++++++++++++++++++++----------------- gcc/ada/atree.ads | 21 ++-- gcc/ada/par-ch4.adb | 120 ++++++++++++++---- gcc/ada/sem_aggr.adb | 85 +++++++------ 4 files changed, 378 insertions(+), 188 deletions(-) diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index aad0b94..f274bc8 100644 --- a/gcc/ada/atree.adb +++ b/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; diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 2902aea..5e2cba6 100644 --- a/gcc/ada/atree.ads +++ b/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); diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 074e4db..2d1adcd 100644 --- a/gcc/ada/par-ch4.adb +++ b/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 diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 87204e7..491d348 100644 --- a/gcc/ada/sem_aggr.adb +++ b/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)); -- 2.7.4