annotate gcc/ada/par-labl.adb @ 111:04ced10e8804

gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
111
kono
parents:
diff changeset
1 ------------------------------------------------------------------------------
kono
parents:
diff changeset
2 -- --
kono
parents:
diff changeset
3 -- GNAT COMPILER COMPONENTS --
kono
parents:
diff changeset
4 -- --
kono
parents:
diff changeset
5 -- P A R . L A B L --
kono
parents:
diff changeset
6 -- --
kono
parents:
diff changeset
7 -- B o d y --
kono
parents:
diff changeset
8 -- --
kono
parents:
diff changeset
9 -- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
kono
parents:
diff changeset
10 -- --
kono
parents:
diff changeset
11 -- GNAT is free software; you can redistribute it and/or modify it under --
kono
parents:
diff changeset
12 -- terms of the GNU General Public License as published by the Free Soft- --
kono
parents:
diff changeset
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
kono
parents:
diff changeset
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
kono
parents:
diff changeset
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
kono
parents:
diff changeset
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
kono
parents:
diff changeset
17 -- for more details. You should have received a copy of the GNU General --
kono
parents:
diff changeset
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
kono
parents:
diff changeset
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
kono
parents:
diff changeset
20 -- --
kono
parents:
diff changeset
21 -- GNAT was originally developed by the GNAT team at New York University. --
kono
parents:
diff changeset
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
kono
parents:
diff changeset
23 -- --
kono
parents:
diff changeset
24 ------------------------------------------------------------------------------
kono
parents:
diff changeset
25
kono
parents:
diff changeset
26 separate (Par)
kono
parents:
diff changeset
27 procedure Labl is
kono
parents:
diff changeset
28 Enclosing_Body_Or_Block : Node_Id;
kono
parents:
diff changeset
29 -- Innermost enclosing body or block statement
kono
parents:
diff changeset
30
kono
parents:
diff changeset
31 Label_Decl_Node : Node_Id;
kono
parents:
diff changeset
32 -- Implicit label declaration node
kono
parents:
diff changeset
33
kono
parents:
diff changeset
34 Defining_Ident_Node : Node_Id;
kono
parents:
diff changeset
35 -- Defining identifier node for implicit label declaration
kono
parents:
diff changeset
36
kono
parents:
diff changeset
37 Next_Label_Elmt : Elmt_Id;
kono
parents:
diff changeset
38 -- Next element on label element list
kono
parents:
diff changeset
39
kono
parents:
diff changeset
40 Label_Node : Node_Id;
kono
parents:
diff changeset
41 -- Next label node to process
kono
parents:
diff changeset
42
kono
parents:
diff changeset
43 function Find_Enclosing_Body_Or_Block (N : Node_Id) return Node_Id;
kono
parents:
diff changeset
44 -- Find the innermost body or block that encloses N
kono
parents:
diff changeset
45
kono
parents:
diff changeset
46 function Find_Enclosing_Body (N : Node_Id) return Node_Id;
kono
parents:
diff changeset
47 -- Find the innermost body that encloses N
kono
parents:
diff changeset
48
kono
parents:
diff changeset
49 procedure Check_Distinct_Labels;
kono
parents:
diff changeset
50 -- Checks the rule in RM-5.1(11), which requires distinct identifiers
kono
parents:
diff changeset
51 -- for all the labels in a given body.
kono
parents:
diff changeset
52
kono
parents:
diff changeset
53 procedure Find_Natural_Loops;
kono
parents:
diff changeset
54 -- Recognizes loops created by backward gotos, and rewrites the
kono
parents:
diff changeset
55 -- corresponding statements into a proper loop, for optimization
kono
parents:
diff changeset
56 -- purposes (for example, to control reclaiming local storage).
kono
parents:
diff changeset
57
kono
parents:
diff changeset
58 ---------------------------
kono
parents:
diff changeset
59 -- Check_Distinct_Labels --
kono
parents:
diff changeset
60 ---------------------------
kono
parents:
diff changeset
61
kono
parents:
diff changeset
62 procedure Check_Distinct_Labels is
kono
parents:
diff changeset
63 Label_Id : constant Node_Id := Identifier (Label_Node);
kono
parents:
diff changeset
64
kono
parents:
diff changeset
65 Enclosing_Body : constant Node_Id :=
kono
parents:
diff changeset
66 Find_Enclosing_Body (Enclosing_Body_Or_Block);
kono
parents:
diff changeset
67 -- Innermost enclosing body
kono
parents:
diff changeset
68
kono
parents:
diff changeset
69 Next_Other_Label_Elmt : Elmt_Id := First_Elmt (Label_List);
kono
parents:
diff changeset
70 -- Next element on label element list
kono
parents:
diff changeset
71
kono
parents:
diff changeset
72 Other_Label : Node_Id;
kono
parents:
diff changeset
73 -- Next label node to process
kono
parents:
diff changeset
74
kono
parents:
diff changeset
75 begin
kono
parents:
diff changeset
76 -- Loop through all the labels, and if we find some other label
kono
parents:
diff changeset
77 -- (i.e. not Label_Node) that has the same identifier,
kono
parents:
diff changeset
78 -- and whose innermost enclosing body is the same,
kono
parents:
diff changeset
79 -- then we have an error.
kono
parents:
diff changeset
80
kono
parents:
diff changeset
81 -- Note that in the worst case, this is quadratic in the number
kono
parents:
diff changeset
82 -- of labels. However, labels are not all that common, and this
kono
parents:
diff changeset
83 -- is only called for explicit labels.
kono
parents:
diff changeset
84
kono
parents:
diff changeset
85 -- ???Nonetheless, the efficiency could be improved. For example,
kono
parents:
diff changeset
86 -- call Labl for each body, rather than once per compilation.
kono
parents:
diff changeset
87
kono
parents:
diff changeset
88 while Present (Next_Other_Label_Elmt) loop
kono
parents:
diff changeset
89 Other_Label := Node (Next_Other_Label_Elmt);
kono
parents:
diff changeset
90
kono
parents:
diff changeset
91 exit when Label_Node = Other_Label;
kono
parents:
diff changeset
92
kono
parents:
diff changeset
93 if Chars (Label_Id) = Chars (Identifier (Other_Label))
kono
parents:
diff changeset
94 and then Enclosing_Body = Find_Enclosing_Body (Other_Label)
kono
parents:
diff changeset
95 then
kono
parents:
diff changeset
96 Error_Msg_Sloc := Sloc (Other_Label);
kono
parents:
diff changeset
97 Error_Msg_N ("& conflicts with label#", Label_Id);
kono
parents:
diff changeset
98 exit;
kono
parents:
diff changeset
99 end if;
kono
parents:
diff changeset
100
kono
parents:
diff changeset
101 Next_Elmt (Next_Other_Label_Elmt);
kono
parents:
diff changeset
102 end loop;
kono
parents:
diff changeset
103 end Check_Distinct_Labels;
kono
parents:
diff changeset
104
kono
parents:
diff changeset
105 -------------------------
kono
parents:
diff changeset
106 -- Find_Enclosing_Body --
kono
parents:
diff changeset
107 -------------------------
kono
parents:
diff changeset
108
kono
parents:
diff changeset
109 function Find_Enclosing_Body (N : Node_Id) return Node_Id is
kono
parents:
diff changeset
110 Result : Node_Id := N;
kono
parents:
diff changeset
111
kono
parents:
diff changeset
112 begin
kono
parents:
diff changeset
113 -- This is the same as Find_Enclosing_Body_Or_Block, except
kono
parents:
diff changeset
114 -- that we skip block statements and accept statements, instead
kono
parents:
diff changeset
115 -- of stopping at them.
kono
parents:
diff changeset
116
kono
parents:
diff changeset
117 while Present (Result)
kono
parents:
diff changeset
118 and then Nkind (Result) /= N_Entry_Body
kono
parents:
diff changeset
119 and then Nkind (Result) /= N_Task_Body
kono
parents:
diff changeset
120 and then Nkind (Result) /= N_Package_Body
kono
parents:
diff changeset
121 and then Nkind (Result) /= N_Subprogram_Body
kono
parents:
diff changeset
122 loop
kono
parents:
diff changeset
123 Result := Parent (Result);
kono
parents:
diff changeset
124 end loop;
kono
parents:
diff changeset
125
kono
parents:
diff changeset
126 return Result;
kono
parents:
diff changeset
127 end Find_Enclosing_Body;
kono
parents:
diff changeset
128
kono
parents:
diff changeset
129 ----------------------------------
kono
parents:
diff changeset
130 -- Find_Enclosing_Body_Or_Block --
kono
parents:
diff changeset
131 ----------------------------------
kono
parents:
diff changeset
132
kono
parents:
diff changeset
133 function Find_Enclosing_Body_Or_Block (N : Node_Id) return Node_Id is
kono
parents:
diff changeset
134 Result : Node_Id := Parent (N);
kono
parents:
diff changeset
135
kono
parents:
diff changeset
136 begin
kono
parents:
diff changeset
137 -- Climb up the parent chain until we find a body or block
kono
parents:
diff changeset
138
kono
parents:
diff changeset
139 while Present (Result)
kono
parents:
diff changeset
140 and then Nkind (Result) /= N_Accept_Statement
kono
parents:
diff changeset
141 and then Nkind (Result) /= N_Entry_Body
kono
parents:
diff changeset
142 and then Nkind (Result) /= N_Task_Body
kono
parents:
diff changeset
143 and then Nkind (Result) /= N_Package_Body
kono
parents:
diff changeset
144 and then Nkind (Result) /= N_Subprogram_Body
kono
parents:
diff changeset
145 and then Nkind (Result) /= N_Block_Statement
kono
parents:
diff changeset
146 loop
kono
parents:
diff changeset
147 Result := Parent (Result);
kono
parents:
diff changeset
148 end loop;
kono
parents:
diff changeset
149
kono
parents:
diff changeset
150 return Result;
kono
parents:
diff changeset
151 end Find_Enclosing_Body_Or_Block;
kono
parents:
diff changeset
152
kono
parents:
diff changeset
153 ------------------------
kono
parents:
diff changeset
154 -- Find_Natural_Loops --
kono
parents:
diff changeset
155 ------------------------
kono
parents:
diff changeset
156
kono
parents:
diff changeset
157 procedure Find_Natural_Loops is
kono
parents:
diff changeset
158 Node_List : constant Elist_Id := New_Elmt_List;
kono
parents:
diff changeset
159 N : Elmt_Id;
kono
parents:
diff changeset
160 Succ : Elmt_Id;
kono
parents:
diff changeset
161
kono
parents:
diff changeset
162 function Goto_Id (Goto_Node : Node_Id) return Name_Id;
kono
parents:
diff changeset
163 -- Find Name_Id of goto statement, which may be an expanded name
kono
parents:
diff changeset
164
kono
parents:
diff changeset
165 function Matches
kono
parents:
diff changeset
166 (Label_Node : Node_Id;
kono
parents:
diff changeset
167 Goto_Node : Node_Id) return Boolean;
kono
parents:
diff changeset
168 -- A label and a goto are candidates for a loop if the names match,
kono
parents:
diff changeset
169 -- and both nodes appear in the same body. In addition, both must
kono
parents:
diff changeset
170 -- appear in the same statement list. If they are not in the same
kono
parents:
diff changeset
171 -- statement list, the goto is from within an nested structure, and
kono
parents:
diff changeset
172 -- the label is not a header. We ignore the case where the goto is
kono
parents:
diff changeset
173 -- within a conditional structure, and capture only infinite loops.
kono
parents:
diff changeset
174
kono
parents:
diff changeset
175 procedure Merge;
kono
parents:
diff changeset
176 -- Merge labels and goto statements in order of increasing sloc value.
kono
parents:
diff changeset
177 -- Discard labels of loop and block statements.
kono
parents:
diff changeset
178
kono
parents:
diff changeset
179 procedure No_Header (N : Elmt_Id);
kono
parents:
diff changeset
180 -- The label N is known not to be a loop header. Scan forward and
kono
parents:
diff changeset
181 -- remove all subsequent gotos that may have this node as a target.
kono
parents:
diff changeset
182
kono
parents:
diff changeset
183 procedure Process_Goto (N : Elmt_Id);
kono
parents:
diff changeset
184 -- N is a forward jump. Scan forward and remove all subsequent gotos
kono
parents:
diff changeset
185 -- that may have the same target, to preclude spurious loops.
kono
parents:
diff changeset
186
kono
parents:
diff changeset
187 procedure Rewrite_As_Loop
kono
parents:
diff changeset
188 (Loop_Header : Node_Id;
kono
parents:
diff changeset
189 Loop_End : Node_Id);
kono
parents:
diff changeset
190 -- Given a label and a backwards goto, rewrite intervening statements
kono
parents:
diff changeset
191 -- as a loop. Remove the label from the node list, and rewrite the
kono
parents:
diff changeset
192 -- goto with the body of the new loop.
kono
parents:
diff changeset
193
kono
parents:
diff changeset
194 procedure Try_Loop (N : Elmt_Id);
kono
parents:
diff changeset
195 -- N is a label that may be a loop header. Scan forward to find some
kono
parents:
diff changeset
196 -- backwards goto with which to make a loop. Do nothing if there is
kono
parents:
diff changeset
197 -- an intervening label that is not part of a loop, or more than one
kono
parents:
diff changeset
198 -- goto with this target.
kono
parents:
diff changeset
199
kono
parents:
diff changeset
200 -------------
kono
parents:
diff changeset
201 -- Goto_Id --
kono
parents:
diff changeset
202 -------------
kono
parents:
diff changeset
203
kono
parents:
diff changeset
204 function Goto_Id (Goto_Node : Node_Id) return Name_Id is
kono
parents:
diff changeset
205 begin
kono
parents:
diff changeset
206 if Nkind (Name (Goto_Node)) = N_Identifier then
kono
parents:
diff changeset
207 return Chars (Name (Goto_Node));
kono
parents:
diff changeset
208
kono
parents:
diff changeset
209 elsif Nkind (Name (Goto_Node)) = N_Selected_Component then
kono
parents:
diff changeset
210 return Chars (Selector_Name (Name (Goto_Node)));
kono
parents:
diff changeset
211 else
kono
parents:
diff changeset
212
kono
parents:
diff changeset
213 -- In case of error, return Id that can't match anything
kono
parents:
diff changeset
214
kono
parents:
diff changeset
215 return Name_Null;
kono
parents:
diff changeset
216 end if;
kono
parents:
diff changeset
217 end Goto_Id;
kono
parents:
diff changeset
218
kono
parents:
diff changeset
219 -------------
kono
parents:
diff changeset
220 -- Matches --
kono
parents:
diff changeset
221 -------------
kono
parents:
diff changeset
222
kono
parents:
diff changeset
223 function Matches
kono
parents:
diff changeset
224 (Label_Node : Node_Id;
kono
parents:
diff changeset
225 Goto_Node : Node_Id) return Boolean
kono
parents:
diff changeset
226 is
kono
parents:
diff changeset
227 begin
kono
parents:
diff changeset
228 return Chars (Identifier (Label_Node)) = Goto_Id (Goto_Node)
kono
parents:
diff changeset
229 and then Find_Enclosing_Body (Label_Node) =
kono
parents:
diff changeset
230 Find_Enclosing_Body (Goto_Node);
kono
parents:
diff changeset
231 end Matches;
kono
parents:
diff changeset
232
kono
parents:
diff changeset
233 -----------
kono
parents:
diff changeset
234 -- Merge --
kono
parents:
diff changeset
235 -----------
kono
parents:
diff changeset
236
kono
parents:
diff changeset
237 procedure Merge is
kono
parents:
diff changeset
238 L1 : Elmt_Id;
kono
parents:
diff changeset
239 G1 : Elmt_Id;
kono
parents:
diff changeset
240
kono
parents:
diff changeset
241 begin
kono
parents:
diff changeset
242 L1 := First_Elmt (Label_List);
kono
parents:
diff changeset
243 G1 := First_Elmt (Goto_List);
kono
parents:
diff changeset
244
kono
parents:
diff changeset
245 while Present (L1)
kono
parents:
diff changeset
246 and then Present (G1)
kono
parents:
diff changeset
247 loop
kono
parents:
diff changeset
248 if Sloc (Node (L1)) < Sloc (Node (G1)) then
kono
parents:
diff changeset
249
kono
parents:
diff changeset
250 -- Optimization: remove labels of loops and blocks, which
kono
parents:
diff changeset
251 -- play no role in what follows.
kono
parents:
diff changeset
252
kono
parents:
diff changeset
253 if Nkind (Node (L1)) /= N_Loop_Statement
kono
parents:
diff changeset
254 and then Nkind (Node (L1)) /= N_Block_Statement
kono
parents:
diff changeset
255 then
kono
parents:
diff changeset
256 Append_Elmt (Node (L1), Node_List);
kono
parents:
diff changeset
257 end if;
kono
parents:
diff changeset
258
kono
parents:
diff changeset
259 Next_Elmt (L1);
kono
parents:
diff changeset
260
kono
parents:
diff changeset
261 else
kono
parents:
diff changeset
262 Append_Elmt (Node (G1), Node_List);
kono
parents:
diff changeset
263 Next_Elmt (G1);
kono
parents:
diff changeset
264 end if;
kono
parents:
diff changeset
265 end loop;
kono
parents:
diff changeset
266
kono
parents:
diff changeset
267 while Present (L1) loop
kono
parents:
diff changeset
268 Append_Elmt (Node (L1), Node_List);
kono
parents:
diff changeset
269 Next_Elmt (L1);
kono
parents:
diff changeset
270 end loop;
kono
parents:
diff changeset
271
kono
parents:
diff changeset
272 while Present (G1) loop
kono
parents:
diff changeset
273 Append_Elmt (Node (G1), Node_List);
kono
parents:
diff changeset
274 Next_Elmt (G1);
kono
parents:
diff changeset
275 end loop;
kono
parents:
diff changeset
276 end Merge;
kono
parents:
diff changeset
277
kono
parents:
diff changeset
278 ---------------
kono
parents:
diff changeset
279 -- No_Header --
kono
parents:
diff changeset
280 ---------------
kono
parents:
diff changeset
281
kono
parents:
diff changeset
282 procedure No_Header (N : Elmt_Id) is
kono
parents:
diff changeset
283 S1, S2 : Elmt_Id;
kono
parents:
diff changeset
284
kono
parents:
diff changeset
285 begin
kono
parents:
diff changeset
286 S1 := Next_Elmt (N);
kono
parents:
diff changeset
287 while Present (S1) loop
kono
parents:
diff changeset
288 S2 := Next_Elmt (S1);
kono
parents:
diff changeset
289 if Nkind (Node (S1)) = N_Goto_Statement
kono
parents:
diff changeset
290 and then Matches (Node (N), Node (S1))
kono
parents:
diff changeset
291 then
kono
parents:
diff changeset
292 Remove_Elmt (Node_List, S1);
kono
parents:
diff changeset
293 end if;
kono
parents:
diff changeset
294
kono
parents:
diff changeset
295 S1 := S2;
kono
parents:
diff changeset
296 end loop;
kono
parents:
diff changeset
297 end No_Header;
kono
parents:
diff changeset
298
kono
parents:
diff changeset
299 ------------------
kono
parents:
diff changeset
300 -- Process_Goto --
kono
parents:
diff changeset
301 ------------------
kono
parents:
diff changeset
302
kono
parents:
diff changeset
303 procedure Process_Goto (N : Elmt_Id) is
kono
parents:
diff changeset
304 Goto1 : constant Node_Id := Node (N);
kono
parents:
diff changeset
305 Goto2 : Node_Id;
kono
parents:
diff changeset
306 S, S1 : Elmt_Id;
kono
parents:
diff changeset
307
kono
parents:
diff changeset
308 begin
kono
parents:
diff changeset
309 S := Next_Elmt (N);
kono
parents:
diff changeset
310
kono
parents:
diff changeset
311 while Present (S) loop
kono
parents:
diff changeset
312 S1 := Next_Elmt (S);
kono
parents:
diff changeset
313 Goto2 := Node (S);
kono
parents:
diff changeset
314
kono
parents:
diff changeset
315 if Nkind (Goto2) = N_Goto_Statement
kono
parents:
diff changeset
316 and then Goto_Id (Goto1) = Goto_Id (Goto2)
kono
parents:
diff changeset
317 and then Find_Enclosing_Body (Goto1) =
kono
parents:
diff changeset
318 Find_Enclosing_Body (Goto2)
kono
parents:
diff changeset
319 then
kono
parents:
diff changeset
320
kono
parents:
diff changeset
321 -- Goto2 may have the same target, remove it from
kono
parents:
diff changeset
322 -- consideration.
kono
parents:
diff changeset
323
kono
parents:
diff changeset
324 Remove_Elmt (Node_List, S);
kono
parents:
diff changeset
325 end if;
kono
parents:
diff changeset
326
kono
parents:
diff changeset
327 S := S1;
kono
parents:
diff changeset
328 end loop;
kono
parents:
diff changeset
329 end Process_Goto;
kono
parents:
diff changeset
330
kono
parents:
diff changeset
331 ---------------------
kono
parents:
diff changeset
332 -- Rewrite_As_Loop --
kono
parents:
diff changeset
333 ---------------------
kono
parents:
diff changeset
334
kono
parents:
diff changeset
335 procedure Rewrite_As_Loop
kono
parents:
diff changeset
336 (Loop_Header : Node_Id;
kono
parents:
diff changeset
337 Loop_End : Node_Id)
kono
parents:
diff changeset
338 is
kono
parents:
diff changeset
339 Loop_Body : constant List_Id := New_List;
kono
parents:
diff changeset
340 Loop_Stmt : constant Node_Id :=
kono
parents:
diff changeset
341 New_Node (N_Loop_Statement, Sloc (Loop_Header));
kono
parents:
diff changeset
342 Stat : Node_Id;
kono
parents:
diff changeset
343 Next_Stat : Node_Id;
kono
parents:
diff changeset
344
kono
parents:
diff changeset
345 begin
kono
parents:
diff changeset
346 Stat := Next (Loop_Header);
kono
parents:
diff changeset
347 while Stat /= Loop_End loop
kono
parents:
diff changeset
348 Next_Stat := Next (Stat);
kono
parents:
diff changeset
349 Remove (Stat);
kono
parents:
diff changeset
350 Append (Stat, Loop_Body);
kono
parents:
diff changeset
351 Stat := Next_Stat;
kono
parents:
diff changeset
352 end loop;
kono
parents:
diff changeset
353
kono
parents:
diff changeset
354 Set_Statements (Loop_Stmt, Loop_Body);
kono
parents:
diff changeset
355 Set_Identifier (Loop_Stmt, Identifier (Loop_Header));
kono
parents:
diff changeset
356
kono
parents:
diff changeset
357 Remove (Loop_Header);
kono
parents:
diff changeset
358 Rewrite (Loop_End, Loop_Stmt);
kono
parents:
diff changeset
359 Error_Msg_N
kono
parents:
diff changeset
360 ("info: code between label and backwards goto rewritten as loop??",
kono
parents:
diff changeset
361 Loop_End);
kono
parents:
diff changeset
362 end Rewrite_As_Loop;
kono
parents:
diff changeset
363
kono
parents:
diff changeset
364 --------------
kono
parents:
diff changeset
365 -- Try_Loop --
kono
parents:
diff changeset
366 --------------
kono
parents:
diff changeset
367
kono
parents:
diff changeset
368 procedure Try_Loop (N : Elmt_Id) is
kono
parents:
diff changeset
369 Source : Elmt_Id;
kono
parents:
diff changeset
370 Found : Boolean := False;
kono
parents:
diff changeset
371 S1 : Elmt_Id;
kono
parents:
diff changeset
372
kono
parents:
diff changeset
373 begin
kono
parents:
diff changeset
374 S1 := Next_Elmt (N);
kono
parents:
diff changeset
375 while Present (S1) loop
kono
parents:
diff changeset
376 if Nkind (Node (S1)) = N_Goto_Statement
kono
parents:
diff changeset
377 and then Matches (Node (N), Node (S1))
kono
parents:
diff changeset
378 then
kono
parents:
diff changeset
379 if not Found then
kono
parents:
diff changeset
380
kono
parents:
diff changeset
381 -- If the label and the goto are both in the same statement
kono
parents:
diff changeset
382 -- list, then we've found a loop. Note that labels and goto
kono
parents:
diff changeset
383 -- statements are always part of some list, so In_Same_List
kono
parents:
diff changeset
384 -- always makes sense.
kono
parents:
diff changeset
385
kono
parents:
diff changeset
386 if In_Same_List (Node (N), Node (S1)) then
kono
parents:
diff changeset
387 Source := S1;
kono
parents:
diff changeset
388 Found := True;
kono
parents:
diff changeset
389
kono
parents:
diff changeset
390 -- The goto is within some nested structure
kono
parents:
diff changeset
391
kono
parents:
diff changeset
392 else
kono
parents:
diff changeset
393 No_Header (N);
kono
parents:
diff changeset
394 return;
kono
parents:
diff changeset
395 end if;
kono
parents:
diff changeset
396
kono
parents:
diff changeset
397 else
kono
parents:
diff changeset
398 -- More than one goto with the same target
kono
parents:
diff changeset
399
kono
parents:
diff changeset
400 No_Header (N);
kono
parents:
diff changeset
401 return;
kono
parents:
diff changeset
402 end if;
kono
parents:
diff changeset
403
kono
parents:
diff changeset
404 elsif Nkind (Node (S1)) = N_Label
kono
parents:
diff changeset
405 and then not Found
kono
parents:
diff changeset
406 then
kono
parents:
diff changeset
407 -- Intervening label before possible end of loop. Current
kono
parents:
diff changeset
408 -- label is not a candidate. This is conservative, because
kono
parents:
diff changeset
409 -- the label might not be the target of any jumps, but not
kono
parents:
diff changeset
410 -- worth dealing with useless labels.
kono
parents:
diff changeset
411
kono
parents:
diff changeset
412 No_Header (N);
kono
parents:
diff changeset
413 return;
kono
parents:
diff changeset
414
kono
parents:
diff changeset
415 else
kono
parents:
diff changeset
416 -- If the node is a loop_statement, it corresponds to a
kono
parents:
diff changeset
417 -- label-goto pair rewritten as a loop. Continue forward scan.
kono
parents:
diff changeset
418
kono
parents:
diff changeset
419 null;
kono
parents:
diff changeset
420 end if;
kono
parents:
diff changeset
421
kono
parents:
diff changeset
422 Next_Elmt (S1);
kono
parents:
diff changeset
423 end loop;
kono
parents:
diff changeset
424
kono
parents:
diff changeset
425 if Found then
kono
parents:
diff changeset
426 Rewrite_As_Loop (Node (N), Node (Source));
kono
parents:
diff changeset
427 Remove_Elmt (Node_List, N);
kono
parents:
diff changeset
428 Remove_Elmt (Node_List, Source);
kono
parents:
diff changeset
429 end if;
kono
parents:
diff changeset
430 end Try_Loop;
kono
parents:
diff changeset
431
kono
parents:
diff changeset
432 begin
kono
parents:
diff changeset
433 -- Start of processing for Find_Natural_Loops
kono
parents:
diff changeset
434
kono
parents:
diff changeset
435 Merge;
kono
parents:
diff changeset
436
kono
parents:
diff changeset
437 N := First_Elmt (Node_List);
kono
parents:
diff changeset
438 while Present (N) loop
kono
parents:
diff changeset
439 Succ := Next_Elmt (N);
kono
parents:
diff changeset
440
kono
parents:
diff changeset
441 if Nkind (Node (N)) = N_Label then
kono
parents:
diff changeset
442 if No (Succ) then
kono
parents:
diff changeset
443 exit;
kono
parents:
diff changeset
444
kono
parents:
diff changeset
445 elsif Nkind (Node (Succ)) = N_Label then
kono
parents:
diff changeset
446 Try_Loop (Succ);
kono
parents:
diff changeset
447
kono
parents:
diff changeset
448 -- If a loop was found, the label has been removed, and
kono
parents:
diff changeset
449 -- the following goto rewritten as the loop body.
kono
parents:
diff changeset
450
kono
parents:
diff changeset
451 Succ := Next_Elmt (N);
kono
parents:
diff changeset
452
kono
parents:
diff changeset
453 if Nkind (Node (Succ)) = N_Label then
kono
parents:
diff changeset
454
kono
parents:
diff changeset
455 -- Following label was not removed, so current label
kono
parents:
diff changeset
456 -- is not a candidate header.
kono
parents:
diff changeset
457
kono
parents:
diff changeset
458 No_Header (N);
kono
parents:
diff changeset
459
kono
parents:
diff changeset
460 else
kono
parents:
diff changeset
461
kono
parents:
diff changeset
462 -- Following label was part of inner loop. Current
kono
parents:
diff changeset
463 -- label is still a candidate.
kono
parents:
diff changeset
464
kono
parents:
diff changeset
465 Try_Loop (N);
kono
parents:
diff changeset
466 Succ := Next_Elmt (N);
kono
parents:
diff changeset
467 end if;
kono
parents:
diff changeset
468
kono
parents:
diff changeset
469 elsif Nkind (Node (Succ)) = N_Goto_Statement then
kono
parents:
diff changeset
470 Try_Loop (N);
kono
parents:
diff changeset
471 Succ := Next_Elmt (N);
kono
parents:
diff changeset
472 end if;
kono
parents:
diff changeset
473
kono
parents:
diff changeset
474 elsif Nkind (Node (N)) = N_Goto_Statement then
kono
parents:
diff changeset
475 Process_Goto (N);
kono
parents:
diff changeset
476 Succ := Next_Elmt (N);
kono
parents:
diff changeset
477 end if;
kono
parents:
diff changeset
478
kono
parents:
diff changeset
479 N := Succ;
kono
parents:
diff changeset
480 end loop;
kono
parents:
diff changeset
481 end Find_Natural_Loops;
kono
parents:
diff changeset
482
kono
parents:
diff changeset
483 -- Start of processing for Par.Labl
kono
parents:
diff changeset
484
kono
parents:
diff changeset
485 begin
kono
parents:
diff changeset
486 Next_Label_Elmt := First_Elmt (Label_List);
kono
parents:
diff changeset
487 while Present (Next_Label_Elmt) loop
kono
parents:
diff changeset
488 Label_Node := Node (Next_Label_Elmt);
kono
parents:
diff changeset
489
kono
parents:
diff changeset
490 if not Comes_From_Source (Label_Node) then
kono
parents:
diff changeset
491 goto Next_Label;
kono
parents:
diff changeset
492 end if;
kono
parents:
diff changeset
493
kono
parents:
diff changeset
494 -- Find the innermost enclosing body or block, which is where
kono
parents:
diff changeset
495 -- we need to implicitly declare this label
kono
parents:
diff changeset
496
kono
parents:
diff changeset
497 Enclosing_Body_Or_Block := Find_Enclosing_Body_Or_Block (Label_Node);
kono
parents:
diff changeset
498
kono
parents:
diff changeset
499 -- If we didn't find a parent, then the label in question never got
kono
parents:
diff changeset
500 -- hooked into a reasonable declarative part. This happens only in
kono
parents:
diff changeset
501 -- error situations, and we simply ignore the entry (we aren't going
kono
parents:
diff changeset
502 -- to get into the semantics in any case given the error).
kono
parents:
diff changeset
503
kono
parents:
diff changeset
504 if Present (Enclosing_Body_Or_Block) then
kono
parents:
diff changeset
505 Check_Distinct_Labels;
kono
parents:
diff changeset
506
kono
parents:
diff changeset
507 -- Now create the implicit label declaration node and its
kono
parents:
diff changeset
508 -- corresponding defining identifier. Note that the defining
kono
parents:
diff changeset
509 -- occurrence of a label is the implicit label declaration that
kono
parents:
diff changeset
510 -- we are creating. The label itself is an applied occurrence.
kono
parents:
diff changeset
511
kono
parents:
diff changeset
512 Label_Decl_Node :=
kono
parents:
diff changeset
513 New_Node (N_Implicit_Label_Declaration, Sloc (Label_Node));
kono
parents:
diff changeset
514 Defining_Ident_Node :=
kono
parents:
diff changeset
515 New_Entity (N_Defining_Identifier, Sloc (Identifier (Label_Node)));
kono
parents:
diff changeset
516 Set_Chars (Defining_Ident_Node, Chars (Identifier (Label_Node)));
kono
parents:
diff changeset
517 Set_Defining_Identifier (Label_Decl_Node, Defining_Ident_Node);
kono
parents:
diff changeset
518 Set_Label_Construct (Label_Decl_Node, Label_Node);
kono
parents:
diff changeset
519
kono
parents:
diff changeset
520 -- The following makes sure that Comes_From_Source is appropriately
kono
parents:
diff changeset
521 -- set for the entity, depending on whether the label appeared in
kono
parents:
diff changeset
522 -- the source explicitly or not.
kono
parents:
diff changeset
523
kono
parents:
diff changeset
524 Set_Comes_From_Source
kono
parents:
diff changeset
525 (Defining_Ident_Node, Comes_From_Source (Identifier (Label_Node)));
kono
parents:
diff changeset
526
kono
parents:
diff changeset
527 -- Now attach the implicit label declaration to the appropriate
kono
parents:
diff changeset
528 -- declarative region, creating a declaration list if none exists
kono
parents:
diff changeset
529
kono
parents:
diff changeset
530 if No (Declarations (Enclosing_Body_Or_Block)) then
kono
parents:
diff changeset
531 Set_Declarations (Enclosing_Body_Or_Block, New_List);
kono
parents:
diff changeset
532 end if;
kono
parents:
diff changeset
533
kono
parents:
diff changeset
534 Append (Label_Decl_Node, Declarations (Enclosing_Body_Or_Block));
kono
parents:
diff changeset
535 end if;
kono
parents:
diff changeset
536
kono
parents:
diff changeset
537 <<Next_Label>>
kono
parents:
diff changeset
538 Next_Elmt (Next_Label_Elmt);
kono
parents:
diff changeset
539 end loop;
kono
parents:
diff changeset
540
kono
parents:
diff changeset
541 Find_Natural_Loops;
kono
parents:
diff changeset
542
kono
parents:
diff changeset
543 end Labl;