--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gcc/ada/par-labl.adb	Fri Oct 27 22:46:09 2017 +0900
@@ -0,0 +1,543 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P A R . L A B L                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--          Copyright (C) 1992-2013, 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;