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