1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ C H 1 3 -- 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 Checks; use Checks; 29with Einfo; use Einfo; 30with Exp_Ch3; use Exp_Ch3; 31with Exp_Ch6; use Exp_Ch6; 32with Exp_Imgv; use Exp_Imgv; 33with Exp_Tss; use Exp_Tss; 34with Exp_Util; use Exp_Util; 35with Nlists; use Nlists; 36with Nmake; use Nmake; 37with Rtsfind; use Rtsfind; 38with Sem; use Sem; 39with Sem_Ch7; use Sem_Ch7; 40with Sem_Ch8; use Sem_Ch8; 41with Sem_Eval; use Sem_Eval; 42with Sem_Util; use Sem_Util; 43with Sinfo; use Sinfo; 44with Snames; use Snames; 45with Stand; use Stand; 46with Stringt; use Stringt; 47with Tbuild; use Tbuild; 48with Uintp; use Uintp; 49 50package body Exp_Ch13 is 51 52 procedure Expand_External_Tag_Definition (N : Node_Id); 53 -- The code to assign and register an external tag must be elaborated 54 -- after the dispatch table has been created, so the expansion of the 55 -- attribute definition node is delayed until after the type is frozen. 56 57 ------------------------------------------ 58 -- Expand_N_Attribute_Definition_Clause -- 59 ------------------------------------------ 60 61 -- Expansion action depends on attribute involved 62 63 procedure Expand_N_Attribute_Definition_Clause (N : Node_Id) is 64 Loc : constant Source_Ptr := Sloc (N); 65 Exp : constant Node_Id := Expression (N); 66 Ent : Entity_Id; 67 V : Node_Id; 68 69 begin 70 Ent := Entity (Name (N)); 71 72 if Is_Type (Ent) then 73 Ent := Underlying_Type (Ent); 74 end if; 75 76 case Get_Attribute_Id (Chars (N)) is 77 78 ------------- 79 -- Address -- 80 ------------- 81 82 when Attribute_Address => 83 84 -- If there is an initialization which did not come from 85 -- the source program, then it is an artifact of our 86 -- expansion, and we suppress it. The case we are most 87 -- concerned about here is the initialization of a packed 88 -- array to all false, which seems inappropriate for a 89 -- variable to which an address clause is applied. The 90 -- expression may itself have been rewritten if the type is a 91 -- packed array, so we need to examine whether the original 92 -- node is in the source. 93 94 declare 95 Decl : constant Node_Id := Declaration_Node (Ent); 96 97 begin 98 if Nkind (Decl) = N_Object_Declaration 99 and then Present (Expression (Decl)) 100 and then 101 not Comes_From_Source (Original_Node (Expression (Decl))) 102 then 103 Set_Expression (Decl, Empty); 104 end if; 105 end; 106 107 --------------- 108 -- Alignment -- 109 --------------- 110 111 when Attribute_Alignment => 112 113 -- As required by Gigi, we guarantee that the operand is an 114 -- integer literal (this simplifies things in Gigi). 115 116 if Nkind (Exp) /= N_Integer_Literal then 117 Rewrite 118 (Exp, Make_Integer_Literal (Loc, Expr_Value (Exp))); 119 end if; 120 121 ------------------ 122 -- Storage_Size -- 123 ------------------ 124 125 when Attribute_Storage_Size => 126 127 -- If the type is a task type, then assign the value of the 128 -- storage size to the Size variable associated with the task. 129 -- task_typeZ := expression 130 131 if Ekind (Ent) = E_Task_Type then 132 Insert_Action (N, 133 Make_Assignment_Statement (Loc, 134 Name => New_Reference_To (Storage_Size_Variable (Ent), Loc), 135 Expression => 136 Convert_To (RTE (RE_Size_Type), Expression (N)))); 137 138 -- For Storage_Size for an access type, create a variable to hold 139 -- the value of the specified size with name typeV and expand an 140 -- assignment statement to initialze this value. 141 142 elsif Is_Access_Type (Ent) then 143 144 V := Make_Defining_Identifier (Loc, 145 New_External_Name (Chars (Ent), 'V')); 146 147 Insert_Action (N, 148 Make_Object_Declaration (Loc, 149 Defining_Identifier => V, 150 Object_Definition => 151 New_Reference_To (RTE (RE_Storage_Offset), Loc), 152 Expression => 153 Convert_To (RTE (RE_Storage_Offset), Expression (N)))); 154 155 Set_Storage_Size_Variable (Ent, Entity_Id (V)); 156 end if; 157 158 -- Other attributes require no expansion 159 160 when others => 161 null; 162 163 end case; 164 165 end Expand_N_Attribute_Definition_Clause; 166 167 ------------------------------------- 168 -- Expand_External_Tag_Definition -- 169 ------------------------------------- 170 171 procedure Expand_External_Tag_Definition (N : Node_Id) is 172 Loc : constant Source_Ptr := Sloc (N); 173 Ent : constant Entity_Id := Entity (Name (N)); 174 Old_Val : constant String_Id := Strval (Expr_Value_S (Expression (N))); 175 New_Val : String_Id; 176 E : Entity_Id; 177 178 begin 179 -- For the rep clause "for x'external_tag use y" generate: 180 181 -- xV : constant string := y; 182 -- Set_External_Tag (x'tag, xV'Address); 183 -- Register_Tag (x'tag); 184 185 -- note that register_tag has been delayed up to now because 186 -- the external_tag must be set before registering. 187 188 -- Create a new nul terminated string if it is not already 189 190 if String_Length (Old_Val) > 0 191 and then Get_String_Char (Old_Val, String_Length (Old_Val)) = 0 192 then 193 New_Val := Old_Val; 194 else 195 Start_String (Old_Val); 196 Store_String_Char (Get_Char_Code (ASCII.NUL)); 197 New_Val := End_String; 198 end if; 199 200 E := 201 Make_Defining_Identifier (Loc, 202 New_External_Name (Chars (Ent), 'A')); 203 204 -- The generated actions must be elaborated at the subsequent 205 -- freeze point, not at the point of the attribute definition. 206 207 Append_Freeze_Action (Ent, 208 Make_Object_Declaration (Loc, 209 Defining_Identifier => E, 210 Constant_Present => True, 211 Object_Definition => 212 New_Reference_To (Standard_String, Loc), 213 Expression => 214 Make_String_Literal (Loc, Strval => New_Val))); 215 216 Append_Freeze_Actions (Ent, New_List ( 217 Make_Procedure_Call_Statement (Loc, 218 Name => New_Reference_To (RTE (RE_Set_External_Tag), Loc), 219 Parameter_Associations => New_List ( 220 Make_Attribute_Reference (Loc, 221 Attribute_Name => Name_Tag, 222 Prefix => New_Occurrence_Of (Ent, Loc)), 223 224 Make_Attribute_Reference (Loc, 225 Attribute_Name => Name_Address, 226 Prefix => New_Occurrence_Of (E, Loc)))), 227 228 Make_Procedure_Call_Statement (Loc, 229 Name => New_Reference_To (RTE (RE_Register_Tag), Loc), 230 Parameter_Associations => New_List ( 231 Make_Attribute_Reference (Loc, 232 Attribute_Name => Name_Tag, 233 Prefix => New_Occurrence_Of (Ent, Loc)))))); 234 end Expand_External_Tag_Definition; 235 236 ---------------------------- 237 -- Expand_N_Freeze_Entity -- 238 ---------------------------- 239 240 procedure Expand_N_Freeze_Entity (N : Node_Id) is 241 E : constant Entity_Id := Entity (N); 242 E_Scope : Entity_Id; 243 S : Entity_Id; 244 In_Other_Scope : Boolean; 245 In_Outer_Scope : Boolean; 246 Decl : Node_Id; 247 248 begin 249 -- For object, with address clause, check alignment is OK 250 251 if Is_Object (E) then 252 Apply_Alignment_Check (E, N); 253 254 -- Only other items requiring any front end action are 255 -- types and subprograms. 256 257 elsif not Is_Type (E) and then not Is_Subprogram (E) then 258 return; 259 end if; 260 261 -- Here E is a type or a subprogram 262 263 E_Scope := Scope (E); 264 265 -- This is an error protection against previous errors 266 267 if No (E_Scope) then 268 return; 269 end if; 270 271 -- If we are freezing entities defined in protected types, they 272 -- belong in the enclosing scope, given that the original type 273 -- has been expanded away. The same is true for entities in task types, 274 -- in particular the parameter records of entries (Entities in bodies 275 -- are all frozen within the body). If we are in the task body, this 276 -- is a proper scope. 277 278 if Ekind (E_Scope) = E_Protected_Type 279 or else (Ekind (E_Scope) = E_Task_Type 280 and then not Has_Completion (E_Scope)) 281 then 282 E_Scope := Scope (E_Scope); 283 end if; 284 285 S := Current_Scope; 286 while S /= Standard_Standard and then S /= E_Scope loop 287 S := Scope (S); 288 end loop; 289 290 In_Other_Scope := not (S = E_Scope); 291 In_Outer_Scope := (not In_Other_Scope) and then (S /= Current_Scope); 292 293 -- If the entity being frozen is defined in a scope that is not 294 -- currently on the scope stack, we must establish the proper 295 -- visibility before freezing the entity and related subprograms. 296 297 if In_Other_Scope then 298 New_Scope (E_Scope); 299 Install_Visible_Declarations (E_Scope); 300 301 if Ekind (E_Scope) = E_Package or else 302 Ekind (E_Scope) = E_Generic_Package or else 303 Is_Protected_Type (E_Scope) or else 304 Is_Task_Type (E_Scope) 305 then 306 Install_Private_Declarations (E_Scope); 307 end if; 308 309 -- If the entity is in an outer scope, then that scope needs to 310 -- temporarily become the current scope so that operations created 311 -- during type freezing will be declared in the right scope and 312 -- can properly override any corresponding inherited operations. 313 314 elsif In_Outer_Scope then 315 New_Scope (E_Scope); 316 end if; 317 318 -- If type, freeze the type 319 320 if Is_Type (E) then 321 Freeze_Type (N); 322 323 -- And for enumeration type, build the enumeration tables 324 325 if Is_Enumeration_Type (E) then 326 Build_Enumeration_Image_Tables (E, N); 327 328 elsif Is_Tagged_Type (E) 329 and then Is_First_Subtype (E) 330 then 331 -- Check for a definition of External_Tag, whose expansion must 332 -- be delayed until the dispatch table is built. The clause 333 -- is considered only if it applies to this specific tagged 334 -- type, as opposed to one of its ancestors. 335 336 declare 337 Def : constant Node_Id := 338 Get_Attribute_Definition_Clause 339 (E, Attribute_External_Tag); 340 341 begin 342 if Present (Def) and then Entity (Name (Def)) = E then 343 Expand_External_Tag_Definition (Def); 344 end if; 345 end; 346 end if; 347 348 -- If subprogram, freeze the subprogram 349 350 elsif Is_Subprogram (E) then 351 Freeze_Subprogram (N); 352 end if; 353 354 -- Analyze actions generated by freezing. The init_proc contains 355 -- source expressions that may raise constraint_error, and the 356 -- assignment procedure for complex types needs checks on individual 357 -- component assignments, but all other freezing actions should be 358 -- compiled with all checks off. 359 360 if Present (Actions (N)) then 361 Decl := First (Actions (N)); 362 363 while Present (Decl) loop 364 365 if Nkind (Decl) = N_Subprogram_Body 366 and then (Is_Init_Proc (Defining_Entity (Decl)) 367 or else 368 Chars (Defining_Entity (Decl)) = Name_uAssign) 369 then 370 Analyze (Decl); 371 372 -- A subprogram body created for a renaming_as_body completes 373 -- a previous declaration, which may be in a different scope. 374 -- Establish the proper scope before analysis. 375 376 elsif Nkind (Decl) = N_Subprogram_Body 377 and then Present (Corresponding_Spec (Decl)) 378 and then Scope (Corresponding_Spec (Decl)) /= Current_Scope 379 then 380 New_Scope (Scope (Corresponding_Spec (Decl))); 381 Analyze (Decl, Suppress => All_Checks); 382 Pop_Scope; 383 384 else 385 Analyze (Decl, Suppress => All_Checks); 386 end if; 387 388 Next (Decl); 389 end loop; 390 end if; 391 392 if In_Other_Scope then 393 if Ekind (Current_Scope) = E_Package then 394 End_Package_Scope (E_Scope); 395 else 396 End_Scope; 397 end if; 398 399 elsif In_Outer_Scope then 400 Pop_Scope; 401 end if; 402 end Expand_N_Freeze_Entity; 403 404 ------------------------------------------- 405 -- Expand_N_Record_Representation_Clause -- 406 ------------------------------------------- 407 408 -- The only expansion required is for the case of a mod clause present, 409 -- which is removed, and translated into an alignment representation 410 -- clause inserted immediately after the record rep clause with any 411 -- initial pragmas inserted at the start of the component clause list. 412 413 procedure Expand_N_Record_Representation_Clause (N : Node_Id) is 414 Loc : constant Source_Ptr := Sloc (N); 415 Rectype : constant Entity_Id := Entity (Identifier (N)); 416 Mod_Val : Uint; 417 Citems : List_Id; 418 Repitem : Node_Id; 419 AtM_Nod : Node_Id; 420 421 begin 422 if Present (Mod_Clause (N)) then 423 Mod_Val := Expr_Value (Expression (Mod_Clause (N))); 424 Citems := Pragmas_Before (Mod_Clause (N)); 425 426 if Present (Citems) then 427 Append_List_To (Citems, Component_Clauses (N)); 428 Set_Component_Clauses (N, Citems); 429 end if; 430 431 AtM_Nod := 432 Make_Attribute_Definition_Clause (Loc, 433 Name => New_Reference_To (Base_Type (Rectype), Loc), 434 Chars => Name_Alignment, 435 Expression => Make_Integer_Literal (Loc, Mod_Val)); 436 437 Set_From_At_Mod (AtM_Nod); 438 Insert_After (N, AtM_Nod); 439 Set_Mod_Clause (N, Empty); 440 end if; 441 442 -- If the record representation clause has no components, then 443 -- completely remove it. Note that we also have to remove 444 -- ourself from the Rep Item list. 445 446 if Is_Empty_List (Component_Clauses (N)) then 447 if First_Rep_Item (Rectype) = N then 448 Set_First_Rep_Item (Rectype, Next_Rep_Item (N)); 449 else 450 Repitem := First_Rep_Item (Rectype); 451 while Present (Next_Rep_Item (Repitem)) loop 452 if Next_Rep_Item (Repitem) = N then 453 Set_Next_Rep_Item (Repitem, Next_Rep_Item (N)); 454 exit; 455 end if; 456 457 Next_Rep_Item (Repitem); 458 end loop; 459 end if; 460 461 Rewrite (N, 462 Make_Null_Statement (Loc)); 463 end if; 464 end Expand_N_Record_Representation_Clause; 465 466end Exp_Ch13; 467