summaryrefslogtreecommitdiff
path: root/gcc/ada/par-labl.adb
blob: 835be36e337ce49434e74ed0eca2a70fa925acfb (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             P A R . L A B L                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2003, 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 2,  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 COPYING.  If not, write --
-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, USA.                                                      --
--                                                                          --
-- 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.

   ---------------------------
   -- 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;

--  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 not Present (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;

end Labl;