1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ P R A G -- 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 Casing; use Casing; 29with Einfo; use Einfo; 30with Errout; use Errout; 31with Exp_Ch11; use Exp_Ch11; 32with Exp_Tss; use Exp_Tss; 33with Exp_Util; use Exp_Util; 34with Expander; use Expander; 35with Namet; use Namet; 36with Nlists; use Nlists; 37with Nmake; use Nmake; 38with Opt; use Opt; 39with Rtsfind; use Rtsfind; 40with Sem; use Sem; 41with Sem_Eval; use Sem_Eval; 42with Sem_Res; use Sem_Res; 43with Sem_Util; use Sem_Util; 44with Sinfo; use Sinfo; 45with Sinput; use Sinput; 46with Snames; use Snames; 47with Stringt; use Stringt; 48with Stand; use Stand; 49with Targparm; use Targparm; 50with Tbuild; use Tbuild; 51with Uintp; use Uintp; 52 53package body Exp_Prag is 54 55 ----------------------- 56 -- Local Subprograms -- 57 ----------------------- 58 59 function Arg1 (N : Node_Id) return Node_Id; 60 function Arg2 (N : Node_Id) return Node_Id; 61 -- Obtain specified Pragma_Argument_Association 62 63 procedure Expand_Pragma_Abort_Defer (N : Node_Id); 64 procedure Expand_Pragma_Assert (N : Node_Id); 65 procedure Expand_Pragma_Import (N : Node_Id); 66 procedure Expand_Pragma_Import_Export_Exception (N : Node_Id); 67 procedure Expand_Pragma_Inspection_Point (N : Node_Id); 68 procedure Expand_Pragma_Interrupt_Priority (N : Node_Id); 69 70 ---------- 71 -- Arg1 -- 72 ---------- 73 74 function Arg1 (N : Node_Id) return Node_Id is 75 begin 76 return First (Pragma_Argument_Associations (N)); 77 end Arg1; 78 79 ---------- 80 -- Arg2 -- 81 ---------- 82 83 function Arg2 (N : Node_Id) return Node_Id is 84 begin 85 return Next (Arg1 (N)); 86 end Arg2; 87 88 --------------------- 89 -- Expand_N_Pragma -- 90 --------------------- 91 92 procedure Expand_N_Pragma (N : Node_Id) is 93 begin 94 -- Note: we may have a pragma whose chars field is not a 95 -- recognized pragma, and we must ignore it at this stage. 96 97 if Is_Pragma_Name (Chars (N)) then 98 case Get_Pragma_Id (Chars (N)) is 99 100 -- Pragmas requiring special expander action 101 102 when Pragma_Abort_Defer => 103 Expand_Pragma_Abort_Defer (N); 104 105 when Pragma_Assert => 106 Expand_Pragma_Assert (N); 107 108 when Pragma_Export_Exception => 109 Expand_Pragma_Import_Export_Exception (N); 110 111 when Pragma_Import => 112 Expand_Pragma_Import (N); 113 114 when Pragma_Import_Exception => 115 Expand_Pragma_Import_Export_Exception (N); 116 117 when Pragma_Inspection_Point => 118 Expand_Pragma_Inspection_Point (N); 119 120 when Pragma_Interrupt_Priority => 121 Expand_Pragma_Interrupt_Priority (N); 122 123 -- All other pragmas need no expander action 124 125 when others => null; 126 end case; 127 end if; 128 129 end Expand_N_Pragma; 130 131 ------------------------------- 132 -- Expand_Pragma_Abort_Defer -- 133 ------------------------------- 134 135 -- An Abort_Defer pragma appears as the first statement in a handled 136 -- statement sequence (right after the begin). It defers aborts for 137 -- the entire statement sequence, but not for any declarations or 138 -- handlers (if any) associated with this statement sequence. 139 140 -- The transformation is to transform 141 142 -- pragma Abort_Defer; 143 -- statements; 144 145 -- into 146 147 -- begin 148 -- Abort_Defer.all; 149 -- statements 150 -- exception 151 -- when all others => 152 -- Abort_Undefer.all; 153 -- raise; 154 -- at end 155 -- Abort_Undefer_Direct; 156 -- end; 157 158 procedure Expand_Pragma_Abort_Defer (N : Node_Id) is 159 Loc : constant Source_Ptr := Sloc (N); 160 Stm : Node_Id; 161 Stms : List_Id; 162 HSS : Node_Id; 163 Blk : constant Entity_Id := 164 New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B'); 165 166 begin 167 Stms := New_List (Build_Runtime_Call (Loc, RE_Abort_Defer)); 168 169 loop 170 Stm := Remove_Next (N); 171 exit when No (Stm); 172 Append (Stm, Stms); 173 end loop; 174 175 HSS := 176 Make_Handled_Sequence_Of_Statements (Loc, 177 Statements => Stms, 178 At_End_Proc => 179 New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc)); 180 181 Rewrite (N, 182 Make_Block_Statement (Loc, 183 Handled_Statement_Sequence => HSS)); 184 185 Set_Scope (Blk, Current_Scope); 186 Set_Etype (Blk, Standard_Void_Type); 187 Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N))); 188 Expand_At_End_Handler (HSS, Blk); 189 Analyze (N); 190 end Expand_Pragma_Abort_Defer; 191 192 -------------------------- 193 -- Expand_Pragma_Assert -- 194 -------------------------- 195 196 procedure Expand_Pragma_Assert (N : Node_Id) is 197 Loc : constant Source_Ptr := Sloc (N); 198 Cond : constant Node_Id := Expression (Arg1 (N)); 199 Msg : String_Id; 200 201 begin 202 -- We already know that assertions are enabled, because otherwise 203 -- the semantic pass dealt with rewriting the assertion (see Sem_Prag) 204 205 pragma Assert (Assertions_Enabled); 206 207 -- Since assertions are on, we rewrite the pragma with its 208 -- corresponding if statement, and then analyze the statement 209 -- The expansion transforms: 210 211 -- pragma Assert (condition [,message]); 212 213 -- into 214 215 -- if not condition then 216 -- System.Assertions.Raise_Assert_Failure (Str); 217 -- end if; 218 219 -- where Str is the message if one is present, or the default of 220 -- file:line if no message is given. 221 222 -- First, we need to prepare the character literal 223 224 if Present (Arg2 (N)) then 225 Msg := Strval (Expr_Value_S (Expression (Arg2 (N)))); 226 else 227 Build_Location_String (Loc); 228 Msg := String_From_Name_Buffer; 229 end if; 230 231 -- Now generate the if statement. Note that we consider this to be 232 -- an explicit conditional in the source, not an implicit if, so we 233 -- do not call Make_Implicit_If_Statement. 234 235 Rewrite (N, 236 Make_If_Statement (Loc, 237 Condition => 238 Make_Op_Not (Loc, 239 Right_Opnd => Cond), 240 Then_Statements => New_List ( 241 Make_Procedure_Call_Statement (Loc, 242 Name => 243 New_Reference_To (RTE (RE_Raise_Assert_Failure), Loc), 244 Parameter_Associations => New_List ( 245 Make_String_Literal (Loc, Msg)))))); 246 247 Analyze (N); 248 249 -- If new condition is always false, give a warning 250 251 if Nkind (N) = N_Procedure_Call_Statement 252 and then Is_RTE (Entity (Name (N)), RE_Raise_Assert_Failure) 253 then 254 -- If original condition was a Standard.False, we assume 255 -- that this is indeed intented to raise assert error 256 -- and no warning is required. 257 258 if Is_Entity_Name (Original_Node (Cond)) 259 and then Entity (Original_Node (Cond)) = Standard_False 260 then 261 return; 262 else 263 Error_Msg_N ("?assertion will fail at run-time", N); 264 end if; 265 end if; 266 end Expand_Pragma_Assert; 267 268 -------------------------- 269 -- Expand_Pragma_Import -- 270 -------------------------- 271 272 -- When applied to a variable, the default initialization must not be 273 -- done. As it is already done when the pragma is found, we just get rid 274 -- of the call the initialization procedure which followed the object 275 -- declaration. 276 277 -- We can't use the freezing mechanism for this purpose, since we 278 -- have to elaborate the initialization expression when it is first 279 -- seen (i.e. this elaboration cannot be deferred to the freeze point). 280 281 procedure Expand_Pragma_Import (N : Node_Id) is 282 Def_Id : constant Entity_Id := Entity (Expression (Arg2 (N))); 283 Typ : Entity_Id; 284 After_Def : Node_Id; 285 286 begin 287 if Ekind (Def_Id) = E_Variable then 288 Typ := Etype (Def_Id); 289 After_Def := Next (Parent (Def_Id)); 290 291 if Has_Non_Null_Base_Init_Proc (Typ) 292 and then Nkind (After_Def) = N_Procedure_Call_Statement 293 and then Is_Entity_Name (Name (After_Def)) 294 and then Entity (Name (After_Def)) = Base_Init_Proc (Typ) 295 then 296 Remove (After_Def); 297 298 -- Any default initialization expression should be removed 299 -- (e.g., null defaults for access objects, zero initialization 300 -- of packed bit arrays). Imported objects aren't allowed to 301 -- have explicit initialization, so the expression must have 302 -- been generated by the compiler. 303 304 elsif Present (Expression (Parent (Def_Id))) then 305 Set_Expression (Parent (Def_Id), Empty); 306 end if; 307 end if; 308 end Expand_Pragma_Import; 309 310 ------------------------------------------- 311 -- Expand_Pragma_Import_Export_Exception -- 312 ------------------------------------------- 313 314 -- For a VMS exception fix up the language field with "VMS" 315 -- instead of "Ada" (gigi needs this), create a constant that will be the 316 -- value of the VMS condition code and stuff the Interface_Name field 317 -- with the unexpanded name of the exception (if not already set). 318 -- For a Ada exception, just stuff the Interface_Name field 319 -- with the unexpanded name of the exception (if not already set). 320 321 procedure Expand_Pragma_Import_Export_Exception (N : Node_Id) is 322 begin 323 -- This pragma is only effective on OpenVMS systems, it was ignored 324 -- on non-VMS systems, and we need to ignore it here as well. 325 326 if not OpenVMS_On_Target then 327 return; 328 end if; 329 330 declare 331 Id : constant Entity_Id := Entity (Expression (Arg1 (N))); 332 Call : constant Node_Id := Register_Exception_Call (Id); 333 Loc : constant Source_Ptr := Sloc (N); 334 335 begin 336 if Present (Call) then 337 declare 338 Excep_Internal : constant Node_Id := 339 Make_Defining_Identifier 340 (Loc, New_Internal_Name ('V')); 341 Export_Pragma : Node_Id; 342 Excep_Alias : Node_Id; 343 Excep_Object : Node_Id; 344 Excep_Image : String_Id; 345 Exdata : List_Id; 346 Lang1 : Node_Id; 347 Lang2 : Node_Id; 348 Lang3 : Node_Id; 349 Code : Node_Id; 350 351 begin 352 if Present (Interface_Name (Id)) then 353 Excep_Image := Strval (Interface_Name (Id)); 354 else 355 Get_Name_String (Chars (Id)); 356 Set_All_Upper_Case; 357 Excep_Image := String_From_Name_Buffer; 358 end if; 359 360 Exdata := Component_Associations (Expression (Parent (Id))); 361 362 if Is_VMS_Exception (Id) then 363 Lang1 := Next (First (Exdata)); 364 Lang2 := Next (Lang1); 365 Lang3 := Next (Lang2); 366 367 Rewrite (Expression (Lang1), 368 Make_Character_Literal (Loc, 369 Chars => Name_uV, 370 Char_Literal_Value => Get_Char_Code ('V'))); 371 Analyze (Expression (Lang1)); 372 373 Rewrite (Expression (Lang2), 374 Make_Character_Literal (Loc, 375 Chars => Name_uM, 376 Char_Literal_Value => Get_Char_Code ('M'))); 377 Analyze (Expression (Lang2)); 378 379 Rewrite (Expression (Lang3), 380 Make_Character_Literal (Loc, 381 Chars => Name_uS, 382 Char_Literal_Value => Get_Char_Code ('S'))); 383 Analyze (Expression (Lang3)); 384 385 if Exception_Code (Id) /= No_Uint then 386 Code := 387 Make_Integer_Literal (Loc, 388 Intval => Exception_Code (Id)); 389 390 Excep_Object := 391 Make_Object_Declaration (Loc, 392 Defining_Identifier => Excep_Internal, 393 Object_Definition => 394 New_Reference_To (Standard_Integer, Loc)); 395 396 Insert_Action (N, Excep_Object); 397 Analyze (Excep_Object); 398 399 Start_String; 400 Store_String_Int 401 (UI_To_Int (Exception_Code (Id)) / 8 * 8); 402 403 Excep_Alias := 404 Make_Pragma 405 (Loc, 406 Name_Linker_Alias, 407 New_List 408 (Make_Pragma_Argument_Association 409 (Sloc => Loc, 410 Expression => 411 New_Reference_To (Excep_Internal, Loc)), 412 413 Make_Pragma_Argument_Association 414 (Sloc => Loc, 415 Expression => 416 Make_String_Literal 417 (Sloc => Loc, 418 Strval => End_String)))); 419 420 Insert_Action (N, Excep_Alias); 421 Analyze (Excep_Alias); 422 423 Export_Pragma := 424 Make_Pragma 425 (Loc, 426 Name_Export, 427 New_List 428 (Make_Pragma_Argument_Association 429 (Sloc => Loc, 430 Expression => Make_Identifier (Loc, Name_C)), 431 432 Make_Pragma_Argument_Association 433 (Sloc => Loc, 434 Expression => 435 New_Reference_To (Excep_Internal, Loc)), 436 437 Make_Pragma_Argument_Association 438 (Sloc => Loc, 439 Expression => 440 Make_String_Literal 441 (Sloc => Loc, 442 Strval => Excep_Image)), 443 444 Make_Pragma_Argument_Association 445 (Sloc => Loc, 446 Expression => 447 Make_String_Literal 448 (Sloc => Loc, 449 Strval => Excep_Image)))); 450 451 Insert_Action (N, Export_Pragma); 452 Analyze (Export_Pragma); 453 454 else 455 Code := 456 Unchecked_Convert_To (Standard_Integer, 457 Make_Function_Call (Loc, 458 Name => 459 New_Reference_To (RTE (RE_Import_Value), Loc), 460 Parameter_Associations => New_List 461 (Make_String_Literal (Loc, 462 Strval => Excep_Image)))); 463 end if; 464 465 Rewrite (Call, 466 Make_Procedure_Call_Statement (Loc, 467 Name => New_Reference_To 468 (RTE (RE_Register_VMS_Exception), Loc), 469 Parameter_Associations => New_List (Code))); 470 471 Analyze_And_Resolve (Code, Standard_Integer); 472 Analyze (Call); 473 end if; 474 475 if not Present (Interface_Name (Id)) then 476 Set_Interface_Name (Id, 477 Make_String_Literal 478 (Sloc => Loc, 479 Strval => Excep_Image)); 480 end if; 481 end; 482 end if; 483 end; 484 end Expand_Pragma_Import_Export_Exception; 485 486 ------------------------------------ 487 -- Expand_Pragma_Inspection_Point -- 488 ------------------------------------ 489 490 -- If no argument is given, then we supply a default argument list that 491 -- includes all objects declared at the source level in all subprograms 492 -- that enclose the inspection point pragma. 493 494 procedure Expand_Pragma_Inspection_Point (N : Node_Id) is 495 Loc : constant Source_Ptr := Sloc (N); 496 A : List_Id; 497 Assoc : Node_Id; 498 S : Entity_Id; 499 E : Entity_Id; 500 501 begin 502 if No (Pragma_Argument_Associations (N)) then 503 A := New_List; 504 S := Current_Scope; 505 506 while S /= Standard_Standard loop 507 E := First_Entity (S); 508 while Present (E) loop 509 if Comes_From_Source (E) 510 and then Is_Object (E) 511 and then not Is_Entry_Formal (E) 512 and then Ekind (E) /= E_Component 513 and then Ekind (E) /= E_Discriminant 514 and then Ekind (E) /= E_Generic_In_Parameter 515 and then Ekind (E) /= E_Generic_In_Out_Parameter 516 then 517 Append_To (A, 518 Make_Pragma_Argument_Association (Loc, 519 Expression => New_Occurrence_Of (E, Loc))); 520 end if; 521 522 Next_Entity (E); 523 end loop; 524 525 S := Scope (S); 526 end loop; 527 528 Set_Pragma_Argument_Associations (N, A); 529 end if; 530 531 -- Expand the arguments of the pragma. Expanding an entity reference 532 -- is a noop, except in a protected operation, where a reference may 533 -- have to be transformed into a reference to the corresponding prival. 534 -- Are there other pragmas that may require this ??? 535 536 Assoc := First (Pragma_Argument_Associations (N)); 537 538 while Present (Assoc) loop 539 Expand (Expression (Assoc)); 540 Next (Assoc); 541 end loop; 542 end Expand_Pragma_Inspection_Point; 543 544 -------------------------------------- 545 -- Expand_Pragma_Interrupt_Priority -- 546 -------------------------------------- 547 548 -- Supply default argument if none exists (System.Interrupt_Priority'Last) 549 550 procedure Expand_Pragma_Interrupt_Priority (N : Node_Id) is 551 Loc : constant Source_Ptr := Sloc (N); 552 553 begin 554 if No (Pragma_Argument_Associations (N)) then 555 Set_Pragma_Argument_Associations (N, New_List ( 556 Make_Pragma_Argument_Association (Loc, 557 Expression => 558 Make_Attribute_Reference (Loc, 559 Prefix => 560 New_Occurrence_Of (RTE (RE_Interrupt_Priority), Loc), 561 Attribute_Name => Name_Last)))); 562 end if; 563 end Expand_Pragma_Interrupt_Priority; 564 565end Exp_Prag; 566