1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ P R A G -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2004, 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 27-- This unit contains the semantic processing for all pragmas, both language 28-- and implementation defined. For most pragmas, the parser only does the 29-- most basic job of checking the syntax, so Sem_Prag also contains the code 30-- to complete the syntax checks. Certain pragmas are handled partially or 31-- completely by the parser (see Par.Prag for further details). 32 33with Atree; use Atree; 34with Casing; use Casing; 35with Csets; use Csets; 36with Debug; use Debug; 37with Einfo; use Einfo; 38with Elists; use Elists; 39with Errout; use Errout; 40with Expander; use Expander; 41with Exp_Dist; use Exp_Dist; 42with Fname; use Fname; 43with Hostparm; use Hostparm; 44with Lib; use Lib; 45with Lib.Writ; use Lib.Writ; 46with Lib.Xref; use Lib.Xref; 47with Namet; use Namet; 48with Nlists; use Nlists; 49with Nmake; use Nmake; 50with Opt; use Opt; 51with Output; use Output; 52with Restrict; use Restrict; 53with Rtsfind; use Rtsfind; 54with Sem; use Sem; 55with Sem_Ch3; use Sem_Ch3; 56with Sem_Ch8; use Sem_Ch8; 57with Sem_Ch13; use Sem_Ch13; 58with Sem_Disp; use Sem_Disp; 59with Sem_Elim; use Sem_Elim; 60with Sem_Eval; use Sem_Eval; 61with Sem_Intr; use Sem_Intr; 62with Sem_Mech; use Sem_Mech; 63with Sem_Res; use Sem_Res; 64with Sem_Type; use Sem_Type; 65with Sem_Util; use Sem_Util; 66with Sem_VFpt; use Sem_VFpt; 67with Stand; use Stand; 68with Sinfo; use Sinfo; 69with Sinfo.CN; use Sinfo.CN; 70with Sinput; use Sinput; 71with Snames; use Snames; 72with Stringt; use Stringt; 73with Stylesw; use Stylesw; 74with Targparm; use Targparm; 75with Tbuild; use Tbuild; 76with Ttypes; 77with Uintp; use Uintp; 78with Urealp; use Urealp; 79with Validsw; use Validsw; 80 81with GNAT.Spelling_Checker; use GNAT.Spelling_Checker; 82 83package body Sem_Prag is 84 85 ---------------------------------------------- 86 -- Common Handling of Import-Export Pragmas -- 87 ---------------------------------------------- 88 89 -- In the following section, a number of Import_xxx and Export_xxx 90 -- pragmas are defined by GNAT. These are compatible with the DEC 91 -- pragmas of the same name, and all have the following common 92 -- form and processing: 93 94 -- pragma Export_xxx 95 -- [Internal =>] LOCAL_NAME, 96 -- [, [External =>] EXTERNAL_SYMBOL] 97 -- [, other optional parameters ]); 98 99 -- pragma Import_xxx 100 -- [Internal =>] LOCAL_NAME, 101 -- [, [External =>] EXTERNAL_SYMBOL] 102 -- [, other optional parameters ]); 103 104 -- EXTERNAL_SYMBOL ::= 105 -- IDENTIFIER 106 -- | static_string_EXPRESSION 107 108 -- The internal LOCAL_NAME designates the entity that is imported or 109 -- exported, and must refer to an entity in the current declarative 110 -- part (as required by the rules for LOCAL_NAME). 111 112 -- The external linker name is designated by the External parameter 113 -- if given, or the Internal parameter if not (if there is no External 114 -- parameter, the External parameter is a copy of the Internal name). 115 116 -- If the External parameter is given as a string, then this string 117 -- is treated as an external name (exactly as though it had been given 118 -- as an External_Name parameter for a normal Import pragma). 119 120 -- If the External parameter is given as an identifier (or there is no 121 -- External parameter, so that the Internal identifier is used), then 122 -- the external name is the characters of the identifier, translated 123 -- to all upper case letters for OpenVMS versions of GNAT, and to all 124 -- lower case letters for all other versions 125 126 -- Note: the external name specified or implied by any of these special 127 -- Import_xxx or Export_xxx pragmas override an external or link name 128 -- specified in a previous Import or Export pragma. 129 130 -- Note: these and all other DEC-compatible GNAT pragmas allow full 131 -- use of named notation, following the standard rules for subprogram 132 -- calls, i.e. parameters can be given in any order if named notation 133 -- is used, and positional and named notation can be mixed, subject to 134 -- the rule that all positional parameters must appear first. 135 136 -- Note: All these pragmas are implemented exactly following the DEC 137 -- design and implementation and are intended to be fully compatible 138 -- with the use of these pragmas in the DEC Ada compiler. 139 140 ------------------------------------- 141 -- Local Subprograms and Variables -- 142 ------------------------------------- 143 144 function Adjust_External_Name_Case (N : Node_Id) return Node_Id; 145 -- This routine is used for possible casing adjustment of an explicit 146 -- external name supplied as a string literal (the node N), according 147 -- to the casing requirement of Opt.External_Name_Casing. If this is 148 -- set to As_Is, then the string literal is returned unchanged, but if 149 -- it is set to Uppercase or Lowercase, then a new string literal with 150 -- appropriate casing is constructed. 151 152 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id; 153 -- If Def_Id refers to a renamed subprogram, then the base subprogram 154 -- (the original one, following the renaming chain) is returned. 155 -- Otherwise the entity is returned unchanged. Should be in Einfo??? 156 157 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id); 158 -- Place semantic information on the argument of an Elaborate or 159 -- Elaborate_All pragma. Entity name for unit and its parents is 160 -- taken from item in previous with_clause that mentions the unit. 161 162 ------------------------------- 163 -- Adjust_External_Name_Case -- 164 ------------------------------- 165 166 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is 167 CC : Char_Code; 168 169 begin 170 -- Adjust case of literal if required 171 172 if Opt.External_Name_Exp_Casing = As_Is then 173 return N; 174 175 else 176 -- Copy existing string 177 178 Start_String; 179 180 -- Set proper casing 181 182 for J in 1 .. String_Length (Strval (N)) loop 183 CC := Get_String_Char (Strval (N), J); 184 185 if Opt.External_Name_Exp_Casing = Uppercase 186 and then CC >= Get_Char_Code ('a') 187 and then CC <= Get_Char_Code ('z') 188 then 189 Store_String_Char (CC - 32); 190 191 elsif Opt.External_Name_Exp_Casing = Lowercase 192 and then CC >= Get_Char_Code ('A') 193 and then CC <= Get_Char_Code ('Z') 194 then 195 Store_String_Char (CC + 32); 196 197 else 198 Store_String_Char (CC); 199 end if; 200 end loop; 201 202 return 203 Make_String_Literal (Sloc (N), 204 Strval => End_String); 205 end if; 206 end Adjust_External_Name_Case; 207 208 -------------------- 209 -- Analyze_Pragma -- 210 -------------------- 211 212 procedure Analyze_Pragma (N : Node_Id) is 213 Loc : constant Source_Ptr := Sloc (N); 214 Prag_Id : Pragma_Id; 215 216 Pragma_Exit : exception; 217 -- This exception is used to exit pragma processing completely. It 218 -- is used when an error is detected, and in other situations where 219 -- it is known that no further processing is required. 220 221 Arg_Count : Nat; 222 -- Number of pragma argument associations 223 224 Arg1 : Node_Id; 225 Arg2 : Node_Id; 226 Arg3 : Node_Id; 227 Arg4 : Node_Id; 228 -- First four pragma arguments (pragma argument association nodes, 229 -- or Empty if the corresponding argument does not exist). 230 231 procedure Check_Ada_83_Warning; 232 -- Issues a warning message for the current pragma if operating in Ada 233 -- 83 mode (used for language pragmas that are not a standard part of 234 -- Ada 83). This procedure does not raise Error_Pragma. Also notes use 235 -- of 95 pragma. 236 237 procedure Check_Arg_Count (Required : Nat); 238 -- Check argument count for pragma is equal to given parameter. 239 -- If not, then issue an error message and raise Pragma_Exit. 240 241 -- Note: all routines whose name is Check_Arg_Is_xxx take an 242 -- argument Arg which can either be a pragma argument association, 243 -- in which case the check is applied to the expression of the 244 -- association or an expression directly. 245 246 procedure Check_Arg_Is_Identifier (Arg : Node_Id); 247 -- Check the specified argument Arg to make sure that it is an 248 -- identifier. If not give error and raise Pragma_Exit. 249 250 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id); 251 -- Check the specified argument Arg to make sure that it is an 252 -- integer literal. If not give error and raise Pragma_Exit. 253 254 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id); 255 -- Check the specified argument Arg to make sure that it has the 256 -- proper syntactic form for a local name and meets the semantic 257 -- requirements for a local name. The local name is analyzed as 258 -- part of the processing for this call. In addition, the local 259 -- name is required to represent an entity at the library level. 260 261 procedure Check_Arg_Is_Local_Name (Arg : Node_Id); 262 -- Check the specified argument Arg to make sure that it has the 263 -- proper syntactic form for a local name and meets the semantic 264 -- requirements for a local name. The local name is analyzed as 265 -- part of the processing for this call. 266 267 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id); 268 -- Check the specified argument Arg to make sure that it is a valid 269 -- locking policy name. If not give error and raise Pragma_Exit. 270 271 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id); 272 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2, N3 : Name_Id); 273 -- Check the specified argument Arg to make sure that it is an 274 -- identifier whose name matches either N1 or N2 (or N3 if present). 275 -- If not then give error and raise Pragma_Exit. 276 277 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id); 278 -- Check the specified argument Arg to make sure that it is a valid 279 -- queuing policy name. If not give error and raise Pragma_Exit. 280 281 procedure Check_Arg_Is_Static_Expression 282 (Arg : Node_Id; 283 Typ : Entity_Id); 284 -- Check the specified argument Arg to make sure that it is a static 285 -- expression of the given type (i.e. it will be analyzed and resolved 286 -- using this type, which can be any valid argument to Resolve, e.g. 287 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. 288 289 procedure Check_Arg_Is_String_Literal (Arg : Node_Id); 290 -- Check the specified argument Arg to make sure that it is a 291 -- string literal. If not give error and raise Pragma_Exit 292 293 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id); 294 -- Check the specified argument Arg to make sure that it is a valid 295 -- valid task dispatching policy name. If not give error and raise 296 -- Pragma_Exit. 297 298 procedure Check_At_Least_N_Arguments (N : Nat); 299 -- Check there are at least N arguments present 300 301 procedure Check_At_Most_N_Arguments (N : Nat); 302 -- Check there are no more than N arguments present 303 304 procedure Check_First_Subtype (Arg : Node_Id); 305 -- Checks that Arg, whose expression is an entity name referencing 306 -- a subtype, does not reference a type that is not a first subtype. 307 308 procedure Check_In_Main_Program; 309 -- Common checks for pragmas that appear within a main program 310 -- (Priority, Main_Storage, Time_Slice). 311 312 procedure Check_Interrupt_Or_Attach_Handler; 313 -- Common processing for first argument of pragma Interrupt_Handler 314 -- or pragma Attach_Handler. 315 316 procedure Check_Is_In_Decl_Part_Or_Package_Spec; 317 -- Check that pragma appears in a declarative part, or in a package 318 -- specification, i.e. that it does not occur in a statement sequence 319 -- in a body. 320 321 procedure Check_No_Identifier (Arg : Node_Id); 322 -- Checks that the given argument does not have an identifier. If 323 -- an identifier is present, then an error message is issued, and 324 -- Pragma_Exit is raised. 325 326 procedure Check_No_Identifiers; 327 -- Checks that none of the arguments to the pragma has an identifier. 328 -- If any argument has an identifier, then an error message is issued, 329 -- and Pragma_Exit is raised. 330 331 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id); 332 -- Checks if the given argument has an identifier, and if so, requires 333 -- it to match the given identifier name. If there is a non-matching 334 -- identifier, then an error message is given and Error_Pragmas raised. 335 336 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String); 337 -- Checks if the given argument has an identifier, and if so, requires 338 -- it to match the given identifier name. If there is a non-matching 339 -- identifier, then an error message is given and Error_Pragmas raised. 340 -- In this version of the procedure, the identifier name is given as 341 -- a string with lower case letters. 342 343 procedure Check_Static_Constraint (Constr : Node_Id); 344 -- Constr is a constraint from an N_Subtype_Indication node from a 345 -- component constraint in an Unchecked_Union type. This routine checks 346 -- that the constraint is static as required by the restrictions for 347 -- Unchecked_Union. 348 349 procedure Check_Valid_Configuration_Pragma; 350 -- Legality checks for placement of a configuration pragma 351 352 procedure Check_Valid_Library_Unit_Pragma; 353 -- Legality checks for library unit pragmas. A special case arises for 354 -- pragmas in generic instances that come from copies of the original 355 -- library unit pragmas in the generic templates. In the case of other 356 -- than library level instantiations these can appear in contexts which 357 -- would normally be invalid (they only apply to the original template 358 -- and to library level instantiations), and they are simply ignored, 359 -- which is implemented by rewriting them as null statements. 360 361 procedure Error_Pragma (Msg : String); 362 pragma No_Return (Error_Pragma); 363 -- Outputs error message for current pragma. The message contains an % 364 -- that will be replaced with the pragma name, and the flag is placed 365 -- on the pragma itself. Pragma_Exit is then raised. 366 367 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id); 368 pragma No_Return (Error_Pragma_Arg); 369 -- Outputs error message for current pragma. The message may contain 370 -- a % that will be replaced with the pragma name. The parameter Arg 371 -- may either be a pragma argument association, in which case the flag 372 -- is placed on the expression of this association, or an expression, 373 -- in which case the flag is placed directly on the expression. The 374 -- message is placed using Error_Msg_N, so the message may also contain 375 -- an & insertion character which will reference the given Arg value. 376 -- After placing the message, Pragma_Exit is raised. 377 378 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id); 379 pragma No_Return (Error_Pragma_Arg); 380 -- Similar to above form of Error_Pragma_Arg except that two messages 381 -- are provided, the second is a continuation comment starting with \. 382 383 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id); 384 pragma No_Return (Error_Pragma_Arg_Ident); 385 -- Outputs error message for current pragma. The message may contain 386 -- a % that will be replaced with the pragma name. The parameter Arg 387 -- must be a pragma argument association with a non-empty identifier 388 -- (i.e. its Chars field must be set), and the error message is placed 389 -- on the identifier. The message is placed using Error_Msg_N so 390 -- the message may also contain an & insertion character which will 391 -- reference the identifier. After placing the message, Pragma_Exit 392 -- is raised. 393 394 function Find_Lib_Unit_Name return Entity_Id; 395 -- Used for a library unit pragma to find the entity to which the 396 -- library unit pragma applies, returns the entity found. 397 398 procedure Find_Program_Unit_Name (Id : Node_Id); 399 -- If the pragma is a compilation unit pragma, the id must denote the 400 -- compilation unit in the same compilation, and the pragma must appear 401 -- in the list of preceding or trailing pragmas. If it is a program 402 -- unit pragma that is not a compilation unit pragma, then the 403 -- identifier must be visible. 404 405 type Name_List is array (Natural range <>) of Name_Id; 406 type Args_List is array (Natural range <>) of Node_Id; 407 procedure Gather_Associations 408 (Names : Name_List; 409 Args : out Args_List); 410 -- This procedure is used to gather the arguments for a pragma that 411 -- permits arbitrary ordering of parameters using the normal rules 412 -- for named and positional parameters. The Names argument is a list 413 -- of Name_Id values that corresponds to the allowed pragma argument 414 -- association identifiers in order. The result returned in Args is 415 -- a list of corresponding expressions that are the pragma arguments. 416 -- Note that this is a list of expressions, not of pragma argument 417 -- associations (Gather_Associations has completely checked all the 418 -- optional identifiers when it returns). An entry in Args is Empty 419 -- on return if the corresponding argument is not present. 420 421 function Get_Pragma_Arg (Arg : Node_Id) return Node_Id; 422 -- All the routines that check pragma arguments take either a pragma 423 -- argument association (in which case the expression of the argument 424 -- association is checked), or the expression directly. The function 425 -- Get_Pragma_Arg is a utility used to deal with these two cases. If 426 -- Arg is a pragma argument association node, then its expression is 427 -- returned, otherwise Arg is returned unchanged. 428 429 procedure GNAT_Pragma; 430 -- Called for all GNAT defined pragmas to note the use of the feature, 431 -- and also check the relevant restriction (No_Implementation_Pragmas). 432 433 function Is_Before_First_Decl 434 (Pragma_Node : Node_Id; 435 Decls : List_Id) return Boolean; 436 -- Return True if Pragma_Node is before the first declarative item in 437 -- Decls where Decls is the list of declarative items. 438 439 function Is_Configuration_Pragma return Boolean; 440 -- Deterermines if the placement of the current pragma is appropriate 441 -- for a configuration pragma (precedes the current compilation unit) 442 443 procedure Pragma_Misplaced; 444 -- Issue fatal error message for misplaced pragma 445 446 procedure Process_Atomic_Shared_Volatile; 447 -- Common processing for pragmas Atomic, Shared, Volatile. Note that 448 -- Shared is an obsolete Ada 83 pragma, treated as being identical 449 -- in effect to pragma Atomic. 450 451 procedure Process_Convention (C : out Convention_Id; E : out Entity_Id); 452 -- Common procesing for Convention, Interface, Import and Export. 453 -- Checks first two arguments of pragma, and sets the appropriate 454 -- convention value in the specified entity or entities. On return 455 -- C is the convention, E is the referenced entity. 456 457 procedure Process_Extended_Import_Export_Exception_Pragma 458 (Arg_Internal : Node_Id; 459 Arg_External : Node_Id; 460 Arg_Form : Node_Id; 461 Arg_Code : Node_Id); 462 -- Common processing for the pragmas Import/Export_Exception. 463 -- The three arguments correspond to the three named parameters of 464 -- the pragma. An argument is empty if the corresponding parameter 465 -- is not present in the pragma. 466 467 procedure Process_Extended_Import_Export_Object_Pragma 468 (Arg_Internal : Node_Id; 469 Arg_External : Node_Id; 470 Arg_Size : Node_Id); 471 -- Common processing for the pragmass Import/Export_Object. 472 -- The three arguments correspond to the three named parameters 473 -- of the pragmas. An argument is empty if the corresponding 474 -- parameter is not present in the pragma. 475 476 procedure Process_Extended_Import_Export_Internal_Arg 477 (Arg_Internal : Node_Id := Empty); 478 -- Common processing for all extended Import and Export pragmas. The 479 -- argument is the pragma parameter for the Internal argument. If 480 -- Arg_Internal is empty or inappropriate, an error message is posted. 481 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is 482 -- set to identify the referenced entity. 483 484 procedure Process_Extended_Import_Export_Subprogram_Pragma 485 (Arg_Internal : Node_Id; 486 Arg_External : Node_Id; 487 Arg_Parameter_Types : Node_Id; 488 Arg_Result_Type : Node_Id := Empty; 489 Arg_Mechanism : Node_Id; 490 Arg_Result_Mechanism : Node_Id := Empty; 491 Arg_First_Optional_Parameter : Node_Id := Empty); 492 -- Common processing for all extended Import and Export pragmas 493 -- applying to subprograms. The caller omits any arguments that do 494 -- bnot apply to the pragma in question (for example, Arg_Result_Type 495 -- can be non-Empty only in the Import_Function and Export_Function 496 -- cases). The argument names correspond to the allowed pragma 497 -- association identifiers. 498 499 procedure Process_Generic_List; 500 -- Common processing for Share_Generic and Inline_Generic 501 502 procedure Process_Import_Or_Interface; 503 -- Common processing for Import of Interface 504 505 procedure Process_Inline (Active : Boolean); 506 -- Common processing for Inline and Inline_Always. The parameter 507 -- indicates if the inline pragma is active, i.e. if it should 508 -- actually cause inlining to occur. 509 510 procedure Process_Interface_Name 511 (Subprogram_Def : Entity_Id; 512 Ext_Arg : Node_Id; 513 Link_Arg : Node_Id); 514 -- Given the last two arguments of pragma Import, pragma Export, or 515 -- pragma Interface_Name, performs validity checks and sets the 516 -- Interface_Name field of the given subprogram entity to the 517 -- appropriate external or link name, depending on the arguments 518 -- given. Ext_Arg is always present, but Link_Arg may be missing. 519 -- Note that Ext_Arg may represent the Link_Name if Link_Arg is 520 -- missing, and appropriate named notation is used for Ext_Arg. 521 -- If neither Ext_Arg nor Link_Arg is present, the interface name 522 -- is set to the default from the subprogram name. 523 524 procedure Process_Interrupt_Or_Attach_Handler; 525 -- Attach the pragmas to the rep item chain. 526 527 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean); 528 -- Common processing for Suppress and Unsuppress. The boolean parameter 529 -- Suppress_Case is True for the Suppress case, and False for the 530 -- Unsuppress case. 531 532 procedure Set_Exported (E : Entity_Id; Arg : Node_Id); 533 -- This procedure sets the Is_Exported flag for the given entity, 534 -- checking that the entity was not previously imported. Arg is 535 -- the argument that specified the entity. A check is also made 536 -- for exporting inappropriate entities. 537 538 procedure Set_Extended_Import_Export_External_Name 539 (Internal_Ent : Entity_Id; 540 Arg_External : Node_Id); 541 -- Common processing for all extended import export pragmas. The first 542 -- argument, Internal_Ent, is the internal entity, which has already 543 -- been checked for validity by the caller. Arg_External is from the 544 -- Import or Export pragma, and may be null if no External parameter 545 -- was present. If Arg_External is present and is a non-null string 546 -- (a null string is treated as the default), then the Interface_Name 547 -- field of Internal_Ent is set appropriately. 548 549 procedure Set_Imported (E : Entity_Id); 550 -- This procedure sets the Is_Imported flag for the given entity, 551 -- checking that it is not previously exported or imported. 552 553 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id); 554 -- Mech is a parameter passing mechanism (see Import_Function syntax 555 -- for MECHANISM_NAME). This routine checks that the mechanism argument 556 -- has the right form, and if not issues an error message. If the 557 -- argument has the right form then the Mechanism field of Ent is 558 -- set appropriately. 559 560 -------------------------- 561 -- Check_Ada_83_Warning -- 562 -------------------------- 563 564 procedure Check_Ada_83_Warning is 565 begin 566 if Ada_83 and then Comes_From_Source (N) then 567 Error_Msg_N ("(Ada 83) pragma& is non-standard?", N); 568 end if; 569 end Check_Ada_83_Warning; 570 571 --------------------- 572 -- Check_Arg_Count -- 573 --------------------- 574 575 procedure Check_Arg_Count (Required : Nat) is 576 begin 577 if Arg_Count /= Required then 578 Error_Pragma ("wrong number of arguments for pragma%"); 579 end if; 580 end Check_Arg_Count; 581 582 ----------------------------- 583 -- Check_Arg_Is_Identifier -- 584 ----------------------------- 585 586 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is 587 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 588 589 begin 590 if Nkind (Argx) /= N_Identifier then 591 Error_Pragma_Arg 592 ("argument for pragma% must be identifier", Argx); 593 end if; 594 end Check_Arg_Is_Identifier; 595 596 ---------------------------------- 597 -- Check_Arg_Is_Integer_Literal -- 598 ---------------------------------- 599 600 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is 601 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 602 603 begin 604 if Nkind (Argx) /= N_Integer_Literal then 605 Error_Pragma_Arg 606 ("argument for pragma% must be integer literal", Argx); 607 end if; 608 end Check_Arg_Is_Integer_Literal; 609 610 ------------------------------------------- 611 -- Check_Arg_Is_Library_Level_Local_Name -- 612 ------------------------------------------- 613 614 -- LOCAL_NAME ::= 615 -- DIRECT_NAME 616 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR 617 -- | library_unit_NAME 618 619 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is 620 begin 621 Check_Arg_Is_Local_Name (Arg); 622 623 if not Is_Library_Level_Entity (Entity (Expression (Arg))) 624 and then Comes_From_Source (N) 625 then 626 Error_Pragma_Arg 627 ("argument for pragma% must be library level entity", Arg); 628 end if; 629 end Check_Arg_Is_Library_Level_Local_Name; 630 631 ----------------------------- 632 -- Check_Arg_Is_Local_Name -- 633 ----------------------------- 634 635 -- LOCAL_NAME ::= 636 -- DIRECT_NAME 637 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR 638 -- | library_unit_NAME 639 640 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is 641 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 642 643 begin 644 Analyze (Argx); 645 646 if Nkind (Argx) not in N_Direct_Name 647 and then (Nkind (Argx) /= N_Attribute_Reference 648 or else Present (Expressions (Argx)) 649 or else Nkind (Prefix (Argx)) /= N_Identifier) 650 and then (not Is_Entity_Name (Argx) 651 or else not Is_Compilation_Unit (Entity (Argx))) 652 then 653 Error_Pragma_Arg ("argument for pragma% must be local name", Argx); 654 end if; 655 656 if Is_Entity_Name (Argx) 657 and then Scope (Entity (Argx)) /= Current_Scope 658 then 659 Error_Pragma_Arg 660 ("pragma% argument must be in same declarative part", Arg); 661 end if; 662 end Check_Arg_Is_Local_Name; 663 664 --------------------------------- 665 -- Check_Arg_Is_Locking_Policy -- 666 --------------------------------- 667 668 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is 669 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 670 671 begin 672 Check_Arg_Is_Identifier (Argx); 673 674 if not Is_Locking_Policy_Name (Chars (Argx)) then 675 Error_Pragma_Arg 676 ("& is not a valid locking policy name", Argx); 677 end if; 678 end Check_Arg_Is_Locking_Policy; 679 680 ------------------------- 681 -- Check_Arg_Is_One_Of -- 682 ------------------------- 683 684 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is 685 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 686 687 begin 688 Check_Arg_Is_Identifier (Argx); 689 690 if Chars (Argx) /= N1 and then Chars (Argx) /= N2 then 691 Error_Msg_Name_2 := N1; 692 Error_Msg_Name_3 := N2; 693 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx); 694 end if; 695 end Check_Arg_Is_One_Of; 696 697 procedure Check_Arg_Is_One_Of 698 (Arg : Node_Id; 699 N1, N2, N3 : Name_Id) 700 is 701 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 702 703 begin 704 Check_Arg_Is_Identifier (Argx); 705 706 if Chars (Argx) /= N1 707 and then Chars (Argx) /= N2 708 and then Chars (Argx) /= N3 709 then 710 Error_Pragma_Arg ("invalid argument for pragma%", Argx); 711 end if; 712 end Check_Arg_Is_One_Of; 713 714 --------------------------------- 715 -- Check_Arg_Is_Queuing_Policy -- 716 --------------------------------- 717 718 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is 719 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 720 721 begin 722 Check_Arg_Is_Identifier (Argx); 723 724 if not Is_Queuing_Policy_Name (Chars (Argx)) then 725 Error_Pragma_Arg 726 ("& is not a valid queuing policy name", Argx); 727 end if; 728 end Check_Arg_Is_Queuing_Policy; 729 730 ------------------------------------ 731 -- Check_Arg_Is_Static_Expression -- 732 ------------------------------------ 733 734 procedure Check_Arg_Is_Static_Expression 735 (Arg : Node_Id; 736 Typ : Entity_Id) 737 is 738 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 739 740 begin 741 Analyze_And_Resolve (Argx, Typ); 742 743 if Is_OK_Static_Expression (Argx) then 744 return; 745 746 elsif Etype (Argx) = Any_Type then 747 raise Pragma_Exit; 748 749 -- An interesting special case, if we have a string literal and 750 -- we are in Ada 83 mode, then we allow it even though it will 751 -- not be flagged as static. This allows the use of Ada 95 752 -- pragmas like Import in Ada 83 mode. They will of course be 753 -- flagged with warnings as usual, but will not cause errors. 754 755 elsif Ada_83 and then Nkind (Argx) = N_String_Literal then 756 return; 757 758 -- Static expression that raises Constraint_Error. This has 759 -- already been flagged, so just exit from pragma processing. 760 761 elsif Is_Static_Expression (Argx) then 762 raise Pragma_Exit; 763 764 -- Finally, we have a real error 765 766 else 767 Error_Msg_Name_1 := Chars (N); 768 Flag_Non_Static_Expr 769 ("argument for pragma% must be a static expression!", Argx); 770 raise Pragma_Exit; 771 end if; 772 end Check_Arg_Is_Static_Expression; 773 774 --------------------------------- 775 -- Check_Arg_Is_String_Literal -- 776 --------------------------------- 777 778 procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is 779 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 780 781 begin 782 if Nkind (Argx) /= N_String_Literal then 783 Error_Pragma_Arg 784 ("argument for pragma% must be string literal", Argx); 785 end if; 786 787 end Check_Arg_Is_String_Literal; 788 789 ------------------------------------------ 790 -- Check_Arg_Is_Task_Dispatching_Policy -- 791 ------------------------------------------ 792 793 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is 794 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 795 796 begin 797 Check_Arg_Is_Identifier (Argx); 798 799 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then 800 Error_Pragma_Arg 801 ("& is not a valid task dispatching policy name", Argx); 802 end if; 803 end Check_Arg_Is_Task_Dispatching_Policy; 804 805 -------------------------------- 806 -- Check_At_Least_N_Arguments -- 807 -------------------------------- 808 809 procedure Check_At_Least_N_Arguments (N : Nat) is 810 begin 811 if Arg_Count < N then 812 Error_Pragma ("too few arguments for pragma%"); 813 end if; 814 end Check_At_Least_N_Arguments; 815 816 ------------------------------- 817 -- Check_At_Most_N_Arguments -- 818 ------------------------------- 819 820 procedure Check_At_Most_N_Arguments (N : Nat) is 821 Arg : Node_Id; 822 823 begin 824 if Arg_Count > N then 825 Arg := Arg1; 826 827 for J in 1 .. N loop 828 Next (Arg); 829 Error_Pragma_Arg ("too many arguments for pragma%", Arg); 830 end loop; 831 end if; 832 end Check_At_Most_N_Arguments; 833 834 ------------------------- 835 -- Check_First_Subtype -- 836 ------------------------- 837 838 procedure Check_First_Subtype (Arg : Node_Id) is 839 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 840 841 begin 842 if not Is_First_Subtype (Entity (Argx)) then 843 Error_Pragma_Arg 844 ("pragma% cannot apply to subtype", Argx); 845 end if; 846 end Check_First_Subtype; 847 848 --------------------------- 849 -- Check_In_Main_Program -- 850 --------------------------- 851 852 procedure Check_In_Main_Program is 853 P : constant Node_Id := Parent (N); 854 855 begin 856 -- Must be at in subprogram body 857 858 if Nkind (P) /= N_Subprogram_Body then 859 Error_Pragma ("% pragma allowed only in subprogram"); 860 861 -- Otherwise warn if obviously not main program 862 863 elsif Present (Parameter_Specifications (Specification (P))) 864 or else not Is_Compilation_Unit (Defining_Entity (P)) 865 then 866 Error_Msg_Name_1 := Chars (N); 867 Error_Msg_N 868 ("?pragma% is only effective in main program", N); 869 end if; 870 end Check_In_Main_Program; 871 872 --------------------------------------- 873 -- Check_Interrupt_Or_Attach_Handler -- 874 --------------------------------------- 875 876 procedure Check_Interrupt_Or_Attach_Handler is 877 Arg1_X : constant Node_Id := Expression (Arg1); 878 879 begin 880 Analyze (Arg1_X); 881 882 if not Is_Entity_Name (Arg1_X) then 883 Error_Pragma_Arg 884 ("argument of pragma% must be entity name", Arg1); 885 886 elsif Prag_Id = Pragma_Interrupt_Handler then 887 Check_Restriction (No_Dynamic_Interrupts, N); 888 end if; 889 890 declare 891 Handler_Proc : Entity_Id := Empty; 892 Proc_Scope : Entity_Id; 893 Found : Boolean := False; 894 895 begin 896 if not Is_Overloaded (Arg1_X) then 897 Handler_Proc := Entity (Arg1_X); 898 899 else 900 declare 901 It : Interp; 902 Index : Interp_Index; 903 904 begin 905 Get_First_Interp (Arg1_X, Index, It); 906 while Present (It.Nam) loop 907 Handler_Proc := It.Nam; 908 909 if Ekind (Handler_Proc) = E_Procedure 910 and then No (First_Formal (Handler_Proc)) 911 then 912 if not Found then 913 Found := True; 914 Set_Entity (Arg1_X, Handler_Proc); 915 Set_Is_Overloaded (Arg1_X, False); 916 else 917 Error_Pragma_Arg 918 ("ambiguous handler name for pragma% ", Arg1); 919 end if; 920 end if; 921 922 Get_Next_Interp (Index, It); 923 end loop; 924 925 if not Found then 926 Error_Pragma_Arg 927 ("argument of pragma% must be parameterless procedure", 928 Arg1); 929 else 930 Handler_Proc := Entity (Arg1_X); 931 end if; 932 end; 933 end if; 934 935 Proc_Scope := Scope (Handler_Proc); 936 937 -- On AAMP only, a pragma Interrupt_Handler is supported for 938 -- nonprotected parameterless procedures. 939 940 if AAMP_On_Target 941 and then Prag_Id = Pragma_Interrupt_Handler 942 then 943 if Ekind (Handler_Proc) /= E_Procedure then 944 Error_Pragma_Arg 945 ("argument of pragma% must be a procedure", Arg1); 946 end if; 947 948 elsif Ekind (Handler_Proc) /= E_Procedure 949 or else Ekind (Proc_Scope) /= E_Protected_Type 950 then 951 Error_Pragma_Arg 952 ("argument of pragma% must be protected procedure", Arg1); 953 end if; 954 955 if (not AAMP_On_Target or else Prag_Id = Pragma_Attach_Handler) 956 and then Ekind (Proc_Scope) = E_Protected_Type 957 then 958 if Parent (N) /= 959 Protected_Definition (Parent (Proc_Scope)) 960 then 961 Error_Pragma ("pragma% must be in protected definition"); 962 end if; 963 end if; 964 965 if not Is_Library_Level_Entity (Proc_Scope) 966 or else (AAMP_On_Target 967 and then not Is_Library_Level_Entity (Handler_Proc)) 968 then 969 Error_Pragma_Arg 970 ("pragma% requires library-level entity", Arg1); 971 end if; 972 973 if Present (First_Formal (Handler_Proc)) then 974 Error_Pragma_Arg 975 ("argument of pragma% must be parameterless procedure", 976 Arg1); 977 end if; 978 end; 979 end Check_Interrupt_Or_Attach_Handler; 980 981 ------------------------------------------- 982 -- Check_Is_In_Decl_Part_Or_Package_Spec -- 983 ------------------------------------------- 984 985 procedure Check_Is_In_Decl_Part_Or_Package_Spec is 986 P : Node_Id; 987 988 begin 989 P := Parent (N); 990 loop 991 if No (P) then 992 exit; 993 994 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then 995 exit; 996 997 elsif Nkind (P) = N_Package_Specification then 998 return; 999 1000 elsif Nkind (P) = N_Block_Statement then 1001 return; 1002 1003 -- Note: the following tests seem a little peculiar, because 1004 -- they test for bodies, but if we were in the statement part 1005 -- of the body, we would already have hit the handled statement 1006 -- sequence, so the only way we get here is by being in the 1007 -- declarative part of the body. 1008 1009 elsif Nkind (P) = N_Subprogram_Body 1010 or else Nkind (P) = N_Package_Body 1011 or else Nkind (P) = N_Task_Body 1012 or else Nkind (P) = N_Entry_Body 1013 then 1014 return; 1015 end if; 1016 1017 P := Parent (P); 1018 end loop; 1019 1020 Error_Pragma ("pragma% is not in declarative part or package spec"); 1021 end Check_Is_In_Decl_Part_Or_Package_Spec; 1022 1023 ------------------------- 1024 -- Check_No_Identifier -- 1025 ------------------------- 1026 1027 procedure Check_No_Identifier (Arg : Node_Id) is 1028 begin 1029 if Chars (Arg) /= No_Name then 1030 Error_Pragma_Arg_Ident 1031 ("pragma% does not permit identifier& here", Arg); 1032 end if; 1033 end Check_No_Identifier; 1034 1035 -------------------------- 1036 -- Check_No_Identifiers -- 1037 -------------------------- 1038 1039 procedure Check_No_Identifiers is 1040 Arg_Node : Node_Id; 1041 1042 begin 1043 if Arg_Count > 0 then 1044 Arg_Node := Arg1; 1045 1046 while Present (Arg_Node) loop 1047 Check_No_Identifier (Arg_Node); 1048 Next (Arg_Node); 1049 end loop; 1050 end if; 1051 end Check_No_Identifiers; 1052 1053 ------------------------------- 1054 -- Check_Optional_Identifier -- 1055 ------------------------------- 1056 1057 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is 1058 begin 1059 if Present (Arg) and then Chars (Arg) /= No_Name then 1060 if Chars (Arg) /= Id then 1061 Error_Msg_Name_1 := Chars (N); 1062 Error_Msg_Name_2 := Id; 1063 Error_Msg_N ("pragma% argument expects identifier%", Arg); 1064 raise Pragma_Exit; 1065 end if; 1066 end if; 1067 end Check_Optional_Identifier; 1068 1069 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is 1070 begin 1071 Name_Buffer (1 .. Id'Length) := Id; 1072 Name_Len := Id'Length; 1073 Check_Optional_Identifier (Arg, Name_Find); 1074 end Check_Optional_Identifier; 1075 1076 ----------------------------- 1077 -- Check_Static_Constraint -- 1078 ----------------------------- 1079 1080 -- Note: for convenience in writing this procedure, in addition to 1081 -- the officially (i.e. by spec) allowed argument which is always 1082 -- a constraint, it also allows ranges and discriminant associations. 1083 -- Above is not clear ??? 1084 1085 procedure Check_Static_Constraint (Constr : Node_Id) is 1086 1087 -------------------- 1088 -- Require_Static -- 1089 -------------------- 1090 1091 procedure Require_Static (E : Node_Id); 1092 -- Require given expression to be static expression 1093 1094 procedure Require_Static (E : Node_Id) is 1095 begin 1096 if not Is_OK_Static_Expression (E) then 1097 Flag_Non_Static_Expr 1098 ("non-static constraint not allowed in Unchecked_Union!", E); 1099 raise Pragma_Exit; 1100 end if; 1101 end Require_Static; 1102 1103 -- Start of processing for Check_Static_Constraint 1104 1105 begin 1106 case Nkind (Constr) is 1107 when N_Discriminant_Association => 1108 Require_Static (Expression (Constr)); 1109 1110 when N_Range => 1111 Require_Static (Low_Bound (Constr)); 1112 Require_Static (High_Bound (Constr)); 1113 1114 when N_Attribute_Reference => 1115 Require_Static (Type_Low_Bound (Etype (Prefix (Constr)))); 1116 Require_Static (Type_High_Bound (Etype (Prefix (Constr)))); 1117 1118 when N_Range_Constraint => 1119 Check_Static_Constraint (Range_Expression (Constr)); 1120 1121 when N_Index_Or_Discriminant_Constraint => 1122 declare 1123 IDC : Entity_Id := First (Constraints (Constr)); 1124 begin 1125 while Present (IDC) loop 1126 Check_Static_Constraint (IDC); 1127 Next (IDC); 1128 end loop; 1129 end; 1130 1131 when others => 1132 null; 1133 end case; 1134 end Check_Static_Constraint; 1135 1136 -------------------------------------- 1137 -- Check_Valid_Configuration_Pragma -- 1138 -------------------------------------- 1139 1140 -- A configuration pragma must appear in the context clause of 1141 -- a compilation unit, at the start of the list (i.e. only other 1142 -- pragmas may precede it). 1143 1144 procedure Check_Valid_Configuration_Pragma is 1145 begin 1146 if not Is_Configuration_Pragma then 1147 Error_Pragma ("incorrect placement for configuration pragma%"); 1148 end if; 1149 end Check_Valid_Configuration_Pragma; 1150 1151 ------------------------------------- 1152 -- Check_Valid_Library_Unit_Pragma -- 1153 ------------------------------------- 1154 1155 procedure Check_Valid_Library_Unit_Pragma is 1156 Plist : List_Id; 1157 Parent_Node : Node_Id; 1158 Unit_Name : Entity_Id; 1159 Unit_Kind : Node_Kind; 1160 Unit_Node : Node_Id; 1161 Sindex : Source_File_Index; 1162 1163 begin 1164 if not Is_List_Member (N) then 1165 Pragma_Misplaced; 1166 1167 else 1168 Plist := List_Containing (N); 1169 Parent_Node := Parent (Plist); 1170 1171 if Parent_Node = Empty then 1172 Pragma_Misplaced; 1173 1174 -- Case of pragma appearing after a compilation unit. In this 1175 -- case it must have an argument with the corresponding name 1176 -- and must be part of the following pragmas of its parent. 1177 1178 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then 1179 if Plist /= Pragmas_After (Parent_Node) then 1180 Pragma_Misplaced; 1181 1182 elsif Arg_Count = 0 then 1183 Error_Pragma 1184 ("argument required if outside compilation unit"); 1185 1186 else 1187 Check_No_Identifiers; 1188 Check_Arg_Count (1); 1189 Unit_Node := Unit (Parent (Parent_Node)); 1190 Unit_Kind := Nkind (Unit_Node); 1191 1192 Analyze (Expression (Arg1)); 1193 1194 if Unit_Kind = N_Generic_Subprogram_Declaration 1195 or else Unit_Kind = N_Subprogram_Declaration 1196 then 1197 Unit_Name := Defining_Entity (Unit_Node); 1198 1199 elsif Unit_Kind = N_Function_Instantiation 1200 or else Unit_Kind = N_Package_Instantiation 1201 or else Unit_Kind = N_Procedure_Instantiation 1202 then 1203 Unit_Name := Defining_Entity (Unit_Node); 1204 1205 else 1206 Unit_Name := Cunit_Entity (Current_Sem_Unit); 1207 end if; 1208 1209 if Chars (Unit_Name) /= 1210 Chars (Entity (Expression (Arg1))) 1211 then 1212 Error_Pragma_Arg 1213 ("pragma% argument is not current unit name", Arg1); 1214 end if; 1215 1216 if Ekind (Unit_Name) = E_Package 1217 and then Present (Renamed_Entity (Unit_Name)) 1218 then 1219 Error_Pragma ("pragma% not allowed for renamed package"); 1220 end if; 1221 end if; 1222 1223 -- Pragma appears other than after a compilation unit 1224 1225 else 1226 -- Here we check for the generic instantiation case and also 1227 -- for the case of processing a generic formal package. We 1228 -- detect these cases by noting that the Sloc on the node 1229 -- does not belong to the current compilation unit. 1230 1231 Sindex := Source_Index (Current_Sem_Unit); 1232 1233 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then 1234 Rewrite (N, Make_Null_Statement (Loc)); 1235 return; 1236 1237 -- If before first declaration, the pragma applies to the 1238 -- enclosing unit, and the name if present must be this name. 1239 1240 elsif Is_Before_First_Decl (N, Plist) then 1241 Unit_Node := Unit_Declaration_Node (Current_Scope); 1242 Unit_Kind := Nkind (Unit_Node); 1243 1244 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then 1245 Pragma_Misplaced; 1246 1247 elsif Unit_Kind = N_Subprogram_Body 1248 and then not Acts_As_Spec (Unit_Node) 1249 then 1250 Pragma_Misplaced; 1251 1252 elsif Nkind (Parent_Node) = N_Package_Body then 1253 Pragma_Misplaced; 1254 1255 elsif Nkind (Parent_Node) = N_Package_Specification 1256 and then Plist = Private_Declarations (Parent_Node) 1257 then 1258 Pragma_Misplaced; 1259 1260 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration 1261 or else Nkind (Parent_Node) 1262 = N_Generic_Subprogram_Declaration) 1263 and then Plist = Generic_Formal_Declarations (Parent_Node) 1264 then 1265 Pragma_Misplaced; 1266 1267 elsif Arg_Count > 0 then 1268 Analyze (Expression (Arg1)); 1269 1270 if Entity (Expression (Arg1)) /= Current_Scope then 1271 Error_Pragma_Arg 1272 ("name in pragma% must be enclosing unit", Arg1); 1273 end if; 1274 1275 -- It is legal to have no argument in this context 1276 1277 else 1278 return; 1279 end if; 1280 1281 -- Error if not before first declaration. This is because a 1282 -- library unit pragma argument must be the name of a library 1283 -- unit (RM 10.1.5(7)), but the only names permitted in this 1284 -- context are (RM 10.1.5(6)) names of subprogram declarations, 1285 -- generic subprogram declarations or generic instantiations. 1286 1287 else 1288 Error_Pragma 1289 ("pragma% misplaced, must be before first declaration"); 1290 end if; 1291 end if; 1292 end if; 1293 end Check_Valid_Library_Unit_Pragma; 1294 1295 ------------------ 1296 -- Error_Pragma -- 1297 ------------------ 1298 1299 procedure Error_Pragma (Msg : String) is 1300 begin 1301 Error_Msg_Name_1 := Chars (N); 1302 Error_Msg_N (Msg, N); 1303 raise Pragma_Exit; 1304 end Error_Pragma; 1305 1306 ---------------------- 1307 -- Error_Pragma_Arg -- 1308 ---------------------- 1309 1310 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is 1311 begin 1312 Error_Msg_Name_1 := Chars (N); 1313 Error_Msg_N (Msg, Get_Pragma_Arg (Arg)); 1314 raise Pragma_Exit; 1315 end Error_Pragma_Arg; 1316 1317 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is 1318 begin 1319 Error_Msg_Name_1 := Chars (N); 1320 Error_Msg_N (Msg1, Get_Pragma_Arg (Arg)); 1321 Error_Pragma_Arg (Msg2, Arg); 1322 end Error_Pragma_Arg; 1323 1324 ---------------------------- 1325 -- Error_Pragma_Arg_Ident -- 1326 ---------------------------- 1327 1328 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is 1329 begin 1330 Error_Msg_Name_1 := Chars (N); 1331 Error_Msg_N (Msg, Arg); 1332 raise Pragma_Exit; 1333 end Error_Pragma_Arg_Ident; 1334 1335 ------------------------ 1336 -- Find_Lib_Unit_Name -- 1337 ------------------------ 1338 1339 function Find_Lib_Unit_Name return Entity_Id is 1340 begin 1341 -- Return inner compilation unit entity, for case of nested 1342 -- categorization pragmas. This happens in generic unit. 1343 1344 if Nkind (Parent (N)) = N_Package_Specification 1345 and then Defining_Entity (Parent (N)) /= Current_Scope 1346 then 1347 return Defining_Entity (Parent (N)); 1348 else 1349 return Current_Scope; 1350 end if; 1351 end Find_Lib_Unit_Name; 1352 1353 ---------------------------- 1354 -- Find_Program_Unit_Name -- 1355 ---------------------------- 1356 1357 procedure Find_Program_Unit_Name (Id : Node_Id) is 1358 Unit_Name : Entity_Id; 1359 Unit_Kind : Node_Kind; 1360 P : constant Node_Id := Parent (N); 1361 1362 begin 1363 if Nkind (P) = N_Compilation_Unit then 1364 Unit_Kind := Nkind (Unit (P)); 1365 1366 if Unit_Kind = N_Subprogram_Declaration 1367 or else Unit_Kind = N_Package_Declaration 1368 or else Unit_Kind in N_Generic_Declaration 1369 then 1370 Unit_Name := Defining_Entity (Unit (P)); 1371 1372 if Chars (Id) = Chars (Unit_Name) then 1373 Set_Entity (Id, Unit_Name); 1374 Set_Etype (Id, Etype (Unit_Name)); 1375 else 1376 Set_Etype (Id, Any_Type); 1377 Error_Pragma 1378 ("cannot find program unit referenced by pragma%"); 1379 end if; 1380 1381 else 1382 Set_Etype (Id, Any_Type); 1383 Error_Pragma ("pragma% inapplicable to this unit"); 1384 end if; 1385 1386 else 1387 Analyze (Id); 1388 end if; 1389 1390 end Find_Program_Unit_Name; 1391 1392 ------------------------- 1393 -- Gather_Associations -- 1394 ------------------------- 1395 1396 procedure Gather_Associations 1397 (Names : Name_List; 1398 Args : out Args_List) 1399 is 1400 Arg : Node_Id; 1401 1402 begin 1403 -- Initialize all parameters to Empty 1404 1405 for J in Args'Range loop 1406 Args (J) := Empty; 1407 end loop; 1408 1409 -- That's all we have to do if there are no argument associations 1410 1411 if No (Pragma_Argument_Associations (N)) then 1412 return; 1413 end if; 1414 1415 -- Otherwise first deal with any positional parameters present 1416 1417 Arg := First (Pragma_Argument_Associations (N)); 1418 1419 for Index in Args'Range loop 1420 exit when No (Arg) or else Chars (Arg) /= No_Name; 1421 Args (Index) := Expression (Arg); 1422 Next (Arg); 1423 end loop; 1424 1425 -- Positional parameters all processed, if any left, then we 1426 -- have too many positional parameters. 1427 1428 if Present (Arg) and then Chars (Arg) = No_Name then 1429 Error_Pragma_Arg 1430 ("too many positional associations for pragma%", Arg); 1431 end if; 1432 1433 -- Process named parameters if any are present 1434 1435 while Present (Arg) loop 1436 if Chars (Arg) = No_Name then 1437 Error_Pragma_Arg 1438 ("positional association cannot follow named association", 1439 Arg); 1440 1441 else 1442 for Index in Names'Range loop 1443 if Names (Index) = Chars (Arg) then 1444 if Present (Args (Index)) then 1445 Error_Pragma_Arg 1446 ("duplicate argument association for pragma%", Arg); 1447 else 1448 Args (Index) := Expression (Arg); 1449 exit; 1450 end if; 1451 end if; 1452 1453 if Index = Names'Last then 1454 Error_Msg_Name_1 := Chars (N); 1455 Error_Msg_N ("pragma% does not allow & argument", Arg); 1456 1457 -- Check for possible misspelling 1458 1459 for Index1 in Names'Range loop 1460 if Is_Bad_Spelling_Of 1461 (Get_Name_String (Chars (Arg)), 1462 Get_Name_String (Names (Index1))) 1463 then 1464 Error_Msg_Name_1 := Names (Index1); 1465 Error_Msg_N ("\possible misspelling of%", Arg); 1466 exit; 1467 end if; 1468 end loop; 1469 1470 raise Pragma_Exit; 1471 end if; 1472 end loop; 1473 end if; 1474 1475 Next (Arg); 1476 end loop; 1477 end Gather_Associations; 1478 1479 -------------------- 1480 -- Get_Pragma_Arg -- 1481 -------------------- 1482 1483 function Get_Pragma_Arg (Arg : Node_Id) return Node_Id is 1484 begin 1485 if Nkind (Arg) = N_Pragma_Argument_Association then 1486 return Expression (Arg); 1487 else 1488 return Arg; 1489 end if; 1490 end Get_Pragma_Arg; 1491 1492 ----------------- 1493 -- GNAT_Pragma -- 1494 ----------------- 1495 1496 procedure GNAT_Pragma is 1497 begin 1498 Check_Restriction (No_Implementation_Pragmas, N); 1499 end GNAT_Pragma; 1500 1501 -------------------------- 1502 -- Is_Before_First_Decl -- 1503 -------------------------- 1504 1505 function Is_Before_First_Decl 1506 (Pragma_Node : Node_Id; 1507 Decls : List_Id) return Boolean 1508 is 1509 Item : Node_Id := First (Decls); 1510 1511 begin 1512 -- Only other pragmas can come before this pragma 1513 1514 loop 1515 if No (Item) or else Nkind (Item) /= N_Pragma then 1516 return False; 1517 1518 elsif Item = Pragma_Node then 1519 return True; 1520 end if; 1521 1522 Next (Item); 1523 end loop; 1524 end Is_Before_First_Decl; 1525 1526 ----------------------------- 1527 -- Is_Configuration_Pragma -- 1528 ----------------------------- 1529 1530 -- A configuration pragma must appear in the context clause of 1531 -- a compilation unit, at the start of the list (i.e. only other 1532 -- pragmas may precede it). 1533 1534 function Is_Configuration_Pragma return Boolean is 1535 Lis : constant List_Id := List_Containing (N); 1536 Par : constant Node_Id := Parent (N); 1537 Prg : Node_Id; 1538 1539 begin 1540 -- If no parent, then we are in the configuration pragma file, 1541 -- so the placement is definitely appropriate. 1542 1543 if No (Par) then 1544 return True; 1545 1546 -- Otherwise we must be in the context clause of a compilation unit 1547 -- and the only thing allowed before us in the context list is more 1548 -- configuration pragmas. 1549 1550 elsif Nkind (Par) = N_Compilation_Unit 1551 and then Context_Items (Par) = Lis 1552 then 1553 Prg := First (Lis); 1554 1555 loop 1556 if Prg = N then 1557 return True; 1558 elsif Nkind (Prg) /= N_Pragma then 1559 return False; 1560 end if; 1561 1562 Next (Prg); 1563 end loop; 1564 1565 else 1566 return False; 1567 end if; 1568 end Is_Configuration_Pragma; 1569 1570 ---------------------- 1571 -- Pragma_Misplaced -- 1572 ---------------------- 1573 1574 procedure Pragma_Misplaced is 1575 begin 1576 Error_Pragma ("incorrect placement of pragma%"); 1577 end Pragma_Misplaced; 1578 1579 ------------------------------------ 1580 -- Process Atomic_Shared_Volatile -- 1581 ------------------------------------ 1582 1583 procedure Process_Atomic_Shared_Volatile is 1584 E_Id : Node_Id; 1585 E : Entity_Id; 1586 D : Node_Id; 1587 K : Node_Kind; 1588 Utyp : Entity_Id; 1589 1590 begin 1591 Check_Ada_83_Warning; 1592 Check_No_Identifiers; 1593 Check_Arg_Count (1); 1594 Check_Arg_Is_Local_Name (Arg1); 1595 E_Id := Expression (Arg1); 1596 1597 if Etype (E_Id) = Any_Type then 1598 return; 1599 end if; 1600 1601 E := Entity (E_Id); 1602 D := Declaration_Node (E); 1603 K := Nkind (D); 1604 1605 if Is_Type (E) then 1606 if Rep_Item_Too_Early (E, N) 1607 or else 1608 Rep_Item_Too_Late (E, N) 1609 then 1610 return; 1611 else 1612 Check_First_Subtype (Arg1); 1613 end if; 1614 1615 if Prag_Id /= Pragma_Volatile then 1616 Set_Is_Atomic (E); 1617 Set_Is_Atomic (Underlying_Type (E)); 1618 end if; 1619 1620 -- Attribute belongs on the base type. If the 1621 -- view of the type is currently private, it also 1622 -- belongs on the underlying type. 1623 1624 Set_Is_Volatile (Base_Type (E)); 1625 Set_Is_Volatile (Underlying_Type (E)); 1626 1627 Set_Treat_As_Volatile (E); 1628 Set_Treat_As_Volatile (Underlying_Type (E)); 1629 1630 elsif K = N_Object_Declaration 1631 or else (K = N_Component_Declaration 1632 and then Original_Record_Component (E) = E) 1633 then 1634 if Rep_Item_Too_Late (E, N) then 1635 return; 1636 end if; 1637 1638 if Prag_Id /= Pragma_Volatile then 1639 Set_Is_Atomic (E); 1640 1641 -- If the object declaration has an explicit 1642 -- initialization, a temporary may have to be 1643 -- created to hold the expression, to insure 1644 -- that access to the object remain atomic. 1645 1646 if Nkind (Parent (E)) = N_Object_Declaration 1647 and then Present (Expression (Parent (E))) 1648 then 1649 Set_Has_Delayed_Freeze (E); 1650 end if; 1651 1652 -- An interesting improvement here. If an object of type X 1653 -- is declared atomic, and the type X is not atomic, that's 1654 -- a pity, since it may not have appropraite alignment etc. 1655 -- We can rescue this in the special case where the object 1656 -- and type are in the same unit by just setting the type 1657 -- as atomic, so that the back end will process it as atomic. 1658 1659 Utyp := Underlying_Type (Etype (E)); 1660 1661 if Present (Utyp) 1662 and then Sloc (E) > No_Location 1663 and then Sloc (Utyp) > No_Location 1664 and then 1665 Get_Source_File_Index (Sloc (E)) = 1666 Get_Source_File_Index (Sloc (Underlying_Type (Etype (E)))) 1667 then 1668 Set_Is_Atomic (Underlying_Type (Etype (E))); 1669 end if; 1670 end if; 1671 1672 Set_Is_Volatile (E); 1673 Set_Treat_As_Volatile (E); 1674 1675 else 1676 Error_Pragma_Arg 1677 ("inappropriate entity for pragma%", Arg1); 1678 end if; 1679 end Process_Atomic_Shared_Volatile; 1680 1681 ------------------------ 1682 -- Process_Convention -- 1683 ------------------------ 1684 1685 procedure Process_Convention 1686 (C : out Convention_Id; 1687 E : out Entity_Id) 1688 is 1689 Id : Node_Id; 1690 E1 : Entity_Id; 1691 Comp_Unit : Unit_Number_Type; 1692 Cname : Name_Id; 1693 1694 procedure Set_Convention_From_Pragma (E : Entity_Id); 1695 -- Set convention in entity E, and also flag that the entity has a 1696 -- convention pragma. If entity is for a private or incomplete type, 1697 -- also set convention and flag on underlying type. This procedure 1698 -- also deals with the special case of C_Pass_By_Copy convention. 1699 1700 -------------------------------- 1701 -- Set_Convention_From_Pragma -- 1702 -------------------------------- 1703 1704 procedure Set_Convention_From_Pragma (E : Entity_Id) is 1705 begin 1706 Set_Convention (E, C); 1707 Set_Has_Convention_Pragma (E); 1708 1709 if Is_Incomplete_Or_Private_Type (E) then 1710 Set_Convention (Underlying_Type (E), C); 1711 Set_Has_Convention_Pragma (Underlying_Type (E), True); 1712 end if; 1713 1714 -- A class-wide type should inherit the convention of 1715 -- the specific root type (although this isn't specified 1716 -- clearly by the RM). 1717 1718 if Is_Type (E) and then Present (Class_Wide_Type (E)) then 1719 Set_Convention (Class_Wide_Type (E), C); 1720 end if; 1721 1722 -- If the entity is a record type, then check for special case 1723 -- of C_Pass_By_Copy, which is treated the same as C except that 1724 -- the special record flag is set. This convention is also only 1725 -- permitted on record types (see AI95-00131). 1726 1727 if Cname = Name_C_Pass_By_Copy then 1728 if Is_Record_Type (E) then 1729 Set_C_Pass_By_Copy (Base_Type (E)); 1730 elsif Is_Incomplete_Or_Private_Type (E) 1731 and then Is_Record_Type (Underlying_Type (E)) 1732 then 1733 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E))); 1734 else 1735 Error_Pragma_Arg 1736 ("C_Pass_By_Copy convention allowed only for record type", 1737 Arg2); 1738 end if; 1739 end if; 1740 1741 -- If the entity is a derived boolean type, check for the 1742 -- special case of convention C, C++, or Fortran, where we 1743 -- consider any nonzero value to represent true. 1744 1745 if Is_Discrete_Type (E) 1746 and then Root_Type (Etype (E)) = Standard_Boolean 1747 and then 1748 (C = Convention_C 1749 or else 1750 C = Convention_CPP 1751 or else 1752 C = Convention_Fortran) 1753 then 1754 Set_Nonzero_Is_True (Base_Type (E)); 1755 end if; 1756 end Set_Convention_From_Pragma; 1757 1758 -- Start of processing for Process_Convention 1759 1760 begin 1761 Check_At_Least_N_Arguments (2); 1762 Check_Arg_Is_Identifier (Arg1); 1763 Check_Optional_Identifier (Arg1, Name_Convention); 1764 Cname := Chars (Expression (Arg1)); 1765 1766 -- C_Pass_By_Copy is treated as a synonym for convention C 1767 -- (this is tested again below to set the critical flag) 1768 1769 if Cname = Name_C_Pass_By_Copy then 1770 C := Convention_C; 1771 1772 -- Otherwise we must have something in the standard convention list 1773 1774 elsif Is_Convention_Name (Cname) then 1775 C := Get_Convention_Id (Chars (Expression (Arg1))); 1776 1777 -- In DEC VMS, it seems that there is an undocumented feature 1778 -- that any unrecognized convention is treated as the default, 1779 -- which for us is convention C. It does not seem so terrible 1780 -- to do this unconditionally, silently in the VMS case, and 1781 -- with a warning in the non-VMS case. 1782 1783 else 1784 if Warn_On_Export_Import and not OpenVMS_On_Target then 1785 Error_Msg_N 1786 ("?unrecognized convention name, C assumed", 1787 Expression (Arg1)); 1788 end if; 1789 1790 C := Convention_C; 1791 end if; 1792 1793 Check_Arg_Is_Local_Name (Arg2); 1794 Check_Optional_Identifier (Arg2, Name_Entity); 1795 1796 Id := Expression (Arg2); 1797 Analyze (Id); 1798 1799 if not Is_Entity_Name (Id) then 1800 Error_Pragma_Arg ("entity name required", Arg2); 1801 end if; 1802 1803 E := Entity (Id); 1804 1805 -- Go to renamed subprogram if present, since convention applies 1806 -- to the actual renamed entity, not to the renaming entity. 1807 1808 if Is_Subprogram (E) 1809 and then Present (Alias (E)) 1810 and then Nkind (Parent (Declaration_Node (E))) = 1811 N_Subprogram_Renaming_Declaration 1812 then 1813 E := Alias (E); 1814 end if; 1815 1816 -- Check that we not applying this to a specless body 1817 1818 if Is_Subprogram (E) 1819 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body 1820 then 1821 Error_Pragma 1822 ("pragma% requires separate spec and must come before body"); 1823 end if; 1824 1825 -- Check that we are not applying this to a named constant 1826 1827 if Ekind (E) = E_Named_Integer 1828 or else 1829 Ekind (E) = E_Named_Real 1830 then 1831 Error_Msg_Name_1 := Chars (N); 1832 Error_Msg_N 1833 ("cannot apply pragma% to named constant!", 1834 Get_Pragma_Arg (Arg2)); 1835 Error_Pragma_Arg 1836 ("\supply appropriate type for&!", Arg2); 1837 end if; 1838 1839 if Etype (E) = Any_Type 1840 or else Rep_Item_Too_Early (E, N) 1841 then 1842 raise Pragma_Exit; 1843 else 1844 E := Underlying_Type (E); 1845 end if; 1846 1847 if Rep_Item_Too_Late (E, N) then 1848 raise Pragma_Exit; 1849 end if; 1850 1851 if Has_Convention_Pragma (E) then 1852 Error_Pragma_Arg 1853 ("at most one Convention/Export/Import pragma is allowed", Arg2); 1854 1855 elsif Convention (E) = Convention_Protected 1856 or else Ekind (Scope (E)) = E_Protected_Type 1857 then 1858 Error_Pragma_Arg 1859 ("a protected operation cannot be given a different convention", 1860 Arg2); 1861 end if; 1862 1863 -- For Intrinsic, a subprogram is required 1864 1865 if C = Convention_Intrinsic 1866 and then not Is_Subprogram (E) 1867 and then not Is_Generic_Subprogram (E) 1868 then 1869 Error_Pragma_Arg 1870 ("second argument of pragma% must be a subprogram", Arg2); 1871 end if; 1872 1873 -- For Stdcall, a subprogram, variable or subprogram type is required 1874 1875 if C = Convention_Stdcall 1876 and then not Is_Subprogram (E) 1877 and then not Is_Generic_Subprogram (E) 1878 and then Ekind (E) /= E_Variable 1879 and then not 1880 (Is_Access_Type (E) 1881 and then Ekind (Designated_Type (E)) = E_Subprogram_Type) 1882 then 1883 Error_Pragma_Arg 1884 ("second argument of pragma% must be subprogram (type)", 1885 Arg2); 1886 end if; 1887 1888 if not Is_Subprogram (E) 1889 and then not Is_Generic_Subprogram (E) 1890 then 1891 Set_Convention_From_Pragma (E); 1892 1893 if Is_Type (E) then 1894 1895 Check_First_Subtype (Arg2); 1896 Set_Convention_From_Pragma (Base_Type (E)); 1897 1898 -- For subprograms, we must set the convention on the 1899 -- internally generated directly designated type as well. 1900 1901 if Ekind (E) = E_Access_Subprogram_Type then 1902 Set_Convention_From_Pragma (Directly_Designated_Type (E)); 1903 end if; 1904 end if; 1905 1906 -- For the subprogram case, set proper convention for all homonyms 1907 -- in same compilation unit. 1908 -- Is the test of compilation unit really necessary ??? 1909 -- What about subprogram renamings here??? 1910 1911 else 1912 Comp_Unit := Get_Source_Unit (E); 1913 Set_Convention_From_Pragma (E); 1914 1915 -- Treat a pragma Import as an implicit body, for GPS use. 1916 1917 if Prag_Id = Pragma_Import then 1918 Generate_Reference (E, Id, 'b'); 1919 end if; 1920 1921 E1 := E; 1922 loop 1923 E1 := Homonym (E1); 1924 exit when No (E1) or else Scope (E1) /= Current_Scope; 1925 1926 -- Note: below we are missing a check for Rep_Item_Too_Late. 1927 -- That is deliberate, we cannot chain the rep item on more 1928 -- than one Rep_Item chain, to be fixed later ??? 1929 1930 if Comp_Unit = Get_Source_Unit (E1) then 1931 Set_Convention_From_Pragma (E1); 1932 1933 if Prag_Id = Pragma_Import then 1934 Generate_Reference (E, Id, 'b'); 1935 end if; 1936 end if; 1937 end loop; 1938 end if; 1939 end Process_Convention; 1940 1941 ----------------------------------------------------- 1942 -- Process_Extended_Import_Export_Exception_Pragma -- 1943 ----------------------------------------------------- 1944 1945 procedure Process_Extended_Import_Export_Exception_Pragma 1946 (Arg_Internal : Node_Id; 1947 Arg_External : Node_Id; 1948 Arg_Form : Node_Id; 1949 Arg_Code : Node_Id) 1950 is 1951 Def_Id : Entity_Id; 1952 Code_Val : Uint; 1953 1954 begin 1955 GNAT_Pragma; 1956 1957 if not OpenVMS_On_Target then 1958 Error_Pragma 1959 ("?pragma% ignored (applies only to Open'V'M'S)"); 1960 end if; 1961 1962 Process_Extended_Import_Export_Internal_Arg (Arg_Internal); 1963 Def_Id := Entity (Arg_Internal); 1964 1965 if Ekind (Def_Id) /= E_Exception then 1966 Error_Pragma_Arg 1967 ("pragma% must refer to declared exception", Arg_Internal); 1968 end if; 1969 1970 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External); 1971 1972 if Present (Arg_Form) then 1973 Check_Arg_Is_One_Of (Arg_Form, Name_Ada, Name_VMS); 1974 end if; 1975 1976 if Present (Arg_Form) 1977 and then Chars (Arg_Form) = Name_Ada 1978 then 1979 null; 1980 else 1981 Set_Is_VMS_Exception (Def_Id); 1982 Set_Exception_Code (Def_Id, No_Uint); 1983 end if; 1984 1985 if Present (Arg_Code) then 1986 if not Is_VMS_Exception (Def_Id) then 1987 Error_Pragma_Arg 1988 ("Code option for pragma% not allowed for Ada case", 1989 Arg_Code); 1990 end if; 1991 1992 Check_Arg_Is_Static_Expression (Arg_Code, Any_Integer); 1993 Code_Val := Expr_Value (Arg_Code); 1994 1995 if not UI_Is_In_Int_Range (Code_Val) then 1996 Error_Pragma_Arg 1997 ("Code option for pragma% must be in 32-bit range", 1998 Arg_Code); 1999 2000 else 2001 Set_Exception_Code (Def_Id, Code_Val); 2002 end if; 2003 end if; 2004 end Process_Extended_Import_Export_Exception_Pragma; 2005 2006 ------------------------------------------------- 2007 -- Process_Extended_Import_Export_Internal_Arg -- 2008 ------------------------------------------------- 2009 2010 procedure Process_Extended_Import_Export_Internal_Arg 2011 (Arg_Internal : Node_Id := Empty) 2012 is 2013 begin 2014 GNAT_Pragma; 2015 2016 if No (Arg_Internal) then 2017 Error_Pragma ("Internal parameter required for pragma%"); 2018 end if; 2019 2020 if Nkind (Arg_Internal) = N_Identifier then 2021 null; 2022 2023 elsif Nkind (Arg_Internal) = N_Operator_Symbol 2024 and then (Prag_Id = Pragma_Import_Function 2025 or else 2026 Prag_Id = Pragma_Export_Function) 2027 then 2028 null; 2029 2030 else 2031 Error_Pragma_Arg 2032 ("wrong form for Internal parameter for pragma%", Arg_Internal); 2033 end if; 2034 2035 Check_Arg_Is_Local_Name (Arg_Internal); 2036 end Process_Extended_Import_Export_Internal_Arg; 2037 2038 -------------------------------------------------- 2039 -- Process_Extended_Import_Export_Object_Pragma -- 2040 -------------------------------------------------- 2041 2042 procedure Process_Extended_Import_Export_Object_Pragma 2043 (Arg_Internal : Node_Id; 2044 Arg_External : Node_Id; 2045 Arg_Size : Node_Id) 2046 is 2047 Def_Id : Entity_Id; 2048 2049 begin 2050 Process_Extended_Import_Export_Internal_Arg (Arg_Internal); 2051 Def_Id := Entity (Arg_Internal); 2052 2053 if Ekind (Def_Id) /= E_Constant 2054 and then Ekind (Def_Id) /= E_Variable 2055 then 2056 Error_Pragma_Arg 2057 ("pragma% must designate an object", Arg_Internal); 2058 end if; 2059 2060 if Is_Psected (Def_Id) then 2061 Error_Pragma_Arg 2062 ("previous Psect_Object applies, pragma % not permitted", 2063 Arg_Internal); 2064 end if; 2065 2066 if Rep_Item_Too_Late (Def_Id, N) then 2067 raise Pragma_Exit; 2068 end if; 2069 2070 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External); 2071 2072 if Present (Arg_Size) 2073 and then Nkind (Arg_Size) /= N_Identifier 2074 and then Nkind (Arg_Size) /= N_String_Literal 2075 then 2076 Error_Pragma_Arg 2077 ("pragma% Size argument must be identifier or string literal", 2078 Arg_Size); 2079 end if; 2080 2081 -- Export_Object case 2082 2083 if Prag_Id = Pragma_Export_Object then 2084 if not Is_Library_Level_Entity (Def_Id) then 2085 Error_Pragma_Arg 2086 ("argument for pragma% must be library level entity", 2087 Arg_Internal); 2088 end if; 2089 2090 if Ekind (Current_Scope) = E_Generic_Package then 2091 Error_Pragma ("pragma& cannot appear in a generic unit"); 2092 end if; 2093 2094 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then 2095 Error_Pragma_Arg 2096 ("exported object must have compile time known size", 2097 Arg_Internal); 2098 end if; 2099 2100 if Warn_On_Export_Import and then Is_Exported (Def_Id) then 2101 Error_Msg_N 2102 ("?duplicate Export_Object pragma", N); 2103 else 2104 Set_Exported (Def_Id, Arg_Internal); 2105 end if; 2106 2107 -- Import_Object case 2108 2109 else 2110 if Is_Concurrent_Type (Etype (Def_Id)) then 2111 Error_Pragma_Arg 2112 ("cannot use pragma% for task/protected object", 2113 Arg_Internal); 2114 end if; 2115 2116 if Ekind (Def_Id) = E_Constant then 2117 Error_Pragma_Arg 2118 ("cannot import a constant", Arg_Internal); 2119 end if; 2120 2121 if Warn_On_Export_Import 2122 and then Has_Discriminants (Etype (Def_Id)) 2123 then 2124 Error_Msg_N 2125 ("imported value must be initialized?", Arg_Internal); 2126 end if; 2127 2128 if Warn_On_Export_Import 2129 and then Is_Access_Type (Etype (Def_Id)) 2130 then 2131 Error_Pragma_Arg 2132 ("cannot import object of an access type?", Arg_Internal); 2133 end if; 2134 2135 if Warn_On_Export_Import 2136 and then Is_Imported (Def_Id) 2137 then 2138 Error_Msg_N 2139 ("?duplicate Import_Object pragma", N); 2140 2141 -- Check for explicit initialization present. Note that an 2142 -- initialization that generated by the code generator, e.g. 2143 -- for an access type, does not count here. 2144 2145 elsif Present (Expression (Parent (Def_Id))) 2146 and then 2147 Comes_From_Source 2148 (Original_Node (Expression (Parent (Def_Id)))) 2149 then 2150 Error_Msg_Sloc := Sloc (Def_Id); 2151 Error_Pragma_Arg 2152 ("no initialization allowed for declaration of& #", 2153 "\imported entities cannot be initialized ('R'M' 'B.1(24))", 2154 Arg1); 2155 else 2156 Set_Imported (Def_Id); 2157 Note_Possible_Modification (Arg_Internal); 2158 end if; 2159 end if; 2160 end Process_Extended_Import_Export_Object_Pragma; 2161 2162 ------------------------------------------------------ 2163 -- Process_Extended_Import_Export_Subprogram_Pragma -- 2164 ------------------------------------------------------ 2165 2166 procedure Process_Extended_Import_Export_Subprogram_Pragma 2167 (Arg_Internal : Node_Id; 2168 Arg_External : Node_Id; 2169 Arg_Parameter_Types : Node_Id; 2170 Arg_Result_Type : Node_Id := Empty; 2171 Arg_Mechanism : Node_Id; 2172 Arg_Result_Mechanism : Node_Id := Empty; 2173 Arg_First_Optional_Parameter : Node_Id := Empty) 2174 is 2175 Ent : Entity_Id; 2176 Def_Id : Entity_Id; 2177 Hom_Id : Entity_Id; 2178 Formal : Entity_Id; 2179 Ambiguous : Boolean; 2180 Match : Boolean; 2181 Dval : Node_Id; 2182 2183 function Same_Base_Type 2184 (Ptype : Node_Id; 2185 Formal : Entity_Id) return Boolean; 2186 -- Determines if Ptype references the type of Formal. Note that 2187 -- only the base types need to match according to the spec. Ptype 2188 -- here is the argument from the pragma, which is either a type 2189 -- name, or an access attribute. 2190 2191 -------------------- 2192 -- Same_Base_Type -- 2193 -------------------- 2194 2195 function Same_Base_Type 2196 (Ptype : Node_Id; 2197 Formal : Entity_Id) return Boolean 2198 is 2199 Ftyp : constant Entity_Id := Base_Type (Etype (Formal)); 2200 Pref : Node_Id; 2201 2202 begin 2203 -- Case where pragma argument is typ'Access 2204 2205 if Nkind (Ptype) = N_Attribute_Reference 2206 and then Attribute_Name (Ptype) = Name_Access 2207 then 2208 Pref := Prefix (Ptype); 2209 Find_Type (Pref); 2210 2211 if not Is_Entity_Name (Pref) 2212 or else Entity (Pref) = Any_Type 2213 then 2214 raise Pragma_Exit; 2215 end if; 2216 2217 -- We have a match if the corresponding argument is of an 2218 -- anonymous access type, and its designicated type matches 2219 -- the type of the prefix of the access attribute 2220 2221 return Ekind (Ftyp) = E_Anonymous_Access_Type 2222 and then Base_Type (Entity (Pref)) = 2223 Base_Type (Etype (Designated_Type (Ftyp))); 2224 2225 -- Case where pragma argument is a type name 2226 2227 else 2228 Find_Type (Ptype); 2229 2230 if not Is_Entity_Name (Ptype) 2231 or else Entity (Ptype) = Any_Type 2232 then 2233 raise Pragma_Exit; 2234 end if; 2235 2236 -- We have a match if the corresponding argument is of 2237 -- the type given in the pragma (comparing base types) 2238 2239 return Base_Type (Entity (Ptype)) = Ftyp; 2240 end if; 2241 end Same_Base_Type; 2242 2243 -- Start of processing for 2244 -- Process_Extended_Import_Export_Subprogram_Pragma 2245 2246 begin 2247 Process_Extended_Import_Export_Internal_Arg (Arg_Internal); 2248 Hom_Id := Entity (Arg_Internal); 2249 Ent := Empty; 2250 Ambiguous := False; 2251 2252 -- Loop through homonyms (overloadings) of Hom_Id 2253 2254 while Present (Hom_Id) loop 2255 Def_Id := Get_Base_Subprogram (Hom_Id); 2256 2257 -- We need a subprogram in the current scope 2258 2259 if not Is_Subprogram (Def_Id) 2260 or else Scope (Def_Id) /= Current_Scope 2261 then 2262 null; 2263 2264 else 2265 Match := True; 2266 2267 -- Pragma cannot apply to subprogram body 2268 2269 if Is_Subprogram (Def_Id) 2270 and then 2271 Nkind (Parent 2272 (Declaration_Node (Def_Id))) = N_Subprogram_Body 2273 then 2274 Error_Pragma 2275 ("pragma% requires separate spec" 2276 & " and must come before body"); 2277 end if; 2278 2279 -- Test result type if given, note that the result type 2280 -- parameter can only be present for the function cases. 2281 2282 if Present (Arg_Result_Type) 2283 and then not Same_Base_Type (Arg_Result_Type, Def_Id) 2284 then 2285 Match := False; 2286 2287 elsif Etype (Def_Id) /= Standard_Void_Type 2288 and then 2289 (Chars (N) = Name_Export_Procedure 2290 or else Chars (N) = Name_Import_Procedure) 2291 then 2292 Match := False; 2293 2294 -- Test parameter types if given. Note that this parameter 2295 -- has not been analyzed (and must not be, since it is 2296 -- semantic nonsense), so we get it as the parser left it. 2297 2298 elsif Present (Arg_Parameter_Types) then 2299 Check_Matching_Types : declare 2300 Formal : Entity_Id; 2301 Ptype : Node_Id; 2302 2303 begin 2304 Formal := First_Formal (Def_Id); 2305 2306 if Nkind (Arg_Parameter_Types) = N_Null then 2307 if Present (Formal) then 2308 Match := False; 2309 end if; 2310 2311 -- A list of one type, e.g. (List) is parsed as 2312 -- a parenthesized expression. 2313 2314 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate 2315 and then Paren_Count (Arg_Parameter_Types) = 1 2316 then 2317 if No (Formal) 2318 or else Present (Next_Formal (Formal)) 2319 then 2320 Match := False; 2321 else 2322 Match := 2323 Same_Base_Type (Arg_Parameter_Types, Formal); 2324 end if; 2325 2326 -- A list of more than one type is parsed as a aggregate 2327 2328 elsif Nkind (Arg_Parameter_Types) = N_Aggregate 2329 and then Paren_Count (Arg_Parameter_Types) = 0 2330 then 2331 Ptype := First (Expressions (Arg_Parameter_Types)); 2332 2333 while Present (Ptype) or else Present (Formal) loop 2334 if No (Ptype) 2335 or else No (Formal) 2336 or else not Same_Base_Type (Ptype, Formal) 2337 then 2338 Match := False; 2339 exit; 2340 else 2341 Next_Formal (Formal); 2342 Next (Ptype); 2343 end if; 2344 end loop; 2345 2346 -- Anything else is of the wrong form 2347 2348 else 2349 Error_Pragma_Arg 2350 ("wrong form for Parameter_Types parameter", 2351 Arg_Parameter_Types); 2352 end if; 2353 end Check_Matching_Types; 2354 end if; 2355 2356 -- Match is now False if the entry we found did not match 2357 -- either a supplied Parameter_Types or Result_Types argument 2358 2359 if Match then 2360 if No (Ent) then 2361 Ent := Def_Id; 2362 2363 -- Ambiguous case, the flag Ambiguous shows if we already 2364 -- detected this and output the initial messages. 2365 2366 else 2367 if not Ambiguous then 2368 Ambiguous := True; 2369 Error_Msg_Name_1 := Chars (N); 2370 Error_Msg_N 2371 ("pragma% does not uniquely identify subprogram!", 2372 N); 2373 Error_Msg_Sloc := Sloc (Ent); 2374 Error_Msg_N ("matching subprogram #!", N); 2375 Ent := Empty; 2376 end if; 2377 2378 Error_Msg_Sloc := Sloc (Def_Id); 2379 Error_Msg_N ("matching subprogram #!", N); 2380 end if; 2381 end if; 2382 end if; 2383 2384 Hom_Id := Homonym (Hom_Id); 2385 end loop; 2386 2387 -- See if we found an entry 2388 2389 if No (Ent) then 2390 if not Ambiguous then 2391 if Is_Generic_Subprogram (Entity (Arg_Internal)) then 2392 Error_Pragma 2393 ("pragma% cannot be given for generic subprogram"); 2394 2395 else 2396 Error_Pragma 2397 ("pragma% does not identify local subprogram"); 2398 end if; 2399 end if; 2400 2401 return; 2402 end if; 2403 2404 -- Import pragmas must be be for imported entities 2405 2406 if Prag_Id = Pragma_Import_Function 2407 or else 2408 Prag_Id = Pragma_Import_Procedure 2409 or else 2410 Prag_Id = Pragma_Import_Valued_Procedure 2411 then 2412 if not Is_Imported (Ent) then 2413 Error_Pragma 2414 ("pragma Import or Interface must precede pragma%"); 2415 end if; 2416 2417 -- Here we have the Export case which can set the entity as exported 2418 2419 -- But does not do so if the specified external name is null, 2420 -- since that is taken as a signal in DEC Ada 83 (with which 2421 -- we want to be compatible) to request no external name. 2422 2423 elsif Nkind (Arg_External) = N_String_Literal 2424 and then String_Length (Strval (Arg_External)) = 0 2425 then 2426 null; 2427 2428 -- In all other cases, set entit as exported 2429 2430 else 2431 Set_Exported (Ent, Arg_Internal); 2432 end if; 2433 2434 -- Special processing for Valued_Procedure cases 2435 2436 if Prag_Id = Pragma_Import_Valued_Procedure 2437 or else 2438 Prag_Id = Pragma_Export_Valued_Procedure 2439 then 2440 Formal := First_Formal (Ent); 2441 2442 if No (Formal) then 2443 Error_Pragma 2444 ("at least one parameter required for pragma%"); 2445 2446 elsif Ekind (Formal) /= E_Out_Parameter then 2447 Error_Pragma 2448 ("first parameter must have mode out for pragma%"); 2449 2450 else 2451 Set_Is_Valued_Procedure (Ent); 2452 end if; 2453 end if; 2454 2455 Set_Extended_Import_Export_External_Name (Ent, Arg_External); 2456 2457 -- Process Result_Mechanism argument if present. We have already 2458 -- checked that this is only allowed for the function case. 2459 2460 if Present (Arg_Result_Mechanism) then 2461 Set_Mechanism_Value (Ent, Arg_Result_Mechanism); 2462 end if; 2463 2464 -- Process Mechanism parameter if present. Note that this parameter 2465 -- is not analyzed, and must not be analyzed since it is semantic 2466 -- nonsense, so we get it in exactly as the parser left it. 2467 2468 if Present (Arg_Mechanism) then 2469 declare 2470 Formal : Entity_Id; 2471 Massoc : Node_Id; 2472 Mname : Node_Id; 2473 Choice : Node_Id; 2474 2475 begin 2476 -- A single mechanism association without a formal parameter 2477 -- name is parsed as a parenthesized expression. All other 2478 -- cases are parsed as aggregates, so we rewrite the single 2479 -- parameter case as an aggregate for consistency. 2480 2481 if Nkind (Arg_Mechanism) /= N_Aggregate 2482 and then Paren_Count (Arg_Mechanism) = 1 2483 then 2484 Rewrite (Arg_Mechanism, 2485 Make_Aggregate (Sloc (Arg_Mechanism), 2486 Expressions => New_List ( 2487 Relocate_Node (Arg_Mechanism)))); 2488 end if; 2489 2490 -- Case of only mechanism name given, applies to all formals 2491 2492 if Nkind (Arg_Mechanism) /= N_Aggregate then 2493 Formal := First_Formal (Ent); 2494 while Present (Formal) loop 2495 Set_Mechanism_Value (Formal, Arg_Mechanism); 2496 Next_Formal (Formal); 2497 end loop; 2498 2499 -- Case of list of mechanism associations given 2500 2501 else 2502 if Null_Record_Present (Arg_Mechanism) then 2503 Error_Pragma_Arg 2504 ("inappropriate form for Mechanism parameter", 2505 Arg_Mechanism); 2506 end if; 2507 2508 -- Deal with positional ones first 2509 2510 Formal := First_Formal (Ent); 2511 if Present (Expressions (Arg_Mechanism)) then 2512 Mname := First (Expressions (Arg_Mechanism)); 2513 2514 while Present (Mname) loop 2515 if No (Formal) then 2516 Error_Pragma_Arg 2517 ("too many mechanism associations", Mname); 2518 end if; 2519 2520 Set_Mechanism_Value (Formal, Mname); 2521 Next_Formal (Formal); 2522 Next (Mname); 2523 end loop; 2524 end if; 2525 2526 -- Deal with named entries 2527 2528 if Present (Component_Associations (Arg_Mechanism)) then 2529 Massoc := First (Component_Associations (Arg_Mechanism)); 2530 2531 while Present (Massoc) loop 2532 Choice := First (Choices (Massoc)); 2533 2534 if Nkind (Choice) /= N_Identifier 2535 or else Present (Next (Choice)) 2536 then 2537 Error_Pragma_Arg 2538 ("incorrect form for mechanism association", 2539 Massoc); 2540 end if; 2541 2542 Formal := First_Formal (Ent); 2543 loop 2544 if No (Formal) then 2545 Error_Pragma_Arg 2546 ("parameter name & not present", Choice); 2547 end if; 2548 2549 if Chars (Choice) = Chars (Formal) then 2550 Set_Mechanism_Value 2551 (Formal, Expression (Massoc)); 2552 exit; 2553 end if; 2554 2555 Next_Formal (Formal); 2556 end loop; 2557 2558 Next (Massoc); 2559 end loop; 2560 end if; 2561 end if; 2562 end; 2563 end if; 2564 2565 -- Process First_Optional_Parameter argument if present. We have 2566 -- already checked that this is only allowed for the Import case. 2567 2568 if Present (Arg_First_Optional_Parameter) then 2569 if Nkind (Arg_First_Optional_Parameter) /= N_Identifier then 2570 Error_Pragma_Arg 2571 ("first optional parameter must be formal parameter name", 2572 Arg_First_Optional_Parameter); 2573 end if; 2574 2575 Formal := First_Formal (Ent); 2576 loop 2577 if No (Formal) then 2578 Error_Pragma_Arg 2579 ("specified formal parameter& not found", 2580 Arg_First_Optional_Parameter); 2581 end if; 2582 2583 exit when Chars (Formal) = 2584 Chars (Arg_First_Optional_Parameter); 2585 2586 Next_Formal (Formal); 2587 end loop; 2588 2589 Set_First_Optional_Parameter (Ent, Formal); 2590 2591 -- Check specified and all remaining formals have right form 2592 2593 while Present (Formal) loop 2594 if Ekind (Formal) /= E_In_Parameter then 2595 Error_Msg_NE 2596 ("optional formal& is not of mode in!", 2597 Arg_First_Optional_Parameter, Formal); 2598 2599 else 2600 Dval := Default_Value (Formal); 2601 2602 if not Present (Dval) then 2603 Error_Msg_NE 2604 ("optional formal& does not have default value!", 2605 Arg_First_Optional_Parameter, Formal); 2606 2607 elsif Compile_Time_Known_Value_Or_Aggr (Dval) then 2608 null; 2609 2610 else 2611 Error_Msg_FE 2612 ("default value for optional formal& is non-static!", 2613 Arg_First_Optional_Parameter, Formal); 2614 end if; 2615 end if; 2616 2617 Set_Is_Optional_Parameter (Formal); 2618 Next_Formal (Formal); 2619 end loop; 2620 end if; 2621 end Process_Extended_Import_Export_Subprogram_Pragma; 2622 2623 -------------------------- 2624 -- Process_Generic_List -- 2625 -------------------------- 2626 2627 procedure Process_Generic_List is 2628 Arg : Node_Id; 2629 Exp : Node_Id; 2630 2631 begin 2632 GNAT_Pragma; 2633 Check_No_Identifiers; 2634 Check_At_Least_N_Arguments (1); 2635 2636 Arg := Arg1; 2637 while Present (Arg) loop 2638 Exp := Expression (Arg); 2639 Analyze (Exp); 2640 2641 if not Is_Entity_Name (Exp) 2642 or else 2643 (not Is_Generic_Instance (Entity (Exp)) 2644 and then 2645 not Is_Generic_Unit (Entity (Exp))) 2646 then 2647 Error_Pragma_Arg 2648 ("pragma% argument must be name of generic unit/instance", 2649 Arg); 2650 end if; 2651 2652 Next (Arg); 2653 end loop; 2654 end Process_Generic_List; 2655 2656 --------------------------------- 2657 -- Process_Import_Or_Interface -- 2658 --------------------------------- 2659 2660 procedure Process_Import_Or_Interface is 2661 C : Convention_Id; 2662 Def_Id : Entity_Id; 2663 Hom_Id : Entity_Id; 2664 2665 begin 2666 Process_Convention (C, Def_Id); 2667 Kill_Size_Check_Code (Def_Id); 2668 Note_Possible_Modification (Expression (Arg2)); 2669 2670 if Ekind (Def_Id) = E_Variable 2671 or else 2672 Ekind (Def_Id) = E_Constant 2673 then 2674 -- User initialization is not allowed for imported object, but 2675 -- the object declaration may contain a default initialization, 2676 -- that will be discarded. Note that an explicit initialization 2677 -- only counts if it comes from source, otherwise it is simply 2678 -- the code generator making an implicit initialization explicit. 2679 2680 if Present (Expression (Parent (Def_Id))) 2681 and then Comes_From_Source (Expression (Parent (Def_Id))) 2682 then 2683 Error_Msg_Sloc := Sloc (Def_Id); 2684 Error_Pragma_Arg 2685 ("no initialization allowed for declaration of& #", 2686 "\imported entities cannot be initialized ('R'M' 'B.1(24))", 2687 Arg2); 2688 2689 else 2690 Set_Imported (Def_Id); 2691 Set_Is_Public (Def_Id); 2692 Process_Interface_Name (Def_Id, Arg3, Arg4); 2693 2694 -- It is not possible to import a constant of an unconstrained 2695 -- array type (e.g. string) because there is no simple way to 2696 -- write a meaningful subtype for it. 2697 2698 if Is_Array_Type (Etype (Def_Id)) 2699 and then not Is_Constrained (Etype (Def_Id)) 2700 then 2701 Error_Msg_NE 2702 ("imported constant& must have a constrained subtype", 2703 N, Def_Id); 2704 end if; 2705 end if; 2706 2707 elsif Is_Subprogram (Def_Id) 2708 or else Is_Generic_Subprogram (Def_Id) 2709 then 2710 -- If the name is overloaded, pragma applies to all of the 2711 -- denoted entities in the same declarative part. 2712 2713 Hom_Id := Def_Id; 2714 2715 while Present (Hom_Id) loop 2716 Def_Id := Get_Base_Subprogram (Hom_Id); 2717 2718 -- Ignore inherited subprograms because the pragma will 2719 -- apply to the parent operation, which is the one called. 2720 2721 if Is_Overloadable (Def_Id) 2722 and then Present (Alias (Def_Id)) 2723 then 2724 null; 2725 2726 -- If it is not a subprogram, it must be in an outer 2727 -- scope and pragma does not apply. 2728 2729 elsif not Is_Subprogram (Def_Id) 2730 and then not Is_Generic_Subprogram (Def_Id) 2731 then 2732 null; 2733 2734 -- Verify that the homonym is in the same declarative 2735 -- part (not just the same scope). 2736 2737 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N) 2738 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux 2739 then 2740 exit; 2741 2742 else 2743 Set_Imported (Def_Id); 2744 2745 -- If Import intrinsic, set intrinsic flag 2746 -- and verify that it is known as such. 2747 2748 if C = Convention_Intrinsic then 2749 Set_Is_Intrinsic_Subprogram (Def_Id); 2750 Check_Intrinsic_Subprogram 2751 (Def_Id, Expression (Arg2)); 2752 end if; 2753 2754 -- All interfaced procedures need an external 2755 -- symbol created for them since they are 2756 -- always referenced from another object file. 2757 2758 Set_Is_Public (Def_Id); 2759 2760 -- Verify that the subprogram does not have a completion 2761 -- through a renaming declaration. For other completions 2762 -- the pragma appears as a too late representation. 2763 2764 declare 2765 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id); 2766 2767 begin 2768 if Present (Decl) 2769 and then Nkind (Decl) = N_Subprogram_Declaration 2770 and then Present (Corresponding_Body (Decl)) 2771 and then 2772 Nkind 2773 (Unit_Declaration_Node 2774 (Corresponding_Body (Decl))) = 2775 N_Subprogram_Renaming_Declaration 2776 then 2777 Error_Msg_Sloc := Sloc (Def_Id); 2778 Error_Msg_NE ("cannot import&#," & 2779 " already completed by a renaming", 2780 N, Def_Id); 2781 end if; 2782 end; 2783 2784 Set_Has_Completion (Def_Id); 2785 Process_Interface_Name (Def_Id, Arg3, Arg4); 2786 end if; 2787 2788 if Is_Compilation_Unit (Hom_Id) then 2789 2790 -- Its possible homonyms are not affected by the pragma. 2791 -- Such homonyms might be present in the context of other 2792 -- units being compiled. 2793 2794 exit; 2795 2796 else 2797 Hom_Id := Homonym (Hom_Id); 2798 end if; 2799 end loop; 2800 2801 -- When the convention is Java, we also allow Import to be given 2802 -- for packages, exceptions, and record components. 2803 2804 elsif C = Convention_Java 2805 and then (Ekind (Def_Id) = E_Package 2806 or else Ekind (Def_Id) = E_Exception 2807 or else Nkind (Parent (Def_Id)) = N_Component_Declaration) 2808 then 2809 Set_Imported (Def_Id); 2810 Set_Is_Public (Def_Id); 2811 Process_Interface_Name (Def_Id, Arg3, Arg4); 2812 2813 else 2814 Error_Pragma_Arg 2815 ("second argument of pragma% must be object or subprogram", 2816 Arg2); 2817 end if; 2818 2819 -- If this pragma applies to a compilation unit, then the unit, 2820 -- which is a subprogram, does not require (or allow) a body. 2821 -- We also do not need to elaborate imported procedures. 2822 2823 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then 2824 declare 2825 Cunit : constant Node_Id := Parent (Parent (N)); 2826 begin 2827 Set_Body_Required (Cunit, False); 2828 end; 2829 end if; 2830 end Process_Import_Or_Interface; 2831 2832 -------------------- 2833 -- Process_Inline -- 2834 -------------------- 2835 2836 procedure Process_Inline (Active : Boolean) is 2837 Assoc : Node_Id; 2838 Decl : Node_Id; 2839 Subp_Id : Node_Id; 2840 Subp : Entity_Id; 2841 Applies : Boolean; 2842 2843 procedure Make_Inline (Subp : Entity_Id); 2844 -- Subp is the defining unit name of the subprogram 2845 -- declaration. Set the flag, as well as the flag in the 2846 -- corresponding body, if there is one present. 2847 2848 procedure Set_Inline_Flags (Subp : Entity_Id); 2849 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp 2850 2851 function Back_End_Cannot_Inline (Subp : Entity_Id) return Boolean; 2852 -- Do not set the inline flag if body is available and contains 2853 -- exception handlers, to prevent undefined symbols at link time. 2854 2855 ---------------------------- 2856 -- Back_End_Cannot_Inline -- 2857 ---------------------------- 2858 2859 function Back_End_Cannot_Inline (Subp : Entity_Id) return Boolean is 2860 Decl : constant Node_Id := Unit_Declaration_Node (Subp); 2861 2862 begin 2863 if Nkind (Decl) = N_Subprogram_Body then 2864 return 2865 Present 2866 (Exception_Handlers (Handled_Statement_Sequence (Decl))); 2867 2868 elsif Nkind (Decl) = N_Subprogram_Declaration 2869 and then Present (Corresponding_Body (Decl)) 2870 then 2871 -- If the subprogram is a renaming as body, the body is 2872 -- just a call to the renamed subprogram, and inlining is 2873 -- trivially possible. 2874 2875 if Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) = 2876 N_Subprogram_Renaming_Declaration 2877 then 2878 return False; 2879 2880 else 2881 return 2882 Present (Exception_Handlers 2883 (Handled_Statement_Sequence 2884 (Unit_Declaration_Node (Corresponding_Body (Decl))))); 2885 end if; 2886 else 2887 -- If body is not available, assume the best, the check is 2888 -- performed again when compiling enclosing package bodies. 2889 2890 return False; 2891 end if; 2892 end Back_End_Cannot_Inline; 2893 2894 ----------------- 2895 -- Make_Inline -- 2896 ----------------- 2897 2898 procedure Make_Inline (Subp : Entity_Id) is 2899 Kind : constant Entity_Kind := Ekind (Subp); 2900 Inner_Subp : Entity_Id := Subp; 2901 2902 begin 2903 if Etype (Subp) = Any_Type then 2904 return; 2905 2906 elsif Back_End_Cannot_Inline (Subp) then 2907 Applies := True; -- Do not treat as an error. 2908 return; 2909 2910 -- Here we have a candidate for inlining, but we must exclude 2911 -- derived operations. Otherwise we will end up trying to 2912 -- inline a phantom declaration, and the result would be to 2913 -- drag in a body which has no direct inlining associated with 2914 -- it. That would not only be inefficient but would also result 2915 -- in the backend doing cross-unit inlining in cases where it 2916 -- was definitely inappropriate to do so. 2917 2918 -- However, a simple Comes_From_Source test is insufficient, 2919 -- since we do want to allow inlining of generic instances, 2920 -- which also do not come from source. Predefined operators do 2921 -- not come from source but are not inlineable either. 2922 2923 elsif not Comes_From_Source (Subp) 2924 and then not Is_Generic_Instance (Subp) 2925 and then Scope (Subp) /= Standard_Standard 2926 then 2927 Applies := True; 2928 return; 2929 2930 -- The referenced entity must either be the enclosing entity, 2931 -- or an entity declared within the current open scope. 2932 2933 elsif Present (Scope (Subp)) 2934 and then Scope (Subp) /= Current_Scope 2935 and then Subp /= Current_Scope 2936 then 2937 Error_Pragma_Arg 2938 ("argument of% must be entity in current scope", Assoc); 2939 return; 2940 end if; 2941 2942 -- Processing for procedure, operator or function. 2943 -- If subprogram is aliased (as for an instance) indicate 2944 -- that the renamed entity is inlined. 2945 2946 if Is_Subprogram (Subp) then 2947 while Present (Alias (Inner_Subp)) loop 2948 Inner_Subp := Alias (Inner_Subp); 2949 end loop; 2950 2951 Set_Inline_Flags (Inner_Subp); 2952 2953 Decl := Parent (Parent (Inner_Subp)); 2954 2955 if Nkind (Decl) = N_Subprogram_Declaration 2956 and then Present (Corresponding_Body (Decl)) 2957 then 2958 Set_Inline_Flags (Corresponding_Body (Decl)); 2959 end if; 2960 2961 Applies := True; 2962 2963 -- For a generic subprogram set flag as well, for use at 2964 -- the point of instantiation, to determine whether the 2965 -- body should be generated. 2966 2967 elsif Is_Generic_Subprogram (Subp) then 2968 Set_Inline_Flags (Subp); 2969 Applies := True; 2970 2971 -- Literals are by definition inlined 2972 2973 elsif Kind = E_Enumeration_Literal then 2974 null; 2975 2976 -- Anything else is an error 2977 2978 else 2979 Error_Pragma_Arg 2980 ("expect subprogram name for pragma%", Assoc); 2981 end if; 2982 end Make_Inline; 2983 2984 ---------------------- 2985 -- Set_Inline_Flags -- 2986 ---------------------- 2987 2988 procedure Set_Inline_Flags (Subp : Entity_Id) is 2989 begin 2990 if Active then 2991 Set_Is_Inlined (Subp, True); 2992 end if; 2993 2994 if not Has_Pragma_Inline (Subp) then 2995 Set_Has_Pragma_Inline (Subp); 2996 Set_Next_Rep_Item (N, First_Rep_Item (Subp)); 2997 Set_First_Rep_Item (Subp, N); 2998 end if; 2999 end Set_Inline_Flags; 3000 3001 -- Start of processing for Process_Inline 3002 3003 begin 3004 Check_No_Identifiers; 3005 Check_At_Least_N_Arguments (1); 3006 3007 if Active then 3008 Inline_Processing_Required := True; 3009 end if; 3010 3011 Assoc := Arg1; 3012 while Present (Assoc) loop 3013 Subp_Id := Expression (Assoc); 3014 Analyze (Subp_Id); 3015 Applies := False; 3016 3017 if Is_Entity_Name (Subp_Id) then 3018 Subp := Entity (Subp_Id); 3019 3020 if Subp = Any_Id then 3021 Applies := True; 3022 3023 else 3024 Make_Inline (Subp); 3025 3026 while Present (Homonym (Subp)) 3027 and then Scope (Homonym (Subp)) = Current_Scope 3028 loop 3029 Make_Inline (Homonym (Subp)); 3030 Subp := Homonym (Subp); 3031 end loop; 3032 end if; 3033 end if; 3034 3035 if not Applies then 3036 Error_Pragma_Arg 3037 ("inappropriate argument for pragma%", Assoc); 3038 end if; 3039 3040 Next (Assoc); 3041 end loop; 3042 end Process_Inline; 3043 3044 ---------------------------- 3045 -- Process_Interface_Name -- 3046 ---------------------------- 3047 3048 procedure Process_Interface_Name 3049 (Subprogram_Def : Entity_Id; 3050 Ext_Arg : Node_Id; 3051 Link_Arg : Node_Id) 3052 is 3053 Ext_Nam : Node_Id; 3054 Link_Nam : Node_Id; 3055 String_Val : String_Id; 3056 3057 procedure Check_Form_Of_Interface_Name (SN : Node_Id); 3058 -- SN is a string literal node for an interface name. This routine 3059 -- performs some minimal checks that the name is reasonable. In 3060 -- particular that no spaces or other obviously incorrect characters 3061 -- appear. This is only a warning, since any characters are allowed. 3062 3063 procedure Check_Form_Of_Interface_Name (SN : Node_Id) is 3064 S : constant String_Id := Strval (Expr_Value_S (SN)); 3065 SL : constant Nat := String_Length (S); 3066 C : Char_Code; 3067 3068 begin 3069 if SL = 0 then 3070 Error_Msg_N ("interface name cannot be null string", SN); 3071 end if; 3072 3073 for J in 1 .. SL loop 3074 C := Get_String_Char (S, J); 3075 3076 if Warn_On_Export_Import 3077 and then (not In_Character_Range (C) 3078 or else Get_Character (C) = ' ' 3079 or else Get_Character (C) = ',') 3080 then 3081 Error_Msg_N 3082 ("?interface name contains illegal character", SN); 3083 end if; 3084 end loop; 3085 end Check_Form_Of_Interface_Name; 3086 3087 -- Start of processing for Process_Interface_Name 3088 3089 begin 3090 if No (Link_Arg) then 3091 if No (Ext_Arg) then 3092 return; 3093 3094 elsif Chars (Ext_Arg) = Name_Link_Name then 3095 Ext_Nam := Empty; 3096 Link_Nam := Expression (Ext_Arg); 3097 3098 else 3099 Check_Optional_Identifier (Ext_Arg, Name_External_Name); 3100 Ext_Nam := Expression (Ext_Arg); 3101 Link_Nam := Empty; 3102 end if; 3103 3104 else 3105 Check_Optional_Identifier (Ext_Arg, Name_External_Name); 3106 Check_Optional_Identifier (Link_Arg, Name_Link_Name); 3107 Ext_Nam := Expression (Ext_Arg); 3108 Link_Nam := Expression (Link_Arg); 3109 end if; 3110 3111 -- Check expressions for external name and link name are static 3112 3113 if Present (Ext_Nam) then 3114 Check_Arg_Is_Static_Expression (Ext_Nam, Standard_String); 3115 Check_Form_Of_Interface_Name (Ext_Nam); 3116 3117 -- Verify that the external name is not the name of a local 3118 -- entity, which would hide the imported one and lead to 3119 -- run-time surprises. The problem can only arise for entities 3120 -- declared in a package body (otherwise the external name is 3121 -- fully qualified and won't conflict). 3122 3123 declare 3124 Nam : Name_Id; 3125 E : Entity_Id; 3126 Par : Node_Id; 3127 3128 begin 3129 if Prag_Id = Pragma_Import then 3130 String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam))); 3131 Nam := Name_Find; 3132 E := Entity_Id (Get_Name_Table_Info (Nam)); 3133 3134 if Nam /= Chars (Subprogram_Def) 3135 and then Present (E) 3136 and then not Is_Overloadable (E) 3137 and then Is_Immediately_Visible (E) 3138 and then not Is_Imported (E) 3139 and then Ekind (Scope (E)) = E_Package 3140 then 3141 Par := Parent (E); 3142 3143 while Present (Par) loop 3144 if Nkind (Par) = N_Package_Body then 3145 Error_Msg_Sloc := Sloc (E); 3146 Error_Msg_NE 3147 ("imported entity is hidden by & declared#", 3148 Ext_Arg, E); 3149 exit; 3150 end if; 3151 3152 Par := Parent (Par); 3153 end loop; 3154 end if; 3155 end if; 3156 end; 3157 end if; 3158 3159 if Present (Link_Nam) then 3160 Check_Arg_Is_Static_Expression (Link_Nam, Standard_String); 3161 Check_Form_Of_Interface_Name (Link_Nam); 3162 end if; 3163 3164 -- If there is no link name, just set the external name 3165 3166 if No (Link_Nam) then 3167 Set_Encoded_Interface_Name 3168 (Get_Base_Subprogram (Subprogram_Def), 3169 Adjust_External_Name_Case (Expr_Value_S (Ext_Nam))); 3170 3171 -- For the Link_Name case, the given literal is preceded by an 3172 -- asterisk, which indicates to GCC that the given name should 3173 -- be taken literally, and in particular that no prepending of 3174 -- underlines should occur, even in systems where this is the 3175 -- normal default. 3176 3177 else 3178 Start_String; 3179 Store_String_Char (Get_Char_Code ('*')); 3180 String_Val := Strval (Expr_Value_S (Link_Nam)); 3181 3182 for J in 1 .. String_Length (String_Val) loop 3183 Store_String_Char (Get_String_Char (String_Val, J)); 3184 end loop; 3185 3186 Link_Nam := 3187 Make_String_Literal (Sloc (Link_Nam), End_String); 3188 3189 Set_Encoded_Interface_Name 3190 (Get_Base_Subprogram (Subprogram_Def), Link_Nam); 3191 end if; 3192 end Process_Interface_Name; 3193 3194 ----------------------------------------- 3195 -- Process_Interrupt_Or_Attach_Handler -- 3196 ----------------------------------------- 3197 3198 procedure Process_Interrupt_Or_Attach_Handler is 3199 Arg1_X : constant Node_Id := Expression (Arg1); 3200 Handler_Proc : constant Entity_Id := Entity (Arg1_X); 3201 Proc_Scope : constant Entity_Id := Scope (Handler_Proc); 3202 3203 begin 3204 Set_Is_Interrupt_Handler (Handler_Proc); 3205 3206 -- If the pragma is not associated with a handler procedure 3207 -- within a protected type, then it must be for a nonprotected 3208 -- procedure for the AAMP target, in which case we don't 3209 -- associate a representation item with the procedure's scope. 3210 3211 if Ekind (Proc_Scope) = E_Protected_Type then 3212 if Prag_Id = Pragma_Interrupt_Handler 3213 or Prag_Id = Pragma_Attach_Handler 3214 then 3215 Record_Rep_Item (Proc_Scope, N); 3216 end if; 3217 end if; 3218 end Process_Interrupt_Or_Attach_Handler; 3219 3220 --------------------------------- 3221 -- Process_Suppress_Unsuppress -- 3222 --------------------------------- 3223 3224 -- Note: this procedure makes entries in the check suppress data 3225 -- structures managed by Sem. See spec of package Sem for full 3226 -- details on how we handle recording of check suppression. 3227 3228 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is 3229 C : Check_Id; 3230 E_Id : Node_Id; 3231 E : Entity_Id; 3232 3233 In_Package_Spec : constant Boolean := 3234 (Ekind (Current_Scope) = E_Package 3235 or else 3236 Ekind (Current_Scope) = E_Generic_Package) 3237 and then not In_Package_Body (Current_Scope); 3238 3239 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id); 3240 -- Used to suppress a single check on the given entity 3241 3242 -------------------------------- 3243 -- Suppress_Unsuppress_Echeck -- 3244 -------------------------------- 3245 3246 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is 3247 ESR : constant Entity_Check_Suppress_Record := 3248 (Entity => E, 3249 Check => C, 3250 Suppress => Suppress_Case); 3251 3252 begin 3253 Set_Checks_May_Be_Suppressed (E); 3254 3255 if In_Package_Spec then 3256 Global_Entity_Suppress.Append (ESR); 3257 else 3258 Local_Entity_Suppress.Append (ESR); 3259 end if; 3260 3261 -- If this is a first subtype, and the base type is distinct, 3262 -- then also set the suppress flags on the base type. 3263 3264 if Is_First_Subtype (E) 3265 and then Etype (E) /= E 3266 then 3267 Suppress_Unsuppress_Echeck (Etype (E), C); 3268 end if; 3269 end Suppress_Unsuppress_Echeck; 3270 3271 -- Start of processing for Process_Suppress_Unsuppress 3272 3273 begin 3274 -- Suppress/Unsuppress can appear as a configuration pragma, 3275 -- or in a declarative part or a package spec (RM 11.5(5)) 3276 3277 if not Is_Configuration_Pragma then 3278 Check_Is_In_Decl_Part_Or_Package_Spec; 3279 end if; 3280 3281 Check_At_Least_N_Arguments (1); 3282 Check_At_Most_N_Arguments (2); 3283 Check_No_Identifier (Arg1); 3284 Check_Arg_Is_Identifier (Arg1); 3285 3286 if not Is_Check_Name (Chars (Expression (Arg1))) then 3287 Error_Pragma_Arg 3288 ("argument of pragma% is not valid check name", Arg1); 3289 3290 else 3291 C := Get_Check_Id (Chars (Expression (Arg1))); 3292 end if; 3293 3294 if Arg_Count = 1 then 3295 3296 -- Make an entry in the local scope suppress table. This is the 3297 -- table that directly shows the current value of the scope 3298 -- suppress check for any check id value. 3299 3300 if C = All_Checks then 3301 for J in Scope_Suppress'Range loop 3302 Scope_Suppress (J) := Suppress_Case; 3303 end loop; 3304 else 3305 Scope_Suppress (C) := Suppress_Case; 3306 end if; 3307 3308 -- Also make an entry in the Local_Entity_Suppress table. See 3309 -- extended description in the package spec of Sem for details. 3310 3311 Local_Entity_Suppress.Append 3312 ((Entity => Empty, 3313 Check => C, 3314 Suppress => Suppress_Case)); 3315 3316 -- Case of two arguments present, where the check is 3317 -- suppressed for a specified entity (given as the second 3318 -- argument of the pragma) 3319 3320 else 3321 Check_Optional_Identifier (Arg2, Name_On); 3322 E_Id := Expression (Arg2); 3323 Analyze (E_Id); 3324 3325 if not Is_Entity_Name (E_Id) then 3326 Error_Pragma_Arg 3327 ("second argument of pragma% must be entity name", Arg2); 3328 end if; 3329 3330 E := Entity (E_Id); 3331 3332 if E = Any_Id then 3333 return; 3334 end if; 3335 3336 -- Enforce RM 11.5(7) which requires that for a pragma that 3337 -- appears within a package spec, the named entity must be 3338 -- within the package spec. We allow the package name itself 3339 -- to be mentioned since that makes sense, although it is not 3340 -- strictly allowed by 11.5(7). 3341 3342 if In_Package_Spec 3343 and then E /= Current_Scope 3344 and then Scope (E) /= Current_Scope 3345 then 3346 Error_Pragma_Arg 3347 ("entity in pragma% is not in package spec ('R'M 11.5(7))", 3348 Arg2); 3349 end if; 3350 3351 -- Loop through homonyms. As noted below, in the case of a package 3352 -- spec, only homonyms within the package spec are considered. 3353 3354 loop 3355 Suppress_Unsuppress_Echeck (E, C); 3356 3357 if Is_Generic_Instance (E) 3358 and then Is_Subprogram (E) 3359 and then Present (Alias (E)) 3360 then 3361 Suppress_Unsuppress_Echeck (Alias (E), C); 3362 end if; 3363 3364 -- Move to next homonym 3365 3366 E := Homonym (E); 3367 exit when No (E); 3368 3369 -- If we are within a package specification, the 3370 -- pragma only applies to homonyms in the same scope. 3371 3372 exit when In_Package_Spec 3373 and then Scope (E) /= Current_Scope; 3374 end loop; 3375 end if; 3376 end Process_Suppress_Unsuppress; 3377 3378 ------------------ 3379 -- Set_Exported -- 3380 ------------------ 3381 3382 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is 3383 begin 3384 if Is_Imported (E) then 3385 Error_Pragma_Arg 3386 ("cannot export entity& that was previously imported", Arg); 3387 3388 elsif Present (Address_Clause (E)) then 3389 Error_Pragma_Arg 3390 ("cannot export entity& that has an address clause", Arg); 3391 end if; 3392 3393 Set_Is_Exported (E); 3394 3395 -- Generate a reference for entity explicitly, because the 3396 -- identifier may be overloaded and name resolution will not 3397 -- generate one. 3398 3399 Generate_Reference (E, Arg); 3400 3401 -- Deal with exporting non-library level entity 3402 3403 if not Is_Library_Level_Entity (E) then 3404 3405 -- Not allowed at all for subprograms 3406 3407 if Is_Subprogram (E) then 3408 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg); 3409 3410 -- Otherwise set public and statically allocated 3411 3412 else 3413 Set_Is_Public (E); 3414 Set_Is_Statically_Allocated (E); 3415 3416 if Warn_On_Export_Import then 3417 Error_Msg_NE 3418 ("?& has been made static as a result of Export", Arg, E); 3419 Error_Msg_N 3420 ("\this usage is non-standard and non-portable", Arg); 3421 end if; 3422 end if; 3423 end if; 3424 3425 if Warn_On_Export_Import and then Is_Type (E) then 3426 Error_Msg_NE 3427 ("exporting a type has no effect?", Arg, E); 3428 end if; 3429 3430 if Warn_On_Export_Import and Inside_A_Generic then 3431 Error_Msg_NE 3432 ("all instances of& will have the same external name?", Arg, E); 3433 end if; 3434 end Set_Exported; 3435 3436 ---------------------------------------------- 3437 -- Set_Extended_Import_Export_External_Name -- 3438 ---------------------------------------------- 3439 3440 procedure Set_Extended_Import_Export_External_Name 3441 (Internal_Ent : Entity_Id; 3442 Arg_External : Node_Id) 3443 is 3444 Old_Name : constant Node_Id := Interface_Name (Internal_Ent); 3445 New_Name : Node_Id; 3446 3447 begin 3448 if No (Arg_External) then 3449 return; 3450 3451 elsif Nkind (Arg_External) = N_String_Literal then 3452 if String_Length (Strval (Arg_External)) = 0 then 3453 return; 3454 else 3455 New_Name := Adjust_External_Name_Case (Arg_External); 3456 end if; 3457 3458 elsif Nkind (Arg_External) = N_Identifier then 3459 New_Name := Get_Default_External_Name (Arg_External); 3460 3461 else 3462 Error_Pragma_Arg 3463 ("incorrect form for External parameter for pragma%", 3464 Arg_External); 3465 end if; 3466 3467 -- If we already have an external name set (by a prior normal 3468 -- Import or Export pragma), then the external names must match 3469 3470 if Present (Interface_Name (Internal_Ent)) then 3471 declare 3472 S1 : constant String_Id := Strval (Old_Name); 3473 S2 : constant String_Id := Strval (New_Name); 3474 3475 procedure Mismatch; 3476 -- Called if names do not match 3477 3478 procedure Mismatch is 3479 begin 3480 Error_Msg_Sloc := Sloc (Old_Name); 3481 Error_Pragma_Arg 3482 ("external name does not match that given #", 3483 Arg_External); 3484 end Mismatch; 3485 3486 begin 3487 if String_Length (S1) /= String_Length (S2) then 3488 Mismatch; 3489 3490 else 3491 for J in 1 .. String_Length (S1) loop 3492 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then 3493 Mismatch; 3494 end if; 3495 end loop; 3496 end if; 3497 end; 3498 3499 -- Otherwise set the given name 3500 3501 else 3502 Set_Encoded_Interface_Name (Internal_Ent, New_Name); 3503 end if; 3504 3505 end Set_Extended_Import_Export_External_Name; 3506 3507 ------------------ 3508 -- Set_Imported -- 3509 ------------------ 3510 3511 procedure Set_Imported (E : Entity_Id) is 3512 begin 3513 Error_Msg_Sloc := Sloc (E); 3514 3515 if Is_Exported (E) or else Is_Imported (E) then 3516 Error_Msg_NE ("import of& declared# not allowed", N, E); 3517 3518 if Is_Exported (E) then 3519 Error_Msg_N ("\entity was previously exported", N); 3520 else 3521 Error_Msg_N ("\entity was previously imported", N); 3522 end if; 3523 3524 Error_Pragma ("\(pragma% applies to all previous entities)"); 3525 3526 else 3527 Set_Is_Imported (E); 3528 3529 -- If the entity is an object that is not at the library 3530 -- level, then it is statically allocated. We do not worry 3531 -- about objects with address clauses in this context since 3532 -- they are not really imported in the linker sense. 3533 3534 if Is_Object (E) 3535 and then not Is_Library_Level_Entity (E) 3536 and then No (Address_Clause (E)) 3537 then 3538 Set_Is_Statically_Allocated (E); 3539 end if; 3540 end if; 3541 end Set_Imported; 3542 3543 ------------------------- 3544 -- Set_Mechanism_Value -- 3545 ------------------------- 3546 3547 -- Note: the mechanism name has not been analyzed (and cannot indeed 3548 -- be analyzed, since it is semantic nonsense), so we get it in the 3549 -- exact form created by the parser. 3550 3551 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is 3552 Class : Node_Id; 3553 Param : Node_Id; 3554 3555 procedure Bad_Class; 3556 -- Signal bad descriptor class name 3557 3558 procedure Bad_Mechanism; 3559 -- Signal bad mechanism name 3560 3561 procedure Bad_Class is 3562 begin 3563 Error_Pragma_Arg ("unrecognized descriptor class name", Class); 3564 end Bad_Class; 3565 3566 procedure Bad_Mechanism is 3567 begin 3568 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name); 3569 end Bad_Mechanism; 3570 3571 -- Start of processing for Set_Mechanism_Value 3572 3573 begin 3574 if Mechanism (Ent) /= Default_Mechanism then 3575 Error_Msg_NE 3576 ("mechanism for & has already been set", Mech_Name, Ent); 3577 end if; 3578 3579 -- MECHANISM_NAME ::= value | reference | descriptor 3580 3581 if Nkind (Mech_Name) = N_Identifier then 3582 if Chars (Mech_Name) = Name_Value then 3583 Set_Mechanism (Ent, By_Copy); 3584 return; 3585 3586 elsif Chars (Mech_Name) = Name_Reference then 3587 Set_Mechanism (Ent, By_Reference); 3588 return; 3589 3590 elsif Chars (Mech_Name) = Name_Descriptor then 3591 Check_VMS (Mech_Name); 3592 Set_Mechanism (Ent, By_Descriptor); 3593 return; 3594 3595 elsif Chars (Mech_Name) = Name_Copy then 3596 Error_Pragma_Arg 3597 ("bad mechanism name, Value assumed", Mech_Name); 3598 3599 else 3600 Bad_Mechanism; 3601 end if; 3602 3603 -- MECHANISM_NAME ::= descriptor (CLASS_NAME) 3604 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca 3605 3606 -- Note: this form is parsed as an indexed component 3607 3608 elsif Nkind (Mech_Name) = N_Indexed_Component then 3609 Class := First (Expressions (Mech_Name)); 3610 3611 if Nkind (Prefix (Mech_Name)) /= N_Identifier 3612 or else Chars (Prefix (Mech_Name)) /= Name_Descriptor 3613 or else Present (Next (Class)) 3614 then 3615 Bad_Mechanism; 3616 end if; 3617 3618 -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) 3619 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca 3620 3621 -- Note: this form is parsed as a function call 3622 3623 elsif Nkind (Mech_Name) = N_Function_Call then 3624 3625 Param := First (Parameter_Associations (Mech_Name)); 3626 3627 if Nkind (Name (Mech_Name)) /= N_Identifier 3628 or else Chars (Name (Mech_Name)) /= Name_Descriptor 3629 or else Present (Next (Param)) 3630 or else No (Selector_Name (Param)) 3631 or else Chars (Selector_Name (Param)) /= Name_Class 3632 then 3633 Bad_Mechanism; 3634 else 3635 Class := Explicit_Actual_Parameter (Param); 3636 end if; 3637 3638 else 3639 Bad_Mechanism; 3640 end if; 3641 3642 -- Fall through here with Class set to descriptor class name 3643 3644 Check_VMS (Mech_Name); 3645 3646 if Nkind (Class) /= N_Identifier then 3647 Bad_Class; 3648 3649 elsif Chars (Class) = Name_UBS then 3650 Set_Mechanism (Ent, By_Descriptor_UBS); 3651 3652 elsif Chars (Class) = Name_UBSB then 3653 Set_Mechanism (Ent, By_Descriptor_UBSB); 3654 3655 elsif Chars (Class) = Name_UBA then 3656 Set_Mechanism (Ent, By_Descriptor_UBA); 3657 3658 elsif Chars (Class) = Name_S then 3659 Set_Mechanism (Ent, By_Descriptor_S); 3660 3661 elsif Chars (Class) = Name_SB then 3662 Set_Mechanism (Ent, By_Descriptor_SB); 3663 3664 elsif Chars (Class) = Name_A then 3665 Set_Mechanism (Ent, By_Descriptor_A); 3666 3667 elsif Chars (Class) = Name_NCA then 3668 Set_Mechanism (Ent, By_Descriptor_NCA); 3669 3670 else 3671 Bad_Class; 3672 end if; 3673 3674 end Set_Mechanism_Value; 3675 3676 -- Start of processing for Analyze_Pragma 3677 3678 begin 3679 if not Is_Pragma_Name (Chars (N)) then 3680 if Warn_On_Unrecognized_Pragma then 3681 Error_Pragma ("unrecognized pragma%!?"); 3682 else 3683 raise Pragma_Exit; 3684 end if; 3685 else 3686 Prag_Id := Get_Pragma_Id (Chars (N)); 3687 end if; 3688 3689 -- Preset arguments 3690 3691 Arg1 := Empty; 3692 Arg2 := Empty; 3693 Arg3 := Empty; 3694 Arg4 := Empty; 3695 3696 if Present (Pragma_Argument_Associations (N)) then 3697 Arg1 := First (Pragma_Argument_Associations (N)); 3698 3699 if Present (Arg1) then 3700 Arg2 := Next (Arg1); 3701 3702 if Present (Arg2) then 3703 Arg3 := Next (Arg2); 3704 3705 if Present (Arg3) then 3706 Arg4 := Next (Arg3); 3707 end if; 3708 end if; 3709 end if; 3710 end if; 3711 3712 -- Count number of arguments 3713 3714 declare 3715 Arg_Node : Node_Id; 3716 begin 3717 Arg_Count := 0; 3718 Arg_Node := Arg1; 3719 while Present (Arg_Node) loop 3720 Arg_Count := Arg_Count + 1; 3721 Next (Arg_Node); 3722 end loop; 3723 end; 3724 3725 -- An enumeration type defines the pragmas that are supported by the 3726 -- implementation. Get_Pragma_Id (in package Prag) transorms a name 3727 -- into the corresponding enumeration value for the following case. 3728 3729 case Prag_Id is 3730 3731 ----------------- 3732 -- Abort_Defer -- 3733 ----------------- 3734 3735 -- pragma Abort_Defer; 3736 3737 when Pragma_Abort_Defer => 3738 GNAT_Pragma; 3739 Check_Arg_Count (0); 3740 3741 -- The only required semantic processing is to check the 3742 -- placement. This pragma must appear at the start of the 3743 -- statement sequence of a handled sequence of statements. 3744 3745 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements 3746 or else N /= First (Statements (Parent (N))) 3747 then 3748 Pragma_Misplaced; 3749 end if; 3750 3751 ------------ 3752 -- Ada_83 -- 3753 ------------ 3754 3755 -- pragma Ada_83; 3756 3757 -- Note: this pragma also has some specific processing in Par.Prag 3758 -- because we want to set the Ada 83 mode switch during parsing. 3759 3760 when Pragma_Ada_83 => 3761 GNAT_Pragma; 3762 Ada_83 := True; 3763 Ada_95 := False; 3764 Check_Arg_Count (0); 3765 3766 ------------ 3767 -- Ada_95 -- 3768 ------------ 3769 3770 -- pragma Ada_95; 3771 3772 -- Note: this pragma also has some specific processing in Par.Prag 3773 -- because we want to set the Ada 83 mode switch during parsing. 3774 3775 when Pragma_Ada_95 => 3776 GNAT_Pragma; 3777 Ada_83 := False; 3778 Ada_95 := True; 3779 Check_Arg_Count (0); 3780 3781 ---------------------- 3782 -- All_Calls_Remote -- 3783 ---------------------- 3784 3785 -- pragma All_Calls_Remote [(library_package_NAME)]; 3786 3787 when Pragma_All_Calls_Remote => All_Calls_Remote : declare 3788 Lib_Entity : Entity_Id; 3789 3790 begin 3791 Check_Ada_83_Warning; 3792 Check_Valid_Library_Unit_Pragma; 3793 3794 if Nkind (N) = N_Null_Statement then 3795 return; 3796 end if; 3797 3798 Lib_Entity := Find_Lib_Unit_Name; 3799 3800 -- This pragma should only apply to a RCI unit (RM E.2.3(23)). 3801 3802 if Present (Lib_Entity) 3803 and then not Debug_Flag_U 3804 then 3805 if not Is_Remote_Call_Interface (Lib_Entity) then 3806 Error_Pragma ("pragma% only apply to rci unit"); 3807 3808 -- Set flag for entity of the library unit 3809 3810 else 3811 Set_Has_All_Calls_Remote (Lib_Entity); 3812 end if; 3813 3814 end if; 3815 end All_Calls_Remote; 3816 3817 -------------- 3818 -- Annotate -- 3819 -------------- 3820 3821 -- pragma Annotate (IDENTIFIER {, ARG}); 3822 -- ARG ::= NAME | EXPRESSION 3823 3824 when Pragma_Annotate => Annotate : begin 3825 GNAT_Pragma; 3826 Check_At_Least_N_Arguments (1); 3827 Check_Arg_Is_Identifier (Arg1); 3828 3829 declare 3830 Arg : Node_Id := Arg2; 3831 Exp : Node_Id; 3832 3833 begin 3834 while Present (Arg) loop 3835 Exp := Expression (Arg); 3836 Analyze (Exp); 3837 3838 if Is_Entity_Name (Exp) then 3839 null; 3840 3841 elsif Nkind (Exp) = N_String_Literal then 3842 Resolve (Exp, Standard_String); 3843 3844 elsif Is_Overloaded (Exp) then 3845 Error_Pragma_Arg ("ambiguous argument for pragma%", Exp); 3846 3847 else 3848 Resolve (Exp); 3849 end if; 3850 3851 Next (Arg); 3852 end loop; 3853 end; 3854 end Annotate; 3855 3856 ------------ 3857 -- Assert -- 3858 ------------ 3859 3860 -- pragma Assert (Boolean_EXPRESSION [, static_string_EXPRESSION]); 3861 3862 when Pragma_Assert => 3863 GNAT_Pragma; 3864 Check_No_Identifiers; 3865 3866 if Arg_Count > 1 then 3867 Check_Arg_Count (2); 3868 Check_Arg_Is_Static_Expression (Arg2, Standard_String); 3869 end if; 3870 3871 -- If expansion is active and assertions are inactive, then 3872 -- we rewrite the Assertion as: 3873 3874 -- if False and then condition then 3875 -- null; 3876 -- end if; 3877 3878 -- The reason we do this rewriting during semantic analysis 3879 -- rather than as part of normal expansion is that we cannot 3880 -- analyze and expand the code for the boolean expression 3881 -- directly, or it may cause insertion of actions that would 3882 -- escape the attempt to suppress the assertion code. 3883 3884 if Expander_Active and not Assertions_Enabled then 3885 Rewrite (N, 3886 Make_If_Statement (Loc, 3887 Condition => 3888 Make_And_Then (Loc, 3889 Left_Opnd => New_Occurrence_Of (Standard_False, Loc), 3890 Right_Opnd => Get_Pragma_Arg (Arg1)), 3891 Then_Statements => New_List ( 3892 Make_Null_Statement (Loc)))); 3893 3894 Analyze (N); 3895 3896 -- Otherwise (if assertions are enabled, or if we are not 3897 -- operating with expansion active), then we just analyze 3898 -- and resolve the expression. 3899 3900 else 3901 Analyze_And_Resolve (Expression (Arg1), Any_Boolean); 3902 end if; 3903 3904 --------------- 3905 -- AST_Entry -- 3906 --------------- 3907 3908 -- pragma AST_Entry (entry_IDENTIFIER); 3909 3910 when Pragma_AST_Entry => AST_Entry : declare 3911 Ent : Node_Id; 3912 3913 begin 3914 GNAT_Pragma; 3915 Check_VMS (N); 3916 Check_Arg_Count (1); 3917 Check_No_Identifiers; 3918 Check_Arg_Is_Local_Name (Arg1); 3919 Ent := Entity (Expression (Arg1)); 3920 3921 -- Note: the implementation of the AST_Entry pragma could handle 3922 -- the entry family case fine, but for now we are consistent with 3923 -- the DEC rules, and do not allow the pragma, which of course 3924 -- has the effect of also forbidding the attribute. 3925 3926 if Ekind (Ent) /= E_Entry then 3927 Error_Pragma_Arg 3928 ("pragma% argument must be simple entry name", Arg1); 3929 3930 elsif Is_AST_Entry (Ent) then 3931 Error_Pragma_Arg 3932 ("duplicate % pragma for entry", Arg1); 3933 3934 elsif Has_Homonym (Ent) then 3935 Error_Pragma_Arg 3936 ("pragma% argument cannot specify overloaded entry", Arg1); 3937 3938 else 3939 declare 3940 FF : constant Entity_Id := First_Formal (Ent); 3941 3942 begin 3943 if Present (FF) then 3944 if Present (Next_Formal (FF)) then 3945 Error_Pragma_Arg 3946 ("entry for pragma% can have only one argument", 3947 Arg1); 3948 3949 elsif Parameter_Mode (FF) /= E_In_Parameter then 3950 Error_Pragma_Arg 3951 ("entry parameter for pragma% must have mode IN", 3952 Arg1); 3953 end if; 3954 end if; 3955 end; 3956 3957 Set_Is_AST_Entry (Ent); 3958 end if; 3959 end AST_Entry; 3960 3961 ------------------ 3962 -- Asynchronous -- 3963 ------------------ 3964 3965 -- pragma Asynchronous (LOCAL_NAME); 3966 3967 when Pragma_Asynchronous => Asynchronous : declare 3968 Nm : Entity_Id; 3969 C_Ent : Entity_Id; 3970 L : List_Id; 3971 S : Node_Id; 3972 N : Node_Id; 3973 Formal : Entity_Id; 3974 3975 procedure Process_Async_Pragma; 3976 -- Common processing for procedure and access-to-procedure case 3977 3978 -------------------------- 3979 -- Process_Async_Pragma -- 3980 -------------------------- 3981 3982 procedure Process_Async_Pragma is 3983 begin 3984 if not Present (L) then 3985 Set_Is_Asynchronous (Nm); 3986 return; 3987 end if; 3988 3989 -- The formals should be of mode IN (RM E.4.1(6)) 3990 3991 S := First (L); 3992 while Present (S) loop 3993 Formal := Defining_Identifier (S); 3994 3995 if Nkind (Formal) = N_Defining_Identifier 3996 and then Ekind (Formal) /= E_In_Parameter 3997 then 3998 Error_Pragma_Arg 3999 ("pragma% procedure can only have IN parameter", 4000 Arg1); 4001 end if; 4002 4003 Next (S); 4004 end loop; 4005 4006 Set_Is_Asynchronous (Nm); 4007 end Process_Async_Pragma; 4008 4009 -- Start of processing for pragma Asynchronous 4010 4011 begin 4012 Check_Ada_83_Warning; 4013 Check_No_Identifiers; 4014 Check_Arg_Count (1); 4015 Check_Arg_Is_Local_Name (Arg1); 4016 4017 if Debug_Flag_U then 4018 return; 4019 end if; 4020 4021 C_Ent := Cunit_Entity (Current_Sem_Unit); 4022 Analyze (Expression (Arg1)); 4023 Nm := Entity (Expression (Arg1)); 4024 4025 if not Is_Remote_Call_Interface (C_Ent) 4026 and then not Is_Remote_Types (C_Ent) 4027 then 4028 -- This pragma should only appear in an RCI or Remote Types 4029 -- unit (RM E.4.1(4)) 4030 4031 Error_Pragma 4032 ("pragma% not in Remote_Call_Interface or " & 4033 "Remote_Types unit"); 4034 end if; 4035 4036 if Ekind (Nm) = E_Procedure 4037 and then Nkind (Parent (Nm)) = N_Procedure_Specification 4038 then 4039 if not Is_Remote_Call_Interface (Nm) then 4040 Error_Pragma_Arg 4041 ("pragma% cannot be applied on non-remote procedure", 4042 Arg1); 4043 end if; 4044 4045 L := Parameter_Specifications (Parent (Nm)); 4046 Process_Async_Pragma; 4047 return; 4048 4049 elsif Ekind (Nm) = E_Function then 4050 Error_Pragma_Arg 4051 ("pragma% cannot be applied to function", Arg1); 4052 4053 elsif Ekind (Nm) = E_Record_Type 4054 and then Present (Corresponding_Remote_Type (Nm)) 4055 then 4056 N := Declaration_Node (Corresponding_Remote_Type (Nm)); 4057 4058 if Nkind (N) = N_Full_Type_Declaration 4059 and then Nkind (Type_Definition (N)) = 4060 N_Access_Procedure_Definition 4061 then 4062 L := Parameter_Specifications (Type_Definition (N)); 4063 Process_Async_Pragma; 4064 4065 else 4066 Error_Pragma_Arg 4067 ("pragma% cannot reference access-to-function type", 4068 Arg1); 4069 end if; 4070 4071 -- Only other possibility is Access-to-class-wide type 4072 4073 elsif Is_Access_Type (Nm) 4074 and then Is_Class_Wide_Type (Designated_Type (Nm)) 4075 then 4076 Check_First_Subtype (Arg1); 4077 Set_Is_Asynchronous (Nm); 4078 if Expander_Active then 4079 RACW_Type_Is_Asynchronous (Nm); 4080 end if; 4081 4082 else 4083 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1); 4084 end if; 4085 end Asynchronous; 4086 4087 ------------ 4088 -- Atomic -- 4089 ------------ 4090 4091 -- pragma Atomic (LOCAL_NAME); 4092 4093 when Pragma_Atomic => 4094 Process_Atomic_Shared_Volatile; 4095 4096 ----------------------- 4097 -- Atomic_Components -- 4098 ----------------------- 4099 4100 -- pragma Atomic_Components (array_LOCAL_NAME); 4101 4102 -- This processing is shared by Volatile_Components 4103 4104 when Pragma_Atomic_Components | 4105 Pragma_Volatile_Components => 4106 4107 Atomic_Components : declare 4108 E_Id : Node_Id; 4109 E : Entity_Id; 4110 D : Node_Id; 4111 K : Node_Kind; 4112 4113 begin 4114 Check_Ada_83_Warning; 4115 Check_No_Identifiers; 4116 Check_Arg_Count (1); 4117 Check_Arg_Is_Local_Name (Arg1); 4118 E_Id := Expression (Arg1); 4119 4120 if Etype (E_Id) = Any_Type then 4121 return; 4122 end if; 4123 4124 E := Entity (E_Id); 4125 4126 if Rep_Item_Too_Early (E, N) 4127 or else 4128 Rep_Item_Too_Late (E, N) 4129 then 4130 return; 4131 end if; 4132 4133 D := Declaration_Node (E); 4134 K := Nkind (D); 4135 4136 if (K = N_Full_Type_Declaration and then Is_Array_Type (E)) 4137 or else 4138 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable) 4139 and then Nkind (D) = N_Object_Declaration 4140 and then Nkind (Object_Definition (D)) = 4141 N_Constrained_Array_Definition) 4142 then 4143 -- The flag is set on the object, or on the base type 4144 4145 if Nkind (D) /= N_Object_Declaration then 4146 E := Base_Type (E); 4147 end if; 4148 4149 Set_Has_Volatile_Components (E); 4150 4151 if Prag_Id = Pragma_Atomic_Components then 4152 Set_Has_Atomic_Components (E); 4153 4154 if Is_Packed (E) then 4155 Set_Is_Packed (E, False); 4156 4157 Error_Pragma_Arg 4158 ("?Pack canceled, cannot pack atomic components", 4159 Arg1); 4160 end if; 4161 end if; 4162 4163 else 4164 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); 4165 end if; 4166 end Atomic_Components; 4167 4168 -------------------- 4169 -- Attach_Handler -- 4170 -------------------- 4171 4172 -- pragma Attach_Handler (handler_NAME, EXPRESSION); 4173 4174 when Pragma_Attach_Handler => 4175 Check_Ada_83_Warning; 4176 Check_No_Identifiers; 4177 Check_Arg_Count (2); 4178 4179 if No_Run_Time_Mode then 4180 Error_Msg_CRT ("Attach_Handler pragma", N); 4181 else 4182 Check_Interrupt_Or_Attach_Handler; 4183 4184 -- The expression that designates the attribute may 4185 -- depend on a discriminant, and is therefore a per- 4186 -- object expression, to be expanded in the init proc. 4187 -- If expansion is enabled, perform semantic checks 4188 -- on a copy only. 4189 4190 if Expander_Active then 4191 declare 4192 Temp : constant Node_Id := 4193 New_Copy_Tree (Expression (Arg2)); 4194 begin 4195 Set_Parent (Temp, N); 4196 Pre_Analyze_And_Resolve (Temp, RTE (RE_Interrupt_ID)); 4197 end; 4198 4199 else 4200 Analyze (Expression (Arg2)); 4201 Resolve (Expression (Arg2), RTE (RE_Interrupt_ID)); 4202 end if; 4203 4204 Process_Interrupt_Or_Attach_Handler; 4205 end if; 4206 4207 -------------------- 4208 -- C_Pass_By_Copy -- 4209 -------------------- 4210 4211 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION); 4212 4213 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare 4214 Arg : Node_Id; 4215 Val : Uint; 4216 4217 begin 4218 GNAT_Pragma; 4219 Check_Valid_Configuration_Pragma; 4220 Check_Arg_Count (1); 4221 Check_Optional_Identifier (Arg1, "max_size"); 4222 4223 Arg := Expression (Arg1); 4224 Check_Arg_Is_Static_Expression (Arg, Any_Integer); 4225 4226 Val := Expr_Value (Arg); 4227 4228 if Val <= 0 then 4229 Error_Pragma_Arg 4230 ("maximum size for pragma% must be positive", Arg1); 4231 4232 elsif UI_Is_In_Int_Range (Val) then 4233 Default_C_Record_Mechanism := UI_To_Int (Val); 4234 4235 -- If a giant value is given, Int'Last will do well enough. 4236 -- If sometime someone complains that a record larger than 4237 -- two gigabytes is not copied, we will worry about it then! 4238 4239 else 4240 Default_C_Record_Mechanism := Mechanism_Type'Last; 4241 end if; 4242 end C_Pass_By_Copy; 4243 4244 ------------- 4245 -- Comment -- 4246 ------------- 4247 4248 -- pragma Comment (static_string_EXPRESSION) 4249 4250 -- Processing for pragma Comment shares the circuitry for 4251 -- pragma Ident. The only differences are that Ident enforces 4252 -- a limit of 31 characters on its argument, and also enforces 4253 -- limitations on placement for DEC compatibility. Pragma 4254 -- Comment shares neither of these restrictions. 4255 4256 ------------------- 4257 -- Common_Object -- 4258 ------------------- 4259 4260 -- pragma Common_Object ( 4261 -- [Internal =>] LOCAL_NAME, 4262 -- [, [External =>] EXTERNAL_SYMBOL] 4263 -- [, [Size =>] EXTERNAL_SYMBOL]); 4264 4265 -- Processing for this pragma is shared with Psect_Object 4266 4267 -------------------------- 4268 -- Compile_Time_Warning -- 4269 -------------------------- 4270 4271 -- pragma Compile_Time_Warning 4272 -- (boolean_EXPRESSION, static_string_EXPRESSION); 4273 4274 when Pragma_Compile_Time_Warning => Compile_Time_Warning : declare 4275 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1); 4276 4277 begin 4278 GNAT_Pragma; 4279 Check_Arg_Count (2); 4280 Check_No_Identifiers; 4281 Check_Arg_Is_Static_Expression (Arg2, Standard_String); 4282 Analyze_And_Resolve (Arg1x, Standard_Boolean); 4283 4284 if Compile_Time_Known_Value (Arg1x) then 4285 if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then 4286 String_To_Name_Buffer (Strval (Get_Pragma_Arg (Arg2))); 4287 Add_Char_To_Name_Buffer ('?'); 4288 4289 declare 4290 Msg : String (1 .. Name_Len) := 4291 Name_Buffer (1 .. Name_Len); 4292 4293 B : Natural; 4294 4295 begin 4296 -- This loop looks for multiple lines separated by 4297 -- ASCII.LF and breaks them into continuation error 4298 -- messages marked with the usual back slash. 4299 4300 B := 1; 4301 for S in 2 .. Msg'Length - 1 loop 4302 if Msg (S) = ASCII.LF then 4303 Msg (S) := '?'; 4304 Error_Msg_N (Msg (B .. S), Arg1); 4305 B := S; 4306 Msg (B) := '\'; 4307 end if; 4308 end loop; 4309 4310 Error_Msg_N (Msg (B .. Msg'Length), Arg1); 4311 end; 4312 end if; 4313 end if; 4314 end Compile_Time_Warning; 4315 4316 ---------------------------- 4317 -- Complex_Representation -- 4318 ---------------------------- 4319 4320 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME); 4321 4322 when Pragma_Complex_Representation => Complex_Representation : declare 4323 E_Id : Entity_Id; 4324 E : Entity_Id; 4325 Ent : Entity_Id; 4326 4327 begin 4328 GNAT_Pragma; 4329 Check_Arg_Count (1); 4330 Check_Optional_Identifier (Arg1, Name_Entity); 4331 Check_Arg_Is_Local_Name (Arg1); 4332 E_Id := Expression (Arg1); 4333 4334 if Etype (E_Id) = Any_Type then 4335 return; 4336 end if; 4337 4338 E := Entity (E_Id); 4339 4340 if not Is_Record_Type (E) then 4341 Error_Pragma_Arg 4342 ("argument for pragma% must be record type", Arg1); 4343 end if; 4344 4345 Ent := First_Entity (E); 4346 4347 if No (Ent) 4348 or else No (Next_Entity (Ent)) 4349 or else Present (Next_Entity (Next_Entity (Ent))) 4350 or else not Is_Floating_Point_Type (Etype (Ent)) 4351 or else Etype (Ent) /= Etype (Next_Entity (Ent)) 4352 then 4353 Error_Pragma_Arg 4354 ("record for pragma% must have two fields of same fpt type", 4355 Arg1); 4356 4357 else 4358 Set_Has_Complex_Representation (Base_Type (E)); 4359 end if; 4360 end Complex_Representation; 4361 4362 ------------------------- 4363 -- Component_Alignment -- 4364 ------------------------- 4365 4366 -- pragma Component_Alignment ( 4367 -- [Form =>] ALIGNMENT_CHOICE 4368 -- [, [Name =>] type_LOCAL_NAME]); 4369 -- 4370 -- ALIGNMENT_CHOICE ::= 4371 -- Component_Size 4372 -- | Component_Size_4 4373 -- | Storage_Unit 4374 -- | Default 4375 4376 when Pragma_Component_Alignment => Component_AlignmentP : declare 4377 Args : Args_List (1 .. 2); 4378 Names : constant Name_List (1 .. 2) := ( 4379 Name_Form, 4380 Name_Name); 4381 4382 Form : Node_Id renames Args (1); 4383 Name : Node_Id renames Args (2); 4384 4385 Atype : Component_Alignment_Kind; 4386 Typ : Entity_Id; 4387 4388 begin 4389 GNAT_Pragma; 4390 Gather_Associations (Names, Args); 4391 4392 if No (Form) then 4393 Error_Pragma ("missing Form argument for pragma%"); 4394 end if; 4395 4396 Check_Arg_Is_Identifier (Form); 4397 4398 -- Get proper alignment, note that Default = Component_Size 4399 -- on all machines we have so far, and we want to set this 4400 -- value rather than the default value to indicate that it 4401 -- has been explicitly set (and thus will not get overridden 4402 -- by the default component alignment for the current scope) 4403 4404 if Chars (Form) = Name_Component_Size then 4405 Atype := Calign_Component_Size; 4406 4407 elsif Chars (Form) = Name_Component_Size_4 then 4408 Atype := Calign_Component_Size_4; 4409 4410 elsif Chars (Form) = Name_Default then 4411 Atype := Calign_Component_Size; 4412 4413 elsif Chars (Form) = Name_Storage_Unit then 4414 Atype := Calign_Storage_Unit; 4415 4416 else 4417 Error_Pragma_Arg 4418 ("invalid Form parameter for pragma%", Form); 4419 end if; 4420 4421 -- Case with no name, supplied, affects scope table entry 4422 4423 if No (Name) then 4424 Scope_Stack.Table 4425 (Scope_Stack.Last).Component_Alignment_Default := Atype; 4426 4427 -- Case of name supplied 4428 4429 else 4430 Check_Arg_Is_Local_Name (Name); 4431 Find_Type (Name); 4432 Typ := Entity (Name); 4433 4434 if Typ = Any_Type 4435 or else Rep_Item_Too_Early (Typ, N) 4436 then 4437 return; 4438 else 4439 Typ := Underlying_Type (Typ); 4440 end if; 4441 4442 if not Is_Record_Type (Typ) 4443 and then not Is_Array_Type (Typ) 4444 then 4445 Error_Pragma_Arg 4446 ("Name parameter of pragma% must identify record or " & 4447 "array type", Name); 4448 end if; 4449 4450 -- An explicit Component_Alignment pragma overrides an 4451 -- implicit pragma Pack, but not an explicit one. 4452 4453 if not Has_Pragma_Pack (Base_Type (Typ)) then 4454 Set_Is_Packed (Base_Type (Typ), False); 4455 Set_Component_Alignment (Base_Type (Typ), Atype); 4456 end if; 4457 end if; 4458 end Component_AlignmentP; 4459 4460 ---------------- 4461 -- Controlled -- 4462 ---------------- 4463 4464 -- pragma Controlled (first_subtype_LOCAL_NAME); 4465 4466 when Pragma_Controlled => Controlled : declare 4467 Arg : Node_Id; 4468 4469 begin 4470 Check_No_Identifiers; 4471 Check_Arg_Count (1); 4472 Check_Arg_Is_Local_Name (Arg1); 4473 Arg := Expression (Arg1); 4474 4475 if not Is_Entity_Name (Arg) 4476 or else not Is_Access_Type (Entity (Arg)) 4477 then 4478 Error_Pragma_Arg ("pragma% requires access type", Arg1); 4479 else 4480 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg))); 4481 end if; 4482 end Controlled; 4483 4484 ---------------- 4485 -- Convention -- 4486 ---------------- 4487 4488 -- pragma Convention ([Convention =>] convention_IDENTIFIER, 4489 -- [Entity =>] LOCAL_NAME); 4490 4491 when Pragma_Convention => Convention : declare 4492 C : Convention_Id; 4493 E : Entity_Id; 4494 begin 4495 Check_Ada_83_Warning; 4496 Check_Arg_Count (2); 4497 Process_Convention (C, E); 4498 end Convention; 4499 4500 --------------------------- 4501 -- Convention_Identifier -- 4502 --------------------------- 4503 4504 -- pragma Convention_Identifier ([Name =>] IDENTIFIER, 4505 -- [Convention =>] convention_IDENTIFIER); 4506 4507 when Pragma_Convention_Identifier => Convention_Identifier : declare 4508 Idnam : Name_Id; 4509 Cname : Name_Id; 4510 4511 begin 4512 GNAT_Pragma; 4513 Check_Arg_Count (2); 4514 Check_Optional_Identifier (Arg1, Name_Name); 4515 Check_Optional_Identifier (Arg2, Name_Convention); 4516 Check_Arg_Is_Identifier (Arg1); 4517 Check_Arg_Is_Identifier (Arg1); 4518 Idnam := Chars (Expression (Arg1)); 4519 Cname := Chars (Expression (Arg2)); 4520 4521 if Is_Convention_Name (Cname) then 4522 Record_Convention_Identifier 4523 (Idnam, Get_Convention_Id (Cname)); 4524 else 4525 Error_Pragma_Arg 4526 ("second arg for % pragma must be convention", Arg2); 4527 end if; 4528 end Convention_Identifier; 4529 4530 --------------- 4531 -- CPP_Class -- 4532 --------------- 4533 4534 -- pragma CPP_Class ([Entity =>] local_NAME) 4535 4536 when Pragma_CPP_Class => CPP_Class : declare 4537 Arg : Node_Id; 4538 Typ : Entity_Id; 4539 Default_DTC : Entity_Id := Empty; 4540 VTP_Type : constant Entity_Id := RTE (RE_Vtable_Ptr); 4541 C : Entity_Id; 4542 Tag_C : Entity_Id; 4543 4544 begin 4545 GNAT_Pragma; 4546 Check_Arg_Count (1); 4547 Check_Optional_Identifier (Arg1, Name_Entity); 4548 Check_Arg_Is_Local_Name (Arg1); 4549 4550 Arg := Expression (Arg1); 4551 Analyze (Arg); 4552 4553 if Etype (Arg) = Any_Type then 4554 return; 4555 end if; 4556 4557 if not Is_Entity_Name (Arg) 4558 or else not Is_Type (Entity (Arg)) 4559 then 4560 Error_Pragma_Arg ("pragma% requires a type mark", Arg1); 4561 end if; 4562 4563 Typ := Entity (Arg); 4564 4565 if not Is_Record_Type (Typ) then 4566 Error_Pragma_Arg ("pragma% applicable to a record, " 4567 & "tagged record or record extension", Arg1); 4568 end if; 4569 4570 Default_DTC := First_Component (Typ); 4571 while Present (Default_DTC) 4572 and then Etype (Default_DTC) /= VTP_Type 4573 loop 4574 Next_Component (Default_DTC); 4575 end loop; 4576 4577 -- Case of non tagged type 4578 4579 if not Is_Tagged_Type (Typ) then 4580 Set_Is_CPP_Class (Typ); 4581 4582 if Present (Default_DTC) then 4583 Error_Pragma_Arg 4584 ("only tagged records can contain vtable pointers", Arg1); 4585 end if; 4586 4587 -- Case of tagged type with no vtable ptr 4588 4589 -- What is test for Typ = Root_Typ (Typ) about here ??? 4590 4591 elsif Is_Tagged_Type (Typ) 4592 and then Typ = Root_Type (Typ) 4593 and then No (Default_DTC) 4594 then 4595 Error_Pragma_Arg 4596 ("a cpp_class must contain a vtable pointer", Arg1); 4597 4598 -- Tagged type that has a vtable ptr 4599 4600 elsif Present (Default_DTC) then 4601 Set_Is_CPP_Class (Typ); 4602 Set_Is_Limited_Record (Typ); 4603 Set_Is_Tag (Default_DTC); 4604 Set_DT_Entry_Count (Default_DTC, No_Uint); 4605 4606 -- Since a CPP type has no direct link to its associated tag 4607 -- most tags checks cannot be performed 4608 4609 Set_Kill_Tag_Checks (Typ); 4610 Set_Kill_Tag_Checks (Class_Wide_Type (Typ)); 4611 4612 -- Get rid of the _tag component when there was one. 4613 -- It is only useful for regular tagged types 4614 4615 if Expander_Active and then Typ = Root_Type (Typ) then 4616 4617 Tag_C := Tag_Component (Typ); 4618 C := First_Entity (Typ); 4619 4620 if C = Tag_C then 4621 Set_First_Entity (Typ, Next_Entity (Tag_C)); 4622 4623 else 4624 while Next_Entity (C) /= Tag_C loop 4625 Next_Entity (C); 4626 end loop; 4627 4628 Set_Next_Entity (C, Next_Entity (Tag_C)); 4629 end if; 4630 end if; 4631 end if; 4632 end CPP_Class; 4633 4634 --------------------- 4635 -- CPP_Constructor -- 4636 --------------------- 4637 4638 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME); 4639 4640 when Pragma_CPP_Constructor => CPP_Constructor : declare 4641 Id : Entity_Id; 4642 Def_Id : Entity_Id; 4643 4644 begin 4645 GNAT_Pragma; 4646 Check_Arg_Count (1); 4647 Check_Optional_Identifier (Arg1, Name_Entity); 4648 Check_Arg_Is_Local_Name (Arg1); 4649 4650 Id := Expression (Arg1); 4651 Find_Program_Unit_Name (Id); 4652 4653 -- If we did not find the name, we are done 4654 4655 if Etype (Id) = Any_Type then 4656 return; 4657 end if; 4658 4659 Def_Id := Entity (Id); 4660 4661 if Ekind (Def_Id) = E_Function 4662 and then Is_Class_Wide_Type (Etype (Def_Id)) 4663 and then Is_CPP_Class (Etype (Etype (Def_Id))) 4664 then 4665 -- What the heck is this??? this pragma allows only 1 arg 4666 4667 if Arg_Count >= 2 then 4668 Check_At_Most_N_Arguments (3); 4669 Process_Interface_Name (Def_Id, Arg2, Arg3); 4670 end if; 4671 4672 if No (Parameter_Specifications (Parent (Def_Id))) then 4673 Set_Has_Completion (Def_Id); 4674 Set_Is_Constructor (Def_Id); 4675 else 4676 Error_Pragma_Arg 4677 ("non-default constructors not implemented", Arg1); 4678 end if; 4679 4680 else 4681 Error_Pragma_Arg 4682 ("pragma% requires function returning a 'C'P'P_Class type", 4683 Arg1); 4684 end if; 4685 end CPP_Constructor; 4686 4687 ----------------- 4688 -- CPP_Virtual -- 4689 ----------------- 4690 4691 -- pragma CPP_Virtual 4692 -- [Entity =>] LOCAL_NAME 4693 -- [ [Vtable_Ptr =>] LOCAL_NAME, 4694 -- [Position =>] static_integer_EXPRESSION]); 4695 4696 when Pragma_CPP_Virtual => CPP_Virtual : declare 4697 Arg : Node_Id; 4698 Typ : Entity_Id; 4699 Subp : Entity_Id; 4700 VTP_Type : constant Entity_Id := RTE (RE_Vtable_Ptr); 4701 DTC : Entity_Id; 4702 V : Uint; 4703 4704 begin 4705 GNAT_Pragma; 4706 4707 if Arg_Count = 3 then 4708 Check_Optional_Identifier (Arg2, "vtable_ptr"); 4709 4710 -- We allow Entry_Count as well as Position for the third 4711 -- parameter for back compatibility with versions of GNAT 4712 -- before version 3.12. The documentation has always said 4713 -- Position, but the code up to 3.12 said Entry_Count. 4714 4715 if Chars (Arg3) /= Name_Position then 4716 Check_Optional_Identifier (Arg3, "entry_count"); 4717 end if; 4718 4719 else 4720 Check_Arg_Count (1); 4721 end if; 4722 4723 Check_Optional_Identifier (Arg1, Name_Entity); 4724 Check_Arg_Is_Local_Name (Arg1); 4725 4726 -- First argument must be a subprogram name 4727 4728 Arg := Expression (Arg1); 4729 Find_Program_Unit_Name (Arg); 4730 4731 if Etype (Arg) = Any_Type then 4732 return; 4733 else 4734 Subp := Entity (Arg); 4735 end if; 4736 4737 if not (Is_Subprogram (Subp) 4738 and then Is_Dispatching_Operation (Subp)) 4739 then 4740 Error_Pragma_Arg 4741 ("pragma% must reference a primitive operation", Arg1); 4742 end if; 4743 4744 Typ := Find_Dispatching_Type (Subp); 4745 4746 -- If only one Argument defaults are : 4747 -- . DTC_Entity is the default Vtable pointer 4748 -- . DT_Position will be set at the freezing point 4749 4750 if Arg_Count = 1 then 4751 Set_DTC_Entity (Subp, Tag_Component (Typ)); 4752 return; 4753 end if; 4754 4755 -- Second argument is a component name of type Vtable_Ptr 4756 4757 Arg := Expression (Arg2); 4758 4759 if Nkind (Arg) /= N_Identifier then 4760 Error_Msg_NE ("must be a& component name", Arg, Typ); 4761 raise Pragma_Exit; 4762 end if; 4763 4764 DTC := First_Component (Typ); 4765 while Present (DTC) and then Chars (DTC) /= Chars (Arg) loop 4766 Next_Component (DTC); 4767 end loop; 4768 4769 if No (DTC) then 4770 Error_Msg_NE ("must be a& component name", Arg, Typ); 4771 raise Pragma_Exit; 4772 4773 elsif Etype (DTC) /= VTP_Type then 4774 Wrong_Type (Arg, VTP_Type); 4775 return; 4776 end if; 4777 4778 -- Third argument is an integer (DT_Position) 4779 4780 Arg := Expression (Arg3); 4781 Analyze_And_Resolve (Arg, Any_Integer); 4782 4783 if not Is_Static_Expression (Arg) then 4784 Flag_Non_Static_Expr 4785 ("third argument of pragma CPP_Virtual must be static!", 4786 Arg3); 4787 raise Pragma_Exit; 4788 4789 else 4790 V := Expr_Value (Expression (Arg3)); 4791 4792 if V <= 0 then 4793 Error_Pragma_Arg 4794 ("third argument of pragma% must be positive", 4795 Arg3); 4796 4797 else 4798 Set_DTC_Entity (Subp, DTC); 4799 Set_DT_Position (Subp, V); 4800 end if; 4801 end if; 4802 end CPP_Virtual; 4803 4804 ---------------- 4805 -- CPP_Vtable -- 4806 ---------------- 4807 4808 -- pragma CPP_Vtable ( 4809 -- [Entity =>] LOCAL_NAME 4810 -- [Vtable_Ptr =>] LOCAL_NAME, 4811 -- [Entry_Count =>] static_integer_EXPRESSION); 4812 4813 when Pragma_CPP_Vtable => CPP_Vtable : declare 4814 Arg : Node_Id; 4815 Typ : Entity_Id; 4816 VTP_Type : constant Entity_Id := RTE (RE_Vtable_Ptr); 4817 DTC : Entity_Id; 4818 V : Uint; 4819 Elmt : Elmt_Id; 4820 4821 begin 4822 GNAT_Pragma; 4823 Check_Arg_Count (3); 4824 Check_Optional_Identifier (Arg1, Name_Entity); 4825 Check_Optional_Identifier (Arg2, "vtable_ptr"); 4826 Check_Optional_Identifier (Arg3, "entry_count"); 4827 Check_Arg_Is_Local_Name (Arg1); 4828 4829 -- First argument is a record type name 4830 4831 Arg := Expression (Arg1); 4832 Analyze (Arg); 4833 4834 if Etype (Arg) = Any_Type then 4835 return; 4836 else 4837 Typ := Entity (Arg); 4838 end if; 4839 4840 if not (Is_Tagged_Type (Typ) and then Is_CPP_Class (Typ)) then 4841 Error_Pragma_Arg ("'C'P'P_Class tagged type expected", Arg1); 4842 end if; 4843 4844 -- Second argument is a component name of type Vtable_Ptr 4845 4846 Arg := Expression (Arg2); 4847 4848 if Nkind (Arg) /= N_Identifier then 4849 Error_Msg_NE ("must be a& component name", Arg, Typ); 4850 raise Pragma_Exit; 4851 end if; 4852 4853 DTC := First_Component (Typ); 4854 while Present (DTC) and then Chars (DTC) /= Chars (Arg) loop 4855 Next_Component (DTC); 4856 end loop; 4857 4858 if No (DTC) then 4859 Error_Msg_NE ("must be a& component name", Arg, Typ); 4860 raise Pragma_Exit; 4861 4862 elsif Etype (DTC) /= VTP_Type then 4863 Wrong_Type (DTC, VTP_Type); 4864 return; 4865 4866 -- If it is the first pragma Vtable, This becomes the default tag 4867 4868 elsif (not Is_Tag (DTC)) 4869 and then DT_Entry_Count (Tag_Component (Typ)) = No_Uint 4870 then 4871 Set_Is_Tag (Tag_Component (Typ), False); 4872 Set_Is_Tag (DTC, True); 4873 Set_DT_Entry_Count (DTC, No_Uint); 4874 end if; 4875 4876 -- Those pragmas must appear before any primitive operation 4877 -- definition (except inherited ones) otherwise the default 4878 -- may be wrong 4879 4880 Elmt := First_Elmt (Primitive_Operations (Typ)); 4881 while Present (Elmt) loop 4882 if No (Alias (Node (Elmt))) then 4883 Error_Msg_Sloc := Sloc (Node (Elmt)); 4884 Error_Pragma 4885 ("pragma% must appear before this primitive operation"); 4886 end if; 4887 4888 Next_Elmt (Elmt); 4889 end loop; 4890 4891 -- Third argument is an integer (DT_Entry_Count) 4892 4893 Arg := Expression (Arg3); 4894 Analyze_And_Resolve (Arg, Any_Integer); 4895 4896 if not Is_Static_Expression (Arg) then 4897 Flag_Non_Static_Expr 4898 ("entry count for pragma CPP_Vtable must be a static " & 4899 "expression!", Arg3); 4900 raise Pragma_Exit; 4901 4902 else 4903 V := Expr_Value (Expression (Arg3)); 4904 4905 if V <= 0 then 4906 Error_Pragma_Arg 4907 ("entry count for pragma% must be positive", Arg3); 4908 else 4909 Set_DT_Entry_Count (DTC, V); 4910 end if; 4911 end if; 4912 end CPP_Vtable; 4913 4914 ----------- 4915 -- Debug -- 4916 ----------- 4917 4918 -- pragma Debug (PROCEDURE_CALL_STATEMENT); 4919 4920 when Pragma_Debug => Debug : begin 4921 GNAT_Pragma; 4922 4923 -- If assertions are enabled, and we are expanding code, then 4924 -- we rewrite the pragma with its corresponding procedure call 4925 -- and then analyze the call. 4926 4927 if Assertions_Enabled and Expander_Active then 4928 Rewrite (N, Relocate_Node (Debug_Statement (N))); 4929 Analyze (N); 4930 4931 -- Otherwise we work a bit to get a tree that makes sense 4932 -- for ASIS purposes, namely a pragma with an analyzed 4933 -- argument that looks like a procedure call. 4934 4935 else 4936 Expander_Mode_Save_And_Set (False); 4937 Rewrite (N, Relocate_Node (Debug_Statement (N))); 4938 Analyze (N); 4939 Rewrite (N, 4940 Make_Pragma (Loc, 4941 Chars => Name_Debug, 4942 Pragma_Argument_Associations => 4943 New_List (Relocate_Node (N)))); 4944 Expander_Mode_Restore; 4945 end if; 4946 end Debug; 4947 4948 ------------------- 4949 -- Discard_Names -- 4950 ------------------- 4951 4952 -- pragma Discard_Names [([On =>] LOCAL_NAME)]; 4953 4954 when Pragma_Discard_Names => Discard_Names : declare 4955 E_Id : Entity_Id; 4956 E : Entity_Id; 4957 4958 begin 4959 Check_Ada_83_Warning; 4960 4961 -- Deal with configuration pragma case 4962 4963 if Arg_Count = 0 and then Is_Configuration_Pragma then 4964 Global_Discard_Names := True; 4965 return; 4966 4967 -- Otherwise, check correct appropriate context 4968 4969 else 4970 Check_Is_In_Decl_Part_Or_Package_Spec; 4971 4972 if Arg_Count = 0 then 4973 4974 -- If there is no parameter, then from now on this pragma 4975 -- applies to any enumeration, exception or tagged type 4976 -- defined in the current declarative part. 4977 4978 Set_Discard_Names (Current_Scope); 4979 return; 4980 4981 else 4982 Check_Arg_Count (1); 4983 Check_Optional_Identifier (Arg1, Name_On); 4984 Check_Arg_Is_Local_Name (Arg1); 4985 E_Id := Expression (Arg1); 4986 4987 if Etype (E_Id) = Any_Type then 4988 return; 4989 else 4990 E := Entity (E_Id); 4991 end if; 4992 4993 if (Is_First_Subtype (E) 4994 and then (Is_Enumeration_Type (E) 4995 or else Is_Tagged_Type (E))) 4996 or else Ekind (E) = E_Exception 4997 then 4998 Set_Discard_Names (E); 4999 else 5000 Error_Pragma_Arg 5001 ("inappropriate entity for pragma%", Arg1); 5002 end if; 5003 end if; 5004 end if; 5005 end Discard_Names; 5006 5007 --------------- 5008 -- Elaborate -- 5009 --------------- 5010 5011 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME}); 5012 5013 when Pragma_Elaborate => Elaborate : declare 5014 Plist : List_Id; 5015 Parent_Node : Node_Id; 5016 Arg : Node_Id; 5017 Citem : Node_Id; 5018 5019 begin 5020 -- Pragma must be in context items list of a compilation unit 5021 5022 if not Is_List_Member (N) then 5023 Pragma_Misplaced; 5024 return; 5025 5026 else 5027 Plist := List_Containing (N); 5028 Parent_Node := Parent (Plist); 5029 5030 if Parent_Node = Empty 5031 or else Nkind (Parent_Node) /= N_Compilation_Unit 5032 or else Context_Items (Parent_Node) /= Plist 5033 then 5034 Pragma_Misplaced; 5035 return; 5036 end if; 5037 end if; 5038 5039 -- Must be at least one argument 5040 5041 if Arg_Count = 0 then 5042 Error_Pragma ("pragma% requires at least one argument"); 5043 end if; 5044 5045 -- In Ada 83 mode, there can be no items following it in the 5046 -- context list except other pragmas and implicit with clauses 5047 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this 5048 -- placement rule does not apply. 5049 5050 if Ada_83 and then Comes_From_Source (N) then 5051 Citem := Next (N); 5052 5053 while Present (Citem) loop 5054 if Nkind (Citem) = N_Pragma 5055 or else (Nkind (Citem) = N_With_Clause 5056 and then Implicit_With (Citem)) 5057 then 5058 null; 5059 else 5060 Error_Pragma 5061 ("(Ada 83) pragma% must be at end of context clause"); 5062 end if; 5063 5064 Next (Citem); 5065 end loop; 5066 end if; 5067 5068 -- Finally, the arguments must all be units mentioned in a with 5069 -- clause in the same context clause. Note we already checked 5070 -- (in Par.Prag) that the arguments are either identifiers or 5071 5072 Arg := Arg1; 5073 Outer : while Present (Arg) loop 5074 Citem := First (Plist); 5075 5076 Inner : while Citem /= N loop 5077 if Nkind (Citem) = N_With_Clause 5078 and then Same_Name (Name (Citem), Expression (Arg)) 5079 then 5080 Set_Elaborate_Present (Citem, True); 5081 Set_Unit_Name (Expression (Arg), Name (Citem)); 5082 Set_Suppress_Elaboration_Warnings (Entity (Name (Citem))); 5083 exit Inner; 5084 end if; 5085 5086 Next (Citem); 5087 end loop Inner; 5088 5089 if Citem = N then 5090 Error_Pragma_Arg 5091 ("argument of pragma% is not with'ed unit", Arg); 5092 end if; 5093 5094 Next (Arg); 5095 end loop Outer; 5096 5097 -- Give a warning if operating in static mode with -gnatwl 5098 -- (elaboration warnings eanbled) switch set. 5099 5100 if Elab_Warnings and not Dynamic_Elaboration_Checks then 5101 Error_Msg_N 5102 ("?use of pragma Elaborate may not be safe", N); 5103 Error_Msg_N 5104 ("?use pragma Elaborate_All instead if possible", N); 5105 end if; 5106 end Elaborate; 5107 5108 ------------------- 5109 -- Elaborate_All -- 5110 ------------------- 5111 5112 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME}); 5113 5114 when Pragma_Elaborate_All => Elaborate_All : declare 5115 Plist : List_Id; 5116 Parent_Node : Node_Id; 5117 Arg : Node_Id; 5118 Citem : Node_Id; 5119 5120 begin 5121 Check_Ada_83_Warning; 5122 5123 -- Pragma must be in context items list of a compilation unit 5124 5125 if not Is_List_Member (N) then 5126 Pragma_Misplaced; 5127 return; 5128 5129 else 5130 Plist := List_Containing (N); 5131 Parent_Node := Parent (Plist); 5132 5133 if Parent_Node = Empty 5134 or else Nkind (Parent_Node) /= N_Compilation_Unit 5135 or else Context_Items (Parent_Node) /= Plist 5136 then 5137 Pragma_Misplaced; 5138 return; 5139 end if; 5140 end if; 5141 5142 -- Must be at least one argument 5143 5144 if Arg_Count = 0 then 5145 Error_Pragma ("pragma% requires at least one argument"); 5146 end if; 5147 5148 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not 5149 -- have to appear at the end of the context clause, but may 5150 -- appear mixed in with other items, even in Ada 83 mode. 5151 5152 -- Final check: the arguments must all be units mentioned in 5153 -- a with clause in the same context clause. Note that we 5154 -- already checked (in Par.Prag) that all the arguments are 5155 -- either identifiers or selected components. 5156 5157 Arg := Arg1; 5158 Outr : while Present (Arg) loop 5159 Citem := First (Plist); 5160 5161 Innr : while Citem /= N loop 5162 if Nkind (Citem) = N_With_Clause 5163 and then Same_Name (Name (Citem), Expression (Arg)) 5164 then 5165 Set_Elaborate_All_Present (Citem, True); 5166 Set_Unit_Name (Expression (Arg), Name (Citem)); 5167 Set_Suppress_Elaboration_Warnings (Entity (Name (Citem))); 5168 exit Innr; 5169 end if; 5170 5171 Next (Citem); 5172 end loop Innr; 5173 5174 if Citem = N then 5175 Set_Error_Posted (N); 5176 Error_Pragma_Arg 5177 ("argument of pragma% is not with'ed unit", Arg); 5178 end if; 5179 5180 Next (Arg); 5181 end loop Outr; 5182 end Elaborate_All; 5183 5184 -------------------- 5185 -- Elaborate_Body -- 5186 -------------------- 5187 5188 -- pragma Elaborate_Body [( library_unit_NAME )]; 5189 5190 when Pragma_Elaborate_Body => Elaborate_Body : declare 5191 Cunit_Node : Node_Id; 5192 Cunit_Ent : Entity_Id; 5193 5194 begin 5195 Check_Ada_83_Warning; 5196 Check_Valid_Library_Unit_Pragma; 5197 5198 if Nkind (N) = N_Null_Statement then 5199 return; 5200 end if; 5201 5202 Cunit_Node := Cunit (Current_Sem_Unit); 5203 Cunit_Ent := Cunit_Entity (Current_Sem_Unit); 5204 5205 if Nkind (Unit (Cunit_Node)) = N_Package_Body 5206 or else 5207 Nkind (Unit (Cunit_Node)) = N_Subprogram_Body 5208 then 5209 Error_Pragma ("pragma% must refer to a spec, not a body"); 5210 else 5211 Set_Body_Required (Cunit_Node, True); 5212 Set_Has_Pragma_Elaborate_Body (Cunit_Ent); 5213 5214 -- If we are in dynamic elaboration mode, then we suppress 5215 -- elaboration warnings for the unit, since it is definitely 5216 -- fine NOT to do dynamic checks at the first level (and such 5217 -- checks will be suppressed because no elaboration boolean 5218 -- is created for Elaborate_Body packages). 5219 5220 -- But in the static model of elaboration, Elaborate_Body is 5221 -- definitely NOT good enough to ensure elaboration safety on 5222 -- its own, since the body may WITH other units that are not 5223 -- safe from an elaboration point of view, so a client must 5224 -- still do an Elaborate_All on such units. 5225 5226 -- Debug flag -gnatdD restores the old behavior of 3.13, 5227 -- where Elaborate_Body always suppressed elab warnings. 5228 5229 if Dynamic_Elaboration_Checks or Debug_Flag_DD then 5230 Set_Suppress_Elaboration_Warnings (Cunit_Ent); 5231 end if; 5232 end if; 5233 end Elaborate_Body; 5234 5235 ------------------------ 5236 -- Elaboration_Checks -- 5237 ------------------------ 5238 5239 -- pragma Elaboration_Checks (Static | Dynamic); 5240 5241 when Pragma_Elaboration_Checks => 5242 GNAT_Pragma; 5243 Check_Arg_Count (1); 5244 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic); 5245 Dynamic_Elaboration_Checks := 5246 (Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic); 5247 5248 --------------- 5249 -- Eliminate -- 5250 --------------- 5251 5252 -- pragma Eliminate ( 5253 -- [Unit_Name =>] IDENTIFIER | 5254 -- SELECTED_COMPONENT 5255 -- [,[Entity =>] IDENTIFIER | 5256 -- SELECTED_COMPONENT | 5257 -- STRING_LITERAL] 5258 -- [,[Parameter_Types =>] PARAMETER_TYPES] 5259 -- [,[Result_Type =>] result_SUBTYPE_NAME] 5260 -- [,[Homonym_Number =>] INTEGER_LITERAL]); 5261 5262 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME}) 5263 -- SUBTYPE_NAME ::= STRING_LITERAL 5264 5265 when Pragma_Eliminate => Eliminate : declare 5266 Args : Args_List (1 .. 5); 5267 Names : constant Name_List (1 .. 5) := ( 5268 Name_Unit_Name, 5269 Name_Entity, 5270 Name_Parameter_Types, 5271 Name_Result_Type, 5272 Name_Homonym_Number); 5273 5274 Unit_Name : Node_Id renames Args (1); 5275 Entity : Node_Id renames Args (2); 5276 Parameter_Types : Node_Id renames Args (3); 5277 Result_Type : Node_Id renames Args (4); 5278 Homonym_Number : Node_Id renames Args (5); 5279 5280 begin 5281 GNAT_Pragma; 5282 Check_Valid_Configuration_Pragma; 5283 Gather_Associations (Names, Args); 5284 5285 if No (Unit_Name) then 5286 Error_Pragma ("missing Unit_Name argument for pragma%"); 5287 end if; 5288 5289 if No (Entity) 5290 and then (Present (Parameter_Types) 5291 or else 5292 Present (Result_Type) 5293 or else 5294 Present (Homonym_Number)) 5295 then 5296 Error_Pragma ("missing Entity argument for pragma%"); 5297 end if; 5298 5299 Process_Eliminate_Pragma 5300 (N, 5301 Unit_Name, 5302 Entity, 5303 Parameter_Types, 5304 Result_Type, 5305 Homonym_Number); 5306 end Eliminate; 5307 5308 -------------------------- 5309 -- Explicit_Overriding -- 5310 -------------------------- 5311 5312 when Pragma_Explicit_Overriding => 5313 Check_Valid_Configuration_Pragma; 5314 Check_Arg_Count (0); 5315 Explicit_Overriding := True; 5316 5317 ------------ 5318 -- Export -- 5319 ------------ 5320 5321 -- pragma Export ( 5322 -- [ Convention =>] convention_IDENTIFIER, 5323 -- [ Entity =>] local_NAME 5324 -- [, [External_Name =>] static_string_EXPRESSION ] 5325 -- [, [Link_Name =>] static_string_EXPRESSION ]); 5326 5327 when Pragma_Export => Export : declare 5328 C : Convention_Id; 5329 Def_Id : Entity_Id; 5330 5331 begin 5332 Check_Ada_83_Warning; 5333 Check_At_Least_N_Arguments (2); 5334 Check_At_Most_N_Arguments (4); 5335 Process_Convention (C, Def_Id); 5336 5337 if Ekind (Def_Id) /= E_Constant then 5338 Note_Possible_Modification (Expression (Arg2)); 5339 end if; 5340 5341 Process_Interface_Name (Def_Id, Arg3, Arg4); 5342 Set_Exported (Def_Id, Arg2); 5343 end Export; 5344 5345 ---------------------- 5346 -- Export_Exception -- 5347 ---------------------- 5348 5349 -- pragma Export_Exception ( 5350 -- [Internal =>] LOCAL_NAME, 5351 -- [, [External =>] EXTERNAL_SYMBOL,] 5352 -- [, [Form =>] Ada | VMS] 5353 -- [, [Code =>] static_integer_EXPRESSION]); 5354 5355 when Pragma_Export_Exception => Export_Exception : declare 5356 Args : Args_List (1 .. 4); 5357 Names : constant Name_List (1 .. 4) := ( 5358 Name_Internal, 5359 Name_External, 5360 Name_Form, 5361 Name_Code); 5362 5363 Internal : Node_Id renames Args (1); 5364 External : Node_Id renames Args (2); 5365 Form : Node_Id renames Args (3); 5366 Code : Node_Id renames Args (4); 5367 5368 begin 5369 if Inside_A_Generic then 5370 Error_Pragma ("pragma% cannot be used for generic entities"); 5371 end if; 5372 5373 Gather_Associations (Names, Args); 5374 Process_Extended_Import_Export_Exception_Pragma ( 5375 Arg_Internal => Internal, 5376 Arg_External => External, 5377 Arg_Form => Form, 5378 Arg_Code => Code); 5379 5380 if not Is_VMS_Exception (Entity (Internal)) then 5381 Set_Exported (Entity (Internal), Internal); 5382 end if; 5383 end Export_Exception; 5384 5385 --------------------- 5386 -- Export_Function -- 5387 --------------------- 5388 5389 -- pragma Export_Function ( 5390 -- [Internal =>] LOCAL_NAME, 5391 -- [, [External =>] EXTERNAL_SYMBOL,] 5392 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 5393 -- [, [Result_Type =>] TYPE_DESIGNATOR] 5394 -- [, [Mechanism =>] MECHANISM] 5395 -- [, [Result_Mechanism =>] MECHANISM_NAME]); 5396 5397 -- EXTERNAL_SYMBOL ::= 5398 -- IDENTIFIER 5399 -- | static_string_EXPRESSION 5400 5401 -- PARAMETER_TYPES ::= 5402 -- null 5403 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 5404 5405 -- TYPE_DESIGNATOR ::= 5406 -- subtype_NAME 5407 -- | subtype_Name ' Access 5408 5409 -- MECHANISM ::= 5410 -- MECHANISM_NAME 5411 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 5412 5413 -- MECHANISM_ASSOCIATION ::= 5414 -- [formal_parameter_NAME =>] MECHANISM_NAME 5415 5416 -- MECHANISM_NAME ::= 5417 -- Value 5418 -- | Reference 5419 -- | Descriptor [([Class =>] CLASS_NAME)] 5420 5421 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca 5422 5423 when Pragma_Export_Function => Export_Function : declare 5424 Args : Args_List (1 .. 6); 5425 Names : constant Name_List (1 .. 6) := ( 5426 Name_Internal, 5427 Name_External, 5428 Name_Parameter_Types, 5429 Name_Result_Type, 5430 Name_Mechanism, 5431 Name_Result_Mechanism); 5432 5433 Internal : Node_Id renames Args (1); 5434 External : Node_Id renames Args (2); 5435 Parameter_Types : Node_Id renames Args (3); 5436 Result_Type : Node_Id renames Args (4); 5437 Mechanism : Node_Id renames Args (5); 5438 Result_Mechanism : Node_Id renames Args (6); 5439 5440 begin 5441 GNAT_Pragma; 5442 Gather_Associations (Names, Args); 5443 Process_Extended_Import_Export_Subprogram_Pragma ( 5444 Arg_Internal => Internal, 5445 Arg_External => External, 5446 Arg_Parameter_Types => Parameter_Types, 5447 Arg_Result_Type => Result_Type, 5448 Arg_Mechanism => Mechanism, 5449 Arg_Result_Mechanism => Result_Mechanism); 5450 end Export_Function; 5451 5452 ------------------- 5453 -- Export_Object -- 5454 ------------------- 5455 5456 -- pragma Export_Object ( 5457 -- [Internal =>] LOCAL_NAME, 5458 -- [, [External =>] EXTERNAL_SYMBOL] 5459 -- [, [Size =>] EXTERNAL_SYMBOL]); 5460 5461 -- EXTERNAL_SYMBOL ::= 5462 -- IDENTIFIER 5463 -- | static_string_EXPRESSION 5464 5465 -- PARAMETER_TYPES ::= 5466 -- null 5467 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 5468 5469 -- TYPE_DESIGNATOR ::= 5470 -- subtype_NAME 5471 -- | subtype_Name ' Access 5472 5473 -- MECHANISM ::= 5474 -- MECHANISM_NAME 5475 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 5476 5477 -- MECHANISM_ASSOCIATION ::= 5478 -- [formal_parameter_NAME =>] MECHANISM_NAME 5479 5480 -- MECHANISM_NAME ::= 5481 -- Value 5482 -- | Reference 5483 -- | Descriptor [([Class =>] CLASS_NAME)] 5484 5485 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca 5486 5487 when Pragma_Export_Object => Export_Object : declare 5488 Args : Args_List (1 .. 3); 5489 Names : constant Name_List (1 .. 3) := ( 5490 Name_Internal, 5491 Name_External, 5492 Name_Size); 5493 5494 Internal : Node_Id renames Args (1); 5495 External : Node_Id renames Args (2); 5496 Size : Node_Id renames Args (3); 5497 5498 begin 5499 GNAT_Pragma; 5500 Gather_Associations (Names, Args); 5501 Process_Extended_Import_Export_Object_Pragma ( 5502 Arg_Internal => Internal, 5503 Arg_External => External, 5504 Arg_Size => Size); 5505 end Export_Object; 5506 5507 ---------------------- 5508 -- Export_Procedure -- 5509 ---------------------- 5510 5511 -- pragma Export_Procedure ( 5512 -- [Internal =>] LOCAL_NAME, 5513 -- [, [External =>] EXTERNAL_SYMBOL,] 5514 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 5515 -- [, [Mechanism =>] MECHANISM]); 5516 5517 -- EXTERNAL_SYMBOL ::= 5518 -- IDENTIFIER 5519 -- | static_string_EXPRESSION 5520 5521 -- PARAMETER_TYPES ::= 5522 -- null 5523 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 5524 5525 -- TYPE_DESIGNATOR ::= 5526 -- subtype_NAME 5527 -- | subtype_Name ' Access 5528 5529 -- MECHANISM ::= 5530 -- MECHANISM_NAME 5531 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 5532 5533 -- MECHANISM_ASSOCIATION ::= 5534 -- [formal_parameter_NAME =>] MECHANISM_NAME 5535 5536 -- MECHANISM_NAME ::= 5537 -- Value 5538 -- | Reference 5539 -- | Descriptor [([Class =>] CLASS_NAME)] 5540 5541 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca 5542 5543 when Pragma_Export_Procedure => Export_Procedure : declare 5544 Args : Args_List (1 .. 4); 5545 Names : constant Name_List (1 .. 4) := ( 5546 Name_Internal, 5547 Name_External, 5548 Name_Parameter_Types, 5549 Name_Mechanism); 5550 5551 Internal : Node_Id renames Args (1); 5552 External : Node_Id renames Args (2); 5553 Parameter_Types : Node_Id renames Args (3); 5554 Mechanism : Node_Id renames Args (4); 5555 5556 begin 5557 GNAT_Pragma; 5558 Gather_Associations (Names, Args); 5559 Process_Extended_Import_Export_Subprogram_Pragma ( 5560 Arg_Internal => Internal, 5561 Arg_External => External, 5562 Arg_Parameter_Types => Parameter_Types, 5563 Arg_Mechanism => Mechanism); 5564 end Export_Procedure; 5565 5566 ------------------ 5567 -- Export_Value -- 5568 ------------------ 5569 5570 -- pragma Export_Value ( 5571 -- [Value =>] static_integer_EXPRESSION, 5572 -- [Link_Name =>] static_string_EXPRESSION); 5573 5574 when Pragma_Export_Value => 5575 GNAT_Pragma; 5576 Check_Arg_Count (2); 5577 5578 Check_Optional_Identifier (Arg1, Name_Value); 5579 Check_Arg_Is_Static_Expression (Arg1, Any_Integer); 5580 5581 Check_Optional_Identifier (Arg2, Name_Link_Name); 5582 Check_Arg_Is_Static_Expression (Arg2, Standard_String); 5583 5584 ----------------------------- 5585 -- Export_Valued_Procedure -- 5586 ----------------------------- 5587 5588 -- pragma Export_Valued_Procedure ( 5589 -- [Internal =>] LOCAL_NAME, 5590 -- [, [External =>] EXTERNAL_SYMBOL,] 5591 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 5592 -- [, [Mechanism =>] MECHANISM]); 5593 5594 -- EXTERNAL_SYMBOL ::= 5595 -- IDENTIFIER 5596 -- | static_string_EXPRESSION 5597 5598 -- PARAMETER_TYPES ::= 5599 -- null 5600 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 5601 5602 -- TYPE_DESIGNATOR ::= 5603 -- subtype_NAME 5604 -- | subtype_Name ' Access 5605 5606 -- MECHANISM ::= 5607 -- MECHANISM_NAME 5608 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 5609 5610 -- MECHANISM_ASSOCIATION ::= 5611 -- [formal_parameter_NAME =>] MECHANISM_NAME 5612 5613 -- MECHANISM_NAME ::= 5614 -- Value 5615 -- | Reference 5616 -- | Descriptor [([Class =>] CLASS_NAME)] 5617 5618 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca 5619 5620 when Pragma_Export_Valued_Procedure => 5621 Export_Valued_Procedure : declare 5622 Args : Args_List (1 .. 4); 5623 Names : constant Name_List (1 .. 4) := ( 5624 Name_Internal, 5625 Name_External, 5626 Name_Parameter_Types, 5627 Name_Mechanism); 5628 5629 Internal : Node_Id renames Args (1); 5630 External : Node_Id renames Args (2); 5631 Parameter_Types : Node_Id renames Args (3); 5632 Mechanism : Node_Id renames Args (4); 5633 5634 begin 5635 GNAT_Pragma; 5636 Gather_Associations (Names, Args); 5637 Process_Extended_Import_Export_Subprogram_Pragma ( 5638 Arg_Internal => Internal, 5639 Arg_External => External, 5640 Arg_Parameter_Types => Parameter_Types, 5641 Arg_Mechanism => Mechanism); 5642 end Export_Valued_Procedure; 5643 5644 ------------------- 5645 -- Extend_System -- 5646 ------------------- 5647 5648 -- pragma Extend_System ([Name =>] Identifier); 5649 5650 when Pragma_Extend_System => Extend_System : declare 5651 begin 5652 GNAT_Pragma; 5653 Check_Valid_Configuration_Pragma; 5654 Check_Arg_Count (1); 5655 Check_Optional_Identifier (Arg1, Name_Name); 5656 Check_Arg_Is_Identifier (Arg1); 5657 5658 Get_Name_String (Chars (Expression (Arg1))); 5659 5660 if Name_Len > 4 5661 and then Name_Buffer (1 .. 4) = "aux_" 5662 then 5663 if Present (System_Extend_Pragma_Arg) then 5664 if Chars (Expression (Arg1)) = 5665 Chars (Expression (System_Extend_Pragma_Arg)) 5666 then 5667 null; 5668 else 5669 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg); 5670 Error_Pragma ("pragma% conflicts with that at#"); 5671 end if; 5672 5673 else 5674 System_Extend_Pragma_Arg := Arg1; 5675 5676 if not GNAT_Mode then 5677 System_Extend_Unit := Arg1; 5678 end if; 5679 end if; 5680 else 5681 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx"); 5682 end if; 5683 end Extend_System; 5684 5685 ------------------------ 5686 -- Extensions_Allowed -- 5687 ------------------------ 5688 5689 -- pragma Extensions_Allowed (ON | OFF); 5690 5691 when Pragma_Extensions_Allowed => 5692 GNAT_Pragma; 5693 Check_Arg_Count (1); 5694 Check_No_Identifiers; 5695 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 5696 Extensions_Allowed := (Chars (Expression (Arg1)) = Name_On); 5697 5698 -------------- 5699 -- External -- 5700 -------------- 5701 5702 -- pragma External ( 5703 -- [ Convention =>] convention_IDENTIFIER, 5704 -- [ Entity =>] local_NAME 5705 -- [, [External_Name =>] static_string_EXPRESSION ] 5706 -- [, [Link_Name =>] static_string_EXPRESSION ]); 5707 5708 when Pragma_External => External : declare 5709 C : Convention_Id; 5710 Def_Id : Entity_Id; 5711 5712 begin 5713 GNAT_Pragma; 5714 Check_At_Least_N_Arguments (2); 5715 Check_At_Most_N_Arguments (4); 5716 Process_Convention (C, Def_Id); 5717 Note_Possible_Modification (Expression (Arg2)); 5718 Process_Interface_Name (Def_Id, Arg3, Arg4); 5719 Set_Exported (Def_Id, Arg2); 5720 end External; 5721 5722 -------------------------- 5723 -- External_Name_Casing -- 5724 -------------------------- 5725 5726 -- pragma External_Name_Casing ( 5727 -- UPPERCASE | LOWERCASE 5728 -- [, AS_IS | UPPERCASE | LOWERCASE]); 5729 5730 when Pragma_External_Name_Casing => 5731 5732 External_Name_Casing : declare 5733 begin 5734 GNAT_Pragma; 5735 Check_No_Identifiers; 5736 5737 if Arg_Count = 2 then 5738 Check_Arg_Is_One_Of 5739 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase); 5740 5741 case Chars (Get_Pragma_Arg (Arg2)) is 5742 when Name_As_Is => 5743 Opt.External_Name_Exp_Casing := As_Is; 5744 5745 when Name_Uppercase => 5746 Opt.External_Name_Exp_Casing := Uppercase; 5747 5748 when Name_Lowercase => 5749 Opt.External_Name_Exp_Casing := Lowercase; 5750 5751 when others => 5752 null; 5753 end case; 5754 5755 else 5756 Check_Arg_Count (1); 5757 end if; 5758 5759 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase); 5760 5761 case Chars (Get_Pragma_Arg (Arg1)) is 5762 when Name_Uppercase => 5763 Opt.External_Name_Imp_Casing := Uppercase; 5764 5765 when Name_Lowercase => 5766 Opt.External_Name_Imp_Casing := Lowercase; 5767 5768 when others => 5769 null; 5770 end case; 5771 end External_Name_Casing; 5772 5773 --------------------------- 5774 -- Finalize_Storage_Only -- 5775 --------------------------- 5776 5777 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME); 5778 5779 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare 5780 Assoc : constant Node_Id := Arg1; 5781 Type_Id : constant Node_Id := Expression (Assoc); 5782 Typ : Entity_Id; 5783 5784 begin 5785 Check_No_Identifiers; 5786 Check_Arg_Count (1); 5787 Check_Arg_Is_Local_Name (Arg1); 5788 5789 Find_Type (Type_Id); 5790 Typ := Entity (Type_Id); 5791 5792 if Typ = Any_Type 5793 or else Rep_Item_Too_Early (Typ, N) 5794 then 5795 return; 5796 else 5797 Typ := Underlying_Type (Typ); 5798 end if; 5799 5800 if not Is_Controlled (Typ) then 5801 Error_Pragma ("pragma% must specify controlled type"); 5802 end if; 5803 5804 Check_First_Subtype (Arg1); 5805 5806 if Finalize_Storage_Only (Typ) then 5807 Error_Pragma ("duplicate pragma%, only one allowed"); 5808 5809 elsif not Rep_Item_Too_Late (Typ, N) then 5810 Set_Finalize_Storage_Only (Base_Type (Typ), True); 5811 end if; 5812 end Finalize_Storage; 5813 5814 -------------------------- 5815 -- Float_Representation -- 5816 -------------------------- 5817 5818 -- pragma Float_Representation (VAX_Float | IEEE_Float); 5819 5820 when Pragma_Float_Representation => Float_Representation : declare 5821 Argx : Node_Id; 5822 Digs : Nat; 5823 Ent : Entity_Id; 5824 5825 begin 5826 GNAT_Pragma; 5827 5828 if Arg_Count = 1 then 5829 Check_Valid_Configuration_Pragma; 5830 else 5831 Check_Arg_Count (2); 5832 Check_Optional_Identifier (Arg2, Name_Entity); 5833 Check_Arg_Is_Local_Name (Arg2); 5834 end if; 5835 5836 Check_No_Identifier (Arg1); 5837 Check_Arg_Is_One_Of (Arg1, Name_VAX_Float, Name_IEEE_Float); 5838 5839 if not OpenVMS_On_Target then 5840 if Chars (Expression (Arg1)) = Name_VAX_Float then 5841 Error_Pragma 5842 ("?pragma% ignored (applies only to Open'V'M'S)"); 5843 end if; 5844 5845 return; 5846 end if; 5847 5848 -- One argument case 5849 5850 if Arg_Count = 1 then 5851 5852 if Chars (Expression (Arg1)) = Name_VAX_Float then 5853 5854 if Opt.Float_Format = 'I' then 5855 Error_Pragma ("'I'E'E'E format previously specified"); 5856 end if; 5857 5858 Opt.Float_Format := 'V'; 5859 5860 else 5861 if Opt.Float_Format = 'V' then 5862 Error_Pragma ("'V'A'X format previously specified"); 5863 end if; 5864 5865 Opt.Float_Format := 'I'; 5866 end if; 5867 5868 Set_Standard_Fpt_Formats; 5869 5870 -- Two argument case 5871 5872 else 5873 Argx := Get_Pragma_Arg (Arg2); 5874 5875 if not Is_Entity_Name (Argx) 5876 or else not Is_Floating_Point_Type (Entity (Argx)) 5877 then 5878 Error_Pragma_Arg 5879 ("second argument of% pragma must be floating-point type", 5880 Arg2); 5881 end if; 5882 5883 Ent := Entity (Argx); 5884 Digs := UI_To_Int (Digits_Value (Ent)); 5885 5886 -- Two arguments, VAX_Float case 5887 5888 if Chars (Expression (Arg1)) = Name_VAX_Float then 5889 5890 case Digs is 5891 when 6 => Set_F_Float (Ent); 5892 when 9 => Set_D_Float (Ent); 5893 when 15 => Set_G_Float (Ent); 5894 5895 when others => 5896 Error_Pragma_Arg 5897 ("wrong digits value, must be 6,9 or 15", Arg2); 5898 end case; 5899 5900 -- Two arguments, IEEE_Float case 5901 5902 else 5903 case Digs is 5904 when 6 => Set_IEEE_Short (Ent); 5905 when 15 => Set_IEEE_Long (Ent); 5906 5907 when others => 5908 Error_Pragma_Arg 5909 ("wrong digits value, must be 6 or 15", Arg2); 5910 end case; 5911 end if; 5912 end if; 5913 end Float_Representation; 5914 5915 ----------- 5916 -- Ident -- 5917 ----------- 5918 5919 -- pragma Ident (static_string_EXPRESSION) 5920 5921 -- Note: pragma Comment shares this processing. Pragma Comment 5922 -- is identical to Ident, except that the restriction of the 5923 -- argument to 31 characters and the placement restrictions 5924 -- are not enforced for pragma Comment. 5925 5926 when Pragma_Ident | Pragma_Comment => Ident : declare 5927 Str : Node_Id; 5928 5929 begin 5930 GNAT_Pragma; 5931 Check_Arg_Count (1); 5932 Check_No_Identifiers; 5933 Check_Arg_Is_Static_Expression (Arg1, Standard_String); 5934 5935 -- For pragma Ident, preserve DEC compatibility by requiring 5936 -- the pragma to appear in a declarative part or package spec. 5937 5938 if Prag_Id = Pragma_Ident then 5939 Check_Is_In_Decl_Part_Or_Package_Spec; 5940 end if; 5941 5942 Str := Expr_Value_S (Expression (Arg1)); 5943 5944 declare 5945 CS : Node_Id; 5946 GP : Node_Id; 5947 5948 begin 5949 GP := Parent (Parent (N)); 5950 5951 if Nkind (GP) = N_Package_Declaration 5952 or else 5953 Nkind (GP) = N_Generic_Package_Declaration 5954 then 5955 GP := Parent (GP); 5956 end if; 5957 5958 -- If we have a compilation unit, then record the ident 5959 -- value, checking for improper duplication. 5960 5961 if Nkind (GP) = N_Compilation_Unit then 5962 CS := Ident_String (Current_Sem_Unit); 5963 5964 if Present (CS) then 5965 5966 -- For Ident, we do not permit multiple instances 5967 5968 if Prag_Id = Pragma_Ident then 5969 Error_Pragma ("duplicate% pragma not permitted"); 5970 5971 -- For Comment, we concatenate the string, unless we 5972 -- want to preserve the tree structure for ASIS. 5973 5974 elsif not ASIS_Mode then 5975 Start_String (Strval (CS)); 5976 Store_String_Char (' '); 5977 Store_String_Chars (Strval (Str)); 5978 Set_Strval (CS, End_String); 5979 end if; 5980 5981 else 5982 -- In VMS, the effect of IDENT is achieved by passing 5983 -- IDENTIFICATION=name as a --for-linker switch. 5984 5985 if OpenVMS_On_Target then 5986 Start_String; 5987 Store_String_Chars 5988 ("--for-linker=IDENTIFICATION="); 5989 String_To_Name_Buffer (Strval (Str)); 5990 Store_String_Chars (Name_Buffer (1 .. Name_Len)); 5991 5992 -- Only the last processed IDENT is saved. The main 5993 -- purpose is so an IDENT associated with a main 5994 -- procedure will be used in preference to an IDENT 5995 -- associated with a with'd package. 5996 5997 Replace_Linker_Option_String 5998 (End_String, "--for-linker=IDENTIFICATION="); 5999 end if; 6000 6001 Set_Ident_String (Current_Sem_Unit, Str); 6002 end if; 6003 6004 -- For subunits, we just ignore the Ident, since in GNAT 6005 -- these are not separate object files, and hence not 6006 -- separate units in the unit table. 6007 6008 elsif Nkind (GP) = N_Subunit then 6009 null; 6010 6011 -- Otherwise we have a misplaced pragma Ident, but we ignore 6012 -- this if we are in an instantiation, since it comes from 6013 -- a generic, and has no relevance to the instantiation. 6014 6015 elsif Prag_Id = Pragma_Ident then 6016 if Instantiation_Location (Loc) = No_Location then 6017 Error_Pragma ("pragma% only allowed at outer level"); 6018 end if; 6019 end if; 6020 end; 6021 end Ident; 6022 6023 ------------ 6024 -- Import -- 6025 ------------ 6026 6027 -- pragma Import ( 6028 -- [ Convention =>] convention_IDENTIFIER, 6029 -- [ Entity =>] local_NAME 6030 -- [, [External_Name =>] static_string_EXPRESSION ] 6031 -- [, [Link_Name =>] static_string_EXPRESSION ]); 6032 6033 when Pragma_Import => 6034 Check_Ada_83_Warning; 6035 Check_At_Least_N_Arguments (2); 6036 Check_At_Most_N_Arguments (4); 6037 Process_Import_Or_Interface; 6038 6039 ---------------------- 6040 -- Import_Exception -- 6041 ---------------------- 6042 6043 -- pragma Import_Exception ( 6044 -- [Internal =>] LOCAL_NAME, 6045 -- [, [External =>] EXTERNAL_SYMBOL,] 6046 -- [, [Form =>] Ada | VMS] 6047 -- [, [Code =>] static_integer_EXPRESSION]); 6048 6049 when Pragma_Import_Exception => Import_Exception : declare 6050 Args : Args_List (1 .. 4); 6051 Names : constant Name_List (1 .. 4) := ( 6052 Name_Internal, 6053 Name_External, 6054 Name_Form, 6055 Name_Code); 6056 6057 Internal : Node_Id renames Args (1); 6058 External : Node_Id renames Args (2); 6059 Form : Node_Id renames Args (3); 6060 Code : Node_Id renames Args (4); 6061 6062 begin 6063 Gather_Associations (Names, Args); 6064 6065 if Present (External) and then Present (Code) then 6066 Error_Pragma 6067 ("cannot give both External and Code options for pragma%"); 6068 end if; 6069 6070 Process_Extended_Import_Export_Exception_Pragma ( 6071 Arg_Internal => Internal, 6072 Arg_External => External, 6073 Arg_Form => Form, 6074 Arg_Code => Code); 6075 6076 if not Is_VMS_Exception (Entity (Internal)) then 6077 Set_Imported (Entity (Internal)); 6078 end if; 6079 end Import_Exception; 6080 6081 --------------------- 6082 -- Import_Function -- 6083 --------------------- 6084 6085 -- pragma Import_Function ( 6086 -- [Internal =>] LOCAL_NAME, 6087 -- [, [External =>] EXTERNAL_SYMBOL] 6088 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 6089 -- [, [Result_Type =>] SUBTYPE_MARK] 6090 -- [, [Mechanism =>] MECHANISM] 6091 -- [, [Result_Mechanism =>] MECHANISM_NAME] 6092 -- [, [First_Optional_Parameter =>] IDENTIFIER]); 6093 6094 -- EXTERNAL_SYMBOL ::= 6095 -- IDENTIFIER 6096 -- | static_string_EXPRESSION 6097 6098 -- PARAMETER_TYPES ::= 6099 -- null 6100 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 6101 6102 -- TYPE_DESIGNATOR ::= 6103 -- subtype_NAME 6104 -- | subtype_Name ' Access 6105 6106 -- MECHANISM ::= 6107 -- MECHANISM_NAME 6108 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 6109 6110 -- MECHANISM_ASSOCIATION ::= 6111 -- [formal_parameter_NAME =>] MECHANISM_NAME 6112 6113 -- MECHANISM_NAME ::= 6114 -- Value 6115 -- | Reference 6116 -- | Descriptor [([Class =>] CLASS_NAME)] 6117 6118 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca 6119 6120 when Pragma_Import_Function => Import_Function : declare 6121 Args : Args_List (1 .. 7); 6122 Names : constant Name_List (1 .. 7) := ( 6123 Name_Internal, 6124 Name_External, 6125 Name_Parameter_Types, 6126 Name_Result_Type, 6127 Name_Mechanism, 6128 Name_Result_Mechanism, 6129 Name_First_Optional_Parameter); 6130 6131 Internal : Node_Id renames Args (1); 6132 External : Node_Id renames Args (2); 6133 Parameter_Types : Node_Id renames Args (3); 6134 Result_Type : Node_Id renames Args (4); 6135 Mechanism : Node_Id renames Args (5); 6136 Result_Mechanism : Node_Id renames Args (6); 6137 First_Optional_Parameter : Node_Id renames Args (7); 6138 6139 begin 6140 GNAT_Pragma; 6141 Gather_Associations (Names, Args); 6142 Process_Extended_Import_Export_Subprogram_Pragma ( 6143 Arg_Internal => Internal, 6144 Arg_External => External, 6145 Arg_Parameter_Types => Parameter_Types, 6146 Arg_Result_Type => Result_Type, 6147 Arg_Mechanism => Mechanism, 6148 Arg_Result_Mechanism => Result_Mechanism, 6149 Arg_First_Optional_Parameter => First_Optional_Parameter); 6150 end Import_Function; 6151 6152 ------------------- 6153 -- Import_Object -- 6154 ------------------- 6155 6156 -- pragma Import_Object ( 6157 -- [Internal =>] LOCAL_NAME, 6158 -- [, [External =>] EXTERNAL_SYMBOL] 6159 -- [, [Size =>] EXTERNAL_SYMBOL]); 6160 6161 -- EXTERNAL_SYMBOL ::= 6162 -- IDENTIFIER 6163 -- | static_string_EXPRESSION 6164 6165 when Pragma_Import_Object => Import_Object : declare 6166 Args : Args_List (1 .. 3); 6167 Names : constant Name_List (1 .. 3) := ( 6168 Name_Internal, 6169 Name_External, 6170 Name_Size); 6171 6172 Internal : Node_Id renames Args (1); 6173 External : Node_Id renames Args (2); 6174 Size : Node_Id renames Args (3); 6175 6176 begin 6177 GNAT_Pragma; 6178 Gather_Associations (Names, Args); 6179 Process_Extended_Import_Export_Object_Pragma ( 6180 Arg_Internal => Internal, 6181 Arg_External => External, 6182 Arg_Size => Size); 6183 end Import_Object; 6184 6185 ---------------------- 6186 -- Import_Procedure -- 6187 ---------------------- 6188 6189 -- pragma Import_Procedure ( 6190 -- [Internal =>] LOCAL_NAME, 6191 -- [, [External =>] EXTERNAL_SYMBOL] 6192 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 6193 -- [, [Mechanism =>] MECHANISM] 6194 -- [, [First_Optional_Parameter =>] IDENTIFIER]); 6195 6196 -- EXTERNAL_SYMBOL ::= 6197 -- IDENTIFIER 6198 -- | static_string_EXPRESSION 6199 6200 -- PARAMETER_TYPES ::= 6201 -- null 6202 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 6203 6204 -- TYPE_DESIGNATOR ::= 6205 -- subtype_NAME 6206 -- | subtype_Name ' Access 6207 6208 -- MECHANISM ::= 6209 -- MECHANISM_NAME 6210 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 6211 6212 -- MECHANISM_ASSOCIATION ::= 6213 -- [formal_parameter_NAME =>] MECHANISM_NAME 6214 6215 -- MECHANISM_NAME ::= 6216 -- Value 6217 -- | Reference 6218 -- | Descriptor [([Class =>] CLASS_NAME)] 6219 6220 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca 6221 6222 when Pragma_Import_Procedure => Import_Procedure : declare 6223 Args : Args_List (1 .. 5); 6224 Names : constant Name_List (1 .. 5) := ( 6225 Name_Internal, 6226 Name_External, 6227 Name_Parameter_Types, 6228 Name_Mechanism, 6229 Name_First_Optional_Parameter); 6230 6231 Internal : Node_Id renames Args (1); 6232 External : Node_Id renames Args (2); 6233 Parameter_Types : Node_Id renames Args (3); 6234 Mechanism : Node_Id renames Args (4); 6235 First_Optional_Parameter : Node_Id renames Args (5); 6236 6237 begin 6238 GNAT_Pragma; 6239 Gather_Associations (Names, Args); 6240 Process_Extended_Import_Export_Subprogram_Pragma ( 6241 Arg_Internal => Internal, 6242 Arg_External => External, 6243 Arg_Parameter_Types => Parameter_Types, 6244 Arg_Mechanism => Mechanism, 6245 Arg_First_Optional_Parameter => First_Optional_Parameter); 6246 end Import_Procedure; 6247 6248 ----------------------------- 6249 -- Import_Valued_Procedure -- 6250 ----------------------------- 6251 6252 -- pragma Import_Valued_Procedure ( 6253 -- [Internal =>] LOCAL_NAME, 6254 -- [, [External =>] EXTERNAL_SYMBOL] 6255 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 6256 -- [, [Mechanism =>] MECHANISM] 6257 -- [, [First_Optional_Parameter =>] IDENTIFIER]); 6258 6259 -- EXTERNAL_SYMBOL ::= 6260 -- IDENTIFIER 6261 -- | static_string_EXPRESSION 6262 6263 -- PARAMETER_TYPES ::= 6264 -- null 6265 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 6266 6267 -- TYPE_DESIGNATOR ::= 6268 -- subtype_NAME 6269 -- | subtype_Name ' Access 6270 6271 -- MECHANISM ::= 6272 -- MECHANISM_NAME 6273 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 6274 6275 -- MECHANISM_ASSOCIATION ::= 6276 -- [formal_parameter_NAME =>] MECHANISM_NAME 6277 6278 -- MECHANISM_NAME ::= 6279 -- Value 6280 -- | Reference 6281 -- | Descriptor [([Class =>] CLASS_NAME)] 6282 6283 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca 6284 6285 when Pragma_Import_Valued_Procedure => 6286 Import_Valued_Procedure : declare 6287 Args : Args_List (1 .. 5); 6288 Names : constant Name_List (1 .. 5) := ( 6289 Name_Internal, 6290 Name_External, 6291 Name_Parameter_Types, 6292 Name_Mechanism, 6293 Name_First_Optional_Parameter); 6294 6295 Internal : Node_Id renames Args (1); 6296 External : Node_Id renames Args (2); 6297 Parameter_Types : Node_Id renames Args (3); 6298 Mechanism : Node_Id renames Args (4); 6299 First_Optional_Parameter : Node_Id renames Args (5); 6300 6301 begin 6302 GNAT_Pragma; 6303 Gather_Associations (Names, Args); 6304 Process_Extended_Import_Export_Subprogram_Pragma ( 6305 Arg_Internal => Internal, 6306 Arg_External => External, 6307 Arg_Parameter_Types => Parameter_Types, 6308 Arg_Mechanism => Mechanism, 6309 Arg_First_Optional_Parameter => First_Optional_Parameter); 6310 end Import_Valued_Procedure; 6311 6312 ------------------------ 6313 -- Initialize_Scalars -- 6314 ------------------------ 6315 6316 -- pragma Initialize_Scalars; 6317 6318 when Pragma_Initialize_Scalars => 6319 GNAT_Pragma; 6320 Check_Arg_Count (0); 6321 Check_Valid_Configuration_Pragma; 6322 Check_Restriction (No_Initialize_Scalars, N); 6323 6324 if not Restrictions (No_Initialize_Scalars) then 6325 Init_Or_Norm_Scalars := True; 6326 Initialize_Scalars := True; 6327 end if; 6328 6329 ------------ 6330 -- Inline -- 6331 ------------ 6332 6333 -- pragma Inline ( NAME {, NAME} ); 6334 6335 when Pragma_Inline => 6336 6337 -- Pragma is active if inlining option is active 6338 6339 if Inline_Active then 6340 Process_Inline (True); 6341 6342 -- Pragma is active in a predefined file in config run time mode 6343 6344 elsif Configurable_Run_Time_Mode 6345 and then 6346 Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit)) 6347 then 6348 Process_Inline (True); 6349 6350 -- Otherwise inlining is not active 6351 6352 else 6353 Process_Inline (False); 6354 end if; 6355 6356 ------------------- 6357 -- Inline_Always -- 6358 ------------------- 6359 6360 -- pragma Inline_Always ( NAME {, NAME} ); 6361 6362 when Pragma_Inline_Always => 6363 Process_Inline (True); 6364 6365 -------------------- 6366 -- Inline_Generic -- 6367 -------------------- 6368 6369 -- pragma Inline_Generic (NAME {, NAME}); 6370 6371 when Pragma_Inline_Generic => 6372 Process_Generic_List; 6373 6374 ---------------------- 6375 -- Inspection_Point -- 6376 ---------------------- 6377 6378 -- pragma Inspection_Point [(object_NAME {, object_NAME})]; 6379 6380 when Pragma_Inspection_Point => Inspection_Point : declare 6381 Arg : Node_Id; 6382 Exp : Node_Id; 6383 6384 begin 6385 if Arg_Count > 0 then 6386 Arg := Arg1; 6387 loop 6388 Exp := Expression (Arg); 6389 Analyze (Exp); 6390 6391 if not Is_Entity_Name (Exp) 6392 or else not Is_Object (Entity (Exp)) 6393 then 6394 Error_Pragma_Arg ("object name required", Arg); 6395 end if; 6396 6397 Next (Arg); 6398 exit when No (Arg); 6399 end loop; 6400 end if; 6401 end Inspection_Point; 6402 6403 --------------- 6404 -- Interface -- 6405 --------------- 6406 6407 -- pragma Interface ( 6408 -- convention_IDENTIFIER, 6409 -- local_NAME ); 6410 6411 when Pragma_Interface => 6412 GNAT_Pragma; 6413 Check_Arg_Count (2); 6414 Check_No_Identifiers; 6415 Process_Import_Or_Interface; 6416 6417 -------------------- 6418 -- Interface_Name -- 6419 -------------------- 6420 6421 -- pragma Interface_Name ( 6422 -- [ Entity =>] local_NAME 6423 -- [,[External_Name =>] static_string_EXPRESSION ] 6424 -- [,[Link_Name =>] static_string_EXPRESSION ]); 6425 6426 when Pragma_Interface_Name => Interface_Name : declare 6427 Id : Node_Id; 6428 Def_Id : Entity_Id; 6429 Hom_Id : Entity_Id; 6430 Found : Boolean; 6431 6432 begin 6433 GNAT_Pragma; 6434 Check_At_Least_N_Arguments (2); 6435 Check_At_Most_N_Arguments (3); 6436 Id := Expression (Arg1); 6437 Analyze (Id); 6438 6439 if not Is_Entity_Name (Id) then 6440 Error_Pragma_Arg 6441 ("first argument for pragma% must be entity name", Arg1); 6442 elsif Etype (Id) = Any_Type then 6443 return; 6444 else 6445 Def_Id := Entity (Id); 6446 end if; 6447 6448 -- Special DEC-compatible processing for the object case, 6449 -- forces object to be imported. 6450 6451 if Ekind (Def_Id) = E_Variable then 6452 Kill_Size_Check_Code (Def_Id); 6453 Note_Possible_Modification (Id); 6454 6455 -- Initialization is not allowed for imported variable 6456 6457 if Present (Expression (Parent (Def_Id))) 6458 and then Comes_From_Source (Expression (Parent (Def_Id))) 6459 then 6460 Error_Msg_Sloc := Sloc (Def_Id); 6461 Error_Pragma_Arg 6462 ("no initialization allowed for declaration of& #", 6463 Arg2); 6464 6465 else 6466 -- For compatibility, support VADS usage of providing both 6467 -- pragmas Interface and Interface_Name to obtain the effect 6468 -- of a single Import pragma. 6469 6470 if Is_Imported (Def_Id) 6471 and then Present (First_Rep_Item (Def_Id)) 6472 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma 6473 and then Chars (First_Rep_Item (Def_Id)) = Name_Interface 6474 then 6475 null; 6476 else 6477 Set_Imported (Def_Id); 6478 end if; 6479 6480 Set_Is_Public (Def_Id); 6481 Process_Interface_Name (Def_Id, Arg2, Arg3); 6482 end if; 6483 6484 -- Otherwise must be subprogram 6485 6486 elsif not Is_Subprogram (Def_Id) then 6487 Error_Pragma_Arg 6488 ("argument of pragma% is not subprogram", Arg1); 6489 6490 else 6491 Check_At_Most_N_Arguments (3); 6492 Hom_Id := Def_Id; 6493 Found := False; 6494 6495 -- Loop through homonyms 6496 6497 loop 6498 Def_Id := Get_Base_Subprogram (Hom_Id); 6499 6500 if Is_Imported (Def_Id) then 6501 Process_Interface_Name (Def_Id, Arg2, Arg3); 6502 Found := True; 6503 end if; 6504 6505 Hom_Id := Homonym (Hom_Id); 6506 6507 exit when No (Hom_Id) 6508 or else Scope (Hom_Id) /= Current_Scope; 6509 end loop; 6510 6511 if not Found then 6512 Error_Pragma_Arg 6513 ("argument of pragma% is not imported subprogram", 6514 Arg1); 6515 end if; 6516 end if; 6517 end Interface_Name; 6518 6519 ----------------------- 6520 -- Interrupt_Handler -- 6521 ----------------------- 6522 6523 -- pragma Interrupt_Handler (handler_NAME); 6524 6525 when Pragma_Interrupt_Handler => 6526 Check_Ada_83_Warning; 6527 Check_Arg_Count (1); 6528 Check_No_Identifiers; 6529 6530 if No_Run_Time_Mode then 6531 Error_Msg_CRT ("Interrupt_Handler pragma", N); 6532 else 6533 Check_Interrupt_Or_Attach_Handler; 6534 Process_Interrupt_Or_Attach_Handler; 6535 end if; 6536 6537 ------------------------ 6538 -- Interrupt_Priority -- 6539 ------------------------ 6540 6541 -- pragma Interrupt_Priority [(EXPRESSION)]; 6542 6543 when Pragma_Interrupt_Priority => Interrupt_Priority : declare 6544 P : constant Node_Id := Parent (N); 6545 Arg : Node_Id; 6546 6547 begin 6548 Check_Ada_83_Warning; 6549 6550 if Arg_Count /= 0 then 6551 Arg := Expression (Arg1); 6552 Check_Arg_Count (1); 6553 Check_No_Identifiers; 6554 6555 -- The expression must be analyzed in the special manner 6556 -- described in "Handling of Default and Per-Object 6557 -- Expressions" in sem.ads. 6558 6559 Analyze_Per_Use_Expression (Arg, RTE (RE_Interrupt_Priority)); 6560 end if; 6561 6562 if Nkind (P) /= N_Task_Definition 6563 and then Nkind (P) /= N_Protected_Definition 6564 then 6565 Pragma_Misplaced; 6566 return; 6567 6568 elsif Has_Priority_Pragma (P) then 6569 Error_Pragma ("duplicate pragma% not allowed"); 6570 6571 else 6572 Set_Has_Priority_Pragma (P, True); 6573 Record_Rep_Item (Defining_Identifier (Parent (P)), N); 6574 end if; 6575 end Interrupt_Priority; 6576 6577 --------------------- 6578 -- Interrupt_State -- 6579 --------------------- 6580 6581 -- pragma Interrupt_State ( 6582 -- [Name =>] INTERRUPT_ID, 6583 -- [State =>] INTERRUPT_STATE); 6584 6585 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION 6586 -- INTERRUPT_STATE => System | Runtime | User 6587 6588 -- Note: if the interrupt id is given as an identifier, then 6589 -- it must be one of the identifiers in Ada.Interrupts.Names. 6590 -- Otherwise it is given as a static integer expression which 6591 -- must be in the range of Ada.Interrupts.Interrupt_ID. 6592 6593 when Pragma_Interrupt_State => Interrupt_State : declare 6594 6595 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID); 6596 -- This is the entity Ada.Interrupts.Interrupt_ID; 6597 6598 State_Type : Character; 6599 -- Set to 's'/'r'/'u' for System/Runtime/User 6600 6601 IST_Num : Pos; 6602 -- Index to entry in Interrupt_States table 6603 6604 Int_Val : Uint; 6605 -- Value of interrupt 6606 6607 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1); 6608 -- The first argument to the pragma 6609 6610 Int_Ent : Entity_Id; 6611 -- Interrupt entity in Ada.Interrupts.Names 6612 6613 begin 6614 GNAT_Pragma; 6615 Check_Arg_Count (2); 6616 6617 Check_Optional_Identifier (Arg1, Name_Name); 6618 Check_Optional_Identifier (Arg2, "state"); 6619 Check_Arg_Is_Identifier (Arg2); 6620 6621 -- First argument is identifier 6622 6623 if Nkind (Arg1X) = N_Identifier then 6624 6625 -- Search list of names in Ada.Interrupts.Names 6626 6627 Int_Ent := First_Entity (RTE (RE_Names)); 6628 loop 6629 if No (Int_Ent) then 6630 Error_Pragma_Arg ("invalid interrupt name", Arg1); 6631 6632 elsif Chars (Int_Ent) = Chars (Arg1X) then 6633 Int_Val := Expr_Value (Constant_Value (Int_Ent)); 6634 exit; 6635 end if; 6636 6637 Next_Entity (Int_Ent); 6638 end loop; 6639 6640 -- First argument is not an identifier, so it must be a 6641 -- static expression of type Ada.Interrupts.Interrupt_ID. 6642 6643 else 6644 Check_Arg_Is_Static_Expression (Arg1, Any_Integer); 6645 Int_Val := Expr_Value (Arg1X); 6646 6647 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id)) 6648 or else 6649 Int_Val > Expr_Value (Type_High_Bound (Int_Id)) 6650 then 6651 Error_Pragma_Arg 6652 ("value not in range of type " & 6653 """Ada.Interrupts.Interrupt_'I'D""", Arg1); 6654 end if; 6655 end if; 6656 6657 -- Check OK state 6658 6659 case Chars (Get_Pragma_Arg (Arg2)) is 6660 when Name_Runtime => State_Type := 'r'; 6661 when Name_System => State_Type := 's'; 6662 when Name_User => State_Type := 'u'; 6663 6664 when others => 6665 Error_Pragma_Arg ("invalid interrupt state", Arg2); 6666 end case; 6667 6668 -- Check if entry is already stored 6669 6670 IST_Num := Interrupt_States.First; 6671 loop 6672 -- If entry not found, add it 6673 6674 if IST_Num > Interrupt_States.Last then 6675 Interrupt_States.Append 6676 ((Interrupt_Number => UI_To_Int (Int_Val), 6677 Interrupt_State => State_Type, 6678 Pragma_Loc => Loc)); 6679 exit; 6680 6681 -- Case of entry for the same entry 6682 6683 elsif Int_Val = Interrupt_States.Table (IST_Num). 6684 Interrupt_Number 6685 then 6686 -- If state matches, done, no need to make redundant entry 6687 6688 exit when 6689 State_Type = Interrupt_States.Table (IST_Num). 6690 Interrupt_State; 6691 6692 -- Otherwise if state does not match, error 6693 6694 Error_Msg_Sloc := 6695 Interrupt_States.Table (IST_Num).Pragma_Loc; 6696 Error_Pragma_Arg 6697 ("state conflicts with that given at #", Arg2); 6698 exit; 6699 end if; 6700 6701 IST_Num := IST_Num + 1; 6702 end loop; 6703 end Interrupt_State; 6704 6705 ---------------------- 6706 -- Java_Constructor -- 6707 ---------------------- 6708 6709 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME); 6710 6711 when Pragma_Java_Constructor => Java_Constructor : declare 6712 Id : Entity_Id; 6713 Def_Id : Entity_Id; 6714 Hom_Id : Entity_Id; 6715 6716 begin 6717 GNAT_Pragma; 6718 Check_Arg_Count (1); 6719 Check_Optional_Identifier (Arg1, Name_Entity); 6720 Check_Arg_Is_Local_Name (Arg1); 6721 6722 Id := Expression (Arg1); 6723 Find_Program_Unit_Name (Id); 6724 6725 -- If we did not find the name, we are done 6726 6727 if Etype (Id) = Any_Type then 6728 return; 6729 end if; 6730 6731 Hom_Id := Entity (Id); 6732 6733 -- Loop through homonyms 6734 6735 loop 6736 Def_Id := Get_Base_Subprogram (Hom_Id); 6737 6738 -- The constructor is required to be a function returning 6739 -- an access type whose designated type has convention Java. 6740 6741 if Ekind (Def_Id) = E_Function 6742 and then Ekind (Etype (Def_Id)) in Access_Kind 6743 and then 6744 (Atree.Convention 6745 (Designated_Type (Etype (Def_Id))) = Convention_Java 6746 or else 6747 Atree.Convention 6748 (Root_Type (Designated_Type (Etype (Def_Id)))) 6749 = Convention_Java) 6750 then 6751 Set_Is_Constructor (Def_Id); 6752 Set_Convention (Def_Id, Convention_Java); 6753 6754 else 6755 Error_Pragma_Arg 6756 ("pragma% requires function returning a 'Java access type", 6757 Arg1); 6758 end if; 6759 6760 Hom_Id := Homonym (Hom_Id); 6761 6762 exit when No (Hom_Id) or else Scope (Hom_Id) /= Current_Scope; 6763 end loop; 6764 end Java_Constructor; 6765 6766 ---------------------- 6767 -- Java_Interface -- 6768 ---------------------- 6769 6770 -- pragma Java_Interface ([Entity =>] LOCAL_NAME); 6771 6772 when Pragma_Java_Interface => Java_Interface : declare 6773 Arg : Node_Id; 6774 Typ : Entity_Id; 6775 6776 begin 6777 GNAT_Pragma; 6778 Check_Arg_Count (1); 6779 Check_Optional_Identifier (Arg1, Name_Entity); 6780 Check_Arg_Is_Local_Name (Arg1); 6781 6782 Arg := Expression (Arg1); 6783 Analyze (Arg); 6784 6785 if Etype (Arg) = Any_Type then 6786 return; 6787 end if; 6788 6789 if not Is_Entity_Name (Arg) 6790 or else not Is_Type (Entity (Arg)) 6791 then 6792 Error_Pragma_Arg ("pragma% requires a type mark", Arg1); 6793 end if; 6794 6795 Typ := Underlying_Type (Entity (Arg)); 6796 6797 -- For now we simply check some of the semantic constraints 6798 -- on the type. This currently leaves out some restrictions 6799 -- on interface types, namely that the parent type must be 6800 -- java.lang.Object.Typ and that all primitives of the type 6801 -- should be declared abstract. ??? 6802 6803 if not Is_Tagged_Type (Typ) or else not Is_Abstract (Typ) then 6804 Error_Pragma_Arg ("pragma% requires an abstract " 6805 & "tagged type", Arg1); 6806 6807 elsif not Has_Discriminants (Typ) 6808 or else Ekind (Etype (First_Discriminant (Typ))) 6809 /= E_Anonymous_Access_Type 6810 or else 6811 not Is_Class_Wide_Type 6812 (Designated_Type (Etype (First_Discriminant (Typ)))) 6813 then 6814 Error_Pragma_Arg 6815 ("type must have a class-wide access discriminant", Arg1); 6816 end if; 6817 end Java_Interface; 6818 6819 ---------------- 6820 -- Keep_Names -- 6821 ---------------- 6822 6823 -- pragma Keep_Names ([On => ] local_NAME); 6824 6825 when Pragma_Keep_Names => Keep_Names : declare 6826 Arg : Node_Id; 6827 6828 begin 6829 GNAT_Pragma; 6830 Check_Arg_Count (1); 6831 Check_Optional_Identifier (Arg1, Name_On); 6832 Check_Arg_Is_Local_Name (Arg1); 6833 6834 Arg := Expression (Arg1); 6835 Analyze (Arg); 6836 6837 if Etype (Arg) = Any_Type then 6838 return; 6839 end if; 6840 6841 if not Is_Entity_Name (Arg) 6842 or else Ekind (Entity (Arg)) /= E_Enumeration_Type 6843 then 6844 Error_Pragma_Arg 6845 ("pragma% requires a local enumeration type", Arg1); 6846 end if; 6847 6848 Set_Discard_Names (Entity (Arg), False); 6849 end Keep_Names; 6850 6851 ------------- 6852 -- License -- 6853 ------------- 6854 6855 -- pragma License (RESTRICTED | UNRESRICTED | GPL | MODIFIED_GPL); 6856 6857 when Pragma_License => 6858 GNAT_Pragma; 6859 Check_Arg_Count (1); 6860 Check_No_Identifiers; 6861 Check_Valid_Configuration_Pragma; 6862 Check_Arg_Is_Identifier (Arg1); 6863 6864 declare 6865 Sind : constant Source_File_Index := 6866 Source_Index (Current_Sem_Unit); 6867 6868 begin 6869 case Chars (Get_Pragma_Arg (Arg1)) is 6870 when Name_GPL => 6871 Set_License (Sind, GPL); 6872 6873 when Name_Modified_GPL => 6874 Set_License (Sind, Modified_GPL); 6875 6876 when Name_Restricted => 6877 Set_License (Sind, Restricted); 6878 6879 when Name_Unrestricted => 6880 Set_License (Sind, Unrestricted); 6881 6882 when others => 6883 Error_Pragma_Arg ("invalid license name", Arg1); 6884 end case; 6885 end; 6886 6887 --------------- 6888 -- Link_With -- 6889 --------------- 6890 6891 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION}); 6892 6893 when Pragma_Link_With => Link_With : declare 6894 Arg : Node_Id; 6895 6896 begin 6897 GNAT_Pragma; 6898 6899 if Operating_Mode = Generate_Code 6900 and then In_Extended_Main_Source_Unit (N) 6901 then 6902 Check_At_Least_N_Arguments (1); 6903 Check_No_Identifiers; 6904 Check_Is_In_Decl_Part_Or_Package_Spec; 6905 Check_Arg_Is_Static_Expression (Arg1, Standard_String); 6906 Start_String; 6907 6908 Arg := Arg1; 6909 while Present (Arg) loop 6910 Check_Arg_Is_Static_Expression (Arg, Standard_String); 6911 6912 -- Store argument, converting sequences of spaces 6913 -- to a single null character (this is one of the 6914 -- differences in processing between Link_With 6915 -- and Linker_Options). 6916 6917 declare 6918 C : constant Char_Code := Get_Char_Code (' '); 6919 S : constant String_Id := 6920 Strval (Expr_Value_S (Expression (Arg))); 6921 L : constant Nat := String_Length (S); 6922 F : Nat := 1; 6923 6924 procedure Skip_Spaces; 6925 -- Advance F past any spaces 6926 6927 procedure Skip_Spaces is 6928 begin 6929 while F <= L and then Get_String_Char (S, F) = C loop 6930 F := F + 1; 6931 end loop; 6932 end Skip_Spaces; 6933 6934 begin 6935 Skip_Spaces; -- skip leading spaces 6936 6937 -- Loop through characters, changing any embedded 6938 -- sequence of spaces to a single null character 6939 -- (this is how Link_With/Linker_Options differ) 6940 6941 while F <= L loop 6942 if Get_String_Char (S, F) = C then 6943 Skip_Spaces; 6944 exit when F > L; 6945 Store_String_Char (ASCII.NUL); 6946 6947 else 6948 Store_String_Char (Get_String_Char (S, F)); 6949 F := F + 1; 6950 end if; 6951 end loop; 6952 end; 6953 6954 Arg := Next (Arg); 6955 6956 if Present (Arg) then 6957 Store_String_Char (ASCII.NUL); 6958 end if; 6959 end loop; 6960 6961 Store_Linker_Option_String (End_String); 6962 end if; 6963 end Link_With; 6964 6965 ------------------ 6966 -- Linker_Alias -- 6967 ------------------ 6968 6969 -- pragma Linker_Alias ( 6970 -- [Entity =>] LOCAL_NAME 6971 -- [Alias =>] static_string_EXPRESSION); 6972 6973 when Pragma_Linker_Alias => 6974 GNAT_Pragma; 6975 Check_Arg_Count (2); 6976 Check_Optional_Identifier (Arg1, Name_Entity); 6977 Check_Optional_Identifier (Arg2, "alias"); 6978 Check_Arg_Is_Library_Level_Local_Name (Arg1); 6979 Check_Arg_Is_Static_Expression (Arg2, Standard_String); 6980 6981 -- The only processing required is to link this item on to the 6982 -- list of rep items for the given entity. This is accomplished 6983 -- by the call to Rep_Item_Too_Late (when no error is detected 6984 -- and False is returned). 6985 6986 if Rep_Item_Too_Late (Entity (Expression (Arg1)), N) then 6987 return; 6988 else 6989 Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1))); 6990 end if; 6991 6992 -------------------- 6993 -- Linker_Options -- 6994 -------------------- 6995 6996 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION}); 6997 6998 when Pragma_Linker_Options => Linker_Options : declare 6999 Arg : Node_Id; 7000 7001 begin 7002 Check_Ada_83_Warning; 7003 Check_No_Identifiers; 7004 Check_Arg_Count (1); 7005 Check_Is_In_Decl_Part_Or_Package_Spec; 7006 7007 if Operating_Mode = Generate_Code 7008 and then In_Extended_Main_Source_Unit (N) 7009 then 7010 Check_Arg_Is_Static_Expression (Arg1, Standard_String); 7011 Start_String (Strval (Expr_Value_S (Expression (Arg1)))); 7012 7013 Arg := Arg2; 7014 while Present (Arg) loop 7015 Check_Arg_Is_Static_Expression (Arg, Standard_String); 7016 Store_String_Char (ASCII.NUL); 7017 Store_String_Chars 7018 (Strval (Expr_Value_S (Expression (Arg)))); 7019 Arg := Next (Arg); 7020 end loop; 7021 7022 Store_Linker_Option_String (End_String); 7023 end if; 7024 end Linker_Options; 7025 7026 -------------------- 7027 -- Linker_Section -- 7028 -------------------- 7029 7030 -- pragma Linker_Section ( 7031 -- [Entity =>] LOCAL_NAME 7032 -- [Section =>] static_string_EXPRESSION); 7033 7034 when Pragma_Linker_Section => 7035 GNAT_Pragma; 7036 Check_Arg_Count (2); 7037 Check_Optional_Identifier (Arg1, Name_Entity); 7038 Check_Optional_Identifier (Arg2, Name_Section); 7039 Check_Arg_Is_Library_Level_Local_Name (Arg1); 7040 Check_Arg_Is_Static_Expression (Arg2, Standard_String); 7041 7042 -- The only processing required is to link this item on to the 7043 -- list of rep items for the given entity. This is accomplished 7044 -- by the call to Rep_Item_Too_Late (when no error is detected 7045 -- and False is returned). 7046 7047 if Rep_Item_Too_Late (Entity (Expression (Arg1)), N) then 7048 return; 7049 else 7050 Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1))); 7051 end if; 7052 7053 ---------- 7054 -- List -- 7055 ---------- 7056 7057 -- pragma List (On | Off) 7058 7059 -- There is nothing to do here, since we did all the processing 7060 -- for this pragma in Par.Prag (so that it works properly even in 7061 -- syntax only mode) 7062 7063 when Pragma_List => 7064 null; 7065 7066 -------------------- 7067 -- Locking_Policy -- 7068 -------------------- 7069 7070 -- pragma Locking_Policy (policy_IDENTIFIER); 7071 7072 when Pragma_Locking_Policy => declare 7073 LP : Character; 7074 7075 begin 7076 Check_Ada_83_Warning; 7077 Check_Arg_Count (1); 7078 Check_No_Identifiers; 7079 Check_Arg_Is_Locking_Policy (Arg1); 7080 Check_Valid_Configuration_Pragma; 7081 Get_Name_String (Chars (Expression (Arg1))); 7082 LP := Fold_Upper (Name_Buffer (1)); 7083 7084 if Locking_Policy /= ' ' 7085 and then Locking_Policy /= LP 7086 then 7087 Error_Msg_Sloc := Locking_Policy_Sloc; 7088 Error_Pragma ("locking policy incompatible with policy#"); 7089 7090 -- Set new policy, but always preserve System_Location since 7091 -- we like the error message with the run time name. 7092 7093 else 7094 Locking_Policy := LP; 7095 7096 if Locking_Policy_Sloc /= System_Location then 7097 Locking_Policy_Sloc := Loc; 7098 end if; 7099 end if; 7100 end; 7101 7102 ---------------- 7103 -- Long_Float -- 7104 ---------------- 7105 7106 -- pragma Long_Float (D_Float | G_Float); 7107 7108 when Pragma_Long_Float => 7109 GNAT_Pragma; 7110 Check_Valid_Configuration_Pragma; 7111 Check_Arg_Count (1); 7112 Check_No_Identifier (Arg1); 7113 Check_Arg_Is_One_Of (Arg1, Name_D_Float, Name_G_Float); 7114 7115 if not OpenVMS_On_Target then 7116 Error_Pragma ("?pragma% ignored (applies only to Open'V'M'S)"); 7117 end if; 7118 7119 -- D_Float case 7120 7121 if Chars (Expression (Arg1)) = Name_D_Float then 7122 if Opt.Float_Format_Long = 'G' then 7123 Error_Pragma ("G_Float previously specified"); 7124 end if; 7125 7126 Opt.Float_Format_Long := 'D'; 7127 7128 -- G_Float case (this is the default, does not need overriding) 7129 7130 else 7131 if Opt.Float_Format_Long = 'D' then 7132 Error_Pragma ("D_Float previously specified"); 7133 end if; 7134 7135 Opt.Float_Format_Long := 'G'; 7136 end if; 7137 7138 Set_Standard_Fpt_Formats; 7139 7140 ----------------------- 7141 -- Machine_Attribute -- 7142 ----------------------- 7143 7144 -- pragma Machine_Attribute ( 7145 -- [Entity =>] LOCAL_NAME, 7146 -- [Attribute_Name =>] static_string_EXPRESSION 7147 -- [,[Info =>] static_string_EXPRESSION] ); 7148 7149 when Pragma_Machine_Attribute => Machine_Attribute : declare 7150 Def_Id : Entity_Id; 7151 7152 begin 7153 GNAT_Pragma; 7154 7155 if Arg_Count = 3 then 7156 Check_Optional_Identifier (Arg3, "info"); 7157 Check_Arg_Is_Static_Expression (Arg3, Standard_String); 7158 else 7159 Check_Arg_Count (2); 7160 end if; 7161 7162 Check_Arg_Is_Local_Name (Arg1); 7163 Check_Optional_Identifier (Arg2, "attribute_name"); 7164 Check_Optional_Identifier (Arg1, Name_Entity); 7165 Check_Arg_Is_Static_Expression (Arg2, Standard_String); 7166 Def_Id := Entity (Expression (Arg1)); 7167 7168 if Is_Access_Type (Def_Id) then 7169 Def_Id := Designated_Type (Def_Id); 7170 end if; 7171 7172 if Rep_Item_Too_Early (Def_Id, N) then 7173 return; 7174 end if; 7175 7176 Def_Id := Underlying_Type (Def_Id); 7177 7178 -- The only processing required is to link this item on to the 7179 -- list of rep items for the given entity. This is accomplished 7180 -- by the call to Rep_Item_Too_Late (when no error is detected 7181 -- and False is returned). 7182 7183 if Rep_Item_Too_Late (Def_Id, N) then 7184 return; 7185 else 7186 Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1))); 7187 end if; 7188 end Machine_Attribute; 7189 7190 ---------- 7191 -- Main -- 7192 ---------- 7193 7194 -- pragma Main_Storage 7195 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]); 7196 7197 -- MAIN_STORAGE_OPTION ::= 7198 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION 7199 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION 7200 7201 when Pragma_Main => Main : declare 7202 Args : Args_List (1 .. 3); 7203 Names : constant Name_List (1 .. 3) := ( 7204 Name_Stack_Size, 7205 Name_Task_Stack_Size_Default, 7206 Name_Time_Slicing_Enabled); 7207 7208 Nod : Node_Id; 7209 7210 begin 7211 GNAT_Pragma; 7212 Gather_Associations (Names, Args); 7213 7214 for J in 1 .. 2 loop 7215 if Present (Args (J)) then 7216 Check_Arg_Is_Static_Expression (Args (J), Any_Integer); 7217 end if; 7218 end loop; 7219 7220 if Present (Args (3)) then 7221 Check_Arg_Is_Static_Expression (Args (3), Standard_Boolean); 7222 end if; 7223 7224 Nod := Next (N); 7225 while Present (Nod) loop 7226 if Nkind (Nod) = N_Pragma 7227 and then Chars (Nod) = Name_Main 7228 then 7229 Error_Msg_Name_1 := Chars (N); 7230 Error_Msg_N ("duplicate pragma% not permitted", Nod); 7231 end if; 7232 7233 Next (Nod); 7234 end loop; 7235 end Main; 7236 7237 ------------------ 7238 -- Main_Storage -- 7239 ------------------ 7240 7241 -- pragma Main_Storage 7242 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]); 7243 7244 -- MAIN_STORAGE_OPTION ::= 7245 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION 7246 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION 7247 7248 when Pragma_Main_Storage => Main_Storage : declare 7249 Args : Args_List (1 .. 2); 7250 Names : constant Name_List (1 .. 2) := ( 7251 Name_Working_Storage, 7252 Name_Top_Guard); 7253 7254 Nod : Node_Id; 7255 7256 begin 7257 GNAT_Pragma; 7258 Gather_Associations (Names, Args); 7259 7260 for J in 1 .. 2 loop 7261 if Present (Args (J)) then 7262 Check_Arg_Is_Static_Expression (Args (J), Any_Integer); 7263 end if; 7264 end loop; 7265 7266 Check_In_Main_Program; 7267 7268 Nod := Next (N); 7269 while Present (Nod) loop 7270 if Nkind (Nod) = N_Pragma 7271 and then Chars (Nod) = Name_Main_Storage 7272 then 7273 Error_Msg_Name_1 := Chars (N); 7274 Error_Msg_N ("duplicate pragma% not permitted", Nod); 7275 end if; 7276 7277 Next (Nod); 7278 end loop; 7279 end Main_Storage; 7280 7281 ----------------- 7282 -- Memory_Size -- 7283 ----------------- 7284 7285 -- pragma Memory_Size (NUMERIC_LITERAL) 7286 7287 when Pragma_Memory_Size => 7288 GNAT_Pragma; 7289 7290 -- Memory size is simply ignored 7291 7292 Check_No_Identifiers; 7293 Check_Arg_Count (1); 7294 Check_Arg_Is_Integer_Literal (Arg1); 7295 7296 --------------- 7297 -- No_Return -- 7298 --------------- 7299 7300 -- pragma No_Return (procedure_LOCAL_NAME); 7301 7302 when Pragma_No_Return => No_Return : declare 7303 Id : Node_Id; 7304 E : Entity_Id; 7305 Found : Boolean; 7306 7307 begin 7308 GNAT_Pragma; 7309 Check_Arg_Count (1); 7310 Check_No_Identifiers; 7311 Check_Arg_Is_Local_Name (Arg1); 7312 Id := Expression (Arg1); 7313 Analyze (Id); 7314 7315 if not Is_Entity_Name (Id) then 7316 Error_Pragma_Arg ("entity name required", Arg1); 7317 end if; 7318 7319 if Etype (Id) = Any_Type then 7320 raise Pragma_Exit; 7321 end if; 7322 7323 E := Entity (Id); 7324 7325 Found := False; 7326 while Present (E) 7327 and then Scope (E) = Current_Scope 7328 loop 7329 if Ekind (E) = E_Procedure 7330 or else Ekind (E) = E_Generic_Procedure 7331 then 7332 Set_No_Return (E); 7333 Found := True; 7334 end if; 7335 7336 E := Homonym (E); 7337 end loop; 7338 7339 if not Found then 7340 Error_Pragma ("no procedures found for pragma%"); 7341 end if; 7342 end No_Return; 7343 7344 ----------------- 7345 -- Obsolescent -- 7346 ----------------- 7347 7348 -- pragma Obsolescent [(static_string_EXPRESSION)]; 7349 7350 when Pragma_Obsolescent => Obsolescent : declare 7351 begin 7352 GNAT_Pragma; 7353 Check_At_Most_N_Arguments (1); 7354 Check_No_Identifiers; 7355 7356 if Arg_Count = 1 then 7357 Check_Arg_Is_Static_Expression (Arg1, Standard_String); 7358 end if; 7359 7360 if No (Prev (N)) 7361 or else (Nkind (Prev (N))) /= N_Subprogram_Declaration 7362 then 7363 Error_Pragma 7364 ("pragma% misplaced, must immediately " & 7365 "follow subprogram spec"); 7366 end if; 7367 end Obsolescent; 7368 7369 ----------------- 7370 -- No_Run_Time -- 7371 ----------------- 7372 7373 -- pragma No_Run_Time 7374 7375 -- Note: this pragma is retained for backwards compatibiltiy. 7376 -- See body of Rtsfind for full details on its handling. 7377 7378 when Pragma_No_Run_Time => 7379 GNAT_Pragma; 7380 Check_Valid_Configuration_Pragma; 7381 Check_Arg_Count (0); 7382 7383 No_Run_Time_Mode := True; 7384 Configurable_Run_Time_Mode := True; 7385 7386 declare 7387 Word32 : constant Boolean := Ttypes.System_Word_Size = 32; 7388 begin 7389 if Word32 then 7390 Duration_32_Bits_On_Target := True; 7391 end if; 7392 end; 7393 7394 Restrictions (No_Finalization) := True; 7395 Restrictions (No_Exception_Handlers) := True; 7396 Restriction_Parameters (Max_Tasks) := Uint_0; 7397 7398 ----------------------- 7399 -- Normalize_Scalars -- 7400 ----------------------- 7401 7402 -- pragma Normalize_Scalars; 7403 7404 when Pragma_Normalize_Scalars => 7405 Check_Ada_83_Warning; 7406 Check_Arg_Count (0); 7407 Check_Valid_Configuration_Pragma; 7408 Normalize_Scalars := True; 7409 Init_Or_Norm_Scalars := True; 7410 7411 -------------- 7412 -- Optimize -- 7413 -------------- 7414 7415 -- pragma Optimize (Time | Space); 7416 7417 -- The actual check for optimize is done in Gigi. Note that this 7418 -- pragma does not actually change the optimization setting, it 7419 -- simply checks that it is consistent with the pragma. 7420 7421 when Pragma_Optimize => 7422 Check_No_Identifiers; 7423 Check_Arg_Count (1); 7424 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off); 7425 7426 ------------------------- 7427 -- Optional_Overriding -- 7428 ------------------------- 7429 7430 -- These pragmas are treated as part of the previous subprogram 7431 -- declaration, and analyzed immediately after it (see sem_ch6, 7432 -- Check_Overriding_Operation). If the pragma has not been analyzed 7433 -- yet, it appears in the wrong place. 7434 7435 when Pragma_Optional_Overriding => 7436 Error_Msg_N ("pragma must appear immediately after subprogram", N); 7437 7438 ---------------- 7439 -- Overriding -- 7440 ---------------- 7441 7442 when Pragma_Overriding => 7443 Error_Msg_N ("pragma must appear immediately after subprogram", N); 7444 7445 ---------- 7446 -- Pack -- 7447 ---------- 7448 7449 -- pragma Pack (first_subtype_LOCAL_NAME); 7450 7451 when Pragma_Pack => Pack : declare 7452 Assoc : constant Node_Id := Arg1; 7453 Type_Id : Node_Id; 7454 Typ : Entity_Id; 7455 7456 begin 7457 Check_No_Identifiers; 7458 Check_Arg_Count (1); 7459 Check_Arg_Is_Local_Name (Arg1); 7460 7461 Type_Id := Expression (Assoc); 7462 Find_Type (Type_Id); 7463 Typ := Entity (Type_Id); 7464 7465 if Typ = Any_Type 7466 or else Rep_Item_Too_Early (Typ, N) 7467 then 7468 return; 7469 else 7470 Typ := Underlying_Type (Typ); 7471 end if; 7472 7473 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then 7474 Error_Pragma ("pragma% must specify array or record type"); 7475 end if; 7476 7477 Check_First_Subtype (Arg1); 7478 7479 if Has_Pragma_Pack (Typ) then 7480 Error_Pragma ("duplicate pragma%, only one allowed"); 7481 7482 -- Array type. We set the Has_Pragma_Pack flag, and Is_Packed, 7483 -- but not Has_Non_Standard_Rep, because we don't actually know 7484 -- till freeze time if the array can have packed representation. 7485 -- That's because in the general case we do not know enough about 7486 -- the component type until it in turn is frozen, which certainly 7487 -- happens before the array type is frozen, but not necessarily 7488 -- till that point (i.e. right now it may be unfrozen). 7489 7490 elsif Is_Array_Type (Typ) then 7491 if Has_Aliased_Components (Base_Type (Typ)) then 7492 Error_Pragma 7493 ("pragma% ignored, cannot pack aliased components?"); 7494 7495 elsif Has_Atomic_Components (Typ) 7496 or else Is_Atomic (Component_Type (Typ)) 7497 then 7498 Error_Pragma 7499 ("?pragma% ignored, cannot pack atomic components"); 7500 7501 elsif not Rep_Item_Too_Late (Typ, N) then 7502 Set_Is_Packed (Base_Type (Typ)); 7503 Set_Has_Pragma_Pack (Base_Type (Typ)); 7504 Set_Has_Non_Standard_Rep (Base_Type (Typ)); 7505 end if; 7506 7507 -- Record type. For record types, the pack is always effective 7508 7509 else pragma Assert (Is_Record_Type (Typ)); 7510 if not Rep_Item_Too_Late (Typ, N) then 7511 Set_Has_Pragma_Pack (Base_Type (Typ)); 7512 Set_Is_Packed (Base_Type (Typ)); 7513 Set_Has_Non_Standard_Rep (Base_Type (Typ)); 7514 end if; 7515 end if; 7516 end Pack; 7517 7518 ---------- 7519 -- Page -- 7520 ---------- 7521 7522 -- pragma Page; 7523 7524 -- There is nothing to do here, since we did all the processing 7525 -- for this pragma in Par.Prag (so that it works properly even in 7526 -- syntax only mode) 7527 7528 when Pragma_Page => 7529 null; 7530 7531 ------------- 7532 -- Passive -- 7533 ------------- 7534 7535 -- pragma Passive [(PASSIVE_FORM)]; 7536 7537 -- PASSIVE_FORM ::= Semaphore | No 7538 7539 when Pragma_Passive => 7540 GNAT_Pragma; 7541 7542 if Nkind (Parent (N)) /= N_Task_Definition then 7543 Error_Pragma ("pragma% must be within task definition"); 7544 end if; 7545 7546 if Arg_Count /= 0 then 7547 Check_Arg_Count (1); 7548 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No); 7549 end if; 7550 7551 ------------- 7552 -- Polling -- 7553 ------------- 7554 7555 -- pragma Polling (ON | OFF); 7556 7557 when Pragma_Polling => 7558 GNAT_Pragma; 7559 Check_Arg_Count (1); 7560 Check_No_Identifiers; 7561 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 7562 Polling_Required := (Chars (Expression (Arg1)) = Name_On); 7563 7564 --------------------- 7565 -- Persistent_Data -- 7566 --------------------- 7567 7568 when Pragma_Persistent_Data => declare 7569 Ent : Entity_Id; 7570 7571 begin 7572 -- Register the pragma as applying to the compilation unit. 7573 -- Individual Persistent_Object pragmas for relevant objects 7574 -- are generated the end of the compilation. 7575 7576 GNAT_Pragma; 7577 Check_Valid_Configuration_Pragma; 7578 Check_Arg_Count (0); 7579 Ent := Find_Lib_Unit_Name; 7580 Set_Is_Preelaborated (Ent); 7581 end; 7582 7583 ------------------------ 7584 -- Persistent_Object -- 7585 ------------------------ 7586 7587 when Pragma_Persistent_Object => declare 7588 Decl : Node_Id; 7589 Ent : Entity_Id; 7590 MA : Node_Id; 7591 Str : String_Id; 7592 7593 begin 7594 GNAT_Pragma; 7595 Check_Arg_Count (1); 7596 Check_Arg_Is_Library_Level_Local_Name (Arg1); 7597 if not Is_Entity_Name (Expression (Arg1)) 7598 or else 7599 (Ekind (Entity (Expression (Arg1))) /= E_Variable 7600 and then Ekind (Entity (Expression (Arg1))) /= E_Constant) 7601 then 7602 Error_Pragma_Arg ("pragma only applies to objects", Arg1); 7603 end if; 7604 7605 Ent := Entity (Expression (Arg1)); 7606 Decl := Parent (Ent); 7607 7608 if Nkind (Decl) /= N_Object_Declaration then 7609 return; 7610 end if; 7611 7612 -- Placement of the object depends on whether there is 7613 -- an initial value or none. If the No_Initialization flag 7614 -- is set, the initialization has been transformed into 7615 -- assignments, which is disallowed elaboration code. 7616 7617 if No_Initialization (Decl) then 7618 Error_Msg_N 7619 ("initialization for persistent object" 7620 & "must be static expression", Decl); 7621 return; 7622 end if; 7623 7624 if No (Expression (Decl)) then 7625 Start_String; 7626 Store_String_Chars ("section ("".persistent.bss"")"); 7627 Str := End_String; 7628 7629 else 7630 if not Is_OK_Static_Expression (Expression (Decl)) then 7631 Flag_Non_Static_Expr 7632 ("initialization for persistent object" 7633 & "must be static expression!", Expression (Decl)); 7634 return; 7635 end if; 7636 7637 Start_String; 7638 Store_String_Chars ("section ("".persistent.data"")"); 7639 Str := End_String; 7640 end if; 7641 7642 MA := 7643 Make_Pragma 7644 (Sloc (N), 7645 Name_Machine_Attribute, 7646 New_List 7647 (Make_Pragma_Argument_Association 7648 (Sloc => Sloc (Arg1), 7649 Expression => New_Occurrence_Of (Ent, Sloc (Ent))), 7650 Make_Pragma_Argument_Association 7651 (Sloc => Sloc (Arg1), 7652 Expression => 7653 Make_String_Literal 7654 (Sloc => Sloc (Arg1), 7655 Strval => Str)))); 7656 7657 Insert_After (N, MA); 7658 Analyze (MA); 7659 Set_Has_Gigi_Rep_Item (Ent); 7660 end; 7661 7662 ------------------ 7663 -- Preelaborate -- 7664 ------------------ 7665 7666 -- pragma Preelaborate [(library_unit_NAME)]; 7667 7668 -- Set the flag Is_Preelaborated of program unit name entity 7669 7670 when Pragma_Preelaborate => Preelaborate : declare 7671 Pa : constant Node_Id := Parent (N); 7672 Pk : constant Node_Kind := Nkind (Pa); 7673 Ent : Entity_Id; 7674 7675 begin 7676 Check_Ada_83_Warning; 7677 Check_Valid_Library_Unit_Pragma; 7678 7679 if Nkind (N) = N_Null_Statement then 7680 return; 7681 end if; 7682 7683 Ent := Find_Lib_Unit_Name; 7684 7685 -- This filters out pragmas inside generic parent then 7686 -- show up inside instantiation 7687 7688 if Present (Ent) 7689 and then not (Pk = N_Package_Specification 7690 and then Present (Generic_Parent (Pa))) 7691 then 7692 if not Debug_Flag_U then 7693 Set_Is_Preelaborated (Ent); 7694 Set_Suppress_Elaboration_Warnings (Ent); 7695 end if; 7696 end if; 7697 end Preelaborate; 7698 7699 -------------- 7700 -- Priority -- 7701 -------------- 7702 7703 -- pragma Priority (EXPRESSION); 7704 7705 when Pragma_Priority => Priority : declare 7706 P : constant Node_Id := Parent (N); 7707 Arg : Node_Id; 7708 7709 begin 7710 Check_No_Identifiers; 7711 Check_Arg_Count (1); 7712 7713 -- Subprogram case 7714 7715 if Nkind (P) = N_Subprogram_Body then 7716 Check_In_Main_Program; 7717 7718 Arg := Expression (Arg1); 7719 Analyze_And_Resolve (Arg, Standard_Integer); 7720 7721 -- Must be static 7722 7723 if not Is_Static_Expression (Arg) then 7724 Flag_Non_Static_Expr 7725 ("main subprogram priority is not static!", Arg); 7726 raise Pragma_Exit; 7727 7728 -- If constraint error, then we already signalled an error 7729 7730 elsif Raises_Constraint_Error (Arg) then 7731 null; 7732 7733 -- Otherwise check in range 7734 7735 else 7736 declare 7737 Val : constant Uint := Expr_Value (Arg); 7738 7739 begin 7740 if Val < 0 7741 or else Val > Expr_Value (Expression 7742 (Parent (RTE (RE_Max_Priority)))) 7743 then 7744 Error_Pragma_Arg 7745 ("main subprogram priority is out of range", Arg1); 7746 end if; 7747 end; 7748 end if; 7749 7750 Set_Main_Priority 7751 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg))); 7752 7753 -- Task or Protected, must be of type Integer 7754 7755 elsif Nkind (P) = N_Protected_Definition 7756 or else 7757 Nkind (P) = N_Task_Definition 7758 then 7759 Arg := Expression (Arg1); 7760 7761 -- The expression must be analyzed in the special manner 7762 -- described in "Handling of Default and Per-Object 7763 -- Expressions" in sem.ads. 7764 7765 Analyze_Per_Use_Expression (Arg, Standard_Integer); 7766 7767 if not Is_Static_Expression (Arg) then 7768 Check_Restriction (Static_Priorities, Arg); 7769 end if; 7770 7771 -- Anything else is incorrect 7772 7773 else 7774 Pragma_Misplaced; 7775 end if; 7776 7777 if Has_Priority_Pragma (P) then 7778 Error_Pragma ("duplicate pragma% not allowed"); 7779 else 7780 Set_Has_Priority_Pragma (P, True); 7781 7782 if Nkind (P) = N_Protected_Definition 7783 or else 7784 Nkind (P) = N_Task_Definition 7785 then 7786 Record_Rep_Item (Defining_Identifier (Parent (P)), N); 7787 -- exp_ch9 should use this ??? 7788 end if; 7789 end if; 7790 end Priority; 7791 7792 -------------------------- 7793 -- Propagate_Exceptions -- 7794 -------------------------- 7795 7796 -- pragma Propagate_Exceptions; 7797 7798 when Pragma_Propagate_Exceptions => 7799 GNAT_Pragma; 7800 Check_Arg_Count (0); 7801 7802 if In_Extended_Main_Source_Unit (N) then 7803 Propagate_Exceptions := True; 7804 end if; 7805 7806 ------------------ 7807 -- Psect_Object -- 7808 ------------------ 7809 7810 -- pragma Psect_Object ( 7811 -- [Internal =>] LOCAL_NAME, 7812 -- [, [External =>] EXTERNAL_SYMBOL] 7813 -- [, [Size =>] EXTERNAL_SYMBOL]); 7814 7815 when Pragma_Psect_Object | Pragma_Common_Object => 7816 Psect_Object : declare 7817 Args : Args_List (1 .. 3); 7818 Names : constant Name_List (1 .. 3) := ( 7819 Name_Internal, 7820 Name_External, 7821 Name_Size); 7822 7823 Internal : Node_Id renames Args (1); 7824 External : Node_Id renames Args (2); 7825 Size : Node_Id renames Args (3); 7826 7827 R_Internal : Node_Id; 7828 R_External : Node_Id; 7829 7830 MA : Node_Id; 7831 Str : String_Id; 7832 7833 Def_Id : Entity_Id; 7834 7835 procedure Check_Too_Long (Arg : Node_Id); 7836 -- Posts message if the argument is an identifier with more 7837 -- than 31 characters, or a string literal with more than 7838 -- 31 characters, and we are operating under VMS 7839 7840 -------------------- 7841 -- Check_Too_Long -- 7842 -------------------- 7843 7844 procedure Check_Too_Long (Arg : Node_Id) is 7845 X : constant Node_Id := Original_Node (Arg); 7846 7847 begin 7848 if Nkind (X) /= N_String_Literal 7849 and then 7850 Nkind (X) /= N_Identifier 7851 then 7852 Error_Pragma_Arg 7853 ("inappropriate argument for pragma %", Arg); 7854 end if; 7855 7856 if OpenVMS_On_Target then 7857 if (Nkind (X) = N_String_Literal 7858 and then String_Length (Strval (X)) > 31) 7859 or else 7860 (Nkind (X) = N_Identifier 7861 and then Length_Of_Name (Chars (X)) > 31) 7862 then 7863 Error_Pragma_Arg 7864 ("argument for pragma % is longer than 31 characters", 7865 Arg); 7866 end if; 7867 end if; 7868 end Check_Too_Long; 7869 7870 -- Start of processing for Common_Object/Psect_Object 7871 7872 begin 7873 GNAT_Pragma; 7874 Gather_Associations (Names, Args); 7875 Process_Extended_Import_Export_Internal_Arg (Internal); 7876 7877 R_Internal := Relocate_Node (Internal); 7878 7879 Def_Id := Entity (R_Internal); 7880 7881 if Ekind (Def_Id) /= E_Constant 7882 and then Ekind (Def_Id) /= E_Variable 7883 then 7884 Error_Pragma_Arg 7885 ("pragma% must designate an object", Internal); 7886 end if; 7887 7888 Check_Too_Long (R_Internal); 7889 7890 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then 7891 Error_Pragma_Arg 7892 ("cannot use pragma% for imported/exported object", 7893 R_Internal); 7894 end if; 7895 7896 if Is_Concurrent_Type (Etype (R_Internal)) then 7897 Error_Pragma_Arg 7898 ("cannot specify pragma % for task/protected object", 7899 R_Internal); 7900 end if; 7901 7902 if Is_Psected (Def_Id) then 7903 Error_Msg_N ("?duplicate Psect_Object pragma", N); 7904 else 7905 Set_Is_Psected (Def_Id); 7906 end if; 7907 7908 if Ekind (Def_Id) = E_Constant then 7909 Error_Pragma_Arg 7910 ("cannot specify pragma % for a constant", R_Internal); 7911 end if; 7912 7913 if Is_Record_Type (Etype (R_Internal)) then 7914 declare 7915 Ent : Entity_Id; 7916 Decl : Entity_Id; 7917 7918 begin 7919 Ent := First_Entity (Etype (R_Internal)); 7920 while Present (Ent) loop 7921 Decl := Declaration_Node (Ent); 7922 7923 if Ekind (Ent) = E_Component 7924 and then Nkind (Decl) = N_Component_Declaration 7925 and then Present (Expression (Decl)) 7926 and then Warn_On_Export_Import 7927 then 7928 Error_Msg_N 7929 ("?object for pragma % has defaults", R_Internal); 7930 exit; 7931 7932 else 7933 Next_Entity (Ent); 7934 end if; 7935 end loop; 7936 end; 7937 end if; 7938 7939 if Present (Size) then 7940 Check_Too_Long (Size); 7941 end if; 7942 7943 -- Make Psect case-insensitive. 7944 7945 if Present (External) then 7946 Check_Too_Long (External); 7947 7948 if Nkind (External) = N_String_Literal then 7949 String_To_Name_Buffer (Strval (External)); 7950 else 7951 Get_Name_String (Chars (External)); 7952 end if; 7953 7954 Set_All_Upper_Case; 7955 Start_String; 7956 Store_String_Chars (Name_Buffer (1 .. Name_Len)); 7957 Str := End_String; 7958 R_External := Make_String_Literal 7959 (Sloc => Sloc (External), Strval => Str); 7960 else 7961 Get_Name_String (Chars (Internal)); 7962 Set_All_Upper_Case; 7963 Start_String; 7964 Store_String_Chars (Name_Buffer (1 .. Name_Len)); 7965 Str := End_String; 7966 R_External := Make_String_Literal 7967 (Sloc => Sloc (Internal), Strval => Str); 7968 end if; 7969 7970 -- Transform into pragma Linker_Section, add attributes to 7971 -- match what DEC Ada does. Ignore size for now? 7972 7973 Rewrite (N, 7974 Make_Pragma 7975 (Sloc (N), 7976 Name_Linker_Section, 7977 New_List 7978 (Make_Pragma_Argument_Association 7979 (Sloc => Sloc (R_Internal), 7980 Expression => R_Internal), 7981 Make_Pragma_Argument_Association 7982 (Sloc => Sloc (R_External), 7983 Expression => R_External)))); 7984 7985 Analyze (N); 7986 7987 -- Add Machine_Attribute of "overlaid", so the section overlays 7988 -- other sections of the same name. 7989 7990 Start_String; 7991 Store_String_Chars ("overlaid"); 7992 Str := End_String; 7993 7994 MA := 7995 Make_Pragma 7996 (Sloc (N), 7997 Name_Machine_Attribute, 7998 New_List 7999 (Make_Pragma_Argument_Association 8000 (Sloc => Sloc (R_Internal), 8001 Expression => R_Internal), 8002 Make_Pragma_Argument_Association 8003 (Sloc => Sloc (R_External), 8004 Expression => 8005 Make_String_Literal 8006 (Sloc => Sloc (R_External), 8007 Strval => Str)))); 8008 Analyze (MA); 8009 8010 -- Add Machine_Attribute of "global", so the section is visible 8011 -- everywhere 8012 8013 Start_String; 8014 Store_String_Chars ("global"); 8015 Str := End_String; 8016 8017 MA := 8018 Make_Pragma 8019 (Sloc (N), 8020 Name_Machine_Attribute, 8021 New_List 8022 (Make_Pragma_Argument_Association 8023 (Sloc => Sloc (R_Internal), 8024 Expression => R_Internal), 8025 8026 Make_Pragma_Argument_Association 8027 (Sloc => Sloc (R_External), 8028 Expression => 8029 Make_String_Literal 8030 (Sloc => Sloc (R_External), 8031 Strval => Str)))); 8032 Analyze (MA); 8033 8034 -- Add Machine_Attribute of "initialize", so the section is 8035 -- demand zeroed. 8036 8037 Start_String; 8038 Store_String_Chars ("initialize"); 8039 Str := End_String; 8040 8041 MA := 8042 Make_Pragma 8043 (Sloc (N), 8044 Name_Machine_Attribute, 8045 New_List 8046 (Make_Pragma_Argument_Association 8047 (Sloc => Sloc (R_Internal), 8048 Expression => R_Internal), 8049 8050 Make_Pragma_Argument_Association 8051 (Sloc => Sloc (R_External), 8052 Expression => 8053 Make_String_Literal 8054 (Sloc => Sloc (R_External), 8055 Strval => Str)))); 8056 Analyze (MA); 8057 end Psect_Object; 8058 8059 ---------- 8060 -- Pure -- 8061 ---------- 8062 8063 -- pragma Pure [(library_unit_NAME)]; 8064 8065 when Pragma_Pure => Pure : declare 8066 Ent : Entity_Id; 8067 begin 8068 Check_Ada_83_Warning; 8069 Check_Valid_Library_Unit_Pragma; 8070 8071 if Nkind (N) = N_Null_Statement then 8072 return; 8073 end if; 8074 8075 Ent := Find_Lib_Unit_Name; 8076 Set_Is_Pure (Ent); 8077 Set_Suppress_Elaboration_Warnings (Ent); 8078 end Pure; 8079 8080 ------------------- 8081 -- Pure_Function -- 8082 ------------------- 8083 8084 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME); 8085 8086 when Pragma_Pure_Function => Pure_Function : declare 8087 E_Id : Node_Id; 8088 E : Entity_Id; 8089 Def_Id : Entity_Id; 8090 8091 begin 8092 GNAT_Pragma; 8093 Check_Arg_Count (1); 8094 Check_Optional_Identifier (Arg1, Name_Entity); 8095 Check_Arg_Is_Local_Name (Arg1); 8096 E_Id := Expression (Arg1); 8097 8098 if Error_Posted (E_Id) then 8099 return; 8100 end if; 8101 8102 -- Loop through homonyms (overloadings) of referenced entity 8103 8104 E := Entity (E_Id); 8105 8106 if Present (E) then 8107 loop 8108 Def_Id := Get_Base_Subprogram (E); 8109 8110 if Ekind (Def_Id) /= E_Function 8111 and then Ekind (Def_Id) /= E_Generic_Function 8112 and then Ekind (Def_Id) /= E_Operator 8113 then 8114 Error_Pragma_Arg 8115 ("pragma% requires a function name", Arg1); 8116 end if; 8117 8118 Set_Is_Pure (Def_Id); 8119 Set_Has_Pragma_Pure_Function (Def_Id); 8120 8121 E := Homonym (E); 8122 exit when No (E) or else Scope (E) /= Current_Scope; 8123 end loop; 8124 end if; 8125 end Pure_Function; 8126 8127 -------------------- 8128 -- Queuing_Policy -- 8129 -------------------- 8130 8131 -- pragma Queuing_Policy (policy_IDENTIFIER); 8132 8133 when Pragma_Queuing_Policy => declare 8134 QP : Character; 8135 8136 begin 8137 Check_Ada_83_Warning; 8138 Check_Arg_Count (1); 8139 Check_No_Identifiers; 8140 Check_Arg_Is_Queuing_Policy (Arg1); 8141 Check_Valid_Configuration_Pragma; 8142 Get_Name_String (Chars (Expression (Arg1))); 8143 QP := Fold_Upper (Name_Buffer (1)); 8144 8145 if Queuing_Policy /= ' ' 8146 and then Queuing_Policy /= QP 8147 then 8148 Error_Msg_Sloc := Queuing_Policy_Sloc; 8149 Error_Pragma ("queuing policy incompatible with policy#"); 8150 8151 -- Set new policy, but always preserve System_Location since 8152 -- we like the error message with the run time name. 8153 8154 else 8155 Queuing_Policy := QP; 8156 8157 if Queuing_Policy_Sloc /= System_Location then 8158 Queuing_Policy_Sloc := Loc; 8159 end if; 8160 end if; 8161 end; 8162 8163 --------------------------- 8164 -- Remote_Call_Interface -- 8165 --------------------------- 8166 8167 -- pragma Remote_Call_Interface [(library_unit_NAME)]; 8168 8169 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare 8170 Cunit_Node : Node_Id; 8171 Cunit_Ent : Entity_Id; 8172 K : Node_Kind; 8173 8174 begin 8175 Check_Ada_83_Warning; 8176 Check_Valid_Library_Unit_Pragma; 8177 8178 if Nkind (N) = N_Null_Statement then 8179 return; 8180 end if; 8181 8182 Cunit_Node := Cunit (Current_Sem_Unit); 8183 K := Nkind (Unit (Cunit_Node)); 8184 Cunit_Ent := Cunit_Entity (Current_Sem_Unit); 8185 8186 if K = N_Package_Declaration 8187 or else K = N_Generic_Package_Declaration 8188 or else K = N_Subprogram_Declaration 8189 or else K = N_Generic_Subprogram_Declaration 8190 or else (K = N_Subprogram_Body 8191 and then Acts_As_Spec (Unit (Cunit_Node))) 8192 then 8193 null; 8194 else 8195 Error_Pragma ( 8196 "pragma% must apply to package or subprogram declaration"); 8197 end if; 8198 8199 Set_Is_Remote_Call_Interface (Cunit_Ent); 8200 end Remote_Call_Interface; 8201 8202 ------------------ 8203 -- Remote_Types -- 8204 ------------------ 8205 8206 -- pragma Remote_Types [(library_unit_NAME)]; 8207 8208 when Pragma_Remote_Types => Remote_Types : declare 8209 Cunit_Node : Node_Id; 8210 Cunit_Ent : Entity_Id; 8211 8212 begin 8213 Check_Ada_83_Warning; 8214 Check_Valid_Library_Unit_Pragma; 8215 8216 if Nkind (N) = N_Null_Statement then 8217 return; 8218 end if; 8219 8220 Cunit_Node := Cunit (Current_Sem_Unit); 8221 Cunit_Ent := Cunit_Entity (Current_Sem_Unit); 8222 8223 if Nkind (Unit (Cunit_Node)) /= N_Package_Declaration 8224 and then 8225 Nkind (Unit (Cunit_Node)) /= N_Generic_Package_Declaration 8226 then 8227 Error_Pragma ( 8228 "pragma% can only apply to a package declaration"); 8229 end if; 8230 8231 Set_Is_Remote_Types (Cunit_Ent); 8232 end Remote_Types; 8233 8234 --------------- 8235 -- Ravenscar -- 8236 --------------- 8237 8238 -- pragma Ravenscar; 8239 8240 when Pragma_Ravenscar => 8241 GNAT_Pragma; 8242 Check_Arg_Count (0); 8243 Check_Valid_Configuration_Pragma; 8244 Set_Ravenscar (N); 8245 8246 ------------------------- 8247 -- Restricted_Run_Time -- 8248 ------------------------- 8249 8250 -- pragma Restricted_Run_Time; 8251 8252 when Pragma_Restricted_Run_Time => 8253 GNAT_Pragma; 8254 Check_Arg_Count (0); 8255 Check_Valid_Configuration_Pragma; 8256 Set_Restricted_Profile (N); 8257 8258 ------------------ 8259 -- Restrictions -- 8260 ------------------ 8261 8262 -- pragma Restrictions (RESTRICTION {, RESTRICTION}); 8263 8264 -- RESTRICTION ::= 8265 -- restriction_IDENTIFIER 8266 -- | restriction_parameter_IDENTIFIER => EXPRESSION 8267 8268 when Pragma_Restrictions => Restrictions_Pragma : declare 8269 Arg : Node_Id; 8270 R_Id : Restriction_Id; 8271 RP_Id : Restriction_Parameter_Id; 8272 Id : Name_Id; 8273 Expr : Node_Id; 8274 Val : Uint; 8275 8276 begin 8277 Check_Ada_83_Warning; 8278 Check_At_Least_N_Arguments (1); 8279 Check_Valid_Configuration_Pragma; 8280 8281 Arg := Arg1; 8282 while Present (Arg) loop 8283 Id := Chars (Arg); 8284 Expr := Expression (Arg); 8285 8286 -- Case of no restriction identifier 8287 8288 if Id = No_Name then 8289 if Nkind (Expr) /= N_Identifier then 8290 Error_Pragma_Arg 8291 ("invalid form for restriction", Arg); 8292 8293 else 8294 R_Id := Get_Restriction_Id (Chars (Expr)); 8295 8296 if R_Id = Not_A_Restriction_Id then 8297 Error_Pragma_Arg 8298 ("invalid restriction identifier", Arg); 8299 8300 -- Restriction is active 8301 8302 else 8303 if Implementation_Restriction (R_Id) then 8304 Check_Restriction 8305 (No_Implementation_Restrictions, Arg); 8306 end if; 8307 8308 Restrictions (R_Id) := True; 8309 8310 -- Set location, but preserve location of system 8311 -- restriction for nice error msg with run time name 8312 8313 if Restrictions_Loc (R_Id) /= System_Location then 8314 Restrictions_Loc (R_Id) := Sloc (N); 8315 end if; 8316 8317 -- Record the restriction if we are in the main unit, 8318 -- or in the extended main unit. The reason that we 8319 -- test separately for Main_Unit is that gnat.adc is 8320 -- processed with Current_Sem_Unit = Main_Unit, but 8321 -- nodes in gnat.adc do not appear to be the extended 8322 -- main source unit (they probably should do ???) 8323 8324 if Current_Sem_Unit = Main_Unit 8325 or else In_Extended_Main_Source_Unit (N) 8326 then 8327 Main_Restrictions (R_Id) := True; 8328 end if; 8329 8330 -- A very special case that must be processed here: 8331 -- pragma Restrictions (No_Exceptions) turns off all 8332 -- run-time checking. This is a bit dubious in terms 8333 -- of the formal language definition, but it is what 8334 -- is intended by the wording of RM H.4(12). 8335 8336 if R_Id = No_Exceptions then 8337 Scope_Suppress := (others => True); 8338 end if; 8339 end if; 8340 end if; 8341 8342 -- Case of restriction identifier present 8343 8344 else 8345 RP_Id := Get_Restriction_Parameter_Id (Id); 8346 Analyze_And_Resolve (Expr, Any_Integer); 8347 8348 if RP_Id = Not_A_Restriction_Parameter_Id then 8349 Error_Pragma_Arg 8350 ("invalid restriction parameter identifier", Arg); 8351 8352 elsif not Is_OK_Static_Expression (Expr) then 8353 Flag_Non_Static_Expr 8354 ("value must be static expression!", Expr); 8355 raise Pragma_Exit; 8356 8357 elsif not Is_Integer_Type (Etype (Expr)) 8358 or else Expr_Value (Expr) < 0 8359 then 8360 Error_Pragma_Arg 8361 ("value must be non-negative integer", Arg); 8362 8363 -- Restriction pragma is active 8364 8365 else 8366 Val := Expr_Value (Expr); 8367 8368 -- Record pragma if most restrictive so far 8369 8370 if Restriction_Parameters (RP_Id) = No_Uint 8371 or else Val < Restriction_Parameters (RP_Id) 8372 then 8373 Restriction_Parameters (RP_Id) := Val; 8374 Restriction_Parameters_Loc (RP_Id) := Sloc (N); 8375 end if; 8376 end if; 8377 end if; 8378 8379 Next (Arg); 8380 end loop; 8381 end Restrictions_Pragma; 8382 8383 -------------------------- 8384 -- Restriction_Warnings -- 8385 -------------------------- 8386 8387 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION}); 8388 8389 -- RESTRICTION ::= restriction_IDENTIFIER 8390 8391 when Pragma_Restriction_Warnings => Restriction_Warn : declare 8392 Arg : Node_Id; 8393 R_Id : Restriction_Id; 8394 Expr : Node_Id; 8395 8396 begin 8397 GNAT_Pragma; 8398 Check_At_Least_N_Arguments (1); 8399 Check_Valid_Configuration_Pragma; 8400 Check_No_Identifiers; 8401 8402 Arg := Arg1; 8403 while Present (Arg) loop 8404 Expr := Expression (Arg); 8405 8406 if Nkind (Expr) /= N_Identifier then 8407 Error_Pragma_Arg 8408 ("invalid form for restriction", Arg); 8409 8410 else 8411 R_Id := Get_Restriction_Id (Chars (Expr)); 8412 8413 if R_Id = Not_A_Restriction_Id then 8414 Error_Pragma_Arg 8415 ("invalid restriction identifier", Arg); 8416 8417 -- Restriction is active 8418 8419 else 8420 if Implementation_Restriction (R_Id) then 8421 Check_Restriction 8422 (No_Implementation_Restrictions, Arg); 8423 end if; 8424 8425 Restriction_Warnings (R_Id) := True; 8426 end if; 8427 end if; 8428 8429 Next (Arg); 8430 end loop; 8431 end Restriction_Warn; 8432 8433 ---------------- 8434 -- Reviewable -- 8435 ---------------- 8436 8437 -- pragma Reviewable; 8438 8439 when Pragma_Reviewable => 8440 Check_Ada_83_Warning; 8441 Check_Arg_Count (0); 8442 8443 ------------------- 8444 -- Share_Generic -- 8445 ------------------- 8446 8447 -- pragma Share_Generic (NAME {, NAME}); 8448 8449 when Pragma_Share_Generic => 8450 GNAT_Pragma; 8451 Process_Generic_List; 8452 8453 ------------ 8454 -- Shared -- 8455 ------------ 8456 8457 -- pragma Shared (LOCAL_NAME); 8458 8459 when Pragma_Shared => 8460 GNAT_Pragma; 8461 Process_Atomic_Shared_Volatile; 8462 8463 -------------------- 8464 -- Shared_Passive -- 8465 -------------------- 8466 8467 -- pragma Shared_Passive [(library_unit_NAME)]; 8468 8469 -- Set the flag Is_Shared_Passive of program unit name entity 8470 8471 when Pragma_Shared_Passive => Shared_Passive : declare 8472 Cunit_Node : Node_Id; 8473 Cunit_Ent : Entity_Id; 8474 8475 begin 8476 Check_Ada_83_Warning; 8477 Check_Valid_Library_Unit_Pragma; 8478 8479 if Nkind (N) = N_Null_Statement then 8480 return; 8481 end if; 8482 8483 Cunit_Node := Cunit (Current_Sem_Unit); 8484 Cunit_Ent := Cunit_Entity (Current_Sem_Unit); 8485 8486 if Nkind (Unit (Cunit_Node)) /= N_Package_Declaration 8487 and then 8488 Nkind (Unit (Cunit_Node)) /= N_Generic_Package_Declaration 8489 then 8490 Error_Pragma ( 8491 "pragma% can only apply to a package declaration"); 8492 end if; 8493 8494 Set_Is_Shared_Passive (Cunit_Ent); 8495 end Shared_Passive; 8496 8497 ---------------------- 8498 -- Source_File_Name -- 8499 ---------------------- 8500 8501 -- pragma Source_File_Name ( 8502 -- [UNIT_NAME =>] unit_NAME, 8503 -- [BODY_FILE_NAME | SPEC_FILE_NAME] => STRING_LITERAL); 8504 8505 -- No processing here. Processing was completed during parsing, 8506 -- since we need to have file names set as early as possible. 8507 -- Units are loaded well before semantic processing starts. 8508 8509 -- The only processing we defer to this point is the check 8510 -- for correct placement. 8511 8512 when Pragma_Source_File_Name => 8513 GNAT_Pragma; 8514 Check_Valid_Configuration_Pragma; 8515 8516 ------------------------------ 8517 -- Source_File_Name_Project -- 8518 ------------------------------ 8519 8520 -- pragma Source_File_Name_Project ( 8521 -- [UNIT_NAME =>] unit_NAME, 8522 -- [BODY_FILE_NAME | SPEC_FILE_NAME] => STRING_LITERAL); 8523 8524 -- No processing here. Processing was completed during parsing, 8525 -- since we need to have file names set as early as possible. 8526 -- Units are loaded well before semantic processing starts. 8527 8528 -- The only processing we defer to this point is the check 8529 -- for correct placement. 8530 8531 when Pragma_Source_File_Name_Project => 8532 GNAT_Pragma; 8533 Check_Valid_Configuration_Pragma; 8534 8535 -- Check that a pragma Source_File_Name_Project is used only 8536 -- in a configuration pragmas file. 8537 -- Pragmas Source_File_Name_Project should only be generated 8538 -- by the Project Manager in configuration pragmas files. 8539 8540 -- This is really an ugly test. It seems to depend on some 8541 -- accidental and undocumented property. At the very least 8542 -- it needs to be documented, but it would be better to have 8543 -- a clean way of testing if we are in a configuration file??? 8544 8545 if Present (Parent (N)) then 8546 Error_Pragma 8547 ("pragma% can only appear in a configuration pragmas file"); 8548 end if; 8549 8550 ---------------------- 8551 -- Source_Reference -- 8552 ---------------------- 8553 8554 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]); 8555 8556 -- Nothing to do, all processing completed in Par.Prag, since we 8557 -- need the information for possible parser messages that are output 8558 8559 when Pragma_Source_Reference => 8560 GNAT_Pragma; 8561 8562 ------------------ 8563 -- Storage_Size -- 8564 ------------------ 8565 8566 -- pragma Storage_Size (EXPRESSION); 8567 8568 when Pragma_Storage_Size => Storage_Size : declare 8569 P : constant Node_Id := Parent (N); 8570 Arg : Node_Id; 8571 8572 begin 8573 Check_No_Identifiers; 8574 Check_Arg_Count (1); 8575 8576 -- The expression must be analyzed in the special manner 8577 -- described in "Handling of Default Expressions" in sem.ads. 8578 8579 -- Set In_Default_Expression for per-object case ??? 8580 8581 Arg := Expression (Arg1); 8582 Analyze_Per_Use_Expression (Arg, Any_Integer); 8583 8584 if not Is_Static_Expression (Arg) then 8585 Check_Restriction (Static_Storage_Size, Arg); 8586 end if; 8587 8588 if Nkind (P) /= N_Task_Definition then 8589 Pragma_Misplaced; 8590 return; 8591 8592 else 8593 if Has_Storage_Size_Pragma (P) then 8594 Error_Pragma ("duplicate pragma% not allowed"); 8595 else 8596 Set_Has_Storage_Size_Pragma (P, True); 8597 end if; 8598 8599 Record_Rep_Item (Defining_Identifier (Parent (P)), N); 8600 -- ??? exp_ch9 should use this! 8601 end if; 8602 end Storage_Size; 8603 8604 ------------------ 8605 -- Storage_Unit -- 8606 ------------------ 8607 8608 -- pragma Storage_Unit (NUMERIC_LITERAL); 8609 8610 -- Only permitted argument is System'Storage_Unit value 8611 8612 when Pragma_Storage_Unit => 8613 Check_No_Identifiers; 8614 Check_Arg_Count (1); 8615 Check_Arg_Is_Integer_Literal (Arg1); 8616 8617 if Intval (Expression (Arg1)) /= 8618 UI_From_Int (Ttypes.System_Storage_Unit) 8619 then 8620 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit); 8621 Error_Pragma_Arg 8622 ("the only allowed argument for pragma% is ^", Arg1); 8623 end if; 8624 8625 -------------------- 8626 -- Stream_Convert -- 8627 -------------------- 8628 8629 -- pragma Stream_Convert ( 8630 -- [Entity =>] type_LOCAL_NAME, 8631 -- [Read =>] function_NAME, 8632 -- [Write =>] function NAME); 8633 8634 when Pragma_Stream_Convert => Stream_Convert : declare 8635 8636 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id); 8637 -- Check that the given argument is the name of a local 8638 -- function of one argument that is not overloaded earlier 8639 -- in the current local scope. A check is also made that the 8640 -- argument is a function with one parameter. 8641 8642 -------------------------------------- 8643 -- Check_OK_Stream_Convert_Function -- 8644 -------------------------------------- 8645 8646 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is 8647 Ent : Entity_Id; 8648 8649 begin 8650 Check_Arg_Is_Local_Name (Arg); 8651 Ent := Entity (Expression (Arg)); 8652 8653 if Has_Homonym (Ent) then 8654 Error_Pragma_Arg 8655 ("argument for pragma% may not be overloaded", Arg); 8656 end if; 8657 8658 if Ekind (Ent) /= E_Function 8659 or else No (First_Formal (Ent)) 8660 or else Present (Next_Formal (First_Formal (Ent))) 8661 then 8662 Error_Pragma_Arg 8663 ("argument for pragma% must be" & 8664 " function of one argument", Arg); 8665 end if; 8666 end Check_OK_Stream_Convert_Function; 8667 8668 -- Start of procecessing for Stream_Convert 8669 8670 begin 8671 GNAT_Pragma; 8672 Check_Arg_Count (3); 8673 Check_Optional_Identifier (Arg1, Name_Entity); 8674 Check_Optional_Identifier (Arg2, Name_Read); 8675 Check_Optional_Identifier (Arg3, Name_Write); 8676 Check_Arg_Is_Local_Name (Arg1); 8677 Check_OK_Stream_Convert_Function (Arg2); 8678 Check_OK_Stream_Convert_Function (Arg3); 8679 8680 declare 8681 Typ : constant Entity_Id := 8682 Underlying_Type (Entity (Expression (Arg1))); 8683 Read : constant Entity_Id := Entity (Expression (Arg2)); 8684 Write : constant Entity_Id := Entity (Expression (Arg3)); 8685 8686 begin 8687 if Etype (Typ) = Any_Type 8688 or else 8689 Etype (Read) = Any_Type 8690 or else 8691 Etype (Write) = Any_Type 8692 then 8693 return; 8694 end if; 8695 8696 Check_First_Subtype (Arg1); 8697 8698 if Rep_Item_Too_Early (Typ, N) 8699 or else 8700 Rep_Item_Too_Late (Typ, N) 8701 then 8702 return; 8703 end if; 8704 8705 if Underlying_Type (Etype (Read)) /= Typ then 8706 Error_Pragma_Arg 8707 ("incorrect return type for function&", Arg2); 8708 end if; 8709 8710 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then 8711 Error_Pragma_Arg 8712 ("incorrect parameter type for function&", Arg3); 8713 end if; 8714 8715 if Underlying_Type (Etype (First_Formal (Read))) /= 8716 Underlying_Type (Etype (Write)) 8717 then 8718 Error_Pragma_Arg 8719 ("result type of & does not match Read parameter type", 8720 Arg3); 8721 end if; 8722 end; 8723 end Stream_Convert; 8724 8725 ------------------------- 8726 -- Style_Checks (GNAT) -- 8727 ------------------------- 8728 8729 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL); 8730 8731 -- This is processed by the parser since some of the style 8732 -- checks take place during source scanning and parsing. This 8733 -- means that we don't need to issue error messages here. 8734 8735 when Pragma_Style_Checks => Style_Checks : declare 8736 A : constant Node_Id := Expression (Arg1); 8737 S : String_Id; 8738 C : Char_Code; 8739 8740 begin 8741 GNAT_Pragma; 8742 Check_No_Identifiers; 8743 8744 -- Two argument form 8745 8746 if Arg_Count = 2 then 8747 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 8748 8749 declare 8750 E_Id : Node_Id; 8751 E : Entity_Id; 8752 8753 begin 8754 E_Id := Expression (Arg2); 8755 Analyze (E_Id); 8756 8757 if not Is_Entity_Name (E_Id) then 8758 Error_Pragma_Arg 8759 ("second argument of pragma% must be entity name", 8760 Arg2); 8761 end if; 8762 8763 E := Entity (E_Id); 8764 8765 if E = Any_Id then 8766 return; 8767 else 8768 loop 8769 Set_Suppress_Style_Checks (E, 8770 (Chars (Expression (Arg1)) = Name_Off)); 8771 exit when No (Homonym (E)); 8772 E := Homonym (E); 8773 end loop; 8774 end if; 8775 end; 8776 8777 -- One argument form 8778 8779 else 8780 Check_Arg_Count (1); 8781 8782 if Nkind (A) = N_String_Literal then 8783 S := Strval (A); 8784 8785 declare 8786 Slen : constant Natural := Natural (String_Length (S)); 8787 Options : String (1 .. Slen); 8788 J : Natural; 8789 8790 begin 8791 J := 1; 8792 loop 8793 C := Get_String_Char (S, Int (J)); 8794 exit when not In_Character_Range (C); 8795 Options (J) := Get_Character (C); 8796 8797 if J = Slen then 8798 Set_Style_Check_Options (Options); 8799 exit; 8800 else 8801 J := J + 1; 8802 end if; 8803 end loop; 8804 end; 8805 8806 elsif Nkind (A) = N_Identifier then 8807 8808 if Chars (A) = Name_All_Checks then 8809 Set_Default_Style_Check_Options; 8810 8811 elsif Chars (A) = Name_On then 8812 Style_Check := True; 8813 8814 elsif Chars (A) = Name_Off then 8815 Style_Check := False; 8816 8817 end if; 8818 end if; 8819 end if; 8820 end Style_Checks; 8821 8822 -------------- 8823 -- Subtitle -- 8824 -------------- 8825 8826 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL); 8827 8828 when Pragma_Subtitle => 8829 GNAT_Pragma; 8830 Check_Arg_Count (1); 8831 Check_Optional_Identifier (Arg1, Name_Subtitle); 8832 Check_Arg_Is_String_Literal (Arg1); 8833 8834 -------------- 8835 -- Suppress -- 8836 -------------- 8837 8838 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]); 8839 8840 when Pragma_Suppress => 8841 Process_Suppress_Unsuppress (True); 8842 8843 ------------------ 8844 -- Suppress_All -- 8845 ------------------ 8846 8847 -- pragma Suppress_All; 8848 8849 -- The only check made here is that the pragma appears in the 8850 -- proper place, i.e. following a compilation unit. If indeed 8851 -- it appears in this context, then the parser has already 8852 -- inserted an equivalent pragma Suppress (All_Checks) to get 8853 -- the required effect. 8854 8855 when Pragma_Suppress_All => 8856 GNAT_Pragma; 8857 Check_Arg_Count (0); 8858 8859 if Nkind (Parent (N)) /= N_Compilation_Unit_Aux 8860 or else not Is_List_Member (N) 8861 or else List_Containing (N) /= Pragmas_After (Parent (N)) 8862 then 8863 Error_Pragma 8864 ("misplaced pragma%, must follow compilation unit"); 8865 end if; 8866 8867 ------------------------- 8868 -- Suppress_Debug_Info -- 8869 ------------------------- 8870 8871 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME); 8872 8873 when Pragma_Suppress_Debug_Info => 8874 GNAT_Pragma; 8875 Check_Arg_Count (1); 8876 Check_Arg_Is_Local_Name (Arg1); 8877 Check_Optional_Identifier (Arg1, Name_Entity); 8878 Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1))); 8879 8880 ---------------------------------- 8881 -- Suppress_Exception_Locations -- 8882 ---------------------------------- 8883 8884 -- pragma Suppress_Exception_Locations; 8885 8886 when Pragma_Suppress_Exception_Locations => 8887 GNAT_Pragma; 8888 Check_Arg_Count (0); 8889 Check_Valid_Configuration_Pragma; 8890 Exception_Locations_Suppressed := True; 8891 8892 ----------------------------- 8893 -- Suppress_Initialization -- 8894 ----------------------------- 8895 8896 -- pragma Suppress_Initialization ([Entity =>] type_Name); 8897 8898 when Pragma_Suppress_Initialization => Suppress_Init : declare 8899 E_Id : Node_Id; 8900 E : Entity_Id; 8901 8902 begin 8903 GNAT_Pragma; 8904 Check_Arg_Count (1); 8905 Check_Optional_Identifier (Arg1, Name_Entity); 8906 Check_Arg_Is_Local_Name (Arg1); 8907 8908 E_Id := Expression (Arg1); 8909 8910 if Etype (E_Id) = Any_Type then 8911 return; 8912 end if; 8913 8914 E := Entity (E_Id); 8915 8916 if Is_Type (E) then 8917 if Is_Incomplete_Or_Private_Type (E) then 8918 if No (Full_View (Base_Type (E))) then 8919 Error_Pragma_Arg 8920 ("argument of pragma% cannot be an incomplete type", 8921 Arg1); 8922 else 8923 Set_Suppress_Init_Proc (Full_View (Base_Type (E))); 8924 end if; 8925 else 8926 Set_Suppress_Init_Proc (Base_Type (E)); 8927 end if; 8928 8929 else 8930 Error_Pragma_Arg 8931 ("pragma% requires argument that is a type name", Arg1); 8932 end if; 8933 end Suppress_Init; 8934 8935 ----------------- 8936 -- System_Name -- 8937 ----------------- 8938 8939 -- pragma System_Name (DIRECT_NAME); 8940 8941 -- Syntax check: one argument, which must be the identifier GNAT 8942 -- or the identifier GCC, no other identifiers are acceptable. 8943 8944 when Pragma_System_Name => 8945 Check_No_Identifiers; 8946 Check_Arg_Count (1); 8947 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat); 8948 8949 ----------------------------- 8950 -- Task_Dispatching_Policy -- 8951 ----------------------------- 8952 8953 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER); 8954 8955 when Pragma_Task_Dispatching_Policy => declare 8956 DP : Character; 8957 8958 begin 8959 Check_Ada_83_Warning; 8960 Check_Arg_Count (1); 8961 Check_No_Identifiers; 8962 Check_Arg_Is_Task_Dispatching_Policy (Arg1); 8963 Check_Valid_Configuration_Pragma; 8964 Get_Name_String (Chars (Expression (Arg1))); 8965 DP := Fold_Upper (Name_Buffer (1)); 8966 8967 if Task_Dispatching_Policy /= ' ' 8968 and then Task_Dispatching_Policy /= DP 8969 then 8970 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc; 8971 Error_Pragma 8972 ("task dispatching policy incompatible with policy#"); 8973 8974 -- Set new policy, but always preserve System_Location since 8975 -- we like the error message with the run time name. 8976 8977 else 8978 Task_Dispatching_Policy := DP; 8979 8980 if Task_Dispatching_Policy_Sloc /= System_Location then 8981 Task_Dispatching_Policy_Sloc := Loc; 8982 end if; 8983 end if; 8984 end; 8985 8986 -------------- 8987 -- Task_Info -- 8988 -------------- 8989 8990 -- pragma Task_Info (EXPRESSION); 8991 8992 when Pragma_Task_Info => Task_Info : declare 8993 P : constant Node_Id := Parent (N); 8994 8995 begin 8996 GNAT_Pragma; 8997 8998 if Nkind (P) /= N_Task_Definition then 8999 Error_Pragma ("pragma% must appear in task definition"); 9000 end if; 9001 9002 Check_No_Identifiers; 9003 Check_Arg_Count (1); 9004 9005 Analyze_And_Resolve (Expression (Arg1), RTE (RE_Task_Info_Type)); 9006 9007 if Etype (Expression (Arg1)) = Any_Type then 9008 return; 9009 end if; 9010 9011 if Has_Task_Info_Pragma (P) then 9012 Error_Pragma ("duplicate pragma% not allowed"); 9013 else 9014 Set_Has_Task_Info_Pragma (P, True); 9015 end if; 9016 end Task_Info; 9017 9018 --------------- 9019 -- Task_Name -- 9020 --------------- 9021 9022 -- pragma Task_Name (string_EXPRESSION); 9023 9024 when Pragma_Task_Name => Task_Name : declare 9025 -- pragma Priority (EXPRESSION); 9026 9027 P : constant Node_Id := Parent (N); 9028 Arg : Node_Id; 9029 9030 begin 9031 Check_No_Identifiers; 9032 Check_Arg_Count (1); 9033 9034 Arg := Expression (Arg1); 9035 Analyze_And_Resolve (Arg, Standard_String); 9036 9037 if Nkind (P) /= N_Task_Definition then 9038 Pragma_Misplaced; 9039 end if; 9040 9041 if Has_Task_Name_Pragma (P) then 9042 Error_Pragma ("duplicate pragma% not allowed"); 9043 else 9044 Set_Has_Task_Name_Pragma (P, True); 9045 Record_Rep_Item (Defining_Identifier (Parent (P)), N); 9046 end if; 9047 end Task_Name; 9048 9049 ------------------ 9050 -- Task_Storage -- 9051 ------------------ 9052 9053 -- pragma Task_Storage ( 9054 -- [Task_Type =>] LOCAL_NAME, 9055 -- [Top_Guard =>] static_integer_EXPRESSION); 9056 9057 when Pragma_Task_Storage => Task_Storage : declare 9058 Args : Args_List (1 .. 2); 9059 Names : constant Name_List (1 .. 2) := ( 9060 Name_Task_Type, 9061 Name_Top_Guard); 9062 9063 Task_Type : Node_Id renames Args (1); 9064 Top_Guard : Node_Id renames Args (2); 9065 9066 Ent : Entity_Id; 9067 9068 begin 9069 GNAT_Pragma; 9070 Gather_Associations (Names, Args); 9071 9072 if No (Task_Type) then 9073 Error_Pragma 9074 ("missing task_type argument for pragma%"); 9075 end if; 9076 9077 Check_Arg_Is_Local_Name (Task_Type); 9078 9079 Ent := Entity (Task_Type); 9080 9081 if not Is_Task_Type (Ent) then 9082 Error_Pragma_Arg 9083 ("argument for pragma% must be task type", Task_Type); 9084 end if; 9085 9086 if No (Top_Guard) then 9087 Error_Pragma_Arg 9088 ("pragma% takes two arguments", Task_Type); 9089 else 9090 Check_Arg_Is_Static_Expression (Top_Guard, Any_Integer); 9091 end if; 9092 9093 Check_First_Subtype (Task_Type); 9094 9095 if Rep_Item_Too_Late (Ent, N) then 9096 raise Pragma_Exit; 9097 end if; 9098 end Task_Storage; 9099 9100 ----------------- 9101 -- Thread_Body -- 9102 ----------------- 9103 9104 -- pragma Thread_Body 9105 -- ( [Entity =>] LOCAL_NAME 9106 -- [,[Secondary_Stack_Size =>] static_integer_EXPRESSION]); 9107 9108 when Pragma_Thread_Body => Thread_Body : declare 9109 Id : Node_Id; 9110 SS : Node_Id; 9111 E : Entity_Id; 9112 9113 begin 9114 GNAT_Pragma; 9115 Check_At_Least_N_Arguments (1); 9116 Check_At_Most_N_Arguments (2); 9117 Check_Optional_Identifier (Arg1, Name_Entity); 9118 Check_Arg_Is_Local_Name (Arg1); 9119 9120 Id := Expression (Arg1); 9121 9122 if not Is_Entity_Name (Id) 9123 or else not Is_Subprogram (Entity (Id)) 9124 then 9125 Error_Pragma_Arg ("subprogram name required", Arg1); 9126 end if; 9127 9128 E := Entity (Id); 9129 9130 -- Go to renamed subprogram if present, since Thread_Body applies 9131 -- to the actual renamed entity, not to the renaming entity. 9132 9133 if Present (Alias (E)) 9134 and then Nkind (Parent (Declaration_Node (E))) = 9135 N_Subprogram_Renaming_Declaration 9136 then 9137 E := Alias (E); 9138 end if; 9139 9140 -- Various error checks 9141 9142 if Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body then 9143 Error_Pragma 9144 ("pragma% requires separate spec and must come before body"); 9145 9146 elsif Rep_Item_Too_Early (E, N) 9147 or else 9148 Rep_Item_Too_Late (E, N) 9149 then 9150 raise Pragma_Exit; 9151 9152 elsif Is_Thread_Body (E) then 9153 Error_Pragma_Arg 9154 ("only one thread body pragma allowed", Arg1); 9155 9156 elsif Present (Homonym (E)) 9157 and then Scope (Homonym (E)) = Current_Scope 9158 then 9159 Error_Pragma_Arg 9160 ("thread body subprogram must not be overloaded", Arg1); 9161 end if; 9162 9163 Set_Is_Thread_Body (E); 9164 9165 -- Deal with secondary stack argument 9166 9167 if Arg_Count = 2 then 9168 Check_Optional_Identifier (Arg2, Name_Secondary_Stack_Size); 9169 SS := Expression (Arg2); 9170 Analyze_And_Resolve (SS, Any_Integer); 9171 end if; 9172 end Thread_Body; 9173 9174 ---------------- 9175 -- Time_Slice -- 9176 ---------------- 9177 9178 -- pragma Time_Slice (static_duration_EXPRESSION); 9179 9180 when Pragma_Time_Slice => Time_Slice : declare 9181 Val : Ureal; 9182 Nod : Node_Id; 9183 9184 begin 9185 GNAT_Pragma; 9186 Check_Arg_Count (1); 9187 Check_No_Identifiers; 9188 Check_In_Main_Program; 9189 Check_Arg_Is_Static_Expression (Arg1, Standard_Duration); 9190 9191 if not Error_Posted (Arg1) then 9192 Nod := Next (N); 9193 while Present (Nod) loop 9194 if Nkind (Nod) = N_Pragma 9195 and then Chars (Nod) = Name_Time_Slice 9196 then 9197 Error_Msg_Name_1 := Chars (N); 9198 Error_Msg_N ("duplicate pragma% not permitted", Nod); 9199 end if; 9200 9201 Next (Nod); 9202 end loop; 9203 end if; 9204 9205 -- Process only if in main unit 9206 9207 if Get_Source_Unit (Loc) = Main_Unit then 9208 Opt.Time_Slice_Set := True; 9209 Val := Expr_Value_R (Expression (Arg1)); 9210 9211 if Val <= Ureal_0 then 9212 Opt.Time_Slice_Value := 0; 9213 9214 elsif Val > UR_From_Uint (UI_From_Int (1000)) then 9215 Opt.Time_Slice_Value := 1_000_000_000; 9216 9217 else 9218 Opt.Time_Slice_Value := 9219 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000))); 9220 end if; 9221 end if; 9222 end Time_Slice; 9223 9224 ----------- 9225 -- Title -- 9226 ----------- 9227 9228 -- pragma Title (TITLING_OPTION [, TITLING OPTION]); 9229 9230 -- TITLING_OPTION ::= 9231 -- [Title =>] STRING_LITERAL 9232 -- | [Subtitle =>] STRING_LITERAL 9233 9234 when Pragma_Title => Title : declare 9235 Args : Args_List (1 .. 2); 9236 Names : constant Name_List (1 .. 2) := ( 9237 Name_Title, 9238 Name_Subtitle); 9239 9240 begin 9241 GNAT_Pragma; 9242 Gather_Associations (Names, Args); 9243 9244 for J in 1 .. 2 loop 9245 if Present (Args (J)) then 9246 Check_Arg_Is_String_Literal (Args (J)); 9247 end if; 9248 end loop; 9249 end Title; 9250 9251 --------------------- 9252 -- Unchecked_Union -- 9253 --------------------- 9254 9255 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME) 9256 9257 when Pragma_Unchecked_Union => Unchecked_Union : declare 9258 Assoc : constant Node_Id := Arg1; 9259 Type_Id : constant Node_Id := Expression (Assoc); 9260 Typ : Entity_Id; 9261 Discr : Entity_Id; 9262 Tdef : Node_Id; 9263 Clist : Node_Id; 9264 Vpart : Node_Id; 9265 Comp : Node_Id; 9266 Variant : Node_Id; 9267 9268 begin 9269 GNAT_Pragma; 9270 Check_No_Identifiers; 9271 Check_Arg_Count (1); 9272 Check_Arg_Is_Local_Name (Arg1); 9273 9274 Find_Type (Type_Id); 9275 Typ := Entity (Type_Id); 9276 9277 if Typ = Any_Type 9278 or else Rep_Item_Too_Early (Typ, N) 9279 then 9280 return; 9281 else 9282 Typ := Underlying_Type (Typ); 9283 end if; 9284 9285 if Rep_Item_Too_Late (Typ, N) then 9286 return; 9287 end if; 9288 9289 Check_First_Subtype (Arg1); 9290 9291 -- Note remaining cases are references to a type in the current 9292 -- declarative part. If we find an error, we post the error on 9293 -- the relevant type declaration at an appropriate point. 9294 9295 if not Is_Record_Type (Typ) then 9296 Error_Msg_N ("Unchecked_Union must be record type", Typ); 9297 return; 9298 9299 elsif Is_Tagged_Type (Typ) then 9300 Error_Msg_N ("Unchecked_Union must not be tagged", Typ); 9301 return; 9302 9303 elsif Is_Limited_Type (Typ) then 9304 Error_Msg_N 9305 ("Unchecked_Union must not be limited record type", Typ); 9306 Explain_Limited_Type (Typ, Typ); 9307 return; 9308 9309 else 9310 if not Has_Discriminants (Typ) then 9311 Error_Msg_N 9312 ("Unchecked_Union must have one discriminant", Typ); 9313 return; 9314 end if; 9315 9316 Discr := First_Discriminant (Typ); 9317 9318 if Present (Next_Discriminant (Discr)) then 9319 Error_Msg_N 9320 ("Unchecked_Union must have exactly one discriminant", 9321 Next_Discriminant (Discr)); 9322 return; 9323 end if; 9324 9325 if No (Discriminant_Default_Value (Discr)) then 9326 Error_Msg_N 9327 ("Unchecked_Union discriminant must have default value", 9328 Discr); 9329 end if; 9330 9331 Tdef := Type_Definition (Declaration_Node (Typ)); 9332 Clist := Component_List (Tdef); 9333 9334 if No (Clist) or else No (Variant_Part (Clist)) then 9335 Error_Msg_N 9336 ("Unchecked_Union must have variant part", 9337 Tdef); 9338 return; 9339 end if; 9340 9341 Vpart := Variant_Part (Clist); 9342 9343 if Is_Non_Empty_List (Component_Items (Clist)) then 9344 Error_Msg_N 9345 ("components before variant not allowed " & 9346 "in Unchecked_Union", 9347 First (Component_Items (Clist))); 9348 end if; 9349 9350 Variant := First (Variants (Vpart)); 9351 while Present (Variant) loop 9352 Clist := Component_List (Variant); 9353 9354 if Present (Variant_Part (Clist)) then 9355 Error_Msg_N 9356 ("Unchecked_Union may not have nested variants", 9357 Variant_Part (Clist)); 9358 end if; 9359 9360 if not Is_Non_Empty_List (Component_Items (Clist)) then 9361 Error_Msg_N 9362 ("Unchecked_Union may not have empty component list", 9363 Variant); 9364 return; 9365 end if; 9366 9367 Comp := First (Component_Items (Clist)); 9368 9369 if Nkind (Comp) = N_Component_Declaration then 9370 9371 if Present (Expression (Comp)) then 9372 Error_Msg_N 9373 ("default initialization not allowed " & 9374 "in Unchecked_Union", 9375 Expression (Comp)); 9376 end if; 9377 9378 declare 9379 Sindic : constant Node_Id := 9380 Subtype_Indication (Component_Definition (Comp)); 9381 9382 begin 9383 if Nkind (Sindic) = N_Subtype_Indication then 9384 Check_Static_Constraint (Constraint (Sindic)); 9385 end if; 9386 end; 9387 end if; 9388 9389 if Present (Next (Comp)) then 9390 Error_Msg_N 9391 ("Unchecked_Union variant can have only one component", 9392 Next (Comp)); 9393 end if; 9394 9395 Next (Variant); 9396 end loop; 9397 end if; 9398 9399 Set_Is_Unchecked_Union (Typ, True); 9400 Set_Convention (Typ, Convention_C); 9401 9402 Set_Has_Unchecked_Union (Base_Type (Typ), True); 9403 Set_Is_Unchecked_Union (Base_Type (Typ), True); 9404 end Unchecked_Union; 9405 9406 ------------------------ 9407 -- Unimplemented_Unit -- 9408 ------------------------ 9409 9410 -- pragma Unimplemented_Unit; 9411 9412 -- Note: this only gives an error if we are generating code, 9413 -- or if we are in a generic library unit (where the pragma 9414 -- appears in the body, not in the spec). 9415 9416 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare 9417 Cunitent : constant Entity_Id := 9418 Cunit_Entity (Get_Source_Unit (Loc)); 9419 Ent_Kind : constant Entity_Kind := 9420 Ekind (Cunitent); 9421 9422 begin 9423 GNAT_Pragma; 9424 Check_Arg_Count (0); 9425 9426 if Operating_Mode = Generate_Code 9427 or else Ent_Kind = E_Generic_Function 9428 or else Ent_Kind = E_Generic_Procedure 9429 or else Ent_Kind = E_Generic_Package 9430 then 9431 Get_Name_String (Chars (Cunitent)); 9432 Set_Casing (Mixed_Case); 9433 Write_Str (Name_Buffer (1 .. Name_Len)); 9434 Write_Str (" is not implemented"); 9435 Write_Eol; 9436 raise Unrecoverable_Error; 9437 end if; 9438 end Unimplemented_Unit; 9439 9440 -------------------- 9441 -- Universal_Data -- 9442 -------------------- 9443 9444 -- pragma Universal_Data [(library_unit_NAME)]; 9445 9446 when Pragma_Universal_Data => 9447 GNAT_Pragma; 9448 9449 -- If this is a configuration pragma, then set the universal 9450 -- addressing option, otherwise confirm that the pragma 9451 -- satisfies the requirements of library unit pragma placement 9452 -- and leave it to the GNAAMP back end to detect the pragma 9453 -- (avoids transitive setting of the option due to withed units). 9454 9455 if Is_Configuration_Pragma then 9456 Universal_Addressing_On_AAMP := True; 9457 else 9458 Check_Valid_Library_Unit_Pragma; 9459 end if; 9460 9461 if not AAMP_On_Target then 9462 Error_Pragma ("?pragma% ignored (applies only to AAMP)"); 9463 end if; 9464 9465 ------------------ 9466 -- Unreferenced -- 9467 ------------------ 9468 9469 -- pragma Unreferenced (local_Name {, local_Name}); 9470 9471 when Pragma_Unreferenced => Unreferenced : declare 9472 Arg_Node : Node_Id; 9473 Arg_Expr : Node_Id; 9474 Arg_Ent : Entity_Id; 9475 9476 begin 9477 GNAT_Pragma; 9478 Check_At_Least_N_Arguments (1); 9479 9480 Arg_Node := Arg1; 9481 9482 while Present (Arg_Node) loop 9483 Check_No_Identifier (Arg_Node); 9484 9485 -- Note that the analyze call done by Check_Arg_Is_Local_Name 9486 -- will in fact generate a reference, so that the entity will 9487 -- have a reference, which will inhibit any warnings about it 9488 -- not being referenced, and also properly show up in the ali 9489 -- file as a reference. But this reference is recorded before 9490 -- the Has_Pragma_Unreferenced flag is set, so that no warning 9491 -- is generated for this reference. 9492 9493 Check_Arg_Is_Local_Name (Arg_Node); 9494 Arg_Expr := Get_Pragma_Arg (Arg_Node); 9495 9496 if Is_Entity_Name (Arg_Expr) then 9497 Arg_Ent := Entity (Arg_Expr); 9498 9499 -- If the entity is overloaded, the pragma applies to the 9500 -- most recent overloading, as documented. In this case, 9501 -- name resolution does not generate a reference, so it 9502 -- must be done here explicitly. 9503 9504 if Is_Overloaded (Arg_Expr) then 9505 Generate_Reference (Arg_Ent, N); 9506 end if; 9507 9508 Set_Has_Pragma_Unreferenced (Arg_Ent); 9509 end if; 9510 9511 Next (Arg_Node); 9512 end loop; 9513 end Unreferenced; 9514 9515 ------------------------------ 9516 -- Unreserve_All_Interrupts -- 9517 ------------------------------ 9518 9519 -- pragma Unreserve_All_Interrupts; 9520 9521 when Pragma_Unreserve_All_Interrupts => 9522 GNAT_Pragma; 9523 Check_Arg_Count (0); 9524 9525 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then 9526 Unreserve_All_Interrupts := True; 9527 end if; 9528 9529 ---------------- 9530 -- Unsuppress -- 9531 ---------------- 9532 9533 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]); 9534 9535 when Pragma_Unsuppress => 9536 GNAT_Pragma; 9537 Process_Suppress_Unsuppress (False); 9538 9539 ------------------- 9540 -- Use_VADS_Size -- 9541 ------------------- 9542 9543 -- pragma Use_VADS_Size; 9544 9545 when Pragma_Use_VADS_Size => 9546 GNAT_Pragma; 9547 Check_Arg_Count (0); 9548 Check_Valid_Configuration_Pragma; 9549 Use_VADS_Size := True; 9550 9551 --------------------- 9552 -- Validity_Checks -- 9553 --------------------- 9554 9555 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL); 9556 9557 when Pragma_Validity_Checks => Validity_Checks : declare 9558 A : constant Node_Id := Expression (Arg1); 9559 S : String_Id; 9560 C : Char_Code; 9561 9562 begin 9563 GNAT_Pragma; 9564 Check_Arg_Count (1); 9565 Check_No_Identifiers; 9566 9567 if Nkind (A) = N_String_Literal then 9568 S := Strval (A); 9569 9570 declare 9571 Slen : constant Natural := Natural (String_Length (S)); 9572 Options : String (1 .. Slen); 9573 J : Natural; 9574 9575 begin 9576 J := 1; 9577 loop 9578 C := Get_String_Char (S, Int (J)); 9579 exit when not In_Character_Range (C); 9580 Options (J) := Get_Character (C); 9581 9582 if J = Slen then 9583 Set_Validity_Check_Options (Options); 9584 exit; 9585 else 9586 J := J + 1; 9587 end if; 9588 end loop; 9589 end; 9590 9591 elsif Nkind (A) = N_Identifier then 9592 9593 if Chars (A) = Name_All_Checks then 9594 Set_Validity_Check_Options ("a"); 9595 9596 elsif Chars (A) = Name_On then 9597 Validity_Checks_On := True; 9598 9599 elsif Chars (A) = Name_Off then 9600 Validity_Checks_On := False; 9601 9602 end if; 9603 end if; 9604 end Validity_Checks; 9605 9606 -------------- 9607 -- Volatile -- 9608 -------------- 9609 9610 -- pragma Volatile (LOCAL_NAME); 9611 9612 when Pragma_Volatile => 9613 Process_Atomic_Shared_Volatile; 9614 9615 ------------------------- 9616 -- Volatile_Components -- 9617 ------------------------- 9618 9619 -- pragma Volatile_Components (array_LOCAL_NAME); 9620 9621 -- Volatile is handled by the same circuit as Atomic_Components 9622 9623 -------------- 9624 -- Warnings -- 9625 -------------- 9626 9627 -- pragma Warnings (On | Off, [LOCAL_NAME]) 9628 9629 when Pragma_Warnings => Warnings : begin 9630 GNAT_Pragma; 9631 Check_At_Least_N_Arguments (1); 9632 Check_At_Most_N_Arguments (2); 9633 Check_No_Identifiers; 9634 9635 -- One argument case was processed by parser in Par.Prag 9636 9637 if Arg_Count /= 1 then 9638 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 9639 Check_Arg_Count (2); 9640 9641 declare 9642 E_Id : Node_Id; 9643 E : Entity_Id; 9644 9645 begin 9646 E_Id := Expression (Arg2); 9647 Analyze (E_Id); 9648 9649 -- In the expansion of an inlined body, a reference to 9650 -- the formal may be wrapped in a conversion if the actual 9651 -- is a conversion. Retrieve the real entity name. 9652 9653 if In_Instance_Body 9654 and then Nkind (E_Id) = N_Unchecked_Type_Conversion 9655 then 9656 E_Id := Expression (E_Id); 9657 end if; 9658 9659 if not Is_Entity_Name (E_Id) then 9660 Error_Pragma_Arg 9661 ("second argument of pragma% must be entity name", 9662 Arg2); 9663 end if; 9664 9665 E := Entity (E_Id); 9666 9667 if E = Any_Id then 9668 return; 9669 else 9670 loop 9671 Set_Warnings_Off (E, 9672 (Chars (Expression (Arg1)) = Name_Off)); 9673 9674 if Is_Enumeration_Type (E) then 9675 declare 9676 Lit : Entity_Id := First_Literal (E); 9677 9678 begin 9679 while Present (Lit) loop 9680 Set_Warnings_Off (Lit); 9681 Next_Literal (Lit); 9682 end loop; 9683 end; 9684 end if; 9685 9686 exit when No (Homonym (E)); 9687 E := Homonym (E); 9688 end loop; 9689 end if; 9690 end; 9691 end if; 9692 end Warnings; 9693 9694 ------------------- 9695 -- Weak_External -- 9696 ------------------- 9697 9698 -- pragma Weak_External ([Entity =>] LOCAL_NAME); 9699 9700 when Pragma_Weak_External => Weak_External : declare 9701 Ent : Entity_Id; 9702 9703 begin 9704 GNAT_Pragma; 9705 Check_Arg_Count (1); 9706 Check_Optional_Identifier (Arg1, Name_Entity); 9707 Check_Arg_Is_Library_Level_Local_Name (Arg1); 9708 Ent := Entity (Expression (Arg1)); 9709 9710 if Rep_Item_Too_Early (Ent, N) then 9711 return; 9712 else 9713 Ent := Underlying_Type (Ent); 9714 end if; 9715 9716 -- The only processing required is to link this item on to the 9717 -- list of rep items for the given entity. This is accomplished 9718 -- by the call to Rep_Item_Too_Late (when no error is detected 9719 -- and False is returned). 9720 9721 if Rep_Item_Too_Late (Ent, N) then 9722 return; 9723 else 9724 Set_Has_Gigi_Rep_Item (Ent); 9725 end if; 9726 end Weak_External; 9727 9728 -------------------- 9729 -- Unknown_Pragma -- 9730 -------------------- 9731 9732 -- Should be impossible, since the case of an unknown pragma is 9733 -- separately processed before the case statement is entered. 9734 9735 when Unknown_Pragma => 9736 raise Program_Error; 9737 9738 end case; 9739 9740 exception 9741 when Pragma_Exit => null; 9742 end Analyze_Pragma; 9743 9744 --------------------------------- 9745 -- Delay_Config_Pragma_Analyze -- 9746 --------------------------------- 9747 9748 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is 9749 begin 9750 return Chars (N) = Name_Interrupt_State; 9751 end Delay_Config_Pragma_Analyze; 9752 9753 ------------------------- 9754 -- Get_Base_Subprogram -- 9755 ------------------------- 9756 9757 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is 9758 Result : Entity_Id; 9759 9760 begin 9761 Result := Def_Id; 9762 9763 -- Follow subprogram renaming chain 9764 9765 while Is_Subprogram (Result) 9766 and then 9767 (Is_Generic_Instance (Result) 9768 or else Nkind (Parent (Declaration_Node (Result))) = 9769 N_Subprogram_Renaming_Declaration) 9770 and then Present (Alias (Result)) 9771 loop 9772 Result := Alias (Result); 9773 end loop; 9774 9775 return Result; 9776 end Get_Base_Subprogram; 9777 9778 ----------------------------------------- 9779 -- Is_Non_Significant_Pragma_Reference -- 9780 ----------------------------------------- 9781 9782 -- This function makes use of the following static table which indicates 9783 -- whether a given pragma is significant. A value of -1 in this table 9784 -- indicates that the reference is significant. A value of zero indicates 9785 -- than appearence as any argument is insignificant, a positive value 9786 -- indicates that appearence in that parameter position is significant. 9787 9788 Sig_Flags : constant array (Pragma_Id) of Int := 9789 (Pragma_AST_Entry => -1, 9790 Pragma_Abort_Defer => -1, 9791 Pragma_Ada_83 => -1, 9792 Pragma_Ada_95 => -1, 9793 Pragma_All_Calls_Remote => -1, 9794 Pragma_Annotate => -1, 9795 Pragma_Assert => -1, 9796 Pragma_Asynchronous => -1, 9797 Pragma_Atomic => 0, 9798 Pragma_Atomic_Components => 0, 9799 Pragma_Attach_Handler => -1, 9800 Pragma_CPP_Class => 0, 9801 Pragma_CPP_Constructor => 0, 9802 Pragma_CPP_Virtual => 0, 9803 Pragma_CPP_Vtable => 0, 9804 Pragma_C_Pass_By_Copy => 0, 9805 Pragma_Comment => 0, 9806 Pragma_Common_Object => -1, 9807 Pragma_Compile_Time_Warning => -1, 9808 Pragma_Complex_Representation => 0, 9809 Pragma_Component_Alignment => -1, 9810 Pragma_Controlled => 0, 9811 Pragma_Convention => 0, 9812 Pragma_Convention_Identifier => 0, 9813 Pragma_Debug => -1, 9814 Pragma_Discard_Names => 0, 9815 Pragma_Elaborate => -1, 9816 Pragma_Elaborate_All => -1, 9817 Pragma_Elaborate_Body => -1, 9818 Pragma_Elaboration_Checks => -1, 9819 Pragma_Eliminate => -1, 9820 Pragma_Explicit_Overriding => -1, 9821 Pragma_Export => -1, 9822 Pragma_Export_Exception => -1, 9823 Pragma_Export_Function => -1, 9824 Pragma_Export_Object => -1, 9825 Pragma_Export_Procedure => -1, 9826 Pragma_Export_Value => -1, 9827 Pragma_Export_Valued_Procedure => -1, 9828 Pragma_Extend_System => -1, 9829 Pragma_Extensions_Allowed => -1, 9830 Pragma_External => -1, 9831 Pragma_External_Name_Casing => -1, 9832 Pragma_Finalize_Storage_Only => 0, 9833 Pragma_Float_Representation => 0, 9834 Pragma_Ident => -1, 9835 Pragma_Import => +2, 9836 Pragma_Import_Exception => 0, 9837 Pragma_Import_Function => 0, 9838 Pragma_Import_Object => 0, 9839 Pragma_Import_Procedure => 0, 9840 Pragma_Import_Valued_Procedure => 0, 9841 Pragma_Initialize_Scalars => -1, 9842 Pragma_Inline => 0, 9843 Pragma_Inline_Always => 0, 9844 Pragma_Inline_Generic => 0, 9845 Pragma_Inspection_Point => -1, 9846 Pragma_Interface => +2, 9847 Pragma_Interface_Name => +2, 9848 Pragma_Interrupt_Handler => -1, 9849 Pragma_Interrupt_Priority => -1, 9850 Pragma_Interrupt_State => -1, 9851 Pragma_Java_Constructor => -1, 9852 Pragma_Java_Interface => -1, 9853 Pragma_Keep_Names => 0, 9854 Pragma_License => -1, 9855 Pragma_Link_With => -1, 9856 Pragma_Linker_Alias => -1, 9857 Pragma_Linker_Options => -1, 9858 Pragma_Linker_Section => -1, 9859 Pragma_List => -1, 9860 Pragma_Locking_Policy => -1, 9861 Pragma_Long_Float => -1, 9862 Pragma_Machine_Attribute => -1, 9863 Pragma_Main => -1, 9864 Pragma_Main_Storage => -1, 9865 Pragma_Memory_Size => -1, 9866 Pragma_No_Return => 0, 9867 Pragma_No_Run_Time => -1, 9868 Pragma_Normalize_Scalars => -1, 9869 Pragma_Obsolescent => 0, 9870 Pragma_Optimize => -1, 9871 Pragma_Optional_Overriding => -1, 9872 Pragma_Overriding => -1, 9873 Pragma_Pack => 0, 9874 Pragma_Page => -1, 9875 Pragma_Passive => -1, 9876 Pragma_Polling => -1, 9877 Pragma_Persistent_Data => -1, 9878 Pragma_Persistent_Object => -1, 9879 Pragma_Preelaborate => -1, 9880 Pragma_Priority => -1, 9881 Pragma_Propagate_Exceptions => -1, 9882 Pragma_Psect_Object => -1, 9883 Pragma_Pure => 0, 9884 Pragma_Pure_Function => 0, 9885 Pragma_Queuing_Policy => -1, 9886 Pragma_Ravenscar => -1, 9887 Pragma_Remote_Call_Interface => -1, 9888 Pragma_Remote_Types => -1, 9889 Pragma_Restricted_Run_Time => -1, 9890 Pragma_Restriction_Warnings => -1, 9891 Pragma_Restrictions => -1, 9892 Pragma_Reviewable => -1, 9893 Pragma_Share_Generic => -1, 9894 Pragma_Shared => -1, 9895 Pragma_Shared_Passive => -1, 9896 Pragma_Source_File_Name => -1, 9897 Pragma_Source_File_Name_Project => -1, 9898 Pragma_Source_Reference => -1, 9899 Pragma_Storage_Size => -1, 9900 Pragma_Storage_Unit => -1, 9901 Pragma_Stream_Convert => -1, 9902 Pragma_Style_Checks => -1, 9903 Pragma_Subtitle => -1, 9904 Pragma_Suppress => 0, 9905 Pragma_Suppress_Exception_Locations => 0, 9906 Pragma_Suppress_All => -1, 9907 Pragma_Suppress_Debug_Info => 0, 9908 Pragma_Suppress_Initialization => 0, 9909 Pragma_System_Name => -1, 9910 Pragma_Task_Dispatching_Policy => -1, 9911 Pragma_Task_Info => -1, 9912 Pragma_Task_Name => -1, 9913 Pragma_Task_Storage => 0, 9914 Pragma_Thread_Body => +2, 9915 Pragma_Time_Slice => -1, 9916 Pragma_Title => -1, 9917 Pragma_Unchecked_Union => -1, 9918 Pragma_Unimplemented_Unit => -1, 9919 Pragma_Universal_Data => -1, 9920 Pragma_Unreferenced => -1, 9921 Pragma_Unreserve_All_Interrupts => -1, 9922 Pragma_Unsuppress => 0, 9923 Pragma_Use_VADS_Size => -1, 9924 Pragma_Validity_Checks => -1, 9925 Pragma_Volatile => 0, 9926 Pragma_Volatile_Components => 0, 9927 Pragma_Warnings => -1, 9928 Pragma_Weak_External => 0, 9929 Unknown_Pragma => 0); 9930 9931 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is 9932 P : Node_Id; 9933 C : Int; 9934 A : Node_Id; 9935 9936 begin 9937 P := Parent (N); 9938 9939 if Nkind (P) /= N_Pragma_Argument_Association then 9940 return False; 9941 9942 else 9943 C := Sig_Flags (Get_Pragma_Id (Chars (Parent (P)))); 9944 9945 case C is 9946 when -1 => 9947 return False; 9948 9949 when 0 => 9950 return True; 9951 9952 when others => 9953 A := First (Pragma_Argument_Associations (Parent (P))); 9954 for J in 1 .. C - 1 loop 9955 if No (A) then 9956 return False; 9957 end if; 9958 9959 Next (A); 9960 end loop; 9961 9962 return A = P; 9963 end case; 9964 end if; 9965 end Is_Non_Significant_Pragma_Reference; 9966 9967 ------------------------------ 9968 -- Is_Pragma_String_Literal -- 9969 ------------------------------ 9970 9971 -- This function returns true if the corresponding pragma argument is 9972 -- a static string expression. These are the only cases in which string 9973 -- literals can appear as pragma arguments. We also allow a string 9974 -- literal as the first argument to pragma Assert (although it will 9975 -- of course always generate a type error). 9976 9977 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is 9978 Pragn : constant Node_Id := Parent (Par); 9979 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn); 9980 Pname : constant Name_Id := Chars (Pragn); 9981 Argn : Natural; 9982 N : Node_Id; 9983 9984 begin 9985 Argn := 1; 9986 N := First (Assoc); 9987 loop 9988 exit when N = Par; 9989 Argn := Argn + 1; 9990 Next (N); 9991 end loop; 9992 9993 if Pname = Name_Assert then 9994 return True; 9995 9996 elsif Pname = Name_Export then 9997 return Argn > 2; 9998 9999 elsif Pname = Name_Ident then 10000 return Argn = 1; 10001 10002 elsif Pname = Name_Import then 10003 return Argn > 2; 10004 10005 elsif Pname = Name_Interface_Name then 10006 return Argn > 1; 10007 10008 elsif Pname = Name_Linker_Alias then 10009 return Argn = 2; 10010 10011 elsif Pname = Name_Linker_Section then 10012 return Argn = 2; 10013 10014 elsif Pname = Name_Machine_Attribute then 10015 return Argn = 2; 10016 10017 elsif Pname = Name_Source_File_Name then 10018 return True; 10019 10020 elsif Pname = Name_Source_Reference then 10021 return Argn = 2; 10022 10023 elsif Pname = Name_Title then 10024 return True; 10025 10026 elsif Pname = Name_Subtitle then 10027 return True; 10028 10029 else 10030 return False; 10031 end if; 10032 end Is_Pragma_String_Literal; 10033 10034 -------------------------------------- 10035 -- Process_Compilation_Unit_Pragmas -- 10036 -------------------------------------- 10037 10038 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is 10039 begin 10040 -- A special check for pragma Suppress_All. This is a strange DEC 10041 -- pragma, strange because it comes at the end of the unit. If we 10042 -- have a pragma Suppress_All in the Pragmas_After of the current 10043 -- unit, then we insert a pragma Suppress (All_Checks) at the start 10044 -- of the context clause to ensure the correct processing. 10045 10046 declare 10047 PA : constant List_Id := Pragmas_After (Aux_Decls_Node (N)); 10048 P : Node_Id; 10049 10050 begin 10051 if Present (PA) then 10052 P := First (PA); 10053 while Present (P) loop 10054 if Chars (P) = Name_Suppress_All then 10055 Prepend_To (Context_Items (N), 10056 Make_Pragma (Sloc (P), 10057 Chars => Name_Suppress, 10058 Pragma_Argument_Associations => New_List ( 10059 Make_Pragma_Argument_Association (Sloc (P), 10060 Expression => 10061 Make_Identifier (Sloc (P), 10062 Chars => Name_All_Checks))))); 10063 exit; 10064 end if; 10065 10066 Next (P); 10067 end loop; 10068 end if; 10069 end; 10070 end Process_Compilation_Unit_Pragmas; 10071 10072 -------------------------------- 10073 -- Set_Encoded_Interface_Name -- 10074 -------------------------------- 10075 10076 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is 10077 Str : constant String_Id := Strval (S); 10078 Len : constant Int := String_Length (Str); 10079 CC : Char_Code; 10080 C : Character; 10081 J : Int; 10082 10083 Hex : constant array (0 .. 15) of Character := "0123456789abcdef"; 10084 10085 procedure Encode; 10086 -- Stores encoded value of character code CC. The encoding we 10087 -- use an underscore followed by four lower case hex digits. 10088 10089 procedure Encode is 10090 begin 10091 Store_String_Char (Get_Char_Code ('_')); 10092 Store_String_Char 10093 (Get_Char_Code (Hex (Integer (CC / 2 ** 12)))); 10094 Store_String_Char 10095 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#)))); 10096 Store_String_Char 10097 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#)))); 10098 Store_String_Char 10099 (Get_Char_Code (Hex (Integer (CC and 16#0F#)))); 10100 end Encode; 10101 10102 -- Start of processing for Set_Encoded_Interface_Name 10103 10104 begin 10105 -- If first character is asterisk, this is a link name, and we 10106 -- leave it completely unmodified. We also ignore null strings 10107 -- (the latter case happens only in error cases) and no encoding 10108 -- should occur for Java interface names. 10109 10110 if Len = 0 10111 or else Get_String_Char (Str, 1) = Get_Char_Code ('*') 10112 or else Java_VM 10113 then 10114 Set_Interface_Name (E, S); 10115 10116 else 10117 J := 1; 10118 loop 10119 CC := Get_String_Char (Str, J); 10120 10121 exit when not In_Character_Range (CC); 10122 10123 C := Get_Character (CC); 10124 10125 exit when C /= '_' and then C /= '$' 10126 and then C not in '0' .. '9' 10127 and then C not in 'a' .. 'z' 10128 and then C not in 'A' .. 'Z'; 10129 10130 if J = Len then 10131 Set_Interface_Name (E, S); 10132 return; 10133 10134 else 10135 J := J + 1; 10136 end if; 10137 end loop; 10138 10139 -- Here we need to encode. The encoding we use as follows: 10140 -- three underscores + four hex digits (lower case) 10141 10142 Start_String; 10143 10144 for J in 1 .. String_Length (Str) loop 10145 CC := Get_String_Char (Str, J); 10146 10147 if not In_Character_Range (CC) then 10148 Encode; 10149 else 10150 C := Get_Character (CC); 10151 10152 if C = '_' or else C = '$' 10153 or else C in '0' .. '9' 10154 or else C in 'a' .. 'z' 10155 or else C in 'A' .. 'Z' 10156 then 10157 Store_String_Char (CC); 10158 else 10159 Encode; 10160 end if; 10161 end if; 10162 end loop; 10163 10164 Set_Interface_Name (E, 10165 Make_String_Literal (Sloc (S), 10166 Strval => End_String)); 10167 end if; 10168 end Set_Encoded_Interface_Name; 10169 10170 ------------------- 10171 -- Set_Unit_Name -- 10172 ------------------- 10173 10174 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id) is 10175 Pref : Node_Id; 10176 Scop : Entity_Id; 10177 10178 begin 10179 if Nkind (N) = N_Identifier 10180 and then Nkind (With_Item) = N_Identifier 10181 then 10182 Set_Entity (N, Entity (With_Item)); 10183 10184 elsif Nkind (N) = N_Selected_Component then 10185 Change_Selected_Component_To_Expanded_Name (N); 10186 Set_Entity (N, Entity (With_Item)); 10187 Set_Entity (Selector_Name (N), Entity (N)); 10188 10189 Pref := Prefix (N); 10190 Scop := Scope (Entity (N)); 10191 10192 while Nkind (Pref) = N_Selected_Component loop 10193 Change_Selected_Component_To_Expanded_Name (Pref); 10194 Set_Entity (Selector_Name (Pref), Scop); 10195 Set_Entity (Pref, Scop); 10196 Pref := Prefix (Pref); 10197 Scop := Scope (Scop); 10198 end loop; 10199 10200 Set_Entity (Pref, Scop); 10201 end if; 10202 end Set_Unit_Name; 10203 10204end Sem_Prag; 10205