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