diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/ChangeLog | 60 | ||||
| -rw-r--r-- | gcc/ada/a-tags.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/checks.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/exp_aggr.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_attr.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 31 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 128 | ||||
| -rw-r--r-- | gcc/ada/gnatcmd.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/s-ststop.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 1797 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 104 | ||||
| -rw-r--r-- | gcc/ada/switch-c.adb | 14 | ||||
| -rw-r--r-- | gcc/ada/usage.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/warnsw.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/warnsw.ads | 7 |
19 files changed, 1489 insertions, 737 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 067d275..8467214 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,63 @@ +2017-09-08 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_aggr.adb (Expand_Array_Aggregate): Use New_Copy_Tree instead + of New_Copy because the latter leaves the syntactic structure of + the tree inconsistent (a child is accessible through two parents) + and prevents proper replication of itypes by subsequent calls + to New_Copy_Tree. + * exp_ch4.adb (Expand_Concatenate): Use New_Copy_Tree instead of + New_Copy because the latter leaves the syntactic structure of the + tree inconsistent (a child is accessible through two parents) + and prevents proper replication of itypes by subsequent calls + to New_Copy_Tree. + * sem_util.adb (In_Subtree): New routine. + (New_Copy_Tree): Reimplemented. + * sem_util.ads (In_Subtree): New routine. + (New_Copy_Tree): Reimplemented. + +2017-09-08 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Resolve_Aspect_Expressions): The expression + for aspect Default_Value is a static scalar value, but it does + not freeze the type. Yhis allows for subsequent representation + clauses for the type. + +2017-09-08 Javier Miranda <miranda@adacore.com> + + * sem_ch8.adb (Find_Direct_Name.Undefined): Do + not add entries into the undefined reference table when we are + compiling with errors ignored. + +2017-09-08 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Check_Formal_Packages): Do not apply conformance + check if the instance is within an enclosing instance body. The + formal package was legal in the enclosing generic, and is + legal in the enclosing instantiation. This optimisation may be + applicable elsewhere, and it also removes spurious errors that + may arise with on-the-fly processing of instantiations that + contain Inline_Always subprograms. + +2017-09-08 Vincent Celier <celier@adacore.com> + + * gnatcmd.adb: Disregard empty argument of GNAT driver. + +2017-09-08 Justin Squirek <squirek@adacore.com> + + * checks.adb (Insert_Valid_Check): Manually decorate + the generated temporary for range valdity checks. + +2017-09-08 Eric Botcazou <ebotcazou@adacore.com> + + * usage.adb (Usage): Document new -gnatw.q/-gnatw.Q switches. + +2017-09-08 Justin Squirek <squirek@adacore.com> + + * switch-c.adb (Scan_Front_End_Switches): Add new warning switch + case to handle underscore flags. + * warnsw.adb, warnsw.ads (Set_Underscore_Warning_Switch): Create + new procedure to handle underscores. + 2017-09-08 Javier Miranda <miranda@adacore.com> * exp_ch4.adb (Expand_N_Op_Divide): Reordering code that handles diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb index 72ec05d..322f991 100644 --- a/gcc/ada/a-tags.adb +++ b/gcc/ada/a-tags.adb @@ -647,11 +647,13 @@ package body Ada.Tags is Res : Tag := null; begin - -- Raise Tag_Error for empty strings, and for absurdly long strings. - -- This is to make T'Class'Input robust in the case of bad data, for - -- example a String(123456789..1234). The limit of 10,000 characters is - -- arbitrary, but is unlikely to be exceeded by legitimate external tag - -- names. + -- Raise Tag_Error for empty strings and very long strings. This makes + -- T'Class'Input robust in the case of bad data, for example + -- + -- String (123456789..1234) + -- + -- The limit of 10,000 characters is arbitrary, but is unlikely to be + -- exceeded by legitimate external tag names. if External'Length not in 1 .. 10_000 then raise Tag_Error; diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 8dd7a39..8a542ad 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -7393,6 +7393,13 @@ package body Checks is if Is_Variable (Exp) then Var_Id := Make_Temporary (Loc, 'T', Exp); + -- Because we could be dealing with a transient scope which would + -- cause our object declaration to remain unanalyzed we must do + -- some manual decoration. + + Set_Ekind (Var_Id, E_Variable); + Set_Etype (Var_Id, Typ); + Insert_Action (Exp, Make_Object_Declaration (Loc, Defining_Identifier => Var_Id, diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 3610ed6..61c6240 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -6275,7 +6275,7 @@ package body Exp_Aggr is New_List ( Make_Assignment_Statement (Loc, Name => Target, - Expression => New_Copy (N))); + Expression => New_Copy_Tree (N))); else Aggr_Code := diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 96b7022..9afb23b 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -3868,14 +3868,16 @@ package body Exp_Attr is New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc), Parameter_Associations => New_List ( Make_Function_Call (Loc, - Name => + Name => New_Occurrence_Of (RTE (RE_String_Input_Tag), Loc), Parameter_Associations => New_List ( Relocate_Node (Duplicate_Subexpr (Strm)))), + Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (P_Type, Loc), Attribute_Name => Name_Tag))); + Set_Etype (Expr, RTE (RE_Tag)); -- Now we need to get the entity for the call, and construct diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 236b300..61d00aa 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -3194,7 +3194,7 @@ package body Exp_Ch4 is Object_Definition => New_Occurrence_Of (Artyp, Loc), Expression => Make_Op_Add (Loc, - Left_Opnd => New_Copy (Aggr_Length (NN - 1)), + Left_Opnd => New_Copy_Tree (Aggr_Length (NN - 1)), Right_Opnd => Clen))); Aggr_Length (NN) := Make_Identifier (Loc, Chars => Chars (Ent)); @@ -3275,7 +3275,7 @@ package body Exp_Ch4 is function Get_Known_Bound (J : Nat) return Node_Id is begin if Is_Fixed_Length (J) or else J = NN then - return New_Copy (Opnd_Low_Bound (J)); + return New_Copy_Tree (Opnd_Low_Bound (J)); else return @@ -3288,7 +3288,7 @@ package body Exp_Ch4 is Right_Opnd => Make_Integer_Literal (Loc, 0)), - New_Copy (Opnd_Low_Bound (J)), + New_Copy_Tree (Opnd_Low_Bound (J)), Get_Known_Bound (J + 1))); end if; end Get_Known_Bound; @@ -3313,10 +3313,10 @@ package body Exp_Ch4 is High_Bound := To_Ityp (Make_Op_Add (Loc, - Left_Opnd => To_Artyp (New_Copy (Low_Bound)), + Left_Opnd => To_Artyp (New_Copy_Tree (Low_Bound)), Right_Opnd => Make_Op_Subtract (Loc, - Left_Opnd => New_Copy (Aggr_Length (NN)), + Left_Opnd => New_Copy_Tree (Aggr_Length (NN)), Right_Opnd => Make_Artyp_Literal (1)))); -- Note that calculation of the high bound may cause overflow in some @@ -3341,7 +3341,7 @@ package body Exp_Ch4 is Make_If_Expression (Loc, Expressions => New_List ( Make_Op_Eq (Loc, - Left_Opnd => New_Copy (Aggr_Length (NN)), + Left_Opnd => New_Copy_Tree (Aggr_Length (NN)), Right_Opnd => Make_Artyp_Literal (0)), Last_Opnd_Low_Bound, Low_Bound)); @@ -3350,7 +3350,7 @@ package body Exp_Ch4 is Make_If_Expression (Loc, Expressions => New_List ( Make_Op_Eq (Loc, - Left_Opnd => New_Copy (Aggr_Length (NN)), + Left_Opnd => New_Copy_Tree (Aggr_Length (NN)), Right_Opnd => Make_Artyp_Literal (0)), Last_Opnd_High_Bound, High_Bound)); @@ -3488,12 +3488,12 @@ package body Exp_Ch4 is declare Lo : constant Node_Id := Make_Op_Add (Loc, - Left_Opnd => To_Artyp (New_Copy (Low_Bound)), + Left_Opnd => To_Artyp (New_Copy_Tree (Low_Bound)), Right_Opnd => Aggr_Length (J - 1)); Hi : constant Node_Id := Make_Op_Add (Loc, - Left_Opnd => To_Artyp (New_Copy (Low_Bound)), + Left_Opnd => To_Artyp (New_Copy_Tree (Low_Bound)), Right_Opnd => Make_Op_Subtract (Loc, Left_Opnd => Aggr_Length (J), @@ -7015,7 +7015,7 @@ package body Exp_Ch4 is if Debug_Flag_Dot_H then declare - Cnod : constant Node_Id := Relocate_Node (Cnode); + Cnod : constant Node_Id := New_Copy_Tree (Cnode); Typ : constant Entity_Id := Base_Type (Etype (Cnode)); begin @@ -11232,9 +11232,9 @@ package body Exp_Ch4 is -- Apply an accessibility check when the conversion operand is an -- access parameter (or a renaming thereof), unless conversion was -- expanded from an Unchecked_ or Unrestricted_Access attribute, - -- or for the actual of a class-wide interface parameter. - -- Note that other checks may still need to be applied below (such - -- as tagged type checks). + -- or for the actual of a class-wide interface parameter. Note that + -- other checks may still need to be applied below (such as tagged + -- type checks). elsif Is_Entity_Name (Operand) and then Has_Extra_Accessibility (Entity (Operand)) @@ -11243,9 +11243,8 @@ package body Exp_Ch4 is or else Attribute_Name (Original_Node (N)) = Name_Access) then if not Comes_From_Source (N) - and then Nkind_In (Parent (N), - N_Function_Call, - N_Procedure_Call_Statement) + and then Nkind_In (Parent (N), N_Function_Call, + N_Procedure_Call_Statement) and then Is_Interface (Designated_Type (Target_Type)) and then Is_Class_Wide_Type (Designated_Type (Target_Type)) then diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 3df6410..c2edde6 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2857,7 +2857,8 @@ package body Exp_Ch6 is Thunk_Formal := Extra_Formals (Current_Scope); while Present (Target_Formal) loop Add_Extra_Actual - (New_Occurrence_Of (Thunk_Formal, Loc), Thunk_Formal); + (Expr => New_Occurrence_Of (Thunk_Formal, Loc), + EF => Thunk_Formal); Target_Formal := Extra_Formal (Target_Formal); Thunk_Formal := Extra_Formal (Thunk_Formal); @@ -2922,15 +2923,15 @@ package body Exp_Ch6 is and then not Has_Discriminants (Base_Type (Etype (Prev))) then Add_Extra_Actual - (New_Occurrence_Of (Standard_False, Loc), - Extra_Constrained (Formal)); + (Expr => New_Occurrence_Of (Standard_False, Loc), + EF => Extra_Constrained (Formal)); elsif Is_Constrained (Etype (Formal)) or else not Has_Discriminants (Etype (Prev)) then Add_Extra_Actual - (New_Occurrence_Of (Standard_True, Loc), - Extra_Constrained (Formal)); + (Expr => New_Occurrence_Of (Standard_True, Loc), + EF => Extra_Constrained (Formal)); -- Do not produce extra actuals for Unchecked_Union parameters. -- Jump directly to the end of the loop. @@ -2967,17 +2968,18 @@ package body Exp_Ch6 is and then Nkind (Act_Prev) = N_Explicit_Dereference then Add_Extra_Actual - (New_Occurrence_Of (Standard_False, Loc), - Extra_Constrained (Formal)); + (Expr => New_Occurrence_Of (Standard_False, Loc), + EF => Extra_Constrained (Formal)); else Add_Extra_Actual - (Make_Attribute_Reference (Sloc (Prev), - Prefix => - Duplicate_Subexpr_No_Checks - (Act_Prev, Name_Req => True), - Attribute_Name => Name_Constrained), - Extra_Constrained (Formal)); + (Expr => + Make_Attribute_Reference (Sloc (Prev), + Prefix => + Duplicate_Subexpr_No_Checks + (Act_Prev, Name_Req => True), + Attribute_Name => Name_Constrained), + EF => Extra_Constrained (Formal)); end if; end; end if; @@ -3046,8 +3048,9 @@ package body Exp_Ch6 is end if; Add_Extra_Actual - (New_Occurrence_Of (Extra_Accessibility (Parm_Ent), Loc), - Extra_Accessibility (Formal)); + (Expr => + New_Occurrence_Of (Extra_Accessibility (Parm_Ent), Loc), + EF => Extra_Accessibility (Formal)); end; elsif Is_Entity_Name (Prev_Orig) then @@ -3078,9 +3081,10 @@ package body Exp_Ch6 is if Present (Extra_Accessibility (Parm_Ent)) then Add_Extra_Actual - (New_Occurrence_Of - (Extra_Accessibility (Parm_Ent), Loc), - Extra_Accessibility (Formal)); + (Expr => + New_Occurrence_Of + (Extra_Accessibility (Parm_Ent), Loc), + EF => Extra_Accessibility (Formal)); -- If the actual access parameter does not have an -- associated extra formal providing its scope level, @@ -3089,9 +3093,10 @@ package body Exp_Ch6 is else Add_Extra_Actual - (Make_Integer_Literal (Loc, - Intval => Scope_Depth (Standard_Standard)), - Extra_Accessibility (Formal)); + (Expr => + Make_Integer_Literal (Loc, + Intval => Scope_Depth (Standard_Standard)), + EF => Extra_Accessibility (Formal)); end if; end; @@ -3100,8 +3105,8 @@ package body Exp_Ch6 is else Add_Extra_Actual - (Dynamic_Accessibility_Level (Prev_Orig), - Extra_Accessibility (Formal)); + (Expr => Dynamic_Accessibility_Level (Prev_Orig), + EF => Extra_Accessibility (Formal)); end if; -- If the actual is an access discriminant, then pass the level @@ -3114,9 +3119,10 @@ package body Exp_Ch6 is E_Anonymous_Access_Type then Add_Extra_Actual - (Make_Integer_Literal (Loc, - Intval => Object_Access_Level (Prefix (Prev_Orig))), - Extra_Accessibility (Formal)); + (Expr => + Make_Integer_Literal (Loc, + Intval => Object_Access_Level (Prefix (Prev_Orig))), + EF => Extra_Accessibility (Formal)); -- All other cases @@ -3129,19 +3135,18 @@ package body Exp_Ch6 is when Attribute_Access => - -- Accessibility level of S'Access is that of A. + -- Accessibility level of S'Access is that of A Prev_Orig := Prefix (Prev_Orig); - -- If the expression is a view conversion, - -- the accessibility level is that of the - -- expression. + -- If the expression is a view conversion, the + -- accessibility level is that of the expression. - if Nkind (Original_Node (Prev_Orig)) - = N_Type_Conversion + if Nkind (Original_Node (Prev_Orig)) = + N_Type_Conversion and then - Nkind (Expression (Original_Node (Prev_Orig))) - = N_Explicit_Dereference + Nkind (Expression (Original_Node (Prev_Orig))) = + N_Explicit_Dereference then Prev_Orig := Expression (Original_Node (Prev_Orig)); @@ -3171,8 +3176,7 @@ package body Exp_Ch6 is Pref_Entity := Entity (Prev_Orig); elsif Nkind (Prev_Orig) = N_Explicit_Dereference - and then - Is_Entity_Name (Prefix (Prev_Orig)) + and then Is_Entity_Name (Prefix (Prev_Orig)) then Pref_Entity := Entity (Prefix ((Prev_Orig))); @@ -3184,28 +3188,31 @@ package body Exp_Ch6 is and then Is_Type (Entity (Prev_Orig)) then Add_Extra_Actual - (Make_Integer_Literal (Loc, - Intval => Type_Access_Level (Pref_Entity)), - Extra_Accessibility (Formal)); + (Expr => + Make_Integer_Literal (Loc, + Intval => + Type_Access_Level (Pref_Entity)), + EF => Extra_Accessibility (Formal)); elsif Nkind (Prev_Orig) = N_Explicit_Dereference and then Present (Pref_Entity) and then Is_Formal (Pref_Entity) and then Present - (Extra_Accessibility (Pref_Entity)) + (Extra_Accessibility (Pref_Entity)) then - Add_Extra_Actual ( - New_Occurrence_Of - (Extra_Accessibility (Pref_Entity), Loc), - Extra_Accessibility (Formal)); + Add_Extra_Actual + (Expr => + New_Occurrence_Of + (Extra_Accessibility (Pref_Entity), Loc), + EF => Extra_Accessibility (Formal)); else Add_Extra_Actual - (Make_Integer_Literal (Loc, - Intval => - Object_Access_Level - (Prev_Orig)), - Extra_Accessibility (Formal)); + (Expr => + Make_Integer_Literal (Loc, + Intval => + Object_Access_Level (Prev_Orig)), + EF => Extra_Accessibility (Formal)); end if; -- Treat the unchecked attributes as library-level @@ -3214,9 +3221,10 @@ package body Exp_Ch6 is | Attribute_Unrestricted_Access => Add_Extra_Actual - (Make_Integer_Literal (Loc, - Intval => Scope_Depth (Standard_Standard)), - Extra_Accessibility (Formal)); + (Expr => + Make_Integer_Literal (Loc, + Intval => Scope_Depth (Standard_Standard)), + EF => Extra_Accessibility (Formal)); -- No other cases of attributes returning access -- values that can be passed to access parameters. @@ -3232,9 +3240,10 @@ package body Exp_Ch6 is when N_Allocator => Add_Extra_Actual - (Make_Integer_Literal (Loc, - Intval => Scope_Depth (Current_Scope) + 1), - Extra_Accessibility (Formal)); + (Expr => + Make_Integer_Literal (Loc, + Intval => Scope_Depth (Current_Scope) + 1), + EF => Extra_Accessibility (Formal)); -- For most other cases we simply pass the level of the -- actual's access type. The type is retrieved from @@ -3244,8 +3253,8 @@ package body Exp_Ch6 is when others => Add_Extra_Actual - (Dynamic_Accessibility_Level (Prev), - Extra_Accessibility (Formal)); + (Expr => Dynamic_Accessibility_Level (Prev), + EF => Extra_Accessibility (Formal)); end case; end if; end if; @@ -3572,8 +3581,9 @@ package body Exp_Ch6 is end if; Add_Extra_Actual - (Level, - Extra_Accessibility_Of_Result (Ultimate_Alias (Subp))); + (Expr => Level, + EF => + Extra_Accessibility_Of_Result (Ultimate_Alias (Subp))); end if; end; end if; diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 55f79c3..8dadc9c 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -394,7 +394,7 @@ begin begin -- Check if an argument file is specified - if The_Arg (The_Arg'First) = '@' then + if The_Arg'Length > 0 and then The_Arg (The_Arg'First) = '@' then declare Arg_File : Ada.Text_IO.File_Type; Line : String (1 .. 256); @@ -432,7 +432,7 @@ begin Close (Arg_File); end; - else + elsif The_Arg'Length > 0 then -- It is not an argument file; just put the argument in -- the Last_Switches table. diff --git a/gcc/ada/s-ststop.adb b/gcc/ada/s-ststop.adb index cfc6f8a..ea02065 100644 --- a/gcc/ada/s-ststop.adb +++ b/gcc/ada/s-ststop.adb @@ -133,9 +133,10 @@ package body System.Strings.Stream_Ops is Max_Length : Long_Integer := Long_Integer'Last) return Array_Type is pragma Unsuppress (All_Checks); - -- To make T'Class'Input robust in the case of bad data. The + -- The above makes T'Class'Input robust in the case of bad data. The -- declaration of Item below could raise Storage_Error if the length - -- is huge. + -- is too big. + begin if Strm = null then raise Constraint_Error; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 69f5818..9022bae 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -6419,7 +6419,18 @@ package body Sem_Ch12 is else Formal_P := Next_Entity (E); - Check_Formal_Package_Instance (Formal_P, E); + + -- If the instance is within an enclosing instance body + -- there is no need to vertify the legqlity of current + -- formsl psckages because they were legal in the generic + -- body. This optimixation may be applicable elsewhere, + -- and it also removes spurious errors that may arise with + -- on-the-fly inlining and confusion between private and + -- full views. + + if not In_Instance_Body then + Check_Formal_Package_Instance (Formal_P, E); + end if; -- After checking, remove the internal validating package. -- It is only needed for semantic checks, and as it may diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index ecfc49e..a263c1f7 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -12800,6 +12800,15 @@ package body Sem_Ch13 is end; end if; + -- The expression for Default_Value is a static expression + -- of the type, but this expression does not freeze the + -- type, so it can still appear in a representation clause + -- before the actual freeze point. + + when Aspect_Default_Value => + Set_Must_Not_Freeze (Expr); + Preanalyze_Spec_Expression (Expr, E); + when others => if Present (Expr) then case Aspect_Argument (A_Id) is diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 5194703..f6ddc7f 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -5328,9 +5328,10 @@ package body Sem_Ch8 is -- Make entry in undefined references table unless the full errors -- switch is set, in which case by refraining from generating the -- table entry, we guarantee that we get an error message for every - -- undefined reference. + -- undefined reference. The entry is not added if we are ignoring + -- errors. - if not All_Errors_Mode then + if not All_Errors_Mode and then Ignore_Errors_Enable = 0 then Urefs.Append ( (Node => N, Err => Emsg, diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index a8eed86..668b760 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -3425,7 +3425,7 @@ package body Sem_Prag is if No (N) then declare Pack : constant Node_Id := - Parent (Declaration_Node (Encap_Id)); + Parent (Declaration_Node (Encap_Id)); begin if Nkind (Pack) = N_Package_Specification and then not In_Private_Part (Encap_Id) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 48b8432..7e2dbe2 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -11715,6 +11715,26 @@ package body Sem_Util is end loop; end In_Subprogram_Or_Concurrent_Unit; + ---------------- + -- In_Subtree -- + ---------------- + + function In_Subtree (Root : Node_Id; N : Node_Id) return Boolean is + Curr : Node_Id; + + begin + Curr := N; + while Present (Curr) loop + if Curr = Root then + return True; + end if; + + Curr := Parent (Curr); + end loop; + + return False; + end In_Subtree; + --------------------- -- In_Visible_Part -- --------------------- @@ -17278,72 +17298,70 @@ package body Sem_Util is end if; end New_Copy_List_Tree; - -------------------------------------------------- - -- New_Copy_Tree Auxiliary Data and Subprograms -- - -------------------------------------------------- - - use Atree.Unchecked_Access; - use Atree_Private_Part; + ------------------- + -- New_Copy_Tree -- + ------------------- - -- Our approach here requires a two pass traversal of the tree. The - -- first pass visits all nodes that eventually will be copied looking - -- for defining Itypes. If any defining Itypes are found, then they are - -- copied, and an entry is added to the replacement map. In the second - -- phase, the tree is copied, using the replacement map to replace any - -- Itype references within the copied tree. + -- The following tables play a key role in replicating entities and Itypes. + -- They are intentionally declared at the library level rather than within + -- New_Copy_Tree to avoid elaborating them on each call. This performance + -- optimization saves up to 2% of the entire compilation time spent in the + -- front end. Care should be taken to reset the tables on each new call to + -- New_Copy_Tree. - -- The following hash tables are used to speed up access to the map. They - -- are declared at library level to avoid elaborating them for every call - -- to New_Copy_Tree. This can save up to 2% of the entire compilation time - -- spent in the front end. + NCT_Table_Max : constant := 511; - subtype NCT_Header_Num is Int range 0 .. 511; - -- Defines range of headers in hash tables (512 headers) + subtype NCT_Table_Index is Nat range 0 .. NCT_Table_Max - 1; - function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num; - -- Hash function used for hash operations + function NCT_Table_Hash (Key : Node_Or_Entity_Id) return NCT_Table_Index; + -- Obtain the hash value of node or entity Key - ------------------- - -- New_Copy_Hash -- - ------------------- + -------------------- + -- NCT_Table_Hash -- + -------------------- - function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num is + function NCT_Table_Hash (Key : Node_Or_Entity_Id) return NCT_Table_Index is begin - return Nat (E) mod (NCT_Header_Num'Last + 1); - end New_Copy_Hash; + return NCT_Table_Index (Key mod NCT_Table_Max); + end NCT_Table_Hash; - --------------- - -- NCT_Assoc -- - --------------- + ---------------------- + -- NCT_New_Entities -- + ---------------------- - -- The hash table NCT_Assoc associates old entities in the table with their - -- corresponding new entities (i.e. the pairs of entries presented in the - -- original Map argument are Key-Element pairs). + -- The following table maps old entities and Itypes to their corresponding + -- new entities and Itypes. - package NCT_Assoc is new Simple_HTable ( - Header_Num => NCT_Header_Num, + -- Aaa -> Xxx + + package NCT_New_Entities is new Simple_HTable ( + Header_Num => NCT_Table_Index, Element => Entity_Id, No_Element => Empty, Key => Entity_Id, - Hash => New_Copy_Hash, - Equal => Types."="); + Hash => NCT_Table_Hash, + Equal => "="); - --------------------- - -- NCT_Itype_Assoc -- - --------------------- + ------------------------ + -- NCT_Pending_Itypes -- + ------------------------ - -- The hash table NCT_Itype_Assoc contains entries only for those old - -- nodes which have a non-empty Associated_Node_For_Itype set. The key - -- is the associated node, and the element is the new node itself (NOT - -- the associated node for the new node). + -- The following table maps old Associated_Node_For_Itype nodes to a set of + -- new itypes. Given a set of old Itypes Aaa, Bbb, and Ccc, where all three + -- have the same Associated_Node_For_Itype Ppp, and their corresponding new + -- Itypes Xxx, Yyy, Zzz, the table contains the following mapping: - package NCT_Itype_Assoc is new Simple_HTable ( - Header_Num => NCT_Header_Num, - Element => Node_Or_Entity_Id, - No_Element => Empty, - Key => Entity_Id, - Hash => New_Copy_Hash, - Equal => Types."="); + -- Ppp -> (Xxx, Yyy, Zzz) + + -- The set is expressed as an Elist + + package NCT_Pending_Itypes is new Simple_HTable ( + Header_Num => NCT_Table_Index, + Element => Elist_Id, + No_Element => No_Elist, + Key => Node_Id, + Hash => NCT_Table_Hash, + Equal => "="); ------------------- -- New_Copy_Tree -- @@ -17355,527 +17373,910 @@ package body Sem_Util is New_Sloc : Source_Ptr := No_Location; New_Scope : Entity_Id := Empty) return Node_Id is + -- This routine performs low-level tree manipulations and needs access + -- to the internals of the tree. + + use Atree.Unchecked_Access; + use Atree_Private_Part; + EWA_Level : Nat := 0; - -- By default, copying of defining identifiers is prohibited because - -- this would introduce an entirely new entity into the tree. The - -- exception to this general rule is declaration of constants and - -- variables located in Expression_With_Action nodes. + -- This counter keeps track of how many N_Expression_With_Actions nodes + -- are encountered during a depth-first traversal of the subtree. These + -- nodes may define new entities in their Actions lists and thus require + -- special processing. EWA_Inner_Scope_Level : Nat := 0; - -- Level of internal scope of defined in EWAs. Used to avoid creating - -- variables for declarations located in blocks or subprograms defined - -- in Expression_With_Action nodes. - - NCT_Hash_Tables_Used : Boolean := False; - -- Set to True if hash tables are in use. It is intended to speed up the - -- common case, which is no hash tables in use. This can save up to 8% - -- of the entire compilation time spent in the front end. + -- This counter keeps track of how many scoping constructs appear within + -- an N_Expression_With_Actions node. + + NCT_Tables_In_Use : Boolean := False; + -- This flag keeps track of whether the two tables NCT_New_Entities and + -- NCT_Pending_Itypes are in use. The flag is part of an optimization + -- where certain operations are not performed if the tables are not in + -- use. This saves up to 8% of the entire compilation time spent in the + -- front end. + + procedure Add_New_Entity (Old_Id : Entity_Id; New_Id : Entity_Id); + pragma Inline (Add_New_Entity); + -- Add an entry in the NCT_New_Entities table which maps key Old_Id to + -- value New_Id. Old_Id is an entity which appears within the Actions + -- list of an N_Expression_With_Actions node, or within an entity map. + -- New_Id is the corresponding new entity generated during Phase 1. + + procedure Add_Pending_Itype (Assoc_Nod : Node_Id; Itype : Entity_Id); + pragma Inline (Add_New_Entity); + -- Add an entry in the NCT_Pending_Itypes which maps key Assoc_Nod to + -- value Itype. Assoc_Nod is the associated node of an itype. Itype is + -- an itype. + + procedure Build_NCT_Tables (Entity_Map : Elist_Id); + pragma Inline (Build_NCT_Tables); + -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with the + -- information supplied in entity map Entity_Map. The format of the + -- entity map must be as follows: + -- + -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN - function Assoc (N : Node_Or_Entity_Id) return Node_Id; - -- Called during second phase to map entities into their corresponding - -- copies using the hash table. If the argument is not an entity, or is - -- not in the hash table, then it is returned unchanged. + function Copy_Any_Node_With_Replacement + (N : Node_Or_Entity_Id) return Node_Or_Entity_Id; + pragma Inline (Copy_Any_Node_With_Replacement); + -- Replicate entity or node N by invoking one of the following routines: + -- + -- Copy_Node_With_Replacement + -- Corresponding_Entity + + function Copy_Elist_With_Replacement (List : Elist_Id) return Elist_Id; + -- Replicate the elements of entity list List + + function Copy_Field_With_Replacement + (Field : Union_Id; + Old_Par : Node_Id := Empty; + New_Par : Node_Id := Empty; + Semantic : Boolean := False) return Union_Id; + -- Replicate field Field by invoking one of the following routines: + -- + -- Copy_Elist_With_Replacement + -- Copy_List_With_Replacement + -- Copy_Node_With_Replacement + -- Corresponding_Entity + -- + -- If the field is not an entity list, entity, itype, syntactic list, + -- or node, then the field is returned unchanged. The routine always + -- replicates entities, itypes, and valid syntactic fields. Old_Par is + -- the expected parent of a syntactic field. New_Par is the new parent + -- associated with a replicated syntactic field. Flag Semantic should + -- be set when the input is a semantic field. + + function Copy_List_With_Replacement (List : List_Id) return List_Id; + -- Replicate the elements of syntactic list List + + function Copy_Node_With_Replacement (N : Node_Id) return Node_Id; + -- Replicate node N + + function Corresponding_Entity (Id : Entity_Id) return Entity_Id; + pragma Inline (Corresponding_Entity); + -- Return the corresponding new entity of Id generated during Phase 1. + -- If there is no such entity, return Id. + + function In_Entity_Map + (Id : Entity_Id; + Entity_Map : Elist_Id) return Boolean; + pragma Inline (In_Entity_Map); + -- Determine whether entity Id is one of the old ids specified in entity + -- map Entity_Map. The format of the entity map must be as follows: + -- + -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN + + procedure Update_CFS_Sloc (N : Node_Or_Entity_Id); + pragma Inline (Update_CFS_Sloc); + -- Update the Comes_From_Source and Sloc attributes of node or entity N + + procedure Update_First_Real_Statement + (Old_HSS : Node_Id; + New_HSS : Node_Id); + pragma Inline (Update_First_Real_Statement); + -- Update semantic attribute First_Real_Statement of handled sequence of + -- statements New_HSS based on handled sequence of statements Old_HSS. + + procedure Update_Named_Associations + (Old_Call : Node_Id; + New_Call : Node_Id); + pragma Inline (Update_Named_Associations); + -- Update semantic chain First/Next_Named_Association of call New_call + -- based on call Old_Call. + + procedure Update_New_Entities (Entity_Map : Elist_Id); + pragma Inline (Update_New_Entities); + -- Update the semantic attributes of all new entities generated during + -- Phase 1 that do not appear in entity map Entity_Map. The format of + -- the entity map must be as follows: + -- + -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN + + procedure Update_Pending_Itypes + (Old_Assoc : Node_Id; + New_Assoc : Node_Id); + pragma Inline (Update_Pending_Itypes); + -- Update semantic attribute Associated_Node_For_Itype to refer to node + -- New_Assoc for all itypes whose associated node is Old_Assoc. + + procedure Update_Semantic_Fields (Id : Entity_Id); + pragma Inline (Update_Semantic_Fields); + -- Subsidiary to Update_New_Entities. Update semantic fields of entity + -- or itype Id. + + procedure Visit_Any_Node (N : Node_Or_Entity_Id); + pragma Inline (Visit_Any_Node); + -- Visit entity of node N by invoking one of the following routines: + -- + -- Visit_Entity + -- Visit_Itype + -- Visit_Node + + procedure Visit_Elist (List : Elist_Id); + -- Visit the elements of entity list List + + procedure Visit_Entity (Id : Entity_Id); + -- Visit entity Id. This action may create a new entity of Id and save + -- it in table NCT_New_Entities. + + procedure Visit_Field + (Field : Union_Id; + Par_Nod : Node_Id := Empty; + Semantic : Boolean := False); + -- Visit field Field by invoking one of the following routines: + -- + -- Visit_Elist + -- Visit_Entity + -- Visit_Itype + -- Visit_List + -- Visit_Node + -- + -- If the field is not an entity list, entity, itype, syntactic list, + -- or node, then the field is not visited. The routine always visits + -- valid syntactic fields. Par_Nod is the expected parent of the + -- syntactic field. Flag Semantic should be set when the input is a + -- semantic field. - procedure Build_NCT_Hash_Tables; - -- Builds hash tables + procedure Visit_Itype (Itype : Entity_Id); + -- Visit itype Itype. This action may create a new entity for Itype and + -- save it in table NCT_New_Entities. In addition, the routine may map + -- the associated node of Itype to the new itype in NCT_Pending_Itypes. - function Copy_Elist_With_Replacement - (Old_Elist : Elist_Id) return Elist_Id; - -- Called during second phase to copy element list doing replacements + procedure Visit_List (List : List_Id); + -- Visit the elements of syntactic list List - procedure Copy_Entity_With_Replacement (New_Entity : Entity_Id); - -- Called during the second phase to process a copied Entity. The actual - -- copy happened during the first phase (so that we could make the entry - -- in the mapping), but we still have to deal with the descendants of - -- the copied Entity and copy them where necessary. + procedure Visit_Node (N : Node_Id); + -- Visit node N - function Copy_List_With_Replacement (Old_List : List_Id) return List_Id; - -- Called during second phase to copy list doing replacements + procedure Visit_Semantic_Fields (Id : Entity_Id); + pragma Inline (Visit_Semantic_Fields); + -- Subsidiary to Visit_Entity and Visit_Itype. Visit common semantic + -- fields of entity or itype Id. - function Copy_Node_With_Replacement (Old_Node : Node_Id) return Node_Id; - -- Called during second phase to copy node doing replacements + -------------------- + -- Add_New_Entity -- + -------------------- - function In_Map (E : Entity_Id) return Boolean; - -- Return True if E is one of the old entities specified in the set of - -- mappings to be applied to entities in the tree (i.e. Map). + procedure Add_New_Entity (Old_Id : Entity_Id; New_Id : Entity_Id) is + begin + pragma Assert (Present (Old_Id)); + pragma Assert (Present (New_Id)); + pragma Assert (Nkind (Old_Id) in N_Entity); + pragma Assert (Nkind (New_Id) in N_Entity); - procedure Visit_Elist (E : Elist_Id); - -- Called during first phase to visit all elements of an Elist + NCT_Tables_In_Use := True; - procedure Visit_Entity (Old_Entity : Entity_Id); - -- Called during first phase to visit subsidiary fields of a defining - -- entity which is not an itype, and also create a copy and make an - -- entry in the replacement map for the new copy. + -- Sanity check the NCT_New_Entities table. No previous mapping with + -- key Old_Id should exist. - procedure Visit_Field (F : Union_Id; N : Node_Id); - -- Visit a single field, recursing to call Visit_Node or Visit_List if - -- the field is a syntactic descendant of the current node (i.e. its - -- parent is Node N). + pragma Assert (No (NCT_New_Entities.Get (Old_Id))); - procedure Visit_Itype (Old_Itype : Entity_Id); - -- Called during first phase to visit subsidiary fields of a defining - -- Itype, and also create a copy and make an entry in the replacement - -- map for the new copy. + -- Establish the mapping - procedure Visit_List (L : List_Id); - -- Called during first phase to visit all elements of a List + -- Old_Id -> New_Id - procedure Visit_Node (N : Node_Or_Entity_Id); - -- Called during first phase to visit a node and all its subtrees + NCT_New_Entities.Set (Old_Id, New_Id); + end Add_New_Entity; - ----------- - -- Assoc -- - ----------- + ----------------------- + -- Add_Pending_Itype -- + ----------------------- - function Assoc (N : Node_Or_Entity_Id) return Node_Id is - Ent : Entity_Id; + procedure Add_Pending_Itype (Assoc_Nod : Node_Id; Itype : Entity_Id) is + Itypes : Elist_Id; begin - if Nkind (N) not in N_Entity or else not NCT_Hash_Tables_Used then - return N; + pragma Assert (Present (Assoc_Nod)); + pragma Assert (Present (Itype)); + pragma Assert (Nkind (Itype) in N_Entity); + pragma Assert (Is_Itype (Itype)); - else - Ent := NCT_Assoc.Get (Entity_Id (N)); + NCT_Tables_In_Use := True; - if Present (Ent) then - return Ent; - end if; + -- It is not possible to sanity check the NCT_Pendint_Itypes table + -- directly because a single node may act as the associated node for + -- multiple itypes. + + Itypes := NCT_Pending_Itypes.Get (Assoc_Nod); + + if No (Itypes) then + Itypes := New_Elmt_List; + NCT_Pending_Itypes.Set (Assoc_Nod, Itypes); end if; - return N; - end Assoc; + -- Establish the mapping - --------------------------- - -- Build_NCT_Hash_Tables -- - --------------------------- + -- Assoc_Nod -> (Itype, ...) + + -- Avoid inserting the same itype multiple times. This involves a + -- linear search, however the set of itypes with the same associated + -- node is very small. - procedure Build_NCT_Hash_Tables is - Assoc : Entity_Id; - Elmt : Elmt_Id; - Key : Entity_Id; - Value : Entity_Id; + Append_Unique_Elmt (Itype, Itypes); + end Add_Pending_Itype; + + ---------------------- + -- Build_NCT_Tables -- + ---------------------- + + procedure Build_NCT_Tables (Entity_Map : Elist_Id) is + Elmt : Elmt_Id; + Old_Id : Entity_Id; + New_Id : Entity_Id; begin - if No (Map) then + -- Nothing to do when there is no entity map + + if No (Entity_Map) then return; end if; - -- Clear both hash tables associated with entry replication since - -- multiple calls to New_Copy_Tree could cause multiple collisions - -- and produce long linked lists in individual buckets. - - NCT_Assoc.Reset; - NCT_Itype_Assoc.Reset; - - Elmt := First_Elmt (Map); + Elmt := First_Elmt (Entity_Map); while Present (Elmt) loop - -- Extract a (key, value) pair from the map + -- Extract the (Old_Id, New_Id) pair from the entity map - Key := Node (Elmt); + Old_Id := Node (Elmt); Next_Elmt (Elmt); - Value := Node (Elmt); - -- Add the pair in the association hash table + New_Id := Node (Elmt); + Next_Elmt (Elmt); - NCT_Assoc.Set (Key, Value); + -- Establish the following mapping within table NCT_New_Entities - -- Add a link between the associated node of the old Itype and the - -- new Itype, for updating later when node is copied. + -- Old_Id -> New_Id - if Is_Type (Key) then - Assoc := Associated_Node_For_Itype (Key); + Add_New_Entity (Old_Id, New_Id); - if Present (Assoc) then - NCT_Itype_Assoc.Set (Assoc, Value); - end if; - end if; + -- Establish the following mapping within table NCT_Pending_Itypes + -- when the new entity is an itype. - Next_Elmt (Elmt); + -- Assoc_Nod -> (New_Id, ...) + + -- IMPORTANT: the associated node is that of the old itype because + -- the node will be replicated in Phase 2. + + if Is_Itype (Old_Id) then + Add_Pending_Itype + (Assoc_Nod => Associated_Node_For_Itype (Old_Id), + Itype => New_Id); + end if; end loop; + end Build_NCT_Tables; - NCT_Hash_Tables_Used := True; - end Build_NCT_Hash_Tables; + ------------------------------------ + -- Copy_Any_Node_With_Replacement -- + ------------------------------------ + + function Copy_Any_Node_With_Replacement + (N : Node_Or_Entity_Id) return Node_Or_Entity_Id + is + begin + if Nkind (N) in N_Entity then + return Corresponding_Entity (N); + else + return Copy_Node_With_Replacement (N); + end if; + end Copy_Any_Node_With_Replacement; --------------------------------- -- Copy_Elist_With_Replacement -- --------------------------------- - function Copy_Elist_With_Replacement - (Old_Elist : Elist_Id) return Elist_Id - is - M : Elmt_Id; - New_Elist : Elist_Id; + function Copy_Elist_With_Replacement (List : Elist_Id) return Elist_Id is + Elmt : Elmt_Id; + Result : Elist_Id; begin - if No (Old_Elist) then - return No_Elist; + -- Copy the contents of the old list. Note that the list itself may + -- be empty, in which case the routine returns a new empty list. This + -- avoids sharing lists between subtrees. The element of an entity + -- list could be an entity or a node, hence the invocation of routine + -- Copy_Any_Node_With_Replacement. - else - New_Elist := New_Elmt_List; + if Present (List) then + Result := New_Elmt_List; - M := First_Elmt (Old_Elist); - while Present (M) loop - Append_Elmt (Copy_Node_With_Replacement (Node (M)), New_Elist); - Next_Elmt (M); + Elmt := First_Elmt (List); + while Present (Elmt) loop + Append_Elmt + (Copy_Any_Node_With_Replacement (Node (Elmt)), Result); + + Next_Elmt (Elmt); end loop; + + -- Otherwise the list does not exist + + else + Result := No_Elist; end if; - return New_Elist; + return Result; end Copy_Elist_With_Replacement; - ---------------------------------- - -- Copy_Entity_With_Replacement -- - ---------------------------------- - - -- This routine exactly parallels its phase one analog Visit_Itype + --------------------------------- + -- Copy_Field_With_Replacement -- + --------------------------------- - procedure Copy_Entity_With_Replacement (New_Entity : Entity_Id) is + function Copy_Field_With_Replacement + (Field : Union_Id; + Old_Par : Node_Id := Empty; + New_Par : Node_Id := Empty; + Semantic : Boolean := False) return Union_Id + is begin - -- Translate Next_Entity, Scope, and Etype fields, in case they - -- reference entities that have been mapped into copies. + -- The field is empty - Set_Next_Entity (New_Entity, Assoc (Next_Entity (New_Entity))); - Set_Etype (New_Entity, Assoc (Etype (New_Entity))); + if Field = Union_Id (Empty) then + return Field; - if Present (New_Scope) then - Set_Scope (New_Entity, New_Scope); - else - Set_Scope (New_Entity, Assoc (Scope (New_Entity))); - end if; + -- The field is an entity/itype/node + + elsif Field in Node_Range then + declare + Old_N : constant Node_Id := Node_Id (Field); + Syntactic : constant Boolean := Parent (Old_N) = Old_Par; - -- Copy referenced fields + New_N : Node_Id; - if Is_Discrete_Type (New_Entity) then - Set_Scalar_Range (New_Entity, - Copy_Node_With_Replacement (Scalar_Range (New_Entity))); + begin + -- The field is an entity/itype - elsif Has_Discriminants (Base_Type (New_Entity)) then - Set_Discriminant_Constraint (New_Entity, - Copy_Elist_With_Replacement - (Discriminant_Constraint (New_Entity))); + if Nkind (Old_N) in N_Entity then - elsif Is_Array_Type (New_Entity) then - if Present (First_Index (New_Entity)) then - Set_First_Index (New_Entity, - First (Copy_List_With_Replacement - (List_Containing (First_Index (New_Entity))))); - end if; + -- An entity/itype is always replicated - if Is_Packed (New_Entity) then - Set_Packed_Array_Impl_Type (New_Entity, - Copy_Node_With_Replacement - (Packed_Array_Impl_Type (New_Entity))); - end if; + New_N := Corresponding_Entity (Old_N); + + -- Update the parent pointer when the entity is a syntactic + -- field. Note that itypes do not have parent pointers. + + if Syntactic and then New_N /= Old_N then + Set_Parent (New_N, New_Par); + end if; + + -- The field is a node + + else + -- A node is replicated when it is either a syntactic field + -- or when the caller treats it as a semantic attribute. + + if Syntactic or else Semantic then + New_N := Copy_Node_With_Replacement (Old_N); + + -- Update the parent pointer when the node is a syntactic + -- field. + + if Syntactic and then New_N /= Old_N then + Set_Parent (New_N, New_Par); + end if; + + -- Otherwise the node is returned unchanged + + else + New_N := Old_N; + end if; + end if; + + return Union_Id (New_N); + end; + + -- The field is an entity list + + elsif Field in Elist_Range then + return Union_Id (Copy_Elist_With_Replacement (Elist_Id (Field))); + + -- The field is a syntactic list + + elsif Field in List_Range then + declare + Old_List : constant List_Id := List_Id (Field); + Syntactic : constant Boolean := Parent (Old_List) = Old_Par; + + New_List : List_Id; + + begin + -- A list is replicated when it is either a syntactic field or + -- when the caller treats it as a semantic attribute. + + if Syntactic or else Semantic then + New_List := Copy_List_With_Replacement (Old_List); + + -- Update the parent pointer when the list is a syntactic + -- field. + + if Syntactic and then New_List /= Old_List then + Set_Parent (New_List, New_Par); + end if; + + -- Otherwise the list is returned unchanged + + else + New_List := Old_List; + end if; + + return Union_Id (New_List); + end; + + -- Otherwise the field denotes an attribute that does not need to be + -- replicated (Chars, literals, etc). + + else + return Field; end if; - end Copy_Entity_With_Replacement; + end Copy_Field_With_Replacement; -------------------------------- -- Copy_List_With_Replacement -- -------------------------------- - function Copy_List_With_Replacement - (Old_List : List_Id) return List_Id - is - New_List : List_Id; - E : Node_Id; + function Copy_List_With_Replacement (List : List_Id) return List_Id is + Elmt : Node_Id; + Result : List_Id; begin - if Old_List = No_List then - return No_List; + -- Copy the contents of the old list. Note that the list itself may + -- be empty, in which case the routine returns a new empty list. This + -- avoids sharing lists between subtrees. The element of a syntactic + -- list is always a node, never an entity or itype, hence the call to + -- routine Copy_Node_With_Replacement. - else - New_List := Empty_List; + if Present (List) then + Result := New_List; + + Elmt := First (List); + while Present (Elmt) loop + Append (Copy_Node_With_Replacement (Elmt), Result); - E := First (Old_List); - while Present (E) loop - Append (Copy_Node_With_Replacement (E), New_List); - Next (E); + Next (Elmt); end loop; - return New_List; + -- Otherwise the list does not exist + + else + Result := No_List; end if; + + return Result; end Copy_List_With_Replacement; -------------------------------- -- Copy_Node_With_Replacement -- -------------------------------- - function Copy_Node_With_Replacement - (Old_Node : Node_Id) return Node_Id - is - New_Node : Node_Id; - - procedure Adjust_Named_Associations - (Old_Node : Node_Id; - New_Node : Node_Id); - -- If a call node has named associations, these are chained through - -- the First_Named_Actual, Next_Named_Actual links. These must be - -- propagated separately to the new parameter list, because these - -- are not syntactic fields. - - function Copy_Field_With_Replacement - (Field : Union_Id) return Union_Id; - -- Given Field, which is a field of Old_Node, return a copy of it - -- if it is a syntactic field (i.e. its parent is Node), setting - -- the parent of the copy to poit to New_Node. Otherwise returns - -- the field (possibly mapped if it is an entity). - - ------------------------------- - -- Adjust_Named_Associations -- - ------------------------------- - - procedure Adjust_Named_Associations - (Old_Node : Node_Id; - New_Node : Node_Id) - is - Old_E : Node_Id; - New_E : Node_Id; + function Copy_Node_With_Replacement (N : Node_Id) return Node_Id is + Result : Node_Id; - Old_Next : Node_Id; - New_Next : Node_Id; + begin + -- Assume that the node must be returned unchanged + + Result := N; + + if N > Empty_Or_Error then + pragma Assert (Nkind (N) not in N_Entity); + + Result := New_Copy (N); + + Set_Field1 (Result, + Copy_Field_With_Replacement + (Field => Field1 (Result), + Old_Par => N, + New_Par => Result)); + + Set_Field2 (Result, + Copy_Field_With_Replacement + (Field => Field2 (Result), + Old_Par => N, + New_Par => Result)); + + Set_Field3 (Result, + Copy_Field_With_Replacement + (Field => Field3 (Result), + Old_Par => N, + New_Par => Result)); + + Set_Field4 (Result, + Copy_Field_With_Replacement + (Field => Field4 (Result), + Old_Par => N, + New_Par => Result)); + + Set_Field5 (Result, + Copy_Field_With_Replacement + (Field => Field5 (Result), + Old_Par => N, + New_Par => Result)); + + -- Update the Comes_From_Source and Sloc attributes of the node + -- in case the caller has supplied new values. + + Update_CFS_Sloc (Result); + + -- Update the Associated_Node_For_Itype attribute of all itypes + -- created during Phase 1 whose associated node is N. As a result + -- the Associated_Node_For_Itype refers to the replicated node. + -- No action needs to be taken when the Associated_Node_For_Itype + -- refers to an entity because this was already handled during + -- Phase 1, in Visit_Itype. + + Update_Pending_Itypes + (Old_Assoc => N, + New_Assoc => Result); + + -- Update the First/Next_Named_Association chain for a replicated + -- call. + + if Nkind_In (N, N_Entry_Call_Statement, + N_Function_Call, + N_Procedure_Call_Statement) + then + Update_Named_Associations + (Old_Call => N, + New_Call => Result); - begin - Old_E := First (Parameter_Associations (Old_Node)); - New_E := First (Parameter_Associations (New_Node)); - while Present (Old_E) loop - if Nkind (Old_E) = N_Parameter_Association - and then Present (Next_Named_Actual (Old_E)) - then - if First_Named_Actual (Old_Node) = - Explicit_Actual_Parameter (Old_E) - then - Set_First_Named_Actual - (New_Node, Explicit_Actual_Parameter (New_E)); - end if; + -- Update the Renamed_Object attribute of a replicated object + -- declaration. - -- Now scan parameter list from the beginning, to locate - -- next named actual, which can be out of order. - - Old_Next := First (Parameter_Associations (Old_Node)); - New_Next := First (Parameter_Associations (New_Node)); - while Nkind (Old_Next) /= N_Parameter_Association - or else Explicit_Actual_Parameter (Old_Next) /= - Next_Named_Actual (Old_E) - loop - Next (Old_Next); - Next (New_Next); - end loop; + elsif Nkind (N) = N_Object_Renaming_Declaration then + Set_Renamed_Object (Defining_Entity (Result), Name (Result)); - Set_Next_Named_Actual - (New_E, Explicit_Actual_Parameter (New_Next)); - end if; + -- Update the First_Real_Statement attribute of a replicated + -- handled sequence of statements. - Next (Old_E); - Next (New_E); - end loop; - end Adjust_Named_Associations; + elsif Nkind (N) = N_Handled_Sequence_Of_Statements then + Update_First_Real_Statement + (Old_HSS => N, + New_HSS => Result); + end if; + end if; - --------------------------------- - -- Copy_Field_With_Replacement -- - --------------------------------- + return Result; + end Copy_Node_With_Replacement; - function Copy_Field_With_Replacement - (Field : Union_Id) return Union_Id - is - begin - if Field = Union_Id (Empty) then - return Field; + -------------------------- + -- Corresponding_Entity -- + -------------------------- - elsif Field in Node_Range then - declare - Old_N : constant Node_Id := Node_Id (Field); - New_N : Node_Id; + function Corresponding_Entity (Id : Entity_Id) return Entity_Id is + New_Id : Entity_Id; + Result : Entity_Id; - begin - -- If syntactic field, as indicated by the parent pointer - -- being set, then copy the referenced node recursively. + begin + -- Assume that the entity must be returned unchanged - if Parent (Old_N) = Old_Node then - New_N := Copy_Node_With_Replacement (Old_N); + Result := Id; - if New_N /= Old_N then - Set_Parent (New_N, New_Node); - end if; + if Id > Empty_Or_Error then + pragma Assert (Nkind (Id) in N_Entity); - -- For semantic fields, update possible entity reference - -- from the replacement map. + -- Determine whether the entity has a corresponding new entity + -- generated during Phase 1 and if it does, use it. - else - New_N := Assoc (Old_N); - end if; + if NCT_Tables_In_Use then + New_Id := NCT_New_Entities.Get (Id); - return Union_Id (New_N); - end; + if Present (New_Id) then + Result := New_Id; + end if; + end if; + end if; - elsif Field in List_Range then - declare - Old_L : constant List_Id := List_Id (Field); - New_L : List_Id; + return Result; + end Corresponding_Entity; - begin - -- If syntactic field, as indicated by the parent pointer, - -- then recursively copy the entire referenced list. + ------------------- + -- In_Entity_Map -- + ------------------- - if Parent (Old_L) = Old_Node then - New_L := Copy_List_With_Replacement (Old_L); - Set_Parent (New_L, New_Node); + function In_Entity_Map + (Id : Entity_Id; + Entity_Map : Elist_Id) return Boolean + is + Elmt : Elmt_Id; + Old_Id : Entity_Id; - -- For semantic list, just returned unchanged + begin + -- The entity map contains pairs (Old_Id, New_Id). The advancement + -- step always skips the New_Id portion of the pair. - else - New_L := Old_L; - end if; + if Present (Entity_Map) then + Elmt := First_Elmt (Entity_Map); + while Present (Elmt) loop + Old_Id := Node (Elmt); - return Union_Id (New_L); - end; + if Old_Id = Id then + return True; + end if; - -- Anything other than a list or a node is returned unchanged + Next_Elmt (Elmt); + Next_Elmt (Elmt); + end loop; + end if; - else - return Field; - end if; - end Copy_Field_With_Replacement; + return False; + end In_Entity_Map; - -- Start of processing for Copy_Node_With_Replacement + --------------------- + -- Update_CFS_Sloc -- + --------------------- + procedure Update_CFS_Sloc (N : Node_Or_Entity_Id) is begin - if Old_Node <= Empty_Or_Error then - return Old_Node; + -- A new source location defaults the Comes_From_Source attribute + + if New_Sloc /= No_Location then + Set_Comes_From_Source (N, Default_Node.Comes_From_Source); + Set_Sloc (N, New_Sloc); + end if; + end Update_CFS_Sloc; - elsif Nkind (Old_Node) in N_Entity then - return Assoc (Old_Node); + --------------------------------- + -- Update_First_Real_Statement -- + --------------------------------- - else - New_Node := New_Copy (Old_Node); + procedure Update_First_Real_Statement + (Old_HSS : Node_Id; + New_HSS : Node_Id) + is + Old_First_Stmt : constant Node_Id := First_Real_Statement (Old_HSS); - -- If the node we are copying is the associated node of a - -- previously copied Itype, then adjust the associated node - -- of the copy of that Itype accordingly. + New_Stmt : Node_Id; + Old_Stmt : Node_Id; - declare - Ent : constant Entity_Id := NCT_Itype_Assoc.Get (Old_Node); + begin + -- Recreate the First_Real_Statement attribute of a handled sequence + -- of statements by traversing the statement lists of both sequences + -- in parallel. + + if Present (Old_First_Stmt) then + New_Stmt := First (Statements (New_HSS)); + Old_Stmt := First (Statements (Old_HSS)); + while Present (Old_Stmt) and then Old_Stmt /= Old_First_Stmt loop + Next (New_Stmt); + Next (Old_Stmt); + end loop; - begin - if Present (Ent) then - Set_Associated_Node_For_Itype (Ent, New_Node); - end if; - end; + pragma Assert (Present (New_Stmt)); + pragma Assert (Present (Old_Stmt)); - -- Recursively copy descendants + Set_First_Real_Statement (New_HSS, New_Stmt); + end if; + end Update_First_Real_Statement; + + ------------------------------- + -- Update_Named_Associations -- + ------------------------------- - Set_Field1 - (New_Node, Copy_Field_With_Replacement (Field1 (New_Node))); - Set_Field2 - (New_Node, Copy_Field_With_Replacement (Field2 (New_Node))); - Set_Field3 - (New_Node, Copy_Field_With_Replacement (Field3 (New_Node))); - Set_Field4 - (New_Node, Copy_Field_With_Replacement (Field4 (New_Node))); - Set_Field5 - (New_Node, Copy_Field_With_Replacement (Field5 (New_Node))); + procedure Update_Named_Associations + (Old_Call : Node_Id; + New_Call : Node_Id) + is + New_Act : Node_Id; + New_Next : Node_Id; + Old_Act : Node_Id; + Old_Next : Node_Id; - -- Adjust Sloc of new node if necessary + begin + -- Recreate the First/Next_Named_Actual chain of a call by traversing + -- the chains of both the old and new calls in parallel. + + New_Act := First (Parameter_Associations (New_Call)); + Old_Act := First (Parameter_Associations (Old_Call)); + while Present (Old_Act) loop + if Nkind (Old_Act) = N_Parameter_Association + and then Present (Next_Named_Actual (Old_Act)) + then + if First_Named_Actual (Old_Call) = + Explicit_Actual_Parameter (Old_Act) + then + Set_First_Named_Actual (New_Call, + Explicit_Actual_Parameter (New_Act)); + end if; - if New_Sloc /= No_Location then - Set_Sloc (New_Node, New_Sloc); + -- Scan the actual parameter list to find the next suitable + -- named actual. Note that the list may be out of order. - -- If we adjust the Sloc, then we are essentially making a - -- completely new node, so the Comes_From_Source flag should - -- be reset to the proper default value. + New_Next := First (Parameter_Associations (New_Call)); + Old_Next := First (Parameter_Associations (Old_Call)); + while Nkind (Old_Next) /= N_Parameter_Association + or else Explicit_Actual_Parameter (Old_Next) /= + Next_Named_Actual (Old_Act) + loop + Next (New_Next); + Next (Old_Next); + end loop; - Set_Comes_From_Source - (New_Node, Default_Node.Comes_From_Source); + Set_Next_Named_Actual (New_Act, + Explicit_Actual_Parameter (New_Next)); end if; - -- Update the named association links for calls to mention the - -- copied actual parameters. + Next (New_Act); + Next (Old_Act); + end loop; + end Update_Named_Associations; - if Nkind_In (Old_Node, N_Entry_Call_Statement, - N_Function_Call, - N_Procedure_Call_Statement) - and then Present (First_Named_Actual (Old_Node)) - then - Adjust_Named_Associations (Old_Node, New_Node); + ------------------------- + -- Update_New_Entities -- + ------------------------- + + procedure Update_New_Entities (Entity_Map : Elist_Id) is + New_Id : Entity_Id := Empty; + Old_Id : Entity_Id := Empty; + + begin + if NCT_Tables_In_Use then + NCT_New_Entities.Get_First (Old_Id, New_Id); + + -- Update the semantic fields of all new entities created during + -- Phase 1 which were not supplied via an entity map. + -- ??? Is there a better way of distinguishing those? + + while Present (Old_Id) and then Present (New_Id) loop + if not (Present (Entity_Map) + and then In_Entity_Map (Old_Id, Entity_Map)) + then + Update_Semantic_Fields (New_Id); + end if; + + NCT_New_Entities.Get_Next (Old_Id, New_Id); + end loop; + end if; + end Update_New_Entities; + + --------------------------- + -- Update_Pending_Itypes -- + --------------------------- + + procedure Update_Pending_Itypes + (Old_Assoc : Node_Id; + New_Assoc : Node_Id) + is + Item : Elmt_Id; + Itypes : Elist_Id; + + begin + if NCT_Tables_In_Use then + Itypes := NCT_Pending_Itypes.Get (Old_Assoc); - -- Update the Renamed_Object attribute of an object renaming - -- declaration to mention the replicated name. + -- Update the Associated_Node_For_Itype attribute for all itypes + -- which originally refer to Old_Assoc to designate New_Assoc. - elsif Nkind (Old_Node) = N_Object_Renaming_Declaration then - Set_Renamed_Object - (Defining_Entity (New_Node), Name (New_Node)); + if Present (Itypes) then + Item := First_Elmt (Itypes); + while Present (Item) loop + Set_Associated_Node_For_Itype (Node (Item), New_Assoc); + + Next_Elmt (Item); + end loop; end if; + end if; + end Update_Pending_Itypes; - -- Reset First_Real_Statement for Handled_Sequence_Of_Statements. - -- The replacement mechanism applies to entities, and is not used - -- here. Eventually we may need a more general graph-copying - -- routine. For now, do a sequential search to find desired node. + ---------------------------- + -- Update_Semantic_Fields -- + ---------------------------- - if Nkind (Old_Node) = N_Handled_Sequence_Of_Statements - and then Present (First_Real_Statement (Old_Node)) - then - declare - Old_F : constant Node_Id := First_Real_Statement (Old_Node); - N1 : Node_Id; - N2 : Node_Id; + procedure Update_Semantic_Fields (Id : Entity_Id) is + begin + -- Discriminant_Constraint - begin - N1 := First (Statements (Old_Node)); - N2 := First (Statements (New_Node)); + if Has_Discriminants (Base_Type (Id)) then + Set_Discriminant_Constraint (Id, Elist_Id ( + Copy_Field_With_Replacement + (Field => Union_Id (Discriminant_Constraint (Id)), + Semantic => True))); + end if; - while N1 /= Old_F loop - Next (N1); - Next (N2); - end loop; + -- Etype - Set_First_Real_Statement (New_Node, N2); - end; + Set_Etype (Id, Node_Id ( + Copy_Field_With_Replacement + (Field => Union_Id (Etype (Id)), + Semantic => True))); + + -- First_Index + -- Packed_Array_Impl_Type + + if Is_Array_Type (Id) then + if Present (First_Index (Id)) then + Set_First_Index (Id, First (List_Id ( + Copy_Field_With_Replacement + (Field => Union_Id (List_Containing (First_Index (Id))), + Semantic => True)))); + end if; + + if Is_Packed (Id) then + Set_Packed_Array_Impl_Type (Id, Node_Id ( + Copy_Field_With_Replacement + (Field => Union_Id (Packed_Array_Impl_Type (Id)), + Semantic => True))); end if; end if; - -- All done, return copied node + -- Next_Entity - return New_Node; - end Copy_Node_With_Replacement; + Set_Next_Entity (Id, Node_Id ( + Copy_Field_With_Replacement + (Field => Union_Id (Next_Entity (Id)), + Semantic => True))); - ------------ - -- In_Map -- - ------------ + -- Scalar_Range - function In_Map (E : Entity_Id) return Boolean is - Elmt : Elmt_Id; - Ent : Entity_Id; + if Is_Discrete_Type (Id) then + Set_Scalar_Range (Id, Node_Id ( + Copy_Field_With_Replacement + (Field => Union_Id (Scalar_Range (Id)), + Semantic => True))); + end if; - begin - if Present (Map) then - Elmt := First_Elmt (Map); - while Present (Elmt) loop - Ent := Node (Elmt); + -- Scope - if Ent = E then - return True; - end if; + -- Update the scope when the caller specified an explicit one - Next_Elmt (Elmt); - Next_Elmt (Elmt); - end loop; + if Present (New_Scope) then + Set_Scope (Id, New_Scope); + else + Set_Scope (Id, Node_Id ( + Copy_Field_With_Replacement + (Field => Union_Id (Scope (Id)), + Semantic => True))); end if; + end Update_Semantic_Fields; - return False; - end In_Map; + -------------------- + -- Visit_Any_Node -- + -------------------- + + procedure Visit_Any_Node (N : Node_Or_Entity_Id) is + begin + if Nkind (N) in N_Entity then + if Is_Itype (N) then + Visit_Itype (N); + else + Visit_Entity (N); + end if; + else + Visit_Node (N); + end if; + end Visit_Any_Node; ----------------- -- Visit_Elist -- ----------------- - procedure Visit_Elist (E : Elist_Id) is + procedure Visit_Elist (List : Elist_Id) is Elmt : Elmt_Id; + begin - if Present (E) then - Elmt := First_Elmt (E); + -- The element of an entity list could be an entity, itype, or a + -- node, hence the call to Visit_Any_Node. + + if Present (List) then + Elmt := First_Elmt (List); + while Present (Elmt) loop + Visit_Any_Node (Node (Elmt)); - while Elmt /= No_Elmt loop - Visit_Node (Node (Elmt)); Next_Elmt (Elmt); end loop; end if; @@ -17885,108 +18286,153 @@ package body Sem_Util is -- Visit_Entity -- ------------------ - procedure Visit_Entity (Old_Entity : Entity_Id) is - New_E : Entity_Id; + procedure Visit_Entity (Id : Entity_Id) is + New_Id : Entity_Id; begin - pragma Assert (not Is_Itype (Old_Entity)); - pragma Assert (Nkind (Old_Entity) in N_Entity); + pragma Assert (Nkind (Id) in N_Entity); + pragma Assert (not Is_Itype (Id)); - -- Do not duplicate an entity when it is declared within an inner - -- scope enclosed by an expression with actions. + -- Nothing to do if the entity is not defined in the Actions list of + -- an N_Expression_With_Actions node. - if EWA_Inner_Scope_Level > 0 then + if EWA_Level = 0 then return; - -- Entity duplication is currently performed only for objects and - -- types. Relaxing this restriction leads to a performance penalty. + -- Nothing to do if the entity is defined within a scoping construct + -- of an N_Expression_With_Actions node. - elsif Ekind_In (Old_Entity, E_Constant, E_Variable) then - null; + elsif EWA_Inner_Scope_Level > 0 then + return; - elsif Is_Type (Old_Entity) then - null; + -- Nothing to do if the entity is not an object or a type. Relaxing + -- this restriction leads to a performance penalty. - else + elsif not Ekind_In (Id, E_Constant, E_Variable) + and then not Is_Type (Id) + then + return; + + -- Nothing to do if the entity was already visited + + elsif NCT_Tables_In_Use + and then Present (NCT_New_Entities.Get (Id)) + then + return; + + -- Nothing to do if the declaration node of the entity is not within + -- the subtree being replicated. + + elsif not In_Subtree + (Root => Source, + N => Declaration_Node (Id)) + then return; end if; - New_E := New_Copy (Old_Entity); + -- Create a new entity by directly copying the old entity. This + -- action causes all attributes of the old entity to be inherited. + + New_Id := New_Copy (Id); + + -- Create a new name for the new entity because the back end needs + -- distinct names for debugging purposes. - -- The new entity has all the attributes of the old one, however it - -- requires a new name for debugging purposes. + Set_Chars (New_Id, New_Internal_Name ('T')); - Set_Chars (New_E, New_Internal_Name ('T')); + -- Update the Comes_From_Source and Sloc attributes of the entity in + -- case the caller has supplied new values. - -- Add new association to map + Update_CFS_Sloc (New_Id); - NCT_Assoc.Set (Old_Entity, New_E); - NCT_Hash_Tables_Used := True; + -- Establish the following mapping within table NCT_New_Entities: - -- Visit descendants that eventually get copied + -- Id -> New_Id - Visit_Field (Union_Id (Etype (Old_Entity)), Old_Entity); + Add_New_Entity (Id, New_Id); + + -- Deal with the semantic fields of entities. The fields are visited + -- because they may mention entities which reside within the subtree + -- being copied. + + Visit_Semantic_Fields (Id); end Visit_Entity; ----------------- -- Visit_Field -- ----------------- - procedure Visit_Field (F : Union_Id; N : Node_Id) is + procedure Visit_Field + (Field : Union_Id; + Par_Nod : Node_Id := Empty; + Semantic : Boolean := False) + is begin - if F = Union_Id (Empty) then + -- The field is empty + + if Field = Union_Id (Empty) then return; - elsif F in Node_Range then + -- The field is an entity/itype/node - -- Copy node if it is syntactic, i.e. its parent pointer is - -- set to point to the field that referenced it (certain - -- Itypes will also meet this criterion, which is fine, since - -- these are clearly Itypes that do need to be copied, since - -- we are copying their parent.) + elsif Field in Node_Range then + declare + N : constant Node_Id := Node_Id (Field); - if Parent (Node_Id (F)) = N then - Visit_Node (Node_Id (F)); - return; + begin + -- The field is an entity/itype - -- Another case, if we are pointing to an Itype, then we want - -- to copy it if its associated node is somewhere in the tree - -- being copied. + if Nkind (N) in N_Entity then - -- Note: the exclusion of self-referential copies is just an - -- optimization, since the search of the already copied list - -- would catch it, but it is a common case (Etype pointing to - -- itself for an Itype that is a base type). + -- Itypes are always visited - elsif Nkind (Node_Id (F)) in N_Entity - and then Is_Itype (Entity_Id (F)) - and then Node_Id (F) /= N - then - declare - P : Node_Id; + if Is_Itype (N) then + Visit_Itype (N); - begin - P := Associated_Node_For_Itype (Node_Id (F)); - while Present (P) loop - if P = Source then - Visit_Node (Node_Id (F)); - return; - else - P := Parent (P); - end if; - end loop; + -- An entity is visited when it is either a syntactic field + -- or when the caller treats it as a semantic attribute. - -- An Itype whose parent is not being copied definitely - -- should NOT be copied, since it does not belong in any - -- sense to the copied subtree. + elsif Parent (N) = Par_Nod or else Semantic then + Visit_Entity (N); + end if; - return; - end; - end if; + -- The field is a node - elsif F in List_Range and then Parent (List_Id (F)) = N then - Visit_List (List_Id (F)); - return; + else + -- A node is visited when it is either a syntactic field or + -- when the caller treats it as a semantic attribute. + + if Parent (N) = Par_Nod or else Semantic then + Visit_Node (N); + end if; + end if; + end; + + -- The field is an entity list + + elsif Field in Elist_Range then + Visit_Elist (Elist_Id (Field)); + + -- The field is a syntax list + + elsif Field in List_Range then + declare + List : constant List_Id := List_Id (Field); + + begin + -- A syntax list is visited when it is either a syntactic field + -- or when the caller treats it as a semantic attribute. + + if Parent (List) = Par_Nod or else Semantic then + Visit_List (List); + end if; + end; + + -- Otherwise the field denotes information which does not need to be + -- visited (chars, literals, etc.). + + else + null; end if; end Visit_Field; @@ -17994,110 +18440,139 @@ package body Sem_Util is -- Visit_Itype -- ----------------- - procedure Visit_Itype (Old_Itype : Entity_Id) is + procedure Visit_Itype (Itype : Entity_Id) is + New_Assoc : Node_Id; New_Itype : Entity_Id; - Ent : Entity_Id; + Old_Assoc : Node_Id; begin + pragma Assert (Nkind (Itype) in N_Entity); + pragma Assert (Is_Itype (Itype)); + -- Itypes that describe the designated type of access to subprograms -- have the structure of subprogram declarations, with signatures, -- etc. Either we duplicate the signatures completely, or choose to -- share such itypes, which is fine because their elaboration will -- have no side effects. - if Ekind (Old_Itype) = E_Subprogram_Type then + if Ekind (Itype) = E_Subprogram_Type then + return; + + -- Nothing to do if the itype was already visited + + elsif NCT_Tables_In_Use + and then Present (NCT_New_Entities.Get (Itype)) + then + return; + + -- Nothing to do if the associated node of the itype is not within + -- the subtree being replicated. + + elsif not In_Subtree + (Root => Source, + N => Associated_Node_For_Itype (Itype)) + then return; end if; - New_Itype := New_Copy (Old_Itype); + -- Create a new itype by directly copying the old itype. This action + -- causes all attributes of the old itype to be inherited. - -- The new Itype has all the attributes of the old one, and we - -- just copy the contents of the entity. However, the back-end - -- needs different names for debugging purposes, so we create a - -- new internal name for it in all cases. + New_Itype := New_Copy (Itype); - Set_Chars (New_Itype, New_Internal_Name ('T')); + -- Create a new name for the new itype because the back end requires + -- distinct names for debugging purposes. - -- If our associated node is an entity that has already been copied, - -- then set the associated node of the copy to point to the right - -- copy. If we have copied an Itype that is itself the associated - -- node of some previously copied Itype, then we set the right - -- pointer in the other direction. + Set_Chars (New_Itype, New_Internal_Name ('T')); - Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype)); + -- Update the Comes_From_Source and Sloc attributes of the itype in + -- case the caller has supplied new values. - if Present (Ent) then - Set_Associated_Node_For_Itype (New_Itype, Ent); - end if; + Update_CFS_Sloc (New_Itype); - Ent := NCT_Itype_Assoc.Get (Old_Itype); + -- Establish the following mapping within table NCT_New_Entities: - if Present (Ent) then - Set_Associated_Node_For_Itype (Ent, New_Itype); + -- Itype -> New_Itype - -- If the hash table has no association for this Itype and its - -- associated node, enter one now. + Add_New_Entity (Itype, New_Itype); - else - NCT_Itype_Assoc.Set - (Associated_Node_For_Itype (Old_Itype), New_Itype); - end if; + -- The new itype must be unfrozen because the resulting subtree may + -- be inserted anywhere and cause an earlier or later freezing. if Present (Freeze_Node (New_Itype)) then - Set_Is_Frozen (New_Itype, False); Set_Freeze_Node (New_Itype, Empty); + Set_Is_Frozen (New_Itype, False); end if; - -- Add new association to map - - NCT_Assoc.Set (Old_Itype, New_Itype); - NCT_Hash_Tables_Used := True; - -- If a record subtype is simply copied, the entity list will be -- shared. Thus cloned_Subtype must be set to indicate the sharing. + -- ??? What does this do? - if Ekind_In (Old_Itype, E_Class_Wide_Subtype, E_Record_Subtype) then - Set_Cloned_Subtype (New_Itype, Old_Itype); + if Ekind_In (Itype, E_Class_Wide_Subtype, E_Record_Subtype) then + Set_Cloned_Subtype (New_Itype, Itype); end if; - -- Visit descendants that eventually get copied + -- The associated node may denote an entity, in which case it may + -- already have a new corresponding entity created during a prior + -- call to Visit_Entity or Visit_Itype for the same subtree. - Visit_Field (Union_Id (Etype (Old_Itype)), Old_Itype); + -- Given + -- Old_Assoc ---------> New_Assoc - if Is_Discrete_Type (Old_Itype) then - Visit_Field (Union_Id (Scalar_Range (Old_Itype)), Old_Itype); + -- Created by Visit_Itype + -- Itype -------------> New_Itype + -- ANFI = Old_Assoc ANFI = Old_Assoc < must be updated - elsif Has_Discriminants (Base_Type (Old_Itype)) then - -- ??? This should involve call to Visit_Field - Visit_Elist (Discriminant_Constraint (Old_Itype)); + -- In the example above, Old_Assoc is an arbitrary entity that was + -- already visited for the same subtree and has a corresponding new + -- entity New_Assoc. Old_Assoc was inherited by New_Itype by virtue + -- of copying entities, however it must be updated to New_Assoc. - elsif Is_Array_Type (Old_Itype) then - if Present (First_Index (Old_Itype)) then - Visit_Field - (Union_Id (List_Containing (First_Index (Old_Itype))), - Old_Itype); - end if; + Old_Assoc := Associated_Node_For_Itype (Itype); - if Is_Packed (Old_Itype) then - Visit_Field - (Union_Id (Packed_Array_Impl_Type (Old_Itype)), Old_Itype); + if Nkind (Old_Assoc) in N_Entity then + if NCT_Tables_In_Use then + New_Assoc := NCT_New_Entities.Get (Old_Assoc); + + if Present (New_Assoc) then + Set_Associated_Node_For_Itype (New_Itype, New_Assoc); + end if; end if; + + -- Otherwise the associated node denotes a node. Postpone the update + -- until Phase 2 when the node is replicated. Establish the following + -- mapping within table NCT_Pending_Itypes: + + -- Old_Assoc -> (New_Type, ...) + + else + Add_Pending_Itype (Old_Assoc, New_Itype); end if; + + -- Deal with the semantic fields of itypes. The fields are visited + -- because they may mention entities that reside within the subtree + -- being copied. + + Visit_Semantic_Fields (Itype); end Visit_Itype; ---------------- -- Visit_List -- ---------------- - procedure Visit_List (L : List_Id) is - N : Node_Id; + procedure Visit_List (List : List_Id) is + Elmt : Node_Id; + begin - if L /= No_List then - N := First (L); + -- Note that the element of a syntactic list is always a node, never + -- an entity or itype, hence the call to Visit_Node. + + if Present (List) then + Elmt := First (List); + while Present (Elmt) loop + Visit_Node (Elmt); - while Present (N) loop - Visit_Node (N); - Next (N); + Next (Elmt); end loop; end if; end Visit_List; @@ -18108,6 +18583,8 @@ package body Sem_Util is procedure Visit_Node (N : Node_Or_Entity_Id) is begin + pragma Assert (Nkind (N) not in N_Entity); + if Nkind (N) = N_Expression_With_Actions then EWA_Level := EWA_Level + 1; @@ -18117,41 +18594,27 @@ package body Sem_Util is N_Subprogram_Declaration) then EWA_Inner_Scope_Level := EWA_Inner_Scope_Level + 1; + end if; - -- Handle case of an Itype, which must be copied - - elsif Nkind (N) in N_Entity and then Is_Itype (N) then - - -- Nothing to do if already in the list. This can happen with an - -- Itype entity that appears more than once in the tree. Note that - -- we do not want to visit descendants in this case. - - if Present (NCT_Assoc.Get (Entity_Id (N))) then - return; - end if; - - Visit_Itype (N); - - -- Handle defining entities in Expression_With_Action nodes + Visit_Field + (Field => Field1 (N), + Par_Nod => N); - elsif Nkind (N) in N_Entity and then EWA_Level > 0 then + Visit_Field + (Field => Field2 (N), + Par_Nod => N); - -- Nothing to do if already in the hash table + Visit_Field + (Field => Field3 (N), + Par_Nod => N); - if Present (NCT_Assoc.Get (Entity_Id (N))) then - return; - end if; - - Visit_Entity (N); - end if; + Visit_Field + (Field => Field4 (N), + Par_Nod => N); - -- Visit descendants - - Visit_Field (Field1 (N), N); - Visit_Field (Field2 (N), N); - Visit_Field (Field3 (N), N); - Visit_Field (Field4 (N), N); - Visit_Field (Field5 (N), N); + Visit_Field + (Field => Field5 (N), + Par_Nod => N); if EWA_Level > 0 and then Nkind_In (N, N_Block_Statement, @@ -18165,57 +18628,171 @@ package body Sem_Util is end if; end Visit_Node; + --------------------------- + -- Visit_Semantic_Fields -- + --------------------------- + + procedure Visit_Semantic_Fields (Id : Entity_Id) is + begin + pragma Assert (Nkind (Id) in N_Entity); + + -- Discriminant_Constraint + + if Has_Discriminants (Base_Type (Id)) then + Visit_Field + (Field => Union_Id (Discriminant_Constraint (Id)), + Semantic => True); + end if; + + -- Etype + + Visit_Field + (Field => Union_Id (Etype (Id)), + Semantic => True); + + -- First_Index + -- Packed_Array_Impl_Type + + if Is_Array_Type (Id) then + if Present (First_Index (Id)) then + Visit_Field + (Field => Union_Id (List_Containing (First_Index (Id))), + Semantic => True); + end if; + + if Is_Packed (Id) then + Visit_Field + (Field => Union_Id (Packed_Array_Impl_Type (Id)), + Semantic => True); + end if; + end if; + + -- Scalar_Range + + if Is_Discrete_Type (Id) then + Visit_Field + (Field => Union_Id (Scalar_Range (Id)), + Semantic => True); + end if; + end Visit_Semantic_Fields; + -- Start of processing for New_Copy_Tree begin - Build_NCT_Hash_Tables; + -- Routine New_Copy_Tree performs a deep copy of a subtree by creating + -- shallow copies for each node within, and then updating the child and + -- parent pointers accordingly. This process is straightforward, however + -- the routine must deal with the following complications: - -- Hash table set up if required, now start phase one by visiting top - -- node (we will recursively visit the descendants). + -- * Entities defined within N_Expression_With_Actions nodes must be + -- replicated rather than shared to avoid introducing two identical + -- symbols within the same scope. Note that no other expression can + -- currently define entities. - Visit_Node (Source); + -- do + -- Source_Low : ...; + -- Source_High : ...; - -- Now the second phase of the copy can start. First we process all the - -- mapped entities, copying their descendants. + -- <reference to Source_Low> + -- <reference to Source_High> + -- in ... end; - if NCT_Hash_Tables_Used then - declare - Old_E : Entity_Id := Empty; - New_E : Entity_Id; + -- New_Copy_Tree handles this case by first creating new entities + -- and then updating all existing references to point to these new + -- entities. - begin - NCT_Assoc.Get_First (Old_E, New_E); - while Present (New_E) loop + -- do + -- New_Low : ...; + -- New_High : ...; - -- Skip entities that were not created in the first phase - -- (that is, old entities specified by the caller in the set of - -- mappings to be applied to the tree). + -- <reference to New_Low> + -- <reference to New_High> + -- in ... end; - if Is_Itype (New_E) - or else No (Map) - or else not In_Map (Old_E) - then - Copy_Entity_With_Replacement (New_E); - end if; + -- * Itypes defined within the subtree must be replicated to avoid any + -- dependencies on invalid or inaccessible data. - NCT_Assoc.Get_Next (Old_E, New_E); - end loop; - end; - end if; + -- subtype Source_Itype is ... range Source_Low .. Source_High; - -- Now we can copy the actual tree + -- New_Copy_Tree handles this case by first creating a new itype in + -- the same fashion as entities, and then updating various relevant + -- constraints. - declare - Result : constant Node_Id := Copy_Node_With_Replacement (Source); + -- subtype New_Itype is ... range New_Low .. New_High; - begin - if NCT_Hash_Tables_Used then - NCT_Assoc.Reset; - NCT_Itype_Assoc.Reset; - end if; + -- * The Associated_Node_For_Itype field of itypes must be updated to + -- reference the proper replicated entity or node. - return Result; - end; + -- * Semantic fields of entities such as Etype and Scope must be + -- updated to reference the proper replicated entities. + + -- * Semantic fields of nodes such as First_Real_Statement must be + -- updated to reference the proper replicated nodes. + + -- To meet all these demands, routine New_Copy_Tree is split into two + -- phases. + + -- Phase 1 traverses the tree in order to locate entities and itypes + -- defined within the subtree. New entities are generated and saved in + -- table NCT_New_Entities. The semantic fields of all new entities and + -- itypes are then updated accordingly. + + -- Phase 2 traverses the tree in order to replicate each node. Various + -- semantic fields of nodes and entities are updated accordingly. + + -- Preparatory phase. Clear the contents of tables NCT_New_Entities and + -- NCT_Pending_Itypes in case a previous call to New_Copy_Tree left some + -- data inside. + + NCT_New_Entities.Reset; + NCT_Pending_Itypes.Reset; + + -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with data + -- supplied by a linear entity map. The tables offer faster access to + -- the same data. + + Build_NCT_Tables (Map); + + -- Execute Phase 1. Traverse the subtree and generate new entities for + -- the following cases: + + -- * An entity defined within an N_Expression_With_Actions node + + -- * An itype referenced within the subtree where the associated node + -- is also in the subtree. + + -- All new entities are accessible via table NCT_New_Entities, which + -- contains mappings of the form: + + -- Old_Entity -> New_Entity + -- Old_Itype -> New_Itype + + -- In addition, the associated nodes of all new itypes are mapped in + -- table NCT_Pending_Itypes: + + -- Assoc_Nod -> (New_Itype1, New_Itype2, .., New_ItypeN) + + Visit_Any_Node (Source); + + -- Update the semantic attributes of all new entities generated during + -- Phase 1 before starting Phase 2. The updates could be performed in + -- routine Corresponding_Entity, however this may cause the same entity + -- to be updated multiple times, effectively generating useless nodes. + -- Keeping the updates separates from Phase 2 ensures that only one set + -- of attributes is generated for an entity at any one time. + + Update_New_Entities (Map); + + -- Execute Phase 2. Replicate the source subtree one node at a time. + -- The following transformations take place: + + -- * References to entities and itypes are updated to refer to the + -- new entities and itypes generated during Phase 1. + + -- * All Associated_Node_For_Itype attributes of itypes are updated + -- to refer to the new replicated Associated_Node_For_Itype. + + return Copy_Node_With_Replacement (Source); end New_Copy_Tree; ------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 7279c63..fab85f0 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1371,6 +1371,9 @@ package Sem_Util is -- appearing anywhere within such a construct (that is it does not need -- to be directly within). + function In_Subtree (Root : Node_Id; N : Node_Id) return Boolean; + -- Determine whether node N is within the subtree rooted at Root + function In_Visible_Part (Scope_Id : Entity_Id) return Boolean; -- Determine whether a declaration occurs within the visible part of a -- package specification. The package must be on the scope stack, and the @@ -2057,46 +2060,75 @@ package Sem_Util is Map : Elist_Id := No_Elist; New_Sloc : Source_Ptr := No_Location; New_Scope : Entity_Id := Empty) return Node_Id; - -- Given a node that is the root of a subtree, New_Copy_Tree copies the - -- entire syntactic subtree, including recursively any descendants whose - -- parent field references a copied node (descendants not linked to a - -- copied node by the parent field are not copied, instead the copied tree - -- references the same descendant as the original in this case, which is - -- appropriate for non-syntactic fields such as Etype). The parent pointers - -- in the copy are properly set. New_Copy_Tree (Empty/Error) returns - -- Empty/Error. The one exception to the rule of not copying semantic - -- fields is that any implicit types attached to the subtree are - -- duplicated, so that the copy contains a distinct set of implicit type - -- entities. Thus this function is used when it is necessary to duplicate - -- an analyzed tree, declared in the same or some other compilation unit. - -- This function is declared here rather than in atree because it uses - -- semantic information in particular concerning the structure of itypes - -- and the generation of public symbols. - - -- The Map argument, if set to a non-empty Elist, specifies a set of - -- mappings to be applied to entities in the tree. The map has the form: + -- Perform a deep copy of the subtree rooted at Source. Entities, itypes, + -- and nodes are handled separately as follows: + -- + -- * A node is replicated by first creating a shallow copy, then copying + -- its syntactic fields, where all Parent pointers of the fields are + -- updated to refer to the copy. In addition, the following semantic + -- fields are recreated after the replication takes place. + -- + -- First_Named_Actual + -- First_Real_Statement + -- Next_Named_Actual + -- + -- If applicable, the Etype field (if any) is updated to refer to a + -- local itype or type (see below). + -- + -- * An entity defined within an N_Expression_With_Actions node in the + -- subtree is given a new entity, and all references to the original + -- entity are updated to refer to the new entity. In addition, the + -- following semantic fields are replicated and/or updated to refer + -- to a local entity or itype. + -- + -- Discriminant_Constraint + -- Etype + -- First_Index + -- Next_Entity + -- Packed_Array_Impl_Type + -- Scalar_Range + -- Scope + -- + -- Note that currently no other expression can define entities. + -- + -- * An itype whose Associated_Node_For_Itype node is in the subtree + -- is given a new entity, and all references to the original itype + -- are updated to refer to the new itype. In addition, the following + -- semantic fields are replicated and/or updated to refer to a local + -- entity or itype. + -- + -- Discriminant_Constraint + -- Etype + -- First_Index + -- Next_Entity + -- Packed_Array_Impl_Type + -- Scalar_Range + -- Scope + -- + -- The Associated_Node_For_Itype is updated to refer to a replicated + -- node. + -- + -- The routine can replicate both analyzed and unanalyzed trees. Copying an + -- Empty or Error node yields the same node. -- - -- old entity 1 - -- new entity to replace references to entity 1 - -- old entity 2 - -- new entity to replace references to entity 2 - -- ... + -- Parameter Map may be used to specify a set of mappings between entities. + -- These mappings are then taken into account when replicating entities. + -- The format of Map must be as follows: -- - -- The call destroys the contents of Map in this case + -- old entity 1 + -- new entity to replace references to entity 1 + -- old entity 2 + -- new entity to replace references to entity 2 + -- ... -- - -- The parameter New_Sloc, if set to a value other than No_Location, is - -- used as the Sloc value for all nodes in the new copy. If New_Sloc is - -- set to its default value No_Location, then the Sloc values of the - -- nodes in the copy are simply copied from the corresponding original. + -- Map and its contents are left unchanged. -- - -- The Comes_From_Source indication is unchanged if New_Sloc is set to - -- the default No_Location value, but is reset if New_Sloc is given, since - -- in this case the result clearly is neither a source node or an exact - -- copy of a source node. + -- Parameter New_Sloc may be used to specify a new source location for all + -- replicated entities, itypes, and nodes. The Comes_From_Source indicator + -- is defaulted if a new source location is provided. -- - -- The parameter New_Scope, if set to a value other than Empty, is the - -- value to use as the Scope for any Itypes that are copied. The most - -- typical value for this parameter, if given, is Current_Scope. + -- Parameter New_Scope may be used to specify a new scope for all copied + -- entities and itypes. function New_External_Entity (Kind : Entity_Kind; @@ -2177,7 +2209,7 @@ package Sem_Util is -- allowed as actuals for this function. function Original_Aspect_Pragma_Name (N : Node_Id) return Name_Id; - -- Retrieve the name of aspect or pragma N taking into account a possible + -- Retrieve the name of aspect or pragma N, taking into account a possible -- rewrite and whether the pragma is generated from an aspect as the names -- may be different. The routine also deals with 'Class in which case it -- returns the following values: diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index a087dd2..cd6b200 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -1268,7 +1268,19 @@ package body Switch.C is Bad_Switch ("-gnatw." & Switch_Chars (Ptr .. Max)); end if; - -- Normal case, no dot + -- Case of underscore switch + + elsif C = '_' and then Ptr < Max then + Ptr := Ptr + 1; + C := Switch_Chars (Ptr); + + if Set_Underscore_Warning_Switch (C) then + Store_Compilation_Switch ("-gnatw_" & C); + else + Bad_Switch ("-gnatw_" & Switch_Chars (Ptr .. Max)); + end if; + + -- Normal case, no dot else if Set_Warning_Switch (C) then diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 1c50c7d..bb712cc 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -549,6 +549,10 @@ begin "missing parenthesis"); Write_Line (" Q turn off warnings for questionable " & "missing parenthesis"); + Write_Line (" .q+ turn on warnings for questionable layout of " & + "record types"); + Write_Line (" .Q* turn off warnings for questionable layout of " & + "record types"); Write_Line (" r+ turn on warnings for redundant construct"); Write_Line (" R* turn off warnings for redundant construct"); Write_Line (" .r+ turn on warnings for object renaming function"); diff --git a/gcc/ada/warnsw.adb b/gcc/ada/warnsw.adb index 461f300..c1b91f1 100644 --- a/gcc/ada/warnsw.adb +++ b/gcc/ada/warnsw.adb @@ -471,6 +471,24 @@ package body Warnsw is return True; end Set_Dot_Warning_Switch; + ----------------------------------- + -- Set_Underscore_Warning_Switch -- + ----------------------------------- + + function Set_Underscore_Warning_Switch (C : Character) return Boolean is + begin + case C is + when others => + if Ignore_Unrecognized_VWY_Switches then + Write_Line ("unrecognized switch -gnatw_" & C & " ignored"); + else + return False; + end if; + end case; + + return True; + end Set_Underscore_Warning_Switch; + ---------------------------- -- Set_GNAT_Mode_Warnings -- ---------------------------- diff --git a/gcc/ada/warnsw.ads b/gcc/ada/warnsw.ads index 53332a7..af9defb 100644 --- a/gcc/ada/warnsw.ads +++ b/gcc/ada/warnsw.ads @@ -147,6 +147,13 @@ package Warnsw is -- the command line or .C in a string literal in pragma Warnings. Returns -- True for valid warning character C, False for invalid character. + function Set_Underscore_Warning_Switch (C : Character) return Boolean; + -- This function sets the warning switch or switches corresponding to the + -- given character preceded by an underscore. Used to process a -gnatw_ + -- switch on the command line or _C in a string literal in pragma Warnings. + -- Returns True for valid warnings character C, False for invalid + -- character. + procedure Set_GNAT_Mode_Warnings; -- This is called in -gnatg mode to set the warnings for gnat mode. It is -- also used to set the proper warning statuses for -gnatw.g. Note that |