1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
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. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
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).
33 with Atree; use Atree;
34 with Casing; use Casing;
35 with Csets; use Csets;
36 with Debug; use Debug;
37 with Einfo; use Einfo;
38 with Elists; use Elists;
39 with Errout; use Errout;
40 with Expander; use Expander;
41 with Exp_Dist; use Exp_Dist;
42 with Fname; use Fname;
43 with Hostparm; use Hostparm;
45 with Lib.Writ; use Lib.Writ;
46 with Lib.Xref; use Lib.Xref;
47 with Namet; use Namet;
48 with Nlists; use Nlists;
49 with Nmake; use Nmake;
51 with Output; use Output;
52 with Restrict; use Restrict;
53 with Rtsfind; use Rtsfind;
55 with Sem_Ch3; use Sem_Ch3;
56 with Sem_Ch8; use Sem_Ch8;
57 with Sem_Ch13; use Sem_Ch13;
58 with Sem_Disp; use Sem_Disp;
59 with Sem_Elim; use Sem_Elim;
60 with Sem_Eval; use Sem_Eval;
61 with Sem_Intr; use Sem_Intr;
62 with Sem_Mech; use Sem_Mech;
63 with Sem_Res; use Sem_Res;
64 with Sem_Type; use Sem_Type;
65 with Sem_Util; use Sem_Util;
66 with Sem_VFpt; use Sem_VFpt;
67 with Stand; use Stand;
68 with Sinfo; use Sinfo;
69 with Sinfo.CN; use Sinfo.CN;
70 with Sinput; use Sinput;
71 with Snames; use Snames;
72 with Stringt; use Stringt;
73 with Stylesw; use Stylesw;
74 with Targparm; use Targparm;
75 with Tbuild; use Tbuild;
77 with Uintp; use Uintp;
78 with Urealp; use Urealp;
79 with Validsw; use Validsw;
81 with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
83 package body Sem_Prag is
85 ----------------------------------------------
86 -- Common Handling of Import-Export Pragmas --
87 ----------------------------------------------
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:
95 -- [Internal =>] LOCAL_NAME,
96 -- [, [External =>] EXTERNAL_SYMBOL]
97 -- [, other optional parameters ]);
100 -- [Internal =>] LOCAL_NAME,
101 -- [, [External =>] EXTERNAL_SYMBOL]
102 -- [, other optional parameters ]);
104 -- EXTERNAL_SYMBOL ::=
106 -- | static_string_EXPRESSION
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).
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).
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).
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
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.
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.
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.
140 -------------------------------------
141 -- Local Subprograms and Variables --
142 -------------------------------------
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.
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???
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.
162 -------------------------------
163 -- Adjust_External_Name_Case --
164 -------------------------------
166 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
170 -- Adjust case of literal if required
172 if Opt.External_Name_Exp_Casing = As_Is then
176 -- Copy existing string
182 for J in 1 .. String_Length (Strval (N)) loop
183 CC := Get_String_Char (Strval (N), J);
185 if Opt.External_Name_Exp_Casing = Uppercase
186 and then CC >= Get_Char_Code ('a')
187 and then CC <= Get_Char_Code ('z')
189 Store_String_Char (CC - 32);
191 elsif Opt.External_Name_Exp_Casing = Lowercase
192 and then CC >= Get_Char_Code ('A')
193 and then CC <= Get_Char_Code ('Z')
195 Store_String_Char (CC + 32);
198 Store_String_Char (CC);
203 Make_String_Literal (Sloc (N),
204 Strval => End_String);
206 end Adjust_External_Name_Case;
212 procedure Analyze_Pragma (N : Node_Id) is
213 Loc : constant Source_Ptr := Sloc (N);
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.
222 -- Number of pragma argument associations
228 -- First four pragma arguments (pragma argument association nodes,
229 -- or Empty if the corresponding argument does not exist).
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
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.
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.
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.
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.
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.
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.
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.
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.
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.
281 procedure Check_Arg_Is_Static_Expression
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.
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
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
298 procedure Check_At_Least_N_Arguments (N : Nat);
299 -- Check there are at least N arguments present
301 procedure Check_At_Most_N_Arguments (N : Nat);
302 -- Check there are no more than N arguments present
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.
308 procedure Check_In_Main_Program;
309 -- Common checks for pragmas that appear within a main program
310 -- (Priority, Main_Storage, Time_Slice).
312 procedure Check_Interrupt_Or_Attach_Handler;
313 -- Common processing for first argument of pragma Interrupt_Handler
314 -- or pragma Attach_Handler.
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
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.
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.
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.
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.
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
349 procedure Check_Valid_Configuration_Pragma;
350 -- Legality checks for placement of a configuration pragma
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.
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.
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.
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 \.
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
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.
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.
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
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.
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.
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).
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.
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)
443 procedure Pragma_Misplaced;
444 -- Issue fatal error message for misplaced pragma
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.
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.
457 procedure Process_Extended_Import_Export_Exception_Pragma
458 (Arg_Internal : Node_Id;
459 Arg_External : 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.
467 procedure Process_Extended_Import_Export_Object_Pragma
468 (Arg_Internal : Node_Id;
469 Arg_External : 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.
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.
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.
499 procedure Process_Generic_List;
500 -- Common processing for Share_Generic and Inline_Generic
502 procedure Process_Import_Or_Interface;
503 -- Common processing for Import of Interface
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.
510 procedure Process_Interface_Name
511 (Subprogram_Def : Entity_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.
524 procedure Process_Interrupt_Or_Attach_Handler;
525 -- Attach the pragmas to the rep item chain.
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
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.
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.
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.
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.
560 --------------------------
561 -- Check_Ada_83_Warning --
562 --------------------------
564 procedure Check_Ada_83_Warning is
566 if Ada_83 and then Comes_From_Source (N) then
567 Error_Msg_N ("(Ada 83) pragma& is non-standard?", N);
569 end Check_Ada_83_Warning;
571 ---------------------
572 -- Check_Arg_Count --
573 ---------------------
575 procedure Check_Arg_Count (Required : Nat) is
577 if Arg_Count /= Required then
578 Error_Pragma ("wrong number of arguments for pragma%");
582 -----------------------------
583 -- Check_Arg_Is_Identifier --
584 -----------------------------
586 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
587 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
590 if Nkind (Argx) /= N_Identifier then
592 ("argument for pragma% must be identifier", Argx);
594 end Check_Arg_Is_Identifier;
596 ----------------------------------
597 -- Check_Arg_Is_Integer_Literal --
598 ----------------------------------
600 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
601 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
604 if Nkind (Argx) /= N_Integer_Literal then
606 ("argument for pragma% must be integer literal", Argx);
608 end Check_Arg_Is_Integer_Literal;
610 -------------------------------------------
611 -- Check_Arg_Is_Library_Level_Local_Name --
612 -------------------------------------------
616 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
617 -- | library_unit_NAME
619 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
621 Check_Arg_Is_Local_Name (Arg);
623 if not Is_Library_Level_Entity (Entity (Expression (Arg)))
624 and then Comes_From_Source (N)
627 ("argument for pragma% must be library level entity", Arg);
629 end Check_Arg_Is_Library_Level_Local_Name;
631 -----------------------------
632 -- Check_Arg_Is_Local_Name --
633 -----------------------------
637 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
638 -- | library_unit_NAME
640 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
641 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
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)))
653 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
656 if Is_Entity_Name (Argx)
657 and then Scope (Entity (Argx)) /= Current_Scope
660 ("pragma% argument must be in same declarative part", Arg);
662 end Check_Arg_Is_Local_Name;
664 ---------------------------------
665 -- Check_Arg_Is_Locking_Policy --
666 ---------------------------------
668 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
669 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
672 Check_Arg_Is_Identifier (Argx);
674 if not Is_Locking_Policy_Name (Chars (Argx)) then
676 ("& is not a valid locking policy name", Argx);
678 end Check_Arg_Is_Locking_Policy;
680 -------------------------
681 -- Check_Arg_Is_One_Of --
682 -------------------------
684 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
685 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
688 Check_Arg_Is_Identifier (Argx);
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);
695 end Check_Arg_Is_One_Of;
697 procedure Check_Arg_Is_One_Of
699 N1, N2, N3 : Name_Id)
701 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
704 Check_Arg_Is_Identifier (Argx);
706 if Chars (Argx) /= N1
707 and then Chars (Argx) /= N2
708 and then Chars (Argx) /= N3
710 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
712 end Check_Arg_Is_One_Of;
714 ---------------------------------
715 -- Check_Arg_Is_Queuing_Policy --
716 ---------------------------------
718 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
719 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
722 Check_Arg_Is_Identifier (Argx);
724 if not Is_Queuing_Policy_Name (Chars (Argx)) then
726 ("& is not a valid queuing policy name", Argx);
728 end Check_Arg_Is_Queuing_Policy;
730 ------------------------------------
731 -- Check_Arg_Is_Static_Expression --
732 ------------------------------------
734 procedure Check_Arg_Is_Static_Expression
738 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
741 Analyze_And_Resolve (Argx, Typ);
743 if Is_OK_Static_Expression (Argx) then
746 elsif Etype (Argx) = Any_Type then
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.
755 elsif Ada_83 and then Nkind (Argx) = N_String_Literal then
758 -- Static expression that raises Constraint_Error. This has
759 -- already been flagged, so just exit from pragma processing.
761 elsif Is_Static_Expression (Argx) then
764 -- Finally, we have a real error
767 Error_Msg_Name_1 := Chars (N);
769 ("argument for pragma% must be a static expression!", Argx);
772 end Check_Arg_Is_Static_Expression;
774 ---------------------------------
775 -- Check_Arg_Is_String_Literal --
776 ---------------------------------
778 procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is
779 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
782 if Nkind (Argx) /= N_String_Literal then
784 ("argument for pragma% must be string literal", Argx);
787 end Check_Arg_Is_String_Literal;
789 ------------------------------------------
790 -- Check_Arg_Is_Task_Dispatching_Policy --
791 ------------------------------------------
793 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
794 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
797 Check_Arg_Is_Identifier (Argx);
799 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
801 ("& is not a valid task dispatching policy name", Argx);
803 end Check_Arg_Is_Task_Dispatching_Policy;
805 --------------------------------
806 -- Check_At_Least_N_Arguments --
807 --------------------------------
809 procedure Check_At_Least_N_Arguments (N : Nat) is
811 if Arg_Count < N then
812 Error_Pragma ("too few arguments for pragma%");
814 end Check_At_Least_N_Arguments;
816 -------------------------------
817 -- Check_At_Most_N_Arguments --
818 -------------------------------
820 procedure Check_At_Most_N_Arguments (N : Nat) is
824 if Arg_Count > N then
829 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
832 end Check_At_Most_N_Arguments;
834 -------------------------
835 -- Check_First_Subtype --
836 -------------------------
838 procedure Check_First_Subtype (Arg : Node_Id) is
839 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
842 if not Is_First_Subtype (Entity (Argx)) then
844 ("pragma% cannot apply to subtype", Argx);
846 end Check_First_Subtype;
848 ---------------------------
849 -- Check_In_Main_Program --
850 ---------------------------
852 procedure Check_In_Main_Program is
853 P : constant Node_Id := Parent (N);
856 -- Must be at in subprogram body
858 if Nkind (P) /= N_Subprogram_Body then
859 Error_Pragma ("% pragma allowed only in subprogram");
861 -- Otherwise warn if obviously not main program
863 elsif Present (Parameter_Specifications (Specification (P)))
864 or else not Is_Compilation_Unit (Defining_Entity (P))
866 Error_Msg_Name_1 := Chars (N);
868 ("?pragma% is only effective in main program", N);
870 end Check_In_Main_Program;
872 ---------------------------------------
873 -- Check_Interrupt_Or_Attach_Handler --
874 ---------------------------------------
876 procedure Check_Interrupt_Or_Attach_Handler is
877 Arg1_X : constant Node_Id := Expression (Arg1);
882 if not Is_Entity_Name (Arg1_X) then
884 ("argument of pragma% must be entity name", Arg1);
886 elsif Prag_Id = Pragma_Interrupt_Handler then
887 Check_Restriction (No_Dynamic_Interrupts, N);
891 Handler_Proc : Entity_Id := Empty;
892 Proc_Scope : Entity_Id;
893 Found : Boolean := False;
896 if not Is_Overloaded (Arg1_X) then
897 Handler_Proc := Entity (Arg1_X);
902 Index : Interp_Index;
905 Get_First_Interp (Arg1_X, Index, It);
906 while Present (It.Nam) loop
907 Handler_Proc := It.Nam;
909 if Ekind (Handler_Proc) = E_Procedure
910 and then No (First_Formal (Handler_Proc))
914 Set_Entity (Arg1_X, Handler_Proc);
915 Set_Is_Overloaded (Arg1_X, False);
918 ("ambiguous handler name for pragma% ", Arg1);
922 Get_Next_Interp (Index, It);
927 ("argument of pragma% must be parameterless procedure",
930 Handler_Proc := Entity (Arg1_X);
935 Proc_Scope := Scope (Handler_Proc);
937 -- On AAMP only, a pragma Interrupt_Handler is supported for
938 -- nonprotected parameterless procedures.
941 and then Prag_Id = Pragma_Interrupt_Handler
943 if Ekind (Handler_Proc) /= E_Procedure then
945 ("argument of pragma% must be a procedure", Arg1);
948 elsif Ekind (Handler_Proc) /= E_Procedure
949 or else Ekind (Proc_Scope) /= E_Protected_Type
952 ("argument of pragma% must be protected procedure", Arg1);
955 if (not AAMP_On_Target or else Prag_Id = Pragma_Attach_Handler)
956 and then Ekind (Proc_Scope) = E_Protected_Type
959 Protected_Definition (Parent (Proc_Scope))
961 Error_Pragma ("pragma% must be in protected definition");
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))
970 ("pragma% requires library-level entity", Arg1);
973 if Present (First_Formal (Handler_Proc)) then
975 ("argument of pragma% must be parameterless procedure",
979 end Check_Interrupt_Or_Attach_Handler;
981 -------------------------------------------
982 -- Check_Is_In_Decl_Part_Or_Package_Spec --
983 -------------------------------------------
985 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
994 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
997 elsif Nkind (P) = N_Package_Specification then
1000 elsif Nkind (P) = N_Block_Statement then
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.
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
1020 Error_Pragma ("pragma% is not in declarative part or package spec");
1021 end Check_Is_In_Decl_Part_Or_Package_Spec;
1023 -------------------------
1024 -- Check_No_Identifier --
1025 -------------------------
1027 procedure Check_No_Identifier (Arg : Node_Id) is
1029 if Chars (Arg) /= No_Name then
1030 Error_Pragma_Arg_Ident
1031 ("pragma% does not permit identifier& here", Arg);
1033 end Check_No_Identifier;
1035 --------------------------
1036 -- Check_No_Identifiers --
1037 --------------------------
1039 procedure Check_No_Identifiers is
1043 if Arg_Count > 0 then
1046 while Present (Arg_Node) loop
1047 Check_No_Identifier (Arg_Node);
1051 end Check_No_Identifiers;
1053 -------------------------------
1054 -- Check_Optional_Identifier --
1055 -------------------------------
1057 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
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);
1067 end Check_Optional_Identifier;
1069 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
1071 Name_Buffer (1 .. Id'Length) := Id;
1072 Name_Len := Id'Length;
1073 Check_Optional_Identifier (Arg, Name_Find);
1074 end Check_Optional_Identifier;
1076 -----------------------------
1077 -- Check_Static_Constraint --
1078 -----------------------------
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 ???
1085 procedure Check_Static_Constraint (Constr : Node_Id) is
1087 --------------------
1088 -- Require_Static --
1089 --------------------
1091 procedure Require_Static (E : Node_Id);
1092 -- Require given expression to be static expression
1094 procedure Require_Static (E : Node_Id) is
1096 if not Is_OK_Static_Expression (E) then
1097 Flag_Non_Static_Expr
1098 ("non-static constraint not allowed in Unchecked_Union!", E);
1103 -- Start of processing for Check_Static_Constraint
1106 case Nkind (Constr) is
1107 when N_Discriminant_Association =>
1108 Require_Static (Expression (Constr));
1111 Require_Static (Low_Bound (Constr));
1112 Require_Static (High_Bound (Constr));
1114 when N_Attribute_Reference =>
1115 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
1116 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
1118 when N_Range_Constraint =>
1119 Check_Static_Constraint (Range_Expression (Constr));
1121 when N_Index_Or_Discriminant_Constraint =>
1123 IDC : Entity_Id := First (Constraints (Constr));
1125 while Present (IDC) loop
1126 Check_Static_Constraint (IDC);
1134 end Check_Static_Constraint;
1136 --------------------------------------
1137 -- Check_Valid_Configuration_Pragma --
1138 --------------------------------------
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).
1144 procedure Check_Valid_Configuration_Pragma is
1146 if not Is_Configuration_Pragma then
1147 Error_Pragma ("incorrect placement for configuration pragma%");
1149 end Check_Valid_Configuration_Pragma;
1151 -------------------------------------
1152 -- Check_Valid_Library_Unit_Pragma --
1153 -------------------------------------
1155 procedure Check_Valid_Library_Unit_Pragma is
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;
1164 if not Is_List_Member (N) then
1168 Plist := List_Containing (N);
1169 Parent_Node := Parent (Plist);
1171 if Parent_Node = Empty then
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.
1178 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
1179 if Plist /= Pragmas_After (Parent_Node) then
1182 elsif Arg_Count = 0 then
1184 ("argument required if outside compilation unit");
1187 Check_No_Identifiers;
1188 Check_Arg_Count (1);
1189 Unit_Node := Unit (Parent (Parent_Node));
1190 Unit_Kind := Nkind (Unit_Node);
1192 Analyze (Expression (Arg1));
1194 if Unit_Kind = N_Generic_Subprogram_Declaration
1195 or else Unit_Kind = N_Subprogram_Declaration
1197 Unit_Name := Defining_Entity (Unit_Node);
1199 elsif Unit_Kind = N_Function_Instantiation
1200 or else Unit_Kind = N_Package_Instantiation
1201 or else Unit_Kind = N_Procedure_Instantiation
1203 Unit_Name := Defining_Entity (Unit_Node);
1206 Unit_Name := Cunit_Entity (Current_Sem_Unit);
1209 if Chars (Unit_Name) /=
1210 Chars (Entity (Expression (Arg1)))
1213 ("pragma% argument is not current unit name", Arg1);
1216 if Ekind (Unit_Name) = E_Package
1217 and then Present (Renamed_Entity (Unit_Name))
1219 Error_Pragma ("pragma% not allowed for renamed package");
1223 -- Pragma appears other than after a compilation unit
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.
1231 Sindex := Source_Index (Current_Sem_Unit);
1233 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
1234 Rewrite (N, Make_Null_Statement (Loc));
1237 -- If before first declaration, the pragma applies to the
1238 -- enclosing unit, and the name if present must be this name.
1240 elsif Is_Before_First_Decl (N, Plist) then
1241 Unit_Node := Unit_Declaration_Node (Current_Scope);
1242 Unit_Kind := Nkind (Unit_Node);
1244 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
1247 elsif Unit_Kind = N_Subprogram_Body
1248 and then not Acts_As_Spec (Unit_Node)
1252 elsif Nkind (Parent_Node) = N_Package_Body then
1255 elsif Nkind (Parent_Node) = N_Package_Specification
1256 and then Plist = Private_Declarations (Parent_Node)
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)
1267 elsif Arg_Count > 0 then
1268 Analyze (Expression (Arg1));
1270 if Entity (Expression (Arg1)) /= Current_Scope then
1272 ("name in pragma% must be enclosing unit", Arg1);
1275 -- It is legal to have no argument in this context
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.
1289 ("pragma% misplaced, must be before first declaration");
1293 end Check_Valid_Library_Unit_Pragma;
1299 procedure Error_Pragma (Msg : String) is
1301 Error_Msg_Name_1 := Chars (N);
1302 Error_Msg_N (Msg, N);
1306 ----------------------
1307 -- Error_Pragma_Arg --
1308 ----------------------
1310 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
1312 Error_Msg_Name_1 := Chars (N);
1313 Error_Msg_N (Msg, Get_Pragma_Arg (Arg));
1315 end Error_Pragma_Arg;
1317 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
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;
1324 ----------------------------
1325 -- Error_Pragma_Arg_Ident --
1326 ----------------------------
1328 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
1330 Error_Msg_Name_1 := Chars (N);
1331 Error_Msg_N (Msg, Arg);
1333 end Error_Pragma_Arg_Ident;
1335 ------------------------
1336 -- Find_Lib_Unit_Name --
1337 ------------------------
1339 function Find_Lib_Unit_Name return Entity_Id is
1341 -- Return inner compilation unit entity, for case of nested
1342 -- categorization pragmas. This happens in generic unit.
1344 if Nkind (Parent (N)) = N_Package_Specification
1345 and then Defining_Entity (Parent (N)) /= Current_Scope
1347 return Defining_Entity (Parent (N));
1349 return Current_Scope;
1351 end Find_Lib_Unit_Name;
1353 ----------------------------
1354 -- Find_Program_Unit_Name --
1355 ----------------------------
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);
1363 if Nkind (P) = N_Compilation_Unit then
1364 Unit_Kind := Nkind (Unit (P));
1366 if Unit_Kind = N_Subprogram_Declaration
1367 or else Unit_Kind = N_Package_Declaration
1368 or else Unit_Kind in N_Generic_Declaration
1370 Unit_Name := Defining_Entity (Unit (P));
1372 if Chars (Id) = Chars (Unit_Name) then
1373 Set_Entity (Id, Unit_Name);
1374 Set_Etype (Id, Etype (Unit_Name));
1376 Set_Etype (Id, Any_Type);
1378 ("cannot find program unit referenced by pragma%");
1382 Set_Etype (Id, Any_Type);
1383 Error_Pragma ("pragma% inapplicable to this unit");
1390 end Find_Program_Unit_Name;
1392 -------------------------
1393 -- Gather_Associations --
1394 -------------------------
1396 procedure Gather_Associations
1398 Args : out Args_List)
1403 -- Initialize all parameters to Empty
1405 for J in Args'Range loop
1409 -- That's all we have to do if there are no argument associations
1411 if No (Pragma_Argument_Associations (N)) then
1415 -- Otherwise first deal with any positional parameters present
1417 Arg := First (Pragma_Argument_Associations (N));
1419 for Index in Args'Range loop
1420 exit when No (Arg) or else Chars (Arg) /= No_Name;
1421 Args (Index) := Expression (Arg);
1425 -- Positional parameters all processed, if any left, then we
1426 -- have too many positional parameters.
1428 if Present (Arg) and then Chars (Arg) = No_Name then
1430 ("too many positional associations for pragma%", Arg);
1433 -- Process named parameters if any are present
1435 while Present (Arg) loop
1436 if Chars (Arg) = No_Name then
1438 ("positional association cannot follow named association",
1442 for Index in Names'Range loop
1443 if Names (Index) = Chars (Arg) then
1444 if Present (Args (Index)) then
1446 ("duplicate argument association for pragma%", Arg);
1448 Args (Index) := Expression (Arg);
1453 if Index = Names'Last then
1454 Error_Msg_Name_1 := Chars (N);
1455 Error_Msg_N ("pragma% does not allow & argument", Arg);
1457 -- Check for possible misspelling
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)))
1464 Error_Msg_Name_1 := Names (Index1);
1465 Error_Msg_N ("\possible misspelling of%", Arg);
1477 end Gather_Associations;
1479 --------------------
1480 -- Get_Pragma_Arg --
1481 --------------------
1483 function Get_Pragma_Arg (Arg : Node_Id) return Node_Id is
1485 if Nkind (Arg) = N_Pragma_Argument_Association then
1486 return Expression (Arg);
1496 procedure GNAT_Pragma is
1498 Check_Restriction (No_Implementation_Pragmas, N);
1501 --------------------------
1502 -- Is_Before_First_Decl --
1503 --------------------------
1505 function Is_Before_First_Decl
1506 (Pragma_Node : Node_Id;
1507 Decls : List_Id) return Boolean
1509 Item : Node_Id := First (Decls);
1512 -- Only other pragmas can come before this pragma
1515 if No (Item) or else Nkind (Item) /= N_Pragma then
1518 elsif Item = Pragma_Node then
1524 end Is_Before_First_Decl;
1526 -----------------------------
1527 -- Is_Configuration_Pragma --
1528 -----------------------------
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).
1534 function Is_Configuration_Pragma return Boolean is
1535 Lis : constant List_Id := List_Containing (N);
1536 Par : constant Node_Id := Parent (N);
1540 -- If no parent, then we are in the configuration pragma file,
1541 -- so the placement is definitely appropriate.
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.
1550 elsif Nkind (Par) = N_Compilation_Unit
1551 and then Context_Items (Par) = Lis
1558 elsif Nkind (Prg) /= N_Pragma then
1568 end Is_Configuration_Pragma;
1570 ----------------------
1571 -- Pragma_Misplaced --
1572 ----------------------
1574 procedure Pragma_Misplaced is
1576 Error_Pragma ("incorrect placement of pragma%");
1577 end Pragma_Misplaced;
1579 ------------------------------------
1580 -- Process Atomic_Shared_Volatile --
1581 ------------------------------------
1583 procedure Process_Atomic_Shared_Volatile is
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);
1597 if Etype (E_Id) = Any_Type then
1602 D := Declaration_Node (E);
1606 if Rep_Item_Too_Early (E, N)
1608 Rep_Item_Too_Late (E, N)
1612 Check_First_Subtype (Arg1);
1615 if Prag_Id /= Pragma_Volatile then
1617 Set_Is_Atomic (Underlying_Type (E));
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.
1624 Set_Is_Volatile (Base_Type (E));
1625 Set_Is_Volatile (Underlying_Type (E));
1627 Set_Treat_As_Volatile (E);
1628 Set_Treat_As_Volatile (Underlying_Type (E));
1630 elsif K = N_Object_Declaration
1631 or else (K = N_Component_Declaration
1632 and then Original_Record_Component (E) = E)
1634 if Rep_Item_Too_Late (E, N) then
1638 if Prag_Id /= Pragma_Volatile then
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.
1646 if Nkind (Parent (E)) = N_Object_Declaration
1647 and then Present (Expression (Parent (E)))
1649 Set_Has_Delayed_Freeze (E);
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.
1659 Utyp := Underlying_Type (Etype (E));
1662 and then Sloc (E) > No_Location
1663 and then Sloc (Utyp) > No_Location
1665 Get_Source_File_Index (Sloc (E)) =
1666 Get_Source_File_Index (Sloc (Underlying_Type (Etype (E))))
1668 Set_Is_Atomic (Underlying_Type (Etype (E)));
1672 Set_Is_Volatile (E);
1673 Set_Treat_As_Volatile (E);
1677 ("inappropriate entity for pragma%", Arg1);
1679 end Process_Atomic_Shared_Volatile;
1681 ------------------------
1682 -- Process_Convention --
1683 ------------------------
1685 procedure Process_Convention
1686 (C : out Convention_Id;
1691 Comp_Unit : Unit_Number_Type;
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.
1700 --------------------------------
1701 -- Set_Convention_From_Pragma --
1702 --------------------------------
1704 procedure Set_Convention_From_Pragma (E : Entity_Id) is
1706 Set_Convention (E, C);
1707 Set_Has_Convention_Pragma (E);
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);
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).
1718 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
1719 Set_Convention (Class_Wide_Type (E), C);
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).
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))
1733 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
1736 ("C_Pass_By_Copy convention allowed only for record type",
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.
1745 if Is_Discrete_Type (E)
1746 and then Root_Type (Etype (E)) = Standard_Boolean
1752 C = Convention_Fortran)
1754 Set_Nonzero_Is_True (Base_Type (E));
1756 end Set_Convention_From_Pragma;
1758 -- Start of processing for Process_Convention
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));
1766 -- C_Pass_By_Copy is treated as a synonym for convention C
1767 -- (this is tested again below to set the critical flag)
1769 if Cname = Name_C_Pass_By_Copy then
1772 -- Otherwise we must have something in the standard convention list
1774 elsif Is_Convention_Name (Cname) then
1775 C := Get_Convention_Id (Chars (Expression (Arg1)));
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.
1784 if Warn_On_Export_Import and not OpenVMS_On_Target then
1786 ("?unrecognized convention name, C assumed",
1793 Check_Arg_Is_Local_Name (Arg2);
1794 Check_Optional_Identifier (Arg2, Name_Entity);
1796 Id := Expression (Arg2);
1799 if not Is_Entity_Name (Id) then
1800 Error_Pragma_Arg ("entity name required", Arg2);
1805 -- Go to renamed subprogram if present, since convention applies
1806 -- to the actual renamed entity, not to the renaming entity.
1808 if Is_Subprogram (E)
1809 and then Present (Alias (E))
1810 and then Nkind (Parent (Declaration_Node (E))) =
1811 N_Subprogram_Renaming_Declaration
1816 -- Check that we not applying this to a specless body
1818 if Is_Subprogram (E)
1819 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
1822 ("pragma% requires separate spec and must come before body");
1825 -- Check that we are not applying this to a named constant
1827 if Ekind (E) = E_Named_Integer
1829 Ekind (E) = E_Named_Real
1831 Error_Msg_Name_1 := Chars (N);
1833 ("cannot apply pragma% to named constant!",
1834 Get_Pragma_Arg (Arg2));
1836 ("\supply appropriate type for&!", Arg2);
1839 if Etype (E) = Any_Type
1840 or else Rep_Item_Too_Early (E, N)
1844 E := Underlying_Type (E);
1847 if Rep_Item_Too_Late (E, N) then
1851 if Has_Convention_Pragma (E) then
1853 ("at most one Convention/Export/Import pragma is allowed", Arg2);
1855 elsif Convention (E) = Convention_Protected
1856 or else Ekind (Scope (E)) = E_Protected_Type
1859 ("a protected operation cannot be given a different convention",
1863 -- For Intrinsic, a subprogram is required
1865 if C = Convention_Intrinsic
1866 and then not Is_Subprogram (E)
1867 and then not Is_Generic_Subprogram (E)
1870 ("second argument of pragma% must be a subprogram", Arg2);
1873 -- For Stdcall, a subprogram, variable or subprogram type is required
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
1881 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
1884 ("second argument of pragma% must be subprogram (type)",
1888 if not Is_Subprogram (E)
1889 and then not Is_Generic_Subprogram (E)
1891 Set_Convention_From_Pragma (E);
1895 Check_First_Subtype (Arg2);
1896 Set_Convention_From_Pragma (Base_Type (E));
1898 -- For subprograms, we must set the convention on the
1899 -- internally generated directly designated type as well.
1901 if Ekind (E) = E_Access_Subprogram_Type then
1902 Set_Convention_From_Pragma (Directly_Designated_Type (E));
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???
1912 Comp_Unit := Get_Source_Unit (E);
1913 Set_Convention_From_Pragma (E);
1915 -- Treat a pragma Import as an implicit body, for GPS use.
1917 if Prag_Id = Pragma_Import then
1918 Generate_Reference (E, Id, 'b');
1924 exit when No (E1) or else Scope (E1) /= Current_Scope;
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 ???
1930 if Comp_Unit = Get_Source_Unit (E1) then
1931 Set_Convention_From_Pragma (E1);
1933 if Prag_Id = Pragma_Import then
1934 Generate_Reference (E, Id, 'b');
1939 end Process_Convention;
1941 -----------------------------------------------------
1942 -- Process_Extended_Import_Export_Exception_Pragma --
1943 -----------------------------------------------------
1945 procedure Process_Extended_Import_Export_Exception_Pragma
1946 (Arg_Internal : Node_Id;
1947 Arg_External : Node_Id;
1957 if not OpenVMS_On_Target then
1959 ("?pragma% ignored (applies only to Open'V'M'S)");
1962 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
1963 Def_Id := Entity (Arg_Internal);
1965 if Ekind (Def_Id) /= E_Exception then
1967 ("pragma% must refer to declared exception", Arg_Internal);
1970 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
1972 if Present (Arg_Form) then
1973 Check_Arg_Is_One_Of (Arg_Form, Name_Ada, Name_VMS);
1976 if Present (Arg_Form)
1977 and then Chars (Arg_Form) = Name_Ada
1981 Set_Is_VMS_Exception (Def_Id);
1982 Set_Exception_Code (Def_Id, No_Uint);
1985 if Present (Arg_Code) then
1986 if not Is_VMS_Exception (Def_Id) then
1988 ("Code option for pragma% not allowed for Ada case",
1992 Check_Arg_Is_Static_Expression (Arg_Code, Any_Integer);
1993 Code_Val := Expr_Value (Arg_Code);
1995 if not UI_Is_In_Int_Range (Code_Val) then
1997 ("Code option for pragma% must be in 32-bit range",
2001 Set_Exception_Code (Def_Id, Code_Val);
2004 end Process_Extended_Import_Export_Exception_Pragma;
2006 -------------------------------------------------
2007 -- Process_Extended_Import_Export_Internal_Arg --
2008 -------------------------------------------------
2010 procedure Process_Extended_Import_Export_Internal_Arg
2011 (Arg_Internal : Node_Id := Empty)
2016 if No (Arg_Internal) then
2017 Error_Pragma ("Internal parameter required for pragma%");
2020 if Nkind (Arg_Internal) = N_Identifier then
2023 elsif Nkind (Arg_Internal) = N_Operator_Symbol
2024 and then (Prag_Id = Pragma_Import_Function
2026 Prag_Id = Pragma_Export_Function)
2032 ("wrong form for Internal parameter for pragma%", Arg_Internal);
2035 Check_Arg_Is_Local_Name (Arg_Internal);
2036 end Process_Extended_Import_Export_Internal_Arg;
2038 --------------------------------------------------
2039 -- Process_Extended_Import_Export_Object_Pragma --
2040 --------------------------------------------------
2042 procedure Process_Extended_Import_Export_Object_Pragma
2043 (Arg_Internal : Node_Id;
2044 Arg_External : Node_Id;
2050 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
2051 Def_Id := Entity (Arg_Internal);
2053 if Ekind (Def_Id) /= E_Constant
2054 and then Ekind (Def_Id) /= E_Variable
2057 ("pragma% must designate an object", Arg_Internal);
2060 if Is_Psected (Def_Id) then
2062 ("previous Psect_Object applies, pragma % not permitted",
2066 if Rep_Item_Too_Late (Def_Id, N) then
2070 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
2072 if Present (Arg_Size)
2073 and then Nkind (Arg_Size) /= N_Identifier
2074 and then Nkind (Arg_Size) /= N_String_Literal
2077 ("pragma% Size argument must be identifier or string literal",
2081 -- Export_Object case
2083 if Prag_Id = Pragma_Export_Object then
2084 if not Is_Library_Level_Entity (Def_Id) then
2086 ("argument for pragma% must be library level entity",
2090 if Ekind (Current_Scope) = E_Generic_Package then
2091 Error_Pragma ("pragma& cannot appear in a generic unit");
2094 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
2096 ("exported object must have compile time known size",
2100 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
2102 ("?duplicate Export_Object pragma", N);
2104 Set_Exported (Def_Id, Arg_Internal);
2107 -- Import_Object case
2110 if Is_Concurrent_Type (Etype (Def_Id)) then
2112 ("cannot use pragma% for task/protected object",
2116 if Ekind (Def_Id) = E_Constant then
2118 ("cannot import a constant", Arg_Internal);
2121 if Warn_On_Export_Import
2122 and then Has_Discriminants (Etype (Def_Id))
2125 ("imported value must be initialized?", Arg_Internal);
2128 if Warn_On_Export_Import
2129 and then Is_Access_Type (Etype (Def_Id))
2132 ("cannot import object of an access type?", Arg_Internal);
2135 if Warn_On_Export_Import
2136 and then Is_Imported (Def_Id)
2139 ("?duplicate Import_Object pragma", N);
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.
2145 elsif Present (Expression (Parent (Def_Id)))
2148 (Original_Node (Expression (Parent (Def_Id))))
2150 Error_Msg_Sloc := Sloc (Def_Id);
2152 ("no initialization allowed for declaration of& #",
2153 "\imported entities cannot be initialized ('R'M' 'B.1(24))",
2156 Set_Imported (Def_Id);
2157 Note_Possible_Modification (Arg_Internal);
2160 end Process_Extended_Import_Export_Object_Pragma;
2162 ------------------------------------------------------
2163 -- Process_Extended_Import_Export_Subprogram_Pragma --
2164 ------------------------------------------------------
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)
2179 Ambiguous : Boolean;
2183 function Same_Base_Type
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.
2191 --------------------
2192 -- Same_Base_Type --
2193 --------------------
2195 function Same_Base_Type
2197 Formal : Entity_Id) return Boolean
2199 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
2203 -- Case where pragma argument is typ'Access
2205 if Nkind (Ptype) = N_Attribute_Reference
2206 and then Attribute_Name (Ptype) = Name_Access
2208 Pref := Prefix (Ptype);
2211 if not Is_Entity_Name (Pref)
2212 or else Entity (Pref) = Any_Type
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
2221 return Ekind (Ftyp) = E_Anonymous_Access_Type
2222 and then Base_Type (Entity (Pref)) =
2223 Base_Type (Etype (Designated_Type (Ftyp)));
2225 -- Case where pragma argument is a type name
2230 if not Is_Entity_Name (Ptype)
2231 or else Entity (Ptype) = Any_Type
2236 -- We have a match if the corresponding argument is of
2237 -- the type given in the pragma (comparing base types)
2239 return Base_Type (Entity (Ptype)) = Ftyp;
2243 -- Start of processing for
2244 -- Process_Extended_Import_Export_Subprogram_Pragma
2247 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
2248 Hom_Id := Entity (Arg_Internal);
2252 -- Loop through homonyms (overloadings) of Hom_Id
2254 while Present (Hom_Id) loop
2255 Def_Id := Get_Base_Subprogram (Hom_Id);
2257 -- We need a subprogram in the current scope
2259 if not Is_Subprogram (Def_Id)
2260 or else Scope (Def_Id) /= Current_Scope
2267 -- Pragma cannot apply to subprogram body
2269 if Is_Subprogram (Def_Id)
2272 (Declaration_Node (Def_Id))) = N_Subprogram_Body
2275 ("pragma% requires separate spec"
2276 & " and must come before body");
2279 -- Test result type if given, note that the result type
2280 -- parameter can only be present for the function cases.
2282 if Present (Arg_Result_Type)
2283 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
2287 elsif Etype (Def_Id) /= Standard_Void_Type
2289 (Chars (N) = Name_Export_Procedure
2290 or else Chars (N) = Name_Import_Procedure)
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.
2298 elsif Present (Arg_Parameter_Types) then
2299 Check_Matching_Types : declare
2304 Formal := First_Formal (Def_Id);
2306 if Nkind (Arg_Parameter_Types) = N_Null then
2307 if Present (Formal) then
2311 -- A list of one type, e.g. (List) is parsed as
2312 -- a parenthesized expression.
2314 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
2315 and then Paren_Count (Arg_Parameter_Types) = 1
2318 or else Present (Next_Formal (Formal))
2323 Same_Base_Type (Arg_Parameter_Types, Formal);
2326 -- A list of more than one type is parsed as a aggregate
2328 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
2329 and then Paren_Count (Arg_Parameter_Types) = 0
2331 Ptype := First (Expressions (Arg_Parameter_Types));
2333 while Present (Ptype) or else Present (Formal) loop
2336 or else not Same_Base_Type (Ptype, Formal)
2341 Next_Formal (Formal);
2346 -- Anything else is of the wrong form
2350 ("wrong form for Parameter_Types parameter",
2351 Arg_Parameter_Types);
2353 end Check_Matching_Types;
2356 -- Match is now False if the entry we found did not match
2357 -- either a supplied Parameter_Types or Result_Types argument
2363 -- Ambiguous case, the flag Ambiguous shows if we already
2364 -- detected this and output the initial messages.
2367 if not Ambiguous then
2369 Error_Msg_Name_1 := Chars (N);
2371 ("pragma% does not uniquely identify subprogram!",
2373 Error_Msg_Sloc := Sloc (Ent);
2374 Error_Msg_N ("matching subprogram #!", N);
2378 Error_Msg_Sloc := Sloc (Def_Id);
2379 Error_Msg_N ("matching subprogram #!", N);
2384 Hom_Id := Homonym (Hom_Id);
2387 -- See if we found an entry
2390 if not Ambiguous then
2391 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
2393 ("pragma% cannot be given for generic subprogram");
2397 ("pragma% does not identify local subprogram");
2404 -- Import pragmas must be be for imported entities
2406 if Prag_Id = Pragma_Import_Function
2408 Prag_Id = Pragma_Import_Procedure
2410 Prag_Id = Pragma_Import_Valued_Procedure
2412 if not Is_Imported (Ent) then
2414 ("pragma Import or Interface must precede pragma%");
2417 -- Here we have the Export case which can set the entity as exported
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.
2423 elsif Nkind (Arg_External) = N_String_Literal
2424 and then String_Length (Strval (Arg_External)) = 0
2428 -- In all other cases, set entit as exported
2431 Set_Exported (Ent, Arg_Internal);
2434 -- Special processing for Valued_Procedure cases
2436 if Prag_Id = Pragma_Import_Valued_Procedure
2438 Prag_Id = Pragma_Export_Valued_Procedure
2440 Formal := First_Formal (Ent);
2444 ("at least one parameter required for pragma%");
2446 elsif Ekind (Formal) /= E_Out_Parameter then
2448 ("first parameter must have mode out for pragma%");
2451 Set_Is_Valued_Procedure (Ent);
2455 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
2457 -- Process Result_Mechanism argument if present. We have already
2458 -- checked that this is only allowed for the function case.
2460 if Present (Arg_Result_Mechanism) then
2461 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
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.
2468 if Present (Arg_Mechanism) then
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.
2481 if Nkind (Arg_Mechanism) /= N_Aggregate
2482 and then Paren_Count (Arg_Mechanism) = 1
2484 Rewrite (Arg_Mechanism,
2485 Make_Aggregate (Sloc (Arg_Mechanism),
2486 Expressions => New_List (
2487 Relocate_Node (Arg_Mechanism))));
2490 -- Case of only mechanism name given, applies to all formals
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);
2499 -- Case of list of mechanism associations given
2502 if Null_Record_Present (Arg_Mechanism) then
2504 ("inappropriate form for Mechanism parameter",
2508 -- Deal with positional ones first
2510 Formal := First_Formal (Ent);
2511 if Present (Expressions (Arg_Mechanism)) then
2512 Mname := First (Expressions (Arg_Mechanism));
2514 while Present (Mname) loop
2517 ("too many mechanism associations", Mname);
2520 Set_Mechanism_Value (Formal, Mname);
2521 Next_Formal (Formal);
2526 -- Deal with named entries
2528 if Present (Component_Associations (Arg_Mechanism)) then
2529 Massoc := First (Component_Associations (Arg_Mechanism));
2531 while Present (Massoc) loop
2532 Choice := First (Choices (Massoc));
2534 if Nkind (Choice) /= N_Identifier
2535 or else Present (Next (Choice))
2538 ("incorrect form for mechanism association",
2542 Formal := First_Formal (Ent);
2546 ("parameter name & not present", Choice);
2549 if Chars (Choice) = Chars (Formal) then
2551 (Formal, Expression (Massoc));
2555 Next_Formal (Formal);
2565 -- Process First_Optional_Parameter argument if present. We have
2566 -- already checked that this is only allowed for the Import case.
2568 if Present (Arg_First_Optional_Parameter) then
2569 if Nkind (Arg_First_Optional_Parameter) /= N_Identifier then
2571 ("first optional parameter must be formal parameter name",
2572 Arg_First_Optional_Parameter);
2575 Formal := First_Formal (Ent);
2579 ("specified formal parameter& not found",
2580 Arg_First_Optional_Parameter);
2583 exit when Chars (Formal) =
2584 Chars (Arg_First_Optional_Parameter);
2586 Next_Formal (Formal);
2589 Set_First_Optional_Parameter (Ent, Formal);
2591 -- Check specified and all remaining formals have right form
2593 while Present (Formal) loop
2594 if Ekind (Formal) /= E_In_Parameter then
2596 ("optional formal& is not of mode in!",
2597 Arg_First_Optional_Parameter, Formal);
2600 Dval := Default_Value (Formal);
2602 if not Present (Dval) then
2604 ("optional formal& does not have default value!",
2605 Arg_First_Optional_Parameter, Formal);
2607 elsif Compile_Time_Known_Value_Or_Aggr (Dval) then
2612 ("default value for optional formal& is non-static!",
2613 Arg_First_Optional_Parameter, Formal);
2617 Set_Is_Optional_Parameter (Formal);
2618 Next_Formal (Formal);
2621 end Process_Extended_Import_Export_Subprogram_Pragma;
2623 --------------------------
2624 -- Process_Generic_List --
2625 --------------------------
2627 procedure Process_Generic_List is
2633 Check_No_Identifiers;
2634 Check_At_Least_N_Arguments (1);
2637 while Present (Arg) loop
2638 Exp := Expression (Arg);
2641 if not Is_Entity_Name (Exp)
2643 (not Is_Generic_Instance (Entity (Exp))
2645 not Is_Generic_Unit (Entity (Exp)))
2648 ("pragma% argument must be name of generic unit/instance",
2654 end Process_Generic_List;
2656 ---------------------------------
2657 -- Process_Import_Or_Interface --
2658 ---------------------------------
2660 procedure Process_Import_Or_Interface is
2666 Process_Convention (C, Def_Id);
2667 Kill_Size_Check_Code (Def_Id);
2668 Note_Possible_Modification (Expression (Arg2));
2670 if Ekind (Def_Id) = E_Variable
2672 Ekind (Def_Id) = E_Constant
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.
2680 if Present (Expression (Parent (Def_Id)))
2681 and then Comes_From_Source (Expression (Parent (Def_Id)))
2683 Error_Msg_Sloc := Sloc (Def_Id);
2685 ("no initialization allowed for declaration of& #",
2686 "\imported entities cannot be initialized ('R'M' 'B.1(24))",
2690 Set_Imported (Def_Id);
2691 Set_Is_Public (Def_Id);
2692 Process_Interface_Name (Def_Id, Arg3, Arg4);
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.
2698 if Is_Array_Type (Etype (Def_Id))
2699 and then not Is_Constrained (Etype (Def_Id))
2702 ("imported constant& must have a constrained subtype",
2707 elsif Is_Subprogram (Def_Id)
2708 or else Is_Generic_Subprogram (Def_Id)
2710 -- If the name is overloaded, pragma applies to all of the
2711 -- denoted entities in the same declarative part.
2715 while Present (Hom_Id) loop
2716 Def_Id := Get_Base_Subprogram (Hom_Id);
2718 -- Ignore inherited subprograms because the pragma will
2719 -- apply to the parent operation, which is the one called.
2721 if Is_Overloadable (Def_Id)
2722 and then Present (Alias (Def_Id))
2726 -- If it is not a subprogram, it must be in an outer
2727 -- scope and pragma does not apply.
2729 elsif not Is_Subprogram (Def_Id)
2730 and then not Is_Generic_Subprogram (Def_Id)
2734 -- Verify that the homonym is in the same declarative
2735 -- part (not just the same scope).
2737 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
2738 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
2743 Set_Imported (Def_Id);
2745 -- If Import intrinsic, set intrinsic flag
2746 -- and verify that it is known as such.
2748 if C = Convention_Intrinsic then
2749 Set_Is_Intrinsic_Subprogram (Def_Id);
2750 Check_Intrinsic_Subprogram
2751 (Def_Id, Expression (Arg2));
2754 -- All interfaced procedures need an external
2755 -- symbol created for them since they are
2756 -- always referenced from another object file.
2758 Set_Is_Public (Def_Id);
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.
2765 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
2768 and then Nkind (Decl) = N_Subprogram_Declaration
2769 and then Present (Corresponding_Body (Decl))
2772 (Unit_Declaration_Node
2773 (Corresponding_Body (Decl))) =
2774 N_Subprogram_Renaming_Declaration
2776 Error_Msg_Sloc := Sloc (Def_Id);
2777 Error_Msg_NE ("cannot import&#," &
2778 " already completed by a renaming",
2783 Set_Has_Completion (Def_Id);
2784 Process_Interface_Name (Def_Id, Arg3, Arg4);
2787 if Is_Compilation_Unit (Hom_Id) then
2789 -- Its possible homonyms are not affected by the pragma.
2790 -- Such homonyms might be present in the context of other
2791 -- units being compiled.
2796 Hom_Id := Homonym (Hom_Id);
2800 -- When the convention is Java, we also allow Import to be given
2801 -- for packages, exceptions, and record components.
2803 elsif C = Convention_Java
2804 and then (Ekind (Def_Id) = E_Package
2805 or else Ekind (Def_Id) = E_Exception
2806 or else Nkind (Parent (Def_Id)) = N_Component_Declaration)
2808 Set_Imported (Def_Id);
2809 Set_Is_Public (Def_Id);
2810 Process_Interface_Name (Def_Id, Arg3, Arg4);
2814 ("second argument of pragma% must be object or subprogram",
2818 -- If this pragma applies to a compilation unit, then the unit,
2819 -- which is a subprogram, does not require (or allow) a body.
2820 -- We also do not need to elaborate imported procedures.
2822 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
2824 Cunit : constant Node_Id := Parent (Parent (N));
2826 Set_Body_Required (Cunit, False);
2829 end Process_Import_Or_Interface;
2831 --------------------
2832 -- Process_Inline --
2833 --------------------
2835 procedure Process_Inline (Active : Boolean) is
2842 procedure Make_Inline (Subp : Entity_Id);
2843 -- Subp is the defining unit name of the subprogram
2844 -- declaration. Set the flag, as well as the flag in the
2845 -- corresponding body, if there is one present.
2847 procedure Set_Inline_Flags (Subp : Entity_Id);
2848 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp
2850 function Back_End_Cannot_Inline (Subp : Entity_Id) return Boolean;
2851 -- Do not set the inline flag if body is available and contains
2852 -- exception handlers, to prevent undefined symbols at link time.
2854 ----------------------------
2855 -- Back_End_Cannot_Inline --
2856 ----------------------------
2858 function Back_End_Cannot_Inline (Subp : Entity_Id) return Boolean is
2859 Decl : Node_Id := Unit_Declaration_Node (Subp);
2862 if Nkind (Decl) = N_Subprogram_Body then
2865 (Exception_Handlers (Handled_Statement_Sequence (Decl)));
2867 elsif Nkind (Decl) = N_Subprogram_Declaration
2868 and then Present (Corresponding_Body (Decl))
2870 -- If the subprogram is a renaming as body, the body is
2871 -- just a call to the renamed subprogram, and inlining is
2872 -- trivially possible.
2874 if Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
2875 N_Subprogram_Renaming_Declaration
2881 Present (Exception_Handlers
2882 (Handled_Statement_Sequence
2883 (Unit_Declaration_Node (Corresponding_Body (Decl)))));
2886 -- If body is not available, assume the best, the check is
2887 -- performed again when compiling enclosing package bodies.
2891 end Back_End_Cannot_Inline;
2897 procedure Make_Inline (Subp : Entity_Id) is
2898 Kind : constant Entity_Kind := Ekind (Subp);
2899 Inner_Subp : Entity_Id := Subp;
2902 if Etype (Subp) = Any_Type then
2905 elsif Back_End_Cannot_Inline (Subp) then
2906 Applies := True; -- Do not treat as an error.
2909 -- Here we have a candidate for inlining, but we must exclude
2910 -- derived operations. Otherwise we will end up trying to
2911 -- inline a phantom declaration, and the result would be to
2912 -- drag in a body which has no direct inlining associated with
2913 -- it. That would not only be inefficient but would also result
2914 -- in the backend doing cross-unit inlining in cases where it
2915 -- was definitely inappropriate to do so.
2917 -- However, a simple Comes_From_Source test is insufficient,
2918 -- since we do want to allow inlining of generic instances,
2919 -- which also do not come from source. Predefined operators do
2920 -- not come from source but are not inlineable either.
2922 elsif not Comes_From_Source (Subp)
2923 and then not Is_Generic_Instance (Subp)
2924 and then Scope (Subp) /= Standard_Standard
2929 -- The referenced entity must either be the enclosing entity,
2930 -- or an entity declared within the current open scope.
2932 elsif Present (Scope (Subp))
2933 and then Scope (Subp) /= Current_Scope
2934 and then Subp /= Current_Scope
2937 ("argument of% must be entity in current scope", Assoc);
2941 -- Processing for procedure, operator or function.
2942 -- If subprogram is aliased (as for an instance) indicate
2943 -- that the renamed entity is inlined.
2945 if Is_Subprogram (Subp) then
2946 while Present (Alias (Inner_Subp)) loop
2947 Inner_Subp := Alias (Inner_Subp);
2950 Set_Inline_Flags (Inner_Subp);
2952 Decl := Parent (Parent (Inner_Subp));
2954 if Nkind (Decl) = N_Subprogram_Declaration
2955 and then Present (Corresponding_Body (Decl))
2957 Set_Inline_Flags (Corresponding_Body (Decl));
2962 -- For a generic subprogram set flag as well, for use at
2963 -- the point of instantiation, to determine whether the
2964 -- body should be generated.
2966 elsif Is_Generic_Subprogram (Subp) then
2967 Set_Inline_Flags (Subp);
2970 -- Literals are by definition inlined
2972 elsif Kind = E_Enumeration_Literal then
2975 -- Anything else is an error
2979 ("expect subprogram name for pragma%", Assoc);
2983 ----------------------
2984 -- Set_Inline_Flags --
2985 ----------------------
2987 procedure Set_Inline_Flags (Subp : Entity_Id) is
2990 Set_Is_Inlined (Subp, True);
2993 if not Has_Pragma_Inline (Subp) then
2994 Set_Has_Pragma_Inline (Subp);
2995 Set_Next_Rep_Item (N, First_Rep_Item (Subp));
2996 Set_First_Rep_Item (Subp, N);
2998 end Set_Inline_Flags;
3000 -- Start of processing for Process_Inline
3003 Check_No_Identifiers;
3004 Check_At_Least_N_Arguments (1);
3007 Inline_Processing_Required := True;
3011 while Present (Assoc) loop
3012 Subp_Id := Expression (Assoc);
3016 if Is_Entity_Name (Subp_Id) then
3017 Subp := Entity (Subp_Id);
3019 if Subp = Any_Id then
3025 while Present (Homonym (Subp))
3026 and then Scope (Homonym (Subp)) = Current_Scope
3028 Make_Inline (Homonym (Subp));
3029 Subp := Homonym (Subp);
3036 ("inappropriate argument for pragma%", Assoc);
3043 ----------------------------
3044 -- Process_Interface_Name --
3045 ----------------------------
3047 procedure Process_Interface_Name
3048 (Subprogram_Def : Entity_Id;
3054 String_Val : String_Id;
3056 procedure Check_Form_Of_Interface_Name (SN : Node_Id);
3057 -- SN is a string literal node for an interface name. This routine
3058 -- performs some minimal checks that the name is reasonable. In
3059 -- particular that no spaces or other obviously incorrect characters
3060 -- appear. This is only a warning, since any characters are allowed.
3062 procedure Check_Form_Of_Interface_Name (SN : Node_Id) is
3063 S : constant String_Id := Strval (Expr_Value_S (SN));
3064 SL : constant Nat := String_Length (S);
3069 Error_Msg_N ("interface name cannot be null string", SN);
3072 for J in 1 .. SL loop
3073 C := Get_String_Char (S, J);
3075 if Warn_On_Export_Import
3076 and then (not In_Character_Range (C)
3077 or else Get_Character (C) = ' '
3078 or else Get_Character (C) = ',')
3081 ("?interface name contains illegal character", SN);
3084 end Check_Form_Of_Interface_Name;
3086 -- Start of processing for Process_Interface_Name
3089 if No (Link_Arg) then
3090 if No (Ext_Arg) then
3093 elsif Chars (Ext_Arg) = Name_Link_Name then
3095 Link_Nam := Expression (Ext_Arg);
3098 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
3099 Ext_Nam := Expression (Ext_Arg);
3104 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
3105 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
3106 Ext_Nam := Expression (Ext_Arg);
3107 Link_Nam := Expression (Link_Arg);
3110 -- Check expressions for external name and link name are static
3112 if Present (Ext_Nam) then
3113 Check_Arg_Is_Static_Expression (Ext_Nam, Standard_String);
3114 Check_Form_Of_Interface_Name (Ext_Nam);
3116 -- Verify that the external name is not the name of a local
3117 -- entity, which would hide the imported one and lead to
3118 -- run-time surprises. The problem can only arise for entities
3119 -- declared in a package body (otherwise the external name is
3120 -- fully qualified and won't conflict).
3128 if Prag_Id = Pragma_Import then
3129 String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam)));
3131 E := Entity_Id (Get_Name_Table_Info (Nam));
3133 if Nam /= Chars (Subprogram_Def)
3134 and then Present (E)
3135 and then not Is_Overloadable (E)
3136 and then Is_Immediately_Visible (E)
3137 and then not Is_Imported (E)
3138 and then Ekind (Scope (E)) = E_Package
3142 while Present (Par) loop
3143 if Nkind (Par) = N_Package_Body then
3144 Error_Msg_Sloc := Sloc (E);
3146 ("imported entity is hidden by & declared#",
3151 Par := Parent (Par);
3158 if Present (Link_Nam) then
3159 Check_Arg_Is_Static_Expression (Link_Nam, Standard_String);
3160 Check_Form_Of_Interface_Name (Link_Nam);
3163 -- If there is no link name, just set the external name
3165 if No (Link_Nam) then
3166 Set_Encoded_Interface_Name
3167 (Get_Base_Subprogram (Subprogram_Def),
3168 Adjust_External_Name_Case (Expr_Value_S (Ext_Nam)));
3170 -- For the Link_Name case, the given literal is preceded by an
3171 -- asterisk, which indicates to GCC that the given name should
3172 -- be taken literally, and in particular that no prepending of
3173 -- underlines should occur, even in systems where this is the
3178 Store_String_Char (Get_Char_Code ('*'));
3179 String_Val := Strval (Expr_Value_S (Link_Nam));
3181 for J in 1 .. String_Length (String_Val) loop
3182 Store_String_Char (Get_String_Char (String_Val, J));
3186 Make_String_Literal (Sloc (Link_Nam), End_String);
3188 Set_Encoded_Interface_Name
3189 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
3191 end Process_Interface_Name;
3193 -----------------------------------------
3194 -- Process_Interrupt_Or_Attach_Handler --
3195 -----------------------------------------
3197 procedure Process_Interrupt_Or_Attach_Handler is
3198 Arg1_X : constant Node_Id := Expression (Arg1);
3199 Handler_Proc : constant Entity_Id := Entity (Arg1_X);
3200 Proc_Scope : constant Entity_Id := Scope (Handler_Proc);
3203 Set_Is_Interrupt_Handler (Handler_Proc);
3205 -- If the pragma is not associated with a handler procedure
3206 -- within a protected type, then it must be for a nonprotected
3207 -- procedure for the AAMP target, in which case we don't
3208 -- associate a representation item with the procedure's scope.
3210 if Ekind (Proc_Scope) = E_Protected_Type then
3211 if Prag_Id = Pragma_Interrupt_Handler
3212 or Prag_Id = Pragma_Attach_Handler
3214 Record_Rep_Item (Proc_Scope, N);
3217 end Process_Interrupt_Or_Attach_Handler;
3219 ---------------------------------
3220 -- Process_Suppress_Unsuppress --
3221 ---------------------------------
3223 -- Note: this procedure makes entries in the check suppress data
3224 -- structures managed by Sem. See spec of package Sem for full
3225 -- details on how we handle recording of check suppression.
3227 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
3232 In_Package_Spec : constant Boolean :=
3233 (Ekind (Current_Scope) = E_Package
3235 Ekind (Current_Scope) = E_Generic_Package)
3236 and then not In_Package_Body (Current_Scope);
3238 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
3239 -- Used to suppress a single check on the given entity
3241 --------------------------------
3242 -- Suppress_Unsuppress_Echeck --
3243 --------------------------------
3245 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
3246 ESR : constant Entity_Check_Suppress_Record :=
3249 Suppress => Suppress_Case);
3252 Set_Checks_May_Be_Suppressed (E);
3254 if In_Package_Spec then
3255 Global_Entity_Suppress.Append (ESR);
3257 Local_Entity_Suppress.Append (ESR);
3260 -- If this is a first subtype, and the base type is distinct,
3261 -- then also set the suppress flags on the base type.
3263 if Is_First_Subtype (E)
3264 and then Etype (E) /= E
3266 Suppress_Unsuppress_Echeck (Etype (E), C);
3268 end Suppress_Unsuppress_Echeck;
3270 -- Start of processing for Process_Suppress_Unsuppress
3273 -- Suppress/Unsuppress can appear as a configuration pragma,
3274 -- or in a declarative part or a package spec (RM 11.5(5))
3276 if not Is_Configuration_Pragma then
3277 Check_Is_In_Decl_Part_Or_Package_Spec;
3280 Check_At_Least_N_Arguments (1);
3281 Check_At_Most_N_Arguments (2);
3282 Check_No_Identifier (Arg1);
3283 Check_Arg_Is_Identifier (Arg1);
3285 if not Is_Check_Name (Chars (Expression (Arg1))) then
3287 ("argument of pragma% is not valid check name", Arg1);
3290 C := Get_Check_Id (Chars (Expression (Arg1)));
3293 if Arg_Count = 1 then
3295 -- Make an entry in the local scope suppress table. This is the
3296 -- table that directly shows the current value of the scope
3297 -- suppress check for any check id value.
3299 if C = All_Checks then
3300 Scope_Suppress := (others => Suppress_Case);
3302 Scope_Suppress (C) := Suppress_Case;
3305 -- Also make an entry in the Local_Entity_Suppress table. See
3306 -- extended description in the package spec of Sem for details.
3308 Local_Entity_Suppress.Append
3311 Suppress => Suppress_Case));
3313 -- Case of two arguments present, where the check is
3314 -- suppressed for a specified entity (given as the second
3315 -- argument of the pragma)
3318 Check_Optional_Identifier (Arg2, Name_On);
3319 E_Id := Expression (Arg2);
3322 if not Is_Entity_Name (E_Id) then
3324 ("second argument of pragma% must be entity name", Arg2);
3333 -- Enforce RM 11.5(7) which requires that for a pragma that
3334 -- appears within a package spec, the named entity must be
3335 -- within the package spec. We allow the package name itself
3336 -- to be mentioned since that makes sense, although it is not
3337 -- strictly allowed by 11.5(7).
3340 and then E /= Current_Scope
3341 and then Scope (E) /= Current_Scope
3344 ("entity in pragma% is not in package spec ('R'M 11.5(7))",
3348 -- Loop through homonyms. As noted below, in the case of a package
3349 -- spec, only homonyms within the package spec are considered.
3352 Suppress_Unsuppress_Echeck (E, C);
3354 if Is_Generic_Instance (E)
3355 and then Is_Subprogram (E)
3356 and then Present (Alias (E))
3358 Suppress_Unsuppress_Echeck (Alias (E), C);
3361 -- Move to next homonym
3366 -- If we are within a package specification, the
3367 -- pragma only applies to homonyms in the same scope.
3369 exit when In_Package_Spec
3370 and then Scope (E) /= Current_Scope;
3373 end Process_Suppress_Unsuppress;
3379 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
3381 if Is_Imported (E) then
3383 ("cannot export entity& that was previously imported", Arg);
3385 elsif Present (Address_Clause (E)) then
3387 ("cannot export entity& that has an address clause", Arg);
3390 Set_Is_Exported (E);
3392 -- Generate a reference for entity explicitly, because the
3393 -- identifier may be overloaded and name resolution will not
3396 Generate_Reference (E, Arg);
3398 -- Deal with exporting non-library level entity
3400 if not Is_Library_Level_Entity (E) then
3402 -- Not allowed at all for subprograms
3404 if Is_Subprogram (E) then
3405 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
3407 -- Otherwise set public and statically allocated
3411 Set_Is_Statically_Allocated (E);
3413 if Warn_On_Export_Import then
3415 ("?& has been made static as a result of Export", Arg, E);
3417 ("\this usage is non-standard and non-portable", Arg);
3422 if Warn_On_Export_Import and then Is_Type (E) then
3424 ("exporting a type has no effect?", Arg, E);
3427 if Warn_On_Export_Import and Inside_A_Generic then
3429 ("all instances of& will have the same external name?", Arg, E);
3433 ----------------------------------------------
3434 -- Set_Extended_Import_Export_External_Name --
3435 ----------------------------------------------
3437 procedure Set_Extended_Import_Export_External_Name
3438 (Internal_Ent : Entity_Id;
3439 Arg_External : Node_Id)
3441 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
3445 if No (Arg_External) then
3448 elsif Nkind (Arg_External) = N_String_Literal then
3449 if String_Length (Strval (Arg_External)) = 0 then
3452 New_Name := Adjust_External_Name_Case (Arg_External);
3455 elsif Nkind (Arg_External) = N_Identifier then
3456 New_Name := Get_Default_External_Name (Arg_External);
3460 ("incorrect form for External parameter for pragma%",
3464 -- If we already have an external name set (by a prior normal
3465 -- Import or Export pragma), then the external names must match
3467 if Present (Interface_Name (Internal_Ent)) then
3469 S1 : constant String_Id := Strval (Old_Name);
3470 S2 : constant String_Id := Strval (New_Name);
3473 -- Called if names do not match
3475 procedure Mismatch is
3477 Error_Msg_Sloc := Sloc (Old_Name);
3479 ("external name does not match that given #",
3484 if String_Length (S1) /= String_Length (S2) then
3488 for J in 1 .. String_Length (S1) loop
3489 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
3496 -- Otherwise set the given name
3499 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
3502 end Set_Extended_Import_Export_External_Name;
3508 procedure Set_Imported (E : Entity_Id) is
3510 Error_Msg_Sloc := Sloc (E);
3512 if Is_Exported (E) or else Is_Imported (E) then
3513 Error_Msg_NE ("import of& declared# not allowed", N, E);
3515 if Is_Exported (E) then
3516 Error_Msg_N ("\entity was previously exported", N);
3518 Error_Msg_N ("\entity was previously imported", N);
3521 Error_Pragma ("\(pragma% applies to all previous entities)");
3524 Set_Is_Imported (E);
3526 -- If the entity is an object that is not at the library
3527 -- level, then it is statically allocated. We do not worry
3528 -- about objects with address clauses in this context since
3529 -- they are not really imported in the linker sense.
3532 and then not Is_Library_Level_Entity (E)
3533 and then No (Address_Clause (E))
3535 Set_Is_Statically_Allocated (E);
3540 -------------------------
3541 -- Set_Mechanism_Value --
3542 -------------------------
3544 -- Note: the mechanism name has not been analyzed (and cannot indeed
3545 -- be analyzed, since it is semantic nonsense), so we get it in the
3546 -- exact form created by the parser.
3548 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
3552 procedure Bad_Class;
3553 -- Signal bad descriptor class name
3555 procedure Bad_Mechanism;
3556 -- Signal bad mechanism name
3558 procedure Bad_Class is
3560 Error_Pragma_Arg ("unrecognized descriptor class name", Class);
3563 procedure Bad_Mechanism is
3565 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
3568 -- Start of processing for Set_Mechanism_Value
3571 if Mechanism (Ent) /= Default_Mechanism then
3573 ("mechanism for & has already been set", Mech_Name, Ent);
3576 -- MECHANISM_NAME ::= value | reference | descriptor
3578 if Nkind (Mech_Name) = N_Identifier then
3579 if Chars (Mech_Name) = Name_Value then
3580 Set_Mechanism (Ent, By_Copy);
3583 elsif Chars (Mech_Name) = Name_Reference then
3584 Set_Mechanism (Ent, By_Reference);
3587 elsif Chars (Mech_Name) = Name_Descriptor then
3588 Check_VMS (Mech_Name);
3589 Set_Mechanism (Ent, By_Descriptor);
3592 elsif Chars (Mech_Name) = Name_Copy then
3594 ("bad mechanism name, Value assumed", Mech_Name);
3600 -- MECHANISM_NAME ::= descriptor (CLASS_NAME)
3601 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
3603 -- Note: this form is parsed as an indexed component
3605 elsif Nkind (Mech_Name) = N_Indexed_Component then
3606 Class := First (Expressions (Mech_Name));
3608 if Nkind (Prefix (Mech_Name)) /= N_Identifier
3609 or else Chars (Prefix (Mech_Name)) /= Name_Descriptor
3610 or else Present (Next (Class))
3615 -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME)
3616 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
3618 -- Note: this form is parsed as a function call
3620 elsif Nkind (Mech_Name) = N_Function_Call then
3622 Param := First (Parameter_Associations (Mech_Name));
3624 if Nkind (Name (Mech_Name)) /= N_Identifier
3625 or else Chars (Name (Mech_Name)) /= Name_Descriptor
3626 or else Present (Next (Param))
3627 or else No (Selector_Name (Param))
3628 or else Chars (Selector_Name (Param)) /= Name_Class
3632 Class := Explicit_Actual_Parameter (Param);
3639 -- Fall through here with Class set to descriptor class name
3641 Check_VMS (Mech_Name);
3643 if Nkind (Class) /= N_Identifier then
3646 elsif Chars (Class) = Name_UBS then
3647 Set_Mechanism (Ent, By_Descriptor_UBS);
3649 elsif Chars (Class) = Name_UBSB then
3650 Set_Mechanism (Ent, By_Descriptor_UBSB);
3652 elsif Chars (Class) = Name_UBA then
3653 Set_Mechanism (Ent, By_Descriptor_UBA);
3655 elsif Chars (Class) = Name_S then
3656 Set_Mechanism (Ent, By_Descriptor_S);
3658 elsif Chars (Class) = Name_SB then
3659 Set_Mechanism (Ent, By_Descriptor_SB);
3661 elsif Chars (Class) = Name_A then
3662 Set_Mechanism (Ent, By_Descriptor_A);
3664 elsif Chars (Class) = Name_NCA then
3665 Set_Mechanism (Ent, By_Descriptor_NCA);
3671 end Set_Mechanism_Value;
3673 -- Start of processing for Analyze_Pragma
3676 if not Is_Pragma_Name (Chars (N)) then
3677 if Warn_On_Unrecognized_Pragma then
3678 Error_Pragma ("unrecognized pragma%!?");
3683 Prag_Id := Get_Pragma_Id (Chars (N));
3693 if Present (Pragma_Argument_Associations (N)) then
3694 Arg1 := First (Pragma_Argument_Associations (N));
3696 if Present (Arg1) then
3697 Arg2 := Next (Arg1);
3699 if Present (Arg2) then
3700 Arg3 := Next (Arg2);
3702 if Present (Arg3) then
3703 Arg4 := Next (Arg3);
3709 -- Count number of arguments
3716 while Present (Arg_Node) loop
3717 Arg_Count := Arg_Count + 1;
3722 -- An enumeration type defines the pragmas that are supported by the
3723 -- implementation. Get_Pragma_Id (in package Prag) transorms a name
3724 -- into the corresponding enumeration value for the following case.
3732 -- pragma Abort_Defer;
3734 when Pragma_Abort_Defer =>
3736 Check_Arg_Count (0);
3738 -- The only required semantic processing is to check the
3739 -- placement. This pragma must appear at the start of the
3740 -- statement sequence of a handled sequence of statements.
3742 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
3743 or else N /= First (Statements (Parent (N)))
3754 -- Note: this pragma also has some specific processing in Par.Prag
3755 -- because we want to set the Ada 83 mode switch during parsing.
3757 when Pragma_Ada_83 =>
3761 Check_Arg_Count (0);
3769 -- Note: this pragma also has some specific processing in Par.Prag
3770 -- because we want to set the Ada 83 mode switch during parsing.
3772 when Pragma_Ada_95 =>
3776 Check_Arg_Count (0);
3778 ----------------------
3779 -- All_Calls_Remote --
3780 ----------------------
3782 -- pragma All_Calls_Remote [(library_package_NAME)];
3784 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
3785 Lib_Entity : Entity_Id;
3788 Check_Ada_83_Warning;
3789 Check_Valid_Library_Unit_Pragma;
3791 if Nkind (N) = N_Null_Statement then
3795 Lib_Entity := Find_Lib_Unit_Name;
3797 -- This pragma should only apply to a RCI unit (RM E.2.3(23)).
3799 if Present (Lib_Entity)
3800 and then not Debug_Flag_U
3802 if not Is_Remote_Call_Interface (Lib_Entity) then
3803 Error_Pragma ("pragma% only apply to rci unit");
3805 -- Set flag for entity of the library unit
3808 Set_Has_All_Calls_Remote (Lib_Entity);
3812 end All_Calls_Remote;
3818 -- pragma Annotate (IDENTIFIER {, ARG});
3819 -- ARG ::= NAME | EXPRESSION
3821 when Pragma_Annotate => Annotate : begin
3823 Check_At_Least_N_Arguments (1);
3824 Check_Arg_Is_Identifier (Arg1);
3827 Arg : Node_Id := Arg2;
3831 while Present (Arg) loop
3832 Exp := Expression (Arg);
3835 if Is_Entity_Name (Exp) then
3838 elsif Nkind (Exp) = N_String_Literal then
3839 Resolve (Exp, Standard_String);
3841 elsif Is_Overloaded (Exp) then
3842 Error_Pragma_Arg ("ambiguous argument for pragma%", Exp);
3857 -- pragma Assert (Boolean_EXPRESSION [, static_string_EXPRESSION]);
3859 when Pragma_Assert =>
3861 Check_No_Identifiers;
3863 if Arg_Count > 1 then
3864 Check_Arg_Count (2);
3865 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
3868 -- If expansion is active and assertions are inactive, then
3869 -- we rewrite the Assertion as:
3871 -- if False and then condition then
3875 -- The reason we do this rewriting during semantic analysis
3876 -- rather than as part of normal expansion is that we cannot
3877 -- analyze and expand the code for the boolean expression
3878 -- directly, or it may cause insertion of actions that would
3879 -- escape the attempt to suppress the assertion code.
3881 if Expander_Active and not Assertions_Enabled then
3883 Make_If_Statement (Loc,
3886 Left_Opnd => New_Occurrence_Of (Standard_False, Loc),
3887 Right_Opnd => Get_Pragma_Arg (Arg1)),
3888 Then_Statements => New_List (
3889 Make_Null_Statement (Loc))));
3893 -- Otherwise (if assertions are enabled, or if we are not
3894 -- operating with expansion active), then we just analyze
3895 -- and resolve the expression.
3898 Analyze_And_Resolve (Expression (Arg1), Any_Boolean);
3905 -- pragma AST_Entry (entry_IDENTIFIER);
3907 when Pragma_AST_Entry => AST_Entry : declare
3913 Check_Arg_Count (1);
3914 Check_No_Identifiers;
3915 Check_Arg_Is_Local_Name (Arg1);
3916 Ent := Entity (Expression (Arg1));
3918 -- Note: the implementation of the AST_Entry pragma could handle
3919 -- the entry family case fine, but for now we are consistent with
3920 -- the DEC rules, and do not allow the pragma, which of course
3921 -- has the effect of also forbidding the attribute.
3923 if Ekind (Ent) /= E_Entry then
3925 ("pragma% argument must be simple entry name", Arg1);
3927 elsif Is_AST_Entry (Ent) then
3929 ("duplicate % pragma for entry", Arg1);
3931 elsif Has_Homonym (Ent) then
3933 ("pragma% argument cannot specify overloaded entry", Arg1);
3937 FF : constant Entity_Id := First_Formal (Ent);
3940 if Present (FF) then
3941 if Present (Next_Formal (FF)) then
3943 ("entry for pragma% can have only one argument",
3946 elsif Parameter_Mode (FF) /= E_In_Parameter then
3948 ("entry parameter for pragma% must have mode IN",
3954 Set_Is_AST_Entry (Ent);
3962 -- pragma Asynchronous (LOCAL_NAME);
3964 when Pragma_Asynchronous => Asynchronous : declare
3972 procedure Process_Async_Pragma;
3973 -- Common processing for procedure and access-to-procedure case
3975 --------------------------
3976 -- Process_Async_Pragma --
3977 --------------------------
3979 procedure Process_Async_Pragma is
3981 if not Present (L) then
3982 Set_Is_Asynchronous (Nm);
3986 -- The formals should be of mode IN (RM E.4.1(6))
3989 while Present (S) loop
3990 Formal := Defining_Identifier (S);
3992 if Nkind (Formal) = N_Defining_Identifier
3993 and then Ekind (Formal) /= E_In_Parameter
3996 ("pragma% procedure can only have IN parameter",
4003 Set_Is_Asynchronous (Nm);
4004 end Process_Async_Pragma;
4006 -- Start of processing for pragma Asynchronous
4009 Check_Ada_83_Warning;
4010 Check_No_Identifiers;
4011 Check_Arg_Count (1);
4012 Check_Arg_Is_Local_Name (Arg1);
4014 if Debug_Flag_U then
4018 C_Ent := Cunit_Entity (Current_Sem_Unit);
4019 Analyze (Expression (Arg1));
4020 Nm := Entity (Expression (Arg1));
4022 if not Is_Remote_Call_Interface (C_Ent)
4023 and then not Is_Remote_Types (C_Ent)
4025 -- This pragma should only appear in an RCI or Remote Types
4026 -- unit (RM E.4.1(4))
4029 ("pragma% not in Remote_Call_Interface or " &
4030 "Remote_Types unit");
4033 if Ekind (Nm) = E_Procedure
4034 and then Nkind (Parent (Nm)) = N_Procedure_Specification
4036 if not Is_Remote_Call_Interface (Nm) then
4038 ("pragma% cannot be applied on non-remote procedure",
4042 L := Parameter_Specifications (Parent (Nm));
4043 Process_Async_Pragma;
4046 elsif Ekind (Nm) = E_Function then
4048 ("pragma% cannot be applied to function", Arg1);
4050 elsif Ekind (Nm) = E_Record_Type
4051 and then Present (Corresponding_Remote_Type (Nm))
4053 N := Declaration_Node (Corresponding_Remote_Type (Nm));
4055 if Nkind (N) = N_Full_Type_Declaration
4056 and then Nkind (Type_Definition (N)) =
4057 N_Access_Procedure_Definition
4059 L := Parameter_Specifications (Type_Definition (N));
4060 Process_Async_Pragma;
4064 ("pragma% cannot reference access-to-function type",
4068 -- Only other possibility is Access-to-class-wide type
4070 elsif Is_Access_Type (Nm)
4071 and then Is_Class_Wide_Type (Designated_Type (Nm))
4073 Check_First_Subtype (Arg1);
4074 Set_Is_Asynchronous (Nm);
4075 if Expander_Active then
4076 RACW_Type_Is_Asynchronous (Nm);
4080 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
4088 -- pragma Atomic (LOCAL_NAME);
4090 when Pragma_Atomic =>
4091 Process_Atomic_Shared_Volatile;
4093 -----------------------
4094 -- Atomic_Components --
4095 -----------------------
4097 -- pragma Atomic_Components (array_LOCAL_NAME);
4099 -- This processing is shared by Volatile_Components
4101 when Pragma_Atomic_Components |
4102 Pragma_Volatile_Components =>
4104 Atomic_Components : declare
4111 Check_Ada_83_Warning;
4112 Check_No_Identifiers;
4113 Check_Arg_Count (1);
4114 Check_Arg_Is_Local_Name (Arg1);
4115 E_Id := Expression (Arg1);
4117 if Etype (E_Id) = Any_Type then
4123 if Rep_Item_Too_Early (E, N)
4125 Rep_Item_Too_Late (E, N)
4130 D := Declaration_Node (E);
4133 if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
4135 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
4136 and then Nkind (D) = N_Object_Declaration
4137 and then Nkind (Object_Definition (D)) =
4138 N_Constrained_Array_Definition)
4140 -- The flag is set on the object, or on the base type
4142 if Nkind (D) /= N_Object_Declaration then
4146 Set_Has_Volatile_Components (E);
4148 if Prag_Id = Pragma_Atomic_Components then
4149 Set_Has_Atomic_Components (E);
4151 if Is_Packed (E) then
4152 Set_Is_Packed (E, False);
4155 ("?Pack canceled, cannot pack atomic components",
4161 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
4163 end Atomic_Components;
4165 --------------------
4166 -- Attach_Handler --
4167 --------------------
4169 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
4171 when Pragma_Attach_Handler =>
4172 Check_Ada_83_Warning;
4173 Check_No_Identifiers;
4174 Check_Arg_Count (2);
4176 if No_Run_Time_Mode then
4177 Error_Msg_CRT ("Attach_Handler pragma", N);
4179 Check_Interrupt_Or_Attach_Handler;
4181 -- The expression that designates the attribute may
4182 -- depend on a discriminant, and is therefore a per-
4183 -- object expression, to be expanded in the init proc.
4184 -- If expansion is enabled, perform semantic checks
4187 if Expander_Active then
4189 Temp : Node_Id := New_Copy_Tree (Expression (Arg2));
4191 Set_Parent (Temp, N);
4192 Pre_Analyze_And_Resolve (Temp, RTE (RE_Interrupt_ID));
4196 Analyze (Expression (Arg2));
4197 Resolve (Expression (Arg2), RTE (RE_Interrupt_ID));
4200 Process_Interrupt_Or_Attach_Handler;
4203 --------------------
4204 -- C_Pass_By_Copy --
4205 --------------------
4207 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
4209 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
4215 Check_Valid_Configuration_Pragma;
4216 Check_Arg_Count (1);
4217 Check_Optional_Identifier (Arg1, "max_size");
4219 Arg := Expression (Arg1);
4220 Check_Arg_Is_Static_Expression (Arg, Any_Integer);
4222 Val := Expr_Value (Arg);
4226 ("maximum size for pragma% must be positive", Arg1);
4228 elsif UI_Is_In_Int_Range (Val) then
4229 Default_C_Record_Mechanism := UI_To_Int (Val);
4231 -- If a giant value is given, Int'Last will do well enough.
4232 -- If sometime someone complains that a record larger than
4233 -- two gigabytes is not copied, we will worry about it then!
4236 Default_C_Record_Mechanism := Mechanism_Type'Last;
4244 -- pragma Comment (static_string_EXPRESSION)
4246 -- Processing for pragma Comment shares the circuitry for
4247 -- pragma Ident. The only differences are that Ident enforces
4248 -- a limit of 31 characters on its argument, and also enforces
4249 -- limitations on placement for DEC compatibility. Pragma
4250 -- Comment shares neither of these restrictions.
4256 -- pragma Common_Object (
4257 -- [Internal =>] LOCAL_NAME,
4258 -- [, [External =>] EXTERNAL_SYMBOL]
4259 -- [, [Size =>] EXTERNAL_SYMBOL]);
4261 -- Processing for this pragma is shared with Psect_Object
4263 --------------------------
4264 -- Compile_Time_Warning --
4265 --------------------------
4267 -- pragma Compile_Time_Warning
4268 -- (boolean_EXPRESSION, static_string_EXPRESSION);
4270 when Pragma_Compile_Time_Warning => Compile_Time_Warning : declare
4271 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
4275 Check_Arg_Count (2);
4276 Check_No_Identifiers;
4277 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
4278 Analyze_And_Resolve (Arg1x, Standard_Boolean);
4280 if Compile_Time_Known_Value (Arg1x) then
4281 if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
4282 String_To_Name_Buffer (Strval (Get_Pragma_Arg (Arg2)));
4283 Add_Char_To_Name_Buffer ('?');
4286 Msg : String (1 .. Name_Len) :=
4287 Name_Buffer (1 .. Name_Len);
4292 -- This loop looks for multiple lines separated by
4293 -- ASCII.LF and breaks them into continuation error
4294 -- messages marked with the usual back slash.
4297 for S in 2 .. Msg'Length - 1 loop
4298 if Msg (S) = ASCII.LF then
4300 Error_Msg_N (Msg (B .. S), Arg1);
4306 Error_Msg_N (Msg (B .. Msg'Length), Arg1);
4310 end Compile_Time_Warning;
4312 ----------------------------
4313 -- Complex_Representation --
4314 ----------------------------
4316 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
4318 when Pragma_Complex_Representation => Complex_Representation : declare
4325 Check_Arg_Count (1);
4326 Check_Optional_Identifier (Arg1, Name_Entity);
4327 Check_Arg_Is_Local_Name (Arg1);
4328 E_Id := Expression (Arg1);
4330 if Etype (E_Id) = Any_Type then
4336 if not Is_Record_Type (E) then
4338 ("argument for pragma% must be record type", Arg1);
4341 Ent := First_Entity (E);
4344 or else No (Next_Entity (Ent))
4345 or else Present (Next_Entity (Next_Entity (Ent)))
4346 or else not Is_Floating_Point_Type (Etype (Ent))
4347 or else Etype (Ent) /= Etype (Next_Entity (Ent))
4350 ("record for pragma% must have two fields of same fpt type",
4354 Set_Has_Complex_Representation (Base_Type (E));
4356 end Complex_Representation;
4358 -------------------------
4359 -- Component_Alignment --
4360 -------------------------
4362 -- pragma Component_Alignment (
4363 -- [Form =>] ALIGNMENT_CHOICE
4364 -- [, [Name =>] type_LOCAL_NAME]);
4366 -- ALIGNMENT_CHOICE ::=
4368 -- | Component_Size_4
4372 when Pragma_Component_Alignment => Component_AlignmentP : declare
4373 Args : Args_List (1 .. 2);
4374 Names : constant Name_List (1 .. 2) := (
4378 Form : Node_Id renames Args (1);
4379 Name : Node_Id renames Args (2);
4381 Atype : Component_Alignment_Kind;
4386 Gather_Associations (Names, Args);
4389 Error_Pragma ("missing Form argument for pragma%");
4392 Check_Arg_Is_Identifier (Form);
4394 -- Get proper alignment, note that Default = Component_Size
4395 -- on all machines we have so far, and we want to set this
4396 -- value rather than the default value to indicate that it
4397 -- has been explicitly set (and thus will not get overridden
4398 -- by the default component alignment for the current scope)
4400 if Chars (Form) = Name_Component_Size then
4401 Atype := Calign_Component_Size;
4403 elsif Chars (Form) = Name_Component_Size_4 then
4404 Atype := Calign_Component_Size_4;
4406 elsif Chars (Form) = Name_Default then
4407 Atype := Calign_Component_Size;
4409 elsif Chars (Form) = Name_Storage_Unit then
4410 Atype := Calign_Storage_Unit;
4414 ("invalid Form parameter for pragma%", Form);
4417 -- Case with no name, supplied, affects scope table entry
4421 (Scope_Stack.Last).Component_Alignment_Default := Atype;
4423 -- Case of name supplied
4426 Check_Arg_Is_Local_Name (Name);
4428 Typ := Entity (Name);
4431 or else Rep_Item_Too_Early (Typ, N)
4435 Typ := Underlying_Type (Typ);
4438 if not Is_Record_Type (Typ)
4439 and then not Is_Array_Type (Typ)
4442 ("Name parameter of pragma% must identify record or " &
4443 "array type", Name);
4446 -- An explicit Component_Alignment pragma overrides an
4447 -- implicit pragma Pack, but not an explicit one.
4449 if not Has_Pragma_Pack (Base_Type (Typ)) then
4450 Set_Is_Packed (Base_Type (Typ), False);
4451 Set_Component_Alignment (Base_Type (Typ), Atype);
4454 end Component_AlignmentP;
4460 -- pragma Controlled (first_subtype_LOCAL_NAME);
4462 when Pragma_Controlled => Controlled : declare
4466 Check_No_Identifiers;
4467 Check_Arg_Count (1);
4468 Check_Arg_Is_Local_Name (Arg1);
4469 Arg := Expression (Arg1);
4471 if not Is_Entity_Name (Arg)
4472 or else not Is_Access_Type (Entity (Arg))
4474 Error_Pragma_Arg ("pragma% requires access type", Arg1);
4476 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
4484 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
4485 -- [Entity =>] LOCAL_NAME);
4487 when Pragma_Convention => Convention : declare
4491 Check_Ada_83_Warning;
4492 Check_Arg_Count (2);
4493 Process_Convention (C, E);
4496 ---------------------------
4497 -- Convention_Identifier --
4498 ---------------------------
4500 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
4501 -- [Convention =>] convention_IDENTIFIER);
4503 when Pragma_Convention_Identifier => Convention_Identifier : declare
4509 Check_Arg_Count (2);
4510 Check_Optional_Identifier (Arg1, Name_Name);
4511 Check_Optional_Identifier (Arg2, Name_Convention);
4512 Check_Arg_Is_Identifier (Arg1);
4513 Check_Arg_Is_Identifier (Arg1);
4514 Idnam := Chars (Expression (Arg1));
4515 Cname := Chars (Expression (Arg2));
4517 if Is_Convention_Name (Cname) then
4518 Record_Convention_Identifier
4519 (Idnam, Get_Convention_Id (Cname));
4522 ("second arg for % pragma must be convention", Arg2);
4524 end Convention_Identifier;
4530 -- pragma CPP_Class ([Entity =>] local_NAME)
4532 when Pragma_CPP_Class => CPP_Class : declare
4535 Default_DTC : Entity_Id := Empty;
4536 VTP_Type : constant Entity_Id := RTE (RE_Vtable_Ptr);
4542 Check_Arg_Count (1);
4543 Check_Optional_Identifier (Arg1, Name_Entity);
4544 Check_Arg_Is_Local_Name (Arg1);
4546 Arg := Expression (Arg1);
4549 if Etype (Arg) = Any_Type then
4553 if not Is_Entity_Name (Arg)
4554 or else not Is_Type (Entity (Arg))
4556 Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
4559 Typ := Entity (Arg);
4561 if not Is_Record_Type (Typ) then
4562 Error_Pragma_Arg ("pragma% applicable to a record, "
4563 & "tagged record or record extension", Arg1);
4566 Default_DTC := First_Component (Typ);
4567 while Present (Default_DTC)
4568 and then Etype (Default_DTC) /= VTP_Type
4570 Next_Component (Default_DTC);
4573 -- Case of non tagged type
4575 if not Is_Tagged_Type (Typ) then
4576 Set_Is_CPP_Class (Typ);
4578 if Present (Default_DTC) then
4580 ("only tagged records can contain vtable pointers", Arg1);
4583 -- Case of tagged type with no vtable ptr
4585 -- What is test for Typ = Root_Typ (Typ) about here ???
4587 elsif Is_Tagged_Type (Typ)
4588 and then Typ = Root_Type (Typ)
4589 and then No (Default_DTC)
4592 ("a cpp_class must contain a vtable pointer", Arg1);
4594 -- Tagged type that has a vtable ptr
4596 elsif Present (Default_DTC) then
4597 Set_Is_CPP_Class (Typ);
4598 Set_Is_Limited_Record (Typ);
4599 Set_Is_Tag (Default_DTC);
4600 Set_DT_Entry_Count (Default_DTC, No_Uint);
4602 -- Since a CPP type has no direct link to its associated tag
4603 -- most tags checks cannot be performed
4605 Set_Kill_Tag_Checks (Typ);
4606 Set_Kill_Tag_Checks (Class_Wide_Type (Typ));
4608 -- Get rid of the _tag component when there was one.
4609 -- It is only useful for regular tagged types
4611 if Expander_Active and then Typ = Root_Type (Typ) then
4613 Tag_C := Tag_Component (Typ);
4614 C := First_Entity (Typ);
4617 Set_First_Entity (Typ, Next_Entity (Tag_C));
4620 while Next_Entity (C) /= Tag_C loop
4624 Set_Next_Entity (C, Next_Entity (Tag_C));
4630 ---------------------
4631 -- CPP_Constructor --
4632 ---------------------
4634 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME);
4636 when Pragma_CPP_Constructor => CPP_Constructor : declare
4642 Check_Arg_Count (1);
4643 Check_Optional_Identifier (Arg1, Name_Entity);
4644 Check_Arg_Is_Local_Name (Arg1);
4646 Id := Expression (Arg1);
4647 Find_Program_Unit_Name (Id);
4649 -- If we did not find the name, we are done
4651 if Etype (Id) = Any_Type then
4655 Def_Id := Entity (Id);
4657 if Ekind (Def_Id) = E_Function
4658 and then Is_Class_Wide_Type (Etype (Def_Id))
4659 and then Is_CPP_Class (Etype (Etype (Def_Id)))
4661 -- What the heck is this??? this pragma allows only 1 arg
4663 if Arg_Count >= 2 then
4664 Check_At_Most_N_Arguments (3);
4665 Process_Interface_Name (Def_Id, Arg2, Arg3);
4668 if No (Parameter_Specifications (Parent (Def_Id))) then
4669 Set_Has_Completion (Def_Id);
4670 Set_Is_Constructor (Def_Id);
4673 ("non-default constructors not implemented", Arg1);
4678 ("pragma% requires function returning a 'C'P'P_Class type",
4681 end CPP_Constructor;
4687 -- pragma CPP_Virtual
4688 -- [Entity =>] LOCAL_NAME
4689 -- [ [Vtable_Ptr =>] LOCAL_NAME,
4690 -- [Position =>] static_integer_EXPRESSION]);
4692 when Pragma_CPP_Virtual => CPP_Virtual : declare
4696 VTP_Type : constant Entity_Id := RTE (RE_Vtable_Ptr);
4703 if Arg_Count = 3 then
4704 Check_Optional_Identifier (Arg2, "vtable_ptr");
4706 -- We allow Entry_Count as well as Position for the third
4707 -- parameter for back compatibility with versions of GNAT
4708 -- before version 3.12. The documentation has always said
4709 -- Position, but the code up to 3.12 said Entry_Count.
4711 if Chars (Arg3) /= Name_Position then
4712 Check_Optional_Identifier (Arg3, "entry_count");
4716 Check_Arg_Count (1);
4719 Check_Optional_Identifier (Arg1, Name_Entity);
4720 Check_Arg_Is_Local_Name (Arg1);
4722 -- First argument must be a subprogram name
4724 Arg := Expression (Arg1);
4725 Find_Program_Unit_Name (Arg);
4727 if Etype (Arg) = Any_Type then
4730 Subp := Entity (Arg);
4733 if not (Is_Subprogram (Subp)
4734 and then Is_Dispatching_Operation (Subp))
4737 ("pragma% must reference a primitive operation", Arg1);
4740 Typ := Find_Dispatching_Type (Subp);
4742 -- If only one Argument defaults are :
4743 -- . DTC_Entity is the default Vtable pointer
4744 -- . DT_Position will be set at the freezing point
4746 if Arg_Count = 1 then
4747 Set_DTC_Entity (Subp, Tag_Component (Typ));
4751 -- Second argument is a component name of type Vtable_Ptr
4753 Arg := Expression (Arg2);
4755 if Nkind (Arg) /= N_Identifier then
4756 Error_Msg_NE ("must be a& component name", Arg, Typ);
4760 DTC := First_Component (Typ);
4761 while Present (DTC) and then Chars (DTC) /= Chars (Arg) loop
4762 Next_Component (DTC);
4766 Error_Msg_NE ("must be a& component name", Arg, Typ);
4769 elsif Etype (DTC) /= VTP_Type then
4770 Wrong_Type (Arg, VTP_Type);
4774 -- Third argument is an integer (DT_Position)
4776 Arg := Expression (Arg3);
4777 Analyze_And_Resolve (Arg, Any_Integer);
4779 if not Is_Static_Expression (Arg) then
4780 Flag_Non_Static_Expr
4781 ("third argument of pragma CPP_Virtual must be static!",
4786 V := Expr_Value (Expression (Arg3));
4790 ("third argument of pragma% must be positive",
4794 Set_DTC_Entity (Subp, DTC);
4795 Set_DT_Position (Subp, V);
4804 -- pragma CPP_Vtable (
4805 -- [Entity =>] LOCAL_NAME
4806 -- [Vtable_Ptr =>] LOCAL_NAME,
4807 -- [Entry_Count =>] static_integer_EXPRESSION);
4809 when Pragma_CPP_Vtable => CPP_Vtable : declare
4812 VTP_Type : constant Entity_Id := RTE (RE_Vtable_Ptr);
4819 Check_Arg_Count (3);
4820 Check_Optional_Identifier (Arg1, Name_Entity);
4821 Check_Optional_Identifier (Arg2, "vtable_ptr");
4822 Check_Optional_Identifier (Arg3, "entry_count");
4823 Check_Arg_Is_Local_Name (Arg1);
4825 -- First argument is a record type name
4827 Arg := Expression (Arg1);
4830 if Etype (Arg) = Any_Type then
4833 Typ := Entity (Arg);
4836 if not (Is_Tagged_Type (Typ) and then Is_CPP_Class (Typ)) then
4837 Error_Pragma_Arg ("'C'P'P_Class tagged type expected", Arg1);
4840 -- Second argument is a component name of type Vtable_Ptr
4842 Arg := Expression (Arg2);
4844 if Nkind (Arg) /= N_Identifier then
4845 Error_Msg_NE ("must be a& component name", Arg, Typ);
4849 DTC := First_Component (Typ);
4850 while Present (DTC) and then Chars (DTC) /= Chars (Arg) loop
4851 Next_Component (DTC);
4855 Error_Msg_NE ("must be a& component name", Arg, Typ);
4858 elsif Etype (DTC) /= VTP_Type then
4859 Wrong_Type (DTC, VTP_Type);
4862 -- If it is the first pragma Vtable, This becomes the default tag
4864 elsif (not Is_Tag (DTC))
4865 and then DT_Entry_Count (Tag_Component (Typ)) = No_Uint
4867 Set_Is_Tag (Tag_Component (Typ), False);
4868 Set_Is_Tag (DTC, True);
4869 Set_DT_Entry_Count (DTC, No_Uint);
4872 -- Those pragmas must appear before any primitive operation
4873 -- definition (except inherited ones) otherwise the default
4876 Elmt := First_Elmt (Primitive_Operations (Typ));
4877 while Present (Elmt) loop
4878 if No (Alias (Node (Elmt))) then
4879 Error_Msg_Sloc := Sloc (Node (Elmt));
4881 ("pragma% must appear before this primitive operation");
4887 -- Third argument is an integer (DT_Entry_Count)
4889 Arg := Expression (Arg3);
4890 Analyze_And_Resolve (Arg, Any_Integer);
4892 if not Is_Static_Expression (Arg) then
4893 Flag_Non_Static_Expr
4894 ("entry count for pragma CPP_Vtable must be a static " &
4895 "expression!", Arg3);
4899 V := Expr_Value (Expression (Arg3));
4903 ("entry count for pragma% must be positive", Arg3);
4905 Set_DT_Entry_Count (DTC, V);
4914 -- pragma Debug (PROCEDURE_CALL_STATEMENT);
4916 when Pragma_Debug => Debug : begin
4919 -- If assertions are enabled, and we are expanding code, then
4920 -- we rewrite the pragma with its corresponding procedure call
4921 -- and then analyze the call.
4923 if Assertions_Enabled and Expander_Active then
4924 Rewrite (N, Relocate_Node (Debug_Statement (N)));
4927 -- Otherwise we work a bit to get a tree that makes sense
4928 -- for ASIS purposes, namely a pragma with an analyzed
4929 -- argument that looks like a procedure call.
4932 Expander_Mode_Save_And_Set (False);
4933 Rewrite (N, Relocate_Node (Debug_Statement (N)));
4937 Chars => Name_Debug,
4938 Pragma_Argument_Associations =>
4939 New_List (Relocate_Node (N))));
4940 Expander_Mode_Restore;
4948 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
4950 when Pragma_Discard_Names => Discard_Names : declare
4955 Check_Ada_83_Warning;
4957 -- Deal with configuration pragma case
4959 if Arg_Count = 0 and then Is_Configuration_Pragma then
4960 Global_Discard_Names := True;
4963 -- Otherwise, check correct appropriate context
4966 Check_Is_In_Decl_Part_Or_Package_Spec;
4968 if Arg_Count = 0 then
4970 -- If there is no parameter, then from now on this pragma
4971 -- applies to any enumeration, exception or tagged type
4972 -- defined in the current declarative part.
4974 Set_Discard_Names (Current_Scope);
4978 Check_Arg_Count (1);
4979 Check_Optional_Identifier (Arg1, Name_On);
4980 Check_Arg_Is_Local_Name (Arg1);
4981 E_Id := Expression (Arg1);
4983 if Etype (E_Id) = Any_Type then
4989 if (Is_First_Subtype (E)
4990 and then (Is_Enumeration_Type (E)
4991 or else Is_Tagged_Type (E)))
4992 or else Ekind (E) = E_Exception
4994 Set_Discard_Names (E);
4997 ("inappropriate entity for pragma%", Arg1);
5007 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
5009 when Pragma_Elaborate => Elaborate : declare
5011 Parent_Node : Node_Id;
5016 -- Pragma must be in context items list of a compilation unit
5018 if not Is_List_Member (N) then
5023 Plist := List_Containing (N);
5024 Parent_Node := Parent (Plist);
5026 if Parent_Node = Empty
5027 or else Nkind (Parent_Node) /= N_Compilation_Unit
5028 or else Context_Items (Parent_Node) /= Plist
5035 -- Must be at least one argument
5037 if Arg_Count = 0 then
5038 Error_Pragma ("pragma% requires at least one argument");
5041 -- In Ada 83 mode, there can be no items following it in the
5042 -- context list except other pragmas and implicit with clauses
5043 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
5044 -- placement rule does not apply.
5046 if Ada_83 and then Comes_From_Source (N) then
5049 while Present (Citem) loop
5050 if Nkind (Citem) = N_Pragma
5051 or else (Nkind (Citem) = N_With_Clause
5052 and then Implicit_With (Citem))
5057 ("(Ada 83) pragma% must be at end of context clause");
5064 -- Finally, the arguments must all be units mentioned in a with
5065 -- clause in the same context clause. Note we already checked
5066 -- (in Par.Prag) that the arguments are either identifiers or
5069 Outer : while Present (Arg) loop
5070 Citem := First (Plist);
5072 Inner : while Citem /= N loop
5073 if Nkind (Citem) = N_With_Clause
5074 and then Same_Name (Name (Citem), Expression (Arg))
5076 Set_Elaborate_Present (Citem, True);
5077 Set_Unit_Name (Expression (Arg), Name (Citem));
5078 Set_Suppress_Elaboration_Warnings (Entity (Name (Citem)));
5087 ("argument of pragma% is not with'ed unit", Arg);
5093 -- Give a warning if operating in static mode with -gnatwl
5094 -- (elaboration warnings eanbled) switch set.
5096 if Elab_Warnings and not Dynamic_Elaboration_Checks then
5098 ("?use of pragma Elaborate may not be safe", N);
5100 ("?use pragma Elaborate_All instead if possible", N);
5108 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
5110 when Pragma_Elaborate_All => Elaborate_All : declare
5112 Parent_Node : Node_Id;
5117 Check_Ada_83_Warning;
5119 -- Pragma must be in context items list of a compilation unit
5121 if not Is_List_Member (N) then
5126 Plist := List_Containing (N);
5127 Parent_Node := Parent (Plist);
5129 if Parent_Node = Empty
5130 or else Nkind (Parent_Node) /= N_Compilation_Unit
5131 or else Context_Items (Parent_Node) /= Plist
5138 -- Must be at least one argument
5140 if Arg_Count = 0 then
5141 Error_Pragma ("pragma% requires at least one argument");
5144 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
5145 -- have to appear at the end of the context clause, but may
5146 -- appear mixed in with other items, even in Ada 83 mode.
5148 -- Final check: the arguments must all be units mentioned in
5149 -- a with clause in the same context clause. Note that we
5150 -- already checked (in Par.Prag) that all the arguments are
5151 -- either identifiers or selected components.
5154 Outr : while Present (Arg) loop
5155 Citem := First (Plist);
5157 Innr : while Citem /= N loop
5158 if Nkind (Citem) = N_With_Clause
5159 and then Same_Name (Name (Citem), Expression (Arg))
5161 Set_Elaborate_All_Present (Citem, True);
5162 Set_Unit_Name (Expression (Arg), Name (Citem));
5163 Set_Suppress_Elaboration_Warnings (Entity (Name (Citem)));
5171 Set_Error_Posted (N);
5173 ("argument of pragma% is not with'ed unit", Arg);
5180 --------------------
5181 -- Elaborate_Body --
5182 --------------------
5184 -- pragma Elaborate_Body [( library_unit_NAME )];
5186 when Pragma_Elaborate_Body => Elaborate_Body : declare
5187 Cunit_Node : Node_Id;
5188 Cunit_Ent : Entity_Id;
5191 Check_Ada_83_Warning;
5192 Check_Valid_Library_Unit_Pragma;
5194 if Nkind (N) = N_Null_Statement then
5198 Cunit_Node := Cunit (Current_Sem_Unit);
5199 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
5201 if Nkind (Unit (Cunit_Node)) = N_Package_Body
5203 Nkind (Unit (Cunit_Node)) = N_Subprogram_Body
5205 Error_Pragma ("pragma% must refer to a spec, not a body");
5207 Set_Body_Required (Cunit_Node, True);
5208 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
5210 -- If we are in dynamic elaboration mode, then we suppress
5211 -- elaboration warnings for the unit, since it is definitely
5212 -- fine NOT to do dynamic checks at the first level (and such
5213 -- checks will be suppressed because no elaboration boolean
5214 -- is created for Elaborate_Body packages).
5216 -- But in the static model of elaboration, Elaborate_Body is
5217 -- definitely NOT good enough to ensure elaboration safety on
5218 -- its own, since the body may WITH other units that are not
5219 -- safe from an elaboration point of view, so a client must
5220 -- still do an Elaborate_All on such units.
5222 -- Debug flag -gnatdD restores the old behavior of 3.13,
5223 -- where Elaborate_Body always suppressed elab warnings.
5225 if Dynamic_Elaboration_Checks or Debug_Flag_DD then
5226 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
5231 ------------------------
5232 -- Elaboration_Checks --
5233 ------------------------
5235 -- pragma Elaboration_Checks (Static | Dynamic);
5237 when Pragma_Elaboration_Checks =>
5239 Check_Arg_Count (1);
5240 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
5241 Dynamic_Elaboration_Checks :=
5242 (Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic);
5248 -- pragma Eliminate (
5249 -- [Unit_Name =>] IDENTIFIER |
5250 -- SELECTED_COMPONENT
5251 -- [,[Entity =>] IDENTIFIER |
5252 -- SELECTED_COMPONENT |
5254 -- [,[Parameter_Types =>] PARAMETER_TYPES]
5255 -- [,[Result_Type =>] result_SUBTYPE_NAME]
5256 -- [,[Homonym_Number =>] INTEGER_LITERAL]);
5258 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
5259 -- SUBTYPE_NAME ::= STRING_LITERAL
5261 when Pragma_Eliminate => Eliminate : declare
5262 Args : Args_List (1 .. 5);
5263 Names : constant Name_List (1 .. 5) := (
5266 Name_Parameter_Types,
5268 Name_Homonym_Number);
5270 Unit_Name : Node_Id renames Args (1);
5271 Entity : Node_Id renames Args (2);
5272 Parameter_Types : Node_Id renames Args (3);
5273 Result_Type : Node_Id renames Args (4);
5274 Homonym_Number : Node_Id renames Args (5);
5278 Check_Valid_Configuration_Pragma;
5279 Gather_Associations (Names, Args);
5281 if No (Unit_Name) then
5282 Error_Pragma ("missing Unit_Name argument for pragma%");
5286 and then (Present (Parameter_Types)
5288 Present (Result_Type)
5290 Present (Homonym_Number))
5292 Error_Pragma ("missing Entity argument for pragma%");
5295 Process_Eliminate_Pragma
5303 --------------------------
5304 -- Explicit_Overriding --
5305 --------------------------
5307 when Pragma_Explicit_Overriding =>
5308 Check_Valid_Configuration_Pragma;
5309 Check_Arg_Count (0);
5310 Explicit_Overriding := True;
5317 -- [ Convention =>] convention_IDENTIFIER,
5318 -- [ Entity =>] local_NAME
5319 -- [, [External_Name =>] static_string_EXPRESSION ]
5320 -- [, [Link_Name =>] static_string_EXPRESSION ]);
5322 when Pragma_Export => Export : declare
5327 Check_Ada_83_Warning;
5328 Check_At_Least_N_Arguments (2);
5329 Check_At_Most_N_Arguments (4);
5330 Process_Convention (C, Def_Id);
5332 if Ekind (Def_Id) /= E_Constant then
5333 Note_Possible_Modification (Expression (Arg2));
5336 Process_Interface_Name (Def_Id, Arg3, Arg4);
5337 Set_Exported (Def_Id, Arg2);
5340 ----------------------
5341 -- Export_Exception --
5342 ----------------------
5344 -- pragma Export_Exception (
5345 -- [Internal =>] LOCAL_NAME,
5346 -- [, [External =>] EXTERNAL_SYMBOL,]
5347 -- [, [Form =>] Ada | VMS]
5348 -- [, [Code =>] static_integer_EXPRESSION]);
5350 when Pragma_Export_Exception => Export_Exception : declare
5351 Args : Args_List (1 .. 4);
5352 Names : constant Name_List (1 .. 4) := (
5358 Internal : Node_Id renames Args (1);
5359 External : Node_Id renames Args (2);
5360 Form : Node_Id renames Args (3);
5361 Code : Node_Id renames Args (4);
5364 if Inside_A_Generic then
5365 Error_Pragma ("pragma% cannot be used for generic entities");
5368 Gather_Associations (Names, Args);
5369 Process_Extended_Import_Export_Exception_Pragma (
5370 Arg_Internal => Internal,
5371 Arg_External => External,
5375 if not Is_VMS_Exception (Entity (Internal)) then
5376 Set_Exported (Entity (Internal), Internal);
5378 end Export_Exception;
5380 ---------------------
5381 -- Export_Function --
5382 ---------------------
5384 -- pragma Export_Function (
5385 -- [Internal =>] LOCAL_NAME,
5386 -- [, [External =>] EXTERNAL_SYMBOL,]
5387 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
5388 -- [, [Result_Type =>] TYPE_DESIGNATOR]
5389 -- [, [Mechanism =>] MECHANISM]
5390 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
5392 -- EXTERNAL_SYMBOL ::=
5394 -- | static_string_EXPRESSION
5396 -- PARAMETER_TYPES ::=
5398 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
5400 -- TYPE_DESIGNATOR ::=
5402 -- | subtype_Name ' Access
5406 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
5408 -- MECHANISM_ASSOCIATION ::=
5409 -- [formal_parameter_NAME =>] MECHANISM_NAME
5411 -- MECHANISM_NAME ::=
5414 -- | Descriptor [([Class =>] CLASS_NAME)]
5416 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
5418 when Pragma_Export_Function => Export_Function : declare
5419 Args : Args_List (1 .. 6);
5420 Names : constant Name_List (1 .. 6) := (
5423 Name_Parameter_Types,
5426 Name_Result_Mechanism);
5428 Internal : Node_Id renames Args (1);
5429 External : Node_Id renames Args (2);
5430 Parameter_Types : Node_Id renames Args (3);
5431 Result_Type : Node_Id renames Args (4);
5432 Mechanism : Node_Id renames Args (5);
5433 Result_Mechanism : Node_Id renames Args (6);
5437 Gather_Associations (Names, Args);
5438 Process_Extended_Import_Export_Subprogram_Pragma (
5439 Arg_Internal => Internal,
5440 Arg_External => External,
5441 Arg_Parameter_Types => Parameter_Types,
5442 Arg_Result_Type => Result_Type,
5443 Arg_Mechanism => Mechanism,
5444 Arg_Result_Mechanism => Result_Mechanism);
5445 end Export_Function;
5451 -- pragma Export_Object (
5452 -- [Internal =>] LOCAL_NAME,
5453 -- [, [External =>] EXTERNAL_SYMBOL]
5454 -- [, [Size =>] EXTERNAL_SYMBOL]);
5456 -- EXTERNAL_SYMBOL ::=
5458 -- | static_string_EXPRESSION
5460 -- PARAMETER_TYPES ::=
5462 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
5464 -- TYPE_DESIGNATOR ::=
5466 -- | subtype_Name ' Access
5470 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
5472 -- MECHANISM_ASSOCIATION ::=
5473 -- [formal_parameter_NAME =>] MECHANISM_NAME
5475 -- MECHANISM_NAME ::=
5478 -- | Descriptor [([Class =>] CLASS_NAME)]
5480 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
5482 when Pragma_Export_Object => Export_Object : declare
5483 Args : Args_List (1 .. 3);
5484 Names : constant Name_List (1 .. 3) := (
5489 Internal : Node_Id renames Args (1);
5490 External : Node_Id renames Args (2);
5491 Size : Node_Id renames Args (3);
5495 Gather_Associations (Names, Args);
5496 Process_Extended_Import_Export_Object_Pragma (
5497 Arg_Internal => Internal,
5498 Arg_External => External,
5502 ----------------------
5503 -- Export_Procedure --
5504 ----------------------
5506 -- pragma Export_Procedure (
5507 -- [Internal =>] LOCAL_NAME,
5508 -- [, [External =>] EXTERNAL_SYMBOL,]
5509 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
5510 -- [, [Mechanism =>] MECHANISM]);
5512 -- EXTERNAL_SYMBOL ::=
5514 -- | static_string_EXPRESSION
5516 -- PARAMETER_TYPES ::=
5518 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
5520 -- TYPE_DESIGNATOR ::=
5522 -- | subtype_Name ' Access
5526 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
5528 -- MECHANISM_ASSOCIATION ::=
5529 -- [formal_parameter_NAME =>] MECHANISM_NAME
5531 -- MECHANISM_NAME ::=
5534 -- | Descriptor [([Class =>] CLASS_NAME)]
5536 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
5538 when Pragma_Export_Procedure => Export_Procedure : declare
5539 Args : Args_List (1 .. 4);
5540 Names : constant Name_List (1 .. 4) := (
5543 Name_Parameter_Types,
5546 Internal : Node_Id renames Args (1);
5547 External : Node_Id renames Args (2);
5548 Parameter_Types : Node_Id renames Args (3);
5549 Mechanism : Node_Id renames Args (4);
5553 Gather_Associations (Names, Args);
5554 Process_Extended_Import_Export_Subprogram_Pragma (
5555 Arg_Internal => Internal,
5556 Arg_External => External,
5557 Arg_Parameter_Types => Parameter_Types,
5558 Arg_Mechanism => Mechanism);
5559 end Export_Procedure;
5565 -- pragma Export_Value (
5566 -- [Value =>] static_integer_EXPRESSION,
5567 -- [Link_Name =>] static_string_EXPRESSION);
5569 when Pragma_Export_Value =>
5571 Check_Arg_Count (2);
5573 Check_Optional_Identifier (Arg1, Name_Value);
5574 Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
5576 Check_Optional_Identifier (Arg2, Name_Link_Name);
5577 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
5579 -----------------------------
5580 -- Export_Valued_Procedure --
5581 -----------------------------
5583 -- pragma Export_Valued_Procedure (
5584 -- [Internal =>] LOCAL_NAME,
5585 -- [, [External =>] EXTERNAL_SYMBOL,]
5586 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
5587 -- [, [Mechanism =>] MECHANISM]);
5589 -- EXTERNAL_SYMBOL ::=
5591 -- | static_string_EXPRESSION
5593 -- PARAMETER_TYPES ::=
5595 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
5597 -- TYPE_DESIGNATOR ::=
5599 -- | subtype_Name ' Access
5603 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
5605 -- MECHANISM_ASSOCIATION ::=
5606 -- [formal_parameter_NAME =>] MECHANISM_NAME
5608 -- MECHANISM_NAME ::=
5611 -- | Descriptor [([Class =>] CLASS_NAME)]
5613 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
5615 when Pragma_Export_Valued_Procedure =>
5616 Export_Valued_Procedure : declare
5617 Args : Args_List (1 .. 4);
5618 Names : constant Name_List (1 .. 4) := (
5621 Name_Parameter_Types,
5624 Internal : Node_Id renames Args (1);
5625 External : Node_Id renames Args (2);
5626 Parameter_Types : Node_Id renames Args (3);
5627 Mechanism : Node_Id renames Args (4);
5631 Gather_Associations (Names, Args);
5632 Process_Extended_Import_Export_Subprogram_Pragma (
5633 Arg_Internal => Internal,
5634 Arg_External => External,
5635 Arg_Parameter_Types => Parameter_Types,
5636 Arg_Mechanism => Mechanism);
5637 end Export_Valued_Procedure;
5643 -- pragma Extend_System ([Name =>] Identifier);
5645 when Pragma_Extend_System => Extend_System : declare
5648 Check_Valid_Configuration_Pragma;
5649 Check_Arg_Count (1);
5650 Check_Optional_Identifier (Arg1, Name_Name);
5651 Check_Arg_Is_Identifier (Arg1);
5653 Get_Name_String (Chars (Expression (Arg1)));
5656 and then Name_Buffer (1 .. 4) = "aux_"
5658 if Present (System_Extend_Pragma_Arg) then
5659 if Chars (Expression (Arg1)) =
5660 Chars (Expression (System_Extend_Pragma_Arg))
5664 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
5665 Error_Pragma ("pragma% conflicts with that at#");
5669 System_Extend_Pragma_Arg := Arg1;
5671 if not GNAT_Mode then
5672 System_Extend_Unit := Arg1;
5676 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
5680 ------------------------
5681 -- Extensions_Allowed --
5682 ------------------------
5684 -- pragma Extensions_Allowed (ON | OFF);
5686 when Pragma_Extensions_Allowed =>
5688 Check_Arg_Count (1);
5689 Check_No_Identifiers;
5690 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
5691 Extensions_Allowed := (Chars (Expression (Arg1)) = Name_On);
5697 -- pragma External (
5698 -- [ Convention =>] convention_IDENTIFIER,
5699 -- [ Entity =>] local_NAME
5700 -- [, [External_Name =>] static_string_EXPRESSION ]
5701 -- [, [Link_Name =>] static_string_EXPRESSION ]);
5703 when Pragma_External => External : declare
5709 Check_At_Least_N_Arguments (2);
5710 Check_At_Most_N_Arguments (4);
5711 Process_Convention (C, Def_Id);
5712 Note_Possible_Modification (Expression (Arg2));
5713 Process_Interface_Name (Def_Id, Arg3, Arg4);
5714 Set_Exported (Def_Id, Arg2);
5717 --------------------------
5718 -- External_Name_Casing --
5719 --------------------------
5721 -- pragma External_Name_Casing (
5722 -- UPPERCASE | LOWERCASE
5723 -- [, AS_IS | UPPERCASE | LOWERCASE]);
5725 when Pragma_External_Name_Casing =>
5727 External_Name_Casing : declare
5730 Check_No_Identifiers;
5732 if Arg_Count = 2 then
5734 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
5736 case Chars (Get_Pragma_Arg (Arg2)) is
5738 Opt.External_Name_Exp_Casing := As_Is;
5740 when Name_Uppercase =>
5741 Opt.External_Name_Exp_Casing := Uppercase;
5743 when Name_Lowercase =>
5744 Opt.External_Name_Exp_Casing := Lowercase;
5751 Check_Arg_Count (1);
5754 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
5756 case Chars (Get_Pragma_Arg (Arg1)) is
5757 when Name_Uppercase =>
5758 Opt.External_Name_Imp_Casing := Uppercase;
5760 when Name_Lowercase =>
5761 Opt.External_Name_Imp_Casing := Lowercase;
5766 end External_Name_Casing;
5768 ---------------------------
5769 -- Finalize_Storage_Only --
5770 ---------------------------
5772 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
5774 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
5775 Assoc : constant Node_Id := Arg1;
5776 Type_Id : constant Node_Id := Expression (Assoc);
5780 Check_No_Identifiers;
5781 Check_Arg_Count (1);
5782 Check_Arg_Is_Local_Name (Arg1);
5784 Find_Type (Type_Id);
5785 Typ := Entity (Type_Id);
5788 or else Rep_Item_Too_Early (Typ, N)
5792 Typ := Underlying_Type (Typ);
5795 if not Is_Controlled (Typ) then
5796 Error_Pragma ("pragma% must specify controlled type");
5799 Check_First_Subtype (Arg1);
5801 if Finalize_Storage_Only (Typ) then
5802 Error_Pragma ("duplicate pragma%, only one allowed");
5804 elsif not Rep_Item_Too_Late (Typ, N) then
5805 Set_Finalize_Storage_Only (Base_Type (Typ), True);
5807 end Finalize_Storage;
5809 --------------------------
5810 -- Float_Representation --
5811 --------------------------
5813 -- pragma Float_Representation (VAX_Float | IEEE_Float);
5815 when Pragma_Float_Representation => Float_Representation : declare
5823 if Arg_Count = 1 then
5824 Check_Valid_Configuration_Pragma;
5826 Check_Arg_Count (2);
5827 Check_Optional_Identifier (Arg2, Name_Entity);
5828 Check_Arg_Is_Local_Name (Arg2);
5831 Check_No_Identifier (Arg1);
5832 Check_Arg_Is_One_Of (Arg1, Name_VAX_Float, Name_IEEE_Float);
5834 if not OpenVMS_On_Target then
5835 if Chars (Expression (Arg1)) = Name_VAX_Float then
5837 ("?pragma% ignored (applies only to Open'V'M'S)");
5843 -- One argument case
5845 if Arg_Count = 1 then
5847 if Chars (Expression (Arg1)) = Name_VAX_Float then
5849 if Opt.Float_Format = 'I' then
5850 Error_Pragma ("'I'E'E'E format previously specified");
5853 Opt.Float_Format := 'V';
5856 if Opt.Float_Format = 'V' then
5857 Error_Pragma ("'V'A'X format previously specified");
5860 Opt.Float_Format := 'I';
5863 Set_Standard_Fpt_Formats;
5865 -- Two argument case
5868 Argx := Get_Pragma_Arg (Arg2);
5870 if not Is_Entity_Name (Argx)
5871 or else not Is_Floating_Point_Type (Entity (Argx))
5874 ("second argument of% pragma must be floating-point type",
5878 Ent := Entity (Argx);
5879 Digs := UI_To_Int (Digits_Value (Ent));
5881 -- Two arguments, VAX_Float case
5883 if Chars (Expression (Arg1)) = Name_VAX_Float then
5886 when 6 => Set_F_Float (Ent);
5887 when 9 => Set_D_Float (Ent);
5888 when 15 => Set_G_Float (Ent);
5892 ("wrong digits value, must be 6,9 or 15", Arg2);
5895 -- Two arguments, IEEE_Float case
5899 when 6 => Set_IEEE_Short (Ent);
5900 when 15 => Set_IEEE_Long (Ent);
5904 ("wrong digits value, must be 6 or 15", Arg2);
5908 end Float_Representation;
5914 -- pragma Ident (static_string_EXPRESSION)
5916 -- Note: pragma Comment shares this processing. Pragma Comment
5917 -- is identical to Ident, except that the restriction of the
5918 -- argument to 31 characters and the placement restrictions
5919 -- are not enforced for pragma Comment.
5921 when Pragma_Ident | Pragma_Comment => Ident : declare
5926 Check_Arg_Count (1);
5927 Check_No_Identifiers;
5928 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
5930 -- For pragma Ident, preserve DEC compatibility by requiring
5931 -- the pragma to appear in a declarative part or package spec.
5933 if Prag_Id = Pragma_Ident then
5934 Check_Is_In_Decl_Part_Or_Package_Spec;
5937 Str := Expr_Value_S (Expression (Arg1));
5944 GP := Parent (Parent (N));
5946 if Nkind (GP) = N_Package_Declaration
5948 Nkind (GP) = N_Generic_Package_Declaration
5953 -- If we have a compilation unit, then record the ident
5954 -- value, checking for improper duplication.
5956 if Nkind (GP) = N_Compilation_Unit then
5957 CS := Ident_String (Current_Sem_Unit);
5959 if Present (CS) then
5961 -- For Ident, we do not permit multiple instances
5963 if Prag_Id = Pragma_Ident then
5964 Error_Pragma ("duplicate% pragma not permitted");
5966 -- For Comment, we concatenate the string, unless we
5967 -- want to preserve the tree structure for ASIS.
5969 elsif not ASIS_Mode then
5970 Start_String (Strval (CS));
5971 Store_String_Char (' ');
5972 Store_String_Chars (Strval (Str));
5973 Set_Strval (CS, End_String);
5977 -- In VMS, the effect of IDENT is achieved by passing
5978 -- IDENTIFICATION=name as a --for-linker switch.
5980 if OpenVMS_On_Target then
5983 ("--for-linker=IDENTIFICATION=");
5984 String_To_Name_Buffer (Strval (Str));
5985 Store_String_Chars (Name_Buffer (1 .. Name_Len));
5987 -- Only the last processed IDENT is saved. The main
5988 -- purpose is so an IDENT associated with a main
5989 -- procedure will be used in preference to an IDENT
5990 -- associated with a with'd package.
5992 Replace_Linker_Option_String
5993 (End_String, "--for-linker=IDENTIFICATION=");
5996 Set_Ident_String (Current_Sem_Unit, Str);
5999 -- For subunits, we just ignore the Ident, since in GNAT
6000 -- these are not separate object files, and hence not
6001 -- separate units in the unit table.
6003 elsif Nkind (GP) = N_Subunit then
6006 -- Otherwise we have a misplaced pragma Ident, but we ignore
6007 -- this if we are in an instantiation, since it comes from
6008 -- a generic, and has no relevance to the instantiation.
6010 elsif Prag_Id = Pragma_Ident then
6011 if Instantiation_Location (Loc) = No_Location then
6012 Error_Pragma ("pragma% only allowed at outer level");
6023 -- [ Convention =>] convention_IDENTIFIER,
6024 -- [ Entity =>] local_NAME
6025 -- [, [External_Name =>] static_string_EXPRESSION ]
6026 -- [, [Link_Name =>] static_string_EXPRESSION ]);
6028 when Pragma_Import =>
6029 Check_Ada_83_Warning;
6030 Check_At_Least_N_Arguments (2);
6031 Check_At_Most_N_Arguments (4);
6032 Process_Import_Or_Interface;
6034 ----------------------
6035 -- Import_Exception --
6036 ----------------------
6038 -- pragma Import_Exception (
6039 -- [Internal =>] LOCAL_NAME,
6040 -- [, [External =>] EXTERNAL_SYMBOL,]
6041 -- [, [Form =>] Ada | VMS]
6042 -- [, [Code =>] static_integer_EXPRESSION]);
6044 when Pragma_Import_Exception => Import_Exception : declare
6045 Args : Args_List (1 .. 4);
6046 Names : constant Name_List (1 .. 4) := (
6052 Internal : Node_Id renames Args (1);
6053 External : Node_Id renames Args (2);
6054 Form : Node_Id renames Args (3);
6055 Code : Node_Id renames Args (4);
6058 Gather_Associations (Names, Args);
6060 if Present (External) and then Present (Code) then
6062 ("cannot give both External and Code options for pragma%");
6065 Process_Extended_Import_Export_Exception_Pragma (
6066 Arg_Internal => Internal,
6067 Arg_External => External,
6071 if not Is_VMS_Exception (Entity (Internal)) then
6072 Set_Imported (Entity (Internal));
6074 end Import_Exception;
6076 ---------------------
6077 -- Import_Function --
6078 ---------------------
6080 -- pragma Import_Function (
6081 -- [Internal =>] LOCAL_NAME,
6082 -- [, [External =>] EXTERNAL_SYMBOL]
6083 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
6084 -- [, [Result_Type =>] SUBTYPE_MARK]
6085 -- [, [Mechanism =>] MECHANISM]
6086 -- [, [Result_Mechanism =>] MECHANISM_NAME]
6087 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
6089 -- EXTERNAL_SYMBOL ::=
6091 -- | static_string_EXPRESSION
6093 -- PARAMETER_TYPES ::=
6095 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
6097 -- TYPE_DESIGNATOR ::=
6099 -- | subtype_Name ' Access
6103 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
6105 -- MECHANISM_ASSOCIATION ::=
6106 -- [formal_parameter_NAME =>] MECHANISM_NAME
6108 -- MECHANISM_NAME ::=
6111 -- | Descriptor [([Class =>] CLASS_NAME)]
6113 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
6115 when Pragma_Import_Function => Import_Function : declare
6116 Args : Args_List (1 .. 7);
6117 Names : constant Name_List (1 .. 7) := (
6120 Name_Parameter_Types,
6123 Name_Result_Mechanism,
6124 Name_First_Optional_Parameter);
6126 Internal : Node_Id renames Args (1);
6127 External : Node_Id renames Args (2);
6128 Parameter_Types : Node_Id renames Args (3);
6129 Result_Type : Node_Id renames Args (4);
6130 Mechanism : Node_Id renames Args (5);
6131 Result_Mechanism : Node_Id renames Args (6);
6132 First_Optional_Parameter : Node_Id renames Args (7);
6136 Gather_Associations (Names, Args);
6137 Process_Extended_Import_Export_Subprogram_Pragma (
6138 Arg_Internal => Internal,
6139 Arg_External => External,
6140 Arg_Parameter_Types => Parameter_Types,
6141 Arg_Result_Type => Result_Type,
6142 Arg_Mechanism => Mechanism,
6143 Arg_Result_Mechanism => Result_Mechanism,
6144 Arg_First_Optional_Parameter => First_Optional_Parameter);
6145 end Import_Function;
6151 -- pragma Import_Object (
6152 -- [Internal =>] LOCAL_NAME,
6153 -- [, [External =>] EXTERNAL_SYMBOL]
6154 -- [, [Size =>] EXTERNAL_SYMBOL]);
6156 -- EXTERNAL_SYMBOL ::=
6158 -- | static_string_EXPRESSION
6160 when Pragma_Import_Object => Import_Object : declare
6161 Args : Args_List (1 .. 3);
6162 Names : constant Name_List (1 .. 3) := (
6167 Internal : Node_Id renames Args (1);
6168 External : Node_Id renames Args (2);
6169 Size : Node_Id renames Args (3);
6173 Gather_Associations (Names, Args);
6174 Process_Extended_Import_Export_Object_Pragma (
6175 Arg_Internal => Internal,
6176 Arg_External => External,
6180 ----------------------
6181 -- Import_Procedure --
6182 ----------------------
6184 -- pragma Import_Procedure (
6185 -- [Internal =>] LOCAL_NAME,
6186 -- [, [External =>] EXTERNAL_SYMBOL]
6187 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
6188 -- [, [Mechanism =>] MECHANISM]
6189 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
6191 -- EXTERNAL_SYMBOL ::=
6193 -- | static_string_EXPRESSION
6195 -- PARAMETER_TYPES ::=
6197 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
6199 -- TYPE_DESIGNATOR ::=
6201 -- | subtype_Name ' Access
6205 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
6207 -- MECHANISM_ASSOCIATION ::=
6208 -- [formal_parameter_NAME =>] MECHANISM_NAME
6210 -- MECHANISM_NAME ::=
6213 -- | Descriptor [([Class =>] CLASS_NAME)]
6215 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
6217 when Pragma_Import_Procedure => Import_Procedure : declare
6218 Args : Args_List (1 .. 5);
6219 Names : constant Name_List (1 .. 5) := (
6222 Name_Parameter_Types,
6224 Name_First_Optional_Parameter);
6226 Internal : Node_Id renames Args (1);
6227 External : Node_Id renames Args (2);
6228 Parameter_Types : Node_Id renames Args (3);
6229 Mechanism : Node_Id renames Args (4);
6230 First_Optional_Parameter : Node_Id renames Args (5);
6234 Gather_Associations (Names, Args);
6235 Process_Extended_Import_Export_Subprogram_Pragma (
6236 Arg_Internal => Internal,
6237 Arg_External => External,
6238 Arg_Parameter_Types => Parameter_Types,
6239 Arg_Mechanism => Mechanism,
6240 Arg_First_Optional_Parameter => First_Optional_Parameter);
6241 end Import_Procedure;
6243 -----------------------------
6244 -- Import_Valued_Procedure --
6245 -----------------------------
6247 -- pragma Import_Valued_Procedure (
6248 -- [Internal =>] LOCAL_NAME,
6249 -- [, [External =>] EXTERNAL_SYMBOL]
6250 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
6251 -- [, [Mechanism =>] MECHANISM]
6252 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
6254 -- EXTERNAL_SYMBOL ::=
6256 -- | static_string_EXPRESSION
6258 -- PARAMETER_TYPES ::=
6260 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
6262 -- TYPE_DESIGNATOR ::=
6264 -- | subtype_Name ' Access
6268 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
6270 -- MECHANISM_ASSOCIATION ::=
6271 -- [formal_parameter_NAME =>] MECHANISM_NAME
6273 -- MECHANISM_NAME ::=
6276 -- | Descriptor [([Class =>] CLASS_NAME)]
6278 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
6280 when Pragma_Import_Valued_Procedure =>
6281 Import_Valued_Procedure : declare
6282 Args : Args_List (1 .. 5);
6283 Names : constant Name_List (1 .. 5) := (
6286 Name_Parameter_Types,
6288 Name_First_Optional_Parameter);
6290 Internal : Node_Id renames Args (1);
6291 External : Node_Id renames Args (2);
6292 Parameter_Types : Node_Id renames Args (3);
6293 Mechanism : Node_Id renames Args (4);
6294 First_Optional_Parameter : Node_Id renames Args (5);
6298 Gather_Associations (Names, Args);
6299 Process_Extended_Import_Export_Subprogram_Pragma (
6300 Arg_Internal => Internal,
6301 Arg_External => External,
6302 Arg_Parameter_Types => Parameter_Types,
6303 Arg_Mechanism => Mechanism,
6304 Arg_First_Optional_Parameter => First_Optional_Parameter);
6305 end Import_Valued_Procedure;
6307 ------------------------
6308 -- Initialize_Scalars --
6309 ------------------------
6311 -- pragma Initialize_Scalars;
6313 when Pragma_Initialize_Scalars =>
6315 Check_Arg_Count (0);
6316 Check_Valid_Configuration_Pragma;
6317 Check_Restriction (No_Initialize_Scalars, N);
6319 if not Restrictions (No_Initialize_Scalars) then
6320 Init_Or_Norm_Scalars := True;
6321 Initialize_Scalars := True;
6328 -- pragma Inline ( NAME {, NAME} );
6330 when Pragma_Inline =>
6332 -- Pragma is active if inlining option is active
6334 if Inline_Active then
6335 Process_Inline (True);
6337 -- Pragma is active in a predefined file in config run time mode
6339 elsif Configurable_Run_Time_Mode
6341 Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
6343 Process_Inline (True);
6345 -- Otherwise inlining is not active
6348 Process_Inline (False);
6355 -- pragma Inline_Always ( NAME {, NAME} );
6357 when Pragma_Inline_Always =>
6358 Process_Inline (True);
6360 --------------------
6361 -- Inline_Generic --
6362 --------------------
6364 -- pragma Inline_Generic (NAME {, NAME});
6366 when Pragma_Inline_Generic =>
6367 Process_Generic_List;
6369 ----------------------
6370 -- Inspection_Point --
6371 ----------------------
6373 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
6375 when Pragma_Inspection_Point => Inspection_Point : declare
6380 if Arg_Count > 0 then
6383 Exp := Expression (Arg);
6386 if not Is_Entity_Name (Exp)
6387 or else not Is_Object (Entity (Exp))
6389 Error_Pragma_Arg ("object name required", Arg);
6396 end Inspection_Point;
6402 -- pragma Interface (
6403 -- convention_IDENTIFIER,
6406 when Pragma_Interface =>
6408 Check_Arg_Count (2);
6409 Check_No_Identifiers;
6410 Process_Import_Or_Interface;
6412 --------------------
6413 -- Interface_Name --
6414 --------------------
6416 -- pragma Interface_Name (
6417 -- [ Entity =>] local_NAME
6418 -- [,[External_Name =>] static_string_EXPRESSION ]
6419 -- [,[Link_Name =>] static_string_EXPRESSION ]);
6421 when Pragma_Interface_Name => Interface_Name : declare
6429 Check_At_Least_N_Arguments (2);
6430 Check_At_Most_N_Arguments (3);
6431 Id := Expression (Arg1);
6434 if not Is_Entity_Name (Id) then
6436 ("first argument for pragma% must be entity name", Arg1);
6437 elsif Etype (Id) = Any_Type then
6440 Def_Id := Entity (Id);
6443 -- Special DEC-compatible processing for the object case,
6444 -- forces object to be imported.
6446 if Ekind (Def_Id) = E_Variable then
6447 Kill_Size_Check_Code (Def_Id);
6448 Note_Possible_Modification (Id);
6450 -- Initialization is not allowed for imported variable
6452 if Present (Expression (Parent (Def_Id)))
6453 and then Comes_From_Source (Expression (Parent (Def_Id)))
6455 Error_Msg_Sloc := Sloc (Def_Id);
6457 ("no initialization allowed for declaration of& #",
6461 -- For compatibility, support VADS usage of providing both
6462 -- pragmas Interface and Interface_Name to obtain the effect
6463 -- of a single Import pragma.
6465 if Is_Imported (Def_Id)
6466 and then Present (First_Rep_Item (Def_Id))
6467 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
6468 and then Chars (First_Rep_Item (Def_Id)) = Name_Interface
6472 Set_Imported (Def_Id);
6475 Set_Is_Public (Def_Id);
6476 Process_Interface_Name (Def_Id, Arg2, Arg3);
6479 -- Otherwise must be subprogram
6481 elsif not Is_Subprogram (Def_Id) then
6483 ("argument of pragma% is not subprogram", Arg1);
6486 Check_At_Most_N_Arguments (3);
6490 -- Loop through homonyms
6493 Def_Id := Get_Base_Subprogram (Hom_Id);
6495 if Is_Imported (Def_Id) then
6496 Process_Interface_Name (Def_Id, Arg2, Arg3);
6500 Hom_Id := Homonym (Hom_Id);
6502 exit when No (Hom_Id)
6503 or else Scope (Hom_Id) /= Current_Scope;
6508 ("argument of pragma% is not imported subprogram",
6514 -----------------------
6515 -- Interrupt_Handler --
6516 -----------------------
6518 -- pragma Interrupt_Handler (handler_NAME);
6520 when Pragma_Interrupt_Handler =>
6521 Check_Ada_83_Warning;
6522 Check_Arg_Count (1);
6523 Check_No_Identifiers;
6525 if No_Run_Time_Mode then
6526 Error_Msg_CRT ("Interrupt_Handler pragma", N);
6528 Check_Interrupt_Or_Attach_Handler;
6529 Process_Interrupt_Or_Attach_Handler;
6532 ------------------------
6533 -- Interrupt_Priority --
6534 ------------------------
6536 -- pragma Interrupt_Priority [(EXPRESSION)];
6538 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
6539 P : constant Node_Id := Parent (N);
6543 Check_Ada_83_Warning;
6545 if Arg_Count /= 0 then
6546 Arg := Expression (Arg1);
6547 Check_Arg_Count (1);
6548 Check_No_Identifiers;
6550 -- The expression must be analyzed in the special manner
6551 -- described in "Handling of Default and Per-Object
6552 -- Expressions" in sem.ads.
6554 Analyze_Per_Use_Expression (Arg, RTE (RE_Interrupt_Priority));
6557 if Nkind (P) /= N_Task_Definition
6558 and then Nkind (P) /= N_Protected_Definition
6563 elsif Has_Priority_Pragma (P) then
6564 Error_Pragma ("duplicate pragma% not allowed");
6567 Set_Has_Priority_Pragma (P, True);
6568 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
6570 end Interrupt_Priority;
6572 ---------------------
6573 -- Interrupt_State --
6574 ---------------------
6576 -- pragma Interrupt_State (
6577 -- [Name =>] INTERRUPT_ID,
6578 -- [State =>] INTERRUPT_STATE);
6580 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
6581 -- INTERRUPT_STATE => System | Runtime | User
6583 -- Note: if the interrupt id is given as an identifier, then
6584 -- it must be one of the identifiers in Ada.Interrupts.Names.
6585 -- Otherwise it is given as a static integer expression which
6586 -- must be in the range of Ada.Interrupts.Interrupt_ID.
6588 when Pragma_Interrupt_State => Interrupt_State : declare
6590 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
6591 -- This is the entity Ada.Interrupts.Interrupt_ID;
6593 State_Type : Character;
6594 -- Set to 's'/'r'/'u' for System/Runtime/User
6597 -- Index to entry in Interrupt_States table
6600 -- Value of interrupt
6602 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
6603 -- The first argument to the pragma
6605 Int_Ent : Entity_Id;
6606 -- Interrupt entity in Ada.Interrupts.Names
6610 Check_Arg_Count (2);
6612 Check_Optional_Identifier (Arg1, Name_Name);
6613 Check_Optional_Identifier (Arg2, "state");
6614 Check_Arg_Is_Identifier (Arg2);
6616 -- First argument is identifier
6618 if Nkind (Arg1X) = N_Identifier then
6620 -- Search list of names in Ada.Interrupts.Names
6622 Int_Ent := First_Entity (RTE (RE_Names));
6624 if No (Int_Ent) then
6625 Error_Pragma_Arg ("invalid interrupt name", Arg1);
6627 elsif Chars (Int_Ent) = Chars (Arg1X) then
6628 Int_Val := Expr_Value (Constant_Value (Int_Ent));
6632 Next_Entity (Int_Ent);
6635 -- First argument is not an identifier, so it must be a
6636 -- static expression of type Ada.Interrupts.Interrupt_ID.
6639 Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
6640 Int_Val := Expr_Value (Arg1X);
6642 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
6644 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
6647 ("value not in range of type " &
6648 """Ada.Interrupts.Interrupt_'I'D""", Arg1);
6654 case Chars (Get_Pragma_Arg (Arg2)) is
6655 when Name_Runtime => State_Type := 'r';
6656 when Name_System => State_Type := 's';
6657 when Name_User => State_Type := 'u';
6660 Error_Pragma_Arg ("invalid interrupt state", Arg2);
6663 -- Check if entry is already stored
6665 IST_Num := Interrupt_States.First;
6667 -- If entry not found, add it
6669 if IST_Num > Interrupt_States.Last then
6670 Interrupt_States.Append
6671 ((Interrupt_Number => UI_To_Int (Int_Val),
6672 Interrupt_State => State_Type,
6673 Pragma_Loc => Loc));
6676 -- Case of entry for the same entry
6678 elsif Int_Val = Interrupt_States.Table (IST_Num).
6681 -- If state matches, done, no need to make redundant entry
6684 State_Type = Interrupt_States.Table (IST_Num).
6687 -- Otherwise if state does not match, error
6690 Interrupt_States.Table (IST_Num).Pragma_Loc;
6692 ("state conflicts with that given at #", Arg2);
6696 IST_Num := IST_Num + 1;
6698 end Interrupt_State;
6700 ----------------------
6701 -- Java_Constructor --
6702 ----------------------
6704 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
6706 when Pragma_Java_Constructor => Java_Constructor : declare
6713 Check_Arg_Count (1);
6714 Check_Optional_Identifier (Arg1, Name_Entity);
6715 Check_Arg_Is_Local_Name (Arg1);
6717 Id := Expression (Arg1);
6718 Find_Program_Unit_Name (Id);
6720 -- If we did not find the name, we are done
6722 if Etype (Id) = Any_Type then
6726 Hom_Id := Entity (Id);
6728 -- Loop through homonyms
6731 Def_Id := Get_Base_Subprogram (Hom_Id);
6733 -- The constructor is required to be a function returning
6734 -- an access type whose designated type has convention Java.
6736 if Ekind (Def_Id) = E_Function
6737 and then Ekind (Etype (Def_Id)) in Access_Kind
6740 (Designated_Type (Etype (Def_Id))) = Convention_Java
6743 (Root_Type (Designated_Type (Etype (Def_Id))))
6746 Set_Is_Constructor (Def_Id);
6747 Set_Convention (Def_Id, Convention_Java);
6751 ("pragma% requires function returning a 'Java access type",
6755 Hom_Id := Homonym (Hom_Id);
6757 exit when No (Hom_Id) or else Scope (Hom_Id) /= Current_Scope;
6759 end Java_Constructor;
6761 ----------------------
6762 -- Java_Interface --
6763 ----------------------
6765 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
6767 when Pragma_Java_Interface => Java_Interface : declare
6773 Check_Arg_Count (1);
6774 Check_Optional_Identifier (Arg1, Name_Entity);
6775 Check_Arg_Is_Local_Name (Arg1);
6777 Arg := Expression (Arg1);
6780 if Etype (Arg) = Any_Type then
6784 if not Is_Entity_Name (Arg)
6785 or else not Is_Type (Entity (Arg))
6787 Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
6790 Typ := Underlying_Type (Entity (Arg));
6792 -- For now we simply check some of the semantic constraints
6793 -- on the type. This currently leaves out some restrictions
6794 -- on interface types, namely that the parent type must be
6795 -- java.lang.Object.Typ and that all primitives of the type
6796 -- should be declared abstract. ???
6798 if not Is_Tagged_Type (Typ) or else not Is_Abstract (Typ) then
6799 Error_Pragma_Arg ("pragma% requires an abstract "
6800 & "tagged type", Arg1);
6802 elsif not Has_Discriminants (Typ)
6803 or else Ekind (Etype (First_Discriminant (Typ)))
6804 /= E_Anonymous_Access_Type
6806 not Is_Class_Wide_Type
6807 (Designated_Type (Etype (First_Discriminant (Typ))))
6810 ("type must have a class-wide access discriminant", Arg1);
6818 -- pragma Keep_Names ([On => ] local_NAME);
6820 when Pragma_Keep_Names => Keep_Names : declare
6825 Check_Arg_Count (1);
6826 Check_Optional_Identifier (Arg1, Name_On);
6827 Check_Arg_Is_Local_Name (Arg1);
6829 Arg := Expression (Arg1);
6832 if Etype (Arg) = Any_Type then
6836 if not Is_Entity_Name (Arg)
6837 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
6840 ("pragma% requires a local enumeration type", Arg1);
6843 Set_Discard_Names (Entity (Arg), False);
6850 -- pragma License (RESTRICTED | UNRESRICTED | GPL | MODIFIED_GPL);
6852 when Pragma_License =>
6854 Check_Arg_Count (1);
6855 Check_No_Identifiers;
6856 Check_Valid_Configuration_Pragma;
6857 Check_Arg_Is_Identifier (Arg1);
6860 Sind : constant Source_File_Index :=
6861 Source_Index (Current_Sem_Unit);
6864 case Chars (Get_Pragma_Arg (Arg1)) is
6866 Set_License (Sind, GPL);
6868 when Name_Modified_GPL =>
6869 Set_License (Sind, Modified_GPL);
6871 when Name_Restricted =>
6872 Set_License (Sind, Restricted);
6874 when Name_Unrestricted =>
6875 Set_License (Sind, Unrestricted);
6878 Error_Pragma_Arg ("invalid license name", Arg1);
6886 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
6888 when Pragma_Link_With => Link_With : declare
6894 if Operating_Mode = Generate_Code
6895 and then In_Extended_Main_Source_Unit (N)
6897 Check_At_Least_N_Arguments (1);
6898 Check_No_Identifiers;
6899 Check_Is_In_Decl_Part_Or_Package_Spec;
6900 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
6904 while Present (Arg) loop
6905 Check_Arg_Is_Static_Expression (Arg, Standard_String);
6907 -- Store argument, converting sequences of spaces
6908 -- to a single null character (this is one of the
6909 -- differences in processing between Link_With
6910 -- and Linker_Options).
6913 C : constant Char_Code := Get_Char_Code (' ');
6914 S : constant String_Id :=
6915 Strval (Expr_Value_S (Expression (Arg)));
6916 L : constant Nat := String_Length (S);
6919 procedure Skip_Spaces;
6920 -- Advance F past any spaces
6922 procedure Skip_Spaces is
6924 while F <= L and then Get_String_Char (S, F) = C loop
6930 Skip_Spaces; -- skip leading spaces
6932 -- Loop through characters, changing any embedded
6933 -- sequence of spaces to a single null character
6934 -- (this is how Link_With/Linker_Options differ)
6937 if Get_String_Char (S, F) = C then
6940 Store_String_Char (ASCII.NUL);
6943 Store_String_Char (Get_String_Char (S, F));
6951 if Present (Arg) then
6952 Store_String_Char (ASCII.NUL);
6956 Store_Linker_Option_String (End_String);
6964 -- pragma Linker_Alias (
6965 -- [Entity =>] LOCAL_NAME
6966 -- [Alias =>] static_string_EXPRESSION);
6968 when Pragma_Linker_Alias =>
6970 Check_Arg_Count (2);
6971 Check_Optional_Identifier (Arg1, Name_Entity);
6972 Check_Optional_Identifier (Arg2, "alias");
6973 Check_Arg_Is_Library_Level_Local_Name (Arg1);
6974 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
6976 -- The only processing required is to link this item on to the
6977 -- list of rep items for the given entity. This is accomplished
6978 -- by the call to Rep_Item_Too_Late (when no error is detected
6979 -- and False is returned).
6981 if Rep_Item_Too_Late (Entity (Expression (Arg1)), N) then
6984 Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1)));
6987 --------------------
6988 -- Linker_Options --
6989 --------------------
6991 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
6993 when Pragma_Linker_Options => Linker_Options : declare
6997 Check_Ada_83_Warning;
6998 Check_No_Identifiers;
6999 Check_Arg_Count (1);
7000 Check_Is_In_Decl_Part_Or_Package_Spec;
7002 if Operating_Mode = Generate_Code
7003 and then In_Extended_Main_Source_Unit (N)
7005 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
7006 Start_String (Strval (Expr_Value_S (Expression (Arg1))));
7009 while Present (Arg) loop
7010 Check_Arg_Is_Static_Expression (Arg, Standard_String);
7011 Store_String_Char (ASCII.NUL);
7013 (Strval (Expr_Value_S (Expression (Arg))));
7017 Store_Linker_Option_String (End_String);
7021 --------------------
7022 -- Linker_Section --
7023 --------------------
7025 -- pragma Linker_Section (
7026 -- [Entity =>] LOCAL_NAME
7027 -- [Section =>] static_string_EXPRESSION);
7029 when Pragma_Linker_Section =>
7031 Check_Arg_Count (2);
7032 Check_Optional_Identifier (Arg1, Name_Entity);
7033 Check_Optional_Identifier (Arg2, Name_Section);
7034 Check_Arg_Is_Library_Level_Local_Name (Arg1);
7035 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
7037 -- The only processing required is to link this item on to the
7038 -- list of rep items for the given entity. This is accomplished
7039 -- by the call to Rep_Item_Too_Late (when no error is detected
7040 -- and False is returned).
7042 if Rep_Item_Too_Late (Entity (Expression (Arg1)), N) then
7045 Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1)));
7052 -- pragma List (On | Off)
7054 -- There is nothing to do here, since we did all the processing
7055 -- for this pragma in Par.Prag (so that it works properly even in
7056 -- syntax only mode)
7061 --------------------
7062 -- Locking_Policy --
7063 --------------------
7065 -- pragma Locking_Policy (policy_IDENTIFIER);
7067 when Pragma_Locking_Policy => declare
7071 Check_Ada_83_Warning;
7072 Check_Arg_Count (1);
7073 Check_No_Identifiers;
7074 Check_Arg_Is_Locking_Policy (Arg1);
7075 Check_Valid_Configuration_Pragma;
7076 Get_Name_String (Chars (Expression (Arg1)));
7077 LP := Fold_Upper (Name_Buffer (1));
7079 if Locking_Policy /= ' '
7080 and then Locking_Policy /= LP
7082 Error_Msg_Sloc := Locking_Policy_Sloc;
7083 Error_Pragma ("locking policy incompatible with policy#");
7085 -- Set new policy, but always preserve System_Location since
7086 -- we like the error message with the run time name.
7089 Locking_Policy := LP;
7091 if Locking_Policy_Sloc /= System_Location then
7092 Locking_Policy_Sloc := Loc;
7101 -- pragma Long_Float (D_Float | G_Float);
7103 when Pragma_Long_Float =>
7105 Check_Valid_Configuration_Pragma;
7106 Check_Arg_Count (1);
7107 Check_No_Identifier (Arg1);
7108 Check_Arg_Is_One_Of (Arg1, Name_D_Float, Name_G_Float);
7110 if not OpenVMS_On_Target then
7111 Error_Pragma ("?pragma% ignored (applies only to Open'V'M'S)");
7116 if Chars (Expression (Arg1)) = Name_D_Float then
7117 if Opt.Float_Format_Long = 'G' then
7118 Error_Pragma ("G_Float previously specified");
7121 Opt.Float_Format_Long := 'D';
7123 -- G_Float case (this is the default, does not need overriding)
7126 if Opt.Float_Format_Long = 'D' then
7127 Error_Pragma ("D_Float previously specified");
7130 Opt.Float_Format_Long := 'G';
7133 Set_Standard_Fpt_Formats;
7135 -----------------------
7136 -- Machine_Attribute --
7137 -----------------------
7139 -- pragma Machine_Attribute (
7140 -- [Entity =>] LOCAL_NAME,
7141 -- [Attribute_Name =>] static_string_EXPRESSION
7142 -- [,[Info =>] static_string_EXPRESSION] );
7144 when Pragma_Machine_Attribute => Machine_Attribute : declare
7150 if Arg_Count = 3 then
7151 Check_Optional_Identifier (Arg3, "info");
7152 Check_Arg_Is_Static_Expression (Arg3, Standard_String);
7154 Check_Arg_Count (2);
7157 Check_Arg_Is_Local_Name (Arg1);
7158 Check_Optional_Identifier (Arg2, "attribute_name");
7159 Check_Optional_Identifier (Arg1, Name_Entity);
7160 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
7161 Def_Id := Entity (Expression (Arg1));
7163 if Is_Access_Type (Def_Id) then
7164 Def_Id := Designated_Type (Def_Id);
7167 if Rep_Item_Too_Early (Def_Id, N) then
7171 Def_Id := Underlying_Type (Def_Id);
7173 -- The only processing required is to link this item on to the
7174 -- list of rep items for the given entity. This is accomplished
7175 -- by the call to Rep_Item_Too_Late (when no error is detected
7176 -- and False is returned).
7178 if Rep_Item_Too_Late (Def_Id, N) then
7181 Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1)));
7183 end Machine_Attribute;
7189 -- pragma Main_Storage
7190 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
7192 -- MAIN_STORAGE_OPTION ::=
7193 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
7194 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
7196 when Pragma_Main => Main : declare
7197 Args : Args_List (1 .. 3);
7198 Names : constant Name_List (1 .. 3) := (
7200 Name_Task_Stack_Size_Default,
7201 Name_Time_Slicing_Enabled);
7207 Gather_Associations (Names, Args);
7209 for J in 1 .. 2 loop
7210 if Present (Args (J)) then
7211 Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
7215 if Present (Args (3)) then
7216 Check_Arg_Is_Static_Expression (Args (3), Standard_Boolean);
7220 while Present (Nod) loop
7221 if Nkind (Nod) = N_Pragma
7222 and then Chars (Nod) = Name_Main
7224 Error_Msg_Name_1 := Chars (N);
7225 Error_Msg_N ("duplicate pragma% not permitted", Nod);
7236 -- pragma Main_Storage
7237 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
7239 -- MAIN_STORAGE_OPTION ::=
7240 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
7241 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
7243 when Pragma_Main_Storage => Main_Storage : declare
7244 Args : Args_List (1 .. 2);
7245 Names : constant Name_List (1 .. 2) := (
7246 Name_Working_Storage,
7253 Gather_Associations (Names, Args);
7255 for J in 1 .. 2 loop
7256 if Present (Args (J)) then
7257 Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
7261 Check_In_Main_Program;
7264 while Present (Nod) loop
7265 if Nkind (Nod) = N_Pragma
7266 and then Chars (Nod) = Name_Main_Storage
7268 Error_Msg_Name_1 := Chars (N);
7269 Error_Msg_N ("duplicate pragma% not permitted", Nod);
7280 -- pragma Memory_Size (NUMERIC_LITERAL)
7282 when Pragma_Memory_Size =>
7285 -- Memory size is simply ignored
7287 Check_No_Identifiers;
7288 Check_Arg_Count (1);
7289 Check_Arg_Is_Integer_Literal (Arg1);
7295 -- pragma No_Return (procedure_LOCAL_NAME);
7297 when Pragma_No_Return => No_Return : declare
7304 Check_Arg_Count (1);
7305 Check_No_Identifiers;
7306 Check_Arg_Is_Local_Name (Arg1);
7307 Id := Expression (Arg1);
7310 if not Is_Entity_Name (Id) then
7311 Error_Pragma_Arg ("entity name required", Arg1);
7314 if Etype (Id) = Any_Type then
7322 and then Scope (E) = Current_Scope
7324 if Ekind (E) = E_Procedure
7325 or else Ekind (E) = E_Generic_Procedure
7335 Error_Pragma ("no procedures found for pragma%");
7343 -- pragma Obsolescent [(static_string_EXPRESSION)];
7345 when Pragma_Obsolescent => Obsolescent : declare
7348 Check_At_Most_N_Arguments (1);
7349 Check_No_Identifiers;
7351 if Arg_Count = 1 then
7352 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
7356 or else (Nkind (Prev (N))) /= N_Subprogram_Declaration
7359 ("pragma% misplaced, must immediately " &
7360 "follow subprogram spec");
7368 -- pragma No_Run_Time
7370 -- Note: this pragma is retained for backwards compatibiltiy.
7371 -- See body of Rtsfind for full details on its handling.
7373 when Pragma_No_Run_Time =>
7375 Check_Valid_Configuration_Pragma;
7376 Check_Arg_Count (0);
7378 No_Run_Time_Mode := True;
7379 Configurable_Run_Time_Mode := True;
7381 if Ttypes.System_Word_Size = 32 then
7382 Duration_32_Bits_On_Target := True;
7385 Restrictions (No_Finalization) := True;
7386 Restrictions (No_Exception_Handlers) := True;
7387 Restriction_Parameters (Max_Tasks) := Uint_0;
7389 -----------------------
7390 -- Normalize_Scalars --
7391 -----------------------
7393 -- pragma Normalize_Scalars;
7395 when Pragma_Normalize_Scalars =>
7396 Check_Ada_83_Warning;
7397 Check_Arg_Count (0);
7398 Check_Valid_Configuration_Pragma;
7399 Normalize_Scalars := True;
7400 Init_Or_Norm_Scalars := True;
7406 -- pragma Optimize (Time | Space);
7408 -- The actual check for optimize is done in Gigi. Note that this
7409 -- pragma does not actually change the optimization setting, it
7410 -- simply checks that it is consistent with the pragma.
7412 when Pragma_Optimize =>
7413 Check_No_Identifiers;
7414 Check_Arg_Count (1);
7415 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
7417 -------------------------
7418 -- Optional_Overriding --
7419 -------------------------
7421 -- These pragmas are treated as part of the previous subprogram
7422 -- declaration, and analyzed immediately after it (see sem_ch6,
7423 -- Check_Overriding_Operation). If the pragma has not been analyzed
7424 -- yet, it appears in the wrong place.
7426 when Pragma_Optional_Overriding =>
7427 Error_Msg_N ("pragma must appear immediately after subprogram", N);
7433 when Pragma_Overriding =>
7434 Error_Msg_N ("pragma must appear immediately after subprogram", N);
7440 -- pragma Pack (first_subtype_LOCAL_NAME);
7442 when Pragma_Pack => Pack : declare
7443 Assoc : constant Node_Id := Arg1;
7448 Check_No_Identifiers;
7449 Check_Arg_Count (1);
7450 Check_Arg_Is_Local_Name (Arg1);
7452 Type_Id := Expression (Assoc);
7453 Find_Type (Type_Id);
7454 Typ := Entity (Type_Id);
7457 or else Rep_Item_Too_Early (Typ, N)
7461 Typ := Underlying_Type (Typ);
7464 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
7465 Error_Pragma ("pragma% must specify array or record type");
7468 Check_First_Subtype (Arg1);
7470 if Has_Pragma_Pack (Typ) then
7471 Error_Pragma ("duplicate pragma%, only one allowed");
7473 -- Array type. We set the Has_Pragma_Pack flag, and Is_Packed,
7474 -- but not Has_Non_Standard_Rep, because we don't actually know
7475 -- till freeze time if the array can have packed representation.
7476 -- That's because in the general case we do not know enough about
7477 -- the component type until it in turn is frozen, which certainly
7478 -- happens before the array type is frozen, but not necessarily
7479 -- till that point (i.e. right now it may be unfrozen).
7481 elsif Is_Array_Type (Typ) then
7482 if Has_Aliased_Components (Base_Type (Typ)) then
7484 ("pragma% ignored, cannot pack aliased components?");
7486 elsif Has_Atomic_Components (Typ)
7487 or else Is_Atomic (Component_Type (Typ))
7490 ("?pragma% ignored, cannot pack atomic components");
7492 elsif not Rep_Item_Too_Late (Typ, N) then
7493 Set_Is_Packed (Base_Type (Typ));
7494 Set_Has_Pragma_Pack (Base_Type (Typ));
7495 Set_Has_Non_Standard_Rep (Base_Type (Typ));
7498 -- Record type. For record types, the pack is always effective
7500 else pragma Assert (Is_Record_Type (Typ));
7501 if not Rep_Item_Too_Late (Typ, N) then
7502 Set_Has_Pragma_Pack (Base_Type (Typ));
7503 Set_Is_Packed (Base_Type (Typ));
7504 Set_Has_Non_Standard_Rep (Base_Type (Typ));
7515 -- There is nothing to do here, since we did all the processing
7516 -- for this pragma in Par.Prag (so that it works properly even in
7517 -- syntax only mode)
7526 -- pragma Passive [(PASSIVE_FORM)];
7528 -- PASSIVE_FORM ::= Semaphore | No
7530 when Pragma_Passive =>
7533 if Nkind (Parent (N)) /= N_Task_Definition then
7534 Error_Pragma ("pragma% must be within task definition");
7537 if Arg_Count /= 0 then
7538 Check_Arg_Count (1);
7539 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
7546 -- pragma Polling (ON | OFF);
7548 when Pragma_Polling =>
7550 Check_Arg_Count (1);
7551 Check_No_Identifiers;
7552 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
7553 Polling_Required := (Chars (Expression (Arg1)) = Name_On);
7555 ---------------------
7556 -- Persistent_Data --
7557 ---------------------
7559 when Pragma_Persistent_Data => declare
7563 -- Register the pragma as applying to the compilation unit.
7564 -- Individual Persistent_Object pragmas for relevant objects
7565 -- are generated the end of the compilation.
7568 Check_Valid_Configuration_Pragma;
7569 Check_Arg_Count (0);
7570 Ent := Find_Lib_Unit_Name;
7571 Set_Is_Preelaborated (Ent);
7574 ------------------------
7575 -- Persistent_Object --
7576 ------------------------
7578 when Pragma_Persistent_Object => declare
7586 Check_Arg_Count (1);
7587 Check_Arg_Is_Library_Level_Local_Name (Arg1);
7588 if not Is_Entity_Name (Expression (Arg1))
7590 (Ekind (Entity (Expression (Arg1))) /= E_Variable
7591 and then Ekind (Entity (Expression (Arg1))) /= E_Constant)
7593 Error_Pragma_Arg ("pragma only applies to objects", Arg1);
7596 Ent := Entity (Expression (Arg1));
7597 Decl := Parent (Ent);
7599 if Nkind (Decl) /= N_Object_Declaration then
7603 -- Placement of the object depends on whether there is
7604 -- an initial value or none. If the No_Initialization flag
7605 -- is set, the initialization has been transformed into
7606 -- assignments, which is disallowed elaboration code.
7608 if No_Initialization (Decl) then
7610 ("initialization for persistent object"
7611 & "must be static expression", Decl);
7615 if No (Expression (Decl)) then
7617 Store_String_Chars ("section ("".persistent.bss"")");
7621 if not Is_OK_Static_Expression (Expression (Decl)) then
7622 Flag_Non_Static_Expr
7623 ("initialization for persistent object"
7624 & "must be static expression!", Expression (Decl));
7629 Store_String_Chars ("section ("".persistent.data"")");
7636 Name_Machine_Attribute,
7638 (Make_Pragma_Argument_Association
7639 (Sloc => Sloc (Arg1),
7640 Expression => New_Occurrence_Of (Ent, Sloc (Ent))),
7641 Make_Pragma_Argument_Association
7642 (Sloc => Sloc (Arg1),
7645 (Sloc => Sloc (Arg1),
7648 Insert_After (N, MA);
7650 Set_Has_Gigi_Rep_Item (Ent);
7657 -- pragma Preelaborate [(library_unit_NAME)];
7659 -- Set the flag Is_Preelaborated of program unit name entity
7661 when Pragma_Preelaborate => Preelaborate : declare
7662 Pa : constant Node_Id := Parent (N);
7663 Pk : constant Node_Kind := Nkind (Pa);
7667 Check_Ada_83_Warning;
7668 Check_Valid_Library_Unit_Pragma;
7670 if Nkind (N) = N_Null_Statement then
7674 Ent := Find_Lib_Unit_Name;
7676 -- This filters out pragmas inside generic parent then
7677 -- show up inside instantiation
7680 and then not (Pk = N_Package_Specification
7681 and then Present (Generic_Parent (Pa)))
7683 if not Debug_Flag_U then
7684 Set_Is_Preelaborated (Ent);
7685 Set_Suppress_Elaboration_Warnings (Ent);
7694 -- pragma Priority (EXPRESSION);
7696 when Pragma_Priority => Priority : declare
7697 P : constant Node_Id := Parent (N);
7701 Check_No_Identifiers;
7702 Check_Arg_Count (1);
7706 if Nkind (P) = N_Subprogram_Body then
7707 Check_In_Main_Program;
7709 Arg := Expression (Arg1);
7710 Analyze_And_Resolve (Arg, Standard_Integer);
7714 if not Is_Static_Expression (Arg) then
7715 Flag_Non_Static_Expr
7716 ("main subprogram priority is not static!", Arg);
7719 -- If constraint error, then we already signalled an error
7721 elsif Raises_Constraint_Error (Arg) then
7724 -- Otherwise check in range
7728 Val : constant Uint := Expr_Value (Arg);
7732 or else Val > Expr_Value (Expression
7733 (Parent (RTE (RE_Max_Priority))))
7736 ("main subprogram priority is out of range", Arg1);
7742 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
7744 -- Task or Protected, must be of type Integer
7746 elsif Nkind (P) = N_Protected_Definition
7748 Nkind (P) = N_Task_Definition
7750 Arg := Expression (Arg1);
7752 -- The expression must be analyzed in the special manner
7753 -- described in "Handling of Default and Per-Object
7754 -- Expressions" in sem.ads.
7756 Analyze_Per_Use_Expression (Arg, Standard_Integer);
7758 if not Is_Static_Expression (Arg) then
7759 Check_Restriction (Static_Priorities, Arg);
7762 -- Anything else is incorrect
7768 if Has_Priority_Pragma (P) then
7769 Error_Pragma ("duplicate pragma% not allowed");
7771 Set_Has_Priority_Pragma (P, True);
7773 if Nkind (P) = N_Protected_Definition
7775 Nkind (P) = N_Task_Definition
7777 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
7778 -- exp_ch9 should use this ???
7783 --------------------------
7784 -- Propagate_Exceptions --
7785 --------------------------
7787 -- pragma Propagate_Exceptions;
7789 when Pragma_Propagate_Exceptions =>
7791 Check_Arg_Count (0);
7793 if In_Extended_Main_Source_Unit (N) then
7794 Propagate_Exceptions := True;
7801 -- pragma Psect_Object (
7802 -- [Internal =>] LOCAL_NAME,
7803 -- [, [External =>] EXTERNAL_SYMBOL]
7804 -- [, [Size =>] EXTERNAL_SYMBOL]);
7806 when Pragma_Psect_Object | Pragma_Common_Object =>
7807 Psect_Object : declare
7808 Args : Args_List (1 .. 3);
7809 Names : constant Name_List (1 .. 3) := (
7814 Internal : Node_Id renames Args (1);
7815 External : Node_Id renames Args (2);
7816 Size : Node_Id renames Args (3);
7818 R_Internal : Node_Id;
7819 R_External : Node_Id;
7826 procedure Check_Too_Long (Arg : Node_Id);
7827 -- Posts message if the argument is an identifier with more
7828 -- than 31 characters, or a string literal with more than
7829 -- 31 characters, and we are operating under VMS
7831 --------------------
7832 -- Check_Too_Long --
7833 --------------------
7835 procedure Check_Too_Long (Arg : Node_Id) is
7836 X : constant Node_Id := Original_Node (Arg);
7839 if Nkind (X) /= N_String_Literal
7841 Nkind (X) /= N_Identifier
7844 ("inappropriate argument for pragma %", Arg);
7847 if OpenVMS_On_Target then
7848 if (Nkind (X) = N_String_Literal
7849 and then String_Length (Strval (X)) > 31)
7851 (Nkind (X) = N_Identifier
7852 and then Length_Of_Name (Chars (X)) > 31)
7855 ("argument for pragma % is longer than 31 characters",
7861 -- Start of processing for Common_Object/Psect_Object
7865 Gather_Associations (Names, Args);
7866 Process_Extended_Import_Export_Internal_Arg (Internal);
7868 R_Internal := Relocate_Node (Internal);
7870 Def_Id := Entity (R_Internal);
7872 if Ekind (Def_Id) /= E_Constant
7873 and then Ekind (Def_Id) /= E_Variable
7876 ("pragma% must designate an object", Internal);
7879 Check_Too_Long (R_Internal);
7881 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
7883 ("cannot use pragma% for imported/exported object",
7887 if Is_Concurrent_Type (Etype (R_Internal)) then
7889 ("cannot specify pragma % for task/protected object",
7893 if Is_Psected (Def_Id) then
7894 Error_Msg_N ("?duplicate Psect_Object pragma", N);
7896 Set_Is_Psected (Def_Id);
7899 if Ekind (Def_Id) = E_Constant then
7901 ("cannot specify pragma % for a constant", R_Internal);
7904 if Is_Record_Type (Etype (R_Internal)) then
7910 Ent := First_Entity (Etype (R_Internal));
7911 while Present (Ent) loop
7912 Decl := Declaration_Node (Ent);
7914 if Ekind (Ent) = E_Component
7915 and then Nkind (Decl) = N_Component_Declaration
7916 and then Present (Expression (Decl))
7917 and then Warn_On_Export_Import
7920 ("?object for pragma % has defaults", R_Internal);
7930 if Present (Size) then
7931 Check_Too_Long (Size);
7934 -- Make Psect case-insensitive.
7936 if Present (External) then
7937 Check_Too_Long (External);
7939 if Nkind (External) = N_String_Literal then
7940 String_To_Name_Buffer (Strval (External));
7942 Get_Name_String (Chars (External));
7947 Store_String_Chars (Name_Buffer (1 .. Name_Len));
7949 R_External := Make_String_Literal
7950 (Sloc => Sloc (External), Strval => Str);
7952 Get_Name_String (Chars (Internal));
7955 Store_String_Chars (Name_Buffer (1 .. Name_Len));
7957 R_External := Make_String_Literal
7958 (Sloc => Sloc (Internal), Strval => Str);
7961 -- Transform into pragma Linker_Section, add attributes to
7962 -- match what DEC Ada does. Ignore size for now?
7967 Name_Linker_Section,
7969 (Make_Pragma_Argument_Association
7970 (Sloc => Sloc (R_Internal),
7971 Expression => R_Internal),
7972 Make_Pragma_Argument_Association
7973 (Sloc => Sloc (R_External),
7974 Expression => R_External))));
7978 -- Add Machine_Attribute of "overlaid", so the section overlays
7979 -- other sections of the same name.
7982 Store_String_Chars ("overlaid");
7988 Name_Machine_Attribute,
7990 (Make_Pragma_Argument_Association
7991 (Sloc => Sloc (R_Internal),
7992 Expression => R_Internal),
7993 Make_Pragma_Argument_Association
7994 (Sloc => Sloc (R_External),
7997 (Sloc => Sloc (R_External),
8001 -- Add Machine_Attribute of "global", so the section is visible
8005 Store_String_Chars ("global");
8011 Name_Machine_Attribute,
8013 (Make_Pragma_Argument_Association
8014 (Sloc => Sloc (R_Internal),
8015 Expression => R_Internal),
8017 Make_Pragma_Argument_Association
8018 (Sloc => Sloc (R_External),
8021 (Sloc => Sloc (R_External),
8025 -- Add Machine_Attribute of "initialize", so the section is
8029 Store_String_Chars ("initialize");
8035 Name_Machine_Attribute,
8037 (Make_Pragma_Argument_Association
8038 (Sloc => Sloc (R_Internal),
8039 Expression => R_Internal),
8041 Make_Pragma_Argument_Association
8042 (Sloc => Sloc (R_External),
8045 (Sloc => Sloc (R_External),
8054 -- pragma Pure [(library_unit_NAME)];
8056 when Pragma_Pure => Pure : declare
8059 Check_Ada_83_Warning;
8060 Check_Valid_Library_Unit_Pragma;
8062 if Nkind (N) = N_Null_Statement then
8066 Ent := Find_Lib_Unit_Name;
8068 Set_Suppress_Elaboration_Warnings (Ent);
8075 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
8077 when Pragma_Pure_Function => Pure_Function : declare
8084 Check_Arg_Count (1);
8085 Check_Optional_Identifier (Arg1, Name_Entity);
8086 Check_Arg_Is_Local_Name (Arg1);
8087 E_Id := Expression (Arg1);
8089 if Error_Posted (E_Id) then
8093 -- Loop through homonyms (overloadings) of referenced entity
8099 Def_Id := Get_Base_Subprogram (E);
8101 if Ekind (Def_Id) /= E_Function
8102 and then Ekind (Def_Id) /= E_Generic_Function
8103 and then Ekind (Def_Id) /= E_Operator
8106 ("pragma% requires a function name", Arg1);
8109 Set_Is_Pure (Def_Id);
8110 Set_Has_Pragma_Pure_Function (Def_Id);
8113 exit when No (E) or else Scope (E) /= Current_Scope;
8118 --------------------
8119 -- Queuing_Policy --
8120 --------------------
8122 -- pragma Queuing_Policy (policy_IDENTIFIER);
8124 when Pragma_Queuing_Policy => declare
8128 Check_Ada_83_Warning;
8129 Check_Arg_Count (1);
8130 Check_No_Identifiers;
8131 Check_Arg_Is_Queuing_Policy (Arg1);
8132 Check_Valid_Configuration_Pragma;
8133 Get_Name_String (Chars (Expression (Arg1)));
8134 QP := Fold_Upper (Name_Buffer (1));
8136 if Queuing_Policy /= ' '
8137 and then Queuing_Policy /= QP
8139 Error_Msg_Sloc := Queuing_Policy_Sloc;
8140 Error_Pragma ("queuing policy incompatible with policy#");
8142 -- Set new policy, but always preserve System_Location since
8143 -- we like the error message with the run time name.
8146 Queuing_Policy := QP;
8148 if Queuing_Policy_Sloc /= System_Location then
8149 Queuing_Policy_Sloc := Loc;
8154 ---------------------------
8155 -- Remote_Call_Interface --
8156 ---------------------------
8158 -- pragma Remote_Call_Interface [(library_unit_NAME)];
8160 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
8161 Cunit_Node : Node_Id;
8162 Cunit_Ent : Entity_Id;
8166 Check_Ada_83_Warning;
8167 Check_Valid_Library_Unit_Pragma;
8169 if Nkind (N) = N_Null_Statement then
8173 Cunit_Node := Cunit (Current_Sem_Unit);
8174 K := Nkind (Unit (Cunit_Node));
8175 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
8177 if K = N_Package_Declaration
8178 or else K = N_Generic_Package_Declaration
8179 or else K = N_Subprogram_Declaration
8180 or else K = N_Generic_Subprogram_Declaration
8181 or else (K = N_Subprogram_Body
8182 and then Acts_As_Spec (Unit (Cunit_Node)))
8187 "pragma% must apply to package or subprogram declaration");
8190 Set_Is_Remote_Call_Interface (Cunit_Ent);
8191 end Remote_Call_Interface;
8197 -- pragma Remote_Types [(library_unit_NAME)];
8199 when Pragma_Remote_Types => Remote_Types : declare
8200 Cunit_Node : Node_Id;
8201 Cunit_Ent : Entity_Id;
8204 Check_Ada_83_Warning;
8205 Check_Valid_Library_Unit_Pragma;
8207 if Nkind (N) = N_Null_Statement then
8211 Cunit_Node := Cunit (Current_Sem_Unit);
8212 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
8214 if Nkind (Unit (Cunit_Node)) /= N_Package_Declaration
8216 Nkind (Unit (Cunit_Node)) /= N_Generic_Package_Declaration
8219 "pragma% can only apply to a package declaration");
8222 Set_Is_Remote_Types (Cunit_Ent);
8229 -- pragma Ravenscar;
8231 when Pragma_Ravenscar =>
8233 Check_Arg_Count (0);
8234 Check_Valid_Configuration_Pragma;
8237 -------------------------
8238 -- Restricted_Run_Time --
8239 -------------------------
8241 -- pragma Restricted_Run_Time;
8243 when Pragma_Restricted_Run_Time =>
8245 Check_Arg_Count (0);
8246 Check_Valid_Configuration_Pragma;
8247 Set_Restricted_Profile (N);
8253 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
8256 -- restriction_IDENTIFIER
8257 -- | restriction_parameter_IDENTIFIER => EXPRESSION
8259 when Pragma_Restrictions => Restrictions_Pragma : declare
8261 R_Id : Restriction_Id;
8262 RP_Id : Restriction_Parameter_Id;
8268 Check_Ada_83_Warning;
8269 Check_At_Least_N_Arguments (1);
8270 Check_Valid_Configuration_Pragma;
8273 while Present (Arg) loop
8275 Expr := Expression (Arg);
8277 -- Case of no restriction identifier
8279 if Id = No_Name then
8280 if Nkind (Expr) /= N_Identifier then
8282 ("invalid form for restriction", Arg);
8285 R_Id := Get_Restriction_Id (Chars (Expr));
8287 if R_Id = Not_A_Restriction_Id then
8289 ("invalid restriction identifier", Arg);
8291 -- Restriction is active
8294 if Implementation_Restriction (R_Id) then
8296 (No_Implementation_Restrictions, Arg);
8299 Restrictions (R_Id) := True;
8301 -- Set location, but preserve location of system
8302 -- restriction for nice error msg with run time name
8304 if Restrictions_Loc (R_Id) /= System_Location then
8305 Restrictions_Loc (R_Id) := Sloc (N);
8308 -- Record the restriction if we are in the main unit,
8309 -- or in the extended main unit. The reason that we
8310 -- test separately for Main_Unit is that gnat.adc is
8311 -- processed with Current_Sem_Unit = Main_Unit, but
8312 -- nodes in gnat.adc do not appear to be the extended
8313 -- main source unit (they probably should do ???)
8315 if Current_Sem_Unit = Main_Unit
8316 or else In_Extended_Main_Source_Unit (N)
8318 Main_Restrictions (R_Id) := True;
8321 -- A very special case that must be processed here:
8322 -- pragma Restrictions (No_Exceptions) turns off all
8323 -- run-time checking. This is a bit dubious in terms
8324 -- of the formal language definition, but it is what
8325 -- is intended by the wording of RM H.4(12).
8327 if R_Id = No_Exceptions then
8328 Scope_Suppress := (others => True);
8333 -- Case of restriction identifier present
8336 RP_Id := Get_Restriction_Parameter_Id (Id);
8337 Analyze_And_Resolve (Expr, Any_Integer);
8339 if RP_Id = Not_A_Restriction_Parameter_Id then
8341 ("invalid restriction parameter identifier", Arg);
8343 elsif not Is_OK_Static_Expression (Expr) then
8344 Flag_Non_Static_Expr
8345 ("value must be static expression!", Expr);
8348 elsif not Is_Integer_Type (Etype (Expr))
8349 or else Expr_Value (Expr) < 0
8352 ("value must be non-negative integer", Arg);
8354 -- Restriction pragma is active
8357 Val := Expr_Value (Expr);
8359 -- Record pragma if most restrictive so far
8361 if Restriction_Parameters (RP_Id) = No_Uint
8362 or else Val < Restriction_Parameters (RP_Id)
8364 Restriction_Parameters (RP_Id) := Val;
8365 Restriction_Parameters_Loc (RP_Id) := Sloc (N);
8372 end Restrictions_Pragma;
8374 --------------------------
8375 -- Restriction_Warnings --
8376 --------------------------
8378 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
8380 -- RESTRICTION ::= restriction_IDENTIFIER
8382 when Pragma_Restriction_Warnings => Restriction_Warn : declare
8384 R_Id : Restriction_Id;
8389 Check_At_Least_N_Arguments (1);
8390 Check_Valid_Configuration_Pragma;
8391 Check_No_Identifiers;
8394 while Present (Arg) loop
8395 Expr := Expression (Arg);
8397 if Nkind (Expr) /= N_Identifier then
8399 ("invalid form for restriction", Arg);
8402 R_Id := Get_Restriction_Id (Chars (Expr));
8404 if R_Id = Not_A_Restriction_Id then
8406 ("invalid restriction identifier", Arg);
8408 -- Restriction is active
8411 if Implementation_Restriction (R_Id) then
8413 (No_Implementation_Restrictions, Arg);
8416 Restriction_Warnings (R_Id) := True;
8422 end Restriction_Warn;
8428 -- pragma Reviewable;
8430 when Pragma_Reviewable =>
8431 Check_Ada_83_Warning;
8432 Check_Arg_Count (0);
8438 -- pragma Share_Generic (NAME {, NAME});
8440 when Pragma_Share_Generic =>
8442 Process_Generic_List;
8448 -- pragma Shared (LOCAL_NAME);
8450 when Pragma_Shared =>
8452 Process_Atomic_Shared_Volatile;
8454 --------------------
8455 -- Shared_Passive --
8456 --------------------
8458 -- pragma Shared_Passive [(library_unit_NAME)];
8460 -- Set the flag Is_Shared_Passive of program unit name entity
8462 when Pragma_Shared_Passive => Shared_Passive : declare
8463 Cunit_Node : Node_Id;
8464 Cunit_Ent : Entity_Id;
8467 Check_Ada_83_Warning;
8468 Check_Valid_Library_Unit_Pragma;
8470 if Nkind (N) = N_Null_Statement then
8474 Cunit_Node := Cunit (Current_Sem_Unit);
8475 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
8477 if Nkind (Unit (Cunit_Node)) /= N_Package_Declaration
8479 Nkind (Unit (Cunit_Node)) /= N_Generic_Package_Declaration
8482 "pragma% can only apply to a package declaration");
8485 Set_Is_Shared_Passive (Cunit_Ent);
8488 ----------------------
8489 -- Source_File_Name --
8490 ----------------------
8492 -- pragma Source_File_Name (
8493 -- [UNIT_NAME =>] unit_NAME,
8494 -- [BODY_FILE_NAME | SPEC_FILE_NAME] => STRING_LITERAL);
8496 -- No processing here. Processing was completed during parsing,
8497 -- since we need to have file names set as early as possible.
8498 -- Units are loaded well before semantic processing starts.
8500 -- The only processing we defer to this point is the check
8501 -- for correct placement.
8503 when Pragma_Source_File_Name =>
8505 Check_Valid_Configuration_Pragma;
8507 ------------------------------
8508 -- Source_File_Name_Project --
8509 ------------------------------
8511 -- pragma Source_File_Name_Project (
8512 -- [UNIT_NAME =>] unit_NAME,
8513 -- [BODY_FILE_NAME | SPEC_FILE_NAME] => STRING_LITERAL);
8515 -- No processing here. Processing was completed during parsing,
8516 -- since we need to have file names set as early as possible.
8517 -- Units are loaded well before semantic processing starts.
8519 -- The only processing we defer to this point is the check
8520 -- for correct placement.
8522 when Pragma_Source_File_Name_Project =>
8524 Check_Valid_Configuration_Pragma;
8526 -- Check that a pragma Source_File_Name_Project is used only
8527 -- in a configuration pragmas file.
8528 -- Pragmas Source_File_Name_Project should only be generated
8529 -- by the Project Manager in configuration pragmas files.
8531 -- This is really an ugly test. It seems to depend on some
8532 -- accidental and undocumented property. At the very least
8533 -- it needs to be documented, but it would be better to have
8534 -- a clean way of testing if we are in a configuration file???
8536 if Present (Parent (N)) then
8538 ("pragma% can only appear in a configuration pragmas file");
8541 ----------------------
8542 -- Source_Reference --
8543 ----------------------
8545 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
8547 -- Nothing to do, all processing completed in Par.Prag, since we
8548 -- need the information for possible parser messages that are output
8550 when Pragma_Source_Reference =>
8557 -- pragma Storage_Size (EXPRESSION);
8559 when Pragma_Storage_Size => Storage_Size : declare
8560 P : constant Node_Id := Parent (N);
8564 Check_No_Identifiers;
8565 Check_Arg_Count (1);
8567 -- The expression must be analyzed in the special manner
8568 -- described in "Handling of Default Expressions" in sem.ads.
8570 -- Set In_Default_Expression for per-object case ???
8572 Arg := Expression (Arg1);
8573 Analyze_Per_Use_Expression (Arg, Any_Integer);
8575 if not Is_Static_Expression (Arg) then
8576 Check_Restriction (Static_Storage_Size, Arg);
8579 if Nkind (P) /= N_Task_Definition then
8584 if Has_Storage_Size_Pragma (P) then
8585 Error_Pragma ("duplicate pragma% not allowed");
8587 Set_Has_Storage_Size_Pragma (P, True);
8590 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
8591 -- ??? exp_ch9 should use this!
8599 -- pragma Storage_Unit (NUMERIC_LITERAL);
8601 -- Only permitted argument is System'Storage_Unit value
8603 when Pragma_Storage_Unit =>
8604 Check_No_Identifiers;
8605 Check_Arg_Count (1);
8606 Check_Arg_Is_Integer_Literal (Arg1);
8608 if Intval (Expression (Arg1)) /=
8609 UI_From_Int (Ttypes.System_Storage_Unit)
8611 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
8613 ("the only allowed argument for pragma% is ^", Arg1);
8616 --------------------
8617 -- Stream_Convert --
8618 --------------------
8620 -- pragma Stream_Convert (
8621 -- [Entity =>] type_LOCAL_NAME,
8622 -- [Read =>] function_NAME,
8623 -- [Write =>] function NAME);
8625 when Pragma_Stream_Convert => Stream_Convert : declare
8627 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
8628 -- Check that the given argument is the name of a local
8629 -- function of one argument that is not overloaded earlier
8630 -- in the current local scope. A check is also made that the
8631 -- argument is a function with one parameter.
8633 --------------------------------------
8634 -- Check_OK_Stream_Convert_Function --
8635 --------------------------------------
8637 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
8641 Check_Arg_Is_Local_Name (Arg);
8642 Ent := Entity (Expression (Arg));
8644 if Has_Homonym (Ent) then
8646 ("argument for pragma% may not be overloaded", Arg);
8649 if Ekind (Ent) /= E_Function
8650 or else No (First_Formal (Ent))
8651 or else Present (Next_Formal (First_Formal (Ent)))
8654 ("argument for pragma% must be" &
8655 " function of one argument", Arg);
8657 end Check_OK_Stream_Convert_Function;
8659 -- Start of procecessing for Stream_Convert
8663 Check_Arg_Count (3);
8664 Check_Optional_Identifier (Arg1, Name_Entity);
8665 Check_Optional_Identifier (Arg2, Name_Read);
8666 Check_Optional_Identifier (Arg3, Name_Write);
8667 Check_Arg_Is_Local_Name (Arg1);
8668 Check_OK_Stream_Convert_Function (Arg2);
8669 Check_OK_Stream_Convert_Function (Arg3);
8672 Typ : constant Entity_Id :=
8673 Underlying_Type (Entity (Expression (Arg1)));
8674 Read : constant Entity_Id := Entity (Expression (Arg2));
8675 Write : constant Entity_Id := Entity (Expression (Arg3));
8678 if Etype (Typ) = Any_Type
8680 Etype (Read) = Any_Type
8682 Etype (Write) = Any_Type
8687 Check_First_Subtype (Arg1);
8689 if Rep_Item_Too_Early (Typ, N)
8691 Rep_Item_Too_Late (Typ, N)
8696 if Underlying_Type (Etype (Read)) /= Typ then
8698 ("incorrect return type for function&", Arg2);
8701 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
8703 ("incorrect parameter type for function&", Arg3);
8706 if Underlying_Type (Etype (First_Formal (Read))) /=
8707 Underlying_Type (Etype (Write))
8710 ("result type of & does not match Read parameter type",
8716 -------------------------
8717 -- Style_Checks (GNAT) --
8718 -------------------------
8720 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
8722 -- This is processed by the parser since some of the style
8723 -- checks take place during source scanning and parsing. This
8724 -- means that we don't need to issue error messages here.
8726 when Pragma_Style_Checks => Style_Checks : declare
8727 A : constant Node_Id := Expression (Arg1);
8733 Check_No_Identifiers;
8735 -- Two argument form
8737 if Arg_Count = 2 then
8738 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
8745 E_Id := Expression (Arg2);
8748 if not Is_Entity_Name (E_Id) then
8750 ("second argument of pragma% must be entity name",
8760 Set_Suppress_Style_Checks (E,
8761 (Chars (Expression (Arg1)) = Name_Off));
8762 exit when No (Homonym (E));
8768 -- One argument form
8771 Check_Arg_Count (1);
8773 if Nkind (A) = N_String_Literal then
8777 Slen : constant Natural := Natural (String_Length (S));
8778 Options : String (1 .. Slen);
8784 C := Get_String_Char (S, Int (J));
8785 exit when not In_Character_Range (C);
8786 Options (J) := Get_Character (C);
8789 Set_Style_Check_Options (Options);
8797 elsif Nkind (A) = N_Identifier then
8799 if Chars (A) = Name_All_Checks then
8800 Set_Default_Style_Check_Options;
8802 elsif Chars (A) = Name_On then
8803 Style_Check := True;
8805 elsif Chars (A) = Name_Off then
8806 Style_Check := False;
8817 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
8819 when Pragma_Subtitle =>
8821 Check_Arg_Count (1);
8822 Check_Optional_Identifier (Arg1, Name_Subtitle);
8823 Check_Arg_Is_String_Literal (Arg1);
8829 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
8831 when Pragma_Suppress =>
8832 Process_Suppress_Unsuppress (True);
8838 -- pragma Suppress_All;
8840 -- The only check made here is that the pragma appears in the
8841 -- proper place, i.e. following a compilation unit. If indeed
8842 -- it appears in this context, then the parser has already
8843 -- inserted an equivalent pragma Suppress (All_Checks) to get
8844 -- the required effect.
8846 when Pragma_Suppress_All =>
8848 Check_Arg_Count (0);
8850 if Nkind (Parent (N)) /= N_Compilation_Unit_Aux
8851 or else not Is_List_Member (N)
8852 or else List_Containing (N) /= Pragmas_After (Parent (N))
8855 ("misplaced pragma%, must follow compilation unit");
8858 -------------------------
8859 -- Suppress_Debug_Info --
8860 -------------------------
8862 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
8864 when Pragma_Suppress_Debug_Info =>
8866 Check_Arg_Count (1);
8867 Check_Arg_Is_Local_Name (Arg1);
8868 Check_Optional_Identifier (Arg1, Name_Entity);
8869 Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1)));
8871 ----------------------------------
8872 -- Suppress_Exception_Locations --
8873 ----------------------------------
8875 -- pragma Suppress_Exception_Locations;
8877 when Pragma_Suppress_Exception_Locations =>
8879 Check_Arg_Count (0);
8880 Check_Valid_Configuration_Pragma;
8881 Exception_Locations_Suppressed := True;
8883 -----------------------------
8884 -- Suppress_Initialization --
8885 -----------------------------
8887 -- pragma Suppress_Initialization ([Entity =>] type_Name);
8889 when Pragma_Suppress_Initialization => Suppress_Init : declare
8895 Check_Arg_Count (1);
8896 Check_Optional_Identifier (Arg1, Name_Entity);
8897 Check_Arg_Is_Local_Name (Arg1);
8899 E_Id := Expression (Arg1);
8901 if Etype (E_Id) = Any_Type then
8908 if Is_Incomplete_Or_Private_Type (E) then
8909 if No (Full_View (Base_Type (E))) then
8911 ("argument of pragma% cannot be an incomplete type",
8914 Set_Suppress_Init_Proc (Full_View (Base_Type (E)));
8917 Set_Suppress_Init_Proc (Base_Type (E));
8922 ("pragma% requires argument that is a type name", Arg1);
8930 -- pragma System_Name (DIRECT_NAME);
8932 -- Syntax check: one argument, which must be the identifier GNAT
8933 -- or the identifier GCC, no other identifiers are acceptable.
8935 when Pragma_System_Name =>
8936 Check_No_Identifiers;
8937 Check_Arg_Count (1);
8938 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
8940 -----------------------------
8941 -- Task_Dispatching_Policy --
8942 -----------------------------
8944 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
8946 when Pragma_Task_Dispatching_Policy => declare
8950 Check_Ada_83_Warning;
8951 Check_Arg_Count (1);
8952 Check_No_Identifiers;
8953 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
8954 Check_Valid_Configuration_Pragma;
8955 Get_Name_String (Chars (Expression (Arg1)));
8956 DP := Fold_Upper (Name_Buffer (1));
8958 if Task_Dispatching_Policy /= ' '
8959 and then Task_Dispatching_Policy /= DP
8961 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
8963 ("task dispatching policy incompatible with policy#");
8965 -- Set new policy, but always preserve System_Location since
8966 -- we like the error message with the run time name.
8969 Task_Dispatching_Policy := DP;
8971 if Task_Dispatching_Policy_Sloc /= System_Location then
8972 Task_Dispatching_Policy_Sloc := Loc;
8981 -- pragma Task_Info (EXPRESSION);
8983 when Pragma_Task_Info => Task_Info : declare
8984 P : constant Node_Id := Parent (N);
8989 if Nkind (P) /= N_Task_Definition then
8990 Error_Pragma ("pragma% must appear in task definition");
8993 Check_No_Identifiers;
8994 Check_Arg_Count (1);
8996 Analyze_And_Resolve (Expression (Arg1), RTE (RE_Task_Info_Type));
8998 if Etype (Expression (Arg1)) = Any_Type then
9002 if Has_Task_Info_Pragma (P) then
9003 Error_Pragma ("duplicate pragma% not allowed");
9005 Set_Has_Task_Info_Pragma (P, True);
9013 -- pragma Task_Name (string_EXPRESSION);
9015 when Pragma_Task_Name => Task_Name : declare
9016 -- pragma Priority (EXPRESSION);
9018 P : constant Node_Id := Parent (N);
9022 Check_No_Identifiers;
9023 Check_Arg_Count (1);
9025 Arg := Expression (Arg1);
9026 Analyze_And_Resolve (Arg, Standard_String);
9028 if Nkind (P) /= N_Task_Definition then
9032 if Has_Task_Name_Pragma (P) then
9033 Error_Pragma ("duplicate pragma% not allowed");
9035 Set_Has_Task_Name_Pragma (P, True);
9036 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
9044 -- pragma Task_Storage (
9045 -- [Task_Type =>] LOCAL_NAME,
9046 -- [Top_Guard =>] static_integer_EXPRESSION);
9048 when Pragma_Task_Storage => Task_Storage : declare
9049 Args : Args_List (1 .. 2);
9050 Names : constant Name_List (1 .. 2) := (
9054 Task_Type : Node_Id renames Args (1);
9055 Top_Guard : Node_Id renames Args (2);
9061 Gather_Associations (Names, Args);
9063 if No (Task_Type) then
9065 ("missing task_type argument for pragma%");
9068 Check_Arg_Is_Local_Name (Task_Type);
9070 Ent := Entity (Task_Type);
9072 if not Is_Task_Type (Ent) then
9074 ("argument for pragma% must be task type", Task_Type);
9077 if No (Top_Guard) then
9079 ("pragma% takes two arguments", Task_Type);
9081 Check_Arg_Is_Static_Expression (Top_Guard, Any_Integer);
9084 Check_First_Subtype (Task_Type);
9086 if Rep_Item_Too_Late (Ent, N) then
9095 -- pragma Thread_Body
9096 -- ( [Entity =>] LOCAL_NAME
9097 -- [,[Secondary_Stack_Size =>] static_integer_EXPRESSION]);
9099 when Pragma_Thread_Body => Thread_Body : declare
9106 Check_At_Least_N_Arguments (1);
9107 Check_At_Most_N_Arguments (2);
9108 Check_Optional_Identifier (Arg1, Name_Entity);
9109 Check_Arg_Is_Local_Name (Arg1);
9111 Id := Expression (Arg1);
9113 if not Is_Entity_Name (Id)
9114 or else not Is_Subprogram (Entity (Id))
9116 Error_Pragma_Arg ("subprogram name required", Arg1);
9121 -- Go to renamed subprogram if present, since Thread_Body applies
9122 -- to the actual renamed entity, not to the renaming entity.
9124 if Present (Alias (E))
9125 and then Nkind (Parent (Declaration_Node (E))) =
9126 N_Subprogram_Renaming_Declaration
9131 -- Various error checks
9133 if Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body then
9135 ("pragma% requires separate spec and must come before body");
9137 elsif Rep_Item_Too_Early (E, N)
9139 Rep_Item_Too_Late (E, N)
9143 elsif Is_Thread_Body (E) then
9145 ("only one thread body pragma allowed", Arg1);
9147 elsif Present (Homonym (E))
9148 and then Scope (Homonym (E)) = Current_Scope
9151 ("thread body subprogram must not be overloaded", Arg1);
9154 Set_Is_Thread_Body (E);
9156 -- Deal with secondary stack argument
9158 if Arg_Count = 2 then
9159 Check_Optional_Identifier (Arg2, Name_Secondary_Stack_Size);
9160 SS := Expression (Arg2);
9161 Analyze_And_Resolve (SS, Any_Integer);
9169 -- pragma Time_Slice (static_duration_EXPRESSION);
9171 when Pragma_Time_Slice => Time_Slice : declare
9177 Check_Arg_Count (1);
9178 Check_No_Identifiers;
9179 Check_In_Main_Program;
9180 Check_Arg_Is_Static_Expression (Arg1, Standard_Duration);
9182 if not Error_Posted (Arg1) then
9184 while Present (Nod) loop
9185 if Nkind (Nod) = N_Pragma
9186 and then Chars (Nod) = Name_Time_Slice
9188 Error_Msg_Name_1 := Chars (N);
9189 Error_Msg_N ("duplicate pragma% not permitted", Nod);
9196 -- Process only if in main unit
9198 if Get_Source_Unit (Loc) = Main_Unit then
9199 Opt.Time_Slice_Set := True;
9200 Val := Expr_Value_R (Expression (Arg1));
9202 if Val <= Ureal_0 then
9203 Opt.Time_Slice_Value := 0;
9205 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
9206 Opt.Time_Slice_Value := 1_000_000_000;
9209 Opt.Time_Slice_Value :=
9210 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
9219 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
9221 -- TITLING_OPTION ::=
9222 -- [Title =>] STRING_LITERAL
9223 -- | [Subtitle =>] STRING_LITERAL
9225 when Pragma_Title => Title : declare
9226 Args : Args_List (1 .. 2);
9227 Names : constant Name_List (1 .. 2) := (
9233 Gather_Associations (Names, Args);
9235 for J in 1 .. 2 loop
9236 if Present (Args (J)) then
9237 Check_Arg_Is_String_Literal (Args (J));
9242 ---------------------
9243 -- Unchecked_Union --
9244 ---------------------
9246 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
9248 when Pragma_Unchecked_Union => Unchecked_Union : declare
9249 Assoc : constant Node_Id := Arg1;
9250 Type_Id : constant Node_Id := Expression (Assoc);
9261 Check_No_Identifiers;
9262 Check_Arg_Count (1);
9263 Check_Arg_Is_Local_Name (Arg1);
9265 Find_Type (Type_Id);
9266 Typ := Entity (Type_Id);
9269 or else Rep_Item_Too_Early (Typ, N)
9273 Typ := Underlying_Type (Typ);
9276 if Rep_Item_Too_Late (Typ, N) then
9280 Check_First_Subtype (Arg1);
9282 -- Note remaining cases are references to a type in the current
9283 -- declarative part. If we find an error, we post the error on
9284 -- the relevant type declaration at an appropriate point.
9286 if not Is_Record_Type (Typ) then
9287 Error_Msg_N ("Unchecked_Union must be record type", Typ);
9290 elsif Is_Tagged_Type (Typ) then
9291 Error_Msg_N ("Unchecked_Union must not be tagged", Typ);
9294 elsif Is_Limited_Type (Typ) then
9296 ("Unchecked_Union must not be limited record type", Typ);
9297 Explain_Limited_Type (Typ, Typ);
9301 if not Has_Discriminants (Typ) then
9303 ("Unchecked_Union must have one discriminant", Typ);
9307 Discr := First_Discriminant (Typ);
9309 if Present (Next_Discriminant (Discr)) then
9311 ("Unchecked_Union must have exactly one discriminant",
9312 Next_Discriminant (Discr));
9316 if No (Discriminant_Default_Value (Discr)) then
9318 ("Unchecked_Union discriminant must have default value",
9322 Tdef := Type_Definition (Declaration_Node (Typ));
9323 Clist := Component_List (Tdef);
9325 if No (Clist) or else No (Variant_Part (Clist)) then
9327 ("Unchecked_Union must have variant part",
9332 Vpart := Variant_Part (Clist);
9334 if Is_Non_Empty_List (Component_Items (Clist)) then
9336 ("components before variant not allowed " &
9337 "in Unchecked_Union",
9338 First (Component_Items (Clist)));
9341 Variant := First (Variants (Vpart));
9342 while Present (Variant) loop
9343 Clist := Component_List (Variant);
9345 if Present (Variant_Part (Clist)) then
9347 ("Unchecked_Union may not have nested variants",
9348 Variant_Part (Clist));
9351 if not Is_Non_Empty_List (Component_Items (Clist)) then
9353 ("Unchecked_Union may not have empty component list",
9358 Comp := First (Component_Items (Clist));
9360 if Nkind (Comp) = N_Component_Declaration then
9362 if Present (Expression (Comp)) then
9364 ("default initialization not allowed " &
9365 "in Unchecked_Union",
9370 Sindic : constant Node_Id :=
9371 Subtype_Indication (Comp);
9374 if Nkind (Sindic) = N_Subtype_Indication then
9375 Check_Static_Constraint (Constraint (Sindic));
9380 if Present (Next (Comp)) then
9382 ("Unchecked_Union variant can have only one component",
9390 Set_Is_Unchecked_Union (Typ, True);
9391 Set_Convention (Typ, Convention_C);
9393 Set_Has_Unchecked_Union (Base_Type (Typ), True);
9394 Set_Is_Unchecked_Union (Base_Type (Typ), True);
9395 end Unchecked_Union;
9397 ------------------------
9398 -- Unimplemented_Unit --
9399 ------------------------
9401 -- pragma Unimplemented_Unit;
9403 -- Note: this only gives an error if we are generating code,
9404 -- or if we are in a generic library unit (where the pragma
9405 -- appears in the body, not in the spec).
9407 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
9408 Cunitent : constant Entity_Id :=
9409 Cunit_Entity (Get_Source_Unit (Loc));
9410 Ent_Kind : constant Entity_Kind :=
9415 Check_Arg_Count (0);
9417 if Operating_Mode = Generate_Code
9418 or else Ent_Kind = E_Generic_Function
9419 or else Ent_Kind = E_Generic_Procedure
9420 or else Ent_Kind = E_Generic_Package
9422 Get_Name_String (Chars (Cunitent));
9423 Set_Casing (Mixed_Case);
9424 Write_Str (Name_Buffer (1 .. Name_Len));
9425 Write_Str (" is not implemented");
9427 raise Unrecoverable_Error;
9429 end Unimplemented_Unit;
9431 --------------------
9432 -- Universal_Data --
9433 --------------------
9435 -- pragma Universal_Data [(library_unit_NAME)];
9437 when Pragma_Universal_Data =>
9440 -- If this is a configuration pragma, then set the universal
9441 -- addressing option, otherwise confirm that the pragma
9442 -- satisfies the requirements of library unit pragma placement
9443 -- and leave it to the GNAAMP back end to detect the pragma
9444 -- (avoids transitive setting of the option due to withed units).
9446 if Is_Configuration_Pragma then
9447 Universal_Addressing_On_AAMP := True;
9449 Check_Valid_Library_Unit_Pragma;
9452 if not AAMP_On_Target then
9453 Error_Pragma ("?pragma% ignored (applies only to AAMP)");
9460 -- pragma Unreferenced (local_Name {, local_Name});
9462 when Pragma_Unreferenced => Unreferenced : declare
9465 Arg_Ent : Entity_Id;
9469 Check_At_Least_N_Arguments (1);
9473 while Present (Arg_Node) loop
9474 Check_No_Identifier (Arg_Node);
9476 -- Note that the analyze call done by Check_Arg_Is_Local_Name
9477 -- will in fact generate a reference, so that the entity will
9478 -- have a reference, which will inhibit any warnings about it
9479 -- not being referenced, and also properly show up in the ali
9480 -- file as a reference. But this reference is recorded before
9481 -- the Has_Pragma_Unreferenced flag is set, so that no warning
9482 -- is generated for this reference.
9484 Check_Arg_Is_Local_Name (Arg_Node);
9485 Arg_Expr := Get_Pragma_Arg (Arg_Node);
9487 if Is_Entity_Name (Arg_Expr) then
9488 Arg_Ent := Entity (Arg_Expr);
9490 -- If the entity is overloaded, the pragma applies to the
9491 -- most recent overloading, as documented. In this case,
9492 -- name resolution does not generate a reference, so it
9493 -- must be done here explicitly.
9495 if Is_Overloaded (Arg_Expr) then
9496 Generate_Reference (Arg_Ent, N);
9499 Set_Has_Pragma_Unreferenced (Arg_Ent);
9506 ------------------------------
9507 -- Unreserve_All_Interrupts --
9508 ------------------------------
9510 -- pragma Unreserve_All_Interrupts;
9512 when Pragma_Unreserve_All_Interrupts =>
9514 Check_Arg_Count (0);
9516 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
9517 Unreserve_All_Interrupts := True;
9524 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
9526 when Pragma_Unsuppress =>
9528 Process_Suppress_Unsuppress (False);
9534 -- pragma Use_VADS_Size;
9536 when Pragma_Use_VADS_Size =>
9538 Check_Arg_Count (0);
9539 Check_Valid_Configuration_Pragma;
9540 Use_VADS_Size := True;
9542 ---------------------
9543 -- Validity_Checks --
9544 ---------------------
9546 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
9548 when Pragma_Validity_Checks => Validity_Checks : declare
9549 A : constant Node_Id := Expression (Arg1);
9555 Check_Arg_Count (1);
9556 Check_No_Identifiers;
9558 if Nkind (A) = N_String_Literal then
9562 Slen : constant Natural := Natural (String_Length (S));
9563 Options : String (1 .. Slen);
9569 C := Get_String_Char (S, Int (J));
9570 exit when not In_Character_Range (C);
9571 Options (J) := Get_Character (C);
9574 Set_Validity_Check_Options (Options);
9582 elsif Nkind (A) = N_Identifier then
9584 if Chars (A) = Name_All_Checks then
9585 Set_Validity_Check_Options ("a");
9587 elsif Chars (A) = Name_On then
9588 Validity_Checks_On := True;
9590 elsif Chars (A) = Name_Off then
9591 Validity_Checks_On := False;
9595 end Validity_Checks;
9601 -- pragma Volatile (LOCAL_NAME);
9603 when Pragma_Volatile =>
9604 Process_Atomic_Shared_Volatile;
9606 -------------------------
9607 -- Volatile_Components --
9608 -------------------------
9610 -- pragma Volatile_Components (array_LOCAL_NAME);
9612 -- Volatile is handled by the same circuit as Atomic_Components
9618 -- pragma Warnings (On | Off, [LOCAL_NAME])
9620 when Pragma_Warnings => Warnings : begin
9622 Check_At_Least_N_Arguments (1);
9623 Check_At_Most_N_Arguments (2);
9624 Check_No_Identifiers;
9626 -- One argument case was processed by parser in Par.Prag
9628 if Arg_Count /= 1 then
9629 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
9630 Check_Arg_Count (2);
9637 E_Id := Expression (Arg2);
9640 -- In the expansion of an inlined body, a reference to
9641 -- the formal may be wrapped in a conversion if the actual
9642 -- is a conversion. Retrieve the real entity name.
9645 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
9647 E_Id := Expression (E_Id);
9650 if not Is_Entity_Name (E_Id) then
9652 ("second argument of pragma% must be entity name",
9662 Set_Warnings_Off (E,
9663 (Chars (Expression (Arg1)) = Name_Off));
9665 if Is_Enumeration_Type (E) then
9667 Lit : Entity_Id := First_Literal (E);
9670 while Present (Lit) loop
9671 Set_Warnings_Off (Lit);
9677 exit when No (Homonym (E));
9689 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
9691 when Pragma_Weak_External => Weak_External : declare
9696 Check_Arg_Count (1);
9697 Check_Optional_Identifier (Arg1, Name_Entity);
9698 Check_Arg_Is_Library_Level_Local_Name (Arg1);
9699 Ent := Entity (Expression (Arg1));
9701 if Rep_Item_Too_Early (Ent, N) then
9704 Ent := Underlying_Type (Ent);
9707 -- The only processing required is to link this item on to the
9708 -- list of rep items for the given entity. This is accomplished
9709 -- by the call to Rep_Item_Too_Late (when no error is detected
9710 -- and False is returned).
9712 if Rep_Item_Too_Late (Ent, N) then
9715 Set_Has_Gigi_Rep_Item (Ent);
9719 --------------------
9720 -- Unknown_Pragma --
9721 --------------------
9723 -- Should be impossible, since the case of an unknown pragma is
9724 -- separately processed before the case statement is entered.
9726 when Unknown_Pragma =>
9727 raise Program_Error;
9732 when Pragma_Exit => null;
9735 ---------------------------------
9736 -- Delay_Config_Pragma_Analyze --
9737 ---------------------------------
9739 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
9741 return Chars (N) = Name_Interrupt_State;
9742 end Delay_Config_Pragma_Analyze;
9744 -------------------------
9745 -- Get_Base_Subprogram --
9746 -------------------------
9748 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
9754 -- Follow subprogram renaming chain
9756 while Is_Subprogram (Result)
9758 (Is_Generic_Instance (Result)
9759 or else Nkind (Parent (Declaration_Node (Result))) =
9760 N_Subprogram_Renaming_Declaration)
9761 and then Present (Alias (Result))
9763 Result := Alias (Result);
9767 end Get_Base_Subprogram;
9769 -----------------------------------------
9770 -- Is_Non_Significant_Pragma_Reference --
9771 -----------------------------------------
9773 -- This function makes use of the following static table which indicates
9774 -- whether a given pragma is significant. A value of -1 in this table
9775 -- indicates that the reference is significant. A value of zero indicates
9776 -- than appearence as any argument is insignificant, a positive value
9777 -- indicates that appearence in that parameter position is significant.
9779 Sig_Flags : array (Pragma_Id) of Int :=
9780 (Pragma_AST_Entry => -1,
9781 Pragma_Abort_Defer => -1,
9782 Pragma_Ada_83 => -1,
9783 Pragma_Ada_95 => -1,
9784 Pragma_All_Calls_Remote => -1,
9785 Pragma_Annotate => -1,
9786 Pragma_Assert => -1,
9787 Pragma_Asynchronous => -1,
9789 Pragma_Atomic_Components => 0,
9790 Pragma_Attach_Handler => -1,
9791 Pragma_CPP_Class => 0,
9792 Pragma_CPP_Constructor => 0,
9793 Pragma_CPP_Virtual => 0,
9794 Pragma_CPP_Vtable => 0,
9795 Pragma_C_Pass_By_Copy => 0,
9796 Pragma_Comment => 0,
9797 Pragma_Common_Object => -1,
9798 Pragma_Compile_Time_Warning => -1,
9799 Pragma_Complex_Representation => 0,
9800 Pragma_Component_Alignment => -1,
9801 Pragma_Controlled => 0,
9802 Pragma_Convention => 0,
9803 Pragma_Convention_Identifier => 0,
9805 Pragma_Discard_Names => 0,
9806 Pragma_Elaborate => -1,
9807 Pragma_Elaborate_All => -1,
9808 Pragma_Elaborate_Body => -1,
9809 Pragma_Elaboration_Checks => -1,
9810 Pragma_Eliminate => -1,
9811 Pragma_Explicit_Overriding => -1,
9812 Pragma_Export => -1,
9813 Pragma_Export_Exception => -1,
9814 Pragma_Export_Function => -1,
9815 Pragma_Export_Object => -1,
9816 Pragma_Export_Procedure => -1,
9817 Pragma_Export_Value => -1,
9818 Pragma_Export_Valued_Procedure => -1,
9819 Pragma_Extend_System => -1,
9820 Pragma_Extensions_Allowed => -1,
9821 Pragma_External => -1,
9822 Pragma_External_Name_Casing => -1,
9823 Pragma_Finalize_Storage_Only => 0,
9824 Pragma_Float_Representation => 0,
9826 Pragma_Import => +2,
9827 Pragma_Import_Exception => 0,
9828 Pragma_Import_Function => 0,
9829 Pragma_Import_Object => 0,
9830 Pragma_Import_Procedure => 0,
9831 Pragma_Import_Valued_Procedure => 0,
9832 Pragma_Initialize_Scalars => -1,
9834 Pragma_Inline_Always => 0,
9835 Pragma_Inline_Generic => 0,
9836 Pragma_Inspection_Point => -1,
9837 Pragma_Interface => +2,
9838 Pragma_Interface_Name => +2,
9839 Pragma_Interrupt_Handler => -1,
9840 Pragma_Interrupt_Priority => -1,
9841 Pragma_Interrupt_State => -1,
9842 Pragma_Java_Constructor => -1,
9843 Pragma_Java_Interface => -1,
9844 Pragma_Keep_Names => 0,
9845 Pragma_License => -1,
9846 Pragma_Link_With => -1,
9847 Pragma_Linker_Alias => -1,
9848 Pragma_Linker_Options => -1,
9849 Pragma_Linker_Section => -1,
9851 Pragma_Locking_Policy => -1,
9852 Pragma_Long_Float => -1,
9853 Pragma_Machine_Attribute => -1,
9855 Pragma_Main_Storage => -1,
9856 Pragma_Memory_Size => -1,
9857 Pragma_No_Return => 0,
9858 Pragma_No_Run_Time => -1,
9859 Pragma_Normalize_Scalars => -1,
9860 Pragma_Obsolescent => 0,
9861 Pragma_Optimize => -1,
9862 Pragma_Optional_Overriding => -1,
9863 Pragma_Overriding => -1,
9866 Pragma_Passive => -1,
9867 Pragma_Polling => -1,
9868 Pragma_Persistent_Data => -1,
9869 Pragma_Persistent_Object => -1,
9870 Pragma_Preelaborate => -1,
9871 Pragma_Priority => -1,
9872 Pragma_Propagate_Exceptions => -1,
9873 Pragma_Psect_Object => -1,
9875 Pragma_Pure_Function => 0,
9876 Pragma_Queuing_Policy => -1,
9877 Pragma_Ravenscar => -1,
9878 Pragma_Remote_Call_Interface => -1,
9879 Pragma_Remote_Types => -1,
9880 Pragma_Restricted_Run_Time => -1,
9881 Pragma_Restriction_Warnings => -1,
9882 Pragma_Restrictions => -1,
9883 Pragma_Reviewable => -1,
9884 Pragma_Share_Generic => -1,
9885 Pragma_Shared => -1,
9886 Pragma_Shared_Passive => -1,
9887 Pragma_Source_File_Name => -1,
9888 Pragma_Source_File_Name_Project => -1,
9889 Pragma_Source_Reference => -1,
9890 Pragma_Storage_Size => -1,
9891 Pragma_Storage_Unit => -1,
9892 Pragma_Stream_Convert => -1,
9893 Pragma_Style_Checks => -1,
9894 Pragma_Subtitle => -1,
9895 Pragma_Suppress => 0,
9896 Pragma_Suppress_Exception_Locations => 0,
9897 Pragma_Suppress_All => -1,
9898 Pragma_Suppress_Debug_Info => 0,
9899 Pragma_Suppress_Initialization => 0,
9900 Pragma_System_Name => -1,
9901 Pragma_Task_Dispatching_Policy => -1,
9902 Pragma_Task_Info => -1,
9903 Pragma_Task_Name => -1,
9904 Pragma_Task_Storage => 0,
9905 Pragma_Thread_Body => +2,
9906 Pragma_Time_Slice => -1,
9908 Pragma_Unchecked_Union => -1,
9909 Pragma_Unimplemented_Unit => -1,
9910 Pragma_Universal_Data => -1,
9911 Pragma_Unreferenced => -1,
9912 Pragma_Unreserve_All_Interrupts => -1,
9913 Pragma_Unsuppress => 0,
9914 Pragma_Use_VADS_Size => -1,
9915 Pragma_Validity_Checks => -1,
9916 Pragma_Volatile => 0,
9917 Pragma_Volatile_Components => 0,
9918 Pragma_Warnings => -1,
9919 Pragma_Weak_External => 0,
9920 Unknown_Pragma => 0);
9922 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
9930 if Nkind (P) /= N_Pragma_Argument_Association then
9934 C := Sig_Flags (Get_Pragma_Id (Chars (Parent (P))));
9944 A := First (Pragma_Argument_Associations (Parent (P)));
9945 for J in 1 .. C - 1 loop
9956 end Is_Non_Significant_Pragma_Reference;
9958 ------------------------------
9959 -- Is_Pragma_String_Literal --
9960 ------------------------------
9962 -- This function returns true if the corresponding pragma argument is
9963 -- a static string expression. These are the only cases in which string
9964 -- literals can appear as pragma arguments. We also allow a string
9965 -- literal as the first argument to pragma Assert (although it will
9966 -- of course always generate a type error).
9968 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
9969 Pragn : constant Node_Id := Parent (Par);
9970 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
9971 Pname : constant Name_Id := Chars (Pragn);
9984 if Pname = Name_Assert then
9987 elsif Pname = Name_Export then
9990 elsif Pname = Name_Ident then
9993 elsif Pname = Name_Import then
9996 elsif Pname = Name_Interface_Name then
9999 elsif Pname = Name_Linker_Alias then
10002 elsif Pname = Name_Linker_Section then
10005 elsif Pname = Name_Machine_Attribute then
10008 elsif Pname = Name_Source_File_Name then
10011 elsif Pname = Name_Source_Reference then
10014 elsif Pname = Name_Title then
10017 elsif Pname = Name_Subtitle then
10023 end Is_Pragma_String_Literal;
10025 --------------------------------------
10026 -- Process_Compilation_Unit_Pragmas --
10027 --------------------------------------
10029 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
10031 -- A special check for pragma Suppress_All. This is a strange DEC
10032 -- pragma, strange because it comes at the end of the unit. If we
10033 -- have a pragma Suppress_All in the Pragmas_After of the current
10034 -- unit, then we insert a pragma Suppress (All_Checks) at the start
10035 -- of the context clause to ensure the correct processing.
10038 PA : constant List_Id := Pragmas_After (Aux_Decls_Node (N));
10042 if Present (PA) then
10044 while Present (P) loop
10045 if Chars (P) = Name_Suppress_All then
10046 Prepend_To (Context_Items (N),
10047 Make_Pragma (Sloc (P),
10048 Chars => Name_Suppress,
10049 Pragma_Argument_Associations => New_List (
10050 Make_Pragma_Argument_Association (Sloc (P),
10052 Make_Identifier (Sloc (P),
10053 Chars => Name_All_Checks)))));
10061 end Process_Compilation_Unit_Pragmas;
10063 --------------------------------
10064 -- Set_Encoded_Interface_Name --
10065 --------------------------------
10067 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
10068 Str : constant String_Id := Strval (S);
10069 Len : constant Int := String_Length (Str);
10074 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
10077 -- Stores encoded value of character code CC. The encoding we
10078 -- use an underscore followed by four lower case hex digits.
10080 procedure Encode is
10082 Store_String_Char (Get_Char_Code ('_'));
10084 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
10086 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
10088 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
10090 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
10093 -- Start of processing for Set_Encoded_Interface_Name
10096 -- If first character is asterisk, this is a link name, and we
10097 -- leave it completely unmodified. We also ignore null strings
10098 -- (the latter case happens only in error cases) and no encoding
10099 -- should occur for Java interface names.
10102 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
10105 Set_Interface_Name (E, S);
10110 CC := Get_String_Char (Str, J);
10112 exit when not In_Character_Range (CC);
10114 C := Get_Character (CC);
10116 exit when C /= '_' and then C /= '$'
10117 and then C not in '0' .. '9'
10118 and then C not in 'a' .. 'z'
10119 and then C not in 'A' .. 'Z';
10122 Set_Interface_Name (E, S);
10130 -- Here we need to encode. The encoding we use as follows:
10131 -- three underscores + four hex digits (lower case)
10135 for J in 1 .. String_Length (Str) loop
10136 CC := Get_String_Char (Str, J);
10138 if not In_Character_Range (CC) then
10141 C := Get_Character (CC);
10143 if C = '_' or else C = '$'
10144 or else C in '0' .. '9'
10145 or else C in 'a' .. 'z'
10146 or else C in 'A' .. 'Z'
10148 Store_String_Char (CC);
10155 Set_Interface_Name (E,
10156 Make_String_Literal (Sloc (S),
10157 Strval => End_String));
10159 end Set_Encoded_Interface_Name;
10161 -------------------
10162 -- Set_Unit_Name --
10163 -------------------
10165 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id) is
10170 if Nkind (N) = N_Identifier
10171 and then Nkind (With_Item) = N_Identifier
10173 Set_Entity (N, Entity (With_Item));
10175 elsif Nkind (N) = N_Selected_Component then
10176 Change_Selected_Component_To_Expanded_Name (N);
10177 Set_Entity (N, Entity (With_Item));
10178 Set_Entity (Selector_Name (N), Entity (N));
10180 Pref := Prefix (N);
10181 Scop := Scope (Entity (N));
10183 while Nkind (Pref) = N_Selected_Component loop
10184 Change_Selected_Component_To_Expanded_Name (Pref);
10185 Set_Entity (Selector_Name (Pref), Scop);
10186 Set_Entity (Pref, Scop);
10187 Pref := Prefix (Pref);
10188 Scop := Scope (Scop);
10191 Set_Entity (Pref, Scop);