1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ T S S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2019, 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 26with Atree; use Atree; 27with Einfo; use Einfo; 28with Elists; use Elists; 29with Exp_Util; use Exp_Util; 30with Nlists; use Nlists; 31with Lib; use Lib; 32with Restrict; use Restrict; 33with Rident; use Rident; 34with Sem_Aux; use Sem_Aux; 35with Sem_Ch6; use Sem_Ch6; 36with Sem_Util; use Sem_Util; 37with Sinfo; use Sinfo; 38 39package body Exp_Tss is 40 41 -------------------- 42 -- Base_Init_Proc -- 43 -------------------- 44 45 function Base_Init_Proc 46 (Typ : Entity_Id; 47 Ref : Entity_Id := Empty) return Entity_Id 48 is 49 Full_Type : E; 50 Proc : Entity_Id; 51 52 begin 53 pragma Assert (Is_Type (Typ)); 54 55 if Is_Private_Type (Typ) then 56 Full_Type := Underlying_Type (Base_Type (Typ)); 57 else 58 Full_Type := Typ; 59 end if; 60 61 if No (Full_Type) then 62 return Empty; 63 64 elsif Is_Concurrent_Type (Full_Type) 65 and then Present (Corresponding_Record_Type (Base_Type (Full_Type))) 66 then 67 -- The initialization routine to be called is that of the base type 68 -- of the corresponding record type, which may itself be a subtype 69 -- and possibly an itype. 70 71 return Init_Proc 72 (Base_Type (Corresponding_Record_Type (Base_Type (Full_Type))), 73 Ref); 74 75 else 76 Proc := Init_Proc (Base_Type (Full_Type), Ref); 77 78 if No (Proc) 79 and then Is_Composite_Type (Full_Type) 80 and then Is_Derived_Type (Full_Type) 81 then 82 return Init_Proc (Root_Type (Full_Type), Ref); 83 else 84 return Proc; 85 end if; 86 end if; 87 end Base_Init_Proc; 88 89 -------------- 90 -- Copy_TSS -- 91 -------------- 92 93 -- Note: internally this routine is also used to initially set up 94 -- a TSS entry for a new type (case of being called from Set_TSS) 95 96 procedure Copy_TSS (TSS : Entity_Id; Typ : Entity_Id) is 97 FN : Node_Id; 98 99 begin 100 Ensure_Freeze_Node (Typ); 101 FN := Freeze_Node (Typ); 102 103 if No (TSS_Elist (FN)) then 104 Set_TSS_Elist (FN, New_Elmt_List); 105 end if; 106 107 -- We prepend here, so that a second call overrides the first, it 108 -- is not clear that this is required, but it seems reasonable. 109 110 Prepend_Elmt (TSS, TSS_Elist (FN)); 111 end Copy_TSS; 112 113 ------------------- 114 -- CPP_Init_Proc -- 115 ------------------- 116 117 function CPP_Init_Proc (Typ : Entity_Id) return Entity_Id is 118 FN : constant Node_Id := Freeze_Node (Typ); 119 Elmt : Elmt_Id; 120 121 begin 122 if not Is_CPP_Class (Root_Type (Typ)) 123 or else No (FN) 124 or else No (TSS_Elist (FN)) 125 then 126 return Empty; 127 128 else 129 Elmt := First_Elmt (TSS_Elist (FN)); 130 while Present (Elmt) loop 131 if Is_CPP_Init_Proc (Node (Elmt)) then 132 return Node (Elmt); 133 end if; 134 135 Next_Elmt (Elmt); 136 end loop; 137 end if; 138 139 return Empty; 140 end CPP_Init_Proc; 141 142 ------------------------ 143 -- Find_Inherited_TSS -- 144 ------------------------ 145 146 function Find_Inherited_TSS 147 (Typ : Entity_Id; 148 Nam : TSS_Name_Type) return Entity_Id 149 is 150 Btyp : Entity_Id := Typ; 151 Proc : Entity_Id; 152 153 begin 154 loop 155 Btyp := Base_Type (Btyp); 156 Proc := TSS (Btyp, Nam); 157 158 exit when Present (Proc) 159 or else not Is_Derived_Type (Btyp); 160 161 -- If Typ is a derived type, it may inherit attributes from some 162 -- ancestor. 163 164 Btyp := Etype (Btyp); 165 end loop; 166 167 if No (Proc) then 168 169 -- If nothing else, use the TSS of the root type 170 171 Proc := TSS (Base_Type (Underlying_Type (Typ)), Nam); 172 end if; 173 174 return Proc; 175 end Find_Inherited_TSS; 176 177 ------------------ 178 -- Get_TSS_Name -- 179 ------------------ 180 181 function Get_TSS_Name (E : Entity_Id) return TSS_Name_Type is 182 C1 : Character; 183 C2 : Character; 184 Nm : TSS_Name_Type; 185 186 begin 187 Get_Last_Two_Chars (Chars (E), C1, C2); 188 189 if C1 in 'A' .. 'Z' and then C2 in 'A' .. 'Z' then 190 Nm := (C1, C2); 191 192 for J in TSS_Names'Range loop 193 if Nm = TSS_Names (J) then 194 return Nm; 195 end if; 196 end loop; 197 end if; 198 199 return TSS_Null; 200 end Get_TSS_Name; 201 202 --------------------------------- 203 -- Has_Non_Null_Base_Init_Proc -- 204 --------------------------------- 205 206 -- Note: if a base Init_Proc is present, and No_Default_Initialization is 207 -- present, then we must avoid testing for a null init proc, since there 208 -- is no init proc present in this case. 209 210 function Has_Non_Null_Base_Init_Proc (Typ : Entity_Id) return Boolean is 211 BIP : constant Entity_Id := Base_Init_Proc (Typ); 212 begin 213 return Present (BIP) 214 and then (Restriction_Active (No_Default_Initialization) 215 or else not Is_Null_Init_Proc (BIP)); 216 end Has_Non_Null_Base_Init_Proc; 217 218 --------------- 219 -- Init_Proc -- 220 --------------- 221 222 function Init_Proc 223 (Typ : Entity_Id; 224 Ref : Entity_Id := Empty) return Entity_Id 225 is 226 FN : constant Node_Id := Freeze_Node (Typ); 227 Elmt : Elmt_Id; 228 E1 : Entity_Id; 229 E2 : Entity_Id; 230 231 begin 232 if No (FN) then 233 return Empty; 234 235 elsif No (TSS_Elist (FN)) then 236 return Empty; 237 238 elsif No (Ref) then 239 Elmt := First_Elmt (TSS_Elist (FN)); 240 while Present (Elmt) loop 241 if Is_Init_Proc (Node (Elmt)) then 242 if not Is_CPP_Class (Typ) then 243 return Node (Elmt); 244 245 -- For CPP classes, we are looking for the default constructor, 246 -- and so we must skip any non-default constructor. 247 248 elsif 249 No (Next 250 (First 251 (Parameter_Specifications (Parent (Node (Elmt)))))) 252 then 253 return Node (Elmt); 254 end if; 255 end if; 256 257 Next_Elmt (Elmt); 258 end loop; 259 260 -- Non-default constructors are currently supported only in the context 261 -- of interfacing with C++. 262 263 else pragma Assert (Is_CPP_Class (Typ)); 264 265 -- Use the referenced function to locate the init_proc matching 266 -- the C++ constructor. 267 268 Elmt := First_Elmt (TSS_Elist (FN)); 269 while Present (Elmt) loop 270 if Is_Init_Proc (Node (Elmt)) then 271 E1 := Next_Formal (First_Formal (Node (Elmt))); 272 E2 := First_Formal (Ref); 273 while Present (E1) and then Present (E2) loop 274 if Chars (E1) /= Chars (E2) 275 or else Ekind (E1) /= Ekind (E2) 276 then 277 exit; 278 279 elsif not Is_Anonymous_Access_Type (Etype (E1)) 280 and then not Is_Anonymous_Access_Type (Etype (E2)) 281 and then Etype (E1) /= Etype (E2) 282 then 283 exit; 284 285 elsif Ekind (Etype (E1)) = E_Anonymous_Access_Type 286 and then Ekind (Etype (E2)) = E_Anonymous_Access_Type 287 and then Directly_Designated_Type (Etype (E1)) 288 /= Directly_Designated_Type (Etype (E2)) 289 then 290 exit; 291 292 elsif Ekind_In (Etype (E1), 293 E_Anonymous_Access_Subprogram_Type, 294 E_Anonymous_Access_Protected_Subprogram_Type) 295 and then Ekind_In (Etype (E2), 296 E_Anonymous_Access_Subprogram_Type, 297 E_Anonymous_Access_Protected_Subprogram_Type) 298 and then not Conforming_Types 299 (Etype (E1), Etype (E2), Fully_Conformant) 300 then 301 exit; 302 end if; 303 304 E1 := Next_Formal (E1); 305 E2 := Next_Formal (E2); 306 end loop; 307 308 if No (E1) and then No (E2) then 309 return Node (Elmt); 310 end if; 311 end if; 312 313 Next_Elmt (Elmt); 314 end loop; 315 end if; 316 317 return Empty; 318 end Init_Proc; 319 320 ---------------------- 321 -- Is_CPP_Init_Proc -- 322 ---------------------- 323 324 function Is_CPP_Init_Proc (E : Entity_Id) return Boolean is 325 C1 : Character; 326 C2 : Character; 327 begin 328 Get_Last_Two_Chars (Chars (E), C1, C2); 329 return C1 = TSS_CPP_Init_Proc (1) and then C2 = TSS_CPP_Init_Proc (2); 330 end Is_CPP_Init_Proc; 331 332 ------------------ 333 -- Is_Init_Proc -- 334 ------------------ 335 336 function Is_Init_Proc (E : Entity_Id) return Boolean is 337 C1 : Character; 338 C2 : Character; 339 begin 340 Get_Last_Two_Chars (Chars (E), C1, C2); 341 return C1 = TSS_Init_Proc (1) and then C2 = TSS_Init_Proc (2); 342 end Is_Init_Proc; 343 344 ------------ 345 -- Is_TSS -- 346 ------------ 347 348 function Is_TSS (E : Entity_Id; Nam : TSS_Name_Type) return Boolean is 349 C1 : Character; 350 C2 : Character; 351 begin 352 Get_Last_Two_Chars (Chars (E), C1, C2); 353 return C1 = Nam (1) and then C2 = Nam (2); 354 end Is_TSS; 355 356 function Is_TSS (N : Name_Id; Nam : TSS_Name_Type) return Boolean is 357 C1 : Character; 358 C2 : Character; 359 begin 360 Get_Last_Two_Chars (N, C1, C2); 361 return C1 = Nam (1) and then C2 = Nam (2); 362 end Is_TSS; 363 364 ------------------------- 365 -- Make_Init_Proc_Name -- 366 ------------------------- 367 368 function Make_Init_Proc_Name (Typ : Entity_Id) return Name_Id is 369 begin 370 return Make_TSS_Name (Typ, TSS_Init_Proc); 371 end Make_Init_Proc_Name; 372 373 ------------------- 374 -- Make_TSS_Name -- 375 ------------------- 376 377 function Make_TSS_Name 378 (Typ : Entity_Id; 379 Nam : TSS_Name_Type) return Name_Id 380 is 381 begin 382 Get_Name_String (Chars (Typ)); 383 Add_Char_To_Name_Buffer (Nam (1)); 384 Add_Char_To_Name_Buffer (Nam (2)); 385 return Name_Find; 386 end Make_TSS_Name; 387 388 ------------------------- 389 -- Make_TSS_Name_Local -- 390 ------------------------- 391 392 function Make_TSS_Name_Local 393 (Typ : Entity_Id; 394 Nam : TSS_Name_Type) return Name_Id 395 is 396 begin 397 Get_Name_String (Chars (Typ)); 398 Add_Char_To_Name_Buffer ('_'); 399 Add_Nat_To_Name_Buffer (Increment_Serial_Number); 400 Add_Char_To_Name_Buffer (Nam (1)); 401 Add_Char_To_Name_Buffer (Nam (2)); 402 return Name_Find; 403 end Make_TSS_Name_Local; 404 405 -------------- 406 -- Same_TSS -- 407 -------------- 408 409 function Same_TSS (E1, E2 : Entity_Id) return Boolean is 410 E1C1 : Character; 411 E1C2 : Character; 412 E2C1 : Character; 413 E2C2 : Character; 414 415 begin 416 Get_Last_Two_Chars (Chars (E1), E1C1, E1C2); 417 Get_Last_Two_Chars (Chars (E2), E2C1, E2C2); 418 419 return 420 E1C1 = E2C1 421 and then 422 E1C2 = E2C2 423 and then 424 E1C1 in 'A' .. 'Z' 425 and then 426 E1C2 in 'A' .. 'Z'; 427 end Same_TSS; 428 429 ------------------- 430 -- Set_Init_Proc -- 431 ------------------- 432 433 procedure Set_Init_Proc (Typ : Entity_Id; Init : Entity_Id) is 434 begin 435 Set_TSS (Typ, Init); 436 end Set_Init_Proc; 437 438 ------------- 439 -- Set_TSS -- 440 ------------- 441 442 procedure Set_TSS (Typ : Entity_Id; TSS : Entity_Id) is 443 begin 444 -- Make sure body of subprogram is frozen 445 446 -- Skip this for Init_Proc with No_Default_Initialization, since the 447 -- Init proc is a dummy void entity in this case to be ignored. 448 449 if (Is_Init_Proc (TSS) or else Is_CPP_Init_Proc (TSS)) 450 and then Restriction_Active (No_Default_Initialization) 451 then 452 null; 453 454 -- Skip this if not in the same code unit (since it means we are using 455 -- an already existing TSS in another unit) 456 457 elsif not In_Same_Code_Unit (Typ, TSS) then 458 null; 459 460 -- Otherwise make sure body is frozen 461 462 else 463 Append_Freeze_Action (Typ, Unit_Declaration_Node (TSS)); 464 end if; 465 466 -- Set TSS entry 467 468 Copy_TSS (TSS, Typ); 469 end Set_TSS; 470 471 --------- 472 -- TSS -- 473 --------- 474 475 function TSS (Typ : Entity_Id; Nam : TSS_Name_Type) return Entity_Id is 476 FN : constant Node_Id := Freeze_Node (Typ); 477 Elmt : Elmt_Id; 478 Subp : Entity_Id; 479 480 begin 481 if No (FN) then 482 return Empty; 483 484 elsif No (TSS_Elist (FN)) then 485 return Empty; 486 487 else 488 Elmt := First_Elmt (TSS_Elist (FN)); 489 while Present (Elmt) loop 490 if Is_TSS (Node (Elmt), Nam) then 491 Subp := Node (Elmt); 492 493 -- For stream subprograms, the TSS entity may be a renaming- 494 -- as-body of an already generated entity. Use that one rather 495 -- the one introduced by the renaming, which is an artifact of 496 -- current stream handling. 497 498 if Nkind (Parent (Parent (Subp))) = 499 N_Subprogram_Renaming_Declaration 500 and then 501 Present (Corresponding_Spec (Parent (Parent (Subp)))) 502 then 503 return Corresponding_Spec (Parent (Parent (Subp))); 504 else 505 return Subp; 506 end if; 507 508 else 509 Next_Elmt (Elmt); 510 end if; 511 end loop; 512 end if; 513 514 return Empty; 515 end TSS; 516 517 function TSS (Typ : Entity_Id; Nam : Name_Id) return Entity_Id is 518 FN : constant Node_Id := Freeze_Node (Typ); 519 Elmt : Elmt_Id; 520 Subp : Entity_Id; 521 522 begin 523 if No (FN) then 524 return Empty; 525 526 elsif No (TSS_Elist (FN)) then 527 return Empty; 528 529 else 530 Elmt := First_Elmt (TSS_Elist (FN)); 531 while Present (Elmt) loop 532 if Chars (Node (Elmt)) = Nam then 533 Subp := Node (Elmt); 534 535 -- For stream subprograms, the TSS entity may be a renaming- 536 -- as-body of an already generated entity. Use that one rather 537 -- the one introduced by the renaming, which is an artifact of 538 -- current stream handling. 539 540 if Nkind (Parent (Parent (Subp))) = 541 N_Subprogram_Renaming_Declaration 542 and then 543 Present (Corresponding_Spec (Parent (Parent (Subp)))) 544 then 545 return Corresponding_Spec (Parent (Parent (Subp))); 546 else 547 return Subp; 548 end if; 549 550 else 551 Next_Elmt (Elmt); 552 end if; 553 end loop; 554 end if; 555 556 return Empty; 557 end TSS; 558 559end Exp_Tss; 560