gcc/ada/par-labl.adb

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