Mercurial > hg > CbC > CbC_gcc
comparison gcc/ada/par-labl.adb @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
comparison
equal
deleted
inserted
replaced
68:561a7518be6b | 111:04ced10e8804 |
---|---|
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-2013, 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 3, 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 COPYING3. If not, go to -- | |
19 -- http://www.gnu.org/licenses for a complete copy of the license. -- | |
20 -- -- | |
21 -- GNAT was originally developed by the GNAT team at New York University. -- | |
22 -- Extensive contributions were provided by Ada Core Technologies Inc. -- | |
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; | |
44 -- Find the innermost body or block that encloses N | |
45 | |
46 function Find_Enclosing_Body (N : Node_Id) return Node_Id; | |
47 -- Find the innermost body that encloses N | |
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 | |
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 | |
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 | |
82 -- of labels. However, labels are not all that common, and this | |
83 -- is only called for explicit labels. | |
84 | |
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 | |
137 -- Climb up the parent chain until we find a body or block | |
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 | |
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; | |
163 -- Find Name_Id of goto statement, which may be an expanded name | |
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 | |
181 -- remove all subsequent gotos that may have this node as a target. | |
182 | |
183 procedure Process_Goto (N : Elmt_Id); | |
184 -- N is a forward jump. Scan forward and remove all subsequent gotos | |
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; | |
344 | |
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 | |
360 ("info: code between label and backwards goto rewritten as loop??", | |
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 | |
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 | |
383 -- statements are always part of some list, so In_Same_List | |
384 -- always makes sense. | |
385 | |
386 if In_Same_List (Node (N), Node (S1)) then | |
387 Source := S1; | |
388 Found := True; | |
389 | |
390 -- The goto is within some nested structure | |
391 | |
392 else | |
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 | |
410 -- worth dealing with useless labels. | |
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 | |
483 -- Start of processing for Par.Labl | |
484 | |
485 begin | |
486 Next_Label_Elmt := First_Elmt (Label_List); | |
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 | |
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 | |
527 -- Now attach the implicit label declaration to the appropriate | |
528 -- declarative region, creating a declaration list if none exists | |
529 | |
530 if No (Declarations (Enclosing_Body_Or_Block)) then | |
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 | |
541 Find_Natural_Loops; | |
542 | |
543 end Labl; |