diff options
| -rw-r--r-- | gcc/ada/atree.adb | 81 | ||||
| -rw-r--r-- | gcc/ada/atree.ads | 18 | ||||
| -rw-r--r-- | gcc/ada/checks.adb | 14 | ||||
| -rw-r--r-- | gcc/ada/errout.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 278 |
5 files changed, 232 insertions, 172 deletions
diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 322528c4..414fd62 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -2624,12 +2624,12 @@ package body Atree is -- Traverse_Func -- ------------------- - function Traverse_Func (Node : Node_Id) return Traverse_Result is + function Traverse_Func (Node : Node_Id) return Traverse_Final_Result is function Traverse_Field (Nod : Node_Id; Fld : Union_Id; - FN : Field_Num) return Traverse_Result; + FN : Field_Num) return Traverse_Final_Result; -- Fld is one of the fields of Nod. If the field points to syntactic -- node or list, then this node or list is traversed, and the result is -- the result of this traversal. Otherwise a value of True is returned @@ -2642,7 +2642,7 @@ package body Atree is function Traverse_Field (Nod : Node_Id; Fld : Union_Id; - FN : Field_Num) return Traverse_Result + FN : Field_Num) return Traverse_Final_Result is begin if Fld = Union_Id (Empty) then @@ -2697,10 +2697,21 @@ package body Atree is end if; end Traverse_Field; + Cur_Node : Node_Id := Node; + -- Start of processing for Traverse_Func begin - case Process (Node) is + -- We walk Field2 last, and if it is a node, we eliminate the tail + -- recursion by jumping back to this label. This is because Field2 is + -- where the Left_Opnd field of N_Op_Concat is stored, and in practice + -- concatenations are sometimes deeply nested, as in X1&X2&...&XN. This + -- trick prevents us from running out of memory in that case. We don't + -- bother eliminating the tail recursion if Field2 is a list. + + <<Tail_Recurse>> + + case Process (Cur_Node) is when Abandon => return Abandon; @@ -2708,41 +2719,37 @@ package body Atree is return OK; when OK => - if Traverse_Field (Node, Union_Id (Field1 (Node)), 1) = Abandon - or else - Traverse_Field (Node, Union_Id (Field2 (Node)), 2) = Abandon - or else - Traverse_Field (Node, Union_Id (Field3 (Node)), 3) = Abandon - or else - Traverse_Field (Node, Union_Id (Field4 (Node)), 4) = Abandon - or else - Traverse_Field (Node, Union_Id (Field5 (Node)), 5) = Abandon - then - return Abandon; - else - return OK; - end if; + null; when OK_Orig => - declare - Onod : constant Node_Id := Original_Node (Node); - begin - if Traverse_Field (Onod, Union_Id (Field1 (Onod)), 1) = Abandon - or else - Traverse_Field (Onod, Union_Id (Field2 (Onod)), 2) = Abandon - or else - Traverse_Field (Onod, Union_Id (Field3 (Onod)), 3) = Abandon - or else - Traverse_Field (Onod, Union_Id (Field4 (Onod)), 4) = Abandon - or else - Traverse_Field (Onod, Union_Id (Field5 (Onod)), 5) = Abandon - then - return Abandon; - else - return OK_Orig; - end if; - end; + Cur_Node := Original_Node (Cur_Node); end case; + + if Traverse_Field (Cur_Node, Field1 (Cur_Node), 1) = Abandon + or else -- skip Field2 here + Traverse_Field (Cur_Node, Field3 (Cur_Node), 3) = Abandon + or else + Traverse_Field (Cur_Node, Field4 (Cur_Node), 4) = Abandon + or else + Traverse_Field (Cur_Node, Field5 (Cur_Node), 5) = Abandon + then + return Abandon; + end if; + + if Field2 (Cur_Node) not in Node_Range then + return Traverse_Field (Cur_Node, Field2 (Cur_Node), 2); + elsif Is_Syntactic_Field (Nkind (Cur_Node), 2) and then + Field2 (Cur_Node) /= Empty_List_Or_Node + then + -- Here is the tail recursion step, we reset Cur_Node and jump + -- back to the start of the procedure, which has the same + -- semantic effect as a call. + + Cur_Node := Node_Id (Field2 (Cur_Node)); + goto Tail_Recurse; + end if; + + return OK; end Traverse_Func; ------------------- @@ -2751,7 +2758,7 @@ package body Atree is procedure Traverse_Proc (Node : Node_Id) is function Traverse is new Traverse_Func (Process); - Discard : Traverse_Result; + Discard : Traverse_Final_Result; pragma Warnings (Off, Discard); begin Discard := Traverse (Node); diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index b99d349..ab9fdb4 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -503,18 +503,22 @@ package Atree is -- function is used only by Sinfo.CN to change nodes into their -- corresponding entities. - type Traverse_Result is (OK, OK_Orig, Skip, Abandon); + type Traverse_Result is (Abandon, OK, OK_Orig, Skip); -- This is the type of the result returned by the Process function passed - -- to Traverse_Func and Traverse_Proc and also the type of the result of - -- Traverse_Func itself. See descriptions below for details. + -- to Traverse_Func and Traverse_Proc. See below for details. + + subtype Traverse_Final_Result is Traverse_Result range Abandon .. OK; + -- This is the type of the final result returned Traverse_Func, based on + -- the results of Process calls. See below for details. generic with function Process (N : Node_Id) return Traverse_Result is <>; - function Traverse_Func (Node : Node_Id) return Traverse_Result; + function Traverse_Func (Node : Node_Id) return Traverse_Final_Result; -- This is a generic function that, given the parent node for a subtree, -- traverses all syntactic nodes of this tree, calling the given function - -- Process on each one. The traversal is controlled as follows by the - -- result returned by Process: + -- Process on each one, in pre order (i.e. top-down). The order of + -- traversing subtrees is arbitrary. The traversal is controlled as follows + -- by the result returned by Process: -- OK The traversal continues normally with the syntactic -- children of the node just processed. @@ -537,7 +541,7 @@ package Atree is with function Process (N : Node_Id) return Traverse_Result is <>; procedure Traverse_Proc (Node : Node_Id); pragma Inline (Traverse_Proc); - -- This is similar to Traverse_Func except that no result is returned, + -- This is the same as Traverse_Func except that no result is returned, -- i.e. Traverse_Func is called and the result is simply discarded. --------------------------- diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 7395594..b179fff 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -2360,7 +2360,6 @@ package body Checks is Analyze_And_Resolve (N, Typ); return; end if; - end Apply_Universal_Integer_Attribute_Checks; ------------------------------- @@ -5366,14 +5365,11 @@ package body Checks is ------------------- procedure Remove_Checks (Expr : Node_Id) is - Discard : Traverse_Result; - pragma Warnings (Off, Discard); - function Process (N : Node_Id) return Traverse_Result; -- Process a single node during the traversal - function Traverse is new Traverse_Func (Process); - -- The traversal function itself + procedure Traverse is new Traverse_Proc (Process); + -- The traversal procedure itself ------------- -- Process -- @@ -5389,7 +5385,7 @@ package body Checks is case Nkind (N) is when N_And_Then => - Discard := Traverse (Left_Opnd (N)); + Traverse (Left_Opnd (N)); return Skip; when N_Attribute_Reference => @@ -5425,7 +5421,7 @@ package body Checks is end case; when N_Or_Else => - Discard := Traverse (Left_Opnd (N)); + Traverse (Left_Opnd (N)); return Skip; when N_Selected_Component => @@ -5446,7 +5442,7 @@ package body Checks is -- Start of processing for Remove_Checks begin - Discard := Traverse (Expr); + Traverse (Expr); end Remove_Checks; ---------------------------- diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index adf6435..e0f6492 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -1235,15 +1235,12 @@ package body Errout is Sfile : constant Source_File_Index := Get_Source_File_Index (L); Earliest : Node_Id; Eloc : Source_Ptr; - Discard : Traverse_Result; - - pragma Warnings (Off, Discard); function Test_Earlier (N : Node_Id) return Traverse_Result; -- Function applied to every node in the construct - function Search_Tree_First is new Traverse_Func (Test_Earlier); - -- Create traversal function + procedure Search_Tree_First is new Traverse_Proc (Test_Earlier); + -- Create traversal procedure ------------------ -- Test_Earlier -- @@ -1273,7 +1270,7 @@ package body Errout is begin Earliest := Original_Node (C); Eloc := Sloc (Earliest); - Discard := Search_Tree_First (Original_Node (C)); + Search_Tree_First (Original_Node (C)); return Earliest; end First_Node; @@ -1982,7 +1979,7 @@ package body Errout is -- to the tree is harmless. declare - Status : Traverse_Result; + Status : Traverse_Final_Result; begin if Is_List_Member (N) then @@ -2006,7 +2003,7 @@ package body Errout is begin if Warnings_Detected /= 0 then declare - Discard : Traverse_Result; + Discard : Traverse_Final_Result; pragma Warnings (Off, Discard); begin diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 523a883..a741c46 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -131,6 +131,23 @@ package body Sem_Res is -- of the task, it must be replaced with a reference to the discriminant -- of the task being called. + procedure Resolve_Op_Concat_Arg + (N : Node_Id; + Arg : Node_Id; + Typ : Entity_Id; + Is_Comp : Boolean); + -- Internal procedure for Resolve_Op_Concat to resolve one operand of + -- concatenation operator. The operand is either of the array type or of + -- the component type. If the operand is an aggregate, and the component + -- type is composite, this is ambiguous if component type has aggregates. + + procedure Resolve_Op_Concat_First (N : Node_Id; Typ : Entity_Id); + -- Does the first part of the work of Resolve_Op_Concat + + procedure Resolve_Op_Concat_Rest (N : Node_Id; Typ : Entity_Id); + -- Does the "rest" of the work of Resolve_Op_Concat, after the left operand + -- has been resolved. See Resolve_Op_Concat for details. + procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id); procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id); procedure Resolve_Call (N : Node_Id; Typ : Entity_Id); @@ -6354,116 +6371,167 @@ package body Sem_Res is ----------------------- procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id) is - Btyp : constant Entity_Id := Base_Type (Typ); - Op1 : constant Node_Id := Left_Opnd (N); - Op2 : constant Node_Id := Right_Opnd (N); - procedure Resolve_Concatenation_Arg (Arg : Node_Id; Is_Comp : Boolean); - -- Internal procedure to resolve one operand of concatenation operator. - -- The operand is either of the array type or of the component type. - -- If the operand is an aggregate, and the component type is composite, - -- this is ambiguous if component type has aggregates. + -- We wish to avoid deep recursion, because concatenations are often + -- deeply nested, as in A&B&...&Z. Therefore, we walk down the left + -- operands nonrecursively until we find something that is not a simple + -- concatenation (A in this case). We resolve that, and then walk back + -- up the tree following Parent pointers, calling Resolve_Op_Concat_Rest + -- to do the rest of the work at each level. The Parent pointers allow + -- us to avoid recursion, and thus avoid running out of memory. See also + -- Sem_Ch4.Analyze_Concatenation, where a similar hack is used. - ------------------------------- - -- Resolve_Concatenation_Arg -- - ------------------------------- - - procedure Resolve_Concatenation_Arg (Arg : Node_Id; Is_Comp : Boolean) is - begin - if In_Instance then - if Is_Comp - or else (not Is_Overloaded (Arg) - and then Etype (Arg) /= Any_Composite - and then Covers (Component_Type (Typ), Etype (Arg))) - then - Resolve (Arg, Component_Type (Typ)); - else - Resolve (Arg, Btyp); - end if; + NN : Node_Id := N; + Op1 : Node_Id; - elsif Has_Compatible_Type (Arg, Component_Type (Typ)) then + begin + -- The following code is equivalent to: - if Nkind (Arg) = N_Aggregate - and then Is_Composite_Type (Component_Type (Typ)) - then - if Is_Private_Type (Component_Type (Typ)) then - Resolve (Arg, Btyp); + -- Resolve_Op_Concat_First (NN, Typ); + -- Resolve_Op_Concat_Arg (N, ...); + -- Resolve_Op_Concat_Rest (N, Typ); - else - Error_Msg_N ("ambiguous aggregate must be qualified", Arg); - Set_Etype (Arg, Any_Type); - end if; + -- where the Resolve_Op_Concat_Arg call recurses back here if the left + -- operand is a concatenation. - else - if Is_Overloaded (Arg) - and then Has_Compatible_Type (Arg, Typ) - and then Etype (Arg) /= Any_Type - then + -- Walk down left operands - declare - I : Interp_Index; - It : Interp; - Func : Entity_Id; + loop + Resolve_Op_Concat_First (NN, Typ); + Op1 := Left_Opnd (NN); + exit when not (Nkind (Op1) = N_Op_Concat + and then not Is_Array_Type (Component_Type (Typ)) + and then Entity (Op1) = Entity (NN)); + NN := Op1; + end loop; - begin - Get_First_Interp (Arg, I, It); - Func := It.Nam; - Get_Next_Interp (I, It); + -- Now (given the above example) NN is A&B and Op1 is A - -- Special-case the error message when the overloading - -- is caused by a function that yields and array and - -- can be called without parameters. + -- First resolve Op1 ... - if It.Nam = Func then - Error_Msg_Sloc := Sloc (Func); - Error_Msg_N ("ambiguous call to function#", Arg); - Error_Msg_NE - ("\\interpretation as call yields&", Arg, Typ); - Error_Msg_NE - ("\\interpretation as indexing of call yields&", - Arg, Component_Type (Typ)); + Resolve_Op_Concat_Arg (NN, Op1, Typ, Is_Component_Left_Opnd (NN)); - else - Error_Msg_N - ("ambiguous operand for concatenation!", Arg); - Get_First_Interp (Arg, I, It); - while Present (It.Nam) loop - Error_Msg_Sloc := Sloc (It.Nam); + -- ... then walk NN back up until we reach N (where we started), calling + -- Resolve_Op_Concat_Rest along the way. - if Base_Type (It.Typ) = Base_Type (Typ) - or else Base_Type (It.Typ) = - Base_Type (Component_Type (Typ)) - then - Error_Msg_N ("\\possible interpretation#", Arg); - end if; + loop + Resolve_Op_Concat_Rest (NN, Typ); + exit when NN = N; + NN := Parent (NN); + end loop; + end Resolve_Op_Concat; - Get_Next_Interp (I, It); - end loop; - end if; - end; - end if; + --------------------------- + -- Resolve_Op_Concat_Arg -- + --------------------------- - Resolve (Arg, Component_Type (Typ)); + procedure Resolve_Op_Concat_Arg + (N : Node_Id; + Arg : Node_Id; + Typ : Entity_Id; + Is_Comp : Boolean) + is + Btyp : constant Entity_Id := Base_Type (Typ); - if Nkind (Arg) = N_String_Literal then - Set_Etype (Arg, Component_Type (Typ)); - end if; + begin + if In_Instance then + if Is_Comp + or else (not Is_Overloaded (Arg) + and then Etype (Arg) /= Any_Composite + and then Covers (Component_Type (Typ), Etype (Arg))) + then + Resolve (Arg, Component_Type (Typ)); + else + Resolve (Arg, Btyp); + end if; - if Arg = Left_Opnd (N) then - Set_Is_Component_Left_Opnd (N); - else - Set_Is_Component_Right_Opnd (N); - end if; + elsif Has_Compatible_Type (Arg, Component_Type (Typ)) then + if Nkind (Arg) = N_Aggregate + and then Is_Composite_Type (Component_Type (Typ)) + then + if Is_Private_Type (Component_Type (Typ)) then + Resolve (Arg, Btyp); + else + Error_Msg_N ("ambiguous aggregate must be qualified", Arg); + Set_Etype (Arg, Any_Type); end if; else - Resolve (Arg, Btyp); + if Is_Overloaded (Arg) + and then Has_Compatible_Type (Arg, Typ) + and then Etype (Arg) /= Any_Type + then + declare + I : Interp_Index; + It : Interp; + Func : Entity_Id; + + begin + Get_First_Interp (Arg, I, It); + Func := It.Nam; + Get_Next_Interp (I, It); + + -- Special-case the error message when the overloading is + -- caused by a function that yields an array and can be + -- called without parameters. + + if It.Nam = Func then + Error_Msg_Sloc := Sloc (Func); + Error_Msg_N ("ambiguous call to function#", Arg); + Error_Msg_NE + ("\\interpretation as call yields&", Arg, Typ); + Error_Msg_NE + ("\\interpretation as indexing of call yields&", + Arg, Component_Type (Typ)); + + else + Error_Msg_N + ("ambiguous operand for concatenation!", Arg); + Get_First_Interp (Arg, I, It); + while Present (It.Nam) loop + Error_Msg_Sloc := Sloc (It.Nam); + + if Base_Type (It.Typ) = Base_Type (Typ) + or else Base_Type (It.Typ) = + Base_Type (Component_Type (Typ)) + then + Error_Msg_N ("\\possible interpretation#", Arg); + end if; + + Get_Next_Interp (I, It); + end loop; + end if; + end; + end if; + + Resolve (Arg, Component_Type (Typ)); + + if Nkind (Arg) = N_String_Literal then + Set_Etype (Arg, Component_Type (Typ)); + end if; + + if Arg = Left_Opnd (N) then + Set_Is_Component_Left_Opnd (N); + else + Set_Is_Component_Right_Opnd (N); + end if; end if; - Check_Unset_Reference (Arg); - end Resolve_Concatenation_Arg; + else + Resolve (Arg, Btyp); + end if; - -- Start of processing for Resolve_Op_Concat + Check_Unset_Reference (Arg); + end Resolve_Op_Concat_Arg; + + ----------------------------- + -- Resolve_Op_Concat_First -- + ----------------------------- + + procedure Resolve_Op_Concat_First (N : Node_Id; Typ : Entity_Id) is + Btyp : constant Entity_Id := Base_Type (Typ); + Op1 : constant Node_Id := Left_Opnd (N); + Op2 : constant Node_Id := Right_Opnd (N); begin -- The parser folds an enormous sequence of concatenations of string @@ -6488,30 +6556,18 @@ package body Sem_Res is Error_Msg_N ("concatenation not available for limited array", N); Explain_Limited_Type (Btyp, N); end if; + end Resolve_Op_Concat_First; - -- If the operands are themselves concatenations, resolve them as such - -- directly. This removes several layers of recursion and allows GNAT to - -- handle larger multiple concatenations. + ---------------------------- + -- Resolve_Op_Concat_Rest -- + ---------------------------- - if Nkind (Op1) = N_Op_Concat - and then not Is_Array_Type (Component_Type (Typ)) - and then Entity (Op1) = Entity (N) - then - Resolve_Op_Concat (Op1, Typ); - else - Resolve_Concatenation_Arg - (Op1, Is_Component_Left_Opnd (N)); - end if; + procedure Resolve_Op_Concat_Rest (N : Node_Id; Typ : Entity_Id) is + Op1 : constant Node_Id := Left_Opnd (N); + Op2 : constant Node_Id := Right_Opnd (N); - if Nkind (Op2) = N_Op_Concat - and then not Is_Array_Type (Component_Type (Typ)) - and then Entity (Op2) = Entity (N) - then - Resolve_Op_Concat (Op2, Typ); - else - Resolve_Concatenation_Arg - (Op2, Is_Component_Right_Opnd (N)); - end if; + begin + Resolve_Op_Concat_Arg (N, Op2, Typ, Is_Component_Right_Opnd (N)); Generate_Operator_Reference (N, Typ); @@ -6520,7 +6576,7 @@ package body Sem_Res is end if; -- If this is not a static concatenation, but the result is a - -- string type (and not an array of strings) insure that static + -- string type (and not an array of strings) ensure that static -- string operands have their subtypes properly constructed. if Nkind (N) /= N_String_Literal @@ -6529,7 +6585,7 @@ package body Sem_Res is Set_String_Literal_Subtype (Op1, Typ); Set_String_Literal_Subtype (Op2, Typ); end if; - end Resolve_Op_Concat; + end Resolve_Op_Concat_Rest; ---------------------- -- Resolve_Op_Expon -- |