1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, 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 3, 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This unit contains the semantic processing for all pragmas, both language
27 -- and implementation defined. For most pragmas, the parser only does the
28 -- most basic job of checking the syntax, so Sem_Prag also contains the code
29 -- to complete the syntax checks. Certain pragmas are handled partially or
30 -- completely by the parser (see Par.Prag for further details).
32 with Atree; use Atree;
33 with Casing; use Casing;
34 with Checks; use Checks;
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 Exp_Dist; use Exp_Dist;
42 with Lib.Writ; use Lib.Writ;
43 with Lib.Xref; use Lib.Xref;
44 with Namet.Sp; use Namet.Sp;
45 with Nlists; use Nlists;
46 with Nmake; use Nmake;
48 with Output; use Output;
49 with Par_SCO; use Par_SCO;
50 with Restrict; use Restrict;
51 with Rident; use Rident;
52 with Rtsfind; use Rtsfind;
54 with Sem_Aux; use Sem_Aux;
55 with Sem_Ch3; use Sem_Ch3;
56 with Sem_Ch6; use Sem_Ch6;
57 with Sem_Ch8; use Sem_Ch8;
58 with Sem_Ch12; use Sem_Ch12;
59 with Sem_Ch13; use Sem_Ch13;
60 with Sem_Dist; use Sem_Dist;
61 with Sem_Elim; use Sem_Elim;
62 with Sem_Eval; use Sem_Eval;
63 with Sem_Intr; use Sem_Intr;
64 with Sem_Mech; use Sem_Mech;
65 with Sem_Res; use Sem_Res;
66 with Sem_Type; use Sem_Type;
67 with Sem_Util; use Sem_Util;
68 with Sem_VFpt; use Sem_VFpt;
69 with Sem_Warn; use Sem_Warn;
70 with Stand; use Stand;
71 with Sinfo; use Sinfo;
72 with Sinfo.CN; use Sinfo.CN;
73 with Sinput; use Sinput;
74 with Snames; use Snames;
75 with Stringt; use Stringt;
76 with Stylesw; use Stylesw;
78 with Targparm; use Targparm;
79 with Tbuild; use Tbuild;
81 with Uintp; use Uintp;
82 with Uname; use Uname;
83 with Urealp; use Urealp;
84 with Validsw; use Validsw;
86 package body Sem_Prag is
88 ----------------------------------------------
89 -- Common Handling of Import-Export Pragmas --
90 ----------------------------------------------
92 -- In the following section, a number of Import_xxx and Export_xxx
93 -- pragmas are defined by GNAT. These are compatible with the DEC
94 -- pragmas of the same name, and all have the following common
95 -- form and processing:
98 -- [Internal =>] LOCAL_NAME
99 -- [, [External =>] EXTERNAL_SYMBOL]
100 -- [, other optional parameters ]);
103 -- [Internal =>] LOCAL_NAME
104 -- [, [External =>] EXTERNAL_SYMBOL]
105 -- [, other optional parameters ]);
107 -- EXTERNAL_SYMBOL ::=
109 -- | static_string_EXPRESSION
111 -- The internal LOCAL_NAME designates the entity that is imported or
112 -- exported, and must refer to an entity in the current declarative
113 -- part (as required by the rules for LOCAL_NAME).
115 -- The external linker name is designated by the External parameter if
116 -- given, or the Internal parameter if not (if there is no External
117 -- parameter, the External parameter is a copy of the Internal name).
119 -- If the External parameter is given as a string, then this string is
120 -- treated as an external name (exactly as though it had been given as an
121 -- External_Name parameter for a normal Import pragma).
123 -- If the External parameter is given as an identifier (or there is no
124 -- External parameter, so that the Internal identifier is used), then
125 -- the external name is the characters of the identifier, translated
126 -- to all upper case letters for OpenVMS versions of GNAT, and to all
127 -- lower case letters for all other versions
129 -- Note: the external name specified or implied by any of these special
130 -- Import_xxx or Export_xxx pragmas override an external or link name
131 -- specified in a previous Import or Export pragma.
133 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
134 -- named notation, following the standard rules for subprogram calls, i.e.
135 -- parameters can be given in any order if named notation is used, and
136 -- positional and named notation can be mixed, subject to the rule that all
137 -- positional parameters must appear first.
139 -- Note: All these pragmas are implemented exactly following the DEC design
140 -- and implementation and are intended to be fully compatible with the use
141 -- of these pragmas in the DEC Ada compiler.
143 --------------------------------------------
144 -- Checking for Duplicated External Names --
145 --------------------------------------------
147 -- It is suspicious if two separate Export pragmas use the same external
148 -- name. The following table is used to diagnose this situation so that
149 -- an appropriate warning can be issued.
151 -- The Node_Id stored is for the N_String_Literal node created to hold
152 -- the value of the external name. The Sloc of this node is used to
153 -- cross-reference the location of the duplication.
155 package Externals is new Table.Table (
156 Table_Component_Type => Node_Id,
157 Table_Index_Type => Int,
158 Table_Low_Bound => 0,
159 Table_Initial => 100,
160 Table_Increment => 100,
161 Table_Name => "Name_Externals");
163 -------------------------------------
164 -- Local Subprograms and Variables --
165 -------------------------------------
167 function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
168 -- This routine is used for possible casing adjustment of an explicit
169 -- external name supplied as a string literal (the node N), according to
170 -- the casing requirement of Opt.External_Name_Casing. If this is set to
171 -- As_Is, then the string literal is returned unchanged, but if it is set
172 -- to Uppercase or Lowercase, then a new string literal with appropriate
173 -- casing is constructed.
175 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
176 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
177 -- original one, following the renaming chain) is returned. Otherwise the
178 -- entity is returned unchanged. Should be in Einfo???
180 function Get_Pragma_Arg (Arg : Node_Id) return Node_Id;
181 -- All the routines that check pragma arguments take either a pragma
182 -- argument association (in which case the expression of the argument
183 -- association is checked), or the expression directly. The function
184 -- Get_Pragma_Arg is a utility used to deal with these two cases. If Arg
185 -- is a pragma argument association node, then its expression is returned,
186 -- otherwise Arg is returned unchanged.
189 -- This is a dummy function called by the processing for pragma Reviewable.
190 -- It is there for assisting front end debugging. By placing a Reviewable
191 -- pragma in the source program, a breakpoint on rv catches this place in
192 -- the source, allowing convenient stepping to the point of interest.
194 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id);
195 -- Place semantic information on the argument of an Elaborate/Elaborate_All
196 -- pragma. Entity name for unit and its parents is taken from item in
197 -- previous with_clause that mentions the unit.
199 -------------------------------
200 -- Adjust_External_Name_Case --
201 -------------------------------
203 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
207 -- Adjust case of literal if required
209 if Opt.External_Name_Exp_Casing = As_Is then
213 -- Copy existing string
219 for J in 1 .. String_Length (Strval (N)) loop
220 CC := Get_String_Char (Strval (N), J);
222 if Opt.External_Name_Exp_Casing = Uppercase
223 and then CC >= Get_Char_Code ('a')
224 and then CC <= Get_Char_Code ('z')
226 Store_String_Char (CC - 32);
228 elsif Opt.External_Name_Exp_Casing = Lowercase
229 and then CC >= Get_Char_Code ('A')
230 and then CC <= Get_Char_Code ('Z')
232 Store_String_Char (CC + 32);
235 Store_String_Char (CC);
240 Make_String_Literal (Sloc (N),
241 Strval => End_String);
243 end Adjust_External_Name_Case;
245 ------------------------------
246 -- Analyze_PPC_In_Decl_Part --
247 ------------------------------
249 procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id) is
250 Arg1 : constant Node_Id :=
251 First (Pragma_Argument_Associations (N));
252 Arg2 : constant Node_Id := Next (Arg1);
255 -- Install formals and push subprogram spec onto scope stack so that we
256 -- can see the formals from the pragma.
261 -- Preanalyze the boolean expression, we treat this as a spec expression
262 -- (i.e. similar to a default expression).
264 Preanalyze_Spec_Expression
265 (Get_Pragma_Arg (Arg1), Standard_Boolean);
267 -- If there is a message argument, analyze it the same way
269 if Present (Arg2) then
270 Preanalyze_Spec_Expression
271 (Get_Pragma_Arg (Arg2), Standard_String);
274 -- Remove the subprogram from the scope stack now that the pre-analysis
275 -- of the precondition/postcondition is done.
278 end Analyze_PPC_In_Decl_Part;
284 procedure Analyze_Pragma (N : Node_Id) is
285 Loc : constant Source_Ptr := Sloc (N);
286 Pname : constant Name_Id := Pragma_Name (N);
289 Pragma_Exit : exception;
290 -- This exception is used to exit pragma processing completely. It is
291 -- used when an error is detected, and no further processing is
292 -- required. It is also used if an earlier error has left the tree in
293 -- a state where the pragma should not be processed.
296 -- Number of pragma argument associations
302 -- First four pragma arguments (pragma argument association nodes, or
303 -- Empty if the corresponding argument does not exist).
305 type Name_List is array (Natural range <>) of Name_Id;
306 type Args_List is array (Natural range <>) of Node_Id;
307 -- Types used for arguments to Check_Arg_Order and Gather_Associations
309 procedure Ada_2005_Pragma;
310 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
311 -- Ada 95 mode, these are implementation defined pragmas, so should be
312 -- caught by the No_Implementation_Pragmas restriction
314 procedure Check_Ada_83_Warning;
315 -- Issues a warning message for the current pragma if operating in Ada
316 -- 83 mode (used for language pragmas that are not a standard part of
317 -- Ada 83). This procedure does not raise Error_Pragma. Also notes use
320 procedure Check_Arg_Count (Required : Nat);
321 -- Check argument count for pragma is equal to given parameter. If not,
322 -- then issue an error message and raise Pragma_Exit.
324 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
325 -- Arg which can either be a pragma argument association, in which case
326 -- the check is applied to the expression of the association or an
327 -- expression directly.
329 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
330 -- Check that an argument has the right form for an EXTERNAL_NAME
331 -- parameter of an extended import/export pragma. The rule is that the
332 -- name must be an identifier or string literal (in Ada 83 mode) or a
333 -- static string expression (in Ada 95 mode).
335 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
336 -- Check the specified argument Arg to make sure that it is an
337 -- identifier. If not give error and raise Pragma_Exit.
339 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
340 -- Check the specified argument Arg to make sure that it is an integer
341 -- literal. If not give error and raise Pragma_Exit.
343 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
344 -- Check the specified argument Arg to make sure that it has the proper
345 -- syntactic form for a local name and meets the semantic requirements
346 -- for a local name. The local name is analyzed as part of the
347 -- processing for this call. In addition, the local name is required
348 -- to represent an entity at the library level.
350 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
351 -- Check the specified argument Arg to make sure that it has the proper
352 -- syntactic form for a local name and meets the semantic requirements
353 -- for a local name. The local name is analyzed as part of the
354 -- processing for this call.
356 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
357 -- Check the specified argument Arg to make sure that it is a valid
358 -- locking policy name. If not give error and raise Pragma_Exit.
360 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
361 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2, N3 : Name_Id);
362 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2, N3, N4 : Name_Id);
363 -- Check the specified argument Arg to make sure that it is an
364 -- identifier whose name matches either N1 or N2 (or N3 if present).
365 -- If not then give error and raise Pragma_Exit.
367 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
368 -- Check the specified argument Arg to make sure that it is a valid
369 -- queuing policy name. If not give error and raise Pragma_Exit.
371 procedure Check_Arg_Is_Static_Expression
373 Typ : Entity_Id := Empty);
374 -- Check the specified argument Arg to make sure that it is a static
375 -- expression of the given type (i.e. it will be analyzed and resolved
376 -- using this type, which can be any valid argument to Resolve, e.g.
377 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
378 -- Typ is left Empty, then any static expression is allowed.
380 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
381 -- Check the specified argument Arg to make sure that it is a valid task
382 -- dispatching policy name. If not give error and raise Pragma_Exit.
384 procedure Check_Arg_Order (Names : Name_List);
385 -- Checks for an instance of two arguments with identifiers for the
386 -- current pragma which are not in the sequence indicated by Names,
387 -- and if so, generates a fatal message about bad order of arguments.
389 procedure Check_At_Least_N_Arguments (N : Nat);
390 -- Check there are at least N arguments present
392 procedure Check_At_Most_N_Arguments (N : Nat);
393 -- Check there are no more than N arguments present
395 procedure Check_Component (Comp : Node_Id);
396 -- Examine Unchecked_Union component for correct use of per-object
397 -- constrained subtypes, and for restrictions on finalizable components.
399 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
400 -- Nam is an N_String_Literal node containing the external name set by
401 -- an Import or Export pragma (or extended Import or Export pragma).
402 -- This procedure checks for possible duplications if this is the export
403 -- case, and if found, issues an appropriate error message.
405 procedure Check_First_Subtype (Arg : Node_Id);
406 -- Checks that Arg, whose expression is an entity name referencing a
407 -- subtype, does not reference a type that is not a first subtype.
409 procedure Check_In_Main_Program;
410 -- Common checks for pragmas that appear within a main program
411 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline).
413 procedure Check_Interrupt_Or_Attach_Handler;
414 -- Common processing for first argument of pragma Interrupt_Handler or
415 -- pragma Attach_Handler.
417 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
418 -- Check that pragma appears in a declarative part, or in a package
419 -- specification, i.e. that it does not occur in a statement sequence
422 procedure Check_No_Identifier (Arg : Node_Id);
423 -- Checks that the given argument does not have an identifier. If
424 -- an identifier is present, then an error message is issued, and
425 -- Pragma_Exit is raised.
427 procedure Check_No_Identifiers;
428 -- Checks that none of the arguments to the pragma has an identifier.
429 -- If any argument has an identifier, then an error message is issued,
430 -- and Pragma_Exit is raised.
432 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
433 -- Checks if the given argument has an identifier, and if so, requires
434 -- it to match the given identifier name. If there is a non-matching
435 -- identifier, then an error message is given and Error_Pragmas raised.
437 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
438 -- Checks if the given argument has an identifier, and if so, requires
439 -- it to match the given identifier name. If there is a non-matching
440 -- identifier, then an error message is given and Error_Pragmas raised.
441 -- In this version of the procedure, the identifier name is given as
442 -- a string with lower case letters.
444 procedure Check_Precondition_Postcondition (In_Body : out Boolean);
445 -- Called to process a precondition or postcondition pragma. There are
448 -- The pragma appears after a subprogram spec
450 -- If the corresponding check is not enabled, the pragma is analyzed
451 -- but otherwise ignored and control returns with In_Body set False.
453 -- If the check is enabled, then the first step is to analyze the
454 -- pragma, but this is skipped if the subprogram spec appears within
455 -- a package specification (because this is the case where we delay
456 -- analysis till the end of the spec). Then (whether or not it was
457 -- analyzed), the pragma is chained to the subprogram in question
458 -- (using Spec_PPC_List and Next_Pragma) and control returns to the
459 -- caller with In_Body set False.
461 -- The pragma appears at the start of subprogram body declarations
463 -- In this case an immediate return to the caller is made with
464 -- In_Body set True, and the pragma is NOT analyzed.
466 -- In all other cases, an error message for bad placement is given
468 procedure Check_Static_Constraint (Constr : Node_Id);
469 -- Constr is a constraint from an N_Subtype_Indication node from a
470 -- component constraint in an Unchecked_Union type. This routine checks
471 -- that the constraint is static as required by the restrictions for
474 procedure Check_Valid_Configuration_Pragma;
475 -- Legality checks for placement of a configuration pragma
477 procedure Check_Valid_Library_Unit_Pragma;
478 -- Legality checks for library unit pragmas. A special case arises for
479 -- pragmas in generic instances that come from copies of the original
480 -- library unit pragmas in the generic templates. In the case of other
481 -- than library level instantiations these can appear in contexts which
482 -- would normally be invalid (they only apply to the original template
483 -- and to library level instantiations), and they are simply ignored,
484 -- which is implemented by rewriting them as null statements.
486 procedure Check_Variant (Variant : Node_Id);
487 -- Check Unchecked_Union variant for lack of nested variants and
488 -- presence of at least one component.
490 procedure Error_Pragma (Msg : String);
491 pragma No_Return (Error_Pragma);
492 -- Outputs error message for current pragma. The message contains a %
493 -- that will be replaced with the pragma name, and the flag is placed
494 -- on the pragma itself. Pragma_Exit is then raised.
496 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
497 pragma No_Return (Error_Pragma_Arg);
498 -- Outputs error message for current pragma. The message may contain
499 -- a % that will be replaced with the pragma name. The parameter Arg
500 -- may either be a pragma argument association, in which case the flag
501 -- is placed on the expression of this association, or an expression,
502 -- in which case the flag is placed directly on the expression. The
503 -- message is placed using Error_Msg_N, so the message may also contain
504 -- an & insertion character which will reference the given Arg value.
505 -- After placing the message, Pragma_Exit is raised.
507 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
508 pragma No_Return (Error_Pragma_Arg);
509 -- Similar to above form of Error_Pragma_Arg except that two messages
510 -- are provided, the second is a continuation comment starting with \.
512 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
513 pragma No_Return (Error_Pragma_Arg_Ident);
514 -- Outputs error message for current pragma. The message may contain
515 -- a % that will be replaced with the pragma name. The parameter Arg
516 -- must be a pragma argument association with a non-empty identifier
517 -- (i.e. its Chars field must be set), and the error message is placed
518 -- on the identifier. The message is placed using Error_Msg_N so
519 -- the message may also contain an & insertion character which will
520 -- reference the identifier. After placing the message, Pragma_Exit
523 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
524 pragma No_Return (Error_Pragma_Ref);
525 -- Outputs error message for current pragma. The message may contain
526 -- a % that will be replaced with the pragma name. The parameter Ref
527 -- must be an entity whose name can be referenced by & and sloc by #.
528 -- After placing the message, Pragma_Exit is raised.
530 function Find_Lib_Unit_Name return Entity_Id;
531 -- Used for a library unit pragma to find the entity to which the
532 -- library unit pragma applies, returns the entity found.
534 procedure Find_Program_Unit_Name (Id : Node_Id);
535 -- If the pragma is a compilation unit pragma, the id must denote the
536 -- compilation unit in the same compilation, and the pragma must appear
537 -- in the list of preceding or trailing pragmas. If it is a program
538 -- unit pragma that is not a compilation unit pragma, then the
539 -- identifier must be visible.
541 function Find_Unique_Parameterless_Procedure
543 Arg : Node_Id) return Entity_Id;
544 -- Used for a procedure pragma to find the unique parameterless
545 -- procedure identified by Name, returns it if it exists, otherwise
546 -- errors out and uses Arg as the pragma argument for the message.
548 procedure Gather_Associations
550 Args : out Args_List);
551 -- This procedure is used to gather the arguments for a pragma that
552 -- permits arbitrary ordering of parameters using the normal rules
553 -- for named and positional parameters. The Names argument is a list
554 -- of Name_Id values that corresponds to the allowed pragma argument
555 -- association identifiers in order. The result returned in Args is
556 -- a list of corresponding expressions that are the pragma arguments.
557 -- Note that this is a list of expressions, not of pragma argument
558 -- associations (Gather_Associations has completely checked all the
559 -- optional identifiers when it returns). An entry in Args is Empty
560 -- on return if the corresponding argument is not present.
562 procedure GNAT_Pragma;
563 -- Called for all GNAT defined pragmas to check the relevant restriction
564 -- (No_Implementation_Pragmas).
566 function Is_Before_First_Decl
567 (Pragma_Node : Node_Id;
568 Decls : List_Id) return Boolean;
569 -- Return True if Pragma_Node is before the first declarative item in
570 -- Decls where Decls is the list of declarative items.
572 function Is_Configuration_Pragma return Boolean;
573 -- Determines if the placement of the current pragma is appropriate
574 -- for a configuration pragma.
576 function Is_In_Context_Clause return Boolean;
577 -- Returns True if pragma appears within the context clause of a unit,
578 -- and False for any other placement (does not generate any messages).
580 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
581 -- Analyzes the argument, and determines if it is a static string
582 -- expression, returns True if so, False if non-static or not String.
584 procedure Pragma_Misplaced;
585 pragma No_Return (Pragma_Misplaced);
586 -- Issue fatal error message for misplaced pragma
588 procedure Process_Atomic_Shared_Volatile;
589 -- Common processing for pragmas Atomic, Shared, Volatile. Note that
590 -- Shared is an obsolete Ada 83 pragma, treated as being identical
591 -- in effect to pragma Atomic.
593 procedure Process_Compile_Time_Warning_Or_Error;
594 -- Common processing for Compile_Time_Error and Compile_Time_Warning
596 procedure Process_Convention
597 (C : out Convention_Id;
598 Ent : out Entity_Id);
599 -- Common processing for Convention, Interface, Import and Export.
600 -- Checks first two arguments of pragma, and sets the appropriate
601 -- convention value in the specified entity or entities. On return
602 -- C is the convention, Ent is the referenced entity.
604 procedure Process_Extended_Import_Export_Exception_Pragma
605 (Arg_Internal : Node_Id;
606 Arg_External : Node_Id;
609 -- Common processing for the pragmas Import/Export_Exception. The three
610 -- arguments correspond to the three named parameters of the pragma. An
611 -- argument is empty if the corresponding parameter is not present in
614 procedure Process_Extended_Import_Export_Object_Pragma
615 (Arg_Internal : Node_Id;
616 Arg_External : Node_Id;
618 -- Common processing for the pragmas Import/Export_Object. The three
619 -- arguments correspond to the three named parameters of the pragmas. An
620 -- argument is empty if the corresponding parameter is not present in
623 procedure Process_Extended_Import_Export_Internal_Arg
624 (Arg_Internal : Node_Id := Empty);
625 -- Common processing for all extended Import and Export pragmas. The
626 -- argument is the pragma parameter for the Internal argument. If
627 -- Arg_Internal is empty or inappropriate, an error message is posted.
628 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
629 -- set to identify the referenced entity.
631 procedure Process_Extended_Import_Export_Subprogram_Pragma
632 (Arg_Internal : Node_Id;
633 Arg_External : Node_Id;
634 Arg_Parameter_Types : Node_Id;
635 Arg_Result_Type : Node_Id := Empty;
636 Arg_Mechanism : Node_Id;
637 Arg_Result_Mechanism : Node_Id := Empty;
638 Arg_First_Optional_Parameter : Node_Id := Empty);
639 -- Common processing for all extended Import and Export pragmas applying
640 -- to subprograms. The caller omits any arguments that do not apply to
641 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
642 -- only in the Import_Function and Export_Function cases). The argument
643 -- names correspond to the allowed pragma association identifiers.
645 procedure Process_Generic_List;
646 -- Common processing for Share_Generic and Inline_Generic
648 procedure Process_Import_Or_Interface;
649 -- Common processing for Import of Interface
651 procedure Process_Inline (Active : Boolean);
652 -- Common processing for Inline and Inline_Always. The parameter
653 -- indicates if the inline pragma is active, i.e. if it should actually
654 -- cause inlining to occur.
656 procedure Process_Interface_Name
657 (Subprogram_Def : Entity_Id;
660 -- Given the last two arguments of pragma Import, pragma Export, or
661 -- pragma Interface_Name, performs validity checks and sets the
662 -- Interface_Name field of the given subprogram entity to the
663 -- appropriate external or link name, depending on the arguments given.
664 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
665 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
666 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
667 -- nor Link_Arg is present, the interface name is set to the default
668 -- from the subprogram name.
670 procedure Process_Interrupt_Or_Attach_Handler;
671 -- Common processing for Interrupt and Attach_Handler pragmas
673 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
674 -- Common processing for Restrictions and Restriction_Warnings pragmas.
675 -- Warn is True for Restriction_Warnings, or for Restrictions if the
676 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
677 -- is not set in the Restrictions case.
679 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
680 -- Common processing for Suppress and Unsuppress. The boolean parameter
681 -- Suppress_Case is True for the Suppress case, and False for the
684 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
685 -- This procedure sets the Is_Exported flag for the given entity,
686 -- checking that the entity was not previously imported. Arg is
687 -- the argument that specified the entity. A check is also made
688 -- for exporting inappropriate entities.
690 procedure Set_Extended_Import_Export_External_Name
691 (Internal_Ent : Entity_Id;
692 Arg_External : Node_Id);
693 -- Common processing for all extended import export pragmas. The first
694 -- argument, Internal_Ent, is the internal entity, which has already
695 -- been checked for validity by the caller. Arg_External is from the
696 -- Import or Export pragma, and may be null if no External parameter
697 -- was present. If Arg_External is present and is a non-null string
698 -- (a null string is treated as the default), then the Interface_Name
699 -- field of Internal_Ent is set appropriately.
701 procedure Set_Imported (E : Entity_Id);
702 -- This procedure sets the Is_Imported flag for the given entity,
703 -- checking that it is not previously exported or imported.
705 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
706 -- Mech is a parameter passing mechanism (see Import_Function syntax
707 -- for MECHANISM_NAME). This routine checks that the mechanism argument
708 -- has the right form, and if not issues an error message. If the
709 -- argument has the right form then the Mechanism field of Ent is
710 -- set appropriately.
712 procedure Set_Ravenscar_Profile (N : Node_Id);
713 -- Activate the set of configuration pragmas and restrictions that make
714 -- up the Ravenscar Profile. N is the corresponding pragma node, which
715 -- is used for error messages on any constructs that violate the
718 ---------------------
719 -- Ada_2005_Pragma --
720 ---------------------
722 procedure Ada_2005_Pragma is
724 if Ada_Version <= Ada_95 then
725 Check_Restriction (No_Implementation_Pragmas, N);
729 --------------------------
730 -- Check_Ada_83_Warning --
731 --------------------------
733 procedure Check_Ada_83_Warning is
735 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
736 Error_Msg_N ("(Ada 83) pragma& is non-standard?", N);
738 end Check_Ada_83_Warning;
740 ---------------------
741 -- Check_Arg_Count --
742 ---------------------
744 procedure Check_Arg_Count (Required : Nat) is
746 if Arg_Count /= Required then
747 Error_Pragma ("wrong number of arguments for pragma%");
751 --------------------------------
752 -- Check_Arg_Is_External_Name --
753 --------------------------------
755 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
756 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
759 if Nkind (Argx) = N_Identifier then
763 Analyze_And_Resolve (Argx, Standard_String);
765 if Is_OK_Static_Expression (Argx) then
768 elsif Etype (Argx) = Any_Type then
771 -- An interesting special case, if we have a string literal and
772 -- we are in Ada 83 mode, then we allow it even though it will
773 -- not be flagged as static. This allows expected Ada 83 mode
774 -- use of external names which are string literals, even though
775 -- technically these are not static in Ada 83.
777 elsif Ada_Version = Ada_83
778 and then Nkind (Argx) = N_String_Literal
782 -- Static expression that raises Constraint_Error. This has
783 -- already been flagged, so just exit from pragma processing.
785 elsif Is_Static_Expression (Argx) then
788 -- Here we have a real error (non-static expression)
791 Error_Msg_Name_1 := Pname;
793 ("argument for pragma% must be a identifier or " &
794 "static string expression!", Argx);
798 end Check_Arg_Is_External_Name;
800 -----------------------------
801 -- Check_Arg_Is_Identifier --
802 -----------------------------
804 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
805 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
807 if Nkind (Argx) /= N_Identifier then
809 ("argument for pragma% must be identifier", Argx);
811 end Check_Arg_Is_Identifier;
813 ----------------------------------
814 -- Check_Arg_Is_Integer_Literal --
815 ----------------------------------
817 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
818 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
820 if Nkind (Argx) /= N_Integer_Literal then
822 ("argument for pragma% must be integer literal", Argx);
824 end Check_Arg_Is_Integer_Literal;
826 -------------------------------------------
827 -- Check_Arg_Is_Library_Level_Local_Name --
828 -------------------------------------------
832 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
833 -- | library_unit_NAME
835 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
837 Check_Arg_Is_Local_Name (Arg);
839 if not Is_Library_Level_Entity (Entity (Expression (Arg)))
840 and then Comes_From_Source (N)
843 ("argument for pragma% must be library level entity", Arg);
845 end Check_Arg_Is_Library_Level_Local_Name;
847 -----------------------------
848 -- Check_Arg_Is_Local_Name --
849 -----------------------------
853 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
854 -- | library_unit_NAME
856 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
857 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
862 if Nkind (Argx) not in N_Direct_Name
863 and then (Nkind (Argx) /= N_Attribute_Reference
864 or else Present (Expressions (Argx))
865 or else Nkind (Prefix (Argx)) /= N_Identifier)
866 and then (not Is_Entity_Name (Argx)
867 or else not Is_Compilation_Unit (Entity (Argx)))
869 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
872 if Is_Entity_Name (Argx)
873 and then Scope (Entity (Argx)) /= Current_Scope
876 ("pragma% argument must be in same declarative part", Arg);
878 end Check_Arg_Is_Local_Name;
880 ---------------------------------
881 -- Check_Arg_Is_Locking_Policy --
882 ---------------------------------
884 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
885 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
888 Check_Arg_Is_Identifier (Argx);
890 if not Is_Locking_Policy_Name (Chars (Argx)) then
892 ("& is not a valid locking policy name", Argx);
894 end Check_Arg_Is_Locking_Policy;
896 -------------------------
897 -- Check_Arg_Is_One_Of --
898 -------------------------
900 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
901 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
904 Check_Arg_Is_Identifier (Argx);
906 if Chars (Argx) /= N1 and then Chars (Argx) /= N2 then
907 Error_Msg_Name_2 := N1;
908 Error_Msg_Name_3 := N2;
909 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
911 end Check_Arg_Is_One_Of;
913 procedure Check_Arg_Is_One_Of
915 N1, N2, N3 : Name_Id)
917 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
920 Check_Arg_Is_Identifier (Argx);
922 if Chars (Argx) /= N1
923 and then Chars (Argx) /= N2
924 and then Chars (Argx) /= N3
926 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
928 end Check_Arg_Is_One_Of;
930 procedure Check_Arg_Is_One_Of
932 N1, N2, N3, N4 : Name_Id)
934 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
937 Check_Arg_Is_Identifier (Argx);
939 if Chars (Argx) /= N1
940 and then Chars (Argx) /= N2
941 and then Chars (Argx) /= N3
942 and then Chars (Argx) /= N4
944 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
946 end Check_Arg_Is_One_Of;
948 ---------------------------------
949 -- Check_Arg_Is_Queuing_Policy --
950 ---------------------------------
952 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
953 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
956 Check_Arg_Is_Identifier (Argx);
958 if not Is_Queuing_Policy_Name (Chars (Argx)) then
960 ("& is not a valid queuing policy name", Argx);
962 end Check_Arg_Is_Queuing_Policy;
964 ------------------------------------
965 -- Check_Arg_Is_Static_Expression --
966 ------------------------------------
968 procedure Check_Arg_Is_Static_Expression
970 Typ : Entity_Id := Empty)
972 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
975 if Present (Typ) then
976 Analyze_And_Resolve (Argx, Typ);
978 Analyze_And_Resolve (Argx);
981 if Is_OK_Static_Expression (Argx) then
984 elsif Etype (Argx) = Any_Type then
987 -- An interesting special case, if we have a string literal and we
988 -- are in Ada 83 mode, then we allow it even though it will not be
989 -- flagged as static. This allows the use of Ada 95 pragmas like
990 -- Import in Ada 83 mode. They will of course be flagged with
991 -- warnings as usual, but will not cause errors.
993 elsif Ada_Version = Ada_83
994 and then Nkind (Argx) = N_String_Literal
998 -- Static expression that raises Constraint_Error. This has already
999 -- been flagged, so just exit from pragma processing.
1001 elsif Is_Static_Expression (Argx) then
1004 -- Finally, we have a real error
1007 Error_Msg_Name_1 := Pname;
1008 Flag_Non_Static_Expr
1009 ("argument for pragma% must be a static expression!", Argx);
1012 end Check_Arg_Is_Static_Expression;
1014 ------------------------------------------
1015 -- Check_Arg_Is_Task_Dispatching_Policy --
1016 ------------------------------------------
1018 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
1019 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1022 Check_Arg_Is_Identifier (Argx);
1024 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
1026 ("& is not a valid task dispatching policy name", Argx);
1028 end Check_Arg_Is_Task_Dispatching_Policy;
1030 ---------------------
1031 -- Check_Arg_Order --
1032 ---------------------
1034 procedure Check_Arg_Order (Names : Name_List) is
1037 Highest_So_Far : Natural := 0;
1038 -- Highest index in Names seen do far
1042 for J in 1 .. Arg_Count loop
1043 if Chars (Arg) /= No_Name then
1044 for K in Names'Range loop
1045 if Chars (Arg) = Names (K) then
1046 if K < Highest_So_Far then
1047 Error_Msg_Name_1 := Pname;
1049 ("parameters out of order for pragma%", Arg);
1050 Error_Msg_Name_1 := Names (K);
1051 Error_Msg_Name_2 := Names (Highest_So_Far);
1052 Error_Msg_N ("\% must appear before %", Arg);
1056 Highest_So_Far := K;
1064 end Check_Arg_Order;
1066 --------------------------------
1067 -- Check_At_Least_N_Arguments --
1068 --------------------------------
1070 procedure Check_At_Least_N_Arguments (N : Nat) is
1072 if Arg_Count < N then
1073 Error_Pragma ("too few arguments for pragma%");
1075 end Check_At_Least_N_Arguments;
1077 -------------------------------
1078 -- Check_At_Most_N_Arguments --
1079 -------------------------------
1081 procedure Check_At_Most_N_Arguments (N : Nat) is
1084 if Arg_Count > N then
1086 for J in 1 .. N loop
1088 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
1091 end Check_At_Most_N_Arguments;
1093 ---------------------
1094 -- Check_Component --
1095 ---------------------
1097 procedure Check_Component (Comp : Node_Id) is
1099 if Nkind (Comp) = N_Component_Declaration then
1101 Sindic : constant Node_Id :=
1102 Subtype_Indication (Component_Definition (Comp));
1103 Typ : constant Entity_Id :=
1104 Etype (Defining_Identifier (Comp));
1106 if Nkind (Sindic) = N_Subtype_Indication then
1108 -- Ada 2005 (AI-216): If a component subtype is subject to
1109 -- a per-object constraint, then the component type shall
1110 -- be an Unchecked_Union.
1112 if Has_Per_Object_Constraint (Defining_Identifier (Comp))
1114 not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
1116 Error_Msg_N ("component subtype subject to per-object" &
1117 " constraint must be an Unchecked_Union", Comp);
1121 if Is_Controlled (Typ) then
1123 ("component of unchecked union cannot be controlled", Comp);
1125 elsif Has_Task (Typ) then
1127 ("component of unchecked union cannot have tasks", Comp);
1131 end Check_Component;
1133 ----------------------------------
1134 -- Check_Duplicated_Export_Name --
1135 ----------------------------------
1137 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
1138 String_Val : constant String_Id := Strval (Nam);
1141 -- We are only interested in the export case, and in the case of
1142 -- generics, it is the instance, not the template, that is the
1143 -- problem (the template will generate a warning in any case).
1145 if not Inside_A_Generic
1146 and then (Prag_Id = Pragma_Export
1148 Prag_Id = Pragma_Export_Procedure
1150 Prag_Id = Pragma_Export_Valued_Procedure
1152 Prag_Id = Pragma_Export_Function)
1154 for J in Externals.First .. Externals.Last loop
1155 if String_Equal (String_Val, Strval (Externals.Table (J))) then
1156 Error_Msg_Sloc := Sloc (Externals.Table (J));
1157 Error_Msg_N ("external name duplicates name given#", Nam);
1162 Externals.Append (Nam);
1164 end Check_Duplicated_Export_Name;
1166 -------------------------
1167 -- Check_First_Subtype --
1168 -------------------------
1170 procedure Check_First_Subtype (Arg : Node_Id) is
1171 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1173 if not Is_First_Subtype (Entity (Argx)) then
1175 ("pragma% cannot apply to subtype", Argx);
1177 end Check_First_Subtype;
1179 ---------------------------
1180 -- Check_In_Main_Program --
1181 ---------------------------
1183 procedure Check_In_Main_Program is
1184 P : constant Node_Id := Parent (N);
1187 -- Must be at in subprogram body
1189 if Nkind (P) /= N_Subprogram_Body then
1190 Error_Pragma ("% pragma allowed only in subprogram");
1192 -- Otherwise warn if obviously not main program
1194 elsif Present (Parameter_Specifications (Specification (P)))
1195 or else not Is_Compilation_Unit (Defining_Entity (P))
1197 Error_Msg_Name_1 := Pname;
1199 ("?pragma% is only effective in main program", N);
1201 end Check_In_Main_Program;
1203 ---------------------------------------
1204 -- Check_Interrupt_Or_Attach_Handler --
1205 ---------------------------------------
1207 procedure Check_Interrupt_Or_Attach_Handler is
1208 Arg1_X : constant Node_Id := Expression (Arg1);
1209 Handler_Proc, Proc_Scope : Entity_Id;
1214 if Prag_Id = Pragma_Interrupt_Handler then
1215 Check_Restriction (No_Dynamic_Attachment, N);
1218 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
1219 Proc_Scope := Scope (Handler_Proc);
1221 -- On AAMP only, a pragma Interrupt_Handler is supported for
1222 -- nonprotected parameterless procedures.
1224 if not AAMP_On_Target
1225 or else Prag_Id = Pragma_Attach_Handler
1227 if Ekind (Proc_Scope) /= E_Protected_Type then
1229 ("argument of pragma% must be protected procedure", Arg1);
1232 if Parent (N) /= Protected_Definition (Parent (Proc_Scope)) then
1233 Error_Pragma ("pragma% must be in protected definition");
1237 if not Is_Library_Level_Entity (Proc_Scope)
1238 or else (AAMP_On_Target
1239 and then not Is_Library_Level_Entity (Handler_Proc))
1242 ("argument for pragma% must be library level entity", Arg1);
1244 end Check_Interrupt_Or_Attach_Handler;
1246 -------------------------------------------
1247 -- Check_Is_In_Decl_Part_Or_Package_Spec --
1248 -------------------------------------------
1250 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
1259 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
1262 elsif Nkind_In (P, N_Package_Specification,
1267 -- Note: the following tests seem a little peculiar, because
1268 -- they test for bodies, but if we were in the statement part
1269 -- of the body, we would already have hit the handled statement
1270 -- sequence, so the only way we get here is by being in the
1271 -- declarative part of the body.
1273 elsif Nkind_In (P, N_Subprogram_Body,
1284 Error_Pragma ("pragma% is not in declarative part or package spec");
1285 end Check_Is_In_Decl_Part_Or_Package_Spec;
1287 -------------------------
1288 -- Check_No_Identifier --
1289 -------------------------
1291 procedure Check_No_Identifier (Arg : Node_Id) is
1293 if Chars (Arg) /= No_Name then
1294 Error_Pragma_Arg_Ident
1295 ("pragma% does not permit identifier& here", Arg);
1297 end Check_No_Identifier;
1299 --------------------------
1300 -- Check_No_Identifiers --
1301 --------------------------
1303 procedure Check_No_Identifiers is
1306 if Arg_Count > 0 then
1308 while Present (Arg_Node) loop
1309 Check_No_Identifier (Arg_Node);
1313 end Check_No_Identifiers;
1315 -------------------------------
1316 -- Check_Optional_Identifier --
1317 -------------------------------
1319 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
1321 if Present (Arg) and then Chars (Arg) /= No_Name then
1322 if Chars (Arg) /= Id then
1323 Error_Msg_Name_1 := Pname;
1324 Error_Msg_Name_2 := Id;
1325 Error_Msg_N ("pragma% argument expects identifier%", Arg);
1329 end Check_Optional_Identifier;
1331 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
1333 Name_Buffer (1 .. Id'Length) := Id;
1334 Name_Len := Id'Length;
1335 Check_Optional_Identifier (Arg, Name_Find);
1336 end Check_Optional_Identifier;
1338 --------------------------------------
1339 -- Check_Precondition_Postcondition --
1340 --------------------------------------
1342 procedure Check_Precondition_Postcondition (In_Body : out Boolean) is
1346 procedure Chain_PPC (PO : Node_Id);
1347 -- If PO is a subprogram declaration node (or a generic subprogram
1348 -- declaration node), then the precondition/postcondition applies
1349 -- to this subprogram and the processing for the pragma is completed.
1350 -- Otherwise the pragma is misplaced.
1356 procedure Chain_PPC (PO : Node_Id) is
1360 if not Nkind_In (PO, N_Subprogram_Declaration,
1361 N_Generic_Subprogram_Declaration)
1366 -- Here if we have subprogram or generic subprogram declaration
1368 S := Defining_Unit_Name (Specification (PO));
1370 -- Analyze the pragma unless it appears within a package spec,
1371 -- which is the case where we delay the analysis of the PPC until
1372 -- the end of the package declarations (for details, see
1373 -- Analyze_Package_Specification.Analyze_PPCs).
1375 if not Is_Package_Or_Generic_Package (Scope (S)) then
1376 Analyze_PPC_In_Decl_Part (N, S);
1379 -- Chain spec PPC pragma to list for subprogram
1381 Set_Next_Pragma (N, Spec_PPC_List (S));
1382 Set_Spec_PPC_List (S, N);
1384 -- Return indicating spec case
1390 -- Start of processing for Check_Precondition_Postcondition
1393 if not Is_List_Member (N) then
1397 -- Record if pragma is enabled
1399 if Check_Enabled (Pname) then
1400 Set_Pragma_Enabled (N);
1401 Set_SCO_Pragma_Enabled (Loc);
1404 -- If we are within an inlined body, the legality of the pragma
1405 -- has been checked already.
1407 if In_Inlined_Body then
1412 -- Search prior declarations
1415 while Present (Prev (P)) loop
1418 -- If the previous node is a generic subprogram, do not go to to
1419 -- the original node, which is the unanalyzed tree: we need to
1420 -- attach the pre/postconditions to the analyzed version at this
1421 -- point. They get propagated to the original tree when analyzing
1422 -- the corresponding body.
1424 if Nkind (P) not in N_Generic_Declaration then
1425 PO := Original_Node (P);
1430 -- Skip past prior pragma
1432 if Nkind (PO) = N_Pragma then
1435 -- Skip stuff not coming from source
1437 elsif not Comes_From_Source (PO) then
1440 -- Only remaining possibility is subprogram declaration
1448 -- If we fall through loop, pragma is at start of list, so see if it
1449 -- is at the start of declarations of a subprogram body.
1451 if Nkind (Parent (N)) = N_Subprogram_Body
1452 and then List_Containing (N) = Declarations (Parent (N))
1454 if Operating_Mode /= Generate_Code
1455 or else Inside_A_Generic
1458 -- Analyze expression in pragma, for correctness
1459 -- and for ASIS use.
1461 Preanalyze_Spec_Expression
1462 (Get_Pragma_Arg (Arg1), Standard_Boolean);
1468 -- See if it is in the pragmas after a library level subprogram
1470 elsif Nkind (Parent (N)) = N_Compilation_Unit_Aux then
1471 Chain_PPC (Unit (Parent (Parent (N))));
1475 -- If we fall through, pragma was misplaced
1478 end Check_Precondition_Postcondition;
1480 -----------------------------
1481 -- Check_Static_Constraint --
1482 -----------------------------
1484 -- Note: for convenience in writing this procedure, in addition to
1485 -- the officially (i.e. by spec) allowed argument which is always a
1486 -- constraint, it also allows ranges and discriminant associations.
1487 -- Above is not clear ???
1489 procedure Check_Static_Constraint (Constr : Node_Id) is
1491 procedure Require_Static (E : Node_Id);
1492 -- Require given expression to be static expression
1494 --------------------
1495 -- Require_Static --
1496 --------------------
1498 procedure Require_Static (E : Node_Id) is
1500 if not Is_OK_Static_Expression (E) then
1501 Flag_Non_Static_Expr
1502 ("non-static constraint not allowed in Unchecked_Union!", E);
1507 -- Start of processing for Check_Static_Constraint
1510 case Nkind (Constr) is
1511 when N_Discriminant_Association =>
1512 Require_Static (Expression (Constr));
1515 Require_Static (Low_Bound (Constr));
1516 Require_Static (High_Bound (Constr));
1518 when N_Attribute_Reference =>
1519 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
1520 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
1522 when N_Range_Constraint =>
1523 Check_Static_Constraint (Range_Expression (Constr));
1525 when N_Index_Or_Discriminant_Constraint =>
1529 IDC := First (Constraints (Constr));
1530 while Present (IDC) loop
1531 Check_Static_Constraint (IDC);
1539 end Check_Static_Constraint;
1541 --------------------------------------
1542 -- Check_Valid_Configuration_Pragma --
1543 --------------------------------------
1545 -- A configuration pragma must appear in the context clause of a
1546 -- compilation unit, and only other pragmas may precede it. Note that
1547 -- the test also allows use in a configuration pragma file.
1549 procedure Check_Valid_Configuration_Pragma is
1551 if not Is_Configuration_Pragma then
1552 Error_Pragma ("incorrect placement for configuration pragma%");
1554 end Check_Valid_Configuration_Pragma;
1556 -------------------------------------
1557 -- Check_Valid_Library_Unit_Pragma --
1558 -------------------------------------
1560 procedure Check_Valid_Library_Unit_Pragma is
1562 Parent_Node : Node_Id;
1563 Unit_Name : Entity_Id;
1564 Unit_Kind : Node_Kind;
1565 Unit_Node : Node_Id;
1566 Sindex : Source_File_Index;
1569 if not Is_List_Member (N) then
1573 Plist := List_Containing (N);
1574 Parent_Node := Parent (Plist);
1576 if Parent_Node = Empty then
1579 -- Case of pragma appearing after a compilation unit. In this case
1580 -- it must have an argument with the corresponding name and must
1581 -- be part of the following pragmas of its parent.
1583 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
1584 if Plist /= Pragmas_After (Parent_Node) then
1587 elsif Arg_Count = 0 then
1589 ("argument required if outside compilation unit");
1592 Check_No_Identifiers;
1593 Check_Arg_Count (1);
1594 Unit_Node := Unit (Parent (Parent_Node));
1595 Unit_Kind := Nkind (Unit_Node);
1597 Analyze (Expression (Arg1));
1599 if Unit_Kind = N_Generic_Subprogram_Declaration
1600 or else Unit_Kind = N_Subprogram_Declaration
1602 Unit_Name := Defining_Entity (Unit_Node);
1604 elsif Unit_Kind in N_Generic_Instantiation then
1605 Unit_Name := Defining_Entity (Unit_Node);
1608 Unit_Name := Cunit_Entity (Current_Sem_Unit);
1611 if Chars (Unit_Name) /=
1612 Chars (Entity (Expression (Arg1)))
1615 ("pragma% argument is not current unit name", Arg1);
1618 if Ekind (Unit_Name) = E_Package
1619 and then Present (Renamed_Entity (Unit_Name))
1621 Error_Pragma ("pragma% not allowed for renamed package");
1625 -- Pragma appears other than after a compilation unit
1628 -- Here we check for the generic instantiation case and also
1629 -- for the case of processing a generic formal package. We
1630 -- detect these cases by noting that the Sloc on the node
1631 -- does not belong to the current compilation unit.
1633 Sindex := Source_Index (Current_Sem_Unit);
1635 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
1636 Rewrite (N, Make_Null_Statement (Loc));
1639 -- If before first declaration, the pragma applies to the
1640 -- enclosing unit, and the name if present must be this name.
1642 elsif Is_Before_First_Decl (N, Plist) then
1643 Unit_Node := Unit_Declaration_Node (Current_Scope);
1644 Unit_Kind := Nkind (Unit_Node);
1646 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
1649 elsif Unit_Kind = N_Subprogram_Body
1650 and then not Acts_As_Spec (Unit_Node)
1654 elsif Nkind (Parent_Node) = N_Package_Body then
1657 elsif Nkind (Parent_Node) = N_Package_Specification
1658 and then Plist = Private_Declarations (Parent_Node)
1662 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
1663 or else Nkind (Parent_Node) =
1664 N_Generic_Subprogram_Declaration)
1665 and then Plist = Generic_Formal_Declarations (Parent_Node)
1669 elsif Arg_Count > 0 then
1670 Analyze (Expression (Arg1));
1672 if Entity (Expression (Arg1)) /= Current_Scope then
1674 ("name in pragma% must be enclosing unit", Arg1);
1677 -- It is legal to have no argument in this context
1683 -- Error if not before first declaration. This is because a
1684 -- library unit pragma argument must be the name of a library
1685 -- unit (RM 10.1.5(7)), but the only names permitted in this
1686 -- context are (RM 10.1.5(6)) names of subprogram declarations,
1687 -- generic subprogram declarations or generic instantiations.
1691 ("pragma% misplaced, must be before first declaration");
1695 end Check_Valid_Library_Unit_Pragma;
1701 procedure Check_Variant (Variant : Node_Id) is
1702 Clist : constant Node_Id := Component_List (Variant);
1706 if not Is_Non_Empty_List (Component_Items (Clist)) then
1708 ("Unchecked_Union may not have empty component list",
1713 Comp := First (Component_Items (Clist));
1714 while Present (Comp) loop
1715 Check_Component (Comp);
1724 procedure Error_Pragma (Msg : String) is
1726 Error_Msg_Name_1 := Pname;
1727 Error_Msg_N (Msg, N);
1731 ----------------------
1732 -- Error_Pragma_Arg --
1733 ----------------------
1735 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
1737 Error_Msg_Name_1 := Pname;
1738 Error_Msg_N (Msg, Get_Pragma_Arg (Arg));
1740 end Error_Pragma_Arg;
1742 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
1744 Error_Msg_Name_1 := Pname;
1745 Error_Msg_N (Msg1, Get_Pragma_Arg (Arg));
1746 Error_Pragma_Arg (Msg2, Arg);
1747 end Error_Pragma_Arg;
1749 ----------------------------
1750 -- Error_Pragma_Arg_Ident --
1751 ----------------------------
1753 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
1755 Error_Msg_Name_1 := Pname;
1756 Error_Msg_N (Msg, Arg);
1758 end Error_Pragma_Arg_Ident;
1760 ----------------------
1761 -- Error_Pragma_Ref --
1762 ----------------------
1764 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
1766 Error_Msg_Name_1 := Pname;
1767 Error_Msg_Sloc := Sloc (Ref);
1768 Error_Msg_NE (Msg, N, Ref);
1770 end Error_Pragma_Ref;
1772 ------------------------
1773 -- Find_Lib_Unit_Name --
1774 ------------------------
1776 function Find_Lib_Unit_Name return Entity_Id is
1778 -- Return inner compilation unit entity, for case of nested
1779 -- categorization pragmas. This happens in generic unit.
1781 if Nkind (Parent (N)) = N_Package_Specification
1782 and then Defining_Entity (Parent (N)) /= Current_Scope
1784 return Defining_Entity (Parent (N));
1786 return Current_Scope;
1788 end Find_Lib_Unit_Name;
1790 ----------------------------
1791 -- Find_Program_Unit_Name --
1792 ----------------------------
1794 procedure Find_Program_Unit_Name (Id : Node_Id) is
1795 Unit_Name : Entity_Id;
1796 Unit_Kind : Node_Kind;
1797 P : constant Node_Id := Parent (N);
1800 if Nkind (P) = N_Compilation_Unit then
1801 Unit_Kind := Nkind (Unit (P));
1803 if Unit_Kind = N_Subprogram_Declaration
1804 or else Unit_Kind = N_Package_Declaration
1805 or else Unit_Kind in N_Generic_Declaration
1807 Unit_Name := Defining_Entity (Unit (P));
1809 if Chars (Id) = Chars (Unit_Name) then
1810 Set_Entity (Id, Unit_Name);
1811 Set_Etype (Id, Etype (Unit_Name));
1813 Set_Etype (Id, Any_Type);
1815 ("cannot find program unit referenced by pragma%");
1819 Set_Etype (Id, Any_Type);
1820 Error_Pragma ("pragma% inapplicable to this unit");
1826 end Find_Program_Unit_Name;
1828 -----------------------------------------
1829 -- Find_Unique_Parameterless_Procedure --
1830 -----------------------------------------
1832 function Find_Unique_Parameterless_Procedure
1834 Arg : Node_Id) return Entity_Id
1836 Proc : Entity_Id := Empty;
1839 -- The body of this procedure needs some comments ???
1841 if not Is_Entity_Name (Name) then
1843 ("argument of pragma% must be entity name", Arg);
1845 elsif not Is_Overloaded (Name) then
1846 Proc := Entity (Name);
1848 if Ekind (Proc) /= E_Procedure
1849 or else Present (First_Formal (Proc))
1852 ("argument of pragma% must be parameterless procedure", Arg);
1857 Found : Boolean := False;
1859 Index : Interp_Index;
1862 Get_First_Interp (Name, Index, It);
1863 while Present (It.Nam) loop
1866 if Ekind (Proc) = E_Procedure
1867 and then No (First_Formal (Proc))
1871 Set_Entity (Name, Proc);
1872 Set_Is_Overloaded (Name, False);
1875 ("ambiguous handler name for pragma% ", Arg);
1879 Get_Next_Interp (Index, It);
1884 ("argument of pragma% must be parameterless procedure",
1887 Proc := Entity (Name);
1893 end Find_Unique_Parameterless_Procedure;
1895 -------------------------
1896 -- Gather_Associations --
1897 -------------------------
1899 procedure Gather_Associations
1901 Args : out Args_List)
1906 -- Initialize all parameters to Empty
1908 for J in Args'Range loop
1912 -- That's all we have to do if there are no argument associations
1914 if No (Pragma_Argument_Associations (N)) then
1918 -- Otherwise first deal with any positional parameters present
1920 Arg := First (Pragma_Argument_Associations (N));
1921 for Index in Args'Range loop
1922 exit when No (Arg) or else Chars (Arg) /= No_Name;
1923 Args (Index) := Expression (Arg);
1927 -- Positional parameters all processed, if any left, then we
1928 -- have too many positional parameters.
1930 if Present (Arg) and then Chars (Arg) = No_Name then
1932 ("too many positional associations for pragma%", Arg);
1935 -- Process named parameters if any are present
1937 while Present (Arg) loop
1938 if Chars (Arg) = No_Name then
1940 ("positional association cannot follow named association",
1944 for Index in Names'Range loop
1945 if Names (Index) = Chars (Arg) then
1946 if Present (Args (Index)) then
1948 ("duplicate argument association for pragma%", Arg);
1950 Args (Index) := Expression (Arg);
1955 if Index = Names'Last then
1956 Error_Msg_Name_1 := Pname;
1957 Error_Msg_N ("pragma% does not allow & argument", Arg);
1959 -- Check for possible misspelling
1961 for Index1 in Names'Range loop
1962 if Is_Bad_Spelling_Of
1963 (Chars (Arg), Names (Index1))
1965 Error_Msg_Name_1 := Names (Index1);
1966 Error_Msg_N -- CODEFIX
1967 ("\possible misspelling of%", Arg);
1979 end Gather_Associations;
1985 procedure GNAT_Pragma is
1987 Check_Restriction (No_Implementation_Pragmas, N);
1990 --------------------------
1991 -- Is_Before_First_Decl --
1992 --------------------------
1994 function Is_Before_First_Decl
1995 (Pragma_Node : Node_Id;
1996 Decls : List_Id) return Boolean
1998 Item : Node_Id := First (Decls);
2001 -- Only other pragmas can come before this pragma
2004 if No (Item) or else Nkind (Item) /= N_Pragma then
2007 elsif Item = Pragma_Node then
2013 end Is_Before_First_Decl;
2015 -----------------------------
2016 -- Is_Configuration_Pragma --
2017 -----------------------------
2019 -- A configuration pragma must appear in the context clause of a
2020 -- compilation unit, and only other pragmas may precede it. Note that
2021 -- the test below also permits use in a configuration pragma file.
2023 function Is_Configuration_Pragma return Boolean is
2024 Lis : constant List_Id := List_Containing (N);
2025 Par : constant Node_Id := Parent (N);
2029 -- If no parent, then we are in the configuration pragma file,
2030 -- so the placement is definitely appropriate.
2035 -- Otherwise we must be in the context clause of a compilation unit
2036 -- and the only thing allowed before us in the context list is more
2037 -- configuration pragmas.
2039 elsif Nkind (Par) = N_Compilation_Unit
2040 and then Context_Items (Par) = Lis
2047 elsif Nkind (Prg) /= N_Pragma then
2057 end Is_Configuration_Pragma;
2059 --------------------------
2060 -- Is_In_Context_Clause --
2061 --------------------------
2063 function Is_In_Context_Clause return Boolean is
2065 Parent_Node : Node_Id;
2068 if not Is_List_Member (N) then
2072 Plist := List_Containing (N);
2073 Parent_Node := Parent (Plist);
2075 if Parent_Node = Empty
2076 or else Nkind (Parent_Node) /= N_Compilation_Unit
2077 or else Context_Items (Parent_Node) /= Plist
2084 end Is_In_Context_Clause;
2086 ---------------------------------
2087 -- Is_Static_String_Expression --
2088 ---------------------------------
2090 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
2091 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
2094 Analyze_And_Resolve (Argx);
2095 return Is_OK_Static_Expression (Argx)
2096 and then Nkind (Argx) = N_String_Literal;
2097 end Is_Static_String_Expression;
2099 ----------------------
2100 -- Pragma_Misplaced --
2101 ----------------------
2103 procedure Pragma_Misplaced is
2105 Error_Pragma ("incorrect placement of pragma%");
2106 end Pragma_Misplaced;
2108 ------------------------------------
2109 -- Process Atomic_Shared_Volatile --
2110 ------------------------------------
2112 procedure Process_Atomic_Shared_Volatile is
2119 procedure Set_Atomic (E : Entity_Id);
2120 -- Set given type as atomic, and if no explicit alignment was given,
2121 -- set alignment to unknown, since back end knows what the alignment
2122 -- requirements are for atomic arrays. Note: this step is necessary
2123 -- for derived types.
2129 procedure Set_Atomic (E : Entity_Id) is
2133 if not Has_Alignment_Clause (E) then
2134 Set_Alignment (E, Uint_0);
2138 -- Start of processing for Process_Atomic_Shared_Volatile
2141 Check_Ada_83_Warning;
2142 Check_No_Identifiers;
2143 Check_Arg_Count (1);
2144 Check_Arg_Is_Local_Name (Arg1);
2145 E_Id := Expression (Arg1);
2147 if Etype (E_Id) = Any_Type then
2152 D := Declaration_Node (E);
2156 if Rep_Item_Too_Early (E, N)
2158 Rep_Item_Too_Late (E, N)
2162 Check_First_Subtype (Arg1);
2165 if Prag_Id /= Pragma_Volatile then
2167 Set_Atomic (Underlying_Type (E));
2168 Set_Atomic (Base_Type (E));
2171 -- Attribute belongs on the base type. If the view of the type is
2172 -- currently private, it also belongs on the underlying type.
2174 Set_Is_Volatile (Base_Type (E));
2175 Set_Is_Volatile (Underlying_Type (E));
2177 Set_Treat_As_Volatile (E);
2178 Set_Treat_As_Volatile (Underlying_Type (E));
2180 elsif K = N_Object_Declaration
2181 or else (K = N_Component_Declaration
2182 and then Original_Record_Component (E) = E)
2184 if Rep_Item_Too_Late (E, N) then
2188 if Prag_Id /= Pragma_Volatile then
2191 -- If the object declaration has an explicit initialization, a
2192 -- temporary may have to be created to hold the expression, to
2193 -- ensure that access to the object remain atomic.
2195 if Nkind (Parent (E)) = N_Object_Declaration
2196 and then Present (Expression (Parent (E)))
2198 Set_Has_Delayed_Freeze (E);
2201 -- An interesting improvement here. If an object of type X is
2202 -- declared atomic, and the type X is not atomic, that's a
2203 -- pity, since it may not have appropriate alignment etc. We
2204 -- can rescue this in the special case where the object and
2205 -- type are in the same unit by just setting the type as
2206 -- atomic, so that the back end will process it as atomic.
2208 Utyp := Underlying_Type (Etype (E));
2211 and then Sloc (E) > No_Location
2212 and then Sloc (Utyp) > No_Location
2214 Get_Source_File_Index (Sloc (E)) =
2215 Get_Source_File_Index (Sloc (Underlying_Type (Etype (E))))
2217 Set_Is_Atomic (Underlying_Type (Etype (E)));
2221 Set_Is_Volatile (E);
2222 Set_Treat_As_Volatile (E);
2226 ("inappropriate entity for pragma%", Arg1);
2228 end Process_Atomic_Shared_Volatile;
2230 -------------------------------------------
2231 -- Process_Compile_Time_Warning_Or_Error --
2232 -------------------------------------------
2234 procedure Process_Compile_Time_Warning_Or_Error is
2235 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
2238 Check_Arg_Count (2);
2239 Check_No_Identifiers;
2240 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
2241 Analyze_And_Resolve (Arg1x, Standard_Boolean);
2243 if Compile_Time_Known_Value (Arg1x) then
2244 if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
2246 Str : constant String_Id :=
2247 Strval (Get_Pragma_Arg (Arg2));
2248 Len : constant Int := String_Length (Str);
2253 Cent : constant Entity_Id :=
2254 Cunit_Entity (Current_Sem_Unit);
2256 Force : constant Boolean :=
2257 Prag_Id = Pragma_Compile_Time_Warning
2259 Is_Spec_Name (Unit_Name (Current_Sem_Unit))
2260 and then (Ekind (Cent) /= E_Package
2261 or else not In_Private_Part (Cent));
2262 -- Set True if this is the warning case, and we are in the
2263 -- visible part of a package spec, or in a subprogram spec,
2264 -- in which case we want to force the client to see the
2265 -- warning, even though it is not in the main unit.
2268 -- Loop through segments of message separated by line feeds.
2269 -- We output these segments as separate messages with
2270 -- continuation marks for all but the first.
2275 Error_Msg_Strlen := 0;
2277 -- Loop to copy characters from argument to error message
2281 exit when Ptr > Len;
2282 CC := Get_String_Char (Str, Ptr);
2285 -- Ignore wide chars ??? else store character
2287 if In_Character_Range (CC) then
2288 C := Get_Character (CC);
2289 exit when C = ASCII.LF;
2290 Error_Msg_Strlen := Error_Msg_Strlen + 1;
2291 Error_Msg_String (Error_Msg_Strlen) := C;
2295 -- Here with one line ready to go
2297 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
2299 -- If this is a warning in a spec, then we want clients
2300 -- to see the warning, so mark the message with the
2301 -- special sequence !! to force the warning. In the case
2302 -- of a package spec, we do not force this if we are in
2303 -- the private part of the spec.
2306 if Cont = False then
2307 Error_Msg_N ("<~!!", Arg1);
2310 Error_Msg_N ("\<~!!", Arg1);
2313 -- Error, rather than warning, or in a body, so we do not
2314 -- need to force visibility for client (error will be
2315 -- output in any case, and this is the situation in which
2316 -- we do not want a client to get a warning, since the
2317 -- warning is in the body or the spec private part.
2320 if Cont = False then
2321 Error_Msg_N ("<~", Arg1);
2324 Error_Msg_N ("\<~", Arg1);
2328 exit when Ptr > Len;
2333 end Process_Compile_Time_Warning_Or_Error;
2335 ------------------------
2336 -- Process_Convention --
2337 ------------------------
2339 procedure Process_Convention
2340 (C : out Convention_Id;
2341 Ent : out Entity_Id)
2347 Comp_Unit : Unit_Number_Type;
2349 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
2350 -- Called if we have more than one Export/Import/Convention pragma.
2351 -- This is generally illegal, but we have a special case of allowing
2352 -- Import and Interface to coexist if they specify the convention in
2353 -- a consistent manner. We are allowed to do this, since Interface is
2354 -- an implementation defined pragma, and we choose to do it since we
2355 -- know Rational allows this combination. S is the entity id of the
2356 -- subprogram in question. This procedure also sets the special flag
2357 -- Import_Interface_Present in both pragmas in the case where we do
2358 -- have matching Import and Interface pragmas.
2360 procedure Set_Convention_From_Pragma (E : Entity_Id);
2361 -- Set convention in entity E, and also flag that the entity has a
2362 -- convention pragma. If entity is for a private or incomplete type,
2363 -- also set convention and flag on underlying type. This procedure
2364 -- also deals with the special case of C_Pass_By_Copy convention.
2366 -------------------------------
2367 -- Diagnose_Multiple_Pragmas --
2368 -------------------------------
2370 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
2371 Pdec : constant Node_Id := Declaration_Node (S);
2375 function Same_Convention (Decl : Node_Id) return Boolean;
2376 -- Decl is a pragma node. This function returns True if this
2377 -- pragma has a first argument that is an identifier with a
2378 -- Chars field corresponding to the Convention_Id C.
2380 function Same_Name (Decl : Node_Id) return Boolean;
2381 -- Decl is a pragma node. This function returns True if this
2382 -- pragma has a second argument that is an identifier with a
2383 -- Chars field that matches the Chars of the current subprogram.
2385 ---------------------
2386 -- Same_Convention --
2387 ---------------------
2389 function Same_Convention (Decl : Node_Id) return Boolean is
2390 Arg1 : constant Node_Id :=
2391 First (Pragma_Argument_Associations (Decl));
2394 if Present (Arg1) then
2396 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
2398 if Nkind (Arg) = N_Identifier
2399 and then Is_Convention_Name (Chars (Arg))
2400 and then Get_Convention_Id (Chars (Arg)) = C
2408 end Same_Convention;
2414 function Same_Name (Decl : Node_Id) return Boolean is
2415 Arg1 : constant Node_Id :=
2416 First (Pragma_Argument_Associations (Decl));
2424 Arg2 := Next (Arg1);
2431 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
2433 if Nkind (Arg) = N_Identifier
2434 and then Chars (Arg) = Chars (S)
2443 -- Start of processing for Diagnose_Multiple_Pragmas
2448 -- Definitely give message if we have Convention/Export here
2450 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
2453 -- If we have an Import or Export, scan back from pragma to
2454 -- find any previous pragma applying to the same procedure.
2455 -- The scan will be terminated by the start of the list, or
2456 -- hitting the subprogram declaration. This won't allow one
2457 -- pragma to appear in the public part and one in the private
2458 -- part, but that seems very unlikely in practice.
2462 while Present (Decl) and then Decl /= Pdec loop
2464 -- Look for pragma with same name as us
2466 if Nkind (Decl) = N_Pragma
2467 and then Same_Name (Decl)
2469 -- Give error if same as our pragma or Export/Convention
2471 if Pragma_Name (Decl) = Name_Export
2473 Pragma_Name (Decl) = Name_Convention
2475 Pragma_Name (Decl) = Pragma_Name (N)
2479 -- Case of Import/Interface or the other way round
2481 elsif Pragma_Name (Decl) = Name_Interface
2483 Pragma_Name (Decl) = Name_Import
2485 -- Here we know that we have Import and Interface. It
2486 -- doesn't matter which way round they are. See if
2487 -- they specify the same convention. If so, all OK,
2488 -- and set special flags to stop other messages
2490 if Same_Convention (Decl) then
2491 Set_Import_Interface_Present (N);
2492 Set_Import_Interface_Present (Decl);
2495 -- If different conventions, special message
2498 Error_Msg_Sloc := Sloc (Decl);
2500 ("convention differs from that given#", Arg1);
2510 -- Give message if needed if we fall through those tests
2514 ("at most one Convention/Export/Import pragma is allowed",
2517 end Diagnose_Multiple_Pragmas;
2519 --------------------------------
2520 -- Set_Convention_From_Pragma --
2521 --------------------------------
2523 procedure Set_Convention_From_Pragma (E : Entity_Id) is
2525 -- Ada 2005 (AI-430): Check invalid attempt to change convention
2526 -- for an overridden dispatching operation. Technically this is
2527 -- an amendment and should only be done in Ada 2005 mode. However,
2528 -- this is clearly a mistake, since the problem that is addressed
2529 -- by this AI is that there is a clear gap in the RM!
2531 if Is_Dispatching_Operation (E)
2532 and then Present (Overridden_Operation (E))
2533 and then C /= Convention (Overridden_Operation (E))
2536 ("cannot change convention for " &
2537 "overridden dispatching operation",
2541 -- Set the convention
2543 Set_Convention (E, C);
2544 Set_Has_Convention_Pragma (E);
2546 if Is_Incomplete_Or_Private_Type (E) then
2547 Set_Convention (Underlying_Type (E), C);
2548 Set_Has_Convention_Pragma (Underlying_Type (E), True);
2551 -- A class-wide type should inherit the convention of the specific
2552 -- root type (although this isn't specified clearly by the RM).
2554 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
2555 Set_Convention (Class_Wide_Type (E), C);
2558 -- If the entity is a record type, then check for special case of
2559 -- C_Pass_By_Copy, which is treated the same as C except that the
2560 -- special record flag is set. This convention is only permitted
2561 -- on record types (see AI95-00131).
2563 if Cname = Name_C_Pass_By_Copy then
2564 if Is_Record_Type (E) then
2565 Set_C_Pass_By_Copy (Base_Type (E));
2566 elsif Is_Incomplete_Or_Private_Type (E)
2567 and then Is_Record_Type (Underlying_Type (E))
2569 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
2572 ("C_Pass_By_Copy convention allowed only for record type",
2577 -- If the entity is a derived boolean type, check for the special
2578 -- case of convention C, C++, or Fortran, where we consider any
2579 -- nonzero value to represent true.
2581 if Is_Discrete_Type (E)
2582 and then Root_Type (Etype (E)) = Standard_Boolean
2588 C = Convention_Fortran)
2590 Set_Nonzero_Is_True (Base_Type (E));
2592 end Set_Convention_From_Pragma;
2594 -- Start of processing for Process_Convention
2597 Check_At_Least_N_Arguments (2);
2598 Check_Optional_Identifier (Arg1, Name_Convention);
2599 Check_Arg_Is_Identifier (Arg1);
2600 Cname := Chars (Expression (Arg1));
2602 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
2603 -- tested again below to set the critical flag).
2604 if Cname = Name_C_Pass_By_Copy then
2607 -- Otherwise we must have something in the standard convention list
2609 elsif Is_Convention_Name (Cname) then
2610 C := Get_Convention_Id (Chars (Expression (Arg1)));
2612 -- In DEC VMS, it seems that there is an undocumented feature that
2613 -- any unrecognized convention is treated as the default, which for
2614 -- us is convention C. It does not seem so terrible to do this
2615 -- unconditionally, silently in the VMS case, and with a warning
2616 -- in the non-VMS case.
2619 if Warn_On_Export_Import and not OpenVMS_On_Target then
2621 ("?unrecognized convention name, C assumed",
2628 Check_Optional_Identifier (Arg2, Name_Entity);
2629 Check_Arg_Is_Local_Name (Arg2);
2631 Id := Expression (Arg2);
2634 if not Is_Entity_Name (Id) then
2635 Error_Pragma_Arg ("entity name required", Arg2);
2640 -- Set entity to return
2644 -- Go to renamed subprogram if present, since convention applies to
2645 -- the actual renamed entity, not to the renaming entity. If the
2646 -- subprogram is inherited, go to parent subprogram.
2648 if Is_Subprogram (E)
2649 and then Present (Alias (E))
2651 if Nkind (Parent (Declaration_Node (E))) =
2652 N_Subprogram_Renaming_Declaration
2654 if Scope (E) /= Scope (Alias (E)) then
2656 ("cannot apply pragma% to non-local entity&#", E);
2661 elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
2662 N_Private_Extension_Declaration)
2663 and then Scope (E) = Scope (Alias (E))
2667 -- Return the parent subprogram the entity was inherited from
2673 -- Check that we are not applying this to a specless body
2675 if Is_Subprogram (E)
2676 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
2679 ("pragma% requires separate spec and must come before body");
2682 -- Check that we are not applying this to a named constant
2684 if Ekind_In (E, E_Named_Integer, E_Named_Real) then
2685 Error_Msg_Name_1 := Pname;
2687 ("cannot apply pragma% to named constant!",
2688 Get_Pragma_Arg (Arg2));
2690 ("\supply appropriate type for&!", Arg2);
2693 if Ekind (E) = E_Enumeration_Literal then
2694 Error_Pragma ("enumeration literal not allowed for pragma%");
2697 -- Check for rep item appearing too early or too late
2699 if Etype (E) = Any_Type
2700 or else Rep_Item_Too_Early (E, N)
2704 E := Underlying_Type (E);
2707 if Rep_Item_Too_Late (E, N) then
2711 if Has_Convention_Pragma (E) then
2712 Diagnose_Multiple_Pragmas (E);
2714 elsif Convention (E) = Convention_Protected
2715 or else Ekind (Scope (E)) = E_Protected_Type
2718 ("a protected operation cannot be given a different convention",
2722 -- For Intrinsic, a subprogram is required
2724 if C = Convention_Intrinsic
2725 and then not Is_Subprogram (E)
2726 and then not Is_Generic_Subprogram (E)
2729 ("second argument of pragma% must be a subprogram", Arg2);
2732 -- For Stdcall, a subprogram, variable or subprogram type is required
2734 if C = Convention_Stdcall
2735 and then not Is_Subprogram (E)
2736 and then not Is_Generic_Subprogram (E)
2737 and then Ekind (E) /= E_Variable
2740 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
2743 ("second argument of pragma% must be subprogram (type)",
2747 if not Is_Subprogram (E)
2748 and then not Is_Generic_Subprogram (E)
2750 Set_Convention_From_Pragma (E);
2753 Check_First_Subtype (Arg2);
2754 Set_Convention_From_Pragma (Base_Type (E));
2756 -- For subprograms, we must set the convention on the
2757 -- internally generated directly designated type as well.
2759 if Ekind (E) = E_Access_Subprogram_Type then
2760 Set_Convention_From_Pragma (Directly_Designated_Type (E));
2764 -- For the subprogram case, set proper convention for all homonyms
2765 -- in same scope and the same declarative part, i.e. the same
2766 -- compilation unit.
2769 Comp_Unit := Get_Source_Unit (E);
2770 Set_Convention_From_Pragma (E);
2772 -- Treat a pragma Import as an implicit body, for GPS use
2774 if Prag_Id = Pragma_Import then
2775 Generate_Reference (E, Id, 'b');
2778 -- Loop through the homonyms of the pragma argument's entity
2783 exit when No (E1) or else Scope (E1) /= Current_Scope;
2785 -- Do not set the pragma on inherited operations or on formal
2788 if Comes_From_Source (E1)
2789 and then Comp_Unit = Get_Source_Unit (E1)
2790 and then not Is_Formal_Subprogram (E1)
2791 and then Nkind (Original_Node (Parent (E1))) /=
2792 N_Full_Type_Declaration
2794 if Present (Alias (E1))
2795 and then Scope (E1) /= Scope (Alias (E1))
2798 ("cannot apply pragma% to non-local entity& declared#",
2802 Set_Convention_From_Pragma (E1);
2804 if Prag_Id = Pragma_Import then
2805 Generate_Reference (E1, Id, 'b');
2810 end Process_Convention;
2812 -----------------------------------------------------
2813 -- Process_Extended_Import_Export_Exception_Pragma --
2814 -----------------------------------------------------
2816 procedure Process_Extended_Import_Export_Exception_Pragma
2817 (Arg_Internal : Node_Id;
2818 Arg_External : Node_Id;
2826 if not OpenVMS_On_Target then
2828 ("?pragma% ignored (applies only to Open'V'M'S)");
2831 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
2832 Def_Id := Entity (Arg_Internal);
2834 if Ekind (Def_Id) /= E_Exception then
2836 ("pragma% must refer to declared exception", Arg_Internal);
2839 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
2841 if Present (Arg_Form) then
2842 Check_Arg_Is_One_Of (Arg_Form, Name_Ada, Name_VMS);
2845 if Present (Arg_Form)
2846 and then Chars (Arg_Form) = Name_Ada
2850 Set_Is_VMS_Exception (Def_Id);
2851 Set_Exception_Code (Def_Id, No_Uint);
2854 if Present (Arg_Code) then
2855 if not Is_VMS_Exception (Def_Id) then
2857 ("Code option for pragma% not allowed for Ada case",
2861 Check_Arg_Is_Static_Expression (Arg_Code, Any_Integer);
2862 Code_Val := Expr_Value (Arg_Code);
2864 if not UI_Is_In_Int_Range (Code_Val) then
2866 ("Code option for pragma% must be in 32-bit range",
2870 Set_Exception_Code (Def_Id, Code_Val);
2873 end Process_Extended_Import_Export_Exception_Pragma;
2875 -------------------------------------------------
2876 -- Process_Extended_Import_Export_Internal_Arg --
2877 -------------------------------------------------
2879 procedure Process_Extended_Import_Export_Internal_Arg
2880 (Arg_Internal : Node_Id := Empty)
2883 if No (Arg_Internal) then
2884 Error_Pragma ("Internal parameter required for pragma%");
2887 if Nkind (Arg_Internal) = N_Identifier then
2890 elsif Nkind (Arg_Internal) = N_Operator_Symbol
2891 and then (Prag_Id = Pragma_Import_Function
2893 Prag_Id = Pragma_Export_Function)
2899 ("wrong form for Internal parameter for pragma%", Arg_Internal);
2902 Check_Arg_Is_Local_Name (Arg_Internal);
2903 end Process_Extended_Import_Export_Internal_Arg;
2905 --------------------------------------------------
2906 -- Process_Extended_Import_Export_Object_Pragma --
2907 --------------------------------------------------
2909 procedure Process_Extended_Import_Export_Object_Pragma
2910 (Arg_Internal : Node_Id;
2911 Arg_External : Node_Id;
2917 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
2918 Def_Id := Entity (Arg_Internal);
2920 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
2922 ("pragma% must designate an object", Arg_Internal);
2925 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
2927 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
2930 ("previous Common/Psect_Object applies, pragma % not permitted",
2934 if Rep_Item_Too_Late (Def_Id, N) then
2938 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
2940 if Present (Arg_Size) then
2941 Check_Arg_Is_External_Name (Arg_Size);
2944 -- Export_Object case
2946 if Prag_Id = Pragma_Export_Object then
2947 if not Is_Library_Level_Entity (Def_Id) then
2949 ("argument for pragma% must be library level entity",
2953 if Ekind (Current_Scope) = E_Generic_Package then
2954 Error_Pragma ("pragma& cannot appear in a generic unit");
2957 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
2959 ("exported object must have compile time known size",
2963 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
2964 Error_Msg_N ("?duplicate Export_Object pragma", N);
2966 Set_Exported (Def_Id, Arg_Internal);
2969 -- Import_Object case
2972 if Is_Concurrent_Type (Etype (Def_Id)) then
2974 ("cannot use pragma% for task/protected object",
2978 if Ekind (Def_Id) = E_Constant then
2980 ("cannot import a constant", Arg_Internal);
2983 if Warn_On_Export_Import
2984 and then Has_Discriminants (Etype (Def_Id))
2987 ("imported value must be initialized?", Arg_Internal);
2990 if Warn_On_Export_Import
2991 and then Is_Access_Type (Etype (Def_Id))
2994 ("cannot import object of an access type?", Arg_Internal);
2997 if Warn_On_Export_Import
2998 and then Is_Imported (Def_Id)
3001 ("?duplicate Import_Object pragma", N);
3003 -- Check for explicit initialization present. Note that an
3004 -- initialization generated by the code generator, e.g. for an
3005 -- access type, does not count here.
3007 elsif Present (Expression (Parent (Def_Id)))
3010 (Original_Node (Expression (Parent (Def_Id))))
3012 Error_Msg_Sloc := Sloc (Def_Id);
3014 ("imported entities cannot be initialized (RM B.1(24))",
3015 "\no initialization allowed for & declared#", Arg1);
3017 Set_Imported (Def_Id);
3018 Note_Possible_Modification (Arg_Internal, Sure => False);
3021 end Process_Extended_Import_Export_Object_Pragma;
3023 ------------------------------------------------------
3024 -- Process_Extended_Import_Export_Subprogram_Pragma --
3025 ------------------------------------------------------
3027 procedure Process_Extended_Import_Export_Subprogram_Pragma
3028 (Arg_Internal : Node_Id;
3029 Arg_External : Node_Id;
3030 Arg_Parameter_Types : Node_Id;
3031 Arg_Result_Type : Node_Id := Empty;
3032 Arg_Mechanism : Node_Id;
3033 Arg_Result_Mechanism : Node_Id := Empty;
3034 Arg_First_Optional_Parameter : Node_Id := Empty)
3040 Ambiguous : Boolean;
3044 function Same_Base_Type
3046 Formal : Entity_Id) return Boolean;
3047 -- Determines if Ptype references the type of Formal. Note that only
3048 -- the base types need to match according to the spec. Ptype here is
3049 -- the argument from the pragma, which is either a type name, or an
3050 -- access attribute.
3052 --------------------
3053 -- Same_Base_Type --
3054 --------------------
3056 function Same_Base_Type
3058 Formal : Entity_Id) return Boolean
3060 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
3064 -- Case where pragma argument is typ'Access
3066 if Nkind (Ptype) = N_Attribute_Reference
3067 and then Attribute_Name (Ptype) = Name_Access
3069 Pref := Prefix (Ptype);
3072 if not Is_Entity_Name (Pref)
3073 or else Entity (Pref) = Any_Type
3078 -- We have a match if the corresponding argument is of an
3079 -- anonymous access type, and its designated type matches the
3080 -- type of the prefix of the access attribute
3082 return Ekind (Ftyp) = E_Anonymous_Access_Type
3083 and then Base_Type (Entity (Pref)) =
3084 Base_Type (Etype (Designated_Type (Ftyp)));
3086 -- Case where pragma argument is a type name
3091 if not Is_Entity_Name (Ptype)
3092 or else Entity (Ptype) = Any_Type
3097 -- We have a match if the corresponding argument is of the type
3098 -- given in the pragma (comparing base types)
3100 return Base_Type (Entity (Ptype)) = Ftyp;
3104 -- Start of processing for
3105 -- Process_Extended_Import_Export_Subprogram_Pragma
3108 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
3112 -- Loop through homonyms (overloadings) of the entity
3114 Hom_Id := Entity (Arg_Internal);
3115 while Present (Hom_Id) loop
3116 Def_Id := Get_Base_Subprogram (Hom_Id);
3118 -- We need a subprogram in the current scope
3120 if not Is_Subprogram (Def_Id)
3121 or else Scope (Def_Id) /= Current_Scope
3128 -- Pragma cannot apply to subprogram body
3130 if Is_Subprogram (Def_Id)
3131 and then Nkind (Parent (Declaration_Node (Def_Id))) =
3135 ("pragma% requires separate spec"
3136 & " and must come before body");
3139 -- Test result type if given, note that the result type
3140 -- parameter can only be present for the function cases.
3142 if Present (Arg_Result_Type)
3143 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
3147 elsif Etype (Def_Id) /= Standard_Void_Type
3149 (Pname = Name_Export_Procedure
3151 Pname = Name_Import_Procedure)
3155 -- Test parameter types if given. Note that this parameter
3156 -- has not been analyzed (and must not be, since it is
3157 -- semantic nonsense), so we get it as the parser left it.
3159 elsif Present (Arg_Parameter_Types) then
3160 Check_Matching_Types : declare
3165 Formal := First_Formal (Def_Id);
3167 if Nkind (Arg_Parameter_Types) = N_Null then
3168 if Present (Formal) then
3172 -- A list of one type, e.g. (List) is parsed as
3173 -- a parenthesized expression.
3175 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
3176 and then Paren_Count (Arg_Parameter_Types) = 1
3179 or else Present (Next_Formal (Formal))
3184 Same_Base_Type (Arg_Parameter_Types, Formal);
3187 -- A list of more than one type is parsed as a aggregate
3189 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
3190 and then Paren_Count (Arg_Parameter_Types) = 0
3192 Ptype := First (Expressions (Arg_Parameter_Types));
3193 while Present (Ptype) or else Present (Formal) loop
3196 or else not Same_Base_Type (Ptype, Formal)
3201 Next_Formal (Formal);
3206 -- Anything else is of the wrong form
3210 ("wrong form for Parameter_Types parameter",
3211 Arg_Parameter_Types);
3213 end Check_Matching_Types;
3216 -- Match is now False if the entry we found did not match
3217 -- either a supplied Parameter_Types or Result_Types argument
3223 -- Ambiguous case, the flag Ambiguous shows if we already
3224 -- detected this and output the initial messages.
3227 if not Ambiguous then
3229 Error_Msg_Name_1 := Pname;
3231 ("pragma% does not uniquely identify subprogram!",
3233 Error_Msg_Sloc := Sloc (Ent);
3234 Error_Msg_N ("matching subprogram #!", N);
3238 Error_Msg_Sloc := Sloc (Def_Id);
3239 Error_Msg_N ("matching subprogram #!", N);
3244 Hom_Id := Homonym (Hom_Id);
3247 -- See if we found an entry
3250 if not Ambiguous then
3251 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
3253 ("pragma% cannot be given for generic subprogram");
3256 ("pragma% does not identify local subprogram");
3263 -- Import pragmas must be for imported entities
3265 if Prag_Id = Pragma_Import_Function
3267 Prag_Id = Pragma_Import_Procedure
3269 Prag_Id = Pragma_Import_Valued_Procedure
3271 if not Is_Imported (Ent) then
3273 ("pragma Import or Interface must precede pragma%");
3276 -- Here we have the Export case which can set the entity as exported
3278 -- But does not do so if the specified external name is null, since
3279 -- that is taken as a signal in DEC Ada 83 (with which we want to be
3280 -- compatible) to request no external name.
3282 elsif Nkind (Arg_External) = N_String_Literal
3283 and then String_Length (Strval (Arg_External)) = 0
3287 -- In all other cases, set entity as exported
3290 Set_Exported (Ent, Arg_Internal);
3293 -- Special processing for Valued_Procedure cases
3295 if Prag_Id = Pragma_Import_Valued_Procedure
3297 Prag_Id = Pragma_Export_Valued_Procedure
3299 Formal := First_Formal (Ent);
3302 Error_Pragma ("at least one parameter required for pragma%");
3304 elsif Ekind (Formal) /= E_Out_Parameter then
3305 Error_Pragma ("first parameter must have mode out for pragma%");
3308 Set_Is_Valued_Procedure (Ent);
3312 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
3314 -- Process Result_Mechanism argument if present. We have already
3315 -- checked that this is only allowed for the function case.
3317 if Present (Arg_Result_Mechanism) then
3318 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
3321 -- Process Mechanism parameter if present. Note that this parameter
3322 -- is not analyzed, and must not be analyzed since it is semantic
3323 -- nonsense, so we get it in exactly as the parser left it.
3325 if Present (Arg_Mechanism) then
3333 -- A single mechanism association without a formal parameter
3334 -- name is parsed as a parenthesized expression. All other
3335 -- cases are parsed as aggregates, so we rewrite the single
3336 -- parameter case as an aggregate for consistency.
3338 if Nkind (Arg_Mechanism) /= N_Aggregate
3339 and then Paren_Count (Arg_Mechanism) = 1
3341 Rewrite (Arg_Mechanism,
3342 Make_Aggregate (Sloc (Arg_Mechanism),
3343 Expressions => New_List (
3344 Relocate_Node (Arg_Mechanism))));
3347 -- Case of only mechanism name given, applies to all formals
3349 if Nkind (Arg_Mechanism) /= N_Aggregate then
3350 Formal := First_Formal (Ent);
3351 while Present (Formal) loop
3352 Set_Mechanism_Value (Formal, Arg_Mechanism);
3353 Next_Formal (Formal);
3356 -- Case of list of mechanism associations given
3359 if Null_Record_Present (Arg_Mechanism) then
3361 ("inappropriate form for Mechanism parameter",
3365 -- Deal with positional ones first
3367 Formal := First_Formal (Ent);
3369 if Present (Expressions (Arg_Mechanism)) then
3370 Mname := First (Expressions (Arg_Mechanism));
3371 while Present (Mname) loop
3374 ("too many mechanism associations", Mname);
3377 Set_Mechanism_Value (Formal, Mname);
3378 Next_Formal (Formal);
3383 -- Deal with named entries
3385 if Present (Component_Associations (Arg_Mechanism)) then
3386 Massoc := First (Component_Associations (Arg_Mechanism));
3387 while Present (Massoc) loop
3388 Choice := First (Choices (Massoc));
3390 if Nkind (Choice) /= N_Identifier
3391 or else Present (Next (Choice))
3394 ("incorrect form for mechanism association",
3398 Formal := First_Formal (Ent);
3402 ("parameter name & not present", Choice);
3405 if Chars (Choice) = Chars (Formal) then
3407 (Formal, Expression (Massoc));
3409 -- Set entity on identifier for ASIS
3411 Set_Entity (Choice, Formal);
3416 Next_Formal (Formal);
3426 -- Process First_Optional_Parameter argument if present. We have
3427 -- already checked that this is only allowed for the Import case.
3429 if Present (Arg_First_Optional_Parameter) then
3430 if Nkind (Arg_First_Optional_Parameter) /= N_Identifier then
3432 ("first optional parameter must be formal parameter name",
3433 Arg_First_Optional_Parameter);
3436 Formal := First_Formal (Ent);
3440 ("specified formal parameter& not found",
3441 Arg_First_Optional_Parameter);
3444 exit when Chars (Formal) =
3445 Chars (Arg_First_Optional_Parameter);
3447 Next_Formal (Formal);
3450 Set_First_Optional_Parameter (Ent, Formal);
3452 -- Check specified and all remaining formals have right form
3454 while Present (Formal) loop
3455 if Ekind (Formal) /= E_In_Parameter then
3457 ("optional formal& is not of mode in!",
3458 Arg_First_Optional_Parameter, Formal);
3461 Dval := Default_Value (Formal);
3465 ("optional formal& does not have default value!",
3466 Arg_First_Optional_Parameter, Formal);
3468 elsif Compile_Time_Known_Value_Or_Aggr (Dval) then
3473 ("default value for optional formal& is non-static!",
3474 Arg_First_Optional_Parameter, Formal);
3478 Set_Is_Optional_Parameter (Formal);
3479 Next_Formal (Formal);
3482 end Process_Extended_Import_Export_Subprogram_Pragma;
3484 --------------------------
3485 -- Process_Generic_List --
3486 --------------------------
3488 procedure Process_Generic_List is
3493 Check_No_Identifiers;
3494 Check_At_Least_N_Arguments (1);
3497 while Present (Arg) loop
3498 Exp := Expression (Arg);
3501 if not Is_Entity_Name (Exp)
3503 (not Is_Generic_Instance (Entity (Exp))
3505 not Is_Generic_Unit (Entity (Exp)))
3508 ("pragma% argument must be name of generic unit/instance",
3514 end Process_Generic_List;
3516 ---------------------------------
3517 -- Process_Import_Or_Interface --
3518 ---------------------------------
3520 procedure Process_Import_Or_Interface is
3526 Process_Convention (C, Def_Id);
3527 Kill_Size_Check_Code (Def_Id);
3528 Note_Possible_Modification (Expression (Arg2), Sure => False);
3530 if Ekind_In (Def_Id, E_Variable, E_Constant) then
3532 -- We do not permit Import to apply to a renaming declaration
3534 if Present (Renamed_Object (Def_Id)) then
3536 ("pragma% not allowed for object renaming", Arg2);
3538 -- User initialization is not allowed for imported object, but
3539 -- the object declaration may contain a default initialization,
3540 -- that will be discarded. Note that an explicit initialization
3541 -- only counts if it comes from source, otherwise it is simply
3542 -- the code generator making an implicit initialization explicit.
3544 elsif Present (Expression (Parent (Def_Id)))
3545 and then Comes_From_Source (Expression (Parent (Def_Id)))
3547 Error_Msg_Sloc := Sloc (Def_Id);
3549 ("no initialization allowed for declaration of& #",
3550 "\imported entities cannot be initialized (RM B.1(24))",
3554 Set_Imported (Def_Id);
3555 Process_Interface_Name (Def_Id, Arg3, Arg4);
3557 -- Note that we do not set Is_Public here. That's because we
3558 -- only want to set it if there is no address clause, and we
3559 -- don't know that yet, so we delay that processing till
3562 -- pragma Import completes deferred constants
3564 if Ekind (Def_Id) = E_Constant then
3565 Set_Has_Completion (Def_Id);
3568 -- It is not possible to import a constant of an unconstrained
3569 -- array type (e.g. string) because there is no simple way to
3570 -- write a meaningful subtype for it.
3572 if Is_Array_Type (Etype (Def_Id))
3573 and then not Is_Constrained (Etype (Def_Id))
3576 ("imported constant& must have a constrained subtype",
3581 elsif Is_Subprogram (Def_Id)
3582 or else Is_Generic_Subprogram (Def_Id)
3584 -- If the name is overloaded, pragma applies to all of the
3585 -- denoted entities in the same declarative part.
3588 while Present (Hom_Id) loop
3589 Def_Id := Get_Base_Subprogram (Hom_Id);
3591 -- Ignore inherited subprograms because the pragma will
3592 -- apply to the parent operation, which is the one called.
3594 if Is_Overloadable (Def_Id)
3595 and then Present (Alias (Def_Id))
3599 -- If it is not a subprogram, it must be in an outer scope and
3600 -- pragma does not apply.
3602 elsif not Is_Subprogram (Def_Id)
3603 and then not Is_Generic_Subprogram (Def_Id)
3607 -- Verify that the homonym is in the same declarative part (not
3608 -- just the same scope).
3610 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
3611 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
3616 Set_Imported (Def_Id);
3618 -- Reject an Import applied to an abstract subprogram
3620 if Is_Subprogram (Def_Id)
3621 and then Is_Abstract_Subprogram (Def_Id)
3623 Error_Msg_Sloc := Sloc (Def_Id);
3625 ("cannot import abstract subprogram& declared#",
3629 -- Special processing for Convention_Intrinsic
3631 if C = Convention_Intrinsic then
3633 -- Link_Name argument not allowed for intrinsic
3636 and then Chars (Arg3) = Name_Link_Name
3641 if Present (Arg4) then
3643 ("Link_Name argument not allowed for " &
3648 Set_Is_Intrinsic_Subprogram (Def_Id);
3650 -- If no external name is present, then check that this
3651 -- is a valid intrinsic subprogram. If an external name
3652 -- is present, then this is handled by the back end.
3655 Check_Intrinsic_Subprogram (Def_Id, Expression (Arg2));
3659 -- All interfaced procedures need an external symbol created
3660 -- for them since they are always referenced from another
3663 Set_Is_Public (Def_Id);
3665 -- Verify that the subprogram does not have a completion
3666 -- through a renaming declaration. For other completions the
3667 -- pragma appears as a too late representation.
3670 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
3674 and then Nkind (Decl) = N_Subprogram_Declaration
3675 and then Present (Corresponding_Body (Decl))
3676 and then Nkind (Unit_Declaration_Node
3677 (Corresponding_Body (Decl))) =
3678 N_Subprogram_Renaming_Declaration
3680 Error_Msg_Sloc := Sloc (Def_Id);
3682 ("cannot import&, renaming already provided for " &
3683 "declaration #", N, Def_Id);
3687 Set_Has_Completion (Def_Id);
3688 Process_Interface_Name (Def_Id, Arg3, Arg4);
3691 if Is_Compilation_Unit (Hom_Id) then
3693 -- Its possible homonyms are not affected by the pragma.
3694 -- Such homonyms might be present in the context of other
3695 -- units being compiled.
3700 Hom_Id := Homonym (Hom_Id);
3704 -- When the convention is Java or CIL, we also allow Import to be
3705 -- given for packages, generic packages, exceptions, record
3706 -- components, and access to subprograms.
3708 elsif (C = Convention_Java or else C = Convention_CIL)
3710 (Is_Package_Or_Generic_Package (Def_Id)
3711 or else Ekind (Def_Id) = E_Exception
3712 or else Ekind (Def_Id) = E_Access_Subprogram_Type
3713 or else Nkind (Parent (Def_Id)) = N_Component_Declaration)
3715 Set_Imported (Def_Id);
3716 Set_Is_Public (Def_Id);
3717 Process_Interface_Name (Def_Id, Arg3, Arg4);
3719 -- Import a CPP class
3721 elsif Is_Record_Type (Def_Id)
3722 and then C = Convention_CPP
3724 -- Types treated as CPP classes are treated as limited, but we
3725 -- don't require them to be declared this way. A warning is
3726 -- issued to encourage the user to declare them as limited.
3727 -- This is not an error, for compatibility reasons, because
3728 -- these types have been supported this way for some time.
3730 if not Is_Limited_Type (Def_Id) then
3732 ("imported 'C'P'P type should be " &
3733 "explicitly declared limited?",
3734 Get_Pragma_Arg (Arg2));
3736 ("\type will be considered limited",
3737 Get_Pragma_Arg (Arg2));
3740 Set_Is_CPP_Class (Def_Id);
3741 Set_Is_Limited_Record (Def_Id);
3743 -- Imported CPP types must not have discriminants (because C++
3744 -- classes do not have discriminants).
3746 if Has_Discriminants (Def_Id) then
3748 ("imported 'C'P'P type cannot have discriminants",
3749 First (Discriminant_Specifications
3750 (Declaration_Node (Def_Id))));
3753 -- Components of imported CPP types must not have default
3754 -- expressions because the constructor (if any) is on the
3758 Tdef : constant Node_Id :=
3759 Type_Definition (Declaration_Node (Def_Id));
3764 if Nkind (Tdef) = N_Record_Definition then
3765 Clist := Component_List (Tdef);
3768 pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition);
3769 Clist := Component_List (Record_Extension_Part (Tdef));
3772 if Present (Clist) then
3773 Comp := First (Component_Items (Clist));
3774 while Present (Comp) loop
3775 if Present (Expression (Comp)) then
3777 ("component of imported 'C'P'P type cannot have" &
3778 " default expression", Expression (Comp));
3788 ("second argument of pragma% must be object or subprogram",
3792 -- If this pragma applies to a compilation unit, then the unit, which
3793 -- is a subprogram, does not require (or allow) a body. We also do
3794 -- not need to elaborate imported procedures.
3796 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
3798 Cunit : constant Node_Id := Parent (Parent (N));
3800 Set_Body_Required (Cunit, False);
3803 end Process_Import_Or_Interface;
3805 --------------------
3806 -- Process_Inline --
3807 --------------------
3809 procedure Process_Inline (Active : Boolean) is
3815 Effective : Boolean := False;
3817 procedure Make_Inline (Subp : Entity_Id);
3818 -- Subp is the defining unit name of the subprogram declaration. Set
3819 -- the flag, as well as the flag in the corresponding body, if there
3822 procedure Set_Inline_Flags (Subp : Entity_Id);
3823 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
3824 -- Has_Pragma_Inline_Always for the Inline_Always case.
3826 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
3827 -- Returns True if it can be determined at this stage that inlining
3828 -- is not possible, for example if the body is available and contains
3829 -- exception handlers, we prevent inlining, since otherwise we can
3830 -- get undefined symbols at link time. This function also emits a
3831 -- warning if front-end inlining is enabled and the pragma appears
3834 -- ??? is business with link symbols still valid, or does it relate
3835 -- to front end ZCX which is being phased out ???
3837 ---------------------------
3838 -- Inlining_Not_Possible --
3839 ---------------------------
3841 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
3842 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
3846 if Nkind (Decl) = N_Subprogram_Body then
3847 Stats := Handled_Statement_Sequence (Decl);
3848 return Present (Exception_Handlers (Stats))
3849 or else Present (At_End_Proc (Stats));
3851 elsif Nkind (Decl) = N_Subprogram_Declaration
3852 and then Present (Corresponding_Body (Decl))
3854 if Front_End_Inlining
3855 and then Analyzed (Corresponding_Body (Decl))
3857 Error_Msg_N ("pragma appears too late, ignored?", N);
3860 -- If the subprogram is a renaming as body, the body is just a
3861 -- call to the renamed subprogram, and inlining is trivially
3865 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
3866 N_Subprogram_Renaming_Declaration
3872 Handled_Statement_Sequence
3873 (Unit_Declaration_Node (Corresponding_Body (Decl)));
3876 Present (Exception_Handlers (Stats))
3877 or else Present (At_End_Proc (Stats));
3881 -- If body is not available, assume the best, the check is
3882 -- performed again when compiling enclosing package bodies.
3886 end Inlining_Not_Possible;
3892 procedure Make_Inline (Subp : Entity_Id) is
3893 Kind : constant Entity_Kind := Ekind (Subp);
3894 Inner_Subp : Entity_Id := Subp;
3897 -- Ignore if bad type, avoid cascaded error
3899 if Etype (Subp) = Any_Type then
3903 -- Ignore if all inlining is suppressed
3905 elsif Suppress_All_Inlining then
3909 -- If inlining is not possible, for now do not treat as an error
3911 elsif Inlining_Not_Possible (Subp) then
3915 -- Here we have a candidate for inlining, but we must exclude
3916 -- derived operations. Otherwise we would end up trying to inline
3917 -- a phantom declaration, and the result would be to drag in a
3918 -- body which has no direct inlining associated with it. That
3919 -- would not only be inefficient but would also result in the
3920 -- backend doing cross-unit inlining in cases where it was
3921 -- definitely inappropriate to do so.
3923 -- However, a simple Comes_From_Source test is insufficient, since
3924 -- we do want to allow inlining of generic instances which also do
3925 -- not come from source. We also need to recognize specs generated
3926 -- by the front-end for bodies that carry the pragma. Finally,
3927 -- predefined operators do not come from source but are not
3928 -- inlineable either.
3930 elsif Is_Generic_Instance (Subp)
3931 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
3935 elsif not Comes_From_Source (Subp)
3936 and then Scope (Subp) /= Standard_Standard
3942 -- The referenced entity must either be the enclosing entity, or
3943 -- an entity declared within the current open scope.
3945 if Present (Scope (Subp))
3946 and then Scope (Subp) /= Current_Scope
3947 and then Subp /= Current_Scope
3950 ("argument of% must be entity in current scope", Assoc);
3954 -- Processing for procedure, operator or function. If subprogram
3955 -- is aliased (as for an instance) indicate that the renamed
3956 -- entity (if declared in the same unit) is inlined.
3958 if Is_Subprogram (Subp) then
3959 Inner_Subp := Ultimate_Alias (Inner_Subp);
3961 if In_Same_Source_Unit (Subp, Inner_Subp) then
3962 Set_Inline_Flags (Inner_Subp);
3964 Decl := Parent (Parent (Inner_Subp));
3966 if Nkind (Decl) = N_Subprogram_Declaration
3967 and then Present (Corresponding_Body (Decl))
3969 Set_Inline_Flags (Corresponding_Body (Decl));
3971 elsif Is_Generic_Instance (Subp) then
3973 -- Indicate that the body needs to be created for
3974 -- inlining subsequent calls. The instantiation node
3975 -- follows the declaration of the wrapper package
3978 if Scope (Subp) /= Standard_Standard
3980 Need_Subprogram_Instance_Body
3981 (Next (Unit_Declaration_Node (Scope (Alias (Subp)))),
3991 -- For a generic subprogram set flag as well, for use at the point
3992 -- of instantiation, to determine whether the body should be
3995 elsif Is_Generic_Subprogram (Subp) then
3996 Set_Inline_Flags (Subp);
3999 -- Literals are by definition inlined
4001 elsif Kind = E_Enumeration_Literal then
4004 -- Anything else is an error
4008 ("expect subprogram name for pragma%", Assoc);
4012 ----------------------
4013 -- Set_Inline_Flags --
4014 ----------------------
4016 procedure Set_Inline_Flags (Subp : Entity_Id) is
4019 Set_Is_Inlined (Subp, True);
4022 if not Has_Pragma_Inline (Subp) then
4023 Set_Has_Pragma_Inline (Subp);
4027 if Prag_Id = Pragma_Inline_Always then
4028 Set_Has_Pragma_Inline_Always (Subp);
4030 end Set_Inline_Flags;
4032 -- Start of processing for Process_Inline
4035 Check_No_Identifiers;
4036 Check_At_Least_N_Arguments (1);
4039 Inline_Processing_Required := True;
4043 while Present (Assoc) loop
4044 Subp_Id := Expression (Assoc);
4048 if Is_Entity_Name (Subp_Id) then
4049 Subp := Entity (Subp_Id);
4051 if Subp = Any_Id then
4053 -- If previous error, avoid cascaded errors
4061 while Present (Homonym (Subp))
4062 and then Scope (Homonym (Subp)) = Current_Scope
4064 Make_Inline (Homonym (Subp));
4065 Subp := Homonym (Subp);
4072 ("inappropriate argument for pragma%", Assoc);
4075 and then Warn_On_Redundant_Constructs
4076 and then not Suppress_All_Inlining
4078 if Inlining_Not_Possible (Subp) then
4080 ("pragma Inline for& is ignored?", N, Entity (Subp_Id));
4083 ("pragma Inline for& is redundant?", N, Entity (Subp_Id));
4091 ----------------------------
4092 -- Process_Interface_Name --
4093 ----------------------------
4095 procedure Process_Interface_Name
4096 (Subprogram_Def : Entity_Id;
4102 String_Val : String_Id;
4104 procedure Check_Form_Of_Interface_Name
4106 Ext_Name_Case : Boolean);
4107 -- SN is a string literal node for an interface name. This routine
4108 -- performs some minimal checks that the name is reasonable. In
4109 -- particular that no spaces or other obviously incorrect characters
4110 -- appear. This is only a warning, since any characters are allowed.
4111 -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
4113 ----------------------------------
4114 -- Check_Form_Of_Interface_Name --
4115 ----------------------------------
4117 procedure Check_Form_Of_Interface_Name
4119 Ext_Name_Case : Boolean)
4121 S : constant String_Id := Strval (Expr_Value_S (SN));
4122 SL : constant Nat := String_Length (S);
4127 Error_Msg_N ("interface name cannot be null string", SN);
4130 for J in 1 .. SL loop
4131 C := Get_String_Char (S, J);
4133 -- Look for dubious character and issue unconditional warning.
4134 -- Definitely dubious if not in character range.
4136 if not In_Character_Range (C)
4138 -- For all cases except CLI target,
4139 -- commas, spaces and slashes are dubious (in CLI, we use
4140 -- commas and backslashes in external names to specify
4141 -- assembly version and public key, while slashes and spaces
4142 -- can be used in names to mark nested classes and
4145 or else ((not Ext_Name_Case or else VM_Target /= CLI_Target)
4146 and then (Get_Character (C) = ','
4148 Get_Character (C) = '\'))
4149 or else (VM_Target /= CLI_Target
4150 and then (Get_Character (C) = ' '
4152 Get_Character (C) = '/'))
4155 ("?interface name contains illegal character",
4156 Sloc (SN) + Source_Ptr (J));
4159 end Check_Form_Of_Interface_Name;
4161 -- Start of processing for Process_Interface_Name
4164 if No (Link_Arg) then
4165 if No (Ext_Arg) then
4166 if VM_Target = CLI_Target
4167 and then Ekind (Subprogram_Def) = E_Package
4168 and then Nkind (Parent (Subprogram_Def)) =
4169 N_Package_Specification
4170 and then Present (Generic_Parent (Parent (Subprogram_Def)))
4175 (Generic_Parent (Parent (Subprogram_Def))));
4180 elsif Chars (Ext_Arg) = Name_Link_Name then
4182 Link_Nam := Expression (Ext_Arg);
4185 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
4186 Ext_Nam := Expression (Ext_Arg);
4191 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
4192 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
4193 Ext_Nam := Expression (Ext_Arg);
4194 Link_Nam := Expression (Link_Arg);
4197 -- Check expressions for external name and link name are static
4199 if Present (Ext_Nam) then
4200 Check_Arg_Is_Static_Expression (Ext_Nam, Standard_String);
4201 Check_Form_Of_Interface_Name (Ext_Nam, Ext_Name_Case => True);
4203 -- Verify that external name is not the name of a local entity,
4204 -- which would hide the imported one and could lead to run-time
4205 -- surprises. The problem can only arise for entities declared in
4206 -- a package body (otherwise the external name is fully qualified
4207 -- and will not conflict).
4215 if Prag_Id = Pragma_Import then
4216 String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam)));
4218 E := Entity_Id (Get_Name_Table_Info (Nam));
4220 if Nam /= Chars (Subprogram_Def)
4221 and then Present (E)
4222 and then not Is_Overloadable (E)
4223 and then Is_Immediately_Visible (E)
4224 and then not Is_Imported (E)
4225 and then Ekind (Scope (E)) = E_Package
4228 while Present (Par) loop
4229 if Nkind (Par) = N_Package_Body then
4230 Error_Msg_Sloc := Sloc (E);
4232 ("imported entity is hidden by & declared#",
4237 Par := Parent (Par);
4244 if Present (Link_Nam) then
4245 Check_Arg_Is_Static_Expression (Link_Nam, Standard_String);
4246 Check_Form_Of_Interface_Name (Link_Nam, Ext_Name_Case => False);
4249 -- If there is no link name, just set the external name
4251 if No (Link_Nam) then
4252 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
4254 -- For the Link_Name case, the given literal is preceded by an
4255 -- asterisk, which indicates to GCC that the given name should be
4256 -- taken literally, and in particular that no prepending of
4257 -- underlines should occur, even in systems where this is the
4263 if VM_Target = No_VM then
4264 Store_String_Char (Get_Char_Code ('*'));
4267 String_Val := Strval (Expr_Value_S (Link_Nam));
4268 Store_String_Chars (String_Val);
4270 Make_String_Literal (Sloc (Link_Nam),
4271 Strval => End_String);
4274 Set_Encoded_Interface_Name
4275 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
4277 -- We allow duplicated export names in CIL, as they are always
4278 -- enclosed in a namespace that differentiates them, and overloaded
4279 -- entities are supported by the VM.
4281 if Convention (Subprogram_Def) /= Convention_CIL then
4282 Check_Duplicated_Export_Name (Link_Nam);
4284 end Process_Interface_Name;
4286 -----------------------------------------
4287 -- Process_Interrupt_Or_Attach_Handler --
4288 -----------------------------------------
4290 procedure Process_Interrupt_Or_Attach_Handler is
4291 Arg1_X : constant Node_Id := Expression (Arg1);
4292 Handler_Proc : constant Entity_Id := Entity (Arg1_X);
4293 Proc_Scope : constant Entity_Id := Scope (Handler_Proc);
4296 Set_Is_Interrupt_Handler (Handler_Proc);
4298 -- If the pragma is not associated with a handler procedure within a
4299 -- protected type, then it must be for a nonprotected procedure for
4300 -- the AAMP target, in which case we don't associate a representation
4301 -- item with the procedure's scope.
4303 if Ekind (Proc_Scope) = E_Protected_Type then
4304 if Prag_Id = Pragma_Interrupt_Handler
4306 Prag_Id = Pragma_Attach_Handler
4308 Record_Rep_Item (Proc_Scope, N);
4311 end Process_Interrupt_Or_Attach_Handler;
4313 --------------------------------------------------
4314 -- Process_Restrictions_Or_Restriction_Warnings --
4315 --------------------------------------------------
4317 -- Note: some of the simple identifier cases were handled in par-prag,
4318 -- but it is harmless (and more straightforward) to simply handle all
4319 -- cases here, even if it means we repeat a bit of work in some cases.
4321 procedure Process_Restrictions_Or_Restriction_Warnings
4325 R_Id : Restriction_Id;
4330 procedure Check_Unit_Name (N : Node_Id);
4331 -- Checks unit name parameter for No_Dependence. Returns if it has
4332 -- an appropriate form, otherwise raises pragma argument error.
4334 ---------------------
4335 -- Check_Unit_Name --
4336 ---------------------
4338 procedure Check_Unit_Name (N : Node_Id) is
4340 if Nkind (N) = N_Selected_Component then
4341 Check_Unit_Name (Prefix (N));
4342 Check_Unit_Name (Selector_Name (N));
4344 elsif Nkind (N) = N_Identifier then
4349 ("wrong form for unit name for No_Dependence", N);
4351 end Check_Unit_Name;
4353 -- Start of processing for Process_Restrictions_Or_Restriction_Warnings
4356 Check_Ada_83_Warning;
4357 Check_At_Least_N_Arguments (1);
4358 Check_Valid_Configuration_Pragma;
4361 while Present (Arg) loop
4363 Expr := Expression (Arg);
4365 -- Case of no restriction identifier present
4367 if Id = No_Name then
4368 if Nkind (Expr) /= N_Identifier then
4370 ("invalid form for restriction", Arg);
4375 (Process_Restriction_Synonyms (Expr));
4377 if R_Id not in All_Boolean_Restrictions then
4378 Error_Msg_Name_1 := Pname;
4380 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
4382 -- Check for possible misspelling
4384 for J in Restriction_Id loop
4386 Rnm : constant String := Restriction_Id'Image (J);
4389 Name_Buffer (1 .. Rnm'Length) := Rnm;
4390 Name_Len := Rnm'Length;
4391 Set_Casing (All_Lower_Case);
4393 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
4395 (Identifier_Casing (Current_Source_File));
4396 Error_Msg_String (1 .. Rnm'Length) :=
4397 Name_Buffer (1 .. Name_Len);
4398 Error_Msg_Strlen := Rnm'Length;
4399 Error_Msg_N -- CODEFIX
4400 ("\possible misspelling of ""~""",
4401 Get_Pragma_Arg (Arg));
4410 if Implementation_Restriction (R_Id) then
4411 Check_Restriction (No_Implementation_Restrictions, Arg);
4414 -- If this is a warning, then set the warning unless we already
4415 -- have a real restriction active (we never want a warning to
4416 -- override a real restriction).
4419 if not Restriction_Active (R_Id) then
4420 Set_Restriction (R_Id, N);
4421 Restriction_Warnings (R_Id) := True;
4424 -- If real restriction case, then set it and make sure that the
4425 -- restriction warning flag is off, since a real restriction
4426 -- always overrides a warning.
4429 Set_Restriction (R_Id, N);
4430 Restriction_Warnings (R_Id) := False;
4433 -- Check for obsolescent restrictions in Ada 2005 mode
4436 and then Ada_Version >= Ada_2005
4437 and then (R_Id = No_Asynchronous_Control
4439 R_Id = No_Unchecked_Deallocation
4441 R_Id = No_Unchecked_Conversion)
4443 Check_Restriction (No_Obsolescent_Features, N);
4446 -- A very special case that must be processed here: pragma
4447 -- Restrictions (No_Exceptions) turns off all run-time
4448 -- checking. This is a bit dubious in terms of the formal
4449 -- language definition, but it is what is intended by RM
4450 -- H.4(12). Restriction_Warnings never affects generated code
4451 -- so this is done only in the real restriction case.
4453 if R_Id = No_Exceptions and then not Warn then
4454 Scope_Suppress := (others => True);
4457 -- Case of No_Dependence => unit-name. Note that the parser
4458 -- already made the necessary entry in the No_Dependence table.
4460 elsif Id = Name_No_Dependence then
4461 Check_Unit_Name (Expr);
4463 -- All other cases of restriction identifier present
4466 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
4467 Analyze_And_Resolve (Expr, Any_Integer);
4469 if R_Id not in All_Parameter_Restrictions then
4471 ("invalid restriction parameter identifier", Arg);
4473 elsif not Is_OK_Static_Expression (Expr) then
4474 Flag_Non_Static_Expr
4475 ("value must be static expression!", Expr);
4478 elsif not Is_Integer_Type (Etype (Expr))
4479 or else Expr_Value (Expr) < 0
4482 ("value must be non-negative integer", Arg);
4485 -- Restriction pragma is active
4487 Val := Expr_Value (Expr);
4489 if not UI_Is_In_Int_Range (Val) then
4491 ("pragma ignored, value too large?", Arg);
4494 -- Warning case. If the real restriction is active, then we
4495 -- ignore the request, since warning never overrides a real
4496 -- restriction. Otherwise we set the proper warning. Note that
4497 -- this circuit sets the warning again if it is already set,
4498 -- which is what we want, since the constant may have changed.
4501 if not Restriction_Active (R_Id) then
4503 (R_Id, N, Integer (UI_To_Int (Val)));
4504 Restriction_Warnings (R_Id) := True;
4507 -- Real restriction case, set restriction and make sure warning
4508 -- flag is off since real restriction always overrides warning.
4511 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
4512 Restriction_Warnings (R_Id) := False;
4518 end Process_Restrictions_Or_Restriction_Warnings;
4520 ---------------------------------
4521 -- Process_Suppress_Unsuppress --
4522 ---------------------------------
4524 -- Note: this procedure makes entries in the check suppress data
4525 -- structures managed by Sem. See spec of package Sem for full
4526 -- details on how we handle recording of check suppression.
4528 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
4533 In_Package_Spec : constant Boolean :=
4534 Is_Package_Or_Generic_Package (Current_Scope)
4535 and then not In_Package_Body (Current_Scope);
4537 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
4538 -- Used to suppress a single check on the given entity
4540 --------------------------------
4541 -- Suppress_Unsuppress_Echeck --
4542 --------------------------------
4544 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
4546 Set_Checks_May_Be_Suppressed (E);
4548 if In_Package_Spec then
4549 Push_Global_Suppress_Stack_Entry
4552 Suppress => Suppress_Case);
4555 Push_Local_Suppress_Stack_Entry
4558 Suppress => Suppress_Case);
4561 -- If this is a first subtype, and the base type is distinct,
4562 -- then also set the suppress flags on the base type.
4564 if Is_First_Subtype (E)
4565 and then Etype (E) /= E
4567 Suppress_Unsuppress_Echeck (Etype (E), C);
4569 end Suppress_Unsuppress_Echeck;
4571 -- Start of processing for Process_Suppress_Unsuppress
4574 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
4575 -- declarative part or a package spec (RM 11.5(5)).
4577 if not Is_Configuration_Pragma then
4578 Check_Is_In_Decl_Part_Or_Package_Spec;
4581 Check_At_Least_N_Arguments (1);
4582 Check_At_Most_N_Arguments (2);
4583 Check_No_Identifier (Arg1);
4584 Check_Arg_Is_Identifier (Arg1);
4586 C := Get_Check_Id (Chars (Expression (Arg1)));
4588 if C = No_Check_Id then
4590 ("argument of pragma% is not valid check name", Arg1);
4593 if not Suppress_Case
4594 and then (C = All_Checks or else C = Overflow_Check)
4596 Opt.Overflow_Checks_Unsuppressed := True;
4599 if Arg_Count = 1 then
4601 -- Make an entry in the local scope suppress table. This is the
4602 -- table that directly shows the current value of the scope
4603 -- suppress check for any check id value.
4605 if C = All_Checks then
4607 -- For All_Checks, we set all specific predefined checks with
4608 -- the exception of Elaboration_Check, which is handled
4609 -- specially because of not wanting All_Checks to have the
4610 -- effect of deactivating static elaboration order processing.
4612 for J in Scope_Suppress'Range loop
4613 if J /= Elaboration_Check then
4614 Scope_Suppress (J) := Suppress_Case;
4618 -- If not All_Checks, and predefined check, then set appropriate
4619 -- scope entry. Note that we will set Elaboration_Check if this
4620 -- is explicitly specified.
4622 elsif C in Predefined_Check_Id then
4623 Scope_Suppress (C) := Suppress_Case;
4626 -- Also make an entry in the Local_Entity_Suppress table
4628 Push_Local_Suppress_Stack_Entry
4631 Suppress => Suppress_Case);
4633 -- Case of two arguments present, where the check is suppressed for
4634 -- a specified entity (given as the second argument of the pragma)
4637 -- This is obsolescent in Ada 2005 mode
4639 if Ada_Version >= Ada_2005 then
4640 Check_Restriction (No_Obsolescent_Features, Arg2);
4643 Check_Optional_Identifier (Arg2, Name_On);
4644 E_Id := Expression (Arg2);
4647 if not Is_Entity_Name (E_Id) then
4649 ("second argument of pragma% must be entity name", Arg2);
4658 -- Enforce RM 11.5(7) which requires that for a pragma that
4659 -- appears within a package spec, the named entity must be
4660 -- within the package spec. We allow the package name itself
4661 -- to be mentioned since that makes sense, although it is not
4662 -- strictly allowed by 11.5(7).
4665 and then E /= Current_Scope
4666 and then Scope (E) /= Current_Scope
4669 ("entity in pragma% is not in package spec (RM 11.5(7))",
4673 -- Loop through homonyms. As noted below, in the case of a package
4674 -- spec, only homonyms within the package spec are considered.
4677 Suppress_Unsuppress_Echeck (E, C);
4679 if Is_Generic_Instance (E)
4680 and then Is_Subprogram (E)
4681 and then Present (Alias (E))
4683 Suppress_Unsuppress_Echeck (Alias (E), C);
4686 -- Move to next homonym
4691 -- If we are within a package specification, the pragma only
4692 -- applies to homonyms in the same scope.
4694 exit when In_Package_Spec
4695 and then Scope (E) /= Current_Scope;
4698 end Process_Suppress_Unsuppress;
4704 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
4706 if Is_Imported (E) then
4708 ("cannot export entity& that was previously imported", Arg);
4710 elsif Present (Address_Clause (E)) then
4712 ("cannot export entity& that has an address clause", Arg);
4715 Set_Is_Exported (E);
4717 -- Generate a reference for entity explicitly, because the
4718 -- identifier may be overloaded and name resolution will not
4721 Generate_Reference (E, Arg);
4723 -- Deal with exporting non-library level entity
4725 if not Is_Library_Level_Entity (E) then
4727 -- Not allowed at all for subprograms
4729 if Is_Subprogram (E) then
4730 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
4732 -- Otherwise set public and statically allocated
4736 Set_Is_Statically_Allocated (E);
4738 -- Warn if the corresponding W flag is set and the pragma comes
4739 -- from source. The latter may not be true e.g. on VMS where we
4740 -- expand export pragmas for exception codes associated with
4741 -- imported or exported exceptions. We do not want to generate
4742 -- a warning for something that the user did not write.
4744 if Warn_On_Export_Import
4745 and then Comes_From_Source (Arg)
4748 ("?& has been made static as a result of Export", Arg, E);
4750 ("\this usage is non-standard and non-portable", Arg);
4755 if Warn_On_Export_Import and then Is_Type (E) then
4756 Error_Msg_NE ("exporting a type has no effect?", Arg, E);
4759 if Warn_On_Export_Import and Inside_A_Generic then
4761 ("all instances of& will have the same external name?", Arg, E);
4765 ----------------------------------------------
4766 -- Set_Extended_Import_Export_External_Name --
4767 ----------------------------------------------
4769 procedure Set_Extended_Import_Export_External_Name
4770 (Internal_Ent : Entity_Id;
4771 Arg_External : Node_Id)
4773 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
4777 if No (Arg_External) then
4781 Check_Arg_Is_External_Name (Arg_External);
4783 if Nkind (Arg_External) = N_String_Literal then
4784 if String_Length (Strval (Arg_External)) = 0 then
4787 New_Name := Adjust_External_Name_Case (Arg_External);
4790 elsif Nkind (Arg_External) = N_Identifier then
4791 New_Name := Get_Default_External_Name (Arg_External);
4793 -- Check_Arg_Is_External_Name should let through only identifiers and
4794 -- string literals or static string expressions (which are folded to
4795 -- string literals).
4798 raise Program_Error;
4801 -- If we already have an external name set (by a prior normal Import
4802 -- or Export pragma), then the external names must match
4804 if Present (Interface_Name (Internal_Ent)) then
4805 Check_Matching_Internal_Names : declare
4806 S1 : constant String_Id := Strval (Old_Name);
4807 S2 : constant String_Id := Strval (New_Name);
4810 -- Called if names do not match
4816 procedure Mismatch is
4818 Error_Msg_Sloc := Sloc (Old_Name);
4820 ("external name does not match that given #",
4824 -- Start of processing for Check_Matching_Internal_Names
4827 if String_Length (S1) /= String_Length (S2) then
4831 for J in 1 .. String_Length (S1) loop
4832 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
4837 end Check_Matching_Internal_Names;
4839 -- Otherwise set the given name
4842 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
4843 Check_Duplicated_Export_Name (New_Name);
4845 end Set_Extended_Import_Export_External_Name;
4851 procedure Set_Imported (E : Entity_Id) is
4853 -- Error message if already imported or exported
4855 if Is_Exported (E) or else Is_Imported (E) then
4857 -- Error if being set Exported twice
4859 if Is_Exported (E) then
4860 Error_Msg_NE ("entity& was previously exported", N, E);
4862 -- OK if Import/Interface case
4864 elsif Import_Interface_Present (N) then
4867 -- Error if being set Imported twice
4870 Error_Msg_NE ("entity& was previously imported", N, E);
4873 Error_Msg_Name_1 := Pname;
4875 ("\(pragma% applies to all previous entities)", N);
4877 Error_Msg_Sloc := Sloc (E);
4878 Error_Msg_NE ("\import not allowed for& declared#", N, E);
4880 -- Here if not previously imported or exported, OK to import
4883 Set_Is_Imported (E);
4885 -- If the entity is an object that is not at the library level,
4886 -- then it is statically allocated. We do not worry about objects
4887 -- with address clauses in this context since they are not really
4888 -- imported in the linker sense.
4891 and then not Is_Library_Level_Entity (E)
4892 and then No (Address_Clause (E))
4894 Set_Is_Statically_Allocated (E);
4901 -------------------------
4902 -- Set_Mechanism_Value --
4903 -------------------------
4905 -- Note: the mechanism name has not been analyzed (and cannot indeed be
4906 -- analyzed, since it is semantic nonsense), so we get it in the exact
4907 -- form created by the parser.
4909 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
4912 Mech_Name_Id : Name_Id;
4914 procedure Bad_Class;
4915 -- Signal bad descriptor class name
4917 procedure Bad_Mechanism;
4918 -- Signal bad mechanism name
4924 procedure Bad_Class is
4926 Error_Pragma_Arg ("unrecognized descriptor class name", Class);
4929 -------------------------
4930 -- Bad_Mechanism_Value --
4931 -------------------------
4933 procedure Bad_Mechanism is
4935 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
4938 -- Start of processing for Set_Mechanism_Value
4941 if Mechanism (Ent) /= Default_Mechanism then
4943 ("mechanism for & has already been set", Mech_Name, Ent);
4946 -- MECHANISM_NAME ::= value | reference | descriptor |
4949 if Nkind (Mech_Name) = N_Identifier then
4950 if Chars (Mech_Name) = Name_Value then
4951 Set_Mechanism (Ent, By_Copy);
4954 elsif Chars (Mech_Name) = Name_Reference then
4955 Set_Mechanism (Ent, By_Reference);
4958 elsif Chars (Mech_Name) = Name_Descriptor then
4959 Check_VMS (Mech_Name);
4961 -- Descriptor => Short_Descriptor if pragma was given
4963 if Short_Descriptors then
4964 Set_Mechanism (Ent, By_Short_Descriptor);
4966 Set_Mechanism (Ent, By_Descriptor);
4971 elsif Chars (Mech_Name) = Name_Short_Descriptor then
4972 Check_VMS (Mech_Name);
4973 Set_Mechanism (Ent, By_Short_Descriptor);
4976 elsif Chars (Mech_Name) = Name_Copy then
4978 ("bad mechanism name, Value assumed", Mech_Name);
4984 -- MECHANISM_NAME ::= descriptor (CLASS_NAME) |
4985 -- short_descriptor (CLASS_NAME)
4986 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
4988 -- Note: this form is parsed as an indexed component
4990 elsif Nkind (Mech_Name) = N_Indexed_Component then
4991 Class := First (Expressions (Mech_Name));
4993 if Nkind (Prefix (Mech_Name)) /= N_Identifier
4994 or else not (Chars (Prefix (Mech_Name)) = Name_Descriptor or else
4995 Chars (Prefix (Mech_Name)) = Name_Short_Descriptor)
4996 or else Present (Next (Class))
5000 Mech_Name_Id := Chars (Prefix (Mech_Name));
5002 -- Change Descriptor => Short_Descriptor if pragma was given
5004 if Mech_Name_Id = Name_Descriptor
5005 and then Short_Descriptors
5007 Mech_Name_Id := Name_Short_Descriptor;
5011 -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) |
5012 -- short_descriptor (Class => CLASS_NAME)
5013 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
5015 -- Note: this form is parsed as a function call
5017 elsif Nkind (Mech_Name) = N_Function_Call then
5018 Param := First (Parameter_Associations (Mech_Name));
5020 if Nkind (Name (Mech_Name)) /= N_Identifier
5021 or else not (Chars (Name (Mech_Name)) = Name_Descriptor or else
5022 Chars (Name (Mech_Name)) = Name_Short_Descriptor)
5023 or else Present (Next (Param))
5024 or else No (Selector_Name (Param))
5025 or else Chars (Selector_Name (Param)) /= Name_Class
5029 Class := Explicit_Actual_Parameter (Param);
5030 Mech_Name_Id := Chars (Name (Mech_Name));
5037 -- Fall through here with Class set to descriptor class name
5039 Check_VMS (Mech_Name);
5041 if Nkind (Class) /= N_Identifier then
5044 elsif Mech_Name_Id = Name_Descriptor
5045 and then Chars (Class) = Name_UBS
5047 Set_Mechanism (Ent, By_Descriptor_UBS);
5049 elsif Mech_Name_Id = Name_Descriptor
5050 and then Chars (Class) = Name_UBSB
5052 Set_Mechanism (Ent, By_Descriptor_UBSB);
5054 elsif Mech_Name_Id = Name_Descriptor
5055 and then Chars (Class) = Name_UBA
5057 Set_Mechanism (Ent, By_Descriptor_UBA);
5059 elsif Mech_Name_Id = Name_Descriptor
5060 and then Chars (Class) = Name_S
5062 Set_Mechanism (Ent, By_Descriptor_S);
5064 elsif Mech_Name_Id = Name_Descriptor
5065 and then Chars (Class) = Name_SB
5067 Set_Mechanism (Ent, By_Descriptor_SB);
5069 elsif Mech_Name_Id = Name_Descriptor
5070 and then Chars (Class) = Name_A
5072 Set_Mechanism (Ent, By_Descriptor_A);
5074 elsif Mech_Name_Id = Name_Descriptor
5075 and then Chars (Class) = Name_NCA
5077 Set_Mechanism (Ent, By_Descriptor_NCA);
5079 elsif Mech_Name_Id = Name_Short_Descriptor
5080 and then Chars (Class) = Name_UBS
5082 Set_Mechanism (Ent, By_Short_Descriptor_UBS);
5084 elsif Mech_Name_Id = Name_Short_Descriptor
5085 and then Chars (Class) = Name_UBSB
5087 Set_Mechanism (Ent, By_Short_Descriptor_UBSB);
5089 elsif Mech_Name_Id = Name_Short_Descriptor
5090 and then Chars (Class) = Name_UBA
5092 Set_Mechanism (Ent, By_Short_Descriptor_UBA);
5094 elsif Mech_Name_Id = Name_Short_Descriptor
5095 and then Chars (Class) = Name_S
5097 Set_Mechanism (Ent, By_Short_Descriptor_S);
5099 elsif Mech_Name_Id = Name_Short_Descriptor
5100 and then Chars (Class) = Name_SB
5102 Set_Mechanism (Ent, By_Short_Descriptor_SB);
5104 elsif Mech_Name_Id = Name_Short_Descriptor
5105 and then Chars (Class) = Name_A
5107 Set_Mechanism (Ent, By_Short_Descriptor_A);
5109 elsif Mech_Name_Id = Name_Short_Descriptor
5110 and then Chars (Class) = Name_NCA
5112 Set_Mechanism (Ent, By_Short_Descriptor_NCA);
5117 end Set_Mechanism_Value;
5119 ---------------------------
5120 -- Set_Ravenscar_Profile --
5121 ---------------------------
5123 -- The tasks to be done here are
5125 -- Set required policies
5127 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
5128 -- pragma Locking_Policy (Ceiling_Locking)
5130 -- Set Detect_Blocking mode
5132 -- Set required restrictions (see System.Rident for detailed list)
5134 procedure Set_Ravenscar_Profile (N : Node_Id) is
5136 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
5138 if Task_Dispatching_Policy /= ' '
5139 and then Task_Dispatching_Policy /= 'F'
5141 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
5142 Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
5144 -- Set the FIFO_Within_Priorities policy, but always preserve
5145 -- System_Location since we like the error message with the run time
5149 Task_Dispatching_Policy := 'F';
5151 if Task_Dispatching_Policy_Sloc /= System_Location then
5152 Task_Dispatching_Policy_Sloc := Loc;
5156 -- pragma Locking_Policy (Ceiling_Locking)
5158 if Locking_Policy /= ' '
5159 and then Locking_Policy /= 'C'
5161 Error_Msg_Sloc := Locking_Policy_Sloc;
5162 Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
5164 -- Set the Ceiling_Locking policy, but preserve System_Location since
5165 -- we like the error message with the run time name.
5168 Locking_Policy := 'C';
5170 if Locking_Policy_Sloc /= System_Location then
5171 Locking_Policy_Sloc := Loc;
5175 -- pragma Detect_Blocking
5177 Detect_Blocking := True;
5179 -- Set the corresponding restrictions
5181 Set_Profile_Restrictions
5182 (Ravenscar, N, Warn => Treat_Restrictions_As_Warnings);
5183 end Set_Ravenscar_Profile;
5185 -- Start of processing for Analyze_Pragma
5188 -- Deal with unrecognized pragma
5190 if not Is_Pragma_Name (Pname) then
5191 if Warn_On_Unrecognized_Pragma then
5192 Error_Msg_Name_1 := Pname;
5193 Error_Msg_N ("?unrecognized pragma%!", Pragma_Identifier (N));
5195 for PN in First_Pragma_Name .. Last_Pragma_Name loop
5196 if Is_Bad_Spelling_Of (Pname, PN) then
5197 Error_Msg_Name_1 := PN;
5198 Error_Msg_N -- CODEFIX
5199 ("\?possible misspelling of %!", Pragma_Identifier (N));
5208 -- Here to start processing for recognized pragma
5210 Prag_Id := Get_Pragma_Id (Pname);
5219 if Present (Pragma_Argument_Associations (N)) then
5220 Arg1 := First (Pragma_Argument_Associations (N));
5222 if Present (Arg1) then
5223 Arg2 := Next (Arg1);
5225 if Present (Arg2) then
5226 Arg3 := Next (Arg2);
5228 if Present (Arg3) then
5229 Arg4 := Next (Arg3);
5235 -- Count number of arguments
5242 while Present (Arg_Node) loop
5243 Arg_Count := Arg_Count + 1;
5248 -- An enumeration type defines the pragmas that are supported by the
5249 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
5250 -- into the corresponding enumeration value for the following case.
5258 -- pragma Abort_Defer;
5260 when Pragma_Abort_Defer =>
5262 Check_Arg_Count (0);
5264 -- The only required semantic processing is to check the
5265 -- placement. This pragma must appear at the start of the
5266 -- statement sequence of a handled sequence of statements.
5268 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
5269 or else N /= First (Statements (Parent (N)))
5280 -- Note: this pragma also has some specific processing in Par.Prag
5281 -- because we want to set the Ada version mode during parsing.
5283 when Pragma_Ada_83 =>
5285 Check_Arg_Count (0);
5287 -- We really should check unconditionally for proper configuration
5288 -- pragma placement, since we really don't want mixed Ada modes
5289 -- within a single unit, and the GNAT reference manual has always
5290 -- said this was a configuration pragma, but we did not check and
5291 -- are hesitant to add the check now.
5293 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
5294 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
5295 -- or Ada 2012 mode.
5297 if Ada_Version >= Ada_05 then
5298 Check_Valid_Configuration_Pragma;
5301 -- Now set Ada 83 mode
5303 Ada_Version := Ada_83;
5304 Ada_Version_Explicit := Ada_Version;
5312 -- Note: this pragma also has some specific processing in Par.Prag
5313 -- because we want to set the Ada 83 version mode during parsing.
5315 when Pragma_Ada_95 =>
5317 Check_Arg_Count (0);
5319 -- We really should check unconditionally for proper configuration
5320 -- pragma placement, since we really don't want mixed Ada modes
5321 -- within a single unit, and the GNAT reference manual has always
5322 -- said this was a configuration pragma, but we did not check and
5323 -- are hesitant to add the check now.
5325 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
5326 -- or Ada 95, so we must check if we are in Ada 2005 mode.
5328 if Ada_Version >= Ada_05 then
5329 Check_Valid_Configuration_Pragma;
5332 -- Now set Ada 95 mode
5334 Ada_Version := Ada_95;
5335 Ada_Version_Explicit := Ada_Version;
5337 ---------------------
5338 -- Ada_05/Ada_2005 --
5339 ---------------------
5342 -- pragma Ada_05 (LOCAL_NAME);
5345 -- pragma Ada_2005 (LOCAL_NAME):
5347 -- Note: these pragmas also have some specific processing in Par.Prag
5348 -- because we want to set the Ada 2005 version mode during parsing.
5350 when Pragma_Ada_05 | Pragma_Ada_2005 => declare
5356 if Arg_Count = 1 then
5357 Check_Arg_Is_Local_Name (Arg1);
5358 E_Id := Expression (Arg1);
5360 if Etype (E_Id) = Any_Type then
5364 Set_Is_Ada_2005_Only (Entity (E_Id));
5367 Check_Arg_Count (0);
5369 -- For Ada_2005 we unconditionally enforce the documented
5370 -- configuration pragma placement, since we do not want to
5371 -- tolerate mixed modes in a unit involving Ada 2005. That
5372 -- would cause real difficulties for those cases where there
5373 -- are incompatibilities between Ada 95 and Ada 2005.
5375 Check_Valid_Configuration_Pragma;
5377 -- Now set Ada 2005 mode
5379 Ada_Version := Ada_05;
5380 Ada_Version_Explicit := Ada_05;
5384 ---------------------
5385 -- Ada_12/Ada_2012 --
5386 ---------------------
5389 -- pragma Ada_12 (LOCAL_NAME);
5392 -- pragma Ada_2012 (LOCAL_NAME):
5394 -- Note: these pragmas also have some specific processing in Par.Prag
5395 -- because we want to set the Ada 2012 version mode during parsing.
5397 when Pragma_Ada_12 | Pragma_Ada_2012 => declare
5403 if Arg_Count = 1 then
5404 Check_Arg_Is_Local_Name (Arg1);
5405 E_Id := Expression (Arg1);
5407 if Etype (E_Id) = Any_Type then
5411 Set_Is_Ada_2012_Only (Entity (E_Id));
5414 Check_Arg_Count (0);
5416 -- For Ada_2012 we unconditionally enforce the documented
5417 -- configuration pragma placement, since we do not want to
5418 -- tolerate mixed modes in a unit involving Ada 2012. That
5419 -- would cause real difficulties for those cases where there
5420 -- are incompatibilities between Ada 95 and Ada 2012. We could
5421 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
5423 Check_Valid_Configuration_Pragma;
5425 -- Now set Ada 2012 mode
5427 Ada_Version := Ada_12;
5428 Ada_Version_Explicit := Ada_12;
5432 ----------------------
5433 -- All_Calls_Remote --
5434 ----------------------
5436 -- pragma All_Calls_Remote [(library_package_NAME)];
5438 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
5439 Lib_Entity : Entity_Id;
5442 Check_Ada_83_Warning;
5443 Check_Valid_Library_Unit_Pragma;
5445 if Nkind (N) = N_Null_Statement then
5449 Lib_Entity := Find_Lib_Unit_Name;
5451 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
5453 if Present (Lib_Entity)
5454 and then not Debug_Flag_U
5456 if not Is_Remote_Call_Interface (Lib_Entity) then
5457 Error_Pragma ("pragma% only apply to rci unit");
5459 -- Set flag for entity of the library unit
5462 Set_Has_All_Calls_Remote (Lib_Entity);
5466 end All_Calls_Remote;
5472 -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]);
5473 -- ARG ::= NAME | EXPRESSION
5475 -- The first two arguments are by convention intended to refer to an
5476 -- external tool and a tool-specific function. These arguments are
5479 when Pragma_Annotate => Annotate : begin
5481 Check_At_Least_N_Arguments (1);
5482 Check_Arg_Is_Identifier (Arg1);
5483 Check_No_Identifiers;
5491 -- Second unanalyzed parameter is optional
5497 while Present (Arg) loop
5498 Exp := Expression (Arg);
5501 if Is_Entity_Name (Exp) then
5504 -- For string literals, we assume Standard_String as the
5505 -- type, unless the string contains wide or wide_wide
5508 elsif Nkind (Exp) = N_String_Literal then
5509 if Has_Wide_Wide_Character (Exp) then
5510 Resolve (Exp, Standard_Wide_Wide_String);
5511 elsif Has_Wide_Character (Exp) then
5512 Resolve (Exp, Standard_Wide_String);
5514 Resolve (Exp, Standard_String);
5517 elsif Is_Overloaded (Exp) then
5519 ("ambiguous argument for pragma%", Exp);
5535 -- pragma Assert ([Check =>] Boolean_EXPRESSION
5536 -- [, [Message =>] Static_String_EXPRESSION]);
5538 when Pragma_Assert => Assert : declare
5544 Check_At_Least_N_Arguments (1);
5545 Check_At_Most_N_Arguments (2);
5546 Check_Arg_Order ((Name_Check, Name_Message));
5547 Check_Optional_Identifier (Arg1, Name_Check);
5549 -- We treat pragma Assert as equivalent to:
5551 -- pragma Check (Assertion, condition [, msg]);
5553 -- So rewrite pragma in this manner, and analyze the result
5555 Expr := Get_Pragma_Arg (Arg1);
5557 Make_Pragma_Argument_Association (Loc,
5559 Make_Identifier (Loc,
5560 Chars => Name_Assertion)),
5562 Make_Pragma_Argument_Association (Sloc (Expr),
5563 Expression => Expr));
5565 if Arg_Count > 1 then
5566 Check_Optional_Identifier (Arg2, Name_Message);
5567 Analyze_And_Resolve (Get_Pragma_Arg (Arg2), Standard_String);
5568 Append_To (Newa, Relocate_Node (Arg2));
5573 Chars => Name_Check,
5574 Pragma_Argument_Associations => Newa));
5578 ----------------------
5579 -- Assertion_Policy --
5580 ----------------------
5582 -- pragma Assertion_Policy (Check | Ignore)
5584 when Pragma_Assertion_Policy => Assertion_Policy : declare
5589 Check_Valid_Configuration_Pragma;
5590 Check_Arg_Count (1);
5591 Check_No_Identifiers;
5592 Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Ignore);
5594 -- We treat pragma Assertion_Policy as equivalent to:
5596 -- pragma Check_Policy (Assertion, policy)
5598 -- So rewrite the pragma in that manner and link on to the chain
5599 -- of Check_Policy pragmas, marking the pragma as analyzed.
5601 Policy := Get_Pragma_Arg (Arg1);
5605 Chars => Name_Check_Policy,
5607 Pragma_Argument_Associations => New_List (
5608 Make_Pragma_Argument_Association (Loc,
5610 Make_Identifier (Loc,
5611 Chars => Name_Assertion)),
5613 Make_Pragma_Argument_Association (Loc,
5615 Make_Identifier (Sloc (Policy),
5616 Chars => Chars (Policy))))));
5619 Set_Next_Pragma (N, Opt.Check_Policy_List);
5620 Opt.Check_Policy_List := N;
5621 end Assertion_Policy;
5623 ------------------------------
5624 -- Assume_No_Invalid_Values --
5625 ------------------------------
5627 -- pragma Assume_No_Invalid_Values (On | Off);
5629 when Pragma_Assume_No_Invalid_Values =>
5631 Check_Valid_Configuration_Pragma;
5632 Check_Arg_Count (1);
5633 Check_No_Identifiers;
5634 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
5636 if Chars (Expression (Arg1)) = Name_On then
5637 Assume_No_Invalid_Values := True;
5639 Assume_No_Invalid_Values := False;
5646 -- pragma AST_Entry (entry_IDENTIFIER);
5648 when Pragma_AST_Entry => AST_Entry : declare
5654 Check_Arg_Count (1);
5655 Check_No_Identifiers;
5656 Check_Arg_Is_Local_Name (Arg1);
5657 Ent := Entity (Expression (Arg1));
5659 -- Note: the implementation of the AST_Entry pragma could handle
5660 -- the entry family case fine, but for now we are consistent with
5661 -- the DEC rules, and do not allow the pragma, which of course
5662 -- has the effect of also forbidding the attribute.
5664 if Ekind (Ent) /= E_Entry then
5666 ("pragma% argument must be simple entry name", Arg1);
5668 elsif Is_AST_Entry (Ent) then
5670 ("duplicate % pragma for entry", Arg1);
5672 elsif Has_Homonym (Ent) then
5674 ("pragma% argument cannot specify overloaded entry", Arg1);
5678 FF : constant Entity_Id := First_Formal (Ent);
5681 if Present (FF) then
5682 if Present (Next_Formal (FF)) then
5684 ("entry for pragma% can have only one argument",
5687 elsif Parameter_Mode (FF) /= E_In_Parameter then
5689 ("entry parameter for pragma% must have mode IN",
5695 Set_Is_AST_Entry (Ent);
5703 -- pragma Asynchronous (LOCAL_NAME);
5705 when Pragma_Asynchronous => Asynchronous : declare
5713 procedure Process_Async_Pragma;
5714 -- Common processing for procedure and access-to-procedure case
5716 --------------------------
5717 -- Process_Async_Pragma --
5718 --------------------------
5720 procedure Process_Async_Pragma is
5723 Set_Is_Asynchronous (Nm);
5727 -- The formals should be of mode IN (RM E.4.1(6))
5730 while Present (S) loop
5731 Formal := Defining_Identifier (S);
5733 if Nkind (Formal) = N_Defining_Identifier
5734 and then Ekind (Formal) /= E_In_Parameter
5737 ("pragma% procedure can only have IN parameter",
5744 Set_Is_Asynchronous (Nm);
5745 end Process_Async_Pragma;
5747 -- Start of processing for pragma Asynchronous
5750 Check_Ada_83_Warning;
5751 Check_No_Identifiers;
5752 Check_Arg_Count (1);
5753 Check_Arg_Is_Local_Name (Arg1);
5755 if Debug_Flag_U then
5759 C_Ent := Cunit_Entity (Current_Sem_Unit);
5760 Analyze (Expression (Arg1));
5761 Nm := Entity (Expression (Arg1));
5763 if not Is_Remote_Call_Interface (C_Ent)
5764 and then not Is_Remote_Types (C_Ent)
5766 -- This pragma should only appear in an RCI or Remote Types
5767 -- unit (RM E.4.1(4)).
5770 ("pragma% not in Remote_Call_Interface or " &
5771 "Remote_Types unit");
5774 if Ekind (Nm) = E_Procedure
5775 and then Nkind (Parent (Nm)) = N_Procedure_Specification
5777 if not Is_Remote_Call_Interface (Nm) then
5779 ("pragma% cannot be applied on non-remote procedure",
5783 L := Parameter_Specifications (Parent (Nm));
5784 Process_Async_Pragma;
5787 elsif Ekind (Nm) = E_Function then
5789 ("pragma% cannot be applied to function", Arg1);
5791 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
5793 if Is_Record_Type (Nm) then
5795 -- A record type that is the Equivalent_Type for a remote
5796 -- access-to-subprogram type.
5798 N := Declaration_Node (Corresponding_Remote_Type (Nm));
5801 -- A non-expanded RAS type (distribution is not enabled)
5803 N := Declaration_Node (Nm);
5806 if Nkind (N) = N_Full_Type_Declaration
5807 and then Nkind (Type_Definition (N)) =
5808 N_Access_Procedure_Definition
5810 L := Parameter_Specifications (Type_Definition (N));
5811 Process_Async_Pragma;
5813 if Is_Asynchronous (Nm)
5814 and then Expander_Active
5815 and then Get_PCS_Name /= Name_No_DSA
5817 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
5822 ("pragma% cannot reference access-to-function type",
5826 -- Only other possibility is Access-to-class-wide type
5828 elsif Is_Access_Type (Nm)
5829 and then Is_Class_Wide_Type (Designated_Type (Nm))
5831 Check_First_Subtype (Arg1);
5832 Set_Is_Asynchronous (Nm);
5833 if Expander_Active then
5834 RACW_Type_Is_Asynchronous (Nm);
5838 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
5846 -- pragma Atomic (LOCAL_NAME);
5848 when Pragma_Atomic =>
5849 Process_Atomic_Shared_Volatile;
5851 -----------------------
5852 -- Atomic_Components --
5853 -----------------------
5855 -- pragma Atomic_Components (array_LOCAL_NAME);
5857 -- This processing is shared by Volatile_Components
5859 when Pragma_Atomic_Components |
5860 Pragma_Volatile_Components =>
5862 Atomic_Components : declare
5869 Check_Ada_83_Warning;
5870 Check_No_Identifiers;
5871 Check_Arg_Count (1);
5872 Check_Arg_Is_Local_Name (Arg1);
5873 E_Id := Expression (Arg1);
5875 if Etype (E_Id) = Any_Type then
5881 if Rep_Item_Too_Early (E, N)
5883 Rep_Item_Too_Late (E, N)
5888 D := Declaration_Node (E);
5891 if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
5893 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
5894 and then Nkind (D) = N_Object_Declaration
5895 and then Nkind (Object_Definition (D)) =
5896 N_Constrained_Array_Definition)
5898 -- The flag is set on the object, or on the base type
5900 if Nkind (D) /= N_Object_Declaration then
5904 Set_Has_Volatile_Components (E);
5906 if Prag_Id = Pragma_Atomic_Components then
5907 Set_Has_Atomic_Components (E);
5909 if Is_Packed (E) then
5910 Set_Is_Packed (E, False);
5913 ("?Pack canceled, cannot pack atomic components",
5919 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
5921 end Atomic_Components;
5923 --------------------
5924 -- Attach_Handler --
5925 --------------------
5927 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
5929 when Pragma_Attach_Handler =>
5930 Check_Ada_83_Warning;
5931 Check_No_Identifiers;
5932 Check_Arg_Count (2);
5934 if No_Run_Time_Mode then
5935 Error_Msg_CRT ("Attach_Handler pragma", N);
5937 Check_Interrupt_Or_Attach_Handler;
5939 -- The expression that designates the attribute may
5940 -- depend on a discriminant, and is therefore a per-
5941 -- object expression, to be expanded in the init proc.
5942 -- If expansion is enabled, perform semantic checks
5945 if Expander_Active then
5947 Temp : constant Node_Id :=
5948 New_Copy_Tree (Expression (Arg2));
5950 Set_Parent (Temp, N);
5951 Preanalyze_And_Resolve (Temp, RTE (RE_Interrupt_ID));
5955 Analyze (Expression (Arg2));
5956 Resolve (Expression (Arg2), RTE (RE_Interrupt_ID));
5959 Process_Interrupt_Or_Attach_Handler;
5962 --------------------
5963 -- C_Pass_By_Copy --
5964 --------------------
5966 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
5968 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
5974 Check_Valid_Configuration_Pragma;
5975 Check_Arg_Count (1);
5976 Check_Optional_Identifier (Arg1, "max_size");
5978 Arg := Expression (Arg1);
5979 Check_Arg_Is_Static_Expression (Arg, Any_Integer);
5981 Val := Expr_Value (Arg);
5985 ("maximum size for pragma% must be positive", Arg1);
5987 elsif UI_Is_In_Int_Range (Val) then
5988 Default_C_Record_Mechanism := UI_To_Int (Val);
5990 -- If a giant value is given, Int'Last will do well enough.
5991 -- If sometime someone complains that a record larger than
5992 -- two gigabytes is not copied, we will worry about it then!
5995 Default_C_Record_Mechanism := Mechanism_Type'Last;
6003 -- pragma Check ([Name =>] Identifier,
6004 -- [Check =>] Boolean_Expression
6005 -- [,[Message =>] String_Expression]);
6007 when Pragma_Check => Check : declare
6012 -- Set True if category of assertions referenced by Name enabled
6016 Check_At_Least_N_Arguments (2);
6017 Check_At_Most_N_Arguments (3);
6018 Check_Optional_Identifier (Arg1, Name_Name);
6019 Check_Optional_Identifier (Arg2, Name_Check);
6021 if Arg_Count = 3 then
6022 Check_Optional_Identifier (Arg3, Name_Message);
6023 Analyze_And_Resolve (Get_Pragma_Arg (Arg3), Standard_String);
6026 Check_Arg_Is_Identifier (Arg1);
6028 -- Indicate if pragma is enabled. The Original_Node reference here
6029 -- is to deal with pragma Assert rewritten as a Check pragma.
6031 Check_On := Check_Enabled (Chars (Get_Pragma_Arg (Arg1)));
6034 Set_Pragma_Enabled (N);
6035 Set_Pragma_Enabled (Original_Node (N));
6036 Set_SCO_Pragma_Enabled (Loc);
6039 -- If expansion is active and the check is not enabled then we
6040 -- rewrite the Check as:
6042 -- if False and then condition then
6046 -- The reason we do this rewriting during semantic analysis rather
6047 -- than as part of normal expansion is that we cannot analyze and
6048 -- expand the code for the boolean expression directly, or it may
6049 -- cause insertion of actions that would escape the attempt to
6050 -- suppress the check code.
6052 -- Note that the Sloc for the if statement corresponds to the
6053 -- argument condition, not the pragma itself. The reason for this
6054 -- is that we may generate a warning if the condition is False at
6055 -- compile time, and we do not want to delete this warning when we
6056 -- delete the if statement.
6058 Expr := Expression (Arg2);
6060 if Expander_Active and then not Check_On then
6061 Eloc := Sloc (Expr);
6064 Make_If_Statement (Eloc,
6066 Make_And_Then (Eloc,
6067 Left_Opnd => New_Occurrence_Of (Standard_False, Eloc),
6068 Right_Opnd => Expr),
6069 Then_Statements => New_List (
6070 Make_Null_Statement (Eloc))));
6077 Analyze_And_Resolve (Expr, Any_Boolean);
6085 -- pragma Check_Name (check_IDENTIFIER);
6087 when Pragma_Check_Name =>
6088 Check_No_Identifiers;
6090 Check_Valid_Configuration_Pragma;
6091 Check_Arg_Count (1);
6092 Check_Arg_Is_Identifier (Arg1);
6095 Nam : constant Name_Id := Chars (Expression (Arg1));
6098 for J in Check_Names.First .. Check_Names.Last loop
6099 if Check_Names.Table (J) = Nam then
6104 Check_Names.Append (Nam);
6111 -- pragma Check_Policy (
6112 -- [Name =>] IDENTIFIER,
6113 -- [Policy =>] POLICY_IDENTIFIER);
6115 -- POLICY_IDENTIFIER ::= ON | OFF | CHECK | IGNORE
6117 -- Note: this is a configuration pragma, but it is allowed to appear
6120 when Pragma_Check_Policy =>
6122 Check_Arg_Count (2);
6123 Check_Optional_Identifier (Arg1, Name_Name);
6124 Check_Optional_Identifier (Arg2, Name_Policy);
6126 (Arg2, Name_On, Name_Off, Name_Check, Name_Ignore);
6128 -- A Check_Policy pragma can appear either as a configuration
6129 -- pragma, or in a declarative part or a package spec (see RM
6130 -- 11.5(5) for rules for Suppress/Unsuppress which are also
6131 -- followed for Check_Policy).
6133 if not Is_Configuration_Pragma then
6134 Check_Is_In_Decl_Part_Or_Package_Spec;
6137 Set_Next_Pragma (N, Opt.Check_Policy_List);
6138 Opt.Check_Policy_List := N;
6140 ---------------------
6141 -- CIL_Constructor --
6142 ---------------------
6144 -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
6146 -- Processing for this pragma is shared with Java_Constructor
6152 -- pragma Comment (static_string_EXPRESSION)
6154 -- Processing for pragma Comment shares the circuitry for pragma
6155 -- Ident. The only differences are that Ident enforces a limit of 31
6156 -- characters on its argument, and also enforces limitations on
6157 -- placement for DEC compatibility. Pragma Comment shares neither of
6158 -- these restrictions.
6164 -- pragma Common_Object (
6165 -- [Internal =>] LOCAL_NAME
6166 -- [, [External =>] EXTERNAL_SYMBOL]
6167 -- [, [Size =>] EXTERNAL_SYMBOL]);
6169 -- Processing for this pragma is shared with Psect_Object
6171 ------------------------
6172 -- Compile_Time_Error --
6173 ------------------------
6175 -- pragma Compile_Time_Error
6176 -- (boolean_EXPRESSION, static_string_EXPRESSION);
6178 when Pragma_Compile_Time_Error =>
6180 Process_Compile_Time_Warning_Or_Error;
6182 --------------------------
6183 -- Compile_Time_Warning --
6184 --------------------------
6186 -- pragma Compile_Time_Warning
6187 -- (boolean_EXPRESSION, static_string_EXPRESSION);
6189 when Pragma_Compile_Time_Warning =>
6191 Process_Compile_Time_Warning_Or_Error;
6197 when Pragma_Compiler_Unit =>
6199 Check_Arg_Count (0);
6200 Set_Is_Compiler_Unit (Get_Source_Unit (N));
6202 -----------------------------
6203 -- Complete_Representation --
6204 -----------------------------
6206 -- pragma Complete_Representation;
6208 when Pragma_Complete_Representation =>
6210 Check_Arg_Count (0);
6212 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
6214 ("pragma & must appear within record representation clause");
6217 ----------------------------
6218 -- Complex_Representation --
6219 ----------------------------
6221 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
6223 when Pragma_Complex_Representation => Complex_Representation : declare
6230 Check_Arg_Count (1);
6231 Check_Optional_Identifier (Arg1, Name_Entity);
6232 Check_Arg_Is_Local_Name (Arg1);
6233 E_Id := Expression (Arg1);
6235 if Etype (E_Id) = Any_Type then
6241 if not Is_Record_Type (E) then
6243 ("argument for pragma% must be record type", Arg1);
6246 Ent := First_Entity (E);
6249 or else No (Next_Entity (Ent))
6250 or else Present (Next_Entity (Next_Entity (Ent)))
6251 or else not Is_Floating_Point_Type (Etype (Ent))
6252 or else Etype (Ent) /= Etype (Next_Entity (Ent))
6255 ("record for pragma% must have two fields of the same "
6256 & "floating-point type", Arg1);
6259 Set_Has_Complex_Representation (Base_Type (E));
6261 -- We need to treat the type has having a non-standard
6262 -- representation, for back-end purposes, even though in
6263 -- general a complex will have the default representation
6264 -- of a record with two real components.
6266 Set_Has_Non_Standard_Rep (Base_Type (E));
6268 end Complex_Representation;
6270 -------------------------
6271 -- Component_Alignment --
6272 -------------------------
6274 -- pragma Component_Alignment (
6275 -- [Form =>] ALIGNMENT_CHOICE
6276 -- [, [Name =>] type_LOCAL_NAME]);
6278 -- ALIGNMENT_CHOICE ::=
6280 -- | Component_Size_4
6284 when Pragma_Component_Alignment => Component_AlignmentP : declare
6285 Args : Args_List (1 .. 2);
6286 Names : constant Name_List (1 .. 2) := (
6290 Form : Node_Id renames Args (1);
6291 Name : Node_Id renames Args (2);
6293 Atype : Component_Alignment_Kind;
6298 Gather_Associations (Names, Args);
6301 Error_Pragma ("missing Form argument for pragma%");
6304 Check_Arg_Is_Identifier (Form);
6306 -- Get proper alignment, note that Default = Component_Size on all
6307 -- machines we have so far, and we want to set this value rather
6308 -- than the default value to indicate that it has been explicitly
6309 -- set (and thus will not get overridden by the default component
6310 -- alignment for the current scope)
6312 if Chars (Form) = Name_Component_Size then
6313 Atype := Calign_Component_Size;
6315 elsif Chars (Form) = Name_Component_Size_4 then
6316 Atype := Calign_Component_Size_4;
6318 elsif Chars (Form) = Name_Default then
6319 Atype := Calign_Component_Size;
6321 elsif Chars (Form) = Name_Storage_Unit then
6322 Atype := Calign_Storage_Unit;
6326 ("invalid Form parameter for pragma%", Form);
6329 -- Case with no name, supplied, affects scope table entry
6333 (Scope_Stack.Last).Component_Alignment_Default := Atype;
6335 -- Case of name supplied
6338 Check_Arg_Is_Local_Name (Name);
6340 Typ := Entity (Name);
6343 or else Rep_Item_Too_Early (Typ, N)
6347 Typ := Underlying_Type (Typ);
6350 if not Is_Record_Type (Typ)
6351 and then not Is_Array_Type (Typ)
6354 ("Name parameter of pragma% must identify record or " &
6355 "array type", Name);
6358 -- An explicit Component_Alignment pragma overrides an
6359 -- implicit pragma Pack, but not an explicit one.
6361 if not Has_Pragma_Pack (Base_Type (Typ)) then
6362 Set_Is_Packed (Base_Type (Typ), False);
6363 Set_Component_Alignment (Base_Type (Typ), Atype);
6366 end Component_AlignmentP;
6372 -- pragma Controlled (first_subtype_LOCAL_NAME);
6374 when Pragma_Controlled => Controlled : declare
6378 Check_No_Identifiers;
6379 Check_Arg_Count (1);
6380 Check_Arg_Is_Local_Name (Arg1);
6381 Arg := Expression (Arg1);
6383 if not Is_Entity_Name (Arg)
6384 or else not Is_Access_Type (Entity (Arg))
6386 Error_Pragma_Arg ("pragma% requires access type", Arg1);
6388 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
6396 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
6397 -- [Entity =>] LOCAL_NAME);
6399 when Pragma_Convention => Convention : declare
6402 pragma Warnings (Off, C);
6403 pragma Warnings (Off, E);
6405 Check_Arg_Order ((Name_Convention, Name_Entity));
6406 Check_Ada_83_Warning;
6407 Check_Arg_Count (2);
6408 Process_Convention (C, E);
6411 ---------------------------
6412 -- Convention_Identifier --
6413 ---------------------------
6415 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
6416 -- [Convention =>] convention_IDENTIFIER);
6418 when Pragma_Convention_Identifier => Convention_Identifier : declare
6424 Check_Arg_Order ((Name_Name, Name_Convention));
6425 Check_Arg_Count (2);
6426 Check_Optional_Identifier (Arg1, Name_Name);
6427 Check_Optional_Identifier (Arg2, Name_Convention);
6428 Check_Arg_Is_Identifier (Arg1);
6429 Check_Arg_Is_Identifier (Arg2);
6430 Idnam := Chars (Expression (Arg1));
6431 Cname := Chars (Expression (Arg2));
6433 if Is_Convention_Name (Cname) then
6434 Record_Convention_Identifier
6435 (Idnam, Get_Convention_Id (Cname));
6438 ("second arg for % pragma must be convention", Arg2);
6440 end Convention_Identifier;
6446 -- pragma CPP_Class ([Entity =>] local_NAME)
6448 when Pragma_CPP_Class => CPP_Class : declare
6453 if Warn_On_Obsolescent_Feature then
6455 ("'G'N'A'T pragma cpp'_class is now obsolete; replace it" &
6456 " by pragma import?", N);
6460 Check_Arg_Count (1);
6461 Check_Optional_Identifier (Arg1, Name_Entity);
6462 Check_Arg_Is_Local_Name (Arg1);
6464 Arg := Expression (Arg1);
6467 if Etype (Arg) = Any_Type then
6471 if not Is_Entity_Name (Arg)
6472 or else not Is_Type (Entity (Arg))
6474 Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
6477 Typ := Entity (Arg);
6479 if not Is_Tagged_Type (Typ) then
6480 Error_Pragma_Arg ("pragma% applicable to tagged types ", Arg1);
6483 -- Types treated as CPP classes are treated as limited, but we
6484 -- don't require them to be declared this way. A warning is issued
6485 -- to encourage the user to declare them as limited. This is not
6486 -- an error, for compatibility reasons, because these types have
6487 -- been supported this way for some time.
6489 if not Is_Limited_Type (Typ) then
6491 ("imported 'C'P'P type should be " &
6492 "explicitly declared limited?",
6493 Get_Pragma_Arg (Arg1));
6495 ("\type will be considered limited",
6496 Get_Pragma_Arg (Arg1));
6499 Set_Is_CPP_Class (Typ);
6500 Set_Is_Limited_Record (Typ);
6501 Set_Convention (Typ, Convention_CPP);
6503 -- Imported CPP types must not have discriminants (because C++
6504 -- classes do not have discriminants).
6506 if Has_Discriminants (Typ) then
6508 ("imported 'C'P'P type cannot have discriminants",
6509 First (Discriminant_Specifications
6510 (Declaration_Node (Typ))));
6513 -- Components of imported CPP types must not have default
6514 -- expressions because the constructor (if any) is in the
6517 if Is_Incomplete_Or_Private_Type (Typ)
6518 and then No (Underlying_Type (Typ))
6520 -- It should be an error to apply pragma CPP to a private
6521 -- type if the underlying type is not visible (as it is
6522 -- for any representation item). For now, for backward
6523 -- compatibility we do nothing but we cannot check components
6524 -- because they are not available at this stage. All this code
6525 -- will be removed when we cleanup this obsolete GNAT pragma???
6531 Tdef : constant Node_Id :=
6532 Type_Definition (Declaration_Node (Typ));
6537 if Nkind (Tdef) = N_Record_Definition then
6538 Clist := Component_List (Tdef);
6540 pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition);
6541 Clist := Component_List (Record_Extension_Part (Tdef));
6544 if Present (Clist) then
6545 Comp := First (Component_Items (Clist));
6546 while Present (Comp) loop
6547 if Present (Expression (Comp)) then
6549 ("component of imported 'C'P'P type cannot have" &
6550 " default expression", Expression (Comp));
6560 ---------------------
6561 -- CPP_Constructor --
6562 ---------------------
6564 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
6565 -- [, [External_Name =>] static_string_EXPRESSION ]
6566 -- [, [Link_Name =>] static_string_EXPRESSION ]);
6568 when Pragma_CPP_Constructor => CPP_Constructor : declare
6572 Tag_Typ : Entity_Id;
6576 Check_At_Least_N_Arguments (1);
6577 Check_At_Most_N_Arguments (3);
6578 Check_Optional_Identifier (Arg1, Name_Entity);
6579 Check_Arg_Is_Local_Name (Arg1);
6581 Id := Expression (Arg1);
6582 Find_Program_Unit_Name (Id);
6584 -- If we did not find the name, we are done
6586 if Etype (Id) = Any_Type then
6590 Def_Id := Entity (Id);
6592 -- Check if already defined as constructor
6594 if Is_Constructor (Def_Id) then
6596 ("?duplicate argument for pragma 'C'P'P_Constructor", Arg1);
6600 if Ekind (Def_Id) = E_Function
6601 and then (Is_CPP_Class (Etype (Def_Id))
6602 or else (Is_Class_Wide_Type (Etype (Def_Id))
6604 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
6606 if Arg_Count >= 2 then
6607 Set_Imported (Def_Id);
6608 Set_Is_Public (Def_Id);
6609 Process_Interface_Name (Def_Id, Arg2, Arg3);
6612 Set_Has_Completion (Def_Id);
6613 Set_Is_Constructor (Def_Id);
6615 -- Imported C++ constructors are not dispatching primitives
6616 -- because in C++ they don't have a dispatch table slot.
6617 -- However, in Ada the constructor has the profile of a
6618 -- function that returns a tagged type and therefore it has
6619 -- been treated as a primitive operation during semantic
6620 -- analysis. We now remove it from the list of primitive
6621 -- operations of the type.
6623 if Is_Tagged_Type (Etype (Def_Id))
6624 and then not Is_Class_Wide_Type (Etype (Def_Id))
6626 pragma Assert (Is_Dispatching_Operation (Def_Id));
6627 Tag_Typ := Etype (Def_Id);
6629 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
6630 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
6634 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
6635 Set_Is_Dispatching_Operation (Def_Id, False);
6638 -- For backward compatibility, if the constructor returns a
6639 -- class wide type, and we internally change the return type to
6640 -- the corresponding root type.
6642 if Is_Class_Wide_Type (Etype (Def_Id)) then
6643 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
6647 ("pragma% requires function returning a 'C'P'P_Class type",
6650 end CPP_Constructor;
6656 when Pragma_CPP_Virtual => CPP_Virtual : declare
6660 if Warn_On_Obsolescent_Feature then
6662 ("'G'N'A'T pragma cpp'_virtual is now obsolete and has " &
6671 when Pragma_CPP_Vtable => CPP_Vtable : declare
6675 if Warn_On_Obsolescent_Feature then
6677 ("'G'N'A'T pragma cpp'_vtable is now obsolete and has " &
6686 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
6688 when Pragma_Debug => Debug : declare
6696 (Boolean_Literals (Debug_Pragmas_Enabled and Expander_Active),
6699 if Arg_Count = 2 then
6702 Left_Opnd => Relocate_Node (Cond),
6703 Right_Opnd => Expression (Arg1));
6706 -- Rewrite into a conditional with an appropriate condition. We
6707 -- wrap the procedure call in a block so that overhead from e.g.
6708 -- use of the secondary stack does not generate execution overhead
6709 -- for suppressed conditions.
6711 Rewrite (N, Make_Implicit_If_Statement (N,
6713 Then_Statements => New_List (
6714 Make_Block_Statement (Loc,
6715 Handled_Statement_Sequence =>
6716 Make_Handled_Sequence_Of_Statements (Loc,
6717 Statements => New_List (
6718 Relocate_Node (Debug_Statement (N))))))));
6726 -- pragma Debug_Policy (Check | Ignore)
6728 when Pragma_Debug_Policy =>
6730 Check_Arg_Count (1);
6731 Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Ignore);
6732 Debug_Pragmas_Enabled := Chars (Expression (Arg1)) = Name_Check;
6734 ---------------------
6735 -- Detect_Blocking --
6736 ---------------------
6738 -- pragma Detect_Blocking;
6740 when Pragma_Detect_Blocking =>
6742 Check_Arg_Count (0);
6743 Check_Valid_Configuration_Pragma;
6744 Detect_Blocking := True;
6750 when Pragma_Dimension =>
6752 Check_Arg_Count (4);
6753 Check_No_Identifiers;
6754 Check_Arg_Is_Local_Name (Arg1);
6756 if not Is_Type (Arg1) then
6757 Error_Pragma ("first argument for pragma% must be subtype");
6760 Check_Arg_Is_Static_Expression (Arg2, Standard_Integer);
6761 Check_Arg_Is_Static_Expression (Arg3, Standard_Integer);
6762 Check_Arg_Is_Static_Expression (Arg4, Standard_Integer);
6768 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
6770 when Pragma_Discard_Names => Discard_Names : declare
6775 Check_Ada_83_Warning;
6777 -- Deal with configuration pragma case
6779 if Arg_Count = 0 and then Is_Configuration_Pragma then
6780 Global_Discard_Names := True;
6783 -- Otherwise, check correct appropriate context
6786 Check_Is_In_Decl_Part_Or_Package_Spec;
6788 if Arg_Count = 0 then
6790 -- If there is no parameter, then from now on this pragma
6791 -- applies to any enumeration, exception or tagged type
6792 -- defined in the current declarative part, and recursively
6793 -- to any nested scope.
6795 Set_Discard_Names (Current_Scope);
6799 Check_Arg_Count (1);
6800 Check_Optional_Identifier (Arg1, Name_On);
6801 Check_Arg_Is_Local_Name (Arg1);
6803 E_Id := Expression (Arg1);
6805 if Etype (E_Id) = Any_Type then
6811 if (Is_First_Subtype (E)
6813 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
6814 or else Ekind (E) = E_Exception
6816 Set_Discard_Names (E);
6819 ("inappropriate entity for pragma%", Arg1);
6830 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
6832 when Pragma_Elaborate => Elaborate : declare
6837 -- Pragma must be in context items list of a compilation unit
6839 if not Is_In_Context_Clause then
6843 -- Must be at least one argument
6845 if Arg_Count = 0 then
6846 Error_Pragma ("pragma% requires at least one argument");
6849 -- In Ada 83 mode, there can be no items following it in the
6850 -- context list except other pragmas and implicit with clauses
6851 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
6852 -- placement rule does not apply.
6854 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
6856 while Present (Citem) loop
6857 if Nkind (Citem) = N_Pragma
6858 or else (Nkind (Citem) = N_With_Clause
6859 and then Implicit_With (Citem))
6864 ("(Ada 83) pragma% must be at end of context clause");
6871 -- Finally, the arguments must all be units mentioned in a with
6872 -- clause in the same context clause. Note we already checked (in
6873 -- Par.Prag) that the arguments are all identifiers or selected
6877 Outer : while Present (Arg) loop
6878 Citem := First (List_Containing (N));
6879 Inner : while Citem /= N loop
6880 if Nkind (Citem) = N_With_Clause
6881 and then Same_Name (Name (Citem), Expression (Arg))
6883 Set_Elaborate_Present (Citem, True);
6884 Set_Unit_Name (Expression (Arg), Name (Citem));
6886 -- With the pragma present, elaboration calls on
6887 -- subprograms from the named unit need no further
6888 -- checks, as long as the pragma appears in the current
6889 -- compilation unit. If the pragma appears in some unit
6890 -- in the context, there might still be a need for an
6891 -- Elaborate_All_Desirable from the current compilation
6892 -- to the named unit, so we keep the check enabled.
6894 if In_Extended_Main_Source_Unit (N) then
6895 Set_Suppress_Elaboration_Warnings
6896 (Entity (Name (Citem)));
6907 ("argument of pragma% is not with'ed unit", Arg);
6913 -- Give a warning if operating in static mode with -gnatwl
6914 -- (elaboration warnings enabled) switch set.
6916 if Elab_Warnings and not Dynamic_Elaboration_Checks then
6918 ("?use of pragma Elaborate may not be safe", N);
6920 ("?use pragma Elaborate_All instead if possible", N);
6928 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
6930 when Pragma_Elaborate_All => Elaborate_All : declare
6935 Check_Ada_83_Warning;
6937 -- Pragma must be in context items list of a compilation unit
6939 if not Is_In_Context_Clause then
6943 -- Must be at least one argument
6945 if Arg_Count = 0 then
6946 Error_Pragma ("pragma% requires at least one argument");
6949 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
6950 -- have to appear at the end of the context clause, but may
6951 -- appear mixed in with other items, even in Ada 83 mode.
6953 -- Final check: the arguments must all be units mentioned in
6954 -- a with clause in the same context clause. Note that we
6955 -- already checked (in Par.Prag) that all the arguments are
6956 -- either identifiers or selected components.
6959 Outr : while Present (Arg) loop
6960 Citem := First (List_Containing (N));
6961 Innr : while Citem /= N loop
6962 if Nkind (Citem) = N_With_Clause
6963 and then Same_Name (Name (Citem), Expression (Arg))
6965 Set_Elaborate_All_Present (Citem, True);
6966 Set_Unit_Name (Expression (Arg), Name (Citem));
6968 -- Suppress warnings and elaboration checks on the named
6969 -- unit if the pragma is in the current compilation, as
6970 -- for pragma Elaborate.
6972 if In_Extended_Main_Source_Unit (N) then
6973 Set_Suppress_Elaboration_Warnings
6974 (Entity (Name (Citem)));
6983 Set_Error_Posted (N);
6985 ("argument of pragma% is not with'ed unit", Arg);
6992 --------------------
6993 -- Elaborate_Body --
6994 --------------------
6996 -- pragma Elaborate_Body [( library_unit_NAME )];
6998 when Pragma_Elaborate_Body => Elaborate_Body : declare
6999 Cunit_Node : Node_Id;
7000 Cunit_Ent : Entity_Id;
7003 Check_Ada_83_Warning;
7004 Check_Valid_Library_Unit_Pragma;
7006 if Nkind (N) = N_Null_Statement then
7010 Cunit_Node := Cunit (Current_Sem_Unit);
7011 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
7013 if Nkind_In (Unit (Cunit_Node), N_Package_Body,
7016 Error_Pragma ("pragma% must refer to a spec, not a body");
7018 Set_Body_Required (Cunit_Node, True);
7019 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
7021 -- If we are in dynamic elaboration mode, then we suppress
7022 -- elaboration warnings for the unit, since it is definitely
7023 -- fine NOT to do dynamic checks at the first level (and such
7024 -- checks will be suppressed because no elaboration boolean
7025 -- is created for Elaborate_Body packages).
7027 -- But in the static model of elaboration, Elaborate_Body is
7028 -- definitely NOT good enough to ensure elaboration safety on
7029 -- its own, since the body may WITH other units that are not
7030 -- safe from an elaboration point of view, so a client must
7031 -- still do an Elaborate_All on such units.
7033 -- Debug flag -gnatdD restores the old behavior of 3.13, where
7034 -- Elaborate_Body always suppressed elab warnings.
7036 if Dynamic_Elaboration_Checks or Debug_Flag_DD then
7037 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
7042 ------------------------
7043 -- Elaboration_Checks --
7044 ------------------------
7046 -- pragma Elaboration_Checks (Static | Dynamic);
7048 when Pragma_Elaboration_Checks =>
7050 Check_Arg_Count (1);
7051 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
7052 Dynamic_Elaboration_Checks :=
7053 (Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic);
7059 -- pragma Eliminate (
7060 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
7061 -- [,[Entity =>] IDENTIFIER |
7062 -- SELECTED_COMPONENT |
7064 -- [, OVERLOADING_RESOLUTION]);
7066 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
7069 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
7072 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
7074 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
7075 -- Result_Type => result_SUBTYPE_NAME]
7077 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
7078 -- SUBTYPE_NAME ::= STRING_LITERAL
7080 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
7081 -- SOURCE_TRACE ::= STRING_LITERAL
7083 when Pragma_Eliminate => Eliminate : declare
7084 Args : Args_List (1 .. 5);
7085 Names : constant Name_List (1 .. 5) := (
7088 Name_Parameter_Types,
7090 Name_Source_Location);
7092 Unit_Name : Node_Id renames Args (1);
7093 Entity : Node_Id renames Args (2);
7094 Parameter_Types : Node_Id renames Args (3);
7095 Result_Type : Node_Id renames Args (4);
7096 Source_Location : Node_Id renames Args (5);
7100 Check_Valid_Configuration_Pragma;
7101 Gather_Associations (Names, Args);
7103 if No (Unit_Name) then
7104 Error_Pragma ("missing Unit_Name argument for pragma%");
7108 and then (Present (Parameter_Types)
7110 Present (Result_Type)
7112 Present (Source_Location))
7114 Error_Pragma ("missing Entity argument for pragma%");
7117 if (Present (Parameter_Types)
7119 Present (Result_Type))
7121 Present (Source_Location)
7124 ("parameter profile and source location cannot " &
7125 "be used together in pragma%");
7128 Process_Eliminate_Pragma
7142 -- [ Convention =>] convention_IDENTIFIER,
7143 -- [ Entity =>] local_NAME
7144 -- [, [External_Name =>] static_string_EXPRESSION ]
7145 -- [, [Link_Name =>] static_string_EXPRESSION ]);
7147 when Pragma_Export => Export : declare
7151 pragma Warnings (Off, C);
7154 Check_Ada_83_Warning;
7160 Check_At_Least_N_Arguments (2);
7161 Check_At_Most_N_Arguments (4);
7162 Process_Convention (C, Def_Id);
7164 if Ekind (Def_Id) /= E_Constant then
7165 Note_Possible_Modification (Expression (Arg2), Sure => False);
7168 Process_Interface_Name (Def_Id, Arg3, Arg4);
7169 Set_Exported (Def_Id, Arg2);
7171 -- If the entity is a deferred constant, propagate the information
7172 -- to the full view, because gigi elaborates the full view only.
7174 if Ekind (Def_Id) = E_Constant
7175 and then Present (Full_View (Def_Id))
7178 Id2 : constant Entity_Id := Full_View (Def_Id);
7180 Set_Is_Exported (Id2, Is_Exported (Def_Id));
7181 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
7182 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
7187 ----------------------
7188 -- Export_Exception --
7189 ----------------------
7191 -- pragma Export_Exception (
7192 -- [Internal =>] LOCAL_NAME
7193 -- [, [External =>] EXTERNAL_SYMBOL]
7194 -- [, [Form =>] Ada | VMS]
7195 -- [, [Code =>] static_integer_EXPRESSION]);
7197 when Pragma_Export_Exception => Export_Exception : declare
7198 Args : Args_List (1 .. 4);
7199 Names : constant Name_List (1 .. 4) := (
7205 Internal : Node_Id renames Args (1);
7206 External : Node_Id renames Args (2);
7207 Form : Node_Id renames Args (3);
7208 Code : Node_Id renames Args (4);
7213 if Inside_A_Generic then
7214 Error_Pragma ("pragma% cannot be used for generic entities");
7217 Gather_Associations (Names, Args);
7218 Process_Extended_Import_Export_Exception_Pragma (
7219 Arg_Internal => Internal,
7220 Arg_External => External,
7224 if not Is_VMS_Exception (Entity (Internal)) then
7225 Set_Exported (Entity (Internal), Internal);
7227 end Export_Exception;
7229 ---------------------
7230 -- Export_Function --
7231 ---------------------
7233 -- pragma Export_Function (
7234 -- [Internal =>] LOCAL_NAME
7235 -- [, [External =>] EXTERNAL_SYMBOL]
7236 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
7237 -- [, [Result_Type =>] TYPE_DESIGNATOR]
7238 -- [, [Mechanism =>] MECHANISM]
7239 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
7241 -- EXTERNAL_SYMBOL ::=
7243 -- | static_string_EXPRESSION
7245 -- PARAMETER_TYPES ::=
7247 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
7249 -- TYPE_DESIGNATOR ::=
7251 -- | subtype_Name ' Access
7255 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
7257 -- MECHANISM_ASSOCIATION ::=
7258 -- [formal_parameter_NAME =>] MECHANISM_NAME
7260 -- MECHANISM_NAME ::=
7263 -- | Descriptor [([Class =>] CLASS_NAME)]
7265 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7267 when Pragma_Export_Function => Export_Function : declare
7268 Args : Args_List (1 .. 6);
7269 Names : constant Name_List (1 .. 6) := (
7272 Name_Parameter_Types,
7275 Name_Result_Mechanism);
7277 Internal : Node_Id renames Args (1);
7278 External : Node_Id renames Args (2);
7279 Parameter_Types : Node_Id renames Args (3);
7280 Result_Type : Node_Id renames Args (4);
7281 Mechanism : Node_Id renames Args (5);
7282 Result_Mechanism : Node_Id renames Args (6);
7286 Gather_Associations (Names, Args);
7287 Process_Extended_Import_Export_Subprogram_Pragma (
7288 Arg_Internal => Internal,
7289 Arg_External => External,
7290 Arg_Parameter_Types => Parameter_Types,
7291 Arg_Result_Type => Result_Type,
7292 Arg_Mechanism => Mechanism,
7293 Arg_Result_Mechanism => Result_Mechanism);
7294 end Export_Function;
7300 -- pragma Export_Object (
7301 -- [Internal =>] LOCAL_NAME
7302 -- [, [External =>] EXTERNAL_SYMBOL]
7303 -- [, [Size =>] EXTERNAL_SYMBOL]);
7305 -- EXTERNAL_SYMBOL ::=
7307 -- | static_string_EXPRESSION
7309 -- PARAMETER_TYPES ::=
7311 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
7313 -- TYPE_DESIGNATOR ::=
7315 -- | subtype_Name ' Access
7319 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
7321 -- MECHANISM_ASSOCIATION ::=
7322 -- [formal_parameter_NAME =>] MECHANISM_NAME
7324 -- MECHANISM_NAME ::=
7327 -- | Descriptor [([Class =>] CLASS_NAME)]
7329 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7331 when Pragma_Export_Object => Export_Object : declare
7332 Args : Args_List (1 .. 3);
7333 Names : constant Name_List (1 .. 3) := (
7338 Internal : Node_Id renames Args (1);
7339 External : Node_Id renames Args (2);
7340 Size : Node_Id renames Args (3);
7344 Gather_Associations (Names, Args);
7345 Process_Extended_Import_Export_Object_Pragma (
7346 Arg_Internal => Internal,
7347 Arg_External => External,
7351 ----------------------
7352 -- Export_Procedure --
7353 ----------------------
7355 -- pragma Export_Procedure (
7356 -- [Internal =>] LOCAL_NAME
7357 -- [, [External =>] EXTERNAL_SYMBOL]
7358 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
7359 -- [, [Mechanism =>] MECHANISM]);
7361 -- EXTERNAL_SYMBOL ::=
7363 -- | static_string_EXPRESSION
7365 -- PARAMETER_TYPES ::=
7367 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
7369 -- TYPE_DESIGNATOR ::=
7371 -- | subtype_Name ' Access
7375 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
7377 -- MECHANISM_ASSOCIATION ::=
7378 -- [formal_parameter_NAME =>] MECHANISM_NAME
7380 -- MECHANISM_NAME ::=
7383 -- | Descriptor [([Class =>] CLASS_NAME)]
7385 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7387 when Pragma_Export_Procedure => Export_Procedure : declare
7388 Args : Args_List (1 .. 4);
7389 Names : constant Name_List (1 .. 4) := (
7392 Name_Parameter_Types,
7395 Internal : Node_Id renames Args (1);
7396 External : Node_Id renames Args (2);
7397 Parameter_Types : Node_Id renames Args (3);
7398 Mechanism : Node_Id renames Args (4);
7402 Gather_Associations (Names, Args);
7403 Process_Extended_Import_Export_Subprogram_Pragma (
7404 Arg_Internal => Internal,
7405 Arg_External => External,
7406 Arg_Parameter_Types => Parameter_Types,
7407 Arg_Mechanism => Mechanism);
7408 end Export_Procedure;
7414 -- pragma Export_Value (
7415 -- [Value =>] static_integer_EXPRESSION,
7416 -- [Link_Name =>] static_string_EXPRESSION);
7418 when Pragma_Export_Value =>
7420 Check_Arg_Order ((Name_Value, Name_Link_Name));
7421 Check_Arg_Count (2);
7423 Check_Optional_Identifier (Arg1, Name_Value);
7424 Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
7426 Check_Optional_Identifier (Arg2, Name_Link_Name);
7427 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
7429 -----------------------------
7430 -- Export_Valued_Procedure --
7431 -----------------------------
7433 -- pragma Export_Valued_Procedure (
7434 -- [Internal =>] LOCAL_NAME
7435 -- [, [External =>] EXTERNAL_SYMBOL,]
7436 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
7437 -- [, [Mechanism =>] MECHANISM]);
7439 -- EXTERNAL_SYMBOL ::=
7441 -- | static_string_EXPRESSION
7443 -- PARAMETER_TYPES ::=
7445 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
7447 -- TYPE_DESIGNATOR ::=
7449 -- | subtype_Name ' Access
7453 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
7455 -- MECHANISM_ASSOCIATION ::=
7456 -- [formal_parameter_NAME =>] MECHANISM_NAME
7458 -- MECHANISM_NAME ::=
7461 -- | Descriptor [([Class =>] CLASS_NAME)]
7463 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7465 when Pragma_Export_Valued_Procedure =>
7466 Export_Valued_Procedure : declare
7467 Args : Args_List (1 .. 4);
7468 Names : constant Name_List (1 .. 4) := (
7471 Name_Parameter_Types,
7474 Internal : Node_Id renames Args (1);
7475 External : Node_Id renames Args (2);
7476 Parameter_Types : Node_Id renames Args (3);
7477 Mechanism : Node_Id renames Args (4);
7481 Gather_Associations (Names, Args);
7482 Process_Extended_Import_Export_Subprogram_Pragma (
7483 Arg_Internal => Internal,
7484 Arg_External => External,
7485 Arg_Parameter_Types => Parameter_Types,
7486 Arg_Mechanism => Mechanism);
7487 end Export_Valued_Procedure;
7493 -- pragma Extend_System ([Name =>] Identifier);
7495 when Pragma_Extend_System => Extend_System : declare
7498 Check_Valid_Configuration_Pragma;
7499 Check_Arg_Count (1);
7500 Check_Optional_Identifier (Arg1, Name_Name);
7501 Check_Arg_Is_Identifier (Arg1);
7503 Get_Name_String (Chars (Expression (Arg1)));
7506 and then Name_Buffer (1 .. 4) = "aux_"
7508 if Present (System_Extend_Pragma_Arg) then
7509 if Chars (Expression (Arg1)) =
7510 Chars (Expression (System_Extend_Pragma_Arg))
7514 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
7515 Error_Pragma ("pragma% conflicts with that #");
7519 System_Extend_Pragma_Arg := Arg1;
7521 if not GNAT_Mode then
7522 System_Extend_Unit := Arg1;
7526 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
7530 ------------------------
7531 -- Extensions_Allowed --
7532 ------------------------
7534 -- pragma Extensions_Allowed (ON | OFF);
7536 when Pragma_Extensions_Allowed =>
7538 Check_Arg_Count (1);
7539 Check_No_Identifiers;
7540 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
7542 if Chars (Expression (Arg1)) = Name_On then
7543 Extensions_Allowed := True;
7544 Ada_Version := Ada_Version_Type'Last;
7547 Extensions_Allowed := False;
7548 Ada_Version := Ada_Version_Explicit;
7555 -- pragma External (
7556 -- [ Convention =>] convention_IDENTIFIER,
7557 -- [ Entity =>] local_NAME
7558 -- [, [External_Name =>] static_string_EXPRESSION ]
7559 -- [, [Link_Name =>] static_string_EXPRESSION ]);
7561 when Pragma_External => External : declare
7565 pragma Warnings (Off, C);
7574 Check_At_Least_N_Arguments (2);
7575 Check_At_Most_N_Arguments (4);
7576 Process_Convention (C, Def_Id);
7577 Note_Possible_Modification (Expression (Arg2), Sure => False);
7578 Process_Interface_Name (Def_Id, Arg3, Arg4);
7579 Set_Exported (Def_Id, Arg2);
7582 --------------------------
7583 -- External_Name_Casing --
7584 --------------------------
7586 -- pragma External_Name_Casing (
7587 -- UPPERCASE | LOWERCASE
7588 -- [, AS_IS | UPPERCASE | LOWERCASE]);
7590 when Pragma_External_Name_Casing => External_Name_Casing : declare
7593 Check_No_Identifiers;
7595 if Arg_Count = 2 then
7597 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
7599 case Chars (Get_Pragma_Arg (Arg2)) is
7601 Opt.External_Name_Exp_Casing := As_Is;
7603 when Name_Uppercase =>
7604 Opt.External_Name_Exp_Casing := Uppercase;
7606 when Name_Lowercase =>
7607 Opt.External_Name_Exp_Casing := Lowercase;
7614 Check_Arg_Count (1);
7617 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
7619 case Chars (Get_Pragma_Arg (Arg1)) is
7620 when Name_Uppercase =>
7621 Opt.External_Name_Imp_Casing := Uppercase;
7623 when Name_Lowercase =>
7624 Opt.External_Name_Imp_Casing := Lowercase;
7629 end External_Name_Casing;
7631 --------------------------
7632 -- Favor_Top_Level --
7633 --------------------------
7635 -- pragma Favor_Top_Level (type_NAME);
7637 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
7638 Named_Entity : Entity_Id;
7642 Check_No_Identifiers;
7643 Check_Arg_Count (1);
7644 Check_Arg_Is_Local_Name (Arg1);
7645 Named_Entity := Entity (Expression (Arg1));
7647 -- If it's an access-to-subprogram type (in particular, not a
7648 -- subtype), set the flag on that type.
7650 if Is_Access_Subprogram_Type (Named_Entity) then
7651 Set_Can_Use_Internal_Rep (Named_Entity, False);
7653 -- Otherwise it's an error (name denotes the wrong sort of entity)
7657 ("access-to-subprogram type expected", Expression (Arg1));
7659 end Favor_Top_Level;
7665 -- pragma Fast_Math;
7667 when Pragma_Fast_Math =>
7669 Check_No_Identifiers;
7670 Check_Valid_Configuration_Pragma;
7673 ---------------------------
7674 -- Finalize_Storage_Only --
7675 ---------------------------
7677 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
7679 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
7680 Assoc : constant Node_Id := Arg1;
7681 Type_Id : constant Node_Id := Expression (Assoc);
7686 Check_No_Identifiers;
7687 Check_Arg_Count (1);
7688 Check_Arg_Is_Local_Name (Arg1);
7690 Find_Type (Type_Id);
7691 Typ := Entity (Type_Id);
7694 or else Rep_Item_Too_Early (Typ, N)
7698 Typ := Underlying_Type (Typ);
7701 if not Is_Controlled (Typ) then
7702 Error_Pragma ("pragma% must specify controlled type");
7705 Check_First_Subtype (Arg1);
7707 if Finalize_Storage_Only (Typ) then
7708 Error_Pragma ("duplicate pragma%, only one allowed");
7710 elsif not Rep_Item_Too_Late (Typ, N) then
7711 Set_Finalize_Storage_Only (Base_Type (Typ), True);
7713 end Finalize_Storage;
7715 --------------------------
7716 -- Float_Representation --
7717 --------------------------
7719 -- pragma Float_Representation (FLOAT_REP[, float_type_LOCAL_NAME]);
7721 -- FLOAT_REP ::= VAX_Float | IEEE_Float
7723 when Pragma_Float_Representation => Float_Representation : declare
7731 if Arg_Count = 1 then
7732 Check_Valid_Configuration_Pragma;
7734 Check_Arg_Count (2);
7735 Check_Optional_Identifier (Arg2, Name_Entity);
7736 Check_Arg_Is_Local_Name (Arg2);
7739 Check_No_Identifier (Arg1);
7740 Check_Arg_Is_One_Of (Arg1, Name_VAX_Float, Name_IEEE_Float);
7742 if not OpenVMS_On_Target then
7743 if Chars (Expression (Arg1)) = Name_VAX_Float then
7745 ("?pragma% ignored (applies only to Open'V'M'S)");
7751 -- One argument case
7753 if Arg_Count = 1 then
7754 if Chars (Expression (Arg1)) = Name_VAX_Float then
7755 if Opt.Float_Format = 'I' then
7756 Error_Pragma ("'I'E'E'E format previously specified");
7759 Opt.Float_Format := 'V';
7762 if Opt.Float_Format = 'V' then
7763 Error_Pragma ("'V'A'X format previously specified");
7766 Opt.Float_Format := 'I';
7769 Set_Standard_Fpt_Formats;
7771 -- Two argument case
7774 Argx := Get_Pragma_Arg (Arg2);
7776 if not Is_Entity_Name (Argx)
7777 or else not Is_Floating_Point_Type (Entity (Argx))
7780 ("second argument of% pragma must be floating-point type",
7784 Ent := Entity (Argx);
7785 Digs := UI_To_Int (Digits_Value (Ent));
7787 -- Two arguments, VAX_Float case
7789 if Chars (Expression (Arg1)) = Name_VAX_Float then
7791 when 6 => Set_F_Float (Ent);
7792 when 9 => Set_D_Float (Ent);
7793 when 15 => Set_G_Float (Ent);
7797 ("wrong digits value, must be 6,9 or 15", Arg2);
7800 -- Two arguments, IEEE_Float case
7804 when 6 => Set_IEEE_Short (Ent);
7805 when 15 => Set_IEEE_Long (Ent);
7809 ("wrong digits value, must be 6 or 15", Arg2);
7813 end Float_Representation;
7819 -- pragma Ident (static_string_EXPRESSION)
7821 -- Note: pragma Comment shares this processing. Pragma Comment is
7822 -- identical to Ident, except that the restriction of the argument to
7823 -- 31 characters and the placement restrictions are not enforced for
7826 when Pragma_Ident | Pragma_Comment => Ident : declare
7831 Check_Arg_Count (1);
7832 Check_No_Identifiers;
7833 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
7836 -- For pragma Ident, preserve DEC compatibility by requiring the
7837 -- pragma to appear in a declarative part or package spec.
7839 if Prag_Id = Pragma_Ident then
7840 Check_Is_In_Decl_Part_Or_Package_Spec;
7843 Str := Expr_Value_S (Expression (Arg1));
7850 GP := Parent (Parent (N));
7852 if Nkind_In (GP, N_Package_Declaration,
7853 N_Generic_Package_Declaration)
7858 -- If we have a compilation unit, then record the ident value,
7859 -- checking for improper duplication.
7861 if Nkind (GP) = N_Compilation_Unit then
7862 CS := Ident_String (Current_Sem_Unit);
7864 if Present (CS) then
7866 -- For Ident, we do not permit multiple instances
7868 if Prag_Id = Pragma_Ident then
7869 Error_Pragma ("duplicate% pragma not permitted");
7871 -- For Comment, we concatenate the string, unless we want
7872 -- to preserve the tree structure for ASIS.
7874 elsif not ASIS_Mode then
7875 Start_String (Strval (CS));
7876 Store_String_Char (' ');
7877 Store_String_Chars (Strval (Str));
7878 Set_Strval (CS, End_String);
7882 -- In VMS, the effect of IDENT is achieved by passing
7883 -- --identification=name as a --for-linker switch.
7885 if OpenVMS_On_Target then
7888 ("--for-linker=--identification=");
7889 String_To_Name_Buffer (Strval (Str));
7890 Store_String_Chars (Name_Buffer (1 .. Name_Len));
7892 -- Only the last processed IDENT is saved. The main
7893 -- purpose is so an IDENT associated with a main
7894 -- procedure will be used in preference to an IDENT
7895 -- associated with a with'd package.
7897 Replace_Linker_Option_String
7898 (End_String, "--for-linker=--identification=");
7901 Set_Ident_String (Current_Sem_Unit, Str);
7904 -- For subunits, we just ignore the Ident, since in GNAT these
7905 -- are not separate object files, and hence not separate units
7906 -- in the unit table.
7908 elsif Nkind (GP) = N_Subunit then
7911 -- Otherwise we have a misplaced pragma Ident, but we ignore
7912 -- this if we are in an instantiation, since it comes from
7913 -- a generic, and has no relevance to the instantiation.
7915 elsif Prag_Id = Pragma_Ident then
7916 if Instantiation_Location (Loc) = No_Location then
7917 Error_Pragma ("pragma% only allowed at outer level");
7923 --------------------------
7924 -- Implemented_By_Entry --
7925 --------------------------
7927 -- pragma Implemented_By_Entry (DIRECT_NAME);
7929 when Pragma_Implemented_By_Entry => Implemented_By_Entry : declare
7934 Check_Arg_Count (1);
7935 Check_No_Identifiers;
7936 Check_Arg_Is_Identifier (Arg1);
7937 Check_Arg_Is_Local_Name (Arg1);
7938 Ent := Entity (Expression (Arg1));
7940 -- Pragma Implemented_By_Entry must be applied only to protected
7941 -- synchronized or task interface primitives.
7943 if (Ekind (Ent) /= E_Function
7944 and then Ekind (Ent) /= E_Procedure)
7945 or else not Present (First_Formal (Ent))
7946 or else not Is_Concurrent_Interface (Etype (First_Formal (Ent)))
7949 ("pragma % must be applied to a concurrent interface " &
7953 if Einfo.Implemented_By_Entry (Ent)
7954 and then Warn_On_Redundant_Constructs
7956 Error_Pragma ("?duplicate pragma%!");
7958 Set_Implemented_By_Entry (Ent);
7961 end Implemented_By_Entry;
7963 -----------------------
7964 -- Implicit_Packing --
7965 -----------------------
7967 -- pragma Implicit_Packing;
7969 when Pragma_Implicit_Packing =>
7971 Check_Arg_Count (0);
7972 Implicit_Packing := True;
7979 -- [Convention =>] convention_IDENTIFIER,
7980 -- [Entity =>] local_NAME
7981 -- [, [External_Name =>] static_string_EXPRESSION ]
7982 -- [, [Link_Name =>] static_string_EXPRESSION ]);
7984 when Pragma_Import =>
7985 Check_Ada_83_Warning;
7991 Check_At_Least_N_Arguments (2);
7992 Check_At_Most_N_Arguments (4);
7993 Process_Import_Or_Interface;
7995 ----------------------
7996 -- Import_Exception --
7997 ----------------------
7999 -- pragma Import_Exception (
8000 -- [Internal =>] LOCAL_NAME
8001 -- [, [External =>] EXTERNAL_SYMBOL]
8002 -- [, [Form =>] Ada | VMS]
8003 -- [, [Code =>] static_integer_EXPRESSION]);
8005 when Pragma_Import_Exception => Import_Exception : declare
8006 Args : Args_List (1 .. 4);
8007 Names : constant Name_List (1 .. 4) := (
8013 Internal : Node_Id renames Args (1);
8014 External : Node_Id renames Args (2);
8015 Form : Node_Id renames Args (3);
8016 Code : Node_Id renames Args (4);
8020 Gather_Associations (Names, Args);
8022 if Present (External) and then Present (Code) then
8024 ("cannot give both External and Code options for pragma%");
8027 Process_Extended_Import_Export_Exception_Pragma (
8028 Arg_Internal => Internal,
8029 Arg_External => External,
8033 if not Is_VMS_Exception (Entity (Internal)) then
8034 Set_Imported (Entity (Internal));
8036 end Import_Exception;
8038 ---------------------
8039 -- Import_Function --
8040 ---------------------
8042 -- pragma Import_Function (
8043 -- [Internal =>] LOCAL_NAME,
8044 -- [, [External =>] EXTERNAL_SYMBOL]
8045 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
8046 -- [, [Result_Type =>] SUBTYPE_MARK]
8047 -- [, [Mechanism =>] MECHANISM]
8048 -- [, [Result_Mechanism =>] MECHANISM_NAME]
8049 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
8051 -- EXTERNAL_SYMBOL ::=
8053 -- | static_string_EXPRESSION
8055 -- PARAMETER_TYPES ::=
8057 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
8059 -- TYPE_DESIGNATOR ::=
8061 -- | subtype_Name ' Access
8065 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
8067 -- MECHANISM_ASSOCIATION ::=
8068 -- [formal_parameter_NAME =>] MECHANISM_NAME
8070 -- MECHANISM_NAME ::=
8073 -- | Descriptor [([Class =>] CLASS_NAME)]
8075 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
8077 when Pragma_Import_Function => Import_Function : declare
8078 Args : Args_List (1 .. 7);
8079 Names : constant Name_List (1 .. 7) := (
8082 Name_Parameter_Types,
8085 Name_Result_Mechanism,
8086 Name_First_Optional_Parameter);
8088 Internal : Node_Id renames Args (1);
8089 External : Node_Id renames Args (2);
8090 Parameter_Types : Node_Id renames Args (3);
8091 Result_Type : Node_Id renames Args (4);
8092 Mechanism : Node_Id renames Args (5);
8093 Result_Mechanism : Node_Id renames Args (6);
8094 First_Optional_Parameter : Node_Id renames Args (7);
8098 Gather_Associations (Names, Args);
8099 Process_Extended_Import_Export_Subprogram_Pragma (
8100 Arg_Internal => Internal,
8101 Arg_External => External,
8102 Arg_Parameter_Types => Parameter_Types,
8103 Arg_Result_Type => Result_Type,
8104 Arg_Mechanism => Mechanism,
8105 Arg_Result_Mechanism => Result_Mechanism,
8106 Arg_First_Optional_Parameter => First_Optional_Parameter);
8107 end Import_Function;
8113 -- pragma Import_Object (
8114 -- [Internal =>] LOCAL_NAME
8115 -- [, [External =>] EXTERNAL_SYMBOL]
8116 -- [, [Size =>] EXTERNAL_SYMBOL]);
8118 -- EXTERNAL_SYMBOL ::=
8120 -- | static_string_EXPRESSION
8122 when Pragma_Import_Object => Import_Object : declare
8123 Args : Args_List (1 .. 3);
8124 Names : constant Name_List (1 .. 3) := (
8129 Internal : Node_Id renames Args (1);
8130 External : Node_Id renames Args (2);
8131 Size : Node_Id renames Args (3);
8135 Gather_Associations (Names, Args);
8136 Process_Extended_Import_Export_Object_Pragma (
8137 Arg_Internal => Internal,
8138 Arg_External => External,
8142 ----------------------
8143 -- Import_Procedure --
8144 ----------------------
8146 -- pragma Import_Procedure (
8147 -- [Internal =>] LOCAL_NAME
8148 -- [, [External =>] EXTERNAL_SYMBOL]
8149 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
8150 -- [, [Mechanism =>] MECHANISM]
8151 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
8153 -- EXTERNAL_SYMBOL ::=
8155 -- | static_string_EXPRESSION
8157 -- PARAMETER_TYPES ::=
8159 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
8161 -- TYPE_DESIGNATOR ::=
8163 -- | subtype_Name ' Access
8167 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
8169 -- MECHANISM_ASSOCIATION ::=
8170 -- [formal_parameter_NAME =>] MECHANISM_NAME
8172 -- MECHANISM_NAME ::=
8175 -- | Descriptor [([Class =>] CLASS_NAME)]
8177 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
8179 when Pragma_Import_Procedure => Import_Procedure : declare
8180 Args : Args_List (1 .. 5);
8181 Names : constant Name_List (1 .. 5) := (
8184 Name_Parameter_Types,
8186 Name_First_Optional_Parameter);
8188 Internal : Node_Id renames Args (1);
8189 External : Node_Id renames Args (2);
8190 Parameter_Types : Node_Id renames Args (3);
8191 Mechanism : Node_Id renames Args (4);
8192 First_Optional_Parameter : Node_Id renames Args (5);
8196 Gather_Associations (Names, Args);
8197 Process_Extended_Import_Export_Subprogram_Pragma (
8198 Arg_Internal => Internal,
8199 Arg_External => External,
8200 Arg_Parameter_Types => Parameter_Types,
8201 Arg_Mechanism => Mechanism,
8202 Arg_First_Optional_Parameter => First_Optional_Parameter);
8203 end Import_Procedure;
8205 -----------------------------
8206 -- Import_Valued_Procedure --
8207 -----------------------------
8209 -- pragma Import_Valued_Procedure (
8210 -- [Internal =>] LOCAL_NAME
8211 -- [, [External =>] EXTERNAL_SYMBOL]
8212 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
8213 -- [, [Mechanism =>] MECHANISM]
8214 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
8216 -- EXTERNAL_SYMBOL ::=
8218 -- | static_string_EXPRESSION
8220 -- PARAMETER_TYPES ::=
8222 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
8224 -- TYPE_DESIGNATOR ::=
8226 -- | subtype_Name ' Access
8230 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
8232 -- MECHANISM_ASSOCIATION ::=
8233 -- [formal_parameter_NAME =>] MECHANISM_NAME
8235 -- MECHANISM_NAME ::=
8238 -- | Descriptor [([Class =>] CLASS_NAME)]
8240 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
8242 when Pragma_Import_Valued_Procedure =>
8243 Import_Valued_Procedure : declare
8244 Args : Args_List (1 .. 5);
8245 Names : constant Name_List (1 .. 5) := (
8248 Name_Parameter_Types,
8250 Name_First_Optional_Parameter);
8252 Internal : Node_Id renames Args (1);
8253 External : Node_Id renames Args (2);
8254 Parameter_Types : Node_Id renames Args (3);
8255 Mechanism : Node_Id renames Args (4);
8256 First_Optional_Parameter : Node_Id renames Args (5);
8260 Gather_Associations (Names, Args);
8261 Process_Extended_Import_Export_Subprogram_Pragma (
8262 Arg_Internal => Internal,
8263 Arg_External => External,
8264 Arg_Parameter_Types => Parameter_Types,
8265 Arg_Mechanism => Mechanism,
8266 Arg_First_Optional_Parameter => First_Optional_Parameter);
8267 end Import_Valued_Procedure;
8269 ------------------------
8270 -- Initialize_Scalars --
8271 ------------------------
8273 -- pragma Initialize_Scalars;
8275 when Pragma_Initialize_Scalars =>
8277 Check_Arg_Count (0);
8278 Check_Valid_Configuration_Pragma;
8279 Check_Restriction (No_Initialize_Scalars, N);
8281 -- Initialize_Scalars creates false positives in CodePeer,
8282 -- so ignore this pragma in this mode.
8284 if not Restriction_Active (No_Initialize_Scalars)
8285 and then not CodePeer_Mode
8287 Init_Or_Norm_Scalars := True;
8288 Initialize_Scalars := True;
8295 -- pragma Inline ( NAME {, NAME} );
8297 when Pragma_Inline =>
8299 -- Pragma is active if inlining option is active
8301 Process_Inline (Inline_Active);
8307 -- pragma Inline_Always ( NAME {, NAME} );
8309 when Pragma_Inline_Always =>
8312 -- Pragma always active unless in CodePeer mode, since this causes
8313 -- walk order issues.
8315 if not CodePeer_Mode then
8316 Process_Inline (True);
8319 --------------------
8320 -- Inline_Generic --
8321 --------------------
8323 -- pragma Inline_Generic (NAME {, NAME});
8325 when Pragma_Inline_Generic =>
8327 Process_Generic_List;
8329 ----------------------
8330 -- Inspection_Point --
8331 ----------------------
8333 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
8335 when Pragma_Inspection_Point => Inspection_Point : declare
8340 if Arg_Count > 0 then
8343 Exp := Expression (Arg);
8346 if not Is_Entity_Name (Exp)
8347 or else not Is_Object (Entity (Exp))
8349 Error_Pragma_Arg ("object name required", Arg);
8356 end Inspection_Point;
8362 -- pragma Interface (
8363 -- [ Convention =>] convention_IDENTIFIER,
8364 -- [ Entity =>] local_NAME
8365 -- [, [External_Name =>] static_string_EXPRESSION ]
8366 -- [, [Link_Name =>] static_string_EXPRESSION ]);
8368 when Pragma_Interface =>
8375 Check_At_Least_N_Arguments (2);
8376 Check_At_Most_N_Arguments (4);
8377 Process_Import_Or_Interface;
8379 -- In Ada 2005, the permission to use Interface (a reserved word)
8380 -- as a pragma name is considered an obsolescent feature.
8382 if Ada_Version >= Ada_2005 then
8384 (No_Obsolescent_Features, Pragma_Identifier (N));
8387 --------------------
8388 -- Interface_Name --
8389 --------------------
8391 -- pragma Interface_Name (
8392 -- [ Entity =>] local_NAME
8393 -- [,[External_Name =>] static_string_EXPRESSION ]
8394 -- [,[Link_Name =>] static_string_EXPRESSION ]);
8396 when Pragma_Interface_Name => Interface_Name : declare
8405 ((Name_Entity, Name_External_Name, Name_Link_Name));
8406 Check_At_Least_N_Arguments (2);
8407 Check_At_Most_N_Arguments (3);
8408 Id := Expression (Arg1);
8411 if not Is_Entity_Name (Id) then
8413 ("first argument for pragma% must be entity name", Arg1);
8414 elsif Etype (Id) = Any_Type then
8417 Def_Id := Entity (Id);
8420 -- Special DEC-compatible processing for the object case, forces
8421 -- object to be imported.
8423 if Ekind (Def_Id) = E_Variable then
8424 Kill_Size_Check_Code (Def_Id);
8425 Note_Possible_Modification (Id, Sure => False);
8427 -- Initialization is not allowed for imported variable
8429 if Present (Expression (Parent (Def_Id)))
8430 and then Comes_From_Source (Expression (Parent (Def_Id)))
8432 Error_Msg_Sloc := Sloc (Def_Id);
8434 ("no initialization allowed for declaration of& #",
8438 -- For compatibility, support VADS usage of providing both
8439 -- pragmas Interface and Interface_Name to obtain the effect
8440 -- of a single Import pragma.
8442 if Is_Imported (Def_Id)
8443 and then Present (First_Rep_Item (Def_Id))
8444 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
8446 Pragma_Name (First_Rep_Item (Def_Id)) = Name_Interface
8450 Set_Imported (Def_Id);
8453 Set_Is_Public (Def_Id);
8454 Process_Interface_Name (Def_Id, Arg2, Arg3);
8457 -- Otherwise must be subprogram
8459 elsif not Is_Subprogram (Def_Id) then
8461 ("argument of pragma% is not subprogram", Arg1);
8464 Check_At_Most_N_Arguments (3);
8468 -- Loop through homonyms
8471 Def_Id := Get_Base_Subprogram (Hom_Id);
8473 if Is_Imported (Def_Id) then
8474 Process_Interface_Name (Def_Id, Arg2, Arg3);
8478 Hom_Id := Homonym (Hom_Id);
8480 exit when No (Hom_Id)
8481 or else Scope (Hom_Id) /= Current_Scope;
8486 ("argument of pragma% is not imported subprogram",
8492 -----------------------
8493 -- Interrupt_Handler --
8494 -----------------------
8496 -- pragma Interrupt_Handler (handler_NAME);
8498 when Pragma_Interrupt_Handler =>
8499 Check_Ada_83_Warning;
8500 Check_Arg_Count (1);
8501 Check_No_Identifiers;
8503 if No_Run_Time_Mode then
8504 Error_Msg_CRT ("Interrupt_Handler pragma", N);
8506 Check_Interrupt_Or_Attach_Handler;
8507 Process_Interrupt_Or_Attach_Handler;
8510 ------------------------
8511 -- Interrupt_Priority --
8512 ------------------------
8514 -- pragma Interrupt_Priority [(EXPRESSION)];
8516 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
8517 P : constant Node_Id := Parent (N);
8521 Check_Ada_83_Warning;
8523 if Arg_Count /= 0 then
8524 Arg := Expression (Arg1);
8525 Check_Arg_Count (1);
8526 Check_No_Identifiers;
8528 -- The expression must be analyzed in the special manner
8529 -- described in "Handling of Default and Per-Object
8530 -- Expressions" in sem.ads.
8532 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
8535 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
8539 elsif Has_Priority_Pragma (P) then
8540 Error_Pragma ("duplicate pragma% not allowed");
8543 Set_Has_Priority_Pragma (P, True);
8544 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
8546 end Interrupt_Priority;
8548 ---------------------
8549 -- Interrupt_State --
8550 ---------------------
8552 -- pragma Interrupt_State (
8553 -- [Name =>] INTERRUPT_ID,
8554 -- [State =>] INTERRUPT_STATE);
8556 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
8557 -- INTERRUPT_STATE => System | Runtime | User
8559 -- Note: if the interrupt id is given as an identifier, then it must
8560 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
8561 -- given as a static integer expression which must be in the range of
8562 -- Ada.Interrupts.Interrupt_ID.
8564 when Pragma_Interrupt_State => Interrupt_State : declare
8566 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
8567 -- This is the entity Ada.Interrupts.Interrupt_ID;
8569 State_Type : Character;
8570 -- Set to 's'/'r'/'u' for System/Runtime/User
8573 -- Index to entry in Interrupt_States table
8576 -- Value of interrupt
8578 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
8579 -- The first argument to the pragma
8581 Int_Ent : Entity_Id;
8582 -- Interrupt entity in Ada.Interrupts.Names
8586 Check_Arg_Order ((Name_Name, Name_State));
8587 Check_Arg_Count (2);
8589 Check_Optional_Identifier (Arg1, Name_Name);
8590 Check_Optional_Identifier (Arg2, Name_State);
8591 Check_Arg_Is_Identifier (Arg2);
8593 -- First argument is identifier
8595 if Nkind (Arg1X) = N_Identifier then
8597 -- Search list of names in Ada.Interrupts.Names
8599 Int_Ent := First_Entity (RTE (RE_Names));
8601 if No (Int_Ent) then
8602 Error_Pragma_Arg ("invalid interrupt name", Arg1);
8604 elsif Chars (Int_Ent) = Chars (Arg1X) then
8605 Int_Val := Expr_Value (Constant_Value (Int_Ent));
8609 Next_Entity (Int_Ent);
8612 -- First argument is not an identifier, so it must be a static
8613 -- expression of type Ada.Interrupts.Interrupt_ID.
8616 Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
8617 Int_Val := Expr_Value (Arg1X);
8619 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
8621 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
8624 ("value not in range of type " &
8625 """Ada.Interrupts.Interrupt_'I'D""", Arg1);
8631 case Chars (Get_Pragma_Arg (Arg2)) is
8632 when Name_Runtime => State_Type := 'r';
8633 when Name_System => State_Type := 's';
8634 when Name_User => State_Type := 'u';
8637 Error_Pragma_Arg ("invalid interrupt state", Arg2);
8640 -- Check if entry is already stored
8642 IST_Num := Interrupt_States.First;
8644 -- If entry not found, add it
8646 if IST_Num > Interrupt_States.Last then
8647 Interrupt_States.Append
8648 ((Interrupt_Number => UI_To_Int (Int_Val),
8649 Interrupt_State => State_Type,
8650 Pragma_Loc => Loc));
8653 -- Case of entry for the same entry
8655 elsif Int_Val = Interrupt_States.Table (IST_Num).
8658 -- If state matches, done, no need to make redundant entry
8661 State_Type = Interrupt_States.Table (IST_Num).
8664 -- Otherwise if state does not match, error
8667 Interrupt_States.Table (IST_Num).Pragma_Loc;
8669 ("state conflicts with that given #", Arg2);
8673 IST_Num := IST_Num + 1;
8675 end Interrupt_State;
8677 ----------------------
8678 -- Java_Constructor --
8679 ----------------------
8681 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
8683 -- Also handles pragma CIL_Constructor
8685 when Pragma_CIL_Constructor | Pragma_Java_Constructor =>
8686 Java_Constructor : declare
8690 Convention : Convention_Id;
8694 Check_Arg_Count (1);
8695 Check_Optional_Identifier (Arg1, Name_Entity);
8696 Check_Arg_Is_Local_Name (Arg1);
8698 Id := Expression (Arg1);
8699 Find_Program_Unit_Name (Id);
8701 -- If we did not find the name, we are done
8703 if Etype (Id) = Any_Type then
8708 when Pragma_CIL_Constructor => Convention := Convention_CIL;
8709 when Pragma_Java_Constructor => Convention := Convention_Java;
8710 when others => null;
8713 Hom_Id := Entity (Id);
8715 -- Loop through homonyms
8718 Def_Id := Get_Base_Subprogram (Hom_Id);
8720 -- The constructor is required to be a function returning an
8721 -- access type whose designated type has convention Java/CIL.
8723 if Ekind (Def_Id) = E_Function
8725 (Is_Value_Type (Etype (Def_Id))
8727 (Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type
8729 Atree.Convention (Etype (Def_Id)) = Convention)
8731 (Ekind (Etype (Def_Id)) in Access_Kind
8734 (Designated_Type (Etype (Def_Id))) = Convention
8737 (Root_Type (Designated_Type (Etype (Def_Id)))) =
8740 Set_Is_Constructor (Def_Id);
8741 Set_Convention (Def_Id, Convention);
8742 Set_Is_Imported (Def_Id);
8745 if Convention = Convention_Java then
8747 ("pragma% requires function returning a " &
8748 "'Java access type", Arg1);
8750 pragma Assert (Convention = Convention_CIL);
8752 ("pragma% requires function returning a " &
8753 "'C'I'L access type", Arg1);
8757 Hom_Id := Homonym (Hom_Id);
8759 exit when No (Hom_Id) or else Scope (Hom_Id) /= Current_Scope;
8761 end Java_Constructor;
8763 ----------------------
8764 -- Java_Interface --
8765 ----------------------
8767 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
8769 when Pragma_Java_Interface => Java_Interface : declare
8775 Check_Arg_Count (1);
8776 Check_Optional_Identifier (Arg1, Name_Entity);
8777 Check_Arg_Is_Local_Name (Arg1);
8779 Arg := Expression (Arg1);
8782 if Etype (Arg) = Any_Type then
8786 if not Is_Entity_Name (Arg)
8787 or else not Is_Type (Entity (Arg))
8789 Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
8792 Typ := Underlying_Type (Entity (Arg));
8794 -- For now simply check some of the semantic constraints on the
8795 -- type. This currently leaves out some restrictions on interface
8796 -- types, namely that the parent type must be java.lang.Object.Typ
8797 -- and that all primitives of the type should be declared
8800 if not Is_Tagged_Type (Typ) or else not Is_Abstract_Type (Typ) then
8801 Error_Pragma_Arg ("pragma% requires an abstract "
8802 & "tagged type", Arg1);
8804 elsif not Has_Discriminants (Typ)
8805 or else Ekind (Etype (First_Discriminant (Typ)))
8806 /= E_Anonymous_Access_Type
8808 not Is_Class_Wide_Type
8809 (Designated_Type (Etype (First_Discriminant (Typ))))
8812 ("type must have a class-wide access discriminant", Arg1);
8820 -- pragma Keep_Names ([On => ] local_NAME);
8822 when Pragma_Keep_Names => Keep_Names : declare
8827 Check_Arg_Count (1);
8828 Check_Optional_Identifier (Arg1, Name_On);
8829 Check_Arg_Is_Local_Name (Arg1);
8831 Arg := Expression (Arg1);
8834 if Etype (Arg) = Any_Type then
8838 if not Is_Entity_Name (Arg)
8839 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
8842 ("pragma% requires a local enumeration type", Arg1);
8845 Set_Discard_Names (Entity (Arg), False);
8852 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
8854 when Pragma_License =>
8856 Check_Arg_Count (1);
8857 Check_No_Identifiers;
8858 Check_Valid_Configuration_Pragma;
8859 Check_Arg_Is_Identifier (Arg1);
8862 Sind : constant Source_File_Index :=
8863 Source_Index (Current_Sem_Unit);
8866 case Chars (Get_Pragma_Arg (Arg1)) is
8868 Set_License (Sind, GPL);
8870 when Name_Modified_GPL =>
8871 Set_License (Sind, Modified_GPL);
8873 when Name_Restricted =>
8874 Set_License (Sind, Restricted);
8876 when Name_Unrestricted =>
8877 Set_License (Sind, Unrestricted);
8880 Error_Pragma_Arg ("invalid license name", Arg1);
8888 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
8890 when Pragma_Link_With => Link_With : declare
8896 if Operating_Mode = Generate_Code
8897 and then In_Extended_Main_Source_Unit (N)
8899 Check_At_Least_N_Arguments (1);
8900 Check_No_Identifiers;
8901 Check_Is_In_Decl_Part_Or_Package_Spec;
8902 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
8906 while Present (Arg) loop
8907 Check_Arg_Is_Static_Expression (Arg, Standard_String);
8909 -- Store argument, converting sequences of spaces to a
8910 -- single null character (this is one of the differences
8911 -- in processing between Link_With and Linker_Options).
8914 C : constant Char_Code := Get_Char_Code (' ');
8915 S : constant String_Id :=
8916 Strval (Expr_Value_S (Expression (Arg)));
8917 L : constant Nat := String_Length (S);
8920 procedure Skip_Spaces;
8921 -- Advance F past any spaces
8927 procedure Skip_Spaces is
8929 while F <= L and then Get_String_Char (S, F) = C loop
8934 -- Start of processing for Arg_Store
8937 Skip_Spaces; -- skip leading spaces
8939 -- Loop through characters, changing any embedded
8940 -- sequence of spaces to a single null character (this
8941 -- is how Link_With/Linker_Options differ)
8944 if Get_String_Char (S, F) = C then
8947 Store_String_Char (ASCII.NUL);
8950 Store_String_Char (Get_String_Char (S, F));
8958 if Present (Arg) then
8959 Store_String_Char (ASCII.NUL);
8963 Store_Linker_Option_String (End_String);
8971 -- pragma Linker_Alias (
8972 -- [Entity =>] LOCAL_NAME
8973 -- [Target =>] static_string_EXPRESSION);
8975 when Pragma_Linker_Alias =>
8977 Check_Arg_Order ((Name_Entity, Name_Target));
8978 Check_Arg_Count (2);
8979 Check_Optional_Identifier (Arg1, Name_Entity);
8980 Check_Optional_Identifier (Arg2, Name_Target);
8981 Check_Arg_Is_Library_Level_Local_Name (Arg1);
8982 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
8984 -- The only processing required is to link this item on to the
8985 -- list of rep items for the given entity. This is accomplished
8986 -- by the call to Rep_Item_Too_Late (when no error is detected
8987 -- and False is returned).
8989 if Rep_Item_Too_Late (Entity (Expression (Arg1)), N) then
8992 Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1)));
8995 ------------------------
8996 -- Linker_Constructor --
8997 ------------------------
8999 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
9001 -- Code is shared with Linker_Destructor
9003 -----------------------
9004 -- Linker_Destructor --
9005 -----------------------
9007 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
9009 when Pragma_Linker_Constructor |
9010 Pragma_Linker_Destructor =>
9011 Linker_Constructor : declare
9017 Check_Arg_Count (1);
9018 Check_No_Identifiers;
9019 Check_Arg_Is_Local_Name (Arg1);
9020 Arg1_X := Expression (Arg1);
9022 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
9024 if not Is_Library_Level_Entity (Proc) then
9026 ("argument for pragma% must be library level entity", Arg1);
9029 -- The only processing required is to link this item on to the
9030 -- list of rep items for the given entity. This is accomplished
9031 -- by the call to Rep_Item_Too_Late (when no error is detected
9032 -- and False is returned).
9034 if Rep_Item_Too_Late (Proc, N) then
9037 Set_Has_Gigi_Rep_Item (Proc);
9039 end Linker_Constructor;
9041 --------------------
9042 -- Linker_Options --
9043 --------------------
9045 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
9047 when Pragma_Linker_Options => Linker_Options : declare
9051 Check_Ada_83_Warning;
9052 Check_No_Identifiers;
9053 Check_Arg_Count (1);
9054 Check_Is_In_Decl_Part_Or_Package_Spec;
9055 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
9056 Start_String (Strval (Expr_Value_S (Expression (Arg1))));
9059 while Present (Arg) loop
9060 Check_Arg_Is_Static_Expression (Arg, Standard_String);
9061 Store_String_Char (ASCII.NUL);
9062 Store_String_Chars (Strval (Expr_Value_S (Expression (Arg))));
9066 if Operating_Mode = Generate_Code
9067 and then In_Extended_Main_Source_Unit (N)
9069 Store_Linker_Option_String (End_String);
9073 --------------------
9074 -- Linker_Section --
9075 --------------------
9077 -- pragma Linker_Section (
9078 -- [Entity =>] LOCAL_NAME
9079 -- [Section =>] static_string_EXPRESSION);
9081 when Pragma_Linker_Section =>
9083 Check_Arg_Order ((Name_Entity, Name_Section));
9084 Check_Arg_Count (2);
9085 Check_Optional_Identifier (Arg1, Name_Entity);
9086 Check_Optional_Identifier (Arg2, Name_Section);
9087 Check_Arg_Is_Library_Level_Local_Name (Arg1);
9088 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
9090 -- This pragma applies only to objects
9092 if not Is_Object (Entity (Expression (Arg1))) then
9093 Error_Pragma_Arg ("pragma% applies only to objects", Arg1);
9096 -- The only processing required is to link this item on to the
9097 -- list of rep items for the given entity. This is accomplished
9098 -- by the call to Rep_Item_Too_Late (when no error is detected
9099 -- and False is returned).
9101 if Rep_Item_Too_Late (Entity (Expression (Arg1)), N) then
9104 Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1)));
9111 -- pragma List (On | Off)
9113 -- There is nothing to do here, since we did all the processing for
9114 -- this pragma in Par.Prag (so that it works properly even in syntax
9120 --------------------
9121 -- Locking_Policy --
9122 --------------------
9124 -- pragma Locking_Policy (policy_IDENTIFIER);
9126 when Pragma_Locking_Policy => declare
9130 Check_Ada_83_Warning;
9131 Check_Arg_Count (1);
9132 Check_No_Identifiers;
9133 Check_Arg_Is_Locking_Policy (Arg1);
9134 Check_Valid_Configuration_Pragma;
9135 Get_Name_String (Chars (Expression (Arg1)));
9136 LP := Fold_Upper (Name_Buffer (1));
9138 if Locking_Policy /= ' '
9139 and then Locking_Policy /= LP
9141 Error_Msg_Sloc := Locking_Policy_Sloc;
9142 Error_Pragma ("locking policy incompatible with policy#");
9144 -- Set new policy, but always preserve System_Location since we
9145 -- like the error message with the run time name.
9148 Locking_Policy := LP;
9150 if Locking_Policy_Sloc /= System_Location then
9151 Locking_Policy_Sloc := Loc;
9160 -- pragma Long_Float (D_Float | G_Float);
9162 when Pragma_Long_Float =>
9164 Check_Valid_Configuration_Pragma;
9165 Check_Arg_Count (1);
9166 Check_No_Identifier (Arg1);
9167 Check_Arg_Is_One_Of (Arg1, Name_D_Float, Name_G_Float);
9169 if not OpenVMS_On_Target then
9170 Error_Pragma ("?pragma% ignored (applies only to Open'V'M'S)");
9175 if Chars (Expression (Arg1)) = Name_D_Float then
9176 if Opt.Float_Format_Long = 'G' then
9177 Error_Pragma ("G_Float previously specified");
9180 Opt.Float_Format_Long := 'D';
9182 -- G_Float case (this is the default, does not need overriding)
9185 if Opt.Float_Format_Long = 'D' then
9186 Error_Pragma ("D_Float previously specified");
9189 Opt.Float_Format_Long := 'G';
9192 Set_Standard_Fpt_Formats;
9194 -----------------------
9195 -- Machine_Attribute --
9196 -----------------------
9198 -- pragma Machine_Attribute (
9199 -- [Entity =>] LOCAL_NAME,
9200 -- [Attribute_Name =>] static_string_EXPRESSION
9201 -- [, [Info =>] static_EXPRESSION] );
9203 when Pragma_Machine_Attribute => Machine_Attribute : declare
9208 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
9210 if Arg_Count = 3 then
9211 Check_Optional_Identifier (Arg3, Name_Info);
9212 Check_Arg_Is_Static_Expression (Arg3);
9214 Check_Arg_Count (2);
9217 Check_Optional_Identifier (Arg1, Name_Entity);
9218 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
9219 Check_Arg_Is_Local_Name (Arg1);
9220 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
9221 Def_Id := Entity (Expression (Arg1));
9223 if Is_Access_Type (Def_Id) then
9224 Def_Id := Designated_Type (Def_Id);
9227 if Rep_Item_Too_Early (Def_Id, N) then
9231 Def_Id := Underlying_Type (Def_Id);
9233 -- The only processing required is to link this item on to the
9234 -- list of rep items for the given entity. This is accomplished
9235 -- by the call to Rep_Item_Too_Late (when no error is detected
9236 -- and False is returned).
9238 if Rep_Item_Too_Late (Def_Id, N) then
9241 Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1)));
9243 end Machine_Attribute;
9250 -- (MAIN_OPTION [, MAIN_OPTION]);
9253 -- [STACK_SIZE =>] static_integer_EXPRESSION
9254 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
9255 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
9257 when Pragma_Main => Main : declare
9258 Args : Args_List (1 .. 3);
9259 Names : constant Name_List (1 .. 3) := (
9261 Name_Task_Stack_Size_Default,
9262 Name_Time_Slicing_Enabled);
9268 Gather_Associations (Names, Args);
9270 for J in 1 .. 2 loop
9271 if Present (Args (J)) then
9272 Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
9276 if Present (Args (3)) then
9277 Check_Arg_Is_Static_Expression (Args (3), Standard_Boolean);
9281 while Present (Nod) loop
9282 if Nkind (Nod) = N_Pragma
9283 and then Pragma_Name (Nod) = Name_Main
9285 Error_Msg_Name_1 := Pname;
9286 Error_Msg_N ("duplicate pragma% not permitted", Nod);
9297 -- pragma Main_Storage
9298 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
9300 -- MAIN_STORAGE_OPTION ::=
9301 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
9302 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
9304 when Pragma_Main_Storage => Main_Storage : declare
9305 Args : Args_List (1 .. 2);
9306 Names : constant Name_List (1 .. 2) := (
9307 Name_Working_Storage,
9314 Gather_Associations (Names, Args);
9316 for J in 1 .. 2 loop
9317 if Present (Args (J)) then
9318 Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
9322 Check_In_Main_Program;
9325 while Present (Nod) loop
9326 if Nkind (Nod) = N_Pragma
9327 and then Pragma_Name (Nod) = Name_Main_Storage
9329 Error_Msg_Name_1 := Pname;
9330 Error_Msg_N ("duplicate pragma% not permitted", Nod);
9341 -- pragma Memory_Size (NUMERIC_LITERAL)
9343 when Pragma_Memory_Size =>
9346 -- Memory size is simply ignored
9348 Check_No_Identifiers;
9349 Check_Arg_Count (1);
9350 Check_Arg_Is_Integer_Literal (Arg1);
9358 -- The only correct use of this pragma is on its own in a file, in
9359 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
9360 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
9361 -- check for a file containing nothing but a No_Body pragma). If we
9362 -- attempt to process it during normal semantics processing, it means
9363 -- it was misplaced.
9365 when Pragma_No_Body =>
9373 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
9375 when Pragma_No_Return => No_Return : declare
9383 Check_At_Least_N_Arguments (1);
9385 -- Loop through arguments of pragma
9388 while Present (Arg) loop
9389 Check_Arg_Is_Local_Name (Arg);
9390 Id := Expression (Arg);
9393 if not Is_Entity_Name (Id) then
9394 Error_Pragma_Arg ("entity name required", Arg);
9397 if Etype (Id) = Any_Type then
9401 -- Loop to find matching procedures
9406 and then Scope (E) = Current_Scope
9408 if Ekind_In (E, E_Procedure, E_Generic_Procedure) then
9411 -- Set flag on any alias as well
9413 if Is_Overloadable (E) and then Present (Alias (E)) then
9414 Set_No_Return (Alias (E));
9424 Error_Pragma_Arg ("no procedure & found for pragma%", Arg);
9435 -- pragma No_Run_Time;
9437 -- Note: this pragma is retained for backwards compatibility. See
9438 -- body of Rtsfind for full details on its handling.
9440 when Pragma_No_Run_Time =>
9442 Check_Valid_Configuration_Pragma;
9443 Check_Arg_Count (0);
9445 No_Run_Time_Mode := True;
9446 Configurable_Run_Time_Mode := True;
9448 -- Set Duration to 32 bits if word size is 32
9450 if Ttypes.System_Word_Size = 32 then
9451 Duration_32_Bits_On_Target := True;
9454 -- Set appropriate restrictions
9456 Set_Restriction (No_Finalization, N);
9457 Set_Restriction (No_Exception_Handlers, N);
9458 Set_Restriction (Max_Tasks, N, 0);
9459 Set_Restriction (No_Tasking, N);
9461 ------------------------
9462 -- No_Strict_Aliasing --
9463 ------------------------
9465 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
9467 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
9472 Check_At_Most_N_Arguments (1);
9474 if Arg_Count = 0 then
9475 Check_Valid_Configuration_Pragma;
9476 Opt.No_Strict_Aliasing := True;
9479 Check_Optional_Identifier (Arg2, Name_Entity);
9480 Check_Arg_Is_Local_Name (Arg1);
9481 E_Id := Entity (Expression (Arg1));
9483 if E_Id = Any_Type then
9485 elsif No (E_Id) or else not Is_Access_Type (E_Id) then
9486 Error_Pragma_Arg ("pragma% requires access type", Arg1);
9489 Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id));
9491 end No_Strict_Aliasing;
9493 -----------------------
9494 -- Normalize_Scalars --
9495 -----------------------
9497 -- pragma Normalize_Scalars;
9499 when Pragma_Normalize_Scalars =>
9500 Check_Ada_83_Warning;
9501 Check_Arg_Count (0);
9502 Check_Valid_Configuration_Pragma;
9504 -- Normalize_Scalars creates false positives in CodePeer, so
9505 -- ignore this pragma in this mode.
9507 if not CodePeer_Mode then
9508 Normalize_Scalars := True;
9509 Init_Or_Norm_Scalars := True;
9516 -- pragma Obsolescent;
9518 -- pragma Obsolescent (
9519 -- [Message =>] static_string_EXPRESSION
9520 -- [,[Version =>] Ada_05]]);
9522 -- pragma Obsolescent (
9524 -- [,[Message =>] static_string_EXPRESSION
9525 -- [,[Version =>] Ada_05]] );
9527 when Pragma_Obsolescent => Obsolescent : declare
9531 procedure Set_Obsolescent (E : Entity_Id);
9532 -- Given an entity Ent, mark it as obsolescent if appropriate
9534 ---------------------
9535 -- Set_Obsolescent --
9536 ---------------------
9538 procedure Set_Obsolescent (E : Entity_Id) is
9547 -- Entity name was given
9549 if Present (Ename) then
9551 -- If entity name matches, we are fine. Save entity in
9552 -- pragma argument, for ASIS use.
9554 if Chars (Ename) = Chars (Ent) then
9555 Set_Entity (Ename, Ent);
9556 Generate_Reference (Ent, Ename);
9558 -- If entity name does not match, only possibility is an
9559 -- enumeration literal from an enumeration type declaration.
9561 elsif Ekind (Ent) /= E_Enumeration_Type then
9563 ("pragma % entity name does not match declaration");
9566 Ent := First_Literal (E);
9570 ("pragma % entity name does not match any " &
9571 "enumeration literal");
9573 elsif Chars (Ent) = Chars (Ename) then
9574 Set_Entity (Ename, Ent);
9575 Generate_Reference (Ent, Ename);
9579 Ent := Next_Literal (Ent);
9585 -- Ent points to entity to be marked
9587 if Arg_Count >= 1 then
9589 -- Deal with static string argument
9591 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
9592 S := Strval (Expression (Arg1));
9594 for J in 1 .. String_Length (S) loop
9595 if not In_Character_Range (Get_String_Char (S, J)) then
9597 ("pragma% argument does not allow wide characters",
9602 Obsolescent_Warnings.Append
9603 ((Ent => Ent, Msg => Strval (Expression (Arg1))));
9605 -- Check for Ada_05 parameter
9607 if Arg_Count /= 1 then
9608 Check_Arg_Count (2);
9611 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
9614 Check_Arg_Is_Identifier (Argx);
9616 if Chars (Argx) /= Name_Ada_05 then
9617 Error_Msg_Name_2 := Name_Ada_05;
9619 ("only allowed argument for pragma% is %", Argx);
9622 if Ada_Version_Explicit < Ada_05
9623 or else not Warn_On_Ada_2005_Compatibility
9631 -- Set flag if pragma active
9634 Set_Is_Obsolescent (Ent);
9638 end Set_Obsolescent;
9640 -- Start of processing for pragma Obsolescent
9645 Check_At_Most_N_Arguments (3);
9647 -- See if first argument specifies an entity name
9651 (Chars (Arg1) = Name_Entity
9653 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
9657 Ename := Get_Pragma_Arg (Arg1);
9659 -- Eliminate first argument, so we can share processing
9663 Arg_Count := Arg_Count - 1;
9665 -- No Entity name argument given
9671 if Arg_Count >= 1 then
9672 Check_Optional_Identifier (Arg1, Name_Message);
9674 if Arg_Count = 2 then
9675 Check_Optional_Identifier (Arg2, Name_Version);
9679 -- Get immediately preceding declaration
9682 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
9686 -- Cases where we do not follow anything other than another pragma
9690 -- First case: library level compilation unit declaration with
9691 -- the pragma immediately following the declaration.
9693 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
9695 (Defining_Entity (Unit (Parent (Parent (N)))));
9698 -- Case 2: library unit placement for package
9702 Ent : constant Entity_Id := Find_Lib_Unit_Name;
9704 if Is_Package_Or_Generic_Package (Ent) then
9705 Set_Obsolescent (Ent);
9711 -- Cases where we must follow a declaration
9714 if Nkind (Decl) not in N_Declaration
9715 and then Nkind (Decl) not in N_Later_Decl_Item
9716 and then Nkind (Decl) not in N_Generic_Declaration
9717 and then Nkind (Decl) not in N_Renaming_Declaration
9720 ("pragma% misplaced, "
9721 & "must immediately follow a declaration");
9724 Set_Obsolescent (Defining_Entity (Decl));
9734 -- pragma Optimize (Time | Space | Off);
9736 -- The actual check for optimize is done in Gigi. Note that this
9737 -- pragma does not actually change the optimization setting, it
9738 -- simply checks that it is consistent with the pragma.
9740 when Pragma_Optimize =>
9741 Check_No_Identifiers;
9742 Check_Arg_Count (1);
9743 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
9745 ------------------------
9746 -- Optimize_Alignment --
9747 ------------------------
9749 -- pragma Optimize_Alignment (Time | Space | Off);
9751 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
9753 Check_No_Identifiers;
9754 Check_Arg_Count (1);
9755 Check_Valid_Configuration_Pragma;
9758 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
9762 Opt.Optimize_Alignment := 'T';
9764 Opt.Optimize_Alignment := 'S';
9766 Opt.Optimize_Alignment := 'O';
9768 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
9772 -- Set indication that mode is set locally. If we are in fact in a
9773 -- configuration pragma file, this setting is harmless since the
9774 -- switch will get reset anyway at the start of each unit.
9776 Optimize_Alignment_Local := True;
9777 end Optimize_Alignment;
9783 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
9785 when Pragma_Ordered => Ordered : declare
9786 Assoc : constant Node_Id := Arg1;
9792 Check_No_Identifiers;
9793 Check_Arg_Count (1);
9794 Check_Arg_Is_Local_Name (Arg1);
9796 Type_Id := Expression (Assoc);
9797 Find_Type (Type_Id);
9798 Typ := Entity (Type_Id);
9800 if Typ = Any_Type then
9803 Typ := Underlying_Type (Typ);
9806 if not Is_Enumeration_Type (Typ) then
9807 Error_Pragma ("pragma% must specify enumeration type");
9810 Check_First_Subtype (Arg1);
9811 Set_Has_Pragma_Ordered (Base_Type (Typ));
9818 -- pragma Pack (first_subtype_LOCAL_NAME);
9820 when Pragma_Pack => Pack : declare
9821 Assoc : constant Node_Id := Arg1;
9826 Check_No_Identifiers;
9827 Check_Arg_Count (1);
9828 Check_Arg_Is_Local_Name (Arg1);
9830 Type_Id := Expression (Assoc);
9831 Find_Type (Type_Id);
9832 Typ := Entity (Type_Id);
9835 or else Rep_Item_Too_Early (Typ, N)
9839 Typ := Underlying_Type (Typ);
9842 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
9843 Error_Pragma ("pragma% must specify array or record type");
9846 Check_First_Subtype (Arg1);
9848 if Has_Pragma_Pack (Typ) then
9849 Error_Pragma ("duplicate pragma%, only one allowed");
9853 elsif Is_Array_Type (Typ) then
9855 -- Pack not allowed for aliased or atomic components
9857 if Has_Aliased_Components (Base_Type (Typ)) then
9859 ("pragma% ignored, cannot pack aliased components?");
9861 elsif Has_Atomic_Components (Typ)
9862 or else Is_Atomic (Component_Type (Typ))
9865 ("?pragma% ignored, cannot pack atomic components");
9868 -- If we had an explicit component size given, then we do not
9869 -- let Pack override this given size. We also give a warning
9870 -- that Pack is being ignored unless we can tell for sure that
9871 -- the Pack would not have had any effect anyway.
9873 if Has_Component_Size_Clause (Typ) then
9874 if Known_Static_RM_Size (Component_Type (Typ))
9876 RM_Size (Component_Type (Typ)) = Component_Size (Typ)
9881 ("?pragma% ignored, explicit component size given");
9884 -- If no prior array component size given, Pack is effective
9887 if not Rep_Item_Too_Late (Typ, N) then
9889 -- In the context of static code analysis, we do not need
9890 -- complex front-end expansions related to pragma Pack,
9891 -- so disable handling of pragma Pack in this case.
9893 if CodePeer_Mode then
9896 -- For normal non-VM target, do the packing
9898 elsif VM_Target = No_VM then
9899 Set_Is_Packed (Base_Type (Typ));
9900 Set_Has_Pragma_Pack (Base_Type (Typ));
9901 Set_Has_Non_Standard_Rep (Base_Type (Typ));
9903 -- If we ignore the pack, then warn about this, except
9904 -- that we suppress the warning in GNAT mode.
9906 elsif not GNAT_Mode then
9908 ("?pragma% ignored in this configuration");
9913 -- For record types, the pack is always effective
9915 else pragma Assert (Is_Record_Type (Typ));
9916 if not Rep_Item_Too_Late (Typ, N) then
9917 if VM_Target = No_VM then
9918 Set_Is_Packed (Base_Type (Typ));
9919 Set_Has_Pragma_Pack (Base_Type (Typ));
9920 Set_Has_Non_Standard_Rep (Base_Type (Typ));
9922 elsif not GNAT_Mode then
9923 Error_Pragma ("?pragma% ignored in this configuration");
9935 -- There is nothing to do here, since we did all the processing for
9936 -- this pragma in Par.Prag (so that it works properly even in syntax
9946 -- pragma Passive [(PASSIVE_FORM)];
9948 -- PASSIVE_FORM ::= Semaphore | No
9950 when Pragma_Passive =>
9953 if Nkind (Parent (N)) /= N_Task_Definition then
9954 Error_Pragma ("pragma% must be within task definition");
9957 if Arg_Count /= 0 then
9958 Check_Arg_Count (1);
9959 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
9962 ----------------------------------
9963 -- Preelaborable_Initialization --
9964 ----------------------------------
9966 -- pragma Preelaborable_Initialization (DIRECT_NAME);
9968 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
9973 Check_Arg_Count (1);
9974 Check_No_Identifiers;
9975 Check_Arg_Is_Identifier (Arg1);
9976 Check_Arg_Is_Local_Name (Arg1);
9977 Check_First_Subtype (Arg1);
9978 Ent := Entity (Expression (Arg1));
9980 if not Is_Private_Type (Ent)
9981 and then not Is_Protected_Type (Ent)
9984 ("pragma % can only be applied to private or protected type",
9988 -- Give an error if the pragma is applied to a protected type that
9989 -- does not qualify (due to having entries, or due to components
9990 -- that do not qualify).
9992 if Is_Protected_Type (Ent)
9993 and then not Has_Preelaborable_Initialization (Ent)
9996 ("protected type & does not have preelaborable " &
9997 "initialization", Ent);
9999 -- Otherwise mark the type as definitely having preelaborable
10003 Set_Known_To_Have_Preelab_Init (Ent);
10006 if Has_Pragma_Preelab_Init (Ent)
10007 and then Warn_On_Redundant_Constructs
10009 Error_Pragma ("?duplicate pragma%!");
10011 Set_Has_Pragma_Preelab_Init (Ent);
10015 --------------------
10016 -- Persistent_BSS --
10017 --------------------
10019 when Pragma_Persistent_BSS => Persistent_BSS : declare
10026 Check_At_Most_N_Arguments (1);
10028 -- Case of application to specific object (one argument)
10030 if Arg_Count = 1 then
10031 Check_Arg_Is_Library_Level_Local_Name (Arg1);
10033 if not Is_Entity_Name (Expression (Arg1))
10035 (Ekind (Entity (Expression (Arg1))) /= E_Variable
10036 and then Ekind (Entity (Expression (Arg1))) /= E_Constant)
10038 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
10041 Ent := Entity (Expression (Arg1));
10042 Decl := Parent (Ent);
10044 if Rep_Item_Too_Late (Ent, N) then
10048 if Present (Expression (Decl)) then
10050 ("object for pragma% cannot have initialization", Arg1);
10053 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
10055 ("object type for pragma% is not potentially persistent",
10060 Make_Linker_Section_Pragma
10061 (Ent, Sloc (N), ".persistent.bss");
10062 Insert_After (N, Prag);
10065 -- Case of use as configuration pragma with no arguments
10068 Check_Valid_Configuration_Pragma;
10069 Persistent_BSS_Mode := True;
10071 end Persistent_BSS;
10077 -- pragma Polling (ON | OFF);
10079 when Pragma_Polling =>
10081 Check_Arg_Count (1);
10082 Check_No_Identifiers;
10083 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
10084 Polling_Required := (Chars (Expression (Arg1)) = Name_On);
10086 -------------------
10087 -- Postcondition --
10088 -------------------
10090 -- pragma Postcondition ([Check =>] Boolean_Expression
10091 -- [,[Message =>] String_Expression]);
10093 when Pragma_Postcondition => Postcondition : declare
10095 pragma Warnings (Off, In_Body);
10099 Check_At_Least_N_Arguments (1);
10100 Check_At_Most_N_Arguments (2);
10101 Check_Optional_Identifier (Arg1, Name_Check);
10103 -- All we need to do here is call the common check procedure,
10104 -- the remainder of the processing is found in Sem_Ch6/Sem_Ch7.
10106 Check_Precondition_Postcondition (In_Body);
10113 -- pragma Precondition ([Check =>] Boolean_Expression
10114 -- [,[Message =>] String_Expression]);
10116 when Pragma_Precondition => Precondition : declare
10121 Check_At_Least_N_Arguments (1);
10122 Check_At_Most_N_Arguments (2);
10123 Check_Optional_Identifier (Arg1, Name_Check);
10125 Check_Precondition_Postcondition (In_Body);
10127 -- If in spec, nothing more to do. If in body, then we convert the
10128 -- pragma to pragma Check (Precondition, cond [, msg]). Note we do
10129 -- this whether or not precondition checks are enabled. That works
10130 -- fine since pragma Check will do this check, and will also
10131 -- analyze the condition itself in the proper context.
10134 if Arg_Count = 2 then
10135 Check_Optional_Identifier (Arg3, Name_Message);
10136 Analyze_And_Resolve (Get_Pragma_Arg (Arg2), Standard_String);
10141 Chars => Name_Check,
10142 Pragma_Argument_Associations => New_List (
10143 Make_Pragma_Argument_Association (Loc,
10145 Make_Identifier (Loc,
10146 Chars => Name_Precondition)),
10148 Make_Pragma_Argument_Association (Sloc (Arg1),
10149 Expression => Relocate_Node (Get_Pragma_Arg (Arg1))))));
10151 if Arg_Count = 2 then
10152 Append_To (Pragma_Argument_Associations (N),
10153 Make_Pragma_Argument_Association (Sloc (Arg2),
10154 Expression => Relocate_Node (Get_Pragma_Arg (Arg2))));
10165 -- pragma Preelaborate [(library_unit_NAME)];
10167 -- Set the flag Is_Preelaborated of program unit name entity
10169 when Pragma_Preelaborate => Preelaborate : declare
10170 Pa : constant Node_Id := Parent (N);
10171 Pk : constant Node_Kind := Nkind (Pa);
10175 Check_Ada_83_Warning;
10176 Check_Valid_Library_Unit_Pragma;
10178 if Nkind (N) = N_Null_Statement then
10182 Ent := Find_Lib_Unit_Name;
10184 -- This filters out pragmas inside generic parent then
10185 -- show up inside instantiation
10188 and then not (Pk = N_Package_Specification
10189 and then Present (Generic_Parent (Pa)))
10191 if not Debug_Flag_U then
10192 Set_Is_Preelaborated (Ent);
10193 Set_Suppress_Elaboration_Warnings (Ent);
10198 ---------------------
10199 -- Preelaborate_05 --
10200 ---------------------
10202 -- pragma Preelaborate_05 [(library_unit_NAME)];
10204 -- This pragma is useable only in GNAT_Mode, where it is used like
10205 -- pragma Preelaborate but it is only effective in Ada 2005 mode
10206 -- (otherwise it is ignored). This is used to implement AI-362 which
10207 -- recategorizes some run-time packages in Ada 2005 mode.
10209 when Pragma_Preelaborate_05 => Preelaborate_05 : declare
10214 Check_Valid_Library_Unit_Pragma;
10216 if not GNAT_Mode then
10217 Error_Pragma ("pragma% only available in GNAT mode");
10220 if Nkind (N) = N_Null_Statement then
10224 -- This is one of the few cases where we need to test the value of
10225 -- Ada_Version_Explicit rather than Ada_Version (which is always
10226 -- set to Ada_12 in a predefined unit), we need to know the
10227 -- explicit version set to know if this pragma is active.
10229 if Ada_Version_Explicit >= Ada_05 then
10230 Ent := Find_Lib_Unit_Name;
10231 Set_Is_Preelaborated (Ent);
10232 Set_Suppress_Elaboration_Warnings (Ent);
10234 end Preelaborate_05;
10240 -- pragma Priority (EXPRESSION);
10242 when Pragma_Priority => Priority : declare
10243 P : constant Node_Id := Parent (N);
10247 Check_No_Identifiers;
10248 Check_Arg_Count (1);
10252 if Nkind (P) = N_Subprogram_Body then
10253 Check_In_Main_Program;
10255 Arg := Expression (Arg1);
10256 Analyze_And_Resolve (Arg, Standard_Integer);
10260 if not Is_Static_Expression (Arg) then
10261 Flag_Non_Static_Expr
10262 ("main subprogram priority is not static!", Arg);
10265 -- If constraint error, then we already signalled an error
10267 elsif Raises_Constraint_Error (Arg) then
10270 -- Otherwise check in range
10274 Val : constant Uint := Expr_Value (Arg);
10278 or else Val > Expr_Value (Expression
10279 (Parent (RTE (RE_Max_Priority))))
10282 ("main subprogram priority is out of range", Arg1);
10288 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
10290 -- Load an arbitrary entity from System.Tasking to make sure
10291 -- this package is implicitly with'ed, since we need to have
10292 -- the tasking run-time active for the pragma Priority to have
10296 Discard : Entity_Id;
10297 pragma Warnings (Off, Discard);
10299 Discard := RTE (RE_Task_List);
10302 -- Task or Protected, must be of type Integer
10304 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
10305 Arg := Expression (Arg1);
10307 -- The expression must be analyzed in the special manner
10308 -- described in "Handling of Default and Per-Object
10309 -- Expressions" in sem.ads.
10311 Preanalyze_Spec_Expression (Arg, Standard_Integer);
10313 if not Is_Static_Expression (Arg) then
10314 Check_Restriction (Static_Priorities, Arg);
10317 -- Anything else is incorrect
10323 if Has_Priority_Pragma (P) then
10324 Error_Pragma ("duplicate pragma% not allowed");
10326 Set_Has_Priority_Pragma (P, True);
10328 if Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
10329 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
10330 -- exp_ch9 should use this ???
10335 -----------------------------------
10336 -- Priority_Specific_Dispatching --
10337 -----------------------------------
10339 -- pragma Priority_Specific_Dispatching (
10340 -- policy_IDENTIFIER,
10341 -- first_priority_EXPRESSION,
10342 -- last_priority_EXPRESSION);
10344 when Pragma_Priority_Specific_Dispatching =>
10345 Priority_Specific_Dispatching : declare
10346 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
10347 -- This is the entity System.Any_Priority;
10350 Lower_Bound : Node_Id;
10351 Upper_Bound : Node_Id;
10357 Check_Arg_Count (3);
10358 Check_No_Identifiers;
10359 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
10360 Check_Valid_Configuration_Pragma;
10361 Get_Name_String (Chars (Expression (Arg1)));
10362 DP := Fold_Upper (Name_Buffer (1));
10364 Lower_Bound := Expression (Arg2);
10365 Check_Arg_Is_Static_Expression (Lower_Bound, Standard_Integer);
10366 Lower_Val := Expr_Value (Lower_Bound);
10368 Upper_Bound := Expression (Arg3);
10369 Check_Arg_Is_Static_Expression (Upper_Bound, Standard_Integer);
10370 Upper_Val := Expr_Value (Upper_Bound);
10372 -- It is not allowed to use Task_Dispatching_Policy and
10373 -- Priority_Specific_Dispatching in the same partition.
10375 if Task_Dispatching_Policy /= ' ' then
10376 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
10378 ("pragma% incompatible with Task_Dispatching_Policy#");
10380 -- Check lower bound in range
10382 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
10384 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
10387 ("first_priority is out of range", Arg2);
10389 -- Check upper bound in range
10391 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
10393 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
10396 ("last_priority is out of range", Arg3);
10398 -- Check that the priority range is valid
10400 elsif Lower_Val > Upper_Val then
10402 ("last_priority_expression must be greater than" &
10403 " or equal to first_priority_expression");
10405 -- Store the new policy, but always preserve System_Location since
10406 -- we like the error message with the run-time name.
10409 -- Check overlapping in the priority ranges specified in other
10410 -- Priority_Specific_Dispatching pragmas within the same
10411 -- partition. We can only check those we know about!
10414 Specific_Dispatching.First .. Specific_Dispatching.Last
10416 if Specific_Dispatching.Table (J).First_Priority in
10417 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
10418 or else Specific_Dispatching.Table (J).Last_Priority in
10419 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
10422 Specific_Dispatching.Table (J).Pragma_Loc;
10424 ("priority range overlaps with "
10425 & "Priority_Specific_Dispatching#");
10429 -- The use of Priority_Specific_Dispatching is incompatible
10430 -- with Task_Dispatching_Policy.
10432 if Task_Dispatching_Policy /= ' ' then
10433 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
10435 ("Priority_Specific_Dispatching incompatible "
10436 & "with Task_Dispatching_Policy#");
10439 -- The use of Priority_Specific_Dispatching forces ceiling
10442 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
10443 Error_Msg_Sloc := Locking_Policy_Sloc;
10445 ("Priority_Specific_Dispatching incompatible "
10446 & "with Locking_Policy#");
10448 -- Set the Ceiling_Locking policy, but preserve System_Location
10449 -- since we like the error message with the run time name.
10452 Locking_Policy := 'C';
10454 if Locking_Policy_Sloc /= System_Location then
10455 Locking_Policy_Sloc := Loc;
10459 -- Add entry in the table
10461 Specific_Dispatching.Append
10462 ((Dispatching_Policy => DP,
10463 First_Priority => UI_To_Int (Lower_Val),
10464 Last_Priority => UI_To_Int (Upper_Val),
10465 Pragma_Loc => Loc));
10467 end Priority_Specific_Dispatching;
10473 -- pragma Profile (profile_IDENTIFIER);
10475 -- profile_IDENTIFIER => Restricted | Ravenscar
10477 when Pragma_Profile =>
10479 Check_Arg_Count (1);
10480 Check_Valid_Configuration_Pragma;
10481 Check_No_Identifiers;
10484 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
10486 if Chars (Argx) = Name_Ravenscar then
10487 Set_Ravenscar_Profile (N);
10488 elsif Chars (Argx) = Name_Restricted then
10489 Set_Profile_Restrictions
10490 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
10492 Error_Pragma_Arg ("& is not a valid profile", Argx);
10496 ----------------------
10497 -- Profile_Warnings --
10498 ----------------------
10500 -- pragma Profile_Warnings (profile_IDENTIFIER);
10502 -- profile_IDENTIFIER => Restricted | Ravenscar
10504 when Pragma_Profile_Warnings =>
10506 Check_Arg_Count (1);
10507 Check_Valid_Configuration_Pragma;
10508 Check_No_Identifiers;
10511 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
10513 if Chars (Argx) = Name_Ravenscar then
10514 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
10515 elsif Chars (Argx) = Name_Restricted then
10516 Set_Profile_Restrictions (Restricted, N, Warn => True);
10518 Error_Pragma_Arg ("& is not a valid profile", Argx);
10522 --------------------------
10523 -- Propagate_Exceptions --
10524 --------------------------
10526 -- pragma Propagate_Exceptions;
10528 -- Note: this pragma is obsolete and has no effect
10530 when Pragma_Propagate_Exceptions =>
10532 Check_Arg_Count (0);
10534 if In_Extended_Main_Source_Unit (N) then
10535 Propagate_Exceptions := True;
10542 -- pragma Psect_Object (
10543 -- [Internal =>] LOCAL_NAME,
10544 -- [, [External =>] EXTERNAL_SYMBOL]
10545 -- [, [Size =>] EXTERNAL_SYMBOL]);
10547 when Pragma_Psect_Object | Pragma_Common_Object =>
10548 Psect_Object : declare
10549 Args : Args_List (1 .. 3);
10550 Names : constant Name_List (1 .. 3) := (
10555 Internal : Node_Id renames Args (1);
10556 External : Node_Id renames Args (2);
10557 Size : Node_Id renames Args (3);
10559 Def_Id : Entity_Id;
10561 procedure Check_Too_Long (Arg : Node_Id);
10562 -- Posts message if the argument is an identifier with more
10563 -- than 31 characters, or a string literal with more than
10564 -- 31 characters, and we are operating under VMS
10566 --------------------
10567 -- Check_Too_Long --
10568 --------------------
10570 procedure Check_Too_Long (Arg : Node_Id) is
10571 X : constant Node_Id := Original_Node (Arg);
10574 if not Nkind_In (X, N_String_Literal, N_Identifier) then
10576 ("inappropriate argument for pragma %", Arg);
10579 if OpenVMS_On_Target then
10580 if (Nkind (X) = N_String_Literal
10581 and then String_Length (Strval (X)) > 31)
10583 (Nkind (X) = N_Identifier
10584 and then Length_Of_Name (Chars (X)) > 31)
10587 ("argument for pragma % is longer than 31 characters",
10591 end Check_Too_Long;
10593 -- Start of processing for Common_Object/Psect_Object
10597 Gather_Associations (Names, Args);
10598 Process_Extended_Import_Export_Internal_Arg (Internal);
10600 Def_Id := Entity (Internal);
10602 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
10604 ("pragma% must designate an object", Internal);
10607 Check_Too_Long (Internal);
10609 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
10611 ("cannot use pragma% for imported/exported object",
10615 if Is_Concurrent_Type (Etype (Internal)) then
10617 ("cannot specify pragma % for task/protected object",
10621 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
10623 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
10625 Error_Msg_N ("?duplicate Common/Psect_Object pragma", N);
10628 if Ekind (Def_Id) = E_Constant then
10630 ("cannot specify pragma % for a constant", Internal);
10633 if Is_Record_Type (Etype (Internal)) then
10639 Ent := First_Entity (Etype (Internal));
10640 while Present (Ent) loop
10641 Decl := Declaration_Node (Ent);
10643 if Ekind (Ent) = E_Component
10644 and then Nkind (Decl) = N_Component_Declaration
10645 and then Present (Expression (Decl))
10646 and then Warn_On_Export_Import
10649 ("?object for pragma % has defaults", Internal);
10659 if Present (Size) then
10660 Check_Too_Long (Size);
10663 if Present (External) then
10664 Check_Arg_Is_External_Name (External);
10665 Check_Too_Long (External);
10668 -- If all error tests pass, link pragma on to the rep item chain
10670 Record_Rep_Item (Def_Id, N);
10677 -- pragma Pure [(library_unit_NAME)];
10679 when Pragma_Pure => Pure : declare
10683 Check_Ada_83_Warning;
10684 Check_Valid_Library_Unit_Pragma;
10686 if Nkind (N) = N_Null_Statement then
10690 Ent := Find_Lib_Unit_Name;
10692 Set_Has_Pragma_Pure (Ent);
10693 Set_Suppress_Elaboration_Warnings (Ent);
10700 -- pragma Pure_05 [(library_unit_NAME)];
10702 -- This pragma is useable only in GNAT_Mode, where it is used like
10703 -- pragma Pure but it is only effective in Ada 2005 mode (otherwise
10704 -- it is ignored). It may be used after a pragma Preelaborate, in
10705 -- which case it overrides the effect of the pragma Preelaborate.
10706 -- This is used to implement AI-362 which recategorizes some run-time
10707 -- packages in Ada 2005 mode.
10709 when Pragma_Pure_05 => Pure_05 : declare
10714 Check_Valid_Library_Unit_Pragma;
10716 if not GNAT_Mode then
10717 Error_Pragma ("pragma% only available in GNAT mode");
10720 if Nkind (N) = N_Null_Statement then
10724 -- This is one of the few cases where we need to test the value of
10725 -- Ada_Version_Explicit rather than Ada_Version (which is always
10726 -- set to Ada_12 in a predefined unit), we need to know the
10727 -- explicit version set to know if this pragma is active.
10729 if Ada_Version_Explicit >= Ada_05 then
10730 Ent := Find_Lib_Unit_Name;
10731 Set_Is_Preelaborated (Ent, False);
10733 Set_Suppress_Elaboration_Warnings (Ent);
10737 -------------------
10738 -- Pure_Function --
10739 -------------------
10741 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
10743 when Pragma_Pure_Function => Pure_Function : declare
10746 Def_Id : Entity_Id;
10747 Effective : Boolean := False;
10751 Check_Arg_Count (1);
10752 Check_Optional_Identifier (Arg1, Name_Entity);
10753 Check_Arg_Is_Local_Name (Arg1);
10754 E_Id := Expression (Arg1);
10756 if Error_Posted (E_Id) then
10760 -- Loop through homonyms (overloadings) of referenced entity
10762 E := Entity (E_Id);
10764 if Present (E) then
10766 Def_Id := Get_Base_Subprogram (E);
10768 if not Ekind_In (Def_Id, E_Function,
10769 E_Generic_Function,
10773 ("pragma% requires a function name", Arg1);
10776 Set_Is_Pure (Def_Id);
10778 if not Has_Pragma_Pure_Function (Def_Id) then
10779 Set_Has_Pragma_Pure_Function (Def_Id);
10784 exit when No (E) or else Scope (E) /= Current_Scope;
10788 and then Warn_On_Redundant_Constructs
10791 ("pragma Pure_Function on& is redundant?",
10797 --------------------
10798 -- Queuing_Policy --
10799 --------------------
10801 -- pragma Queuing_Policy (policy_IDENTIFIER);
10803 when Pragma_Queuing_Policy => declare
10807 Check_Ada_83_Warning;
10808 Check_Arg_Count (1);
10809 Check_No_Identifiers;
10810 Check_Arg_Is_Queuing_Policy (Arg1);
10811 Check_Valid_Configuration_Pragma;
10812 Get_Name_String (Chars (Expression (Arg1)));
10813 QP := Fold_Upper (Name_Buffer (1));
10815 if Queuing_Policy /= ' '
10816 and then Queuing_Policy /= QP
10818 Error_Msg_Sloc := Queuing_Policy_Sloc;
10819 Error_Pragma ("queuing policy incompatible with policy#");
10821 -- Set new policy, but always preserve System_Location since we
10822 -- like the error message with the run time name.
10825 Queuing_Policy := QP;
10827 if Queuing_Policy_Sloc /= System_Location then
10828 Queuing_Policy_Sloc := Loc;
10833 -----------------------
10834 -- Relative_Deadline --
10835 -----------------------
10837 -- pragma Relative_Deadline (time_span_EXPRESSION);
10839 when Pragma_Relative_Deadline => Relative_Deadline : declare
10840 P : constant Node_Id := Parent (N);
10845 Check_No_Identifiers;
10846 Check_Arg_Count (1);
10848 Arg := Expression (Arg1);
10850 -- The expression must be analyzed in the special manner described
10851 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
10853 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
10857 if Nkind (P) = N_Subprogram_Body then
10858 Check_In_Main_Program;
10862 elsif Nkind (P) = N_Task_Definition then
10865 -- Anything else is incorrect
10871 if Has_Relative_Deadline_Pragma (P) then
10872 Error_Pragma ("duplicate pragma% not allowed");
10874 Set_Has_Relative_Deadline_Pragma (P, True);
10876 if Nkind (P) = N_Task_Definition then
10877 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
10880 end Relative_Deadline;
10882 ---------------------------
10883 -- Remote_Call_Interface --
10884 ---------------------------
10886 -- pragma Remote_Call_Interface [(library_unit_NAME)];
10888 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
10889 Cunit_Node : Node_Id;
10890 Cunit_Ent : Entity_Id;
10894 Check_Ada_83_Warning;
10895 Check_Valid_Library_Unit_Pragma;
10897 if Nkind (N) = N_Null_Statement then
10901 Cunit_Node := Cunit (Current_Sem_Unit);
10902 K := Nkind (Unit (Cunit_Node));
10903 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
10905 if K = N_Package_Declaration
10906 or else K = N_Generic_Package_Declaration
10907 or else K = N_Subprogram_Declaration
10908 or else K = N_Generic_Subprogram_Declaration
10909 or else (K = N_Subprogram_Body
10910 and then Acts_As_Spec (Unit (Cunit_Node)))
10915 "pragma% must apply to package or subprogram declaration");
10918 Set_Is_Remote_Call_Interface (Cunit_Ent);
10919 end Remote_Call_Interface;
10925 -- pragma Remote_Types [(library_unit_NAME)];
10927 when Pragma_Remote_Types => Remote_Types : declare
10928 Cunit_Node : Node_Id;
10929 Cunit_Ent : Entity_Id;
10932 Check_Ada_83_Warning;
10933 Check_Valid_Library_Unit_Pragma;
10935 if Nkind (N) = N_Null_Statement then
10939 Cunit_Node := Cunit (Current_Sem_Unit);
10940 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
10942 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
10943 N_Generic_Package_Declaration)
10946 ("pragma% can only apply to a package declaration");
10949 Set_Is_Remote_Types (Cunit_Ent);
10956 -- pragma Ravenscar;
10958 when Pragma_Ravenscar =>
10960 Check_Arg_Count (0);
10961 Check_Valid_Configuration_Pragma;
10962 Set_Ravenscar_Profile (N);
10964 if Warn_On_Obsolescent_Feature then
10965 Error_Msg_N ("pragma Ravenscar is an obsolescent feature?", N);
10966 Error_Msg_N ("|use pragma Profile (Ravenscar) instead", N);
10969 -------------------------
10970 -- Restricted_Run_Time --
10971 -------------------------
10973 -- pragma Restricted_Run_Time;
10975 when Pragma_Restricted_Run_Time =>
10977 Check_Arg_Count (0);
10978 Check_Valid_Configuration_Pragma;
10979 Set_Profile_Restrictions
10980 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
10982 if Warn_On_Obsolescent_Feature then
10984 ("pragma Restricted_Run_Time is an obsolescent feature?", N);
10985 Error_Msg_N ("|use pragma Profile (Restricted) instead", N);
10992 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
10995 -- restriction_IDENTIFIER
10996 -- | restriction_parameter_IDENTIFIER => EXPRESSION
10998 when Pragma_Restrictions =>
10999 Process_Restrictions_Or_Restriction_Warnings
11000 (Warn => Treat_Restrictions_As_Warnings);
11002 --------------------------
11003 -- Restriction_Warnings --
11004 --------------------------
11006 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
11009 -- restriction_IDENTIFIER
11010 -- | restriction_parameter_IDENTIFIER => EXPRESSION
11012 when Pragma_Restriction_Warnings =>
11014 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
11020 -- pragma Reviewable;
11022 when Pragma_Reviewable =>
11023 Check_Ada_83_Warning;
11024 Check_Arg_Count (0);
11026 -- Call dummy debugging function rv. This is done to assist front
11027 -- end debugging. By placing a Reviewable pragma in the source
11028 -- program, a breakpoint on rv catches this place in the source,
11029 -- allowing convenient stepping to the point of interest.
11033 --------------------------
11034 -- Short_Circuit_And_Or --
11035 --------------------------
11037 when Pragma_Short_Circuit_And_Or =>
11039 Check_Arg_Count (0);
11040 Check_Valid_Configuration_Pragma;
11041 Short_Circuit_And_Or := True;
11043 -------------------
11044 -- Share_Generic --
11045 -------------------
11047 -- pragma Share_Generic (NAME {, NAME});
11049 when Pragma_Share_Generic =>
11051 Process_Generic_List;
11057 -- pragma Shared (LOCAL_NAME);
11059 when Pragma_Shared =>
11061 Process_Atomic_Shared_Volatile;
11063 --------------------
11064 -- Shared_Passive --
11065 --------------------
11067 -- pragma Shared_Passive [(library_unit_NAME)];
11069 -- Set the flag Is_Shared_Passive of program unit name entity
11071 when Pragma_Shared_Passive => Shared_Passive : declare
11072 Cunit_Node : Node_Id;
11073 Cunit_Ent : Entity_Id;
11076 Check_Ada_83_Warning;
11077 Check_Valid_Library_Unit_Pragma;
11079 if Nkind (N) = N_Null_Statement then
11083 Cunit_Node := Cunit (Current_Sem_Unit);
11084 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
11086 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
11087 N_Generic_Package_Declaration)
11090 ("pragma% can only apply to a package declaration");
11093 Set_Is_Shared_Passive (Cunit_Ent);
11094 end Shared_Passive;
11096 -----------------------
11097 -- Short_Descriptors --
11098 -----------------------
11100 -- pragma Short_Descriptors;
11102 when Pragma_Short_Descriptors =>
11104 Check_Arg_Count (0);
11105 Check_Valid_Configuration_Pragma;
11106 Short_Descriptors := True;
11108 ----------------------
11109 -- Source_File_Name --
11110 ----------------------
11112 -- There are five forms for this pragma:
11114 -- pragma Source_File_Name (
11115 -- [UNIT_NAME =>] unit_NAME,
11116 -- BODY_FILE_NAME => STRING_LITERAL
11117 -- [, [INDEX =>] INTEGER_LITERAL]);
11119 -- pragma Source_File_Name (
11120 -- [UNIT_NAME =>] unit_NAME,
11121 -- SPEC_FILE_NAME => STRING_LITERAL
11122 -- [, [INDEX =>] INTEGER_LITERAL]);
11124 -- pragma Source_File_Name (
11125 -- BODY_FILE_NAME => STRING_LITERAL
11126 -- [, DOT_REPLACEMENT => STRING_LITERAL]
11127 -- [, CASING => CASING_SPEC]);
11129 -- pragma Source_File_Name (
11130 -- SPEC_FILE_NAME => STRING_LITERAL
11131 -- [, DOT_REPLACEMENT => STRING_LITERAL]
11132 -- [, CASING => CASING_SPEC]);
11134 -- pragma Source_File_Name (
11135 -- SUBUNIT_FILE_NAME => STRING_LITERAL
11136 -- [, DOT_REPLACEMENT => STRING_LITERAL]
11137 -- [, CASING => CASING_SPEC]);
11139 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
11141 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
11142 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
11143 -- only be used when no project file is used, while SFNP can only be
11144 -- used when a project file is used.
11146 -- No processing here. Processing was completed during parsing, since
11147 -- we need to have file names set as early as possible. Units are
11148 -- loaded well before semantic processing starts.
11150 -- The only processing we defer to this point is the check for
11151 -- correct placement.
11153 when Pragma_Source_File_Name =>
11155 Check_Valid_Configuration_Pragma;
11157 ------------------------------
11158 -- Source_File_Name_Project --
11159 ------------------------------
11161 -- See Source_File_Name for syntax
11163 -- No processing here. Processing was completed during parsing, since
11164 -- we need to have file names set as early as possible. Units are
11165 -- loaded well before semantic processing starts.
11167 -- The only processing we defer to this point is the check for
11168 -- correct placement.
11170 when Pragma_Source_File_Name_Project =>
11172 Check_Valid_Configuration_Pragma;
11174 -- Check that a pragma Source_File_Name_Project is used only in a
11175 -- configuration pragmas file.
11177 -- Pragmas Source_File_Name_Project should only be generated by
11178 -- the Project Manager in configuration pragmas files.
11180 -- This is really an ugly test. It seems to depend on some
11181 -- accidental and undocumented property. At the very least it
11182 -- needs to be documented, but it would be better to have a
11183 -- clean way of testing if we are in a configuration file???
11185 if Present (Parent (N)) then
11187 ("pragma% can only appear in a configuration pragmas file");
11190 ----------------------
11191 -- Source_Reference --
11192 ----------------------
11194 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
11196 -- Nothing to do, all processing completed in Par.Prag, since we need
11197 -- the information for possible parser messages that are output.
11199 when Pragma_Source_Reference =>
11202 --------------------------------
11203 -- Static_Elaboration_Desired --
11204 --------------------------------
11206 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
11208 when Pragma_Static_Elaboration_Desired =>
11210 Check_At_Most_N_Arguments (1);
11212 if Is_Compilation_Unit (Current_Scope)
11213 and then Ekind (Current_Scope) = E_Package
11215 Set_Static_Elaboration_Desired (Current_Scope, True);
11217 Error_Pragma ("pragma% must apply to a library-level package");
11224 -- pragma Storage_Size (EXPRESSION);
11226 when Pragma_Storage_Size => Storage_Size : declare
11227 P : constant Node_Id := Parent (N);
11231 Check_No_Identifiers;
11232 Check_Arg_Count (1);
11234 -- The expression must be analyzed in the special manner described
11235 -- in "Handling of Default Expressions" in sem.ads.
11237 Arg := Expression (Arg1);
11238 Preanalyze_Spec_Expression (Arg, Any_Integer);
11240 if not Is_Static_Expression (Arg) then
11241 Check_Restriction (Static_Storage_Size, Arg);
11244 if Nkind (P) /= N_Task_Definition then
11249 if Has_Storage_Size_Pragma (P) then
11250 Error_Pragma ("duplicate pragma% not allowed");
11252 Set_Has_Storage_Size_Pragma (P, True);
11255 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
11256 -- ??? exp_ch9 should use this!
11264 -- pragma Storage_Unit (NUMERIC_LITERAL);
11266 -- Only permitted argument is System'Storage_Unit value
11268 when Pragma_Storage_Unit =>
11269 Check_No_Identifiers;
11270 Check_Arg_Count (1);
11271 Check_Arg_Is_Integer_Literal (Arg1);
11273 if Intval (Expression (Arg1)) /=
11274 UI_From_Int (Ttypes.System_Storage_Unit)
11276 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
11278 ("the only allowed argument for pragma% is ^", Arg1);
11281 --------------------
11282 -- Stream_Convert --
11283 --------------------
11285 -- pragma Stream_Convert (
11286 -- [Entity =>] type_LOCAL_NAME,
11287 -- [Read =>] function_NAME,
11288 -- [Write =>] function NAME);
11290 when Pragma_Stream_Convert => Stream_Convert : declare
11292 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
11293 -- Check that the given argument is the name of a local function
11294 -- of one argument that is not overloaded earlier in the current
11295 -- local scope. A check is also made that the argument is a
11296 -- function with one parameter.
11298 --------------------------------------
11299 -- Check_OK_Stream_Convert_Function --
11300 --------------------------------------
11302 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
11306 Check_Arg_Is_Local_Name (Arg);
11307 Ent := Entity (Expression (Arg));
11309 if Has_Homonym (Ent) then
11311 ("argument for pragma% may not be overloaded", Arg);
11314 if Ekind (Ent) /= E_Function
11315 or else No (First_Formal (Ent))
11316 or else Present (Next_Formal (First_Formal (Ent)))
11319 ("argument for pragma% must be" &
11320 " function of one argument", Arg);
11322 end Check_OK_Stream_Convert_Function;
11324 -- Start of processing for Stream_Convert
11328 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
11329 Check_Arg_Count (3);
11330 Check_Optional_Identifier (Arg1, Name_Entity);
11331 Check_Optional_Identifier (Arg2, Name_Read);
11332 Check_Optional_Identifier (Arg3, Name_Write);
11333 Check_Arg_Is_Local_Name (Arg1);
11334 Check_OK_Stream_Convert_Function (Arg2);
11335 Check_OK_Stream_Convert_Function (Arg3);
11338 Typ : constant Entity_Id :=
11339 Underlying_Type (Entity (Expression (Arg1)));
11340 Read : constant Entity_Id := Entity (Expression (Arg2));
11341 Write : constant Entity_Id := Entity (Expression (Arg3));
11344 Check_First_Subtype (Arg1);
11346 -- Check for too early or too late. Note that we don't enforce
11347 -- the rule about primitive operations in this case, since, as
11348 -- is the case for explicit stream attributes themselves, these
11349 -- restrictions are not appropriate. Note that the chaining of
11350 -- the pragma by Rep_Item_Too_Late is actually the critical
11351 -- processing done for this pragma.
11353 if Rep_Item_Too_Early (Typ, N)
11355 Rep_Item_Too_Late (Typ, N, FOnly => True)
11360 -- Return if previous error
11362 if Etype (Typ) = Any_Type
11364 Etype (Read) = Any_Type
11366 Etype (Write) = Any_Type
11373 if Underlying_Type (Etype (Read)) /= Typ then
11375 ("incorrect return type for function&", Arg2);
11378 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
11380 ("incorrect parameter type for function&", Arg3);
11383 if Underlying_Type (Etype (First_Formal (Read))) /=
11384 Underlying_Type (Etype (Write))
11387 ("result type of & does not match Read parameter type",
11391 end Stream_Convert;
11393 -------------------------
11394 -- Style_Checks (GNAT) --
11395 -------------------------
11397 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
11399 -- This is processed by the parser since some of the style checks
11400 -- take place during source scanning and parsing. This means that
11401 -- we don't need to issue error messages here.
11403 when Pragma_Style_Checks => Style_Checks : declare
11404 A : constant Node_Id := Expression (Arg1);
11410 Check_No_Identifiers;
11412 -- Two argument form
11414 if Arg_Count = 2 then
11415 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
11422 E_Id := Expression (Arg2);
11425 if not Is_Entity_Name (E_Id) then
11427 ("second argument of pragma% must be entity name",
11431 E := Entity (E_Id);
11437 Set_Suppress_Style_Checks (E,
11438 (Chars (Expression (Arg1)) = Name_Off));
11439 exit when No (Homonym (E));
11445 -- One argument form
11448 Check_Arg_Count (1);
11450 if Nkind (A) = N_String_Literal then
11454 Slen : constant Natural := Natural (String_Length (S));
11455 Options : String (1 .. Slen);
11461 C := Get_String_Char (S, Int (J));
11462 exit when not In_Character_Range (C);
11463 Options (J) := Get_Character (C);
11465 -- If at end of string, set options. As per discussion
11466 -- above, no need to check for errors, since we issued
11467 -- them in the parser.
11470 Set_Style_Check_Options (Options);
11478 elsif Nkind (A) = N_Identifier then
11479 if Chars (A) = Name_All_Checks then
11481 Set_GNAT_Style_Check_Options;
11483 Set_Default_Style_Check_Options;
11486 elsif Chars (A) = Name_On then
11487 Style_Check := True;
11489 elsif Chars (A) = Name_Off then
11490 Style_Check := False;
11500 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
11502 when Pragma_Subtitle =>
11504 Check_Arg_Count (1);
11505 Check_Optional_Identifier (Arg1, Name_Subtitle);
11506 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
11513 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
11515 when Pragma_Suppress =>
11516 Process_Suppress_Unsuppress (True);
11522 -- pragma Suppress_All;
11524 -- The only check made here is that the pragma appears in the proper
11525 -- place, i.e. following a compilation unit. If indeed it appears in
11526 -- this context, then the parser has already inserted an equivalent
11527 -- pragma Suppress (All_Checks) to get the required effect.
11529 when Pragma_Suppress_All =>
11531 Check_Arg_Count (0);
11533 if Nkind (Parent (N)) /= N_Compilation_Unit_Aux
11534 or else not Is_List_Member (N)
11535 or else List_Containing (N) /= Pragmas_After (Parent (N))
11538 ("misplaced pragma%, must follow compilation unit");
11541 -------------------------
11542 -- Suppress_Debug_Info --
11543 -------------------------
11545 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
11547 when Pragma_Suppress_Debug_Info =>
11549 Check_Arg_Count (1);
11550 Check_Optional_Identifier (Arg1, Name_Entity);
11551 Check_Arg_Is_Local_Name (Arg1);
11552 Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1)));
11554 ----------------------------------
11555 -- Suppress_Exception_Locations --
11556 ----------------------------------
11558 -- pragma Suppress_Exception_Locations;
11560 when Pragma_Suppress_Exception_Locations =>
11562 Check_Arg_Count (0);
11563 Check_Valid_Configuration_Pragma;
11564 Exception_Locations_Suppressed := True;
11566 -----------------------------
11567 -- Suppress_Initialization --
11568 -----------------------------
11570 -- pragma Suppress_Initialization ([Entity =>] type_Name);
11572 when Pragma_Suppress_Initialization => Suppress_Init : declare
11578 Check_Arg_Count (1);
11579 Check_Optional_Identifier (Arg1, Name_Entity);
11580 Check_Arg_Is_Local_Name (Arg1);
11582 E_Id := Expression (Arg1);
11584 if Etype (E_Id) = Any_Type then
11588 E := Entity (E_Id);
11590 if Is_Type (E) then
11591 if Is_Incomplete_Or_Private_Type (E) then
11592 if No (Full_View (Base_Type (E))) then
11594 ("argument of pragma% cannot be an incomplete type",
11597 Set_Suppress_Init_Proc (Full_View (Base_Type (E)));
11600 Set_Suppress_Init_Proc (Base_Type (E));
11605 ("pragma% requires argument that is a type name", Arg1);
11613 -- pragma System_Name (DIRECT_NAME);
11615 -- Syntax check: one argument, which must be the identifier GNAT or
11616 -- the identifier GCC, no other identifiers are acceptable.
11618 when Pragma_System_Name =>
11620 Check_No_Identifiers;
11621 Check_Arg_Count (1);
11622 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
11624 -----------------------------
11625 -- Task_Dispatching_Policy --
11626 -----------------------------
11628 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
11630 when Pragma_Task_Dispatching_Policy => declare
11634 Check_Ada_83_Warning;
11635 Check_Arg_Count (1);
11636 Check_No_Identifiers;
11637 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
11638 Check_Valid_Configuration_Pragma;
11639 Get_Name_String (Chars (Expression (Arg1)));
11640 DP := Fold_Upper (Name_Buffer (1));
11642 if Task_Dispatching_Policy /= ' '
11643 and then Task_Dispatching_Policy /= DP
11645 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
11647 ("task dispatching policy incompatible with policy#");
11649 -- Set new policy, but always preserve System_Location since we
11650 -- like the error message with the run time name.
11653 Task_Dispatching_Policy := DP;
11655 if Task_Dispatching_Policy_Sloc /= System_Location then
11656 Task_Dispatching_Policy_Sloc := Loc;
11665 -- pragma Task_Info (EXPRESSION);
11667 when Pragma_Task_Info => Task_Info : declare
11668 P : constant Node_Id := Parent (N);
11673 if Nkind (P) /= N_Task_Definition then
11674 Error_Pragma ("pragma% must appear in task definition");
11677 Check_No_Identifiers;
11678 Check_Arg_Count (1);
11680 Analyze_And_Resolve (Expression (Arg1), RTE (RE_Task_Info_Type));
11682 if Etype (Expression (Arg1)) = Any_Type then
11686 if Has_Task_Info_Pragma (P) then
11687 Error_Pragma ("duplicate pragma% not allowed");
11689 Set_Has_Task_Info_Pragma (P, True);
11697 -- pragma Task_Name (string_EXPRESSION);
11699 when Pragma_Task_Name => Task_Name : declare
11700 P : constant Node_Id := Parent (N);
11704 Check_No_Identifiers;
11705 Check_Arg_Count (1);
11707 Arg := Expression (Arg1);
11709 -- The expression is used in the call to Create_Task, and must be
11710 -- expanded there, not in the context of the current spec. It must
11711 -- however be analyzed to capture global references, in case it
11712 -- appears in a generic context.
11714 Preanalyze_And_Resolve (Arg, Standard_String);
11716 if Nkind (P) /= N_Task_Definition then
11720 if Has_Task_Name_Pragma (P) then
11721 Error_Pragma ("duplicate pragma% not allowed");
11723 Set_Has_Task_Name_Pragma (P, True);
11724 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
11732 -- pragma Task_Storage (
11733 -- [Task_Type =>] LOCAL_NAME,
11734 -- [Top_Guard =>] static_integer_EXPRESSION);
11736 when Pragma_Task_Storage => Task_Storage : declare
11737 Args : Args_List (1 .. 2);
11738 Names : constant Name_List (1 .. 2) := (
11742 Task_Type : Node_Id renames Args (1);
11743 Top_Guard : Node_Id renames Args (2);
11749 Gather_Associations (Names, Args);
11751 if No (Task_Type) then
11753 ("missing task_type argument for pragma%");
11756 Check_Arg_Is_Local_Name (Task_Type);
11758 Ent := Entity (Task_Type);
11760 if not Is_Task_Type (Ent) then
11762 ("argument for pragma% must be task type", Task_Type);
11765 if No (Top_Guard) then
11767 ("pragma% takes two arguments", Task_Type);
11769 Check_Arg_Is_Static_Expression (Top_Guard, Any_Integer);
11772 Check_First_Subtype (Task_Type);
11774 if Rep_Item_Too_Late (Ent, N) then
11779 --------------------------
11780 -- Thread_Local_Storage --
11781 --------------------------
11783 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
11785 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
11791 Check_Arg_Count (1);
11792 Check_Optional_Identifier (Arg1, Name_Entity);
11793 Check_Arg_Is_Library_Level_Local_Name (Arg1);
11795 Id := Expression (Arg1);
11798 if not Is_Entity_Name (Id)
11799 or else Ekind (Entity (Id)) /= E_Variable
11801 Error_Pragma_Arg ("local variable name required", Arg1);
11806 if Rep_Item_Too_Early (E, N)
11807 or else Rep_Item_Too_Late (E, N)
11812 Set_Has_Pragma_Thread_Local_Storage (E);
11813 Set_Has_Gigi_Rep_Item (E);
11814 end Thread_Local_Storage;
11820 -- pragma Time_Slice (static_duration_EXPRESSION);
11822 when Pragma_Time_Slice => Time_Slice : declare
11828 Check_Arg_Count (1);
11829 Check_No_Identifiers;
11830 Check_In_Main_Program;
11831 Check_Arg_Is_Static_Expression (Arg1, Standard_Duration);
11833 if not Error_Posted (Arg1) then
11835 while Present (Nod) loop
11836 if Nkind (Nod) = N_Pragma
11837 and then Pragma_Name (Nod) = Name_Time_Slice
11839 Error_Msg_Name_1 := Pname;
11840 Error_Msg_N ("duplicate pragma% not permitted", Nod);
11847 -- Process only if in main unit
11849 if Get_Source_Unit (Loc) = Main_Unit then
11850 Opt.Time_Slice_Set := True;
11851 Val := Expr_Value_R (Expression (Arg1));
11853 if Val <= Ureal_0 then
11854 Opt.Time_Slice_Value := 0;
11856 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
11857 Opt.Time_Slice_Value := 1_000_000_000;
11860 Opt.Time_Slice_Value :=
11861 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
11870 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
11872 -- TITLING_OPTION ::=
11873 -- [Title =>] STRING_LITERAL
11874 -- | [Subtitle =>] STRING_LITERAL
11876 when Pragma_Title => Title : declare
11877 Args : Args_List (1 .. 2);
11878 Names : constant Name_List (1 .. 2) := (
11884 Gather_Associations (Names, Args);
11887 for J in 1 .. 2 loop
11888 if Present (Args (J)) then
11889 Check_Arg_Is_Static_Expression (Args (J), Standard_String);
11894 ---------------------
11895 -- Unchecked_Union --
11896 ---------------------
11898 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
11900 when Pragma_Unchecked_Union => Unchecked_Union : declare
11901 Assoc : constant Node_Id := Arg1;
11902 Type_Id : constant Node_Id := Expression (Assoc);
11913 Check_No_Identifiers;
11914 Check_Arg_Count (1);
11915 Check_Arg_Is_Local_Name (Arg1);
11917 Find_Type (Type_Id);
11918 Typ := Entity (Type_Id);
11921 or else Rep_Item_Too_Early (Typ, N)
11925 Typ := Underlying_Type (Typ);
11928 if Rep_Item_Too_Late (Typ, N) then
11932 Check_First_Subtype (Arg1);
11934 -- Note remaining cases are references to a type in the current
11935 -- declarative part. If we find an error, we post the error on
11936 -- the relevant type declaration at an appropriate point.
11938 if not Is_Record_Type (Typ) then
11939 Error_Msg_N ("Unchecked_Union must be record type", Typ);
11942 elsif Is_Tagged_Type (Typ) then
11943 Error_Msg_N ("Unchecked_Union must not be tagged", Typ);
11946 elsif Is_Limited_Type (Typ) then
11948 ("Unchecked_Union must not be limited record type", Typ);
11949 Explain_Limited_Type (Typ, Typ);
11953 if not Has_Discriminants (Typ) then
11955 ("Unchecked_Union must have one discriminant", Typ);
11959 Discr := First_Discriminant (Typ);
11960 while Present (Discr) loop
11961 if No (Discriminant_Default_Value (Discr)) then
11963 ("Unchecked_Union discriminant must have default value",
11966 Next_Discriminant (Discr);
11969 Tdef := Type_Definition (Declaration_Node (Typ));
11970 Clist := Component_List (Tdef);
11972 Comp := First (Component_Items (Clist));
11973 while Present (Comp) loop
11974 Check_Component (Comp);
11978 if No (Clist) or else No (Variant_Part (Clist)) then
11980 ("Unchecked_Union must have variant part",
11985 Vpart := Variant_Part (Clist);
11987 Variant := First (Variants (Vpart));
11988 while Present (Variant) loop
11989 Check_Variant (Variant);
11994 Set_Is_Unchecked_Union (Typ, True);
11995 Set_Convention (Typ, Convention_C);
11997 Set_Has_Unchecked_Union (Base_Type (Typ), True);
11998 Set_Is_Unchecked_Union (Base_Type (Typ), True);
11999 end Unchecked_Union;
12001 ------------------------
12002 -- Unimplemented_Unit --
12003 ------------------------
12005 -- pragma Unimplemented_Unit;
12007 -- Note: this only gives an error if we are generating code, or if
12008 -- we are in a generic library unit (where the pragma appears in the
12009 -- body, not in the spec).
12011 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
12012 Cunitent : constant Entity_Id :=
12013 Cunit_Entity (Get_Source_Unit (Loc));
12014 Ent_Kind : constant Entity_Kind :=
12019 Check_Arg_Count (0);
12021 if Operating_Mode = Generate_Code
12022 or else Ent_Kind = E_Generic_Function
12023 or else Ent_Kind = E_Generic_Procedure
12024 or else Ent_Kind = E_Generic_Package
12026 Get_Name_String (Chars (Cunitent));
12027 Set_Casing (Mixed_Case);
12028 Write_Str (Name_Buffer (1 .. Name_Len));
12029 Write_Str (" is not supported in this configuration");
12031 raise Unrecoverable_Error;
12033 end Unimplemented_Unit;
12035 ------------------------
12036 -- Universal_Aliasing --
12037 ------------------------
12039 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
12041 when Pragma_Universal_Aliasing => Universal_Alias : declare
12046 Check_Arg_Count (1);
12047 Check_Optional_Identifier (Arg2, Name_Entity);
12048 Check_Arg_Is_Local_Name (Arg1);
12049 E_Id := Entity (Expression (Arg1));
12051 if E_Id = Any_Type then
12053 elsif No (E_Id) or else not Is_Type (E_Id) then
12054 Error_Pragma_Arg ("pragma% requires type", Arg1);
12057 Set_Universal_Aliasing (Implementation_Base_Type (E_Id));
12058 end Universal_Alias;
12060 --------------------
12061 -- Universal_Data --
12062 --------------------
12064 -- pragma Universal_Data [(library_unit_NAME)];
12066 when Pragma_Universal_Data =>
12069 -- If this is a configuration pragma, then set the universal
12070 -- addressing option, otherwise confirm that the pragma satisfies
12071 -- the requirements of library unit pragma placement and leave it
12072 -- to the GNAAMP back end to detect the pragma (avoids transitive
12073 -- setting of the option due to withed units).
12075 if Is_Configuration_Pragma then
12076 Universal_Addressing_On_AAMP := True;
12078 Check_Valid_Library_Unit_Pragma;
12081 if not AAMP_On_Target then
12082 Error_Pragma ("?pragma% ignored (applies only to AAMP)");
12089 -- pragma Unmodified (local_Name {, local_Name});
12091 when Pragma_Unmodified => Unmodified : declare
12092 Arg_Node : Node_Id;
12093 Arg_Expr : Node_Id;
12094 Arg_Ent : Entity_Id;
12098 Check_At_Least_N_Arguments (1);
12100 -- Loop through arguments
12103 while Present (Arg_Node) loop
12104 Check_No_Identifier (Arg_Node);
12106 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
12107 -- in fact generate reference, so that the entity will have a
12108 -- reference, which will inhibit any warnings about it not
12109 -- being referenced, and also properly show up in the ali file
12110 -- as a reference. But this reference is recorded before the
12111 -- Has_Pragma_Unreferenced flag is set, so that no warning is
12112 -- generated for this reference.
12114 Check_Arg_Is_Local_Name (Arg_Node);
12115 Arg_Expr := Get_Pragma_Arg (Arg_Node);
12117 if Is_Entity_Name (Arg_Expr) then
12118 Arg_Ent := Entity (Arg_Expr);
12120 if not Is_Assignable (Arg_Ent) then
12122 ("pragma% can only be applied to a variable",
12125 Set_Has_Pragma_Unmodified (Arg_Ent);
12137 -- pragma Unreferenced (local_Name {, local_Name});
12139 -- or when used in a context clause:
12141 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
12143 when Pragma_Unreferenced => Unreferenced : declare
12144 Arg_Node : Node_Id;
12145 Arg_Expr : Node_Id;
12146 Arg_Ent : Entity_Id;
12151 Check_At_Least_N_Arguments (1);
12153 -- Check case of appearing within context clause
12155 if Is_In_Context_Clause then
12157 -- The arguments must all be units mentioned in a with clause
12158 -- in the same context clause. Note we already checked (in
12159 -- Par.Prag) that the arguments are either identifiers or
12160 -- selected components.
12163 while Present (Arg_Node) loop
12164 Citem := First (List_Containing (N));
12165 while Citem /= N loop
12166 if Nkind (Citem) = N_With_Clause
12167 and then Same_Name (Name (Citem), Expression (Arg_Node))
12169 Set_Has_Pragma_Unreferenced
12172 (Library_Unit (Citem))));
12173 Set_Unit_Name (Expression (Arg_Node), Name (Citem));
12182 ("argument of pragma% is not with'ed unit", Arg_Node);
12188 -- Case of not in list of context items
12192 while Present (Arg_Node) loop
12193 Check_No_Identifier (Arg_Node);
12195 -- Note: the analyze call done by Check_Arg_Is_Local_Name
12196 -- will in fact generate reference, so that the entity will
12197 -- have a reference, which will inhibit any warnings about
12198 -- it not being referenced, and also properly show up in the
12199 -- ali file as a reference. But this reference is recorded
12200 -- before the Has_Pragma_Unreferenced flag is set, so that
12201 -- no warning is generated for this reference.
12203 Check_Arg_Is_Local_Name (Arg_Node);
12204 Arg_Expr := Get_Pragma_Arg (Arg_Node);
12206 if Is_Entity_Name (Arg_Expr) then
12207 Arg_Ent := Entity (Arg_Expr);
12209 -- If the entity is overloaded, the pragma applies to the
12210 -- most recent overloading, as documented. In this case,
12211 -- name resolution does not generate a reference, so it
12212 -- must be done here explicitly.
12214 if Is_Overloaded (Arg_Expr) then
12215 Generate_Reference (Arg_Ent, N);
12218 Set_Has_Pragma_Unreferenced (Arg_Ent);
12226 --------------------------
12227 -- Unreferenced_Objects --
12228 --------------------------
12230 -- pragma Unreferenced_Objects (local_Name {, local_Name});
12232 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
12233 Arg_Node : Node_Id;
12234 Arg_Expr : Node_Id;
12238 Check_At_Least_N_Arguments (1);
12241 while Present (Arg_Node) loop
12242 Check_No_Identifier (Arg_Node);
12243 Check_Arg_Is_Local_Name (Arg_Node);
12244 Arg_Expr := Get_Pragma_Arg (Arg_Node);
12246 if not Is_Entity_Name (Arg_Expr)
12247 or else not Is_Type (Entity (Arg_Expr))
12250 ("argument for pragma% must be type or subtype", Arg_Node);
12253 Set_Has_Pragma_Unreferenced_Objects (Entity (Arg_Expr));
12256 end Unreferenced_Objects;
12258 ------------------------------
12259 -- Unreserve_All_Interrupts --
12260 ------------------------------
12262 -- pragma Unreserve_All_Interrupts;
12264 when Pragma_Unreserve_All_Interrupts =>
12266 Check_Arg_Count (0);
12268 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
12269 Unreserve_All_Interrupts := True;
12276 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
12278 when Pragma_Unsuppress =>
12280 Process_Suppress_Unsuppress (False);
12282 -------------------
12283 -- Use_VADS_Size --
12284 -------------------
12286 -- pragma Use_VADS_Size;
12288 when Pragma_Use_VADS_Size =>
12290 Check_Arg_Count (0);
12291 Check_Valid_Configuration_Pragma;
12292 Use_VADS_Size := True;
12294 ---------------------
12295 -- Validity_Checks --
12296 ---------------------
12298 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
12300 when Pragma_Validity_Checks => Validity_Checks : declare
12301 A : constant Node_Id := Expression (Arg1);
12307 Check_Arg_Count (1);
12308 Check_No_Identifiers;
12310 if Nkind (A) = N_String_Literal then
12314 Slen : constant Natural := Natural (String_Length (S));
12315 Options : String (1 .. Slen);
12321 C := Get_String_Char (S, Int (J));
12322 exit when not In_Character_Range (C);
12323 Options (J) := Get_Character (C);
12326 Set_Validity_Check_Options (Options);
12334 elsif Nkind (A) = N_Identifier then
12336 if Chars (A) = Name_All_Checks then
12337 Set_Validity_Check_Options ("a");
12339 elsif Chars (A) = Name_On then
12340 Validity_Checks_On := True;
12342 elsif Chars (A) = Name_Off then
12343 Validity_Checks_On := False;
12347 end Validity_Checks;
12353 -- pragma Volatile (LOCAL_NAME);
12355 when Pragma_Volatile =>
12356 Process_Atomic_Shared_Volatile;
12358 -------------------------
12359 -- Volatile_Components --
12360 -------------------------
12362 -- pragma Volatile_Components (array_LOCAL_NAME);
12364 -- Volatile is handled by the same circuit as Atomic_Components
12370 -- pragma Warnings (On | Off);
12371 -- pragma Warnings (On | Off, LOCAL_NAME);
12372 -- pragma Warnings (static_string_EXPRESSION);
12373 -- pragma Warnings (On | Off, STRING_LITERAL);
12375 when Pragma_Warnings => Warnings : begin
12377 Check_At_Least_N_Arguments (1);
12378 Check_No_Identifiers;
12380 -- If debug flag -gnatd.i is set, pragma is ignored
12382 if Debug_Flag_Dot_I then
12386 -- Process various forms of the pragma
12389 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
12392 -- One argument case
12394 if Arg_Count = 1 then
12396 -- On/Off one argument case was processed by parser
12398 if Nkind (Argx) = N_Identifier
12400 (Chars (Argx) = Name_On
12402 Chars (Argx) = Name_Off)
12406 -- One argument case must be ON/OFF or static string expr
12408 elsif not Is_Static_String_Expression (Arg1) then
12410 ("argument of pragma% must be On/Off or " &
12411 "static string expression", Arg1);
12413 -- One argument string expression case
12417 Lit : constant Node_Id := Expr_Value_S (Argx);
12418 Str : constant String_Id := Strval (Lit);
12419 Len : constant Nat := String_Length (Str);
12427 while J <= Len loop
12428 C := Get_String_Char (Str, J);
12429 OK := In_Character_Range (C);
12432 Chr := Get_Character (C);
12436 if J < Len and then Chr = '.' then
12438 C := Get_String_Char (Str, J);
12439 Chr := Get_Character (C);
12441 if not Set_Dot_Warning_Switch (Chr) then
12443 ("invalid warning switch character " &
12450 OK := Set_Warning_Switch (Chr);
12456 ("invalid warning switch character " & Chr,
12465 -- Two or more arguments (must be two)
12468 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
12469 Check_At_Most_N_Arguments (2);
12477 E_Id := Expression (Arg2);
12480 -- In the expansion of an inlined body, a reference to
12481 -- the formal may be wrapped in a conversion if the
12482 -- actual is a conversion. Retrieve the real entity name.
12484 if (In_Instance_Body
12485 or else In_Inlined_Body)
12486 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
12488 E_Id := Expression (E_Id);
12491 -- Entity name case
12493 if Is_Entity_Name (E_Id) then
12494 E := Entity (E_Id);
12501 (E, (Chars (Expression (Arg1)) = Name_Off));
12503 if Chars (Expression (Arg1)) = Name_Off
12504 and then Warn_On_Warnings_Off
12506 Warnings_Off_Pragmas.Append ((N, E));
12509 if Is_Enumeration_Type (E) then
12513 Lit := First_Literal (E);
12514 while Present (Lit) loop
12515 Set_Warnings_Off (Lit);
12516 Next_Literal (Lit);
12521 exit when No (Homonym (E));
12526 -- Error if not entity or static string literal case
12528 elsif not Is_Static_String_Expression (Arg2) then
12530 ("second argument of pragma% must be entity " &
12531 "name or static string expression", Arg2);
12533 -- String literal case
12536 String_To_Name_Buffer
12537 (Strval (Expr_Value_S (Expression (Arg2))));
12539 -- Note on configuration pragma case: If this is a
12540 -- configuration pragma, then for an OFF pragma, we
12541 -- just set Config True in the call, which is all
12542 -- that needs to be done. For the case of ON, this
12543 -- is normally an error, unless it is canceling the
12544 -- effect of a previous OFF pragma in the same file.
12545 -- In any other case, an error will be signalled (ON
12546 -- with no matching OFF).
12548 if Chars (Argx) = Name_Off then
12549 Set_Specific_Warning_Off
12550 (Loc, Name_Buffer (1 .. Name_Len),
12551 Config => Is_Configuration_Pragma);
12553 elsif Chars (Argx) = Name_On then
12554 Set_Specific_Warning_On
12555 (Loc, Name_Buffer (1 .. Name_Len), Err);
12559 ("?pragma Warnings On with no " &
12560 "matching Warnings Off",
12570 -------------------
12571 -- Weak_External --
12572 -------------------
12574 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
12576 when Pragma_Weak_External => Weak_External : declare
12581 Check_Arg_Count (1);
12582 Check_Optional_Identifier (Arg1, Name_Entity);
12583 Check_Arg_Is_Library_Level_Local_Name (Arg1);
12584 Ent := Entity (Expression (Arg1));
12586 if Rep_Item_Too_Early (Ent, N) then
12589 Ent := Underlying_Type (Ent);
12592 -- The only processing required is to link this item on to the
12593 -- list of rep items for the given entity. This is accomplished
12594 -- by the call to Rep_Item_Too_Late (when no error is detected
12595 -- and False is returned).
12597 if Rep_Item_Too_Late (Ent, N) then
12600 Set_Has_Gigi_Rep_Item (Ent);
12604 -----------------------------
12605 -- Wide_Character_Encoding --
12606 -----------------------------
12608 -- pragma Wide_Character_Encoding (IDENTIFIER);
12610 when Pragma_Wide_Character_Encoding =>
12613 -- Nothing to do, handled in parser. Note that we do not enforce
12614 -- configuration pragma placement, this pragma can appear at any
12615 -- place in the source, allowing mixed encodings within a single
12620 --------------------
12621 -- Unknown_Pragma --
12622 --------------------
12624 -- Should be impossible, since the case of an unknown pragma is
12625 -- separately processed before the case statement is entered.
12627 when Unknown_Pragma =>
12628 raise Program_Error;
12631 -- AI05-0144: detect dangerous order dependence. Disabled for now,
12632 -- until AI is formally approved.
12634 -- Check_Order_Dependence;
12637 when Pragma_Exit => null;
12638 end Analyze_Pragma;
12640 -------------------
12641 -- Check_Enabled --
12642 -------------------
12644 function Check_Enabled (Nam : Name_Id) return Boolean is
12648 PP := Opt.Check_Policy_List;
12651 return Assertions_Enabled;
12654 Nam = Chars (Expression (First (Pragma_Argument_Associations (PP))))
12657 Chars (Expression (Last (Pragma_Argument_Associations (PP))))
12659 when Name_On | Name_Check =>
12661 when Name_Off | Name_Ignore =>
12664 raise Program_Error;
12668 PP := Next_Pragma (PP);
12673 ---------------------------------
12674 -- Delay_Config_Pragma_Analyze --
12675 ---------------------------------
12677 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
12679 return Pragma_Name (N) = Name_Interrupt_State
12681 Pragma_Name (N) = Name_Priority_Specific_Dispatching;
12682 end Delay_Config_Pragma_Analyze;
12684 -------------------------
12685 -- Get_Base_Subprogram --
12686 -------------------------
12688 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
12689 Result : Entity_Id;
12692 -- Follow subprogram renaming chain
12695 while Is_Subprogram (Result)
12697 (Is_Generic_Instance (Result)
12698 or else Nkind (Parent (Declaration_Node (Result))) =
12699 N_Subprogram_Renaming_Declaration)
12700 and then Present (Alias (Result))
12702 Result := Alias (Result);
12706 end Get_Base_Subprogram;
12708 --------------------
12709 -- Get_Pragma_Arg --
12710 --------------------
12712 function Get_Pragma_Arg (Arg : Node_Id) return Node_Id is
12714 if Nkind (Arg) = N_Pragma_Argument_Association then
12715 return Expression (Arg);
12719 end Get_Pragma_Arg;
12725 procedure Initialize is
12730 -----------------------------
12731 -- Is_Config_Static_String --
12732 -----------------------------
12734 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
12736 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
12737 -- This is an internal recursive function that is just like the outer
12738 -- function except that it adds the string to the name buffer rather
12739 -- than placing the string in the name buffer.
12741 ------------------------------
12742 -- Add_Config_Static_String --
12743 ------------------------------
12745 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
12752 if Nkind (N) = N_Op_Concat then
12753 if Add_Config_Static_String (Left_Opnd (N)) then
12754 N := Right_Opnd (N);
12760 if Nkind (N) /= N_String_Literal then
12761 Error_Msg_N ("string literal expected for pragma argument", N);
12765 for J in 1 .. String_Length (Strval (N)) loop
12766 C := Get_String_Char (Strval (N), J);
12768 if not In_Character_Range (C) then
12770 ("string literal contains invalid wide character",
12771 Sloc (N) + 1 + Source_Ptr (J));
12775 Add_Char_To_Name_Buffer (Get_Character (C));
12780 end Add_Config_Static_String;
12782 -- Start of processing for Is_Config_Static_String
12787 return Add_Config_Static_String (Arg);
12788 end Is_Config_Static_String;
12790 -----------------------------------------
12791 -- Is_Non_Significant_Pragma_Reference --
12792 -----------------------------------------
12794 -- This function makes use of the following static table which indicates
12795 -- whether a given pragma is significant.
12797 -- -1 indicates that references in any argument position are significant
12798 -- 0 indicates that appearence in any argument is not significant
12799 -- +n indicates that appearence as argument n is significant, but all
12800 -- other arguments are not significant
12801 -- 99 special processing required (e.g. for pragma Check)
12803 Sig_Flags : constant array (Pragma_Id) of Int :=
12804 (Pragma_AST_Entry => -1,
12805 Pragma_Abort_Defer => -1,
12806 Pragma_Ada_83 => -1,
12807 Pragma_Ada_95 => -1,
12808 Pragma_Ada_05 => -1,
12809 Pragma_Ada_2005 => -1,
12810 Pragma_Ada_12 => -1,
12811 Pragma_Ada_2012 => -1,
12812 Pragma_All_Calls_Remote => -1,
12813 Pragma_Annotate => -1,
12814 Pragma_Assert => -1,
12815 Pragma_Assertion_Policy => 0,
12816 Pragma_Assume_No_Invalid_Values => 0,
12817 Pragma_Asynchronous => -1,
12818 Pragma_Atomic => 0,
12819 Pragma_Atomic_Components => 0,
12820 Pragma_Attach_Handler => -1,
12821 Pragma_Check => 99,
12822 Pragma_Check_Name => 0,
12823 Pragma_Check_Policy => 0,
12824 Pragma_CIL_Constructor => -1,
12825 Pragma_CPP_Class => 0,
12826 Pragma_CPP_Constructor => 0,
12827 Pragma_CPP_Virtual => 0,
12828 Pragma_CPP_Vtable => 0,
12829 Pragma_C_Pass_By_Copy => 0,
12830 Pragma_Comment => 0,
12831 Pragma_Common_Object => -1,
12832 Pragma_Compile_Time_Error => -1,
12833 Pragma_Compile_Time_Warning => -1,
12834 Pragma_Compiler_Unit => 0,
12835 Pragma_Complete_Representation => 0,
12836 Pragma_Complex_Representation => 0,
12837 Pragma_Component_Alignment => -1,
12838 Pragma_Controlled => 0,
12839 Pragma_Convention => 0,
12840 Pragma_Convention_Identifier => 0,
12841 Pragma_Debug => -1,
12842 Pragma_Debug_Policy => 0,
12843 Pragma_Detect_Blocking => -1,
12844 Pragma_Dimension => -1,
12845 Pragma_Discard_Names => 0,
12846 Pragma_Elaborate => -1,
12847 Pragma_Elaborate_All => -1,
12848 Pragma_Elaborate_Body => -1,
12849 Pragma_Elaboration_Checks => -1,
12850 Pragma_Eliminate => -1,
12851 Pragma_Export => -1,
12852 Pragma_Export_Exception => -1,
12853 Pragma_Export_Function => -1,
12854 Pragma_Export_Object => -1,
12855 Pragma_Export_Procedure => -1,
12856 Pragma_Export_Value => -1,
12857 Pragma_Export_Valued_Procedure => -1,
12858 Pragma_Extend_System => -1,
12859 Pragma_Extensions_Allowed => -1,
12860 Pragma_External => -1,
12861 Pragma_Favor_Top_Level => -1,
12862 Pragma_External_Name_Casing => -1,
12863 Pragma_Fast_Math => -1,
12864 Pragma_Finalize_Storage_Only => 0,
12865 Pragma_Float_Representation => 0,
12866 Pragma_Ident => -1,
12867 Pragma_Implemented_By_Entry => -1,
12868 Pragma_Implicit_Packing => 0,
12869 Pragma_Import => +2,
12870 Pragma_Import_Exception => 0,
12871 Pragma_Import_Function => 0,
12872 Pragma_Import_Object => 0,
12873 Pragma_Import_Procedure => 0,
12874 Pragma_Import_Valued_Procedure => 0,
12875 Pragma_Initialize_Scalars => -1,
12876 Pragma_Inline => 0,
12877 Pragma_Inline_Always => 0,
12878 Pragma_Inline_Generic => 0,
12879 Pragma_Inspection_Point => -1,
12880 Pragma_Interface => +2,
12881 Pragma_Interface_Name => +2,
12882 Pragma_Interrupt_Handler => -1,
12883 Pragma_Interrupt_Priority => -1,
12884 Pragma_Interrupt_State => -1,
12885 Pragma_Java_Constructor => -1,
12886 Pragma_Java_Interface => -1,
12887 Pragma_Keep_Names => 0,
12888 Pragma_License => -1,
12889 Pragma_Link_With => -1,
12890 Pragma_Linker_Alias => -1,
12891 Pragma_Linker_Constructor => -1,
12892 Pragma_Linker_Destructor => -1,
12893 Pragma_Linker_Options => -1,
12894 Pragma_Linker_Section => -1,
12896 Pragma_Locking_Policy => -1,
12897 Pragma_Long_Float => -1,
12898 Pragma_Machine_Attribute => -1,
12900 Pragma_Main_Storage => -1,
12901 Pragma_Memory_Size => -1,
12902 Pragma_No_Return => 0,
12903 Pragma_No_Body => 0,
12904 Pragma_No_Run_Time => -1,
12905 Pragma_No_Strict_Aliasing => -1,
12906 Pragma_Normalize_Scalars => -1,
12907 Pragma_Obsolescent => 0,
12908 Pragma_Optimize => -1,
12909 Pragma_Optimize_Alignment => -1,
12910 Pragma_Ordered => 0,
12913 Pragma_Passive => -1,
12914 Pragma_Preelaborable_Initialization => -1,
12915 Pragma_Polling => -1,
12916 Pragma_Persistent_BSS => 0,
12917 Pragma_Postcondition => -1,
12918 Pragma_Precondition => -1,
12919 Pragma_Preelaborate => -1,
12920 Pragma_Preelaborate_05 => -1,
12921 Pragma_Priority => -1,
12922 Pragma_Priority_Specific_Dispatching => -1,
12923 Pragma_Profile => 0,
12924 Pragma_Profile_Warnings => 0,
12925 Pragma_Propagate_Exceptions => -1,
12926 Pragma_Psect_Object => -1,
12928 Pragma_Pure_05 => -1,
12929 Pragma_Pure_Function => -1,
12930 Pragma_Queuing_Policy => -1,
12931 Pragma_Ravenscar => -1,
12932 Pragma_Relative_Deadline => -1,
12933 Pragma_Remote_Call_Interface => -1,
12934 Pragma_Remote_Types => -1,
12935 Pragma_Restricted_Run_Time => -1,
12936 Pragma_Restriction_Warnings => -1,
12937 Pragma_Restrictions => -1,
12938 Pragma_Reviewable => -1,
12939 Pragma_Short_Circuit_And_Or => -1,
12940 Pragma_Share_Generic => -1,
12941 Pragma_Shared => -1,
12942 Pragma_Shared_Passive => -1,
12943 Pragma_Short_Descriptors => 0,
12944 Pragma_Source_File_Name => -1,
12945 Pragma_Source_File_Name_Project => -1,
12946 Pragma_Source_Reference => -1,
12947 Pragma_Storage_Size => -1,
12948 Pragma_Storage_Unit => -1,
12949 Pragma_Static_Elaboration_Desired => -1,
12950 Pragma_Stream_Convert => -1,
12951 Pragma_Style_Checks => -1,
12952 Pragma_Subtitle => -1,
12953 Pragma_Suppress => 0,
12954 Pragma_Suppress_Exception_Locations => 0,
12955 Pragma_Suppress_All => -1,
12956 Pragma_Suppress_Debug_Info => 0,
12957 Pragma_Suppress_Initialization => 0,
12958 Pragma_System_Name => -1,
12959 Pragma_Task_Dispatching_Policy => -1,
12960 Pragma_Task_Info => -1,
12961 Pragma_Task_Name => -1,
12962 Pragma_Task_Storage => 0,
12963 Pragma_Thread_Local_Storage => 0,
12964 Pragma_Time_Slice => -1,
12965 Pragma_Title => -1,
12966 Pragma_Unchecked_Union => 0,
12967 Pragma_Unimplemented_Unit => -1,
12968 Pragma_Universal_Aliasing => -1,
12969 Pragma_Universal_Data => -1,
12970 Pragma_Unmodified => -1,
12971 Pragma_Unreferenced => -1,
12972 Pragma_Unreferenced_Objects => -1,
12973 Pragma_Unreserve_All_Interrupts => -1,
12974 Pragma_Unsuppress => 0,
12975 Pragma_Use_VADS_Size => -1,
12976 Pragma_Validity_Checks => -1,
12977 Pragma_Volatile => 0,
12978 Pragma_Volatile_Components => 0,
12979 Pragma_Warnings => -1,
12980 Pragma_Weak_External => -1,
12981 Pragma_Wide_Character_Encoding => 0,
12982 Unknown_Pragma => 0);
12984 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
12993 if Nkind (P) /= N_Pragma_Argument_Association then
12997 Id := Get_Pragma_Id (Parent (P));
12998 C := Sig_Flags (Id);
13010 -- For pragma Check, the first argument is not significant,
13011 -- the second and the third (if present) arguments are
13014 when Pragma_Check =>
13016 P = First (Pragma_Argument_Associations (Parent (P)));
13019 raise Program_Error;
13023 A := First (Pragma_Argument_Associations (Parent (P)));
13024 for J in 1 .. C - 1 loop
13032 return A = P; -- is this wrong way round ???
13035 end Is_Non_Significant_Pragma_Reference;
13037 ------------------------------
13038 -- Is_Pragma_String_Literal --
13039 ------------------------------
13041 -- This function returns true if the corresponding pragma argument is a
13042 -- static string expression. These are the only cases in which string
13043 -- literals can appear as pragma arguments. We also allow a string literal
13044 -- as the first argument to pragma Assert (although it will of course
13045 -- always generate a type error).
13047 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
13048 Pragn : constant Node_Id := Parent (Par);
13049 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
13050 Pname : constant Name_Id := Pragma_Name (Pragn);
13056 N := First (Assoc);
13063 if Pname = Name_Assert then
13066 elsif Pname = Name_Export then
13069 elsif Pname = Name_Ident then
13072 elsif Pname = Name_Import then
13075 elsif Pname = Name_Interface_Name then
13078 elsif Pname = Name_Linker_Alias then
13081 elsif Pname = Name_Linker_Section then
13084 elsif Pname = Name_Machine_Attribute then
13087 elsif Pname = Name_Source_File_Name then
13090 elsif Pname = Name_Source_Reference then
13093 elsif Pname = Name_Title then
13096 elsif Pname = Name_Subtitle then
13102 end Is_Pragma_String_Literal;
13104 --------------------------------------
13105 -- Process_Compilation_Unit_Pragmas --
13106 --------------------------------------
13108 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
13110 -- A special check for pragma Suppress_All, a very strange DEC pragma,
13111 -- strange because it comes at the end of the unit. If we have a pragma
13112 -- Suppress_All in the Pragmas_After of the current unit, then we insert
13113 -- a pragma Suppress (All_Checks) at the start of the context clause to
13114 -- ensure the correct processing.
13117 PA : constant List_Id := Pragmas_After (Aux_Decls_Node (N));
13121 if Present (PA) then
13123 while Present (P) loop
13124 if Pragma_Name (P) = Name_Suppress_All then
13125 Prepend_To (Context_Items (N),
13126 Make_Pragma (Sloc (P),
13127 Chars => Name_Suppress,
13128 Pragma_Argument_Associations => New_List (
13129 Make_Pragma_Argument_Association (Sloc (P),
13131 Make_Identifier (Sloc (P),
13132 Chars => Name_All_Checks)))));
13140 end Process_Compilation_Unit_Pragmas;
13151 --------------------------------
13152 -- Set_Encoded_Interface_Name --
13153 --------------------------------
13155 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
13156 Str : constant String_Id := Strval (S);
13157 Len : constant Int := String_Length (Str);
13162 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
13165 -- Stores encoded value of character code CC. The encoding we use an
13166 -- underscore followed by four lower case hex digits.
13172 procedure Encode is
13174 Store_String_Char (Get_Char_Code ('_'));
13176 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
13178 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
13180 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
13182 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
13185 -- Start of processing for Set_Encoded_Interface_Name
13188 -- If first character is asterisk, this is a link name, and we leave it
13189 -- completely unmodified. We also ignore null strings (the latter case
13190 -- happens only in error cases) and no encoding should occur for Java or
13191 -- AAMP interface names.
13194 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
13195 or else VM_Target /= No_VM
13196 or else AAMP_On_Target
13198 Set_Interface_Name (E, S);
13203 CC := Get_String_Char (Str, J);
13205 exit when not In_Character_Range (CC);
13207 C := Get_Character (CC);
13209 exit when C /= '_' and then C /= '$'
13210 and then C not in '0' .. '9'
13211 and then C not in 'a' .. 'z'
13212 and then C not in 'A' .. 'Z';
13215 Set_Interface_Name (E, S);
13223 -- Here we need to encode. The encoding we use as follows:
13224 -- three underscores + four hex digits (lower case)
13228 for J in 1 .. String_Length (Str) loop
13229 CC := Get_String_Char (Str, J);
13231 if not In_Character_Range (CC) then
13234 C := Get_Character (CC);
13236 if C = '_' or else C = '$'
13237 or else C in '0' .. '9'
13238 or else C in 'a' .. 'z'
13239 or else C in 'A' .. 'Z'
13241 Store_String_Char (CC);
13248 Set_Interface_Name (E,
13249 Make_String_Literal (Sloc (S),
13250 Strval => End_String));
13252 end Set_Encoded_Interface_Name;
13254 -------------------
13255 -- Set_Unit_Name --
13256 -------------------
13258 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id) is
13263 if Nkind (N) = N_Identifier
13264 and then Nkind (With_Item) = N_Identifier
13266 Set_Entity (N, Entity (With_Item));
13268 elsif Nkind (N) = N_Selected_Component then
13269 Change_Selected_Component_To_Expanded_Name (N);
13270 Set_Entity (N, Entity (With_Item));
13271 Set_Entity (Selector_Name (N), Entity (N));
13273 Pref := Prefix (N);
13274 Scop := Scope (Entity (N));
13275 while Nkind (Pref) = N_Selected_Component loop
13276 Change_Selected_Component_To_Expanded_Name (Pref);
13277 Set_Entity (Selector_Name (Pref), Scop);
13278 Set_Entity (Pref, Scop);
13279 Pref := Prefix (Pref);
13280 Scop := Scope (Scop);
13283 Set_Entity (Pref, Scop);
OSDN Git Service
