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