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 26separate (Par) 27procedure 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 485begin 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 543end Labl; 544