diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/atree.adb | 443 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 292 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 43 | ||||
| -rw-r--r-- | gcc/ada/exp_util.ads | 19 | ||||
| -rw-r--r-- | gcc/ada/nlists.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/nlists.ads | 3 | ||||
| -rw-r--r-- | gcc/ada/par-ch4.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_ch7.adb | 28 | ||||
| -rw-r--r-- | gcc/ada/sinfo.adb | 132 | ||||
| -rw-r--r-- | gcc/ada/sinfo.ads | 158 |
10 files changed, 708 insertions, 430 deletions
diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 1e8b1cc..322528c4 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -364,9 +364,6 @@ package body Atree is Flag228 : Boolean; Flag229 : Boolean; Flag230 : Boolean; - - -- Note: flags 231-247 not in use yet - Flag231 : Boolean; Flag232 : Boolean; @@ -647,6 +644,18 @@ package body Atree is return Nodes.Table (N).Analyzed; end Analyzed; + -------------------------- + -- Basic_Set_Convention -- + -------------------------- + + procedure Basic_Set_Convention (E : Entity_Id; Val : Convention_Id) is + begin + pragma Assert (Nkind (E) in N_Entity); + To_Flag_Word_Ptr + (Union_Id_Ptr' + (Nodes.Table (E + 2).Field12'Unrestricted_Access)).Convention := Val; + end Basic_Set_Convention; + ----------------- -- Change_Node -- ----------------- @@ -868,91 +877,6 @@ package body Atree is end if; end Copy_Separate_Tree; - ----------------- - -- Delete_Node -- - ----------------- - - procedure Delete_Node (Node : Node_Id) is - begin - pragma Assert (not Nodes.Table (Node).In_List); - - if Debug_Flag_N then - Write_Str ("Delete node "); - Write_Int (Int (Node)); - Write_Eol; - end if; - - Nodes.Table (Node) := Default_Node; - Nodes.Table (Node).Nkind := N_Unused_At_Start; - Node_Count := Node_Count - 1; - - -- Note: for now, we are not bothering to reuse deleted nodes - - end Delete_Node; - - ----------------- - -- Delete_Tree -- - ----------------- - - procedure Delete_Tree (Node : Node_Id) is - - procedure Delete_Field (F : Union_Id); - -- Delete item pointed to by field F if it is a syntactic element - - procedure Delete_List (L : List_Id); - -- Delete all elements on the given list - - ------------------ - -- Delete_Field -- - ------------------ - - procedure Delete_Field (F : Union_Id) is - begin - if F = Union_Id (Empty) then - return; - - elsif F in Node_Range - and then Parent (Node_Id (F)) = Node - then - Delete_Tree (Node_Id (F)); - - elsif F in List_Range - and then Parent (List_Id (F)) = Node - then - Delete_List (List_Id (F)); - - -- No need to test Elist case, there are no syntactic Elists - - else - return; - end if; - end Delete_Field; - - ----------------- - -- Delete_List -- - ----------------- - - procedure Delete_List (L : List_Id) is - begin - while Is_Non_Empty_List (L) loop - Delete_Tree (Remove_Head (L)); - end loop; - end Delete_List; - - -- Start of processing for Delete_Tree - - begin - -- Delete descendents - - Delete_Field (Field1 (Node)); - Delete_Field (Field2 (Node)); - Delete_Field (Field3 (Node)); - Delete_Field (Field4 (Node)); - Delete_Field (Field5 (Node)); - - -- ??? According to spec, Node itself should be deleted as well - end Delete_Tree; - ----------- -- Ekind -- ----------- @@ -2275,6 +2199,94 @@ package body Atree is return Nodes.Table (N).Nkind; end Nkind; + -------------- + -- Nkind_In -- + -------------- + + function Nkind_In + (N : Node_Id; + V1 : Node_Kind; + V2 : Node_Kind) return Boolean + is + begin + return Nkind_In (Nkind (N), V1, V2); + end Nkind_In; + + function Nkind_In + (N : Node_Id; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind) return Boolean + is + begin + return Nkind_In (Nkind (N), V1, V2, V3); + end Nkind_In; + + function Nkind_In + (N : Node_Id; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind) return Boolean + is + begin + return Nkind_In (Nkind (N), V1, V2, V3, V4); + end Nkind_In; + + function Nkind_In + (N : Node_Id; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind) return Boolean + is + begin + return Nkind_In (Nkind (N), V1, V2, V3, V4, V5); + end Nkind_In; + + function Nkind_In + (N : Node_Id; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind; + V6 : Node_Kind) return Boolean + is + begin + return Nkind_In (Nkind (N), V1, V2, V3, V4, V5, V6); + end Nkind_In; + + function Nkind_In + (N : Node_Id; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind; + V6 : Node_Kind; + V7 : Node_Kind) return Boolean + is + begin + return Nkind_In (Nkind (N), V1, V2, V3, V4, V5, V6, V7); + end Nkind_In; + + function Nkind_In + (N : Node_Id; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind; + V6 : Node_Kind; + V7 : Node_Kind; + V8 : Node_Kind) return Boolean + is + begin + return Nkind_In (Nkind (N), V1, V2, V3, V4, V5, V6, V7, V8); + end Nkind_In; + -------- -- No -- -------- @@ -2443,10 +2455,6 @@ package body Atree is -- to Rewrite if there were an intention to save the original node. Orig_Nodes.Table (Old_Node) := Old_Node; - - -- Finally delete the source, since it is now copied - - Delete_Node (New_Node); end Replace; ------------- @@ -2534,19 +2542,6 @@ package body Atree is Default_Node.Comes_From_Source := Default; end Set_Comes_From_Source_Default; - -------------------- - -- Set_Convention -- - -------------------- - - procedure Set_Convention (E : Entity_Id; Val : Convention_Id) is - begin - pragma Assert (Nkind (E) in N_Entity); - To_Flag_Word_Ptr - (Union_Id_Ptr' - (Nodes.Table (E + 2).Field12'Unrestricted_Access)).Convention := - Val; - end Set_Convention; - --------------- -- Set_Ekind -- --------------- @@ -4865,6 +4860,108 @@ package body Atree is return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag230; end Flag230; + function Flag231 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag231; + end Flag231; + + function Flag232 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag232; + end Flag232; + + function Flag233 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag233; + end Flag233; + + function Flag234 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag234; + end Flag234; + + function Flag235 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag235; + end Flag235; + + function Flag236 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag236; + end Flag236; + + function Flag237 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag237; + end Flag237; + + function Flag238 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag238; + end Flag238; + + function Flag239 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag239; + end Flag239; + + function Flag240 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag240; + end Flag240; + + function Flag241 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag241; + end Flag241; + + function Flag242 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag242; + end Flag242; + + function Flag243 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag243; + end Flag243; + + function Flag244 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag244; + end Flag244; + + function Flag245 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag245; + end Flag245; + + function Flag246 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag246; + end Flag246; + + function Flag247 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag247; + end Flag247; + procedure Set_Nkind (N : Node_Id; Val : Node_Kind) is begin pragma Assert (N <= Nodes.Last); @@ -7091,6 +7188,142 @@ package body Atree is (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag230 := Val; end Set_Flag230; + procedure Set_Flag231 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word5_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag231 := Val; + end Set_Flag231; + + procedure Set_Flag232 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word5_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag232 := Val; + end Set_Flag232; + + procedure Set_Flag233 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word5_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag233 := Val; + end Set_Flag233; + + procedure Set_Flag234 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word5_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag234 := Val; + end Set_Flag234; + + procedure Set_Flag235 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word5_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag235 := Val; + end Set_Flag235; + + procedure Set_Flag236 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word5_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag236 := Val; + end Set_Flag236; + + procedure Set_Flag237 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word5_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag237 := Val; + end Set_Flag237; + + procedure Set_Flag238 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word5_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag238 := Val; + end Set_Flag238; + + procedure Set_Flag239 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word5_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag239 := Val; + end Set_Flag239; + + procedure Set_Flag240 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word5_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag240 := Val; + end Set_Flag240; + + procedure Set_Flag241 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word5_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag241 := Val; + end Set_Flag241; + + procedure Set_Flag242 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word5_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag242 := Val; + end Set_Flag242; + + procedure Set_Flag243 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word5_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag243 := Val; + end Set_Flag243; + + procedure Set_Flag244 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word5_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag244 := Val; + end Set_Flag244; + + procedure Set_Flag245 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word5_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag245 := Val; + end Set_Flag245; + + procedure Set_Flag246 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word5_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag246 := Val; + end Set_Flag246; + + procedure Set_Flag247 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word5_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag247 := Val; + end Set_Flag247; + procedure Set_Node1_With_Parent (N : Node_Id; Val : Node_Id) is begin pragma Assert (N <= Nodes.Last); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 451fa0b..e8f5c11 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -1391,8 +1391,8 @@ package body Exp_Ch6 is begin loop Set_Analyzed (Pfx, False); - exit when Nkind (Pfx) /= N_Selected_Component - and then Nkind (Pfx) /= N_Indexed_Component; + exit when + not Nkind_In (Pfx, N_Selected_Component, N_Indexed_Component); Pfx := Prefix (Pfx); end loop; end Reset_Packed_Prefix; @@ -1633,8 +1633,8 @@ package body Exp_Ch6 is P : constant Node_Id := Parent (N); begin - pragma Assert (Nkind (P) = N_Triggering_Alternative - or else Nkind (P) = N_Entry_Call_Alternative); + pragma Assert (Nkind_In (P, N_Triggering_Alternative, + N_Entry_Call_Alternative)); if Is_Non_Empty_List (Statements (P)) then Insert_List_Before_And_Analyze @@ -2023,10 +2023,7 @@ package body Exp_Ch6 is -- form, and rewritten before analysis. if not Analyzed (Prev_Orig) - and then - (Nkind (Actual) = N_Function_Call - or else - Nkind (Actual) = N_Identifier) + and then Nkind_In (Actual, N_Function_Call, N_Identifier) then Prev_Orig := Prev; end if; @@ -2087,8 +2084,8 @@ package body Exp_Ch6 is -- as out parameter actuals on calls to stream procedures. Act_Prev := Prev; - while Nkind (Act_Prev) = N_Type_Conversion - or else Nkind (Act_Prev) = N_Unchecked_Type_Conversion + while Nkind_In (Act_Prev, N_Type_Conversion, + N_Unchecked_Type_Conversion) loop Act_Prev := Expression (Act_Prev); end loop; @@ -2318,9 +2315,7 @@ package body Exp_Ch6 is then null; - elsif Nkind (Prev) = N_Allocator - or else Nkind (Prev) = N_Attribute_Reference - then + elsif Nkind_In (Prev, N_Allocator, N_Attribute_Reference) then null; -- Suppress null checks when passing to access parameters of Java @@ -2361,9 +2356,8 @@ package body Exp_Ch6 is begin Nod := Actual; - while Nkind (Nod) = N_Indexed_Component - or else - Nkind (Nod) = N_Selected_Component + while Nkind_In (Nod, N_Indexed_Component, + N_Selected_Component) loop Set_Analyzed (Nod, False); Nod := Prefix (Nod); @@ -2419,11 +2413,14 @@ package body Exp_Ch6 is Sav : Node_Id; begin - -- For an OUT parameter that is an assignable entity, we do not - -- want to clobber the Last_Assignment field, since if it is - -- set, it was precisely because it is indeed an OUT parameter! - - if Ekind (Formal) = E_Out_Parameter + -- For an OUT or IN OUT parameter that is an assignable entity, + -- we do not want to clobber the Last_Assignment field, since + -- if it is set, it was precisely because it is indeed an OUT + -- or IN OUT parameter! + + if (Ekind (Formal) = E_Out_Parameter + or else + Ekind (Formal) = E_In_Out_Parameter) and then Is_Assignable (Ent) then Sav := Last_Assignment (Ent); @@ -2534,8 +2531,7 @@ package body Exp_Ch6 is -- Ada 2005 (AI-251): If some formal is a class-wide interface, expand -- it to point to the correct secondary virtual table - if (Nkind (N) = N_Function_Call - or else Nkind (N) = N_Procedure_Call_Statement) + if Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) and then CW_Interface_Formals_Present then Expand_Interface_Actuals (N); @@ -2549,8 +2545,7 @@ package body Exp_Ch6 is -- the VM back-ends directly handle the generation of dispatching -- calls and would have to undo any expansion to an indirect call. - if (Nkind (N) = N_Function_Call - or else Nkind (N) = N_Procedure_Call_Statement) + if Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) and then Present (Controlling_Argument (N)) and then VM_Target = No_VM then @@ -2899,7 +2894,7 @@ package body Exp_Ch6 is if (In_Extended_Main_Code_Unit (N) or else In_Extended_Main_Code_Unit (Parent (N)) - or else Is_Always_Inlined (Subp)) + or else Has_Pragma_Inline_Always (Subp)) and then (not In_Same_Extended_Unit (Sloc (Bod), Loc) or else Earlier_In_Extended_Unit (Sloc (Bod), Loc)) @@ -3036,10 +3031,6 @@ package body Exp_Ch6 is -- If no arguments, delete entire list, this is the easy case if No (Last_Keep_Arg) then - while Is_Non_Empty_List (Parameter_Associations (N)) loop - Delete_Tree (Remove_Head (Parameter_Associations (N))); - end loop; - Set_Parameter_Associations (N, No_List); Set_First_Named_Actual (N, Empty); @@ -3050,7 +3041,7 @@ package body Exp_Ch6 is elsif Is_List_Member (Last_Keep_Arg) then while Present (Next (Last_Keep_Arg)) loop - Delete_Tree (Remove_Next (Last_Keep_Arg)); + Discard_Node (Remove_Next (Last_Keep_Arg)); end loop; Set_First_Named_Actual (N, Empty); @@ -3114,7 +3105,6 @@ package body Exp_Ch6 is exit when No (Temp); Set_Next_Named_Actual (Passoc, Next_Named_Actual (Parent (Temp))); - Delete_Tree (Temp); end loop; end; end if; @@ -3359,9 +3349,7 @@ package body Exp_Ch6 is -- use a qualified expression, because an aggregate is not a -- legal argument of a conversion. - if Nkind (Expression (N)) = N_Aggregate - or else Nkind (Expression (N)) = N_Null - then + if Nkind_In (Expression (N), N_Aggregate, N_Null) then Ret := Make_Qualified_Expression (Sloc (N), Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)), @@ -3724,10 +3712,10 @@ package body Exp_Ch6 is and then Formal_Is_Used_Once (F)) or else - ((Nkind (A) = N_Real_Literal or else - Nkind (A) = N_Integer_Literal or else - Nkind (A) = N_Character_Literal) - and then not Address_Taken (F)) + (Nkind_In (A, N_Real_Literal, + N_Integer_Literal, + N_Character_Literal) + and then not Address_Taken (F)) then if Etype (F) /= Etype (A) then Set_Renamed_Object @@ -3944,190 +3932,8 @@ package body Exp_Ch6 is ---------------------------- procedure Expand_N_Function_Call (N : Node_Id) is - Typ : constant Entity_Id := Etype (N); - - function Returned_By_Reference return Boolean; - -- If the return type is returned through the secondary stack; that is - -- by reference, we don't want to create a temp to force stack checking. - -- ???"sec stack" is not right -- Ada 95 return-by-reference object are - -- returned wherever they are. - -- Shouldn't this function be moved to exp_util??? - - function Rhs_Of_Assign_Or_Decl (N : Node_Id) return Boolean; - -- If the call is the right side of an assignment or the expression in - -- an object declaration, we don't need to create a temp as the left - -- side will already trigger stack checking if necessary. - -- - -- If the call is a component in an extension aggregate, it will be - -- expanded into assignments as well, so no temporary is needed. This - -- also solves the problem of functions returning types with unknown - -- discriminants, where it is not possible to declare an object of the - -- type altogether. - - --------------------------- - -- Returned_By_Reference -- - --------------------------- - - function Returned_By_Reference return Boolean is - S : Entity_Id; - - begin - if Is_Inherently_Limited_Type (Typ) then - return True; - - elsif Nkind (Parent (N)) /= N_Simple_Return_Statement then - return False; - - elsif Requires_Transient_Scope (Typ) then - - -- Verify that the return type of the enclosing function has the - -- same constrained status as that of the expression. - - S := Current_Scope; - while Ekind (S) /= E_Function loop - S := Scope (S); - end loop; - - return Is_Constrained (Typ) = Is_Constrained (Etype (S)); - else - return False; - end if; - end Returned_By_Reference; - - --------------------------- - -- Rhs_Of_Assign_Or_Decl -- - --------------------------- - - function Rhs_Of_Assign_Or_Decl (N : Node_Id) return Boolean is - begin - if (Nkind (Parent (N)) = N_Assignment_Statement - and then Expression (Parent (N)) = N) - or else - (Nkind (Parent (N)) = N_Qualified_Expression - and then Nkind (Parent (Parent (N))) = N_Assignment_Statement - and then Expression (Parent (Parent (N))) = Parent (N)) - or else - (Nkind (Parent (N)) = N_Object_Declaration - and then Expression (Parent (N)) = N) - or else - (Nkind (Parent (N)) = N_Component_Association - and then Expression (Parent (N)) = N - and then Nkind (Parent (Parent (N))) = N_Aggregate - and then Rhs_Of_Assign_Or_Decl (Parent (Parent (N)))) - or else - (Nkind (Parent (N)) = N_Extension_Aggregate - and then Is_Private_Type (Etype (Typ))) - then - return True; - else - return False; - end if; - end Rhs_Of_Assign_Or_Decl; - - -- Start of processing for Expand_N_Function_Call - begin - -- A special check. If stack checking is enabled, and the return type - -- might generate a large temporary, and the call is not the right side - -- of an assignment, then generate an explicit temporary. We do this - -- because otherwise gigi may generate a large temporary on the fly and - -- this can cause trouble with stack checking. - - -- This is unnecessary if the call is the expression in an object - -- declaration, or if it appears outside of any library unit. This can - -- only happen if it appears as an actual in a library-level instance, - -- in which case a temporary will be generated for it once the instance - -- itself is installed. - - if May_Generate_Large_Temp (Typ) - and then not Rhs_Of_Assign_Or_Decl (N) - and then not Returned_By_Reference - and then Current_Scope /= Standard_Standard - then - if Stack_Checking_Enabled then - - -- Note: it might be thought that it would be OK to use a call to - -- Force_Evaluation here, but that's not good enough, because - -- that can results in a 'Reference construct that may still need - -- a temporary. - - declare - Loc : constant Source_Ptr := Sloc (N); - Temp_Obj : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('F')); - Temp_Typ : Entity_Id := Typ; - Decl : Node_Id; - A : Node_Id; - F : Entity_Id; - Proc : Entity_Id; - - begin - if Is_Tagged_Type (Typ) - and then Present (Controlling_Argument (N)) - then - if Nkind (Parent (N)) /= N_Procedure_Call_Statement - and then Nkind (Parent (N)) /= N_Function_Call - then - -- If this is a tag-indeterminate call, the object must - -- be classwide. - - if Is_Tag_Indeterminate (N) then - Temp_Typ := Class_Wide_Type (Typ); - end if; - - else - -- If this is a dispatching call that is itself the - -- controlling argument of an enclosing call, the - -- nominal subtype of the object that replaces it must - -- be classwide, so that dispatching will take place - -- properly. If it is not a controlling argument, the - -- object is not classwide. - - Proc := Entity (Name (Parent (N))); - - F := First_Formal (Proc); - A := First_Actual (Parent (N)); - while A /= N loop - Next_Formal (F); - Next_Actual (A); - end loop; - - if Is_Controlling_Formal (F) then - Temp_Typ := Class_Wide_Type (Typ); - end if; - end if; - end if; - - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Temp_Obj, - Object_Definition => New_Occurrence_Of (Temp_Typ, Loc), - Constant_Present => True, - Expression => Relocate_Node (N)); - Set_Assignment_OK (Decl); - - Insert_Actions (N, New_List (Decl)); - Rewrite (N, New_Occurrence_Of (Temp_Obj, Loc)); - end; - - else - -- If stack-checking is not enabled, increment serial number - -- for internal names, so that subsequent symbols are consistent - -- with and without stack-checking. - - Synchronize_Serial_Number; - - -- Now we can expand the call with consistent symbol names - - Expand_Call (N); - end if; - - -- Normal case, expand the call - - else - Expand_Call (N); - end if; + Expand_Call (N); end Expand_N_Function_Call; --------------------------------------- @@ -4881,8 +4687,8 @@ package body Exp_Ch6 is -- Step past qualification or unchecked conversion (the latter can occur -- in cases of calls to 'Input). - if Nkind (Exp_Node) = N_Qualified_Expression - or else Nkind (Exp_Node) = N_Unchecked_Type_Conversion + if Nkind_In + (Exp_Node, N_Qualified_Expression, N_Unchecked_Type_Conversion) then Exp_Node := Expression (N); end if; @@ -4908,8 +4714,8 @@ package body Exp_Ch6 is function Is_Build_In_Place_Function_Return (N : Node_Id) return Boolean is begin - if Nkind (N) = N_Simple_Return_Statement - or else Nkind (N) = N_Extended_Return_Statement + if Nkind_In (N, N_Simple_Return_Statement, + N_Extended_Return_Statement) then return Is_Build_In_Place_Function (Return_Applies_To (Return_Statement_Entity (N))); @@ -4962,10 +4768,11 @@ package body Exp_Ch6 is while Present (Iface_DT_Ptr) and then Ekind (Node (Iface_DT_Ptr)) = E_Constant loop + pragma Assert (Has_Thunks (Node (Iface_DT_Ptr))); Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); if Present (Thunk_Code) then - Insert_Actions (N, New_List ( + Insert_Actions_After (N, New_List ( Thunk_Code, Build_Set_Predefined_Prim_Op_Address (Loc, @@ -4974,10 +4781,22 @@ package body Exp_Ch6 is Address_Node => Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Thunk_Id, Loc), + Attribute_Name => Name_Address)), + + Build_Set_Predefined_Prim_Op_Address (Loc, + Tag_Node => New_Reference_To + (Node (Next_Elmt (Iface_DT_Ptr)), Loc), + Position => DT_Position (Prim), + Address_Node => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Prim, Loc), Attribute_Name => Name_Address)))); end if; Next_Elmt (Iface_DT_Ptr); + pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); + + Next_Elmt (Iface_DT_Ptr); end loop; end Register_Predefined_DT_Entry; @@ -4985,6 +4804,8 @@ package body Exp_Ch6 is Subp : constant Entity_Id := Entity (N); + -- Start of processing for Freeze_Subprogram + begin -- We suppress the initialization of the dispatch table entry when -- VM_Target because the dispatching mechanism is handled internally @@ -5088,8 +4909,9 @@ package body Exp_Ch6 is -- Step past qualification or unchecked conversion (the latter can occur -- in cases of calls to 'Input). - if Nkind (Func_Call) = N_Qualified_Expression - or else Nkind (Func_Call) = N_Unchecked_Type_Conversion + if Nkind_In (Func_Call, + N_Qualified_Expression, + N_Unchecked_Type_Conversion) then Func_Call := Expression (Func_Call); end if; @@ -5241,8 +5063,8 @@ package body Exp_Ch6 is -- Step past qualification or unchecked conversion (the latter can occur -- in cases of calls to 'Input). - if Nkind (Func_Call) = N_Qualified_Expression - or else Nkind (Func_Call) = N_Unchecked_Type_Conversion + if Nkind_In (Func_Call, N_Qualified_Expression, + N_Unchecked_Type_Conversion) then Func_Call := Expression (Func_Call); end if; @@ -5369,8 +5191,8 @@ package body Exp_Ch6 is -- Step past qualification or unchecked conversion (the latter can occur -- in cases of calls to 'Input). - if Nkind (Func_Call) = N_Qualified_Expression - or else Nkind (Func_Call) = N_Unchecked_Type_Conversion + if Nkind_In (Func_Call, N_Qualified_Expression, + N_Unchecked_Type_Conversion) then Func_Call := Expression (Func_Call); end if; @@ -5491,8 +5313,8 @@ package body Exp_Ch6 is -- Step past qualification or unchecked conversion (the latter can occur -- in cases of calls to 'Input). - if Nkind (Func_Call) = N_Qualified_Expression - or else Nkind (Func_Call) = N_Unchecked_Type_Conversion + if Nkind_In (Func_Call, N_Qualified_Expression, + N_Unchecked_Type_Conversion) then Func_Call := Expression (Func_Call); end if; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index dc181aa..f3b9ee2 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1327,7 +1327,7 @@ package body Exp_Util is function Find_Interface_ADT (T : Entity_Id; - Iface : Entity_Id) return Entity_Id + Iface : Entity_Id) return Elmt_Id is ADT : Elmt_Id; Found : Boolean := False; @@ -1385,6 +1385,7 @@ package body Exp_Util is end if; Next_Elmt (ADT); + Next_Elmt (ADT); Next_Elmt (AI_Elmt); end loop; end if; @@ -1423,7 +1424,7 @@ package body Exp_Util is pragma Assert (Present (Node (ADT))); Find_Secondary_Table (Typ); pragma Assert (Found); - return Node (ADT); + return ADT; end Find_Interface_ADT; ------------------------ @@ -2336,14 +2337,31 @@ package body Exp_Util is when N_And_Then | N_Or_Else => if N = Right_Opnd (P) then + + -- We are now going to either append the actions to the + -- actions field of the short-circuit operation. We will + -- also analyze the actions now. + + -- This analysis is really too early, the proper thing would + -- be to just park them there now, and only analyze them if + -- we find we really need them, and to it at the proper + -- final insertion point. However attempting to this proved + -- tricky, so for now we just kill current values before and + -- after the analyze call to make sure we avoid peculiar + -- optimizations from this out of order insertion. + + Kill_Current_Values; + if Present (Actions (P)) then Insert_List_After_And_Analyze - (Last (Actions (P)), Ins_Actions); + (Last (Actions (P)), Ins_Actions); else Set_Actions (P, Ins_Actions); Analyze_List (Actions (P)); end if; + Kill_Current_Values; + return; end if; @@ -2985,11 +3003,12 @@ package body Exp_Util is or else TSS_Name = TSS_Deep_Adjust or else TSS_Name = TSS_Deep_Finalize or else (Ada_Version >= Ada_05 - and then (Chars (E) = Name_uDisp_Asynchronous_Select - or else Chars (E) = Name_uDisp_Conditional_Select - or else Chars (E) = Name_uDisp_Get_Prim_Op_Kind - or else Chars (E) = Name_uDisp_Get_Task_Id - or else Chars (E) = Name_uDisp_Timed_Select)) + and then (Chars (E) = Name_uDisp_Asynchronous_Select + or else Chars (E) = Name_uDisp_Conditional_Select + or else Chars (E) = Name_uDisp_Get_Prim_Op_Kind + or else Chars (E) = Name_uDisp_Get_Task_Id + or else Chars (E) = Name_uDisp_Requeue + or else Chars (E) = Name_uDisp_Timed_Select)) then return True; end if; @@ -3459,8 +3478,6 @@ package body Exp_Util is elsif Nkind (N) in N_Generic_Instantiation then Remove_Dead_Instance (N); end if; - - Delete_Tree (N); end if; end Kill_Dead_Code; @@ -3472,11 +3489,11 @@ package body Exp_Util is begin W := Warn; if Is_Non_Empty_List (L) then - loop - N := Remove_Head (L); - exit when No (N); + N := First (L); + while Present (N) loop Kill_Dead_Code (N, W); W := False; + Next (N); end loop; end if; end Kill_Dead_Code; diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 5ca346d..42c8d2a 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -338,9 +338,10 @@ package Exp_Util is function Find_Interface_ADT (T : Entity_Id; - Iface : Entity_Id) return Entity_Id; + Iface : Entity_Id) return Elmt_Id; -- Ada 2005 (AI-251): Given a type T implementing the interface Iface, - -- return the Access_Disp_Table value of the interface. + -- return the element of Access_Disp_Table containing the tag of the + -- interface. function Find_Interface_Tag (T : Entity_Id; @@ -483,16 +484,16 @@ package Exp_Util is -- or is a private type whose completion is such a type. procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False); - -- N represents a node for a section of code that is known to be dead. The - -- node is deleted, and any exception handler references and warning - -- messages relating to this code are removed. If Warn is True, a warning - -- will be output at the start of N indicating the deletion of the code. + -- N represents a node for a section of code that is known to be dead. Any + -- exception handler references and warning messages relating to this code + -- are removed. If Warn is True, a warning will be output at the start of N + -- indicating the deletion of the code. Note that the tree for the deleted + -- code is left intact so that e.g. cross-reference data is still valid. procedure Kill_Dead_Code (L : List_Id; Warn : Boolean := False); -- Like the above procedure, but applies to every element in the given - -- list. Each of the entries is removed from the list before killing it. - -- If Warn is True, a warning will be output at the start of N indicating - -- the deletion of the code. + -- list. If Warn is True, a warning will be output at the start of N + -- indicating the deletion of the code. function Known_Non_Negative (Opnd : Node_Id) return Boolean; -- Given a node for a subexpression, determines if it represents a value diff --git a/gcc/ada/nlists.adb b/gcc/ada/nlists.adb index 0745f38..b75226e 100644 --- a/gcc/ada/nlists.adb +++ b/gcc/ada/nlists.adb @@ -279,22 +279,6 @@ package body Nlists is Append (Node, To); end Append_To; - ----------------- - -- Delete_List -- - ----------------- - - procedure Delete_List (L : List_Id) is - N : Node_Id; - - begin - while Is_Non_Empty_List (L) loop - N := Remove_Head (L); - Delete_Tree (N); - end loop; - - -- Should recycle list header??? - end Delete_List; - ----------- -- First -- ----------- @@ -315,7 +299,6 @@ package body Nlists is function First_Non_Pragma (List : List_Id) return Node_Id is N : constant Node_Id := First (List); - begin if Nkind (N) /= N_Pragma and then @@ -649,7 +632,6 @@ package body Nlists is function Last_Non_Pragma (List : List_Id) return Node_Id is N : constant Node_Id := Last (List); - begin if Nkind (N) /= N_Pragma then return N; diff --git a/gcc/ada/nlists.ads b/gcc/ada/nlists.ads index fe9c941..77ae55a 100644 --- a/gcc/ada/nlists.ads +++ b/gcc/ada/nlists.ads @@ -333,9 +333,6 @@ package Nlists is -- These functions return the addresses of the Next_Node and Prev_Node -- tables (used in Back_End for Gigi). - procedure Delete_List (L : List_Id); - -- Removes all elements of the given list, and calls Delete_Tree on each - function p (U : Union_Id) return Node_Id; -- This function is intended for use from the debugger, it determines -- whether U is a Node_Id or List_Id, and calls the appropriate Parent diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index ee63c42..0db6d20 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -463,8 +463,6 @@ package body Ch4 is Style.Check_Attribute_Name (False); end if; - Delete_Node (Token_Node); - -- Here for case of attribute designator is not an identifier else diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index e7076b3..11f24ce 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -592,9 +592,9 @@ package body Sem_Ch7 is -- the flag for outer level entities that are not -- imported/exported, and which have no interface name. - elsif K = N_Object_Declaration - or else K = N_Exception_Declaration - or else K = N_Subprogram_Declaration + elsif Nkind_In (K, N_Object_Declaration, + N_Exception_Declaration, + N_Subprogram_Declaration) then E := Defining_Entity (D); @@ -844,8 +844,8 @@ package body Sem_Ch7 is then Generate_Reference (Id, Scope (Id), 'k', False); - elsif Nkind (Unit (Cunit (Main_Unit))) /= N_Subprogram_Body - and then Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit + elsif not Nkind_In (Unit (Cunit (Main_Unit)), N_Subprogram_Body, + N_Subunit) then -- If current unit is an ancestor of main unit, generate -- a reference to its own parent. @@ -909,16 +909,16 @@ package body Sem_Ch7 is -- with a known_discriminant_part whose full view is an -- Unchecked_Union. - if (Nkind (Decl) = N_Incomplete_Type_Declaration - or else - Nkind (Decl) = N_Private_Type_Declaration) + if Nkind_In (Decl, N_Incomplete_Type_Declaration, + N_Private_Type_Declaration) and then Has_Discriminants (Defining_Identifier (Decl)) and then Present (Full_View (Defining_Identifier (Decl))) - and then Is_Unchecked_Union - (Full_View (Defining_Identifier (Decl))) + and then + Is_Unchecked_Union (Full_View (Defining_Identifier (Decl))) then - Error_Msg_N ("completion of discriminated partial view" & - " cannot be an Unchecked_Union", + Error_Msg_N + ("completion of discriminated partial view " + & "cannot be an Unchecked_Union", Full_View (Defining_Identifier (Decl))); end if; @@ -942,8 +942,8 @@ package body Sem_Ch7 is while Present (Gen_Par) and then Is_Child_Unit (Gen_Par) loop Inst_Node := Get_Package_Instantiation_Node (Inst_Par); - if (Nkind (Inst_Node) = N_Package_Instantiation - or else Nkind (Inst_Node) = N_Formal_Package_Declaration) + if Nkind_In (Inst_Node, N_Package_Instantiation, + N_Formal_Package_Declaration) and then Nkind (Name (Inst_Node)) = N_Expanded_Name then Inst_Par := Entity (Prefix (Name (Inst_Node))); diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index b7bf39e..2baa94b 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -2192,6 +2192,14 @@ package body Sinfo is return List2 (N); end Pragma_Argument_Associations; + function Pragma_Identifier + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + return Node4 (N); + end Pragma_Identifier; + function Pragmas_After (N : Node_Id) return List_Id is begin @@ -4915,6 +4923,14 @@ package body Sinfo is Set_List2_With_Parent (N, Val); end Set_Pragma_Argument_Associations; + procedure Set_Pragma_Identifier + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + Set_Node4_With_Parent (N, Val); + end Set_Pragma_Identifier; + procedure Set_Pragmas_After (N : Node_Id; Val : List_Id) is begin @@ -5558,4 +5574,120 @@ package body Sinfo is UI_From_Int (Int (S) - Int (Sloc (N)))); end Set_End_Location; + -------------------------------- + -- Node_Kind Membership Tests -- + -------------------------------- + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind) return Boolean + is + begin + return T = V1 or else + T = V2; + end Nkind_In; + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3; + end Nkind_In; + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3 or else + T = V4; + end Nkind_In; + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3 or else + T = V4 or else + T = V5; + end Nkind_In; + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind; + V6 : Node_Kind) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3 or else + T = V4 or else + T = V5 or else + T = V6; + end Nkind_In; + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind; + V6 : Node_Kind; + V7 : Node_Kind) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3 or else + T = V4 or else + T = V5 or else + T = V6 or else + T = V7; + end Nkind_In; + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind; + V6 : Node_Kind; + V7 : Node_Kind; + V8 : Node_Kind) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3 or else + T = V4 or else + T = V5 or else + T = V6 or else + T = V7 or else + T = V8; + end Nkind_In; + end Sinfo; diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 61a1400..d1f2017 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -549,9 +549,11 @@ package Sinfo is -- Acts_As_Spec (Flag4-Sem) -- A flag set in the N_Subprogram_Body node for a subprogram body which - -- is acting as its own spec. This flag also appears in the compilation - -- unit node at the library level for such a subprogram (see further - -- description in spec of Lib package). + -- is acting as its own spec, except in the case of a library level + -- subprogram, in which case the flag is set on the parent compilation + -- unit node instead (see further description in spec of Lib package). + -- ??? Above note about Lib is dubious since lib.ads does not mention + -- Acts_As_Spec at all. -- Actual_Designated_Subtype (Node4-Sem) -- Present in N_Free_Statement and N_Explicit_Dereference nodes. If gigi @@ -907,27 +909,36 @@ package Sinfo is -- processing of the variant part of a record type. -- Entity (Node4-Sem) - -- Appears in all direct names (identifier, character literal, operator - -- symbol), as well as expanded names, and attributes that denote - -- entities, such as 'Class. Points to the entity for the corresponding - -- defining occurrence. Set after name resolution. In the case of - -- identifiers in a WITH list, the corresponding defining occurrence is - -- in a separately compiled file, and this pointer must be set using the - -- library Load procedure. Note that during name resolution, the value in - -- Entity may be temporarily incorrect (e.g. during overload resolution, - -- Entity is initially set to the first possible correct interpretation, - -- and then later modified if necessary to contain the correct value - -- after resolution). Note that this field overlaps Associated_Node, - -- which is used during generic processing (see Sem_Ch12 for details). - -- Note also that in generic templates, this means that the Entity field - -- does not always point to an Entity. Since the back end is expected to - -- ignore generic templates, this is harmless. Note that this field also - -- appears in N_Attribute_Definition_Clause nodes. It is used only for - -- stream attributes definition clauses. In this case, it denotes a - -- (possibly dummy) subprogram entity that is conceptually declared at - -- the point of the clause. Thus the visibility of the attribute - -- definition clause (in the sense of 8.3(23) as amended by AI-195) can - -- be checked by testing the visibility of that subprogram. + -- Appears in all direct names (identifiers, character literals, and + -- operator symbols), as well as expanded names, and attributes that + -- denote entities, such as 'Class. Points to entity for corresponding + -- defining occurrence. Set after name resolution. For identifiers in a + -- WITH list, the corresponding defining occurrence is in a separately + -- compiled file, and Entity must be set by the library Load procedure. + -- + -- Note: During name resolution, the value in Entity may be temporarily + -- incorrect (e.g. during overload resolution, Entity is initially set to + -- the first possible correct interpretation, and then later modified if + -- necessary to contain the correct value after resolution). + -- + -- Note: This field overlaps Associated_Node, which is used during + -- generic processing (see Sem_Ch12 for details). Note also that in + -- generic templates, this means that the Entity field does not always + -- point to an Entity. Since the back end is expected to ignore generic + -- templates, this is harmless. + -- + -- Note: This field also appears in N_Attribute_Definition_Clause nodes. + -- It is used only for stream attributes definition clauses. In this + -- case, it denotes a (possibly dummy) subprogram entity that is declared + -- conceptually at the point of the clause. Thus the visibility of the + -- attribute definition clause (in the sense of 8.3(23) as amended by + -- AI-195) can be checked by testing the visibility of that subprogram. + -- + -- Note: Normally the Entity field of an identifier points to the entity + -- for the corresponding defining identifier, and hence the Chars field + -- of an identifier will match the Chars field of the entity. However, + -- there is no requirement that these match, and there are obscure cases + -- of generated code where they do not match. -- Entity_Or_Associated_Node (Node4-Sem) -- A synonym for both Entity and Associated_Node. Used by convention in @@ -1070,7 +1081,7 @@ package Sinfo is -- in the non-generic package case if it determines that no elaboration -- code is generated. Note that this flag is not related to the -- Is_Preelaborated status, there can be preelaborated packages that - -- generate elaboration code, and non- preelaborated packages which do + -- generate elaboration code, and non-preelaborated packages which do -- not generate elaboration code. -- Has_Priority_Pragma (Flag6-Sem) @@ -1864,10 +1875,11 @@ package Sinfo is -- which are explicitly documented. -- N_Pragma - -- Sloc points to PRAGMA + -- Sloc points to pragma identifier -- Chars (Name1) identifier name from pragma identifier -- Pragma_Argument_Associations (List2) (set to No_List if none) -- Debug_Statement (Node3) (set to Empty if not Debug, Assert) + -- Pragma_Identifier (Node4) -- Next_Rep_Item (Node5-Sem) -- Note: we should have a section on what pragmas are passed on to @@ -1875,6 +1887,13 @@ package Sinfo is -- Psect_Object is always converted to Common_Object, but there are -- undoubtedly many other similar notes required ??? + -- Note: we don't really need the Chars field, since it can trivially + -- be obtained as Chars (Pragma_Identifier (Node)). However, it is + -- convenient to have this directly available, and historically the + -- Chars field has been around for ever, whereas the Pragma_Identifier + -- field was added much later (when we found the need to be able to get + -- the Sloc of the pragma identifier). + -------------------------------------- -- 2.8 Pragma Argument Association -- -------------------------------------- @@ -3232,9 +3251,9 @@ package Sinfo is -- component_SELECTOR_NAME {| component_SELECTOR_NAME} -- | others - -- The entries of a component choice list appear in the Choices list - -- of the associated N_Component_Association, as either selector - -- names, or as an N_Others_Choice node. + -- The entries of a component choice list appear in the Choices list of + -- the associated N_Component_Association, as either selector names, or + -- as an N_Others_Choice node. -------------------------------- -- 4.3.2 Extension Aggregate -- @@ -7385,7 +7404,7 @@ package Sinfo is subtype N_Unit_Body is Node_Kind range N_Package_Body .. - N_Subprogram_Body; + N_Subprogram_Body; --------------------------- -- Node Access Functions -- @@ -8071,6 +8090,9 @@ package Sinfo is function Pragma_Argument_Associations (N : Node_Id) return List_Id; -- List2 + function Pragma_Identifier + (N : Node_Id) return Node_Id; -- Node4 + function Pragmas_After (N : Node_Id) return List_Id; -- List5 @@ -8935,6 +8957,9 @@ package Sinfo is procedure Set_Pragma_Argument_Associations (N : Node_Id; Val : List_Id); -- List2 + procedure Set_Pragma_Identifier + (N : Node_Id; Val : Node_Id); -- Node4 + procedure Set_Pragmas_After (N : Node_Id; Val : List_Id); -- List5 @@ -9144,6 +9169,75 @@ package Sinfo is -- other words, End_Span is set to the difference between S and -- Sloc (N), the starting location. + -------------------------------- + -- Node_Kind Membership Tests -- + -------------------------------- + + -- The following functions allow a convenient notation for testing wheter + -- a Node_Kind value matches any one of a list of possible values. In each + -- case True is returned if the given T argument is equal to any of the V + -- arguments. Note that there is a similar set of functions defined in + -- Atree where the first argument is a Node_Id whose Nkind field is tested. + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind) return Boolean; + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind) return Boolean; + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind) return Boolean; + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind) return Boolean; + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind; + V6 : Node_Kind) return Boolean; + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind; + V6 : Node_Kind; + V7 : Node_Kind) return Boolean; + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind; + V6 : Node_Kind; + V7 : Node_Kind; + V8 : Node_Kind) return Boolean; + + pragma Inline (Nkind_In); + -- Inline all above functions + ----------------------------- -- Syntactic Parent Tables -- ----------------------------- @@ -9198,7 +9292,7 @@ package Sinfo is (1 => True, -- Chars (Name1) 2 => True, -- Pragma_Argument_Associations (List2) 3 => True, -- Debug_Statement (Node3) - 4 => False, -- Entity (Node4-Sem) + 4 => True, -- Pragma_Identifier (Node4) 5 => False), -- Next_Rep_Item (Node5-Sem) N_Pragma_Argument_Association => @@ -10912,6 +11006,7 @@ package Sinfo is pragma Inline (Parent_Spec); pragma Inline (Position); pragma Inline (Pragma_Argument_Associations); + pragma Inline (Pragma_Identifier); pragma Inline (Pragmas_After); pragma Inline (Pragmas_Before); pragma Inline (Prefix); @@ -11196,6 +11291,7 @@ package Sinfo is pragma Inline (Set_Parent_Spec); pragma Inline (Set_Position); pragma Inline (Set_Pragma_Argument_Associations); + pragma Inline (Set_Pragma_Identifier); pragma Inline (Set_Pragmas_After); pragma Inline (Set_Pragmas_Before); pragma Inline (Set_Prefix); |