summaryrefslogtreecommitdiff
path: root/gcc/ada/par-labl.adb
blob: bc2a47eeec66ddd2e72ec17736937955cdf79619 (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
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             P A R . L A B L                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2007, 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 3,  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 COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- 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.

   procedure Find_Natural_Loops;
   --  Recognizes loops created by backward gotos, and rewrites the
   --  corresponding statements into a proper loop, for optimization
   --  purposes (for example, to control reclaiming local storage).

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

   ------------------------
   -- Find_Natural_Loops --
   ------------------------

   procedure Find_Natural_Loops is
      Node_List : constant Elist_Id := New_Elmt_List;
      N         : Elmt_Id;
      Succ      : Elmt_Id;

      function Goto_Id (Goto_Node : Node_Id) return Name_Id;
      --  Find Name_Id of goto statement, which may be an expanded name

      function Matches
        (Label_Node : Node_Id;
         Goto_Node  : Node_Id) return Boolean;
      --  A label and a goto are candidates for a loop if the names match,
      --  and both nodes appear in the same body. In addition, both must
      --  appear in the same statement list. If they are not in the same
      --  statement list, the goto is from within an nested structure, and
      --  the label is not a header. We ignore the case where the goto is
      --  within a conditional structure, and capture only infinite loops.

      procedure Merge;
      --  Merge labels and goto statements in order of increasing sloc value.
      --  Discard labels of loop and block statements.

      procedure No_Header (N : Elmt_Id);
      --  The label N is known not to be a loop header. Scan forward and
      --  remove all subsequent gotos that may have this node as a target.

      procedure Process_Goto (N : Elmt_Id);
      --  N is a forward jump. Scan forward and remove all subsequent gotos
      --  that may have the same target, to preclude spurious loops.

      procedure Rewrite_As_Loop
        (Loop_Header : Node_Id;
         Loop_End    : Node_Id);
      --  Given a label and a backwards goto, rewrite intervening statements
      --  as a loop. Remove the label from the node list, and rewrite the
      --  goto with the body of the new loop.

      procedure Try_Loop (N : Elmt_Id);
      --  N is a label that may be a loop header. Scan forward to find some
      --  backwards goto with which to make a loop. Do nothing if there is
      --  an intervening label that is not part of a loop, or more than one
      --  goto with this target.

      -------------
      -- Goto_Id --
      -------------

      function Goto_Id (Goto_Node : Node_Id) return Name_Id is
      begin
         if Nkind (Name (Goto_Node)) = N_Identifier then
            return Chars (Name (Goto_Node));

         elsif Nkind (Name (Goto_Node)) = N_Selected_Component then
            return Chars (Selector_Name (Name (Goto_Node)));
         else

            --  In case of error, return Id that can't match anything

            return Name_Null;
         end if;
      end Goto_Id;

      -------------
      -- Matches --
      -------------

      function Matches
        (Label_Node : Node_Id;
         Goto_Node  :  Node_Id) return Boolean
      is
      begin
         return Chars (Identifier (Label_Node)) = Goto_Id (Goto_Node)
           and then Find_Enclosing_Body (Label_Node) =
                    Find_Enclosing_Body (Goto_Node);
      end Matches;

      -----------
      -- Merge --
      -----------

      procedure Merge is
         L1 : Elmt_Id;
         G1 : Elmt_Id;

      begin
         L1 := First_Elmt (Label_List);
         G1 := First_Elmt (Goto_List);

         while Present (L1)
           and then Present (G1)
         loop
            if Sloc (Node (L1)) < Sloc (Node (G1)) then

               --  Optimization: remove labels of loops and blocks, which
               --  play no role in what follows.

               if Nkind (Node (L1)) /= N_Loop_Statement
                 and then Nkind (Node (L1)) /= N_Block_Statement
               then
                  Append_Elmt (Node (L1), Node_List);
               end if;

               Next_Elmt (L1);

            else
               Append_Elmt (Node (G1), Node_List);
               Next_Elmt (G1);
            end if;
         end loop;

         while Present (L1) loop
            Append_Elmt (Node (L1), Node_List);
            Next_Elmt (L1);
         end loop;

         while Present (G1) loop
            Append_Elmt (Node (G1), Node_List);
            Next_Elmt (G1);
         end loop;
      end Merge;

      ---------------
      -- No_Header --
      ---------------

      procedure No_Header (N : Elmt_Id) is
         S1, S2 : Elmt_Id;

      begin
         S1 := Next_Elmt (N);
         while Present (S1) loop
            S2 := Next_Elmt (S1);
            if Nkind (Node (S1)) = N_Goto_Statement
              and then Matches (Node (N), Node (S1))
            then
               Remove_Elmt (Node_List, S1);
            end if;

            S1 := S2;
         end loop;
      end No_Header;

      ------------------
      -- Process_Goto --
      ------------------

      procedure Process_Goto (N : Elmt_Id) is
         Goto1 : constant Node_Id := Node (N);
         Goto2 : Node_Id;
         S, S1 : Elmt_Id;

      begin
         S := Next_Elmt (N);

         while Present (S) loop
            S1 := Next_Elmt (S);
            Goto2 := Node (S);

            if Nkind (Goto2) = N_Goto_Statement
              and then Goto_Id (Goto1) = Goto_Id (Goto2)
              and then Find_Enclosing_Body (Goto1) =
                       Find_Enclosing_Body (Goto2)
            then

               --  Goto2 may have the same target, remove it from
               --  consideration.

               Remove_Elmt (Node_List, S);
            end if;

            S := S1;
         end loop;
      end Process_Goto;

      ---------------------
      -- Rewrite_As_Loop --
      ---------------------

      procedure Rewrite_As_Loop
        (Loop_Header : Node_Id;
         Loop_End    : Node_Id)
      is
         Loop_Body : constant List_Id := New_List;
         Loop_Stmt : constant Node_Id :=
                       New_Node (N_Loop_Statement, Sloc (Loop_Header));
         Stat      : Node_Id;
         Next_Stat : Node_Id;
      begin
         Stat := Next (Loop_Header);
         while Stat /= Loop_End loop
            Next_Stat := Next (Stat);
            Remove (Stat);
            Append (Stat, Loop_Body);
            Stat := Next_Stat;
         end loop;

         Set_Statements (Loop_Stmt, Loop_Body);
         Set_Identifier (Loop_Stmt, Identifier (Loop_Header));

         Remove (Loop_Header);
         Rewrite (Loop_End, Loop_Stmt);
         Error_Msg_N
           ("code between label and backwards goto rewritten as loop?",
             Loop_End);
      end Rewrite_As_Loop;

      --------------
      -- Try_Loop --
      --------------

      procedure Try_Loop (N : Elmt_Id) is
         Source : Elmt_Id;
         Found  : Boolean := False;
         S1     : Elmt_Id;

      begin
         S1 := Next_Elmt (N);
         while Present (S1) loop
            if Nkind (Node (S1)) = N_Goto_Statement
              and then Matches (Node (N), Node (S1))
            then
               if not Found then
                  if Parent (Node (N)) = Parent (Node (S1)) then
                     Source := S1;
                     Found  := True;

                  else
                     --  The goto is within some nested structure

                     No_Header (N);
                     return;
                  end if;

               else
                  --  More than one goto with the same target

                  No_Header (N);
                  return;
               end if;

            elsif Nkind (Node (S1)) = N_Label
              and then not Found
            then
               --  Intervening label before possible end of loop. Current
               --  label is not a candidate. This is conservative, because
               --  the label might not be the target of any jumps, but not
               --  worth dealing with useless labels!

               No_Header (N);
               return;

            else
               --  If the node is a loop_statement, it corresponds to a
               --  label-goto pair rewritten as a loop. Continue forward scan.

               null;
            end if;

            Next_Elmt (S1);
         end loop;

         if Found then
            Rewrite_As_Loop (Node (N), Node (Source));
            Remove_Elmt (Node_List, N);
            Remove_Elmt (Node_List, Source);
         end if;
      end Try_Loop;

   begin
      --  Start of processing for Find_Natural_Loops

      Merge;

      N := First_Elmt (Node_List);
      while Present (N) loop
         Succ := Next_Elmt (N);

         if Nkind (Node (N)) = N_Label then
            if No (Succ) then
               exit;

            elsif Nkind (Node (Succ)) = N_Label then
               Try_Loop (Succ);

               --  If a loop was found, the label has been removed, and
               --  the following goto rewritten as the loop body.

               Succ := Next_Elmt (N);

               if Nkind (Node (Succ)) = N_Label then

                  --  Following label was not removed, so current label
                  --  is not a candidate header.

                  No_Header (N);

               else

                  --  Following label was part of inner loop. Current
                  --  label is still a candidate.

                  Try_Loop (N);
                  Succ := Next_Elmt (N);
               end if;

            elsif Nkind (Node (Succ)) = N_Goto_Statement then
               Try_Loop (N);
               Succ := Next_Elmt (N);
            end if;

         elsif Nkind (Node (N)) = N_Goto_Statement then
            Process_Goto (N);
            Succ := Next_Elmt (N);
         end if;

         N := Succ;
      end loop;
   end Find_Natural_Loops;

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

   Find_Natural_Loops;

end Labl;