gcc/ada/par-labl.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             P A R . L A B L                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                            $Revision: 1.18 $                             --
  10 --                                                                          --
  11 --          Copyright (C) 1992-1998, Free Software Foundation, Inc.         --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- GNAT was originally developed  by the GNAT team at  New York University. --
  25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  26 --                                                                          --
  27 ------------------------------------------------------------------------------
  28
  29 separate (Par)
  30 procedure Labl is
  31    Enclosing_Body_Or_Block : Node_Id;
  32    --  Innermost enclosing body or block statement
  33
  34    Label_Decl_Node : Node_Id;
  35    --  Implicit label declaration node
  36
  37    Defining_Ident_Node : Node_Id;
  38    --  Defining identifier node for implicit label declaration
  39
  40    Next_Label_Elmt : Elmt_Id;
  41    --  Next element on label element list
  42
  43    Label_Node : Node_Id;
  44    --  Next label node to process
  45
  46    function Find_Enclosing_Body_Or_Block (N : Node_Id) return Node_Id;
  47    --  Find the innermost body or block that encloses N.
  48
  49    function Find_Enclosing_Body (N : Node_Id) return Node_Id;
  50    --  Find the innermost body that encloses N.
  51
  52    procedure Check_Distinct_Labels;
  53    --  Checks the rule in RM-5.1(11), which requires distinct identifiers
  54    --  for all the labels in a given body.
  55
  56    ---------------------------
  57    -- Check_Distinct_Labels --
  58    ---------------------------
  59
  60    procedure Check_Distinct_Labels is
  61       Label_Id : constant Node_Id := Identifier (Label_Node);
  62
  63       Enclosing_Body : constant Node_Id :=
  64                          Find_Enclosing_Body (Enclosing_Body_Or_Block);
  65       --  Innermost enclosing body
  66
  67       Next_Other_Label_Elmt : Elmt_Id := First_Elmt (Label_List);
  68       --  Next element on label element list
  69
  70       Other_Label : Node_Id;
  71       --  Next label node to process
  72
  73    begin
  74       --  Loop through all the labels, and if we find some other label
  75       --  (i.e. not Label_Node) that has the same identifier,
  76       --  and whose innermost enclosing body is the same,
  77       --  then we have an error.
  78
  79       --  Note that in the worst case, this is quadratic in the number
  80       --  of labels.  However, labels are not all that common, and this
  81       --  is only called for explicit labels.
  82       --  ???Nonetheless, the efficiency could be improved. For example,
  83       --  call Labl for each body, rather than once per compilation.
  84
  85       while Present (Next_Other_Label_Elmt) loop
  86          Other_Label := Node (Next_Other_Label_Elmt);
  87
  88          exit when Label_Node = Other_Label;
  89
  90          if Chars (Label_Id) = Chars (Identifier (Other_Label))
  91            and then Enclosing_Body = Find_Enclosing_Body (Other_Label)
  92          then
  93             Error_Msg_Sloc := Sloc (Other_Label);
  94             Error_Msg_N ("& conflicts with label#", Label_Id);
  95             exit;
  96          end if;
  97
  98          Next_Elmt (Next_Other_Label_Elmt);
  99       end loop;
 100    end Check_Distinct_Labels;
 101
 102    -------------------------
 103    -- Find_Enclosing_Body --
 104    -------------------------
 105
 106    function Find_Enclosing_Body (N : Node_Id) return Node_Id is
 107       Result : Node_Id := N;
 108
 109    begin
 110       --  This is the same as Find_Enclosing_Body_Or_Block, except
 111       --  that we skip block statements and accept statements, instead
 112       --  of stopping at them.
 113
 114       while Present (Result)
 115         and then Nkind (Result) /= N_Entry_Body
 116         and then Nkind (Result) /= N_Task_Body
 117         and then Nkind (Result) /= N_Package_Body
 118         and then Nkind (Result) /= N_Subprogram_Body
 119       loop
 120          Result := Parent (Result);
 121       end loop;
 122
 123       return Result;
 124    end Find_Enclosing_Body;
 125
 126    ----------------------------------
 127    -- Find_Enclosing_Body_Or_Block --
 128    ----------------------------------
 129
 130    function Find_Enclosing_Body_Or_Block (N : Node_Id) return Node_Id is
 131       Result : Node_Id := Parent (N);
 132
 133    begin
 134       --  Climb up the parent chain until we find a body or block.
 135
 136       while Present (Result)
 137         and then Nkind (Result) /= N_Accept_Statement
 138         and then Nkind (Result) /= N_Entry_Body
 139         and then Nkind (Result) /= N_Task_Body
 140         and then Nkind (Result) /= N_Package_Body
 141         and then Nkind (Result) /= N_Subprogram_Body
 142         and then Nkind (Result) /= N_Block_Statement
 143       loop
 144          Result := Parent (Result);
 145       end loop;
 146
 147       return Result;
 148    end Find_Enclosing_Body_Or_Block;
 149
 150 --  Start of processing for Par.Labl
 151
 152 begin
 153    Next_Label_Elmt := First_Elmt (Label_List);
 154
 155    while Present (Next_Label_Elmt) loop
 156       Label_Node := Node (Next_Label_Elmt);
 157
 158       if not Comes_From_Source (Label_Node) then
 159          goto Next_Label;
 160       end if;
 161
 162       --  Find the innermost enclosing body or block, which is where
 163       --  we need to implicitly declare this label
 164
 165       Enclosing_Body_Or_Block := Find_Enclosing_Body_Or_Block (Label_Node);
 166
 167       --  If we didn't find a parent, then the label in question never got
 168       --  hooked into a reasonable declarative part. This happens only in
 169       --  error situations, and we simply ignore the entry (we aren't going
 170       --  to get into the semantics in any case given the error).
 171
 172       if Present (Enclosing_Body_Or_Block) then
 173          Check_Distinct_Labels;
 174
 175          --  Now create the implicit label declaration node and its
 176          --  corresponding defining identifier. Note that the defining
 177          --  occurrence of a label is the implicit label declaration that
 178          --  we are creating. The label itself is an applied occurrence.
 179
 180          Label_Decl_Node :=
 181            New_Node (N_Implicit_Label_Declaration, Sloc (Label_Node));
 182          Defining_Ident_Node :=
 183            New_Entity (N_Defining_Identifier, Sloc (Identifier (Label_Node)));
 184          Set_Chars (Defining_Ident_Node, Chars (Identifier (Label_Node)));
 185          Set_Defining_Identifier (Label_Decl_Node, Defining_Ident_Node);
 186          Set_Label_Construct (Label_Decl_Node, Label_Node);
 187
 188          --  Now attach the implicit label declaration to the appropriate
 189          --  declarative region, creating a declaration list if none exists
 190
 191          if not Present (Declarations (Enclosing_Body_Or_Block)) then
 192             Set_Declarations (Enclosing_Body_Or_Block, New_List);
 193          end if;
 194
 195          Append (Label_Decl_Node, Declarations (Enclosing_Body_Or_Block));
 196       end if;
 197
 198       <<Next_Label>>
 199          Next_Elmt (Next_Label_Elmt);
 200    end loop;
 201
 202 end Labl;