From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/ada/par-labl.adb | 541 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 541 insertions(+) create mode 100644 gcc/ada/par-labl.adb (limited to 'gcc/ada/par-labl.adb') diff --git a/gcc/ada/par-labl.adb b/gcc/ada/par-labl.adb new file mode 100644 index 000000000..8520292ec --- /dev/null +++ b/gcc/ada/par-labl.adb @@ -0,0 +1,541 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . L A B L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +separate (Par) +procedure Labl is + Enclosing_Body_Or_Block : Node_Id; + -- Innermost enclosing body or block statement + + Label_Decl_Node : Node_Id; + -- Implicit label declaration node + + Defining_Ident_Node : Node_Id; + -- Defining identifier node for implicit label declaration + + Next_Label_Elmt : Elmt_Id; + -- Next element on label element list + + Label_Node : Node_Id; + -- Next label node to process + + function Find_Enclosing_Body_Or_Block (N : Node_Id) return Node_Id; + -- Find the innermost body or block that encloses N + + function Find_Enclosing_Body (N : Node_Id) return Node_Id; + -- Find the innermost body that encloses N + + procedure Check_Distinct_Labels; + -- Checks the rule in RM-5.1(11), which requires distinct identifiers + -- for all the labels in a given body. + + procedure Find_Natural_Loops; + -- Recognizes loops created by backward gotos, and rewrites the + -- corresponding statements into a proper loop, for optimization + -- purposes (for example, to control reclaiming local storage). + + --------------------------- + -- Check_Distinct_Labels -- + --------------------------- + + procedure Check_Distinct_Labels is + Label_Id : constant Node_Id := Identifier (Label_Node); + + Enclosing_Body : constant Node_Id := + Find_Enclosing_Body (Enclosing_Body_Or_Block); + -- Innermost enclosing body + + Next_Other_Label_Elmt : Elmt_Id := First_Elmt (Label_List); + -- Next element on label element list + + Other_Label : Node_Id; + -- Next label node to process + + begin + -- Loop through all the labels, and if we find some other label + -- (i.e. not Label_Node) that has the same identifier, + -- and whose innermost enclosing body is the same, + -- then we have an error. + + -- Note that in the worst case, this is quadratic in the number + -- of labels. However, labels are not all that common, and this + -- is only called for explicit labels. + -- ???Nonetheless, the efficiency could be improved. For example, + -- call Labl for each body, rather than once per compilation. + + while Present (Next_Other_Label_Elmt) loop + Other_Label := Node (Next_Other_Label_Elmt); + + exit when Label_Node = Other_Label; + + if Chars (Label_Id) = Chars (Identifier (Other_Label)) + and then Enclosing_Body = Find_Enclosing_Body (Other_Label) + then + Error_Msg_Sloc := Sloc (Other_Label); + Error_Msg_N ("& conflicts with label#", Label_Id); + exit; + end if; + + Next_Elmt (Next_Other_Label_Elmt); + end loop; + end Check_Distinct_Labels; + + ------------------------- + -- Find_Enclosing_Body -- + ------------------------- + + function Find_Enclosing_Body (N : Node_Id) return Node_Id is + Result : Node_Id := N; + + begin + -- This is the same as Find_Enclosing_Body_Or_Block, except + -- that we skip block statements and accept statements, instead + -- of stopping at them. + + while Present (Result) + and then Nkind (Result) /= N_Entry_Body + and then Nkind (Result) /= N_Task_Body + and then Nkind (Result) /= N_Package_Body + and then Nkind (Result) /= N_Subprogram_Body + loop + Result := Parent (Result); + end loop; + + return Result; + end Find_Enclosing_Body; + + ---------------------------------- + -- Find_Enclosing_Body_Or_Block -- + ---------------------------------- + + function Find_Enclosing_Body_Or_Block (N : Node_Id) return Node_Id is + Result : Node_Id := Parent (N); + + begin + -- Climb up the parent chain until we find a body or block + + while Present (Result) + and then Nkind (Result) /= N_Accept_Statement + and then Nkind (Result) /= N_Entry_Body + and then Nkind (Result) /= N_Task_Body + and then Nkind (Result) /= N_Package_Body + and then Nkind (Result) /= N_Subprogram_Body + and then Nkind (Result) /= N_Block_Statement + loop + Result := Parent (Result); + end loop; + + return Result; + end Find_Enclosing_Body_Or_Block; + + ------------------------ + -- Find_Natural_Loops -- + ------------------------ + + procedure Find_Natural_Loops is + Node_List : constant Elist_Id := New_Elmt_List; + N : Elmt_Id; + Succ : Elmt_Id; + + function Goto_Id (Goto_Node : Node_Id) return Name_Id; + -- Find Name_Id of goto statement, which may be an expanded name + + function Matches + (Label_Node : Node_Id; + Goto_Node : Node_Id) return Boolean; + -- A label and a goto are candidates for a loop if the names match, + -- and both nodes appear in the same body. In addition, both must + -- appear in the same statement list. If they are not in the same + -- statement list, the goto is from within an nested structure, and + -- the label is not a header. We ignore the case where the goto is + -- within a conditional structure, and capture only infinite loops. + + procedure Merge; + -- Merge labels and goto statements in order of increasing sloc value. + -- Discard labels of loop and block statements. + + procedure No_Header (N : Elmt_Id); + -- The label N is known not to be a loop header. Scan forward and + -- remove all subsequent gotos that may have this node as a target. + + procedure Process_Goto (N : Elmt_Id); + -- N is a forward jump. Scan forward and remove all subsequent gotos + -- that may have the same target, to preclude spurious loops. + + procedure Rewrite_As_Loop + (Loop_Header : Node_Id; + Loop_End : Node_Id); + -- Given a label and a backwards goto, rewrite intervening statements + -- as a loop. Remove the label from the node list, and rewrite the + -- goto with the body of the new loop. + + procedure Try_Loop (N : Elmt_Id); + -- N is a label that may be a loop header. Scan forward to find some + -- backwards goto with which to make a loop. Do nothing if there is + -- an intervening label that is not part of a loop, or more than one + -- goto with this target. + + ------------- + -- Goto_Id -- + ------------- + + function Goto_Id (Goto_Node : Node_Id) return Name_Id is + begin + if Nkind (Name (Goto_Node)) = N_Identifier then + return Chars (Name (Goto_Node)); + + elsif Nkind (Name (Goto_Node)) = N_Selected_Component then + return Chars (Selector_Name (Name (Goto_Node))); + else + + -- In case of error, return Id that can't match anything + + return Name_Null; + end if; + end Goto_Id; + + ------------- + -- Matches -- + ------------- + + function Matches + (Label_Node : Node_Id; + Goto_Node : Node_Id) return Boolean + is + begin + return Chars (Identifier (Label_Node)) = Goto_Id (Goto_Node) + and then Find_Enclosing_Body (Label_Node) = + Find_Enclosing_Body (Goto_Node); + end Matches; + + ----------- + -- Merge -- + ----------- + + procedure Merge is + L1 : Elmt_Id; + G1 : Elmt_Id; + + begin + L1 := First_Elmt (Label_List); + G1 := First_Elmt (Goto_List); + + while Present (L1) + and then Present (G1) + loop + if Sloc (Node (L1)) < Sloc (Node (G1)) then + + -- Optimization: remove labels of loops and blocks, which + -- play no role in what follows. + + if Nkind (Node (L1)) /= N_Loop_Statement + and then Nkind (Node (L1)) /= N_Block_Statement + then + Append_Elmt (Node (L1), Node_List); + end if; + + Next_Elmt (L1); + + else + Append_Elmt (Node (G1), Node_List); + Next_Elmt (G1); + end if; + end loop; + + while Present (L1) loop + Append_Elmt (Node (L1), Node_List); + Next_Elmt (L1); + end loop; + + while Present (G1) loop + Append_Elmt (Node (G1), Node_List); + Next_Elmt (G1); + end loop; + end Merge; + + --------------- + -- No_Header -- + --------------- + + procedure No_Header (N : Elmt_Id) is + S1, S2 : Elmt_Id; + + begin + S1 := Next_Elmt (N); + while Present (S1) loop + S2 := Next_Elmt (S1); + if Nkind (Node (S1)) = N_Goto_Statement + and then Matches (Node (N), Node (S1)) + then + Remove_Elmt (Node_List, S1); + end if; + + S1 := S2; + end loop; + end No_Header; + + ------------------ + -- Process_Goto -- + ------------------ + + procedure Process_Goto (N : Elmt_Id) is + Goto1 : constant Node_Id := Node (N); + Goto2 : Node_Id; + S, S1 : Elmt_Id; + + begin + S := Next_Elmt (N); + + while Present (S) loop + S1 := Next_Elmt (S); + Goto2 := Node (S); + + if Nkind (Goto2) = N_Goto_Statement + and then Goto_Id (Goto1) = Goto_Id (Goto2) + and then Find_Enclosing_Body (Goto1) = + Find_Enclosing_Body (Goto2) + then + + -- Goto2 may have the same target, remove it from + -- consideration. + + Remove_Elmt (Node_List, S); + end if; + + S := S1; + end loop; + end Process_Goto; + + --------------------- + -- Rewrite_As_Loop -- + --------------------- + + procedure Rewrite_As_Loop + (Loop_Header : Node_Id; + Loop_End : Node_Id) + is + Loop_Body : constant List_Id := New_List; + Loop_Stmt : constant Node_Id := + New_Node (N_Loop_Statement, Sloc (Loop_Header)); + Stat : Node_Id; + Next_Stat : Node_Id; + begin + Stat := Next (Loop_Header); + while Stat /= Loop_End loop + Next_Stat := Next (Stat); + Remove (Stat); + Append (Stat, Loop_Body); + Stat := Next_Stat; + end loop; + + Set_Statements (Loop_Stmt, Loop_Body); + Set_Identifier (Loop_Stmt, Identifier (Loop_Header)); + + Remove (Loop_Header); + Rewrite (Loop_End, Loop_Stmt); + Error_Msg_N + ("code between label and backwards goto rewritten as loop?", + Loop_End); + end Rewrite_As_Loop; + + -------------- + -- Try_Loop -- + -------------- + + procedure Try_Loop (N : Elmt_Id) is + Source : Elmt_Id; + Found : Boolean := False; + S1 : Elmt_Id; + + begin + S1 := Next_Elmt (N); + while Present (S1) loop + if Nkind (Node (S1)) = N_Goto_Statement + and then Matches (Node (N), Node (S1)) + then + if not Found then + + -- If the label and the goto are both in the same statement + -- list, then we've found a loop. Note that labels and goto + -- statements are always part of some list, so In_Same_List + -- always makes sense. + + if In_Same_List (Node (N), Node (S1)) then + Source := S1; + Found := True; + + -- The goto is within some nested structure + + else + No_Header (N); + return; + end if; + + else + -- More than one goto with the same target + + No_Header (N); + return; + end if; + + elsif Nkind (Node (S1)) = N_Label + and then not Found + then + -- Intervening label before possible end of loop. Current + -- label is not a candidate. This is conservative, because + -- the label might not be the target of any jumps, but not + -- worth dealing with useless labels! + + No_Header (N); + return; + + else + -- If the node is a loop_statement, it corresponds to a + -- label-goto pair rewritten as a loop. Continue forward scan. + + null; + end if; + + Next_Elmt (S1); + end loop; + + if Found then + Rewrite_As_Loop (Node (N), Node (Source)); + Remove_Elmt (Node_List, N); + Remove_Elmt (Node_List, Source); + end if; + end Try_Loop; + + begin + -- Start of processing for Find_Natural_Loops + + Merge; + + N := First_Elmt (Node_List); + while Present (N) loop + Succ := Next_Elmt (N); + + if Nkind (Node (N)) = N_Label then + if No (Succ) then + exit; + + elsif Nkind (Node (Succ)) = N_Label then + Try_Loop (Succ); + + -- If a loop was found, the label has been removed, and + -- the following goto rewritten as the loop body. + + Succ := Next_Elmt (N); + + if Nkind (Node (Succ)) = N_Label then + + -- Following label was not removed, so current label + -- is not a candidate header. + + No_Header (N); + + else + + -- Following label was part of inner loop. Current + -- label is still a candidate. + + Try_Loop (N); + Succ := Next_Elmt (N); + end if; + + elsif Nkind (Node (Succ)) = N_Goto_Statement then + Try_Loop (N); + Succ := Next_Elmt (N); + end if; + + elsif Nkind (Node (N)) = N_Goto_Statement then + Process_Goto (N); + Succ := Next_Elmt (N); + end if; + + N := Succ; + end loop; + end Find_Natural_Loops; + +-- Start of processing for Par.Labl + +begin + Next_Label_Elmt := First_Elmt (Label_List); + while Present (Next_Label_Elmt) loop + Label_Node := Node (Next_Label_Elmt); + + if not Comes_From_Source (Label_Node) then + goto Next_Label; + end if; + + -- Find the innermost enclosing body or block, which is where + -- we need to implicitly declare this label + + Enclosing_Body_Or_Block := Find_Enclosing_Body_Or_Block (Label_Node); + + -- If we didn't find a parent, then the label in question never got + -- hooked into a reasonable declarative part. This happens only in + -- error situations, and we simply ignore the entry (we aren't going + -- to get into the semantics in any case given the error). + + if Present (Enclosing_Body_Or_Block) then + Check_Distinct_Labels; + + -- Now create the implicit label declaration node and its + -- corresponding defining identifier. Note that the defining + -- occurrence of a label is the implicit label declaration that + -- we are creating. The label itself is an applied occurrence. + + Label_Decl_Node := + New_Node (N_Implicit_Label_Declaration, Sloc (Label_Node)); + Defining_Ident_Node := + New_Entity (N_Defining_Identifier, Sloc (Identifier (Label_Node))); + Set_Chars (Defining_Ident_Node, Chars (Identifier (Label_Node))); + Set_Defining_Identifier (Label_Decl_Node, Defining_Ident_Node); + Set_Label_Construct (Label_Decl_Node, Label_Node); + + -- The following makes sure that Comes_From_Source is appropriately + -- set for the entity, depending on whether the label appeared in + -- the source explicitly or not. + + Set_Comes_From_Source + (Defining_Ident_Node, Comes_From_Source (Identifier (Label_Node))); + + -- Now attach the implicit label declaration to the appropriate + -- declarative region, creating a declaration list if none exists + + if No (Declarations (Enclosing_Body_Or_Block)) then + Set_Declarations (Enclosing_Body_Or_Block, New_List); + end if; + + Append (Label_Decl_Node, Declarations (Enclosing_Body_Or_Block)); + end if; + + <> + Next_Elmt (Next_Label_Elmt); + end loop; + + Find_Natural_Loops; + +end Labl; -- cgit v1.2.3