| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- P A R . L A B L -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2022, 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 |
| ("info: 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_Label>> |
| Next_Elmt (Next_Label_Elmt); |
| end loop; |
| |
| Find_Natural_Loops; |
| |
| end Labl; |
