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-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 Elists; use Elists; 30with Exp_Util; use Exp_Util; 31with Lib; use Lib; 32with Namet; use Namet; 33with Sem_Util; use Sem_Util; 34with Sinfo; use Sinfo; 35 36package body Exp_Tss is 37 38 -------------------- 39 -- Base_Init_Proc -- 40 -------------------- 41 42 function Base_Init_Proc (Typ : Entity_Id) return Entity_Id is 43 Full_Type : E; 44 Proc : Entity_Id; 45 46 begin 47 pragma Assert (Ekind (Typ) in Type_Kind); 48 49 if Is_Private_Type (Typ) then 50 Full_Type := Underlying_Type (Base_Type (Typ)); 51 else 52 Full_Type := Typ; 53 end if; 54 55 if No (Full_Type) then 56 return Empty; 57 elsif Is_Concurrent_Type (Full_Type) 58 and then Present (Corresponding_Record_Type (Base_Type (Full_Type))) 59 then 60 return Init_Proc (Corresponding_Record_Type (Base_Type (Full_Type))); 61 62 else 63 Proc := Init_Proc (Base_Type (Full_Type)); 64 65 if No (Proc) 66 and then Is_Composite_Type (Full_Type) 67 and then Is_Derived_Type (Full_Type) 68 then 69 return Init_Proc (Root_Type (Full_Type)); 70 else 71 return Proc; 72 end if; 73 end if; 74 end Base_Init_Proc; 75 76 -------------- 77 -- Copy_TSS -- 78 -------------- 79 80 -- Note: internally this routine is also used to initially set up 81 -- a TSS entry for a new type (case of being called from Set_TSS) 82 83 procedure Copy_TSS (TSS : Entity_Id; Typ : Entity_Id) is 84 FN : Node_Id; 85 86 begin 87 Ensure_Freeze_Node (Typ); 88 FN := Freeze_Node (Typ); 89 90 if No (TSS_Elist (FN)) then 91 Set_TSS_Elist (FN, New_Elmt_List); 92 end if; 93 94 -- We prepend here, so that a second call overrides the first, it 95 -- is not clear that this is required, but it seems reasonable. 96 97 Prepend_Elmt (TSS, TSS_Elist (FN)); 98 end Copy_TSS; 99 100 ----------------------- 101 -- Get_TSS_Name_Type -- 102 ----------------------- 103 104 function Get_TSS_Name (E : Entity_Id) return TSS_Name_Type is 105 C1 : Character; 106 C2 : Character; 107 Nm : TSS_Name_Type; 108 109 begin 110 Get_Last_Two_Chars (Chars (E), C1, C2); 111 112 if C1 in 'A' .. 'Z' and then C2 in 'A' .. 'Z' then 113 Nm := (C1, C2); 114 115 for J in OK_TSS_Names'Range loop 116 if Nm = OK_TSS_Names (J) then 117 return Nm; 118 end if; 119 end loop; 120 end if; 121 122 return TSS_Null; 123 end Get_TSS_Name; 124 125 --------------------------------- 126 -- Has_Non_Null_Base_Init_Proc -- 127 --------------------------------- 128 129 function Has_Non_Null_Base_Init_Proc (Typ : Entity_Id) return Boolean is 130 BIP : constant Entity_Id := Base_Init_Proc (Typ); 131 132 begin 133 return Present (BIP) and then not Is_Null_Init_Proc (BIP); 134 end Has_Non_Null_Base_Init_Proc; 135 136 --------------- 137 -- Init_Proc -- 138 --------------- 139 140 function Init_Proc (Typ : Entity_Id) return Entity_Id is 141 FN : constant Node_Id := Freeze_Node (Typ); 142 Elmt : Elmt_Id; 143 144 begin 145 if No (FN) then 146 return Empty; 147 148 elsif No (TSS_Elist (FN)) then 149 return Empty; 150 151 else 152 Elmt := First_Elmt (TSS_Elist (FN)); 153 while Present (Elmt) loop 154 if Is_Init_Proc (Node (Elmt)) then 155 return Node (Elmt); 156 end if; 157 158 Next_Elmt (Elmt); 159 end loop; 160 end if; 161 162 return Empty; 163 end Init_Proc; 164 165 ------------------ 166 -- Is_Init_Proc -- 167 ------------------ 168 169 function Is_Init_Proc (E : Entity_Id) return Boolean is 170 C1 : Character; 171 C2 : Character; 172 begin 173 Get_Last_Two_Chars (Chars (E), C1, C2); 174 return C1 = TSS_Init_Proc (1) and then C2 = TSS_Init_Proc (2); 175 end Is_Init_Proc; 176 177 ------------ 178 -- Is_TSS -- 179 ------------ 180 181 function Is_TSS (E : Entity_Id; Nam : TSS_Name_Type) return Boolean is 182 C1 : Character; 183 C2 : Character; 184 begin 185 Get_Last_Two_Chars (Chars (E), C1, C2); 186 return C1 = Nam (1) and then C2 = Nam (2); 187 end Is_TSS; 188 189 function Is_TSS (N : Name_Id; Nam : TSS_Name_Type) return Boolean is 190 C1 : Character; 191 C2 : Character; 192 begin 193 Get_Last_Two_Chars (N, C1, C2); 194 return C1 = Nam (1) and then C2 = Nam (2); 195 end Is_TSS; 196 197 ------------------------- 198 -- Make_Init_Proc_Name -- 199 ------------------------- 200 201 function Make_Init_Proc_Name (Typ : Entity_Id) return Name_Id is 202 begin 203 Get_Name_String (Chars (Typ)); 204 Name_Len := Name_Len + 2; 205 Name_Buffer (Name_Len - 1) := TSS_Init_Proc (1); 206 Name_Buffer (Name_Len) := TSS_Init_Proc (2); 207 return Name_Find; 208 end Make_Init_Proc_Name; 209 210 ------------------------- 211 -- Make_TSS_Name_Local -- 212 ------------------------- 213 214 function Make_TSS_Name_Local 215 (Typ : Entity_Id; 216 Nam : TSS_Name_Type) return Name_Id 217 is 218 begin 219 Get_Name_String (Chars (Typ)); 220 Add_Char_To_Name_Buffer (Nam (1)); 221 Add_Char_To_Name_Buffer (Nam (2)); 222 Add_Char_To_Name_Buffer ('_'); 223 Add_Nat_To_Name_Buffer (Increment_Serial_Number); 224 return Name_Find; 225 end Make_TSS_Name_Local; 226 227 ------------------- 228 -- Make_TSS_Name -- 229 ------------------- 230 231 function Make_TSS_Name 232 (Typ : Entity_Id; 233 Nam : TSS_Name_Type) return Name_Id 234 is 235 begin 236 Get_Name_String (Chars (Typ)); 237 Add_Char_To_Name_Buffer (Nam (1)); 238 Add_Char_To_Name_Buffer (Nam (2)); 239 return Name_Find; 240 end Make_TSS_Name; 241 242 -------------- 243 -- Same_TSS -- 244 -------------- 245 246 function Same_TSS (E1, E2 : Entity_Id) return Boolean is 247 E1C1 : Character; 248 E1C2 : Character; 249 E2C1 : Character; 250 E2C2 : Character; 251 252 begin 253 Get_Last_Two_Chars (Chars (E1), E1C1, E1C2); 254 Get_Last_Two_Chars (Chars (E2), E2C1, E2C2); 255 256 return 257 E1C1 = E2C1 258 and then 259 E1C2 = E2C2 260 and then 261 E1C1 in 'A' .. 'Z' 262 and then 263 E1C2 in 'A' .. 'Z'; 264 end Same_TSS; 265 266 ------------------- 267 -- Set_Init_Proc -- 268 ------------------- 269 270 procedure Set_Init_Proc (Typ : Entity_Id; Init : Entity_Id) is 271 begin 272 Set_TSS (Typ, Init); 273 end Set_Init_Proc; 274 275 ------------- 276 -- Set_TSS -- 277 ------------- 278 279 procedure Set_TSS (Typ : Entity_Id; TSS : Entity_Id) is 280 Subprog_Body : constant Node_Id := Unit_Declaration_Node (TSS); 281 282 begin 283 -- Case of insertion location is in unit defining the type 284 285 if In_Same_Code_Unit (Typ, TSS) then 286 Append_Freeze_Action (Typ, Subprog_Body); 287 288 -- Otherwise, we are using an already existing TSS in another unit 289 290 else 291 null; 292 end if; 293 294 Copy_TSS (TSS, Typ); 295 end Set_TSS; 296 297 --------- 298 -- TSS -- 299 --------- 300 301 function TSS (Typ : Entity_Id; Nam : TSS_Name_Type) return Entity_Id is 302 FN : constant Node_Id := Freeze_Node (Typ); 303 Elmt : Elmt_Id; 304 Subp : Entity_Id; 305 306 begin 307 if No (FN) then 308 return Empty; 309 310 elsif No (TSS_Elist (FN)) then 311 return Empty; 312 313 else 314 Elmt := First_Elmt (TSS_Elist (FN)); 315 while Present (Elmt) loop 316 if Is_TSS (Node (Elmt), Nam) then 317 Subp := Node (Elmt); 318 319 -- For stream subprograms, the TSS entity may be a renaming- 320 -- as-body of an already generated entity. Use that one rather 321 -- the one introduced by the renaming, which is an artifact of 322 -- current stream handling. 323 324 if Nkind (Parent (Parent (Subp))) = 325 N_Subprogram_Renaming_Declaration 326 and then 327 Present (Corresponding_Spec (Parent (Parent (Subp)))) 328 then 329 return Corresponding_Spec (Parent (Parent (Subp))); 330 else 331 return Subp; 332 end if; 333 334 else 335 Next_Elmt (Elmt); 336 end if; 337 end loop; 338 end if; 339 340 return Empty; 341 end TSS; 342 343 function TSS (Typ : Entity_Id; Nam : Name_Id) return Entity_Id is 344 FN : constant Node_Id := Freeze_Node (Typ); 345 Elmt : Elmt_Id; 346 Subp : Entity_Id; 347 348 begin 349 if No (FN) then 350 return Empty; 351 352 elsif No (TSS_Elist (FN)) then 353 return Empty; 354 355 else 356 Elmt := First_Elmt (TSS_Elist (FN)); 357 while Present (Elmt) loop 358 if Chars (Node (Elmt)) = Nam then 359 Subp := Node (Elmt); 360 361 -- For stream subprograms, the TSS entity may be a renaming- 362 -- as-body of an already generated entity. Use that one rather 363 -- the one introduced by the renaming, which is an artifact of 364 -- current stream handling. 365 366 if Nkind (Parent (Parent (Subp))) = 367 N_Subprogram_Renaming_Declaration 368 and then 369 Present (Corresponding_Spec (Parent (Parent (Subp)))) 370 then 371 return Corresponding_Spec (Parent (Parent (Subp))); 372 else 373 return Subp; 374 end if; 375 376 else 377 Next_Elmt (Elmt); 378 end if; 379 end loop; 380 end if; 381 382 return Empty; 383 end TSS; 384 385end Exp_Tss; 386