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