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-2006, 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 2,  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 COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 separate (Par)
  28 procedure Labl is
  29    Enclosing_Body_Or_Block : Node_Id;
  30    --  Innermost enclosing body or block statement
  31
  32    Label_Decl_Node : Node_Id;
  33    --  Implicit label declaration node
  34
  35    Defining_Ident_Node : Node_Id;
  36    --  Defining identifier node for implicit label declaration
  37
  38    Next_Label_Elmt : Elmt_Id;
  39    --  Next element on label element list
  40
  41    Label_Node : Node_Id;
  42    --  Next label node to process
  43
  44    function Find_Enclosing_Body_Or_Block (N : Node_Id) return Node_Id;
  45    --  Find the innermost body or block that encloses N
  46
  47    function Find_Enclosing_Body (N : Node_Id) return Node_Id;
  48    --  Find the innermost body that encloses N
  49
  50    procedure Check_Distinct_Labels;
  51    --  Checks the rule in RM-5.1(11), which requires distinct identifiers
  52    --  for all the labels in a given body.
  53
  54    procedure Find_Natural_Loops;
  55    --  Recognizes loops created by backward gotos, and rewrites the
  56    --  corresponding statements into a proper loop, for optimization
  57    --  purposes (for example, to control reclaiming local storage).
  58
  59    ---------------------------
  60    -- Check_Distinct_Labels --
  61    ---------------------------
  62
  63    procedure Check_Distinct_Labels is
  64       Label_Id : constant Node_Id := Identifier (Label_Node);
  65
  66       Enclosing_Body : constant Node_Id :=
  67                          Find_Enclosing_Body (Enclosing_Body_Or_Block);
  68       --  Innermost enclosing body
  69
  70       Next_Other_Label_Elmt : Elmt_Id := First_Elmt (Label_List);
  71       --  Next element on label element list
  72
  73       Other_Label : Node_Id;
  74       --  Next label node to process
  75
  76    begin
  77       --  Loop through all the labels, and if we find some other label
  78       --  (i.e. not Label_Node) that has the same identifier,
  79       --  and whose innermost enclosing body is the same,
  80       --  then we have an error.
  81
  82       --  Note that in the worst case, this is quadratic in the number
  83       --  of labels.  However, labels are not all that common, and this
  84       --  is only called for explicit labels.
  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 goto's 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 goto's
 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       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            ("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                   if Parent (Node (N)) = Parent (Node (S1)) then
 380                      Source := S1;
 381                      Found  := True;
 382
 383                   else
 384                      --  The goto is within some nested structure
 385
 386                      No_Header (N);
 387                      return;
 388                   end if;
 389
 390                else
 391                   --  More than one goto with the same target
 392
 393                   No_Header (N);
 394                   return;
 395                end if;
 396
 397             elsif Nkind (Node (S1)) = N_Label
 398               and then not Found
 399             then
 400                --  Intervening label before possible end of loop. Current
 401                --  label is not a candidate. This is conservative, because
 402                --  the label might not be the target of any jumps, but not
 403                --  worth dealing with useless labels!
 404
 405                No_Header (N);
 406                return;
 407
 408             else
 409                --  If the node is a loop_statement, it corresponds to a
 410                --  label-goto pair rewritten as a loop. Continue forward scan.
 411
 412                null;
 413             end if;
 414
 415             Next_Elmt (S1);
 416          end loop;
 417
 418          if Found then
 419             Rewrite_As_Loop (Node (N), Node (Source));
 420             Remove_Elmt (Node_List, N);
 421             Remove_Elmt (Node_List, Source);
 422          end if;
 423       end Try_Loop;
 424
 425    begin
 426       --  Start of processing for Find_Natural_Loops
 427
 428       Merge;
 429
 430       N := First_Elmt (Node_List);
 431       while Present (N) loop
 432          Succ := Next_Elmt (N);
 433
 434          if Nkind (Node (N)) = N_Label then
 435             if No (Succ) then
 436                exit;
 437
 438             elsif Nkind (Node (Succ)) = N_Label then
 439                Try_Loop (Succ);
 440
 441                --  If a loop was found, the label has been removed, and
 442                --  the following goto rewritten as the loop body.
 443
 444                Succ := Next_Elmt (N);
 445
 446                if Nkind (Node (Succ)) = N_Label then
 447
 448                   --  Following label was not removed, so current label
 449                   --  is not a candidate header.
 450
 451                   No_Header (N);
 452
 453                else
 454
 455                   --  Following label was part of inner loop. Current
 456                   --  label is still a candidate.
 457
 458                   Try_Loop (N);
 459                   Succ := Next_Elmt (N);
 460                end if;
 461
 462             elsif Nkind (Node (Succ)) = N_Goto_Statement then
 463                Try_Loop (N);
 464                Succ := Next_Elmt (N);
 465             end if;
 466
 467          elsif Nkind (Node (N)) = N_Goto_Statement then
 468             Process_Goto (N);
 469             Succ := Next_Elmt (N);
 470          end if;
 471
 472          N := Succ;
 473       end loop;
 474    end Find_Natural_Loops;
 475
 476 --  Start of processing for Par.Labl
 477
 478 begin
 479    Next_Label_Elmt := First_Elmt (Label_List);
 480
 481    while Present (Next_Label_Elmt) loop
 482       Label_Node := Node (Next_Label_Elmt);
 483
 484       if not Comes_From_Source (Label_Node) then
 485          goto Next_Label;
 486       end if;
 487
 488       --  Find the innermost enclosing body or block, which is where
 489       --  we need to implicitly declare this label
 490
 491       Enclosing_Body_Or_Block := Find_Enclosing_Body_Or_Block (Label_Node);
 492
 493       --  If we didn't find a parent, then the label in question never got
 494       --  hooked into a reasonable declarative part. This happens only in
 495       --  error situations, and we simply ignore the entry (we aren't going
 496       --  to get into the semantics in any case given the error).
 497
 498       if Present (Enclosing_Body_Or_Block) then
 499          Check_Distinct_Labels;
 500
 501          --  Now create the implicit label declaration node and its
 502          --  corresponding defining identifier. Note that the defining
 503          --  occurrence of a label is the implicit label declaration that
 504          --  we are creating. The label itself is an applied occurrence.
 505
 506          Label_Decl_Node :=
 507            New_Node (N_Implicit_Label_Declaration, Sloc (Label_Node));
 508          Defining_Ident_Node :=
 509            New_Entity (N_Defining_Identifier, Sloc (Identifier (Label_Node)));
 510          Set_Chars (Defining_Ident_Node, Chars (Identifier (Label_Node)));
 511          Set_Defining_Identifier (Label_Decl_Node, Defining_Ident_Node);
 512          Set_Label_Construct (Label_Decl_Node, Label_Node);
 513
 514          --  The following makes sure that Comes_From_Source is appropriately
 515          --  set for the entity, depending on whether the label appeared in
 516          --  the source explicitly or not.
 517
 518          Set_Comes_From_Source
 519           (Defining_Ident_Node, Comes_From_Source (Identifier (Label_Node)));
 520
 521          --  Now attach the implicit label declaration to the appropriate
 522          --  declarative region, creating a declaration list if none exists
 523
 524          if No (Declarations (Enclosing_Body_Or_Block)) then
 525             Set_Declarations (Enclosing_Body_Or_Block, New_List);
 526          end if;
 527
 528          Append (Label_Decl_Node, Declarations (Enclosing_Body_Or_Block));
 529       end if;
 530
 531       <<Next_Label>>
 532          Next_Elmt (Next_Label_Elmt);
 533    end loop;
 534
 535    Find_Natural_Loops;
 536
 537 end Labl;