1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ E L I M -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1997-2003 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, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, 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 27with Atree; use Atree; 28with Einfo; use Einfo; 29with Errout; use Errout; 30with Namet; use Namet; 31with Nlists; use Nlists; 32with Sinfo; use Sinfo; 33with Snames; use Snames; 34with Stand; use Stand; 35with Stringt; use Stringt; 36with Table; 37with Uintp; use Uintp; 38 39with GNAT.HTable; use GNAT.HTable; 40package body Sem_Elim is 41 42 No_Elimination : Boolean; 43 -- Set True if no Eliminate pragmas active 44 45 --------------------- 46 -- Data Structures -- 47 --------------------- 48 49 -- A single pragma Eliminate is represented by the following record 50 51 type Elim_Data; 52 type Access_Elim_Data is access Elim_Data; 53 54 type Names is array (Nat range <>) of Name_Id; 55 -- Type used to represent set of names. Used for names in Unit_Name 56 -- and also the set of names in Argument_Types. 57 58 type Access_Names is access Names; 59 60 type Elim_Data is record 61 62 Unit_Name : Access_Names; 63 -- Unit name, broken down into a set of names (e.g. A.B.C is 64 -- represented as Name_Id values for A, B, C in sequence). 65 66 Entity_Name : Name_Id; 67 -- Entity name if Entity parameter if present. If no Entity parameter 68 -- was supplied, then Entity_Node is set to Empty, and the Entity_Name 69 -- field contains the last identifier name in the Unit_Name. 70 71 Entity_Scope : Access_Names; 72 -- Static scope of the entity within the compilation unit represented by 73 -- Unit_Name. 74 75 Entity_Node : Node_Id; 76 -- Save node of entity argument, for posting error messages. Set 77 -- to Empty if there is no entity argument. 78 79 Parameter_Types : Access_Names; 80 -- Set to set of names given for parameter types. If no parameter 81 -- types argument is present, this argument is set to null. 82 83 Result_Type : Name_Id; 84 -- Result type name if Result_Types parameter present, No_Name if not 85 86 Homonym_Number : Uint; 87 -- Homonyn number if Homonym_Number parameter present, No_Uint if not. 88 89 Hash_Link : Access_Elim_Data; 90 -- Link for hash table use 91 92 Homonym : Access_Elim_Data; 93 -- Pointer to next entry with same key 94 95 Prag : Node_Id; 96 -- Node_Id for Eliminate pragma 97 98 end record; 99 100 ---------------- 101 -- Hash_Table -- 102 ---------------- 103 104 -- Setup hash table using the Entity_Name field as the hash key 105 106 subtype Element is Elim_Data; 107 subtype Elmt_Ptr is Access_Elim_Data; 108 109 subtype Key is Name_Id; 110 111 type Header_Num is range 0 .. 1023; 112 113 Null_Ptr : constant Elmt_Ptr := null; 114 115 ---------------------- 116 -- Hash_Subprograms -- 117 ---------------------- 118 119 package Hash_Subprograms is 120 121 function Equal (F1, F2 : Key) return Boolean; 122 pragma Inline (Equal); 123 124 function Get_Key (E : Elmt_Ptr) return Key; 125 pragma Inline (Get_Key); 126 127 function Hash (F : Key) return Header_Num; 128 pragma Inline (Hash); 129 130 function Next (E : Elmt_Ptr) return Elmt_Ptr; 131 pragma Inline (Next); 132 133 procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr); 134 pragma Inline (Set_Next); 135 136 end Hash_Subprograms; 137 138 package body Hash_Subprograms is 139 140 ----------- 141 -- Equal -- 142 ----------- 143 144 function Equal (F1, F2 : Key) return Boolean is 145 begin 146 return F1 = F2; 147 end Equal; 148 149 ------------- 150 -- Get_Key -- 151 ------------- 152 153 function Get_Key (E : Elmt_Ptr) return Key is 154 begin 155 return E.Entity_Name; 156 end Get_Key; 157 158 ---------- 159 -- Hash -- 160 ---------- 161 162 function Hash (F : Key) return Header_Num is 163 begin 164 return Header_Num (Int (F) mod 1024); 165 end Hash; 166 167 ---------- 168 -- Next -- 169 ---------- 170 171 function Next (E : Elmt_Ptr) return Elmt_Ptr is 172 begin 173 return E.Hash_Link; 174 end Next; 175 176 -------------- 177 -- Set_Next -- 178 -------------- 179 180 procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is 181 begin 182 E.Hash_Link := Next; 183 end Set_Next; 184 end Hash_Subprograms; 185 186 ------------ 187 -- Tables -- 188 ------------ 189 190 -- The following table records the data for each pragmas, using the 191 -- entity name as the hash key for retrieval. Entries in this table 192 -- are set by Process_Eliminate_Pragma and read by Check_Eliminated. 193 194 package Elim_Hash_Table is new Static_HTable ( 195 Header_Num => Header_Num, 196 Element => Element, 197 Elmt_Ptr => Elmt_Ptr, 198 Null_Ptr => Null_Ptr, 199 Set_Next => Hash_Subprograms.Set_Next, 200 Next => Hash_Subprograms.Next, 201 Key => Key, 202 Get_Key => Hash_Subprograms.Get_Key, 203 Hash => Hash_Subprograms.Hash, 204 Equal => Hash_Subprograms.Equal); 205 206 -- The following table records entities for subprograms that are 207 -- eliminated, and corresponding eliminate pragmas that caused the 208 -- elimination. Entries in this table are set by Check_Eliminated 209 -- and read by Eliminate_Error_Msg. 210 211 type Elim_Entity_Entry is record 212 Prag : Node_Id; 213 Subp : Entity_Id; 214 end record; 215 216 package Elim_Entities is new Table.Table ( 217 Table_Component_Type => Elim_Entity_Entry, 218 Table_Index_Type => Name_Id, 219 Table_Low_Bound => First_Name_Id, 220 Table_Initial => 50, 221 Table_Increment => 200, 222 Table_Name => "Elim_Entries"); 223 224 ---------------------- 225 -- Check_Eliminated -- 226 ---------------------- 227 228 procedure Check_Eliminated (E : Entity_Id) is 229 Elmt : Access_Elim_Data; 230 Scop : Entity_Id; 231 Form : Entity_Id; 232 Ctr : Nat; 233 Ent : Entity_Id; 234 235 begin 236 if No_Elimination then 237 return; 238 239 -- Elimination of objects and types is not implemented yet 240 241 elsif Ekind (E) not in Subprogram_Kind then 242 return; 243 end if; 244 245 Elmt := Elim_Hash_Table.Get (Chars (E)); 246 247 -- Loop through homonyms for this key 248 249 while Elmt /= null loop 250 declare 251 procedure Set_Eliminated; 252 -- Set current subprogram entity as eliminated 253 254 procedure Set_Eliminated is 255 begin 256 Set_Is_Eliminated (E); 257 Elim_Entities.Append ((Prag => Elmt.Prag, Subp => E)); 258 end Set_Eliminated; 259 260 begin 261 -- First we check that the name of the entity matches 262 263 if Elmt.Entity_Name /= Chars (E) then 264 goto Continue; 265 end if; 266 267 -- Then we need to see if the static scope matches within the 268 -- compilation unit. 269 270 Scop := Scope (E); 271 if Elmt.Entity_Scope /= null then 272 for J in reverse Elmt.Entity_Scope'Range loop 273 if Elmt.Entity_Scope (J) /= Chars (Scop) then 274 goto Continue; 275 end if; 276 277 Scop := Scope (Scop); 278 279 if not Is_Compilation_Unit (Scop) and then J = 1 then 280 goto Continue; 281 end if; 282 end loop; 283 end if; 284 285 -- Now see if compilation unit matches 286 287 for J in reverse Elmt.Unit_Name'Range loop 288 if Elmt.Unit_Name (J) /= Chars (Scop) then 289 goto Continue; 290 end if; 291 292 Scop := Scope (Scop); 293 294 if Scop /= Standard_Standard and then J = 1 then 295 goto Continue; 296 end if; 297 end loop; 298 299 if Scop /= Standard_Standard then 300 goto Continue; 301 end if; 302 303 -- Check for case of given entity is a library level subprogram 304 -- and we have the single parameter Eliminate case, a match! 305 306 if Is_Compilation_Unit (E) 307 and then Is_Subprogram (E) 308 and then No (Elmt.Entity_Node) 309 then 310 Set_Eliminated; 311 return; 312 313 -- Check for case of type or object with two parameter case 314 315 elsif (Is_Type (E) or else Is_Object (E)) 316 and then Elmt.Result_Type = No_Name 317 and then Elmt.Parameter_Types = null 318 then 319 Set_Eliminated; 320 return; 321 322 -- Check for case of subprogram 323 324 elsif Ekind (E) = E_Function 325 or else Ekind (E) = E_Procedure 326 then 327 -- If Homonym_Number present, then see if it matches 328 329 if Elmt.Homonym_Number /= No_Uint then 330 Ctr := 1; 331 332 Ent := E; 333 while Present (Homonym (Ent)) 334 and then Scope (Ent) = Scope (Homonym (Ent)) 335 loop 336 Ctr := Ctr + 1; 337 Ent := Homonym (Ent); 338 end loop; 339 340 if Ctr /= Elmt.Homonym_Number then 341 goto Continue; 342 end if; 343 end if; 344 345 -- If we have a Result_Type, then we must have a function 346 -- with the proper result type 347 348 if Elmt.Result_Type /= No_Name then 349 if Ekind (E) /= E_Function 350 or else Chars (Etype (E)) /= Elmt.Result_Type 351 then 352 goto Continue; 353 end if; 354 end if; 355 356 -- If we have Parameter_Types, they must match 357 358 if Elmt.Parameter_Types /= null then 359 Form := First_Formal (E); 360 361 if No (Form) and then Elmt.Parameter_Types = null then 362 null; 363 364 elsif Elmt.Parameter_Types = null then 365 goto Continue; 366 367 else 368 for J in Elmt.Parameter_Types'Range loop 369 if No (Form) 370 or else 371 Chars (Etype (Form)) /= Elmt.Parameter_Types (J) 372 then 373 goto Continue; 374 else 375 Next_Formal (Form); 376 end if; 377 end loop; 378 379 if Present (Form) then 380 goto Continue; 381 end if; 382 end if; 383 end if; 384 385 -- If we fall through, this is match 386 387 Set_Eliminated; 388 return; 389 end if; 390 391 <<Continue>> Elmt := Elmt.Homonym; 392 end; 393 end loop; 394 395 return; 396 end Check_Eliminated; 397 398 ------------------------- 399 -- Eliminate_Error_Msg -- 400 ------------------------- 401 402 procedure Eliminate_Error_Msg (N : Node_Id; E : Entity_Id) is 403 begin 404 for J in Elim_Entities.First .. Elim_Entities.Last loop 405 if E = Elim_Entities.Table (J).Subp then 406 Error_Msg_Sloc := Sloc (Elim_Entities.Table (J).Prag); 407 Error_Msg_NE ("cannot call subprogram & eliminated #", N, E); 408 return; 409 end if; 410 end loop; 411 412 -- Should never fall through, since entry should be in table 413 414 pragma Assert (False); 415 end Eliminate_Error_Msg; 416 417 ---------------- 418 -- Initialize -- 419 ---------------- 420 421 procedure Initialize is 422 begin 423 Elim_Hash_Table.Reset; 424 Elim_Entities.Init; 425 No_Elimination := True; 426 end Initialize; 427 428 ------------------------------ 429 -- Process_Eliminate_Pragma -- 430 ------------------------------ 431 432 procedure Process_Eliminate_Pragma 433 (Pragma_Node : Node_Id; 434 Arg_Unit_Name : Node_Id; 435 Arg_Entity : Node_Id; 436 Arg_Parameter_Types : Node_Id; 437 Arg_Result_Type : Node_Id; 438 Arg_Homonym_Number : Node_Id) 439 is 440 Data : constant Access_Elim_Data := new Elim_Data; 441 -- Build result data here 442 443 Elmt : Access_Elim_Data; 444 445 Num_Names : Nat := 0; 446 -- Number of names in unit name 447 448 Lit : Node_Id; 449 Arg_Ent : Entity_Id; 450 Arg_Uname : Node_Id; 451 452 function OK_Selected_Component (N : Node_Id) return Boolean; 453 -- Test if N is a selected component with all identifiers, or a 454 -- selected component whose selector is an operator symbol. As a 455 -- side effect if result is True, sets Num_Names to the number 456 -- of names present (identifiers and operator if any). 457 458 --------------------------- 459 -- OK_Selected_Component -- 460 --------------------------- 461 462 function OK_Selected_Component (N : Node_Id) return Boolean is 463 begin 464 if Nkind (N) = N_Identifier 465 or else Nkind (N) = N_Operator_Symbol 466 then 467 Num_Names := Num_Names + 1; 468 return True; 469 470 elsif Nkind (N) = N_Selected_Component then 471 return OK_Selected_Component (Prefix (N)) 472 and then OK_Selected_Component (Selector_Name (N)); 473 474 else 475 return False; 476 end if; 477 end OK_Selected_Component; 478 479 -- Start of processing for Process_Eliminate_Pragma 480 481 begin 482 Data.Prag := Pragma_Node; 483 Error_Msg_Name_1 := Name_Eliminate; 484 485 -- Process Unit_Name argument 486 487 if Nkind (Arg_Unit_Name) = N_Identifier then 488 Data.Unit_Name := new Names'(1 => Chars (Arg_Unit_Name)); 489 Num_Names := 1; 490 491 elsif OK_Selected_Component (Arg_Unit_Name) then 492 Data.Unit_Name := new Names (1 .. Num_Names); 493 494 Arg_Uname := Arg_Unit_Name; 495 for J in reverse 2 .. Num_Names loop 496 Data.Unit_Name (J) := Chars (Selector_Name (Arg_Uname)); 497 Arg_Uname := Prefix (Arg_Uname); 498 end loop; 499 500 Data.Unit_Name (1) := Chars (Arg_Uname); 501 502 else 503 Error_Msg_N 504 ("wrong form for Unit_Name parameter of pragma%", Arg_Unit_Name); 505 return; 506 end if; 507 508 -- Process Entity argument 509 510 if Present (Arg_Entity) then 511 Num_Names := 0; 512 513 if Nkind (Arg_Entity) = N_Identifier 514 or else Nkind (Arg_Entity) = N_Operator_Symbol 515 then 516 Data.Entity_Name := Chars (Arg_Entity); 517 Data.Entity_Node := Arg_Entity; 518 Data.Entity_Scope := null; 519 520 elsif OK_Selected_Component (Arg_Entity) then 521 Data.Entity_Scope := new Names (1 .. Num_Names - 1); 522 Data.Entity_Name := Chars (Selector_Name (Arg_Entity)); 523 Data.Entity_Node := Arg_Entity; 524 525 Arg_Ent := Prefix (Arg_Entity); 526 for J in reverse 2 .. Num_Names - 1 loop 527 Data.Entity_Scope (J) := Chars (Selector_Name (Arg_Ent)); 528 Arg_Ent := Prefix (Arg_Ent); 529 end loop; 530 531 Data.Entity_Scope (1) := Chars (Arg_Ent); 532 533 elsif Nkind (Arg_Entity) = N_String_Literal then 534 String_To_Name_Buffer (Strval (Arg_Entity)); 535 Data.Entity_Name := Name_Find; 536 Data.Entity_Node := Arg_Entity; 537 538 else 539 Error_Msg_N 540 ("wrong form for Entity_Argument parameter of pragma%", 541 Arg_Unit_Name); 542 return; 543 end if; 544 else 545 Data.Entity_Node := Empty; 546 Data.Entity_Name := Data.Unit_Name (Num_Names); 547 end if; 548 549 -- Process Parameter_Types argument 550 551 if Present (Arg_Parameter_Types) then 552 553 -- Case of one name, which looks like a parenthesized literal 554 -- rather than an aggregate. 555 556 if Nkind (Arg_Parameter_Types) = N_String_Literal 557 and then Paren_Count (Arg_Parameter_Types) = 1 558 then 559 String_To_Name_Buffer (Strval (Arg_Parameter_Types)); 560 Data.Parameter_Types := new Names'(1 => Name_Find); 561 562 -- Otherwise must be an aggregate 563 564 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate 565 or else Present (Component_Associations (Arg_Parameter_Types)) 566 or else No (Expressions (Arg_Parameter_Types)) 567 then 568 Error_Msg_N 569 ("Parameter_Types for pragma% must be list of string literals", 570 Arg_Parameter_Types); 571 return; 572 573 -- Here for aggregate case 574 575 else 576 Data.Parameter_Types := 577 new Names 578 (1 .. List_Length (Expressions (Arg_Parameter_Types))); 579 580 Lit := First (Expressions (Arg_Parameter_Types)); 581 for J in Data.Parameter_Types'Range loop 582 if Nkind (Lit) /= N_String_Literal then 583 Error_Msg_N 584 ("parameter types for pragma% must be string literals", 585 Lit); 586 return; 587 end if; 588 589 String_To_Name_Buffer (Strval (Lit)); 590 Data.Parameter_Types (J) := Name_Find; 591 Next (Lit); 592 end loop; 593 end if; 594 end if; 595 596 -- Process Result_Types argument 597 598 if Present (Arg_Result_Type) then 599 600 if Nkind (Arg_Result_Type) /= N_String_Literal then 601 Error_Msg_N 602 ("Result_Type argument for pragma% must be string literal", 603 Arg_Result_Type); 604 return; 605 end if; 606 607 String_To_Name_Buffer (Strval (Arg_Result_Type)); 608 Data.Result_Type := Name_Find; 609 610 else 611 Data.Result_Type := No_Name; 612 end if; 613 614 -- Process Homonym_Number argument 615 616 if Present (Arg_Homonym_Number) then 617 618 if Nkind (Arg_Homonym_Number) /= N_Integer_Literal then 619 Error_Msg_N 620 ("Homonym_Number argument for pragma% must be integer literal", 621 Arg_Homonym_Number); 622 return; 623 end if; 624 625 Data.Homonym_Number := Intval (Arg_Homonym_Number); 626 627 else 628 Data.Homonym_Number := No_Uint; 629 end if; 630 631 -- Now link this new entry into the hash table 632 633 Elmt := Elim_Hash_Table.Get (Hash_Subprograms.Get_Key (Data)); 634 635 -- If we already have an entry with this same key, then link 636 -- it into the chain of entries for this key. 637 638 if Elmt /= null then 639 Data.Homonym := Elmt.Homonym; 640 Elmt.Homonym := Data; 641 642 -- Otherwise create a new entry 643 644 else 645 Elim_Hash_Table.Set (Data); 646 end if; 647 648 No_Elimination := False; 649 end Process_Eliminate_Pragma; 650 651end Sem_Elim; 652