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_Ch7; use Exp_Ch7;
41 with Exp_Dist; use Exp_Dist;
43 with Lib.Writ; use Lib.Writ;
44 with Lib.Xref; use Lib.Xref;
45 with Namet.Sp; use Namet.Sp;
46 with Nlists; use Nlists;
47 with Nmake; use Nmake;
49 with Output; use Output;
50 with Par_SCO; use Par_SCO;
51 with Restrict; use Restrict;
52 with Rident; use Rident;
53 with Rtsfind; use Rtsfind;
55 with Sem_Aux; use Sem_Aux;
56 with Sem_Ch3; use Sem_Ch3;
57 with Sem_Ch6; use Sem_Ch6;
58 with Sem_Ch8; use Sem_Ch8;
59 with Sem_Ch12; use Sem_Ch12;
60 with Sem_Ch13; use Sem_Ch13;
61 with Sem_Disp; use Sem_Disp;
62 with Sem_Dist; use Sem_Dist;
63 with Sem_Elim; use Sem_Elim;
64 with Sem_Eval; use Sem_Eval;
65 with Sem_Intr; use Sem_Intr;
66 with Sem_Mech; use Sem_Mech;
67 with Sem_Res; use Sem_Res;
68 with Sem_Type; use Sem_Type;
69 with Sem_Util; use Sem_Util;
70 with Sem_VFpt; use Sem_VFpt;
71 with Sem_Warn; use Sem_Warn;
72 with Stand; use Stand;
73 with Sinfo; use Sinfo;
74 with Sinfo.CN; use Sinfo.CN;
75 with Sinput; use Sinput;
76 with Snames; use Snames;
77 with Stringt; use Stringt;
78 with Stylesw; use Stylesw;
80 with Targparm; use Targparm;
81 with Tbuild; use Tbuild;
83 with Uintp; use Uintp;
84 with Uname; use Uname;
85 with Urealp; use Urealp;
86 with Validsw; use Validsw;
88 package body Sem_Prag is
90 ----------------------------------------------
91 -- Common Handling of Import-Export Pragmas --
92 ----------------------------------------------
94 -- In the following section, a number of Import_xxx and Export_xxx pragmas
95 -- are defined by GNAT. These are compatible with the DEC pragmas of the
96 -- same name, and all have the following common form and processing:
99 -- [Internal =>] LOCAL_NAME
100 -- [, [External =>] EXTERNAL_SYMBOL]
101 -- [, other optional parameters ]);
104 -- [Internal =>] LOCAL_NAME
105 -- [, [External =>] EXTERNAL_SYMBOL]
106 -- [, other optional parameters ]);
108 -- EXTERNAL_SYMBOL ::=
110 -- | static_string_EXPRESSION
112 -- The internal LOCAL_NAME designates the entity that is imported or
113 -- exported, and must refer to an entity in the current declarative
114 -- part (as required by the rules for LOCAL_NAME).
116 -- The external linker name is designated by the External parameter if
117 -- given, or the Internal parameter if not (if there is no External
118 -- parameter, the External parameter is a copy of the Internal name).
120 -- If the External parameter is given as a string, then this string is
121 -- treated as an external name (exactly as though it had been given as an
122 -- External_Name parameter for a normal Import pragma).
124 -- If the External parameter is given as an identifier (or there is no
125 -- External parameter, so that the Internal identifier is used), then
126 -- the external name is the characters of the identifier, translated
127 -- to all upper case letters for OpenVMS versions of GNAT, and to all
128 -- lower case letters for all other versions
130 -- Note: the external name specified or implied by any of these special
131 -- Import_xxx or Export_xxx pragmas override an external or link name
132 -- specified in a previous Import or Export pragma.
134 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
135 -- named notation, following the standard rules for subprogram calls, i.e.
136 -- parameters can be given in any order if named notation is used, and
137 -- positional and named notation can be mixed, subject to the rule that all
138 -- positional parameters must appear first.
140 -- Note: All these pragmas are implemented exactly following the DEC design
141 -- and implementation and are intended to be fully compatible with the use
142 -- of these pragmas in the DEC Ada compiler.
144 --------------------------------------------
145 -- Checking for Duplicated External Names --
146 --------------------------------------------
148 -- It is suspicious if two separate Export pragmas use the same external
149 -- name. The following table is used to diagnose this situation so that
150 -- an appropriate warning can be issued.
152 -- The Node_Id stored is for the N_String_Literal node created to hold
153 -- the value of the external name. The Sloc of this node is used to
154 -- cross-reference the location of the duplication.
156 package Externals is new Table.Table (
157 Table_Component_Type => Node_Id,
158 Table_Index_Type => Int,
159 Table_Low_Bound => 0,
160 Table_Initial => 100,
161 Table_Increment => 100,
162 Table_Name => "Name_Externals");
164 -------------------------------------
165 -- Local Subprograms and Variables --
166 -------------------------------------
168 function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
169 -- This routine is used for possible casing adjustment of an explicit
170 -- external name supplied as a string literal (the node N), according to
171 -- the casing requirement of Opt.External_Name_Casing. If this is set to
172 -- As_Is, then the string literal is returned unchanged, but if it is set
173 -- to Uppercase or Lowercase, then a new string literal with appropriate
174 -- casing is constructed.
176 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
177 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
178 -- original one, following the renaming chain) is returned. Otherwise the
179 -- entity is returned unchanged. Should be in Einfo???
182 -- This is a dummy function called by the processing for pragma Reviewable.
183 -- It is there for assisting front end debugging. By placing a Reviewable
184 -- pragma in the source program, a breakpoint on rv catches this place in
185 -- the source, allowing convenient stepping to the point of interest.
187 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id);
188 -- Place semantic information on the argument of an Elaborate/Elaborate_All
189 -- pragma. Entity name for unit and its parents is taken from item in
190 -- previous with_clause that mentions the unit.
192 -------------------------------
193 -- Adjust_External_Name_Case --
194 -------------------------------
196 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
200 -- Adjust case of literal if required
202 if Opt.External_Name_Exp_Casing = As_Is then
206 -- Copy existing string
212 for J in 1 .. String_Length (Strval (N)) loop
213 CC := Get_String_Char (Strval (N), J);
215 if Opt.External_Name_Exp_Casing = Uppercase
216 and then CC >= Get_Char_Code ('a')
217 and then CC <= Get_Char_Code ('z')
219 Store_String_Char (CC - 32);
221 elsif Opt.External_Name_Exp_Casing = Lowercase
222 and then CC >= Get_Char_Code ('A')
223 and then CC <= Get_Char_Code ('Z')
225 Store_String_Char (CC + 32);
228 Store_String_Char (CC);
233 Make_String_Literal (Sloc (N),
234 Strval => End_String);
236 end Adjust_External_Name_Case;
238 ------------------------------
239 -- Analyze_PPC_In_Decl_Part --
240 ------------------------------
242 procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id) is
243 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
246 -- Install formals and push subprogram spec onto scope stack so that we
247 -- can see the formals from the pragma.
252 -- Preanalyze the boolean expression, we treat this as a spec expression
253 -- (i.e. similar to a default expression).
255 Preanalyze_Spec_Expression
256 (Get_Pragma_Arg (Arg1), Standard_Boolean);
258 -- Remove the subprogram from the scope stack now that the pre-analysis
259 -- of the precondition/postcondition is done.
262 end Analyze_PPC_In_Decl_Part;
268 procedure Analyze_Pragma (N : Node_Id) is
269 Loc : constant Source_Ptr := Sloc (N);
270 Pname : constant Name_Id := Pragma_Name (N);
273 Sense : constant Boolean := not Aspect_Cancel (N);
274 -- Sense is True if we have the normal case of a pragma that is active
275 -- and turns the corresponding aspect on. It is false only for the case
276 -- of a pragma coming from an aspect which is explicitly turned off by
277 -- using aspect => False. If Sense is False, the effect of the pragma
278 -- is to turn the corresponding aspect off.
280 Pragma_Exit : exception;
281 -- This exception is used to exit pragma processing completely. It is
282 -- used when an error is detected, and no further processing is
283 -- required. It is also used if an earlier error has left the tree in
284 -- a state where the pragma should not be processed.
287 -- Number of pragma argument associations
293 -- First four pragma arguments (pragma argument association nodes, or
294 -- Empty if the corresponding argument does not exist).
296 type Name_List is array (Natural range <>) of Name_Id;
297 type Args_List is array (Natural range <>) of Node_Id;
298 -- Types used for arguments to Check_Arg_Order and Gather_Associations
300 procedure Ada_2005_Pragma;
301 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
302 -- Ada 95 mode, these are implementation defined pragmas, so should be
303 -- caught by the No_Implementation_Pragmas restriction.
305 procedure Ada_2012_Pragma;
306 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
307 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
308 -- should be caught by the No_Implementation_Pragmas restriction.
310 procedure Check_Ada_83_Warning;
311 -- Issues a warning message for the current pragma if operating in Ada
312 -- 83 mode (used for language pragmas that are not a standard part of
313 -- Ada 83). This procedure does not raise Error_Pragma. Also notes use
316 procedure Check_Arg_Count (Required : Nat);
317 -- Check argument count for pragma is equal to given parameter. If not,
318 -- then issue an error message and raise Pragma_Exit.
320 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
321 -- Arg which can either be a pragma argument association, in which case
322 -- the check is applied to the expression of the association or an
323 -- expression directly.
325 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
326 -- Check that an argument has the right form for an EXTERNAL_NAME
327 -- parameter of an extended import/export pragma. The rule is that the
328 -- name must be an identifier or string literal (in Ada 83 mode) or a
329 -- static string expression (in Ada 95 mode).
331 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
332 -- Check the specified argument Arg to make sure that it is an
333 -- identifier. If not give error and raise Pragma_Exit.
335 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
336 -- Check the specified argument Arg to make sure that it is an integer
337 -- literal. If not give error and raise Pragma_Exit.
339 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
340 -- Check the specified argument Arg to make sure that it has the proper
341 -- syntactic form for a local name and meets the semantic requirements
342 -- for a local name. The local name is analyzed as part of the
343 -- processing for this call. In addition, the local name is required
344 -- to represent an entity at the library level.
346 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
347 -- Check the specified argument Arg to make sure that it has the proper
348 -- syntactic form for a local name and meets the semantic requirements
349 -- for a local name. The local name is analyzed as part of the
350 -- processing for this call.
352 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
353 -- Check the specified argument Arg to make sure that it is a valid
354 -- locking policy name. If not give error and raise Pragma_Exit.
356 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
357 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2, N3 : Name_Id);
358 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2, N3, N4 : Name_Id);
359 -- Check the specified argument Arg to make sure that it is an
360 -- identifier whose name matches either N1 or N2 (or N3 if present).
361 -- If not then give error and raise Pragma_Exit.
363 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
364 -- Check the specified argument Arg to make sure that it is a valid
365 -- queuing policy name. If not give error and raise Pragma_Exit.
367 procedure Check_Arg_Is_Static_Expression
369 Typ : Entity_Id := Empty);
370 -- Check the specified argument Arg to make sure that it is a static
371 -- expression of the given type (i.e. it will be analyzed and resolved
372 -- using this type, which can be any valid argument to Resolve, e.g.
373 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
374 -- Typ is left Empty, then any static expression is allowed.
376 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
377 -- Check the specified argument Arg to make sure that it is a valid task
378 -- dispatching policy name. If not give error and raise Pragma_Exit.
380 procedure Check_Arg_Order (Names : Name_List);
381 -- Checks for an instance of two arguments with identifiers for the
382 -- current pragma which are not in the sequence indicated by Names,
383 -- and if so, generates a fatal message about bad order of arguments.
385 procedure Check_At_Least_N_Arguments (N : Nat);
386 -- Check there are at least N arguments present
388 procedure Check_At_Most_N_Arguments (N : Nat);
389 -- Check there are no more than N arguments present
391 procedure Check_Component
394 In_Variant_Part : Boolean := False);
395 -- Examine an Unchecked_Union component for correct use of per-object
396 -- constrained subtypes, and for restrictions on finalizable components.
397 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
398 -- should be set when Comp comes from a record variant.
400 procedure Check_Duplicate_Pragma (E : Entity_Id);
401 -- Check if a pragma of the same name as the current pragma is already
402 -- chained as a rep pragma to the given entity. If so give a message
403 -- about the duplicate, and then raise Pragma_Exit so does not return.
404 -- Also checks for delayed aspect specification node in the chain.
406 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
407 -- Nam is an N_String_Literal node containing the external name set by
408 -- an Import or Export pragma (or extended Import or Export pragma).
409 -- This procedure checks for possible duplications if this is the export
410 -- case, and if found, issues an appropriate error message.
412 procedure Check_First_Subtype (Arg : Node_Id);
413 -- Checks that Arg, whose expression is an entity name referencing a
414 -- subtype, does not reference a type that is not a first subtype.
416 procedure Check_In_Main_Program;
417 -- Common checks for pragmas that appear within a main program
418 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
420 procedure Check_Interrupt_Or_Attach_Handler;
421 -- Common processing for first argument of pragma Interrupt_Handler or
422 -- pragma Attach_Handler.
424 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
425 -- Check that pragma appears in a declarative part, or in a package
426 -- specification, i.e. that it does not occur in a statement sequence
429 procedure Check_No_Identifier (Arg : Node_Id);
430 -- Checks that the given argument does not have an identifier. If
431 -- an identifier is present, then an error message is issued, and
432 -- Pragma_Exit is raised.
434 procedure Check_No_Identifiers;
435 -- Checks that none of the arguments to the pragma has an identifier.
436 -- If any argument has an identifier, then an error message is issued,
437 -- and Pragma_Exit is raised.
439 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
440 -- Checks if the given argument has an identifier, and if so, requires
441 -- it to match the given identifier name. If there is a non-matching
442 -- identifier, then an error message is given and Error_Pragmas raised.
444 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
445 -- Checks if the given argument has an identifier, and if so, requires
446 -- it to match the given identifier name. If there is a non-matching
447 -- identifier, then an error message is given and Error_Pragmas raised.
448 -- In this version of the procedure, the identifier name is given as
449 -- a string with lower case letters.
451 procedure Check_Precondition_Postcondition (In_Body : out Boolean);
452 -- Called to process a precondition or postcondition pragma. There are
455 -- The pragma appears after a subprogram spec
457 -- If the corresponding check is not enabled, the pragma is analyzed
458 -- but otherwise ignored and control returns with In_Body set False.
460 -- If the check is enabled, then the first step is to analyze the
461 -- pragma, but this is skipped if the subprogram spec appears within
462 -- a package specification (because this is the case where we delay
463 -- analysis till the end of the spec). Then (whether or not it was
464 -- analyzed), the pragma is chained to the subprogram in question
465 -- (using Spec_PPC_List and Next_Pragma) and control returns to the
466 -- caller with In_Body set False.
468 -- The pragma appears at the start of subprogram body declarations
470 -- In this case an immediate return to the caller is made with
471 -- In_Body set True, and the pragma is NOT analyzed.
473 -- In all other cases, an error message for bad placement is given
475 procedure Check_Static_Constraint (Constr : Node_Id);
476 -- Constr is a constraint from an N_Subtype_Indication node from a
477 -- component constraint in an Unchecked_Union type. This routine checks
478 -- that the constraint is static as required by the restrictions for
481 procedure Check_Valid_Configuration_Pragma;
482 -- Legality checks for placement of a configuration pragma
484 procedure Check_Valid_Library_Unit_Pragma;
485 -- Legality checks for library unit pragmas. A special case arises for
486 -- pragmas in generic instances that come from copies of the original
487 -- library unit pragmas in the generic templates. In the case of other
488 -- than library level instantiations these can appear in contexts which
489 -- would normally be invalid (they only apply to the original template
490 -- and to library level instantiations), and they are simply ignored,
491 -- which is implemented by rewriting them as null statements.
493 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
494 -- Check an Unchecked_Union variant for lack of nested variants and
495 -- presence of at least one component. UU_Typ is the related Unchecked_
498 procedure Error_Pragma (Msg : String);
499 pragma No_Return (Error_Pragma);
500 -- Outputs error message for current pragma. The message contains a %
501 -- that will be replaced with the pragma name, and the flag is placed
502 -- on the pragma itself. Pragma_Exit is then raised.
504 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
505 pragma No_Return (Error_Pragma_Arg);
506 -- Outputs error message for current pragma. The message may contain
507 -- a % that will be replaced with the pragma name. The parameter Arg
508 -- may either be a pragma argument association, in which case the flag
509 -- is placed on the expression of this association, or an expression,
510 -- in which case the flag is placed directly on the expression. The
511 -- message is placed using Error_Msg_N, so the message may also contain
512 -- an & insertion character which will reference the given Arg value.
513 -- After placing the message, Pragma_Exit is raised.
515 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
516 pragma No_Return (Error_Pragma_Arg);
517 -- Similar to above form of Error_Pragma_Arg except that two messages
518 -- are provided, the second is a continuation comment starting with \.
520 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
521 pragma No_Return (Error_Pragma_Arg_Ident);
522 -- Outputs error message for current pragma. The message may contain
523 -- a % that will be replaced with the pragma name. The parameter Arg
524 -- must be a pragma argument association with a non-empty identifier
525 -- (i.e. its Chars field must be set), and the error message is placed
526 -- on the identifier. The message is placed using Error_Msg_N so
527 -- the message may also contain an & insertion character which will
528 -- reference the identifier. After placing the message, Pragma_Exit
531 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
532 pragma No_Return (Error_Pragma_Ref);
533 -- Outputs error message for current pragma. The message may contain
534 -- a % that will be replaced with the pragma name. The parameter Ref
535 -- must be an entity whose name can be referenced by & and sloc by #.
536 -- After placing the message, Pragma_Exit is raised.
538 function Find_Lib_Unit_Name return Entity_Id;
539 -- Used for a library unit pragma to find the entity to which the
540 -- library unit pragma applies, returns the entity found.
542 procedure Find_Program_Unit_Name (Id : Node_Id);
543 -- If the pragma is a compilation unit pragma, the id must denote the
544 -- compilation unit in the same compilation, and the pragma must appear
545 -- in the list of preceding or trailing pragmas. If it is a program
546 -- unit pragma that is not a compilation unit pragma, then the
547 -- identifier must be visible.
549 function Find_Unique_Parameterless_Procedure
551 Arg : Node_Id) return Entity_Id;
552 -- Used for a procedure pragma to find the unique parameterless
553 -- procedure identified by Name, returns it if it exists, otherwise
554 -- errors out and uses Arg as the pragma argument for the message.
556 procedure Fix_Error (Msg : in out String);
557 -- This is called prior to issuing an error message. Msg is a string
558 -- which typically contains the substring pragma. If the current pragma
559 -- comes from an aspect, each such "pragma" substring is replaced with
560 -- the characters "aspect", and if Error_Msg_Name_1 is Name_Precondition
561 -- (resp Name_Postcondition) it is changed to Name_Pre (resp Name_Post).
563 procedure Gather_Associations
565 Args : out Args_List);
566 -- This procedure is used to gather the arguments for a pragma that
567 -- permits arbitrary ordering of parameters using the normal rules
568 -- for named and positional parameters. The Names argument is a list
569 -- of Name_Id values that corresponds to the allowed pragma argument
570 -- association identifiers in order. The result returned in Args is
571 -- a list of corresponding expressions that are the pragma arguments.
572 -- Note that this is a list of expressions, not of pragma argument
573 -- associations (Gather_Associations has completely checked all the
574 -- optional identifiers when it returns). An entry in Args is Empty
575 -- on return if the corresponding argument is not present.
577 procedure GNAT_Pragma;
578 -- Called for all GNAT defined pragmas to check the relevant restriction
579 -- (No_Implementation_Pragmas).
581 function Is_Before_First_Decl
582 (Pragma_Node : Node_Id;
583 Decls : List_Id) return Boolean;
584 -- Return True if Pragma_Node is before the first declarative item in
585 -- Decls where Decls is the list of declarative items.
587 function Is_Configuration_Pragma return Boolean;
588 -- Determines if the placement of the current pragma is appropriate
589 -- for a configuration pragma.
591 function Is_In_Context_Clause return Boolean;
592 -- Returns True if pragma appears within the context clause of a unit,
593 -- and False for any other placement (does not generate any messages).
595 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
596 -- Analyzes the argument, and determines if it is a static string
597 -- expression, returns True if so, False if non-static or not String.
599 procedure Pragma_Misplaced;
600 pragma No_Return (Pragma_Misplaced);
601 -- Issue fatal error message for misplaced pragma
603 procedure Process_Atomic_Shared_Volatile;
604 -- Common processing for pragmas Atomic, Shared, Volatile. Note that
605 -- Shared is an obsolete Ada 83 pragma, treated as being identical
606 -- in effect to pragma Atomic.
608 procedure Process_Compile_Time_Warning_Or_Error;
609 -- Common processing for Compile_Time_Error and Compile_Time_Warning
611 procedure Process_Convention
612 (C : out Convention_Id;
613 Ent : out Entity_Id);
614 -- Common processing for Convention, Interface, Import and Export.
615 -- Checks first two arguments of pragma, and sets the appropriate
616 -- convention value in the specified entity or entities. On return
617 -- C is the convention, Ent is the referenced entity.
619 procedure Process_Extended_Import_Export_Exception_Pragma
620 (Arg_Internal : Node_Id;
621 Arg_External : Node_Id;
624 -- Common processing for the pragmas Import/Export_Exception. The three
625 -- arguments correspond to the three named parameters of the pragma. An
626 -- argument is empty if the corresponding parameter is not present in
629 procedure Process_Extended_Import_Export_Object_Pragma
630 (Arg_Internal : Node_Id;
631 Arg_External : Node_Id;
633 -- Common processing for the pragmas Import/Export_Object. The three
634 -- arguments correspond to the three named parameters of the pragmas. An
635 -- argument is empty if the corresponding parameter is not present in
638 procedure Process_Extended_Import_Export_Internal_Arg
639 (Arg_Internal : Node_Id := Empty);
640 -- Common processing for all extended Import and Export pragmas. The
641 -- argument is the pragma parameter for the Internal argument. If
642 -- Arg_Internal is empty or inappropriate, an error message is posted.
643 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
644 -- set to identify the referenced entity.
646 procedure Process_Extended_Import_Export_Subprogram_Pragma
647 (Arg_Internal : Node_Id;
648 Arg_External : Node_Id;
649 Arg_Parameter_Types : Node_Id;
650 Arg_Result_Type : Node_Id := Empty;
651 Arg_Mechanism : Node_Id;
652 Arg_Result_Mechanism : Node_Id := Empty;
653 Arg_First_Optional_Parameter : Node_Id := Empty);
654 -- Common processing for all extended Import and Export pragmas applying
655 -- to subprograms. The caller omits any arguments that do not apply to
656 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
657 -- only in the Import_Function and Export_Function cases). The argument
658 -- names correspond to the allowed pragma association identifiers.
660 procedure Process_Generic_List;
661 -- Common processing for Share_Generic and Inline_Generic
663 procedure Process_Import_Or_Interface;
664 -- Common processing for Import of Interface
666 procedure Process_Inline (Active : Boolean);
667 -- Common processing for Inline and Inline_Always. The parameter
668 -- indicates if the inline pragma is active, i.e. if it should actually
669 -- cause inlining to occur.
671 procedure Process_Interface_Name
672 (Subprogram_Def : Entity_Id;
675 -- Given the last two arguments of pragma Import, pragma Export, or
676 -- pragma Interface_Name, performs validity checks and sets the
677 -- Interface_Name field of the given subprogram entity to the
678 -- appropriate external or link name, depending on the arguments given.
679 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
680 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
681 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
682 -- nor Link_Arg is present, the interface name is set to the default
683 -- from the subprogram name.
685 procedure Process_Interrupt_Or_Attach_Handler;
686 -- Common processing for Interrupt and Attach_Handler pragmas
688 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
689 -- Common processing for Restrictions and Restriction_Warnings pragmas.
690 -- Warn is True for Restriction_Warnings, or for Restrictions if the
691 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
692 -- is not set in the Restrictions case.
694 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
695 -- Common processing for Suppress and Unsuppress. The boolean parameter
696 -- Suppress_Case is True for the Suppress case, and False for the
699 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
700 -- This procedure sets the Is_Exported flag for the given entity,
701 -- checking that the entity was not previously imported. Arg is
702 -- the argument that specified the entity. A check is also made
703 -- for exporting inappropriate entities.
705 procedure Set_Extended_Import_Export_External_Name
706 (Internal_Ent : Entity_Id;
707 Arg_External : Node_Id);
708 -- Common processing for all extended import export pragmas. The first
709 -- argument, Internal_Ent, is the internal entity, which has already
710 -- been checked for validity by the caller. Arg_External is from the
711 -- Import or Export pragma, and may be null if no External parameter
712 -- was present. If Arg_External is present and is a non-null string
713 -- (a null string is treated as the default), then the Interface_Name
714 -- field of Internal_Ent is set appropriately.
716 procedure Set_Imported (E : Entity_Id);
717 -- This procedure sets the Is_Imported flag for the given entity,
718 -- checking that it is not previously exported or imported.
720 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
721 -- Mech is a parameter passing mechanism (see Import_Function syntax
722 -- for MECHANISM_NAME). This routine checks that the mechanism argument
723 -- has the right form, and if not issues an error message. If the
724 -- argument has the right form then the Mechanism field of Ent is
725 -- set appropriately.
727 procedure Set_Ravenscar_Profile (N : Node_Id);
728 -- Activate the set of configuration pragmas and restrictions that make
729 -- up the Ravenscar Profile. N is the corresponding pragma node, which
730 -- is used for error messages on any constructs that violate the
733 ---------------------
734 -- Ada_2005_Pragma --
735 ---------------------
737 procedure Ada_2005_Pragma is
739 if Ada_Version <= Ada_95 then
740 Check_Restriction (No_Implementation_Pragmas, N);
744 ---------------------
745 -- Ada_2012_Pragma --
746 ---------------------
748 procedure Ada_2012_Pragma is
750 if Ada_Version <= Ada_2005 then
751 Check_Restriction (No_Implementation_Pragmas, N);
755 --------------------------
756 -- Check_Ada_83_Warning --
757 --------------------------
759 procedure Check_Ada_83_Warning is
761 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
762 Error_Msg_N ("(Ada 83) pragma& is non-standard?", N);
764 end Check_Ada_83_Warning;
766 ---------------------
767 -- Check_Arg_Count --
768 ---------------------
770 procedure Check_Arg_Count (Required : Nat) is
772 if Arg_Count /= Required then
773 Error_Pragma ("wrong number of arguments for pragma%");
777 --------------------------------
778 -- Check_Arg_Is_External_Name --
779 --------------------------------
781 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
782 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
785 if Nkind (Argx) = N_Identifier then
789 Analyze_And_Resolve (Argx, Standard_String);
791 if Is_OK_Static_Expression (Argx) then
794 elsif Etype (Argx) = Any_Type then
797 -- An interesting special case, if we have a string literal and
798 -- we are in Ada 83 mode, then we allow it even though it will
799 -- not be flagged as static. This allows expected Ada 83 mode
800 -- use of external names which are string literals, even though
801 -- technically these are not static in Ada 83.
803 elsif Ada_Version = Ada_83
804 and then Nkind (Argx) = N_String_Literal
808 -- Static expression that raises Constraint_Error. This has
809 -- already been flagged, so just exit from pragma processing.
811 elsif Is_Static_Expression (Argx) then
814 -- Here we have a real error (non-static expression)
817 Error_Msg_Name_1 := Pname;
821 "argument for pragma% must be a identifier or "
822 & "static string expression!";
825 Flag_Non_Static_Expr (Msg, Argx);
830 end Check_Arg_Is_External_Name;
832 -----------------------------
833 -- Check_Arg_Is_Identifier --
834 -----------------------------
836 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
837 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
839 if Nkind (Argx) /= N_Identifier then
841 ("argument for pragma% must be identifier", Argx);
843 end Check_Arg_Is_Identifier;
845 ----------------------------------
846 -- Check_Arg_Is_Integer_Literal --
847 ----------------------------------
849 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
850 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
852 if Nkind (Argx) /= N_Integer_Literal then
854 ("argument for pragma% must be integer literal", Argx);
856 end Check_Arg_Is_Integer_Literal;
858 -------------------------------------------
859 -- Check_Arg_Is_Library_Level_Local_Name --
860 -------------------------------------------
864 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
865 -- | library_unit_NAME
867 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
869 Check_Arg_Is_Local_Name (Arg);
871 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
872 and then Comes_From_Source (N)
875 ("argument for pragma% must be library level entity", Arg);
877 end Check_Arg_Is_Library_Level_Local_Name;
879 -----------------------------
880 -- Check_Arg_Is_Local_Name --
881 -----------------------------
885 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
886 -- | library_unit_NAME
888 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
889 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
894 if Nkind (Argx) not in N_Direct_Name
895 and then (Nkind (Argx) /= N_Attribute_Reference
896 or else Present (Expressions (Argx))
897 or else Nkind (Prefix (Argx)) /= N_Identifier)
898 and then (not Is_Entity_Name (Argx)
899 or else not Is_Compilation_Unit (Entity (Argx)))
901 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
904 if Is_Entity_Name (Argx)
905 and then Scope (Entity (Argx)) /= Current_Scope
908 ("pragma% argument must be in same declarative part", Arg);
910 end Check_Arg_Is_Local_Name;
912 ---------------------------------
913 -- Check_Arg_Is_Locking_Policy --
914 ---------------------------------
916 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
917 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
920 Check_Arg_Is_Identifier (Argx);
922 if not Is_Locking_Policy_Name (Chars (Argx)) then
924 ("& is not a valid locking policy name", Argx);
926 end Check_Arg_Is_Locking_Policy;
928 -------------------------
929 -- Check_Arg_Is_One_Of --
930 -------------------------
932 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
933 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
936 Check_Arg_Is_Identifier (Argx);
938 if Chars (Argx) /= N1 and then Chars (Argx) /= N2 then
939 Error_Msg_Name_2 := N1;
940 Error_Msg_Name_3 := N2;
941 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
943 end Check_Arg_Is_One_Of;
945 procedure Check_Arg_Is_One_Of
947 N1, N2, N3 : Name_Id)
949 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
952 Check_Arg_Is_Identifier (Argx);
954 if Chars (Argx) /= N1
955 and then Chars (Argx) /= N2
956 and then Chars (Argx) /= N3
958 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
960 end Check_Arg_Is_One_Of;
962 procedure Check_Arg_Is_One_Of
964 N1, N2, N3, N4 : Name_Id)
966 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
969 Check_Arg_Is_Identifier (Argx);
971 if Chars (Argx) /= N1
972 and then Chars (Argx) /= N2
973 and then Chars (Argx) /= N3
974 and then Chars (Argx) /= N4
976 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
978 end Check_Arg_Is_One_Of;
980 ---------------------------------
981 -- Check_Arg_Is_Queuing_Policy --
982 ---------------------------------
984 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
985 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
988 Check_Arg_Is_Identifier (Argx);
990 if not Is_Queuing_Policy_Name (Chars (Argx)) then
992 ("& is not a valid queuing policy name", Argx);
994 end Check_Arg_Is_Queuing_Policy;
996 ------------------------------------
997 -- Check_Arg_Is_Static_Expression --
998 ------------------------------------
1000 procedure Check_Arg_Is_Static_Expression
1002 Typ : Entity_Id := Empty)
1004 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1007 if Present (Typ) then
1008 Analyze_And_Resolve (Argx, Typ);
1010 Analyze_And_Resolve (Argx);
1013 if Is_OK_Static_Expression (Argx) then
1016 elsif Etype (Argx) = Any_Type then
1019 -- An interesting special case, if we have a string literal and we
1020 -- are in Ada 83 mode, then we allow it even though it will not be
1021 -- flagged as static. This allows the use of Ada 95 pragmas like
1022 -- Import in Ada 83 mode. They will of course be flagged with
1023 -- warnings as usual, but will not cause errors.
1025 elsif Ada_Version = Ada_83
1026 and then Nkind (Argx) = N_String_Literal
1030 -- Static expression that raises Constraint_Error. This has already
1031 -- been flagged, so just exit from pragma processing.
1033 elsif Is_Static_Expression (Argx) then
1036 -- Finally, we have a real error
1039 Error_Msg_Name_1 := Pname;
1043 "argument for pragma% must be a static expression!";
1046 Flag_Non_Static_Expr (Msg, Argx);
1051 end Check_Arg_Is_Static_Expression;
1053 ------------------------------------------
1054 -- Check_Arg_Is_Task_Dispatching_Policy --
1055 ------------------------------------------
1057 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
1058 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1061 Check_Arg_Is_Identifier (Argx);
1063 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
1065 ("& is not a valid task dispatching policy name", Argx);
1067 end Check_Arg_Is_Task_Dispatching_Policy;
1069 ---------------------
1070 -- Check_Arg_Order --
1071 ---------------------
1073 procedure Check_Arg_Order (Names : Name_List) is
1076 Highest_So_Far : Natural := 0;
1077 -- Highest index in Names seen do far
1081 for J in 1 .. Arg_Count loop
1082 if Chars (Arg) /= No_Name then
1083 for K in Names'Range loop
1084 if Chars (Arg) = Names (K) then
1085 if K < Highest_So_Far then
1086 Error_Msg_Name_1 := Pname;
1088 ("parameters out of order for pragma%", Arg);
1089 Error_Msg_Name_1 := Names (K);
1090 Error_Msg_Name_2 := Names (Highest_So_Far);
1091 Error_Msg_N ("\% must appear before %", Arg);
1095 Highest_So_Far := K;
1103 end Check_Arg_Order;
1105 --------------------------------
1106 -- Check_At_Least_N_Arguments --
1107 --------------------------------
1109 procedure Check_At_Least_N_Arguments (N : Nat) is
1111 if Arg_Count < N then
1112 Error_Pragma ("too few arguments for pragma%");
1114 end Check_At_Least_N_Arguments;
1116 -------------------------------
1117 -- Check_At_Most_N_Arguments --
1118 -------------------------------
1120 procedure Check_At_Most_N_Arguments (N : Nat) is
1123 if Arg_Count > N then
1125 for J in 1 .. N loop
1127 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
1130 end Check_At_Most_N_Arguments;
1132 ---------------------
1133 -- Check_Component --
1134 ---------------------
1136 procedure Check_Component
1139 In_Variant_Part : Boolean := False)
1141 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
1142 Sindic : constant Node_Id :=
1143 Subtype_Indication (Component_Definition (Comp));
1144 Typ : constant Entity_Id := Etype (Comp_Id);
1146 function Inside_Generic_Body (Id : Entity_Id) return Boolean;
1147 -- Determine whether entity Id appears inside a generic body
1149 -------------------------
1150 -- Inside_Generic_Body --
1151 -------------------------
1153 function Inside_Generic_Body (Id : Entity_Id) return Boolean is
1154 S : Entity_Id := Id;
1158 and then S /= Standard_Standard
1160 if Ekind (S) = E_Generic_Package
1161 and then In_Package_Body (S)
1170 end Inside_Generic_Body;
1172 -- Start of processing for Check_Component
1175 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
1176 -- object constraint, then the component type shall be an Unchecked_
1179 if Nkind (Sindic) = N_Subtype_Indication
1180 and then Has_Per_Object_Constraint (Comp_Id)
1181 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
1184 ("component subtype subject to per-object constraint " &
1185 "must be an Unchecked_Union", Comp);
1187 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
1188 -- the body of a generic unit, or within the body of any of its
1189 -- descendant library units, no part of the type of a component
1190 -- declared in a variant_part of the unchecked union type shall be of
1191 -- a formal private type or formal private extension declared within
1192 -- the formal part of the generic unit.
1194 elsif Ada_Version >= Ada_2012
1195 and then Inside_Generic_Body (UU_Typ)
1196 and then In_Variant_Part
1197 and then Is_Private_Type (Typ)
1198 and then Is_Generic_Type (Typ)
1201 ("component of Unchecked_Union cannot be of generic type", Comp);
1203 elsif Needs_Finalization (Typ) then
1205 ("component of Unchecked_Union cannot be controlled", Comp);
1207 elsif Has_Task (Typ) then
1209 ("component of Unchecked_Union cannot have tasks", Comp);
1211 end Check_Component;
1213 ----------------------------
1214 -- Check_Duplicate_Pragma --
1215 ----------------------------
1217 procedure Check_Duplicate_Pragma (E : Entity_Id) is
1221 -- Nothing to do if this pragma comes from an aspect specification,
1222 -- since we could not be duplicating a pragma, and we dealt with the
1223 -- case of duplicated aspects in Analyze_Aspect_Specifications.
1225 if From_Aspect_Specification (N) then
1229 -- Otherwise current pragma may duplicate previous pragma or a
1230 -- previously given aspect specification for the same pragma.
1232 P := Get_Rep_Item_For_Entity (E, Pragma_Name (N));
1235 Error_Msg_Name_1 := Pragma_Name (N);
1236 Error_Msg_Sloc := Sloc (P);
1238 if Nkind (P) = N_Aspect_Specification
1239 or else From_Aspect_Specification (P)
1241 Error_Msg_NE ("aspect% for & previously given#", N, E);
1243 Error_Msg_NE ("pragma% for & duplicates pragma#", N, E);
1248 end Check_Duplicate_Pragma;
1250 ----------------------------------
1251 -- Check_Duplicated_Export_Name --
1252 ----------------------------------
1254 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
1255 String_Val : constant String_Id := Strval (Nam);
1258 -- We are only interested in the export case, and in the case of
1259 -- generics, it is the instance, not the template, that is the
1260 -- problem (the template will generate a warning in any case).
1262 if not Inside_A_Generic
1263 and then (Prag_Id = Pragma_Export
1265 Prag_Id = Pragma_Export_Procedure
1267 Prag_Id = Pragma_Export_Valued_Procedure
1269 Prag_Id = Pragma_Export_Function)
1271 for J in Externals.First .. Externals.Last loop
1272 if String_Equal (String_Val, Strval (Externals.Table (J))) then
1273 Error_Msg_Sloc := Sloc (Externals.Table (J));
1274 Error_Msg_N ("external name duplicates name given#", Nam);
1279 Externals.Append (Nam);
1281 end Check_Duplicated_Export_Name;
1283 -------------------------
1284 -- Check_First_Subtype --
1285 -------------------------
1287 procedure Check_First_Subtype (Arg : Node_Id) is
1288 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1290 if not Is_First_Subtype (Entity (Argx)) then
1292 ("pragma% cannot apply to subtype", Argx);
1294 end Check_First_Subtype;
1296 ---------------------------
1297 -- Check_In_Main_Program --
1298 ---------------------------
1300 procedure Check_In_Main_Program is
1301 P : constant Node_Id := Parent (N);
1304 -- Must be at in subprogram body
1306 if Nkind (P) /= N_Subprogram_Body then
1307 Error_Pragma ("% pragma allowed only in subprogram");
1309 -- Otherwise warn if obviously not main program
1311 elsif Present (Parameter_Specifications (Specification (P)))
1312 or else not Is_Compilation_Unit (Defining_Entity (P))
1314 Error_Msg_Name_1 := Pname;
1316 ("?pragma% is only effective in main program", N);
1318 end Check_In_Main_Program;
1320 ---------------------------------------
1321 -- Check_Interrupt_Or_Attach_Handler --
1322 ---------------------------------------
1324 procedure Check_Interrupt_Or_Attach_Handler is
1325 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
1326 Handler_Proc, Proc_Scope : Entity_Id;
1331 if Prag_Id = Pragma_Interrupt_Handler then
1332 Check_Restriction (No_Dynamic_Attachment, N);
1335 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
1336 Proc_Scope := Scope (Handler_Proc);
1338 -- On AAMP only, a pragma Interrupt_Handler is supported for
1339 -- nonprotected parameterless procedures.
1341 if not AAMP_On_Target
1342 or else Prag_Id = Pragma_Attach_Handler
1344 if Ekind (Proc_Scope) /= E_Protected_Type then
1346 ("argument of pragma% must be protected procedure", Arg1);
1349 if Parent (N) /= Protected_Definition (Parent (Proc_Scope)) then
1350 Error_Pragma ("pragma% must be in protected definition");
1354 if not Is_Library_Level_Entity (Proc_Scope)
1355 or else (AAMP_On_Target
1356 and then not Is_Library_Level_Entity (Handler_Proc))
1359 ("argument for pragma% must be library level entity", Arg1);
1362 -- AI05-0033: A pragma cannot appear within a generic body, because
1363 -- instance can be in a nested scope. The check that protected type
1364 -- is itself a library-level declaration is done elsewhere.
1366 -- Note: we omit this check in Codepeer mode to properly handle code
1367 -- prior to AI-0033 (pragmas don't matter to codepeer in any case).
1369 if Inside_A_Generic then
1370 if Ekind (Scope (Current_Scope)) = E_Generic_Package
1371 and then In_Package_Body (Scope (Current_Scope))
1372 and then not CodePeer_Mode
1374 Error_Pragma ("pragma% cannot be used inside a generic");
1377 end Check_Interrupt_Or_Attach_Handler;
1379 -------------------------------------------
1380 -- Check_Is_In_Decl_Part_Or_Package_Spec --
1381 -------------------------------------------
1383 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
1392 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
1395 elsif Nkind_In (P, N_Package_Specification,
1400 -- Note: the following tests seem a little peculiar, because
1401 -- they test for bodies, but if we were in the statement part
1402 -- of the body, we would already have hit the handled statement
1403 -- sequence, so the only way we get here is by being in the
1404 -- declarative part of the body.
1406 elsif Nkind_In (P, N_Subprogram_Body,
1417 Error_Pragma ("pragma% is not in declarative part or package spec");
1418 end Check_Is_In_Decl_Part_Or_Package_Spec;
1420 -------------------------
1421 -- Check_No_Identifier --
1422 -------------------------
1424 procedure Check_No_Identifier (Arg : Node_Id) is
1426 if Nkind (Arg) = N_Pragma_Argument_Association
1427 and then Chars (Arg) /= No_Name
1429 Error_Pragma_Arg_Ident
1430 ("pragma% does not permit identifier& here", Arg);
1432 end Check_No_Identifier;
1434 --------------------------
1435 -- Check_No_Identifiers --
1436 --------------------------
1438 procedure Check_No_Identifiers is
1441 if Arg_Count > 0 then
1443 while Present (Arg_Node) loop
1444 Check_No_Identifier (Arg_Node);
1448 end Check_No_Identifiers;
1450 -------------------------------
1451 -- Check_Optional_Identifier --
1452 -------------------------------
1454 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
1457 and then Nkind (Arg) = N_Pragma_Argument_Association
1458 and then Chars (Arg) /= No_Name
1460 if Chars (Arg) /= Id then
1461 Error_Msg_Name_1 := Pname;
1462 Error_Msg_Name_2 := Id;
1463 Error_Msg_N ("pragma% argument expects identifier%", Arg);
1467 end Check_Optional_Identifier;
1469 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
1471 Name_Buffer (1 .. Id'Length) := Id;
1472 Name_Len := Id'Length;
1473 Check_Optional_Identifier (Arg, Name_Find);
1474 end Check_Optional_Identifier;
1476 --------------------------------------
1477 -- Check_Precondition_Postcondition --
1478 --------------------------------------
1480 procedure Check_Precondition_Postcondition (In_Body : out Boolean) is
1484 procedure Chain_PPC (PO : Node_Id);
1485 -- If PO is a subprogram declaration node (or a generic subprogram
1486 -- declaration node), then the precondition/postcondition applies
1487 -- to this subprogram and the processing for the pragma is completed.
1488 -- Otherwise the pragma is misplaced.
1494 procedure Chain_PPC (PO : Node_Id) is
1499 if Nkind (PO) = N_Abstract_Subprogram_Declaration then
1500 if not From_Aspect_Specification (N) then
1502 ("pragma% cannot be applied to abstract subprogram");
1504 elsif Class_Present (N) then
1509 ("aspect % requires ''Class for abstract subprogram");
1512 elsif not Nkind_In (PO, N_Subprogram_Declaration,
1513 N_Generic_Subprogram_Declaration,
1514 N_Entry_Declaration)
1519 -- Here if we have [generic] subprogram or entry declaration
1521 if Nkind (PO) = N_Entry_Declaration then
1522 S := Defining_Entity (PO);
1524 S := Defining_Unit_Name (Specification (PO));
1527 -- Make sure we do not have the case of a precondition pragma when
1528 -- the Pre'Class aspect is present.
1530 -- We do this by looking at pragmas already chained to the entity
1531 -- since the aspect derived pragma will be put on this list first.
1533 if Pragma_Name (N) = Name_Precondition then
1534 if not From_Aspect_Specification (N) then
1535 P := Spec_PPC_List (S);
1536 while Present (P) loop
1537 if Pragma_Name (P) = Name_Precondition
1538 and then From_Aspect_Specification (P)
1539 and then Class_Present (P)
1541 Error_Msg_Sloc := Sloc (P);
1543 ("pragma% not allowed, `Pre''Class` aspect given#");
1546 P := Next_Pragma (P);
1551 -- Similarly check for Pre with inherited Pre'Class. Note that
1552 -- we cover the aspect case as well here.
1554 if Pragma_Name (N) = Name_Precondition
1555 and then not Class_Present (N)
1558 Inherited : constant Subprogram_List :=
1559 Inherited_Subprograms (S);
1563 for J in Inherited'Range loop
1564 P := Spec_PPC_List (Inherited (J));
1565 while Present (P) loop
1566 if Pragma_Name (P) = Name_Precondition
1567 and then Class_Present (P)
1569 Error_Msg_Sloc := Sloc (P);
1571 ("pragma% not allowed, `Pre''Class` "
1572 & "aspect inherited from#");
1575 P := Next_Pragma (P);
1581 -- Note: we do not analye the pragma at this point. Instead we
1582 -- delay this analysis until the end of the declarative part in
1583 -- which the pragma appears. This implements the required delay
1584 -- in this analysis, allowing forward references. The analysis
1585 -- happens at the end of Analyze_Declarations.
1587 -- Chain spec PPC pragma to list for subprogram
1589 Set_Next_Pragma (N, Spec_PPC_List (S));
1590 Set_Spec_PPC_List (S, N);
1592 -- Return indicating spec case
1598 -- Start of processing for Check_Precondition_Postcondition
1601 if not Is_List_Member (N) then
1605 -- Preanalyze message argument if present. Visibility in this
1606 -- argument is established at the point of pragma occurrence.
1608 if Arg_Count = 2 then
1609 Check_Optional_Identifier (Arg2, Name_Message);
1610 Preanalyze_Spec_Expression
1611 (Get_Pragma_Arg (Arg2), Standard_String);
1614 -- Record if pragma is enabled
1616 if Check_Enabled (Pname) then
1617 Set_Pragma_Enabled (N);
1618 Set_SCO_Pragma_Enabled (Loc);
1621 -- If we are within an inlined body, the legality of the pragma
1622 -- has been checked already.
1624 if In_Inlined_Body then
1629 -- Search prior declarations
1632 while Present (Prev (P)) loop
1635 -- If the previous node is a generic subprogram, do not go to to
1636 -- the original node, which is the unanalyzed tree: we need to
1637 -- attach the pre/postconditions to the analyzed version at this
1638 -- point. They get propagated to the original tree when analyzing
1639 -- the corresponding body.
1641 if Nkind (P) not in N_Generic_Declaration then
1642 PO := Original_Node (P);
1647 -- Skip past prior pragma
1649 if Nkind (PO) = N_Pragma then
1652 -- Skip stuff not coming from source
1654 elsif not Comes_From_Source (PO) then
1657 -- Only remaining possibility is subprogram declaration
1665 -- If we fall through loop, pragma is at start of list, so see if it
1666 -- is at the start of declarations of a subprogram body.
1668 if Nkind (Parent (N)) = N_Subprogram_Body
1669 and then List_Containing (N) = Declarations (Parent (N))
1671 if Operating_Mode /= Generate_Code
1672 or else Inside_A_Generic
1674 -- Analyze pragma expression for correctness and for ASIS use
1676 Preanalyze_Spec_Expression
1677 (Get_Pragma_Arg (Arg1), Standard_Boolean);
1683 -- See if it is in the pragmas after a library level subprogram
1685 elsif Nkind (Parent (N)) = N_Compilation_Unit_Aux then
1686 Chain_PPC (Unit (Parent (Parent (N))));
1690 -- If we fall through, pragma was misplaced
1693 end Check_Precondition_Postcondition;
1695 -----------------------------
1696 -- Check_Static_Constraint --
1697 -----------------------------
1699 -- Note: for convenience in writing this procedure, in addition to
1700 -- the officially (i.e. by spec) allowed argument which is always a
1701 -- constraint, it also allows ranges and discriminant associations.
1702 -- Above is not clear ???
1704 procedure Check_Static_Constraint (Constr : Node_Id) is
1706 procedure Require_Static (E : Node_Id);
1707 -- Require given expression to be static expression
1709 --------------------
1710 -- Require_Static --
1711 --------------------
1713 procedure Require_Static (E : Node_Id) is
1715 if not Is_OK_Static_Expression (E) then
1716 Flag_Non_Static_Expr
1717 ("non-static constraint not allowed in Unchecked_Union!", E);
1722 -- Start of processing for Check_Static_Constraint
1725 case Nkind (Constr) is
1726 when N_Discriminant_Association =>
1727 Require_Static (Expression (Constr));
1730 Require_Static (Low_Bound (Constr));
1731 Require_Static (High_Bound (Constr));
1733 when N_Attribute_Reference =>
1734 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
1735 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
1737 when N_Range_Constraint =>
1738 Check_Static_Constraint (Range_Expression (Constr));
1740 when N_Index_Or_Discriminant_Constraint =>
1744 IDC := First (Constraints (Constr));
1745 while Present (IDC) loop
1746 Check_Static_Constraint (IDC);
1754 end Check_Static_Constraint;
1756 --------------------------------------
1757 -- Check_Valid_Configuration_Pragma --
1758 --------------------------------------
1760 -- A configuration pragma must appear in the context clause of a
1761 -- compilation unit, and only other pragmas may precede it. Note that
1762 -- the test also allows use in a configuration pragma file.
1764 procedure Check_Valid_Configuration_Pragma is
1766 if not Is_Configuration_Pragma then
1767 Error_Pragma ("incorrect placement for configuration pragma%");
1769 end Check_Valid_Configuration_Pragma;
1771 -------------------------------------
1772 -- Check_Valid_Library_Unit_Pragma --
1773 -------------------------------------
1775 procedure Check_Valid_Library_Unit_Pragma is
1777 Parent_Node : Node_Id;
1778 Unit_Name : Entity_Id;
1779 Unit_Kind : Node_Kind;
1780 Unit_Node : Node_Id;
1781 Sindex : Source_File_Index;
1784 if not Is_List_Member (N) then
1788 Plist := List_Containing (N);
1789 Parent_Node := Parent (Plist);
1791 if Parent_Node = Empty then
1794 -- Case of pragma appearing after a compilation unit. In this case
1795 -- it must have an argument with the corresponding name and must
1796 -- be part of the following pragmas of its parent.
1798 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
1799 if Plist /= Pragmas_After (Parent_Node) then
1802 elsif Arg_Count = 0 then
1804 ("argument required if outside compilation unit");
1807 Check_No_Identifiers;
1808 Check_Arg_Count (1);
1809 Unit_Node := Unit (Parent (Parent_Node));
1810 Unit_Kind := Nkind (Unit_Node);
1812 Analyze (Get_Pragma_Arg (Arg1));
1814 if Unit_Kind = N_Generic_Subprogram_Declaration
1815 or else Unit_Kind = N_Subprogram_Declaration
1817 Unit_Name := Defining_Entity (Unit_Node);
1819 elsif Unit_Kind in N_Generic_Instantiation then
1820 Unit_Name := Defining_Entity (Unit_Node);
1823 Unit_Name := Cunit_Entity (Current_Sem_Unit);
1826 if Chars (Unit_Name) /=
1827 Chars (Entity (Get_Pragma_Arg (Arg1)))
1830 ("pragma% argument is not current unit name", Arg1);
1833 if Ekind (Unit_Name) = E_Package
1834 and then Present (Renamed_Entity (Unit_Name))
1836 Error_Pragma ("pragma% not allowed for renamed package");
1840 -- Pragma appears other than after a compilation unit
1843 -- Here we check for the generic instantiation case and also
1844 -- for the case of processing a generic formal package. We
1845 -- detect these cases by noting that the Sloc on the node
1846 -- does not belong to the current compilation unit.
1848 Sindex := Source_Index (Current_Sem_Unit);
1850 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
1851 Rewrite (N, Make_Null_Statement (Loc));
1854 -- If before first declaration, the pragma applies to the
1855 -- enclosing unit, and the name if present must be this name.
1857 elsif Is_Before_First_Decl (N, Plist) then
1858 Unit_Node := Unit_Declaration_Node (Current_Scope);
1859 Unit_Kind := Nkind (Unit_Node);
1861 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
1864 elsif Unit_Kind = N_Subprogram_Body
1865 and then not Acts_As_Spec (Unit_Node)
1869 elsif Nkind (Parent_Node) = N_Package_Body then
1872 elsif Nkind (Parent_Node) = N_Package_Specification
1873 and then Plist = Private_Declarations (Parent_Node)
1877 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
1878 or else Nkind (Parent_Node) =
1879 N_Generic_Subprogram_Declaration)
1880 and then Plist = Generic_Formal_Declarations (Parent_Node)
1884 elsif Arg_Count > 0 then
1885 Analyze (Get_Pragma_Arg (Arg1));
1887 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
1889 ("name in pragma% must be enclosing unit", Arg1);
1892 -- It is legal to have no argument in this context
1898 -- Error if not before first declaration. This is because a
1899 -- library unit pragma argument must be the name of a library
1900 -- unit (RM 10.1.5(7)), but the only names permitted in this
1901 -- context are (RM 10.1.5(6)) names of subprogram declarations,
1902 -- generic subprogram declarations or generic instantiations.
1906 ("pragma% misplaced, must be before first declaration");
1910 end Check_Valid_Library_Unit_Pragma;
1916 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
1917 Clist : constant Node_Id := Component_List (Variant);
1921 if not Is_Non_Empty_List (Component_Items (Clist)) then
1923 ("Unchecked_Union may not have empty component list",
1928 Comp := First (Component_Items (Clist));
1929 while Present (Comp) loop
1930 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
1939 procedure Error_Pragma (Msg : String) is
1940 MsgF : String := Msg;
1942 Error_Msg_Name_1 := Pname;
1944 Error_Msg_N (MsgF, N);
1948 ----------------------
1949 -- Error_Pragma_Arg --
1950 ----------------------
1952 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
1953 MsgF : String := Msg;
1955 Error_Msg_Name_1 := Pname;
1957 Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
1959 end Error_Pragma_Arg;
1961 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
1962 MsgF : String := Msg1;
1964 Error_Msg_Name_1 := Pname;
1966 Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
1967 Error_Pragma_Arg (Msg2, Arg);
1968 end Error_Pragma_Arg;
1970 ----------------------------
1971 -- Error_Pragma_Arg_Ident --
1972 ----------------------------
1974 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
1975 MsgF : String := Msg;
1977 Error_Msg_Name_1 := Pname;
1979 Error_Msg_N (MsgF, Arg);
1981 end Error_Pragma_Arg_Ident;
1983 ----------------------
1984 -- Error_Pragma_Ref --
1985 ----------------------
1987 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
1988 MsgF : String := Msg;
1990 Error_Msg_Name_1 := Pname;
1992 Error_Msg_Sloc := Sloc (Ref);
1993 Error_Msg_NE (MsgF, N, Ref);
1995 end Error_Pragma_Ref;
1997 ------------------------
1998 -- Find_Lib_Unit_Name --
1999 ------------------------
2001 function Find_Lib_Unit_Name return Entity_Id is
2003 -- Return inner compilation unit entity, for case of nested
2004 -- categorization pragmas. This happens in generic unit.
2006 if Nkind (Parent (N)) = N_Package_Specification
2007 and then Defining_Entity (Parent (N)) /= Current_Scope
2009 return Defining_Entity (Parent (N));
2011 return Current_Scope;
2013 end Find_Lib_Unit_Name;
2015 ----------------------------
2016 -- Find_Program_Unit_Name --
2017 ----------------------------
2019 procedure Find_Program_Unit_Name (Id : Node_Id) is
2020 Unit_Name : Entity_Id;
2021 Unit_Kind : Node_Kind;
2022 P : constant Node_Id := Parent (N);
2025 if Nkind (P) = N_Compilation_Unit then
2026 Unit_Kind := Nkind (Unit (P));
2028 if Unit_Kind = N_Subprogram_Declaration
2029 or else Unit_Kind = N_Package_Declaration
2030 or else Unit_Kind in N_Generic_Declaration
2032 Unit_Name := Defining_Entity (Unit (P));
2034 if Chars (Id) = Chars (Unit_Name) then
2035 Set_Entity (Id, Unit_Name);
2036 Set_Etype (Id, Etype (Unit_Name));
2038 Set_Etype (Id, Any_Type);
2040 ("cannot find program unit referenced by pragma%");
2044 Set_Etype (Id, Any_Type);
2045 Error_Pragma ("pragma% inapplicable to this unit");
2051 end Find_Program_Unit_Name;
2053 -----------------------------------------
2054 -- Find_Unique_Parameterless_Procedure --
2055 -----------------------------------------
2057 function Find_Unique_Parameterless_Procedure
2059 Arg : Node_Id) return Entity_Id
2061 Proc : Entity_Id := Empty;
2064 -- The body of this procedure needs some comments ???
2066 if not Is_Entity_Name (Name) then
2068 ("argument of pragma% must be entity name", Arg);
2070 elsif not Is_Overloaded (Name) then
2071 Proc := Entity (Name);
2073 if Ekind (Proc) /= E_Procedure
2074 or else Present (First_Formal (Proc))
2077 ("argument of pragma% must be parameterless procedure", Arg);
2082 Found : Boolean := False;
2084 Index : Interp_Index;
2087 Get_First_Interp (Name, Index, It);
2088 while Present (It.Nam) loop
2091 if Ekind (Proc) = E_Procedure
2092 and then No (First_Formal (Proc))
2096 Set_Entity (Name, Proc);
2097 Set_Is_Overloaded (Name, False);
2100 ("ambiguous handler name for pragma% ", Arg);
2104 Get_Next_Interp (Index, It);
2109 ("argument of pragma% must be parameterless procedure",
2112 Proc := Entity (Name);
2118 end Find_Unique_Parameterless_Procedure;
2124 procedure Fix_Error (Msg : in out String) is
2126 if From_Aspect_Specification (N) then
2127 for J in Msg'First .. Msg'Last - 5 loop
2128 if Msg (J .. J + 5) = "pragma" then
2129 Msg (J .. J + 5) := "aspect";
2133 if Error_Msg_Name_1 = Name_Precondition then
2134 Error_Msg_Name_1 := Name_Pre;
2135 elsif Error_Msg_Name_1 = Name_Postcondition then
2136 Error_Msg_Name_1 := Name_Post;
2141 -------------------------
2142 -- Gather_Associations --
2143 -------------------------
2145 procedure Gather_Associations
2147 Args : out Args_List)
2152 -- Initialize all parameters to Empty
2154 for J in Args'Range loop
2158 -- That's all we have to do if there are no argument associations
2160 if No (Pragma_Argument_Associations (N)) then
2164 -- Otherwise first deal with any positional parameters present
2166 Arg := First (Pragma_Argument_Associations (N));
2167 for Index in Args'Range loop
2168 exit when No (Arg) or else Chars (Arg) /= No_Name;
2169 Args (Index) := Get_Pragma_Arg (Arg);
2173 -- Positional parameters all processed, if any left, then we
2174 -- have too many positional parameters.
2176 if Present (Arg) and then Chars (Arg) = No_Name then
2178 ("too many positional associations for pragma%", Arg);
2181 -- Process named parameters if any are present
2183 while Present (Arg) loop
2184 if Chars (Arg) = No_Name then
2186 ("positional association cannot follow named association",
2190 for Index in Names'Range loop
2191 if Names (Index) = Chars (Arg) then
2192 if Present (Args (Index)) then
2194 ("duplicate argument association for pragma%", Arg);
2196 Args (Index) := Get_Pragma_Arg (Arg);
2201 if Index = Names'Last then
2202 Error_Msg_Name_1 := Pname;
2203 Error_Msg_N ("pragma% does not allow & argument", Arg);
2205 -- Check for possible misspelling
2207 for Index1 in Names'Range loop
2208 if Is_Bad_Spelling_Of
2209 (Chars (Arg), Names (Index1))
2211 Error_Msg_Name_1 := Names (Index1);
2212 Error_Msg_N -- CODEFIX
2213 ("\possible misspelling of%", Arg);
2225 end Gather_Associations;
2231 procedure GNAT_Pragma is
2233 Check_Restriction (No_Implementation_Pragmas, N);
2236 --------------------------
2237 -- Is_Before_First_Decl --
2238 --------------------------
2240 function Is_Before_First_Decl
2241 (Pragma_Node : Node_Id;
2242 Decls : List_Id) return Boolean
2244 Item : Node_Id := First (Decls);
2247 -- Only other pragmas can come before this pragma
2250 if No (Item) or else Nkind (Item) /= N_Pragma then
2253 elsif Item = Pragma_Node then
2259 end Is_Before_First_Decl;
2261 -----------------------------
2262 -- Is_Configuration_Pragma --
2263 -----------------------------
2265 -- A configuration pragma must appear in the context clause of a
2266 -- compilation unit, and only other pragmas may precede it. Note that
2267 -- the test below also permits use in a configuration pragma file.
2269 function Is_Configuration_Pragma return Boolean is
2270 Lis : constant List_Id := List_Containing (N);
2271 Par : constant Node_Id := Parent (N);
2275 -- If no parent, then we are in the configuration pragma file,
2276 -- so the placement is definitely appropriate.
2281 -- Otherwise we must be in the context clause of a compilation unit
2282 -- and the only thing allowed before us in the context list is more
2283 -- configuration pragmas.
2285 elsif Nkind (Par) = N_Compilation_Unit
2286 and then Context_Items (Par) = Lis
2293 elsif Nkind (Prg) /= N_Pragma then
2303 end Is_Configuration_Pragma;
2305 --------------------------
2306 -- Is_In_Context_Clause --
2307 --------------------------
2309 function Is_In_Context_Clause return Boolean is
2311 Parent_Node : Node_Id;
2314 if not Is_List_Member (N) then
2318 Plist := List_Containing (N);
2319 Parent_Node := Parent (Plist);
2321 if Parent_Node = Empty
2322 or else Nkind (Parent_Node) /= N_Compilation_Unit
2323 or else Context_Items (Parent_Node) /= Plist
2330 end Is_In_Context_Clause;
2332 ---------------------------------
2333 -- Is_Static_String_Expression --
2334 ---------------------------------
2336 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
2337 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
2340 Analyze_And_Resolve (Argx);
2341 return Is_OK_Static_Expression (Argx)
2342 and then Nkind (Argx) = N_String_Literal;
2343 end Is_Static_String_Expression;
2345 ----------------------
2346 -- Pragma_Misplaced --
2347 ----------------------
2349 procedure Pragma_Misplaced is
2351 Error_Pragma ("incorrect placement of pragma%");
2352 end Pragma_Misplaced;
2354 ------------------------------------
2355 -- Process Atomic_Shared_Volatile --
2356 ------------------------------------
2358 procedure Process_Atomic_Shared_Volatile is
2365 procedure Set_Atomic (E : Entity_Id);
2366 -- Set given type as atomic, and if no explicit alignment was given,
2367 -- set alignment to unknown, since back end knows what the alignment
2368 -- requirements are for atomic arrays. Note: this step is necessary
2369 -- for derived types.
2375 procedure Set_Atomic (E : Entity_Id) is
2377 Set_Is_Atomic (E, Sense);
2379 if Sense and then not Has_Alignment_Clause (E) then
2380 Set_Alignment (E, Uint_0);
2384 -- Start of processing for Process_Atomic_Shared_Volatile
2387 Check_Ada_83_Warning;
2388 Check_No_Identifiers;
2389 Check_Arg_Count (1);
2390 Check_Arg_Is_Local_Name (Arg1);
2391 E_Id := Get_Pragma_Arg (Arg1);
2393 if Etype (E_Id) = Any_Type then
2398 D := Declaration_Node (E);
2401 -- Check duplicate before we chain ourselves!
2403 Check_Duplicate_Pragma (E);
2405 -- Now check appropriateness of the entity
2408 if Rep_Item_Too_Early (E, N)
2410 Rep_Item_Too_Late (E, N)
2414 Check_First_Subtype (Arg1);
2417 if Prag_Id /= Pragma_Volatile then
2419 Set_Atomic (Underlying_Type (E));
2420 Set_Atomic (Base_Type (E));
2423 -- Attribute belongs on the base type. If the view of the type is
2424 -- currently private, it also belongs on the underlying type.
2426 Set_Is_Volatile (Base_Type (E), Sense);
2427 Set_Is_Volatile (Underlying_Type (E), Sense);
2429 Set_Treat_As_Volatile (E, Sense);
2430 Set_Treat_As_Volatile (Underlying_Type (E), Sense);
2432 elsif K = N_Object_Declaration
2433 or else (K = N_Component_Declaration
2434 and then Original_Record_Component (E) = E)
2436 if Rep_Item_Too_Late (E, N) then
2440 if Prag_Id /= Pragma_Volatile then
2441 Set_Is_Atomic (E, Sense);
2443 -- If the object declaration has an explicit initialization, a
2444 -- temporary may have to be created to hold the expression, to
2445 -- ensure that access to the object remain atomic.
2447 if Nkind (Parent (E)) = N_Object_Declaration
2448 and then Present (Expression (Parent (E)))
2451 Set_Has_Delayed_Freeze (E);
2454 -- An interesting improvement here. If an object of type X is
2455 -- declared atomic, and the type X is not atomic, that's a
2456 -- pity, since it may not have appropriate alignment etc. We
2457 -- can rescue this in the special case where the object and
2458 -- type are in the same unit by just setting the type as
2459 -- atomic, so that the back end will process it as atomic.
2461 Utyp := Underlying_Type (Etype (E));
2464 and then Sloc (E) > No_Location
2465 and then Sloc (Utyp) > No_Location
2467 Get_Source_File_Index (Sloc (E)) =
2468 Get_Source_File_Index (Sloc (Underlying_Type (Etype (E))))
2470 Set_Is_Atomic (Underlying_Type (Etype (E)), Sense);
2474 Set_Is_Volatile (E);
2475 Set_Treat_As_Volatile (E);
2479 ("inappropriate entity for pragma%", Arg1);
2481 end Process_Atomic_Shared_Volatile;
2483 -------------------------------------------
2484 -- Process_Compile_Time_Warning_Or_Error --
2485 -------------------------------------------
2487 procedure Process_Compile_Time_Warning_Or_Error is
2488 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
2491 Check_Arg_Count (2);
2492 Check_No_Identifiers;
2493 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
2494 Analyze_And_Resolve (Arg1x, Standard_Boolean);
2496 if Compile_Time_Known_Value (Arg1x) then
2497 if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
2499 Str : constant String_Id :=
2500 Strval (Get_Pragma_Arg (Arg2));
2501 Len : constant Int := String_Length (Str);
2506 Cent : constant Entity_Id :=
2507 Cunit_Entity (Current_Sem_Unit);
2509 Force : constant Boolean :=
2510 Prag_Id = Pragma_Compile_Time_Warning
2512 Is_Spec_Name (Unit_Name (Current_Sem_Unit))
2513 and then (Ekind (Cent) /= E_Package
2514 or else not In_Private_Part (Cent));
2515 -- Set True if this is the warning case, and we are in the
2516 -- visible part of a package spec, or in a subprogram spec,
2517 -- in which case we want to force the client to see the
2518 -- warning, even though it is not in the main unit.
2521 -- Loop through segments of message separated by line feeds.
2522 -- We output these segments as separate messages with
2523 -- continuation marks for all but the first.
2528 Error_Msg_Strlen := 0;
2530 -- Loop to copy characters from argument to error message
2534 exit when Ptr > Len;
2535 CC := Get_String_Char (Str, Ptr);
2538 -- Ignore wide chars ??? else store character
2540 if In_Character_Range (CC) then
2541 C := Get_Character (CC);
2542 exit when C = ASCII.LF;
2543 Error_Msg_Strlen := Error_Msg_Strlen + 1;
2544 Error_Msg_String (Error_Msg_Strlen) := C;
2548 -- Here with one line ready to go
2550 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
2552 -- If this is a warning in a spec, then we want clients
2553 -- to see the warning, so mark the message with the
2554 -- special sequence !! to force the warning. In the case
2555 -- of a package spec, we do not force this if we are in
2556 -- the private part of the spec.
2559 if Cont = False then
2560 Error_Msg_N ("<~!!", Arg1);
2563 Error_Msg_N ("\<~!!", Arg1);
2566 -- Error, rather than warning, or in a body, so we do not
2567 -- need to force visibility for client (error will be
2568 -- output in any case, and this is the situation in which
2569 -- we do not want a client to get a warning, since the
2570 -- warning is in the body or the spec private part).
2573 if Cont = False then
2574 Error_Msg_N ("<~", Arg1);
2577 Error_Msg_N ("\<~", Arg1);
2581 exit when Ptr > Len;
2586 end Process_Compile_Time_Warning_Or_Error;
2588 ------------------------
2589 -- Process_Convention --
2590 ------------------------
2592 procedure Process_Convention
2593 (C : out Convention_Id;
2594 Ent : out Entity_Id)
2600 Comp_Unit : Unit_Number_Type;
2602 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
2603 -- Called if we have more than one Export/Import/Convention pragma.
2604 -- This is generally illegal, but we have a special case of allowing
2605 -- Import and Interface to coexist if they specify the convention in
2606 -- a consistent manner. We are allowed to do this, since Interface is
2607 -- an implementation defined pragma, and we choose to do it since we
2608 -- know Rational allows this combination. S is the entity id of the
2609 -- subprogram in question. This procedure also sets the special flag
2610 -- Import_Interface_Present in both pragmas in the case where we do
2611 -- have matching Import and Interface pragmas.
2613 procedure Set_Convention_From_Pragma (E : Entity_Id);
2614 -- Set convention in entity E, and also flag that the entity has a
2615 -- convention pragma. If entity is for a private or incomplete type,
2616 -- also set convention and flag on underlying type. This procedure
2617 -- also deals with the special case of C_Pass_By_Copy convention.
2619 -------------------------------
2620 -- Diagnose_Multiple_Pragmas --
2621 -------------------------------
2623 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
2624 Pdec : constant Node_Id := Declaration_Node (S);
2628 function Same_Convention (Decl : Node_Id) return Boolean;
2629 -- Decl is a pragma node. This function returns True if this
2630 -- pragma has a first argument that is an identifier with a
2631 -- Chars field corresponding to the Convention_Id C.
2633 function Same_Name (Decl : Node_Id) return Boolean;
2634 -- Decl is a pragma node. This function returns True if this
2635 -- pragma has a second argument that is an identifier with a
2636 -- Chars field that matches the Chars of the current subprogram.
2638 ---------------------
2639 -- Same_Convention --
2640 ---------------------
2642 function Same_Convention (Decl : Node_Id) return Boolean is
2643 Arg1 : constant Node_Id :=
2644 First (Pragma_Argument_Associations (Decl));
2647 if Present (Arg1) then
2649 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
2651 if Nkind (Arg) = N_Identifier
2652 and then Is_Convention_Name (Chars (Arg))
2653 and then Get_Convention_Id (Chars (Arg)) = C
2661 end Same_Convention;
2667 function Same_Name (Decl : Node_Id) return Boolean is
2668 Arg1 : constant Node_Id :=
2669 First (Pragma_Argument_Associations (Decl));
2677 Arg2 := Next (Arg1);
2684 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
2686 if Nkind (Arg) = N_Identifier
2687 and then Chars (Arg) = Chars (S)
2696 -- Start of processing for Diagnose_Multiple_Pragmas
2701 -- Definitely give message if we have Convention/Export here
2703 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
2706 -- If we have an Import or Export, scan back from pragma to
2707 -- find any previous pragma applying to the same procedure.
2708 -- The scan will be terminated by the start of the list, or
2709 -- hitting the subprogram declaration. This won't allow one
2710 -- pragma to appear in the public part and one in the private
2711 -- part, but that seems very unlikely in practice.
2715 while Present (Decl) and then Decl /= Pdec loop
2717 -- Look for pragma with same name as us
2719 if Nkind (Decl) = N_Pragma
2720 and then Same_Name (Decl)
2722 -- Give error if same as our pragma or Export/Convention
2724 if Pragma_Name (Decl) = Name_Export
2726 Pragma_Name (Decl) = Name_Convention
2728 Pragma_Name (Decl) = Pragma_Name (N)
2732 -- Case of Import/Interface or the other way round
2734 elsif Pragma_Name (Decl) = Name_Interface
2736 Pragma_Name (Decl) = Name_Import
2738 -- Here we know that we have Import and Interface. It
2739 -- doesn't matter which way round they are. See if
2740 -- they specify the same convention. If so, all OK,
2741 -- and set special flags to stop other messages
2743 if Same_Convention (Decl) then
2744 Set_Import_Interface_Present (N);
2745 Set_Import_Interface_Present (Decl);
2748 -- If different conventions, special message
2751 Error_Msg_Sloc := Sloc (Decl);
2753 ("convention differs from that given#", Arg1);
2763 -- Give message if needed if we fall through those tests
2767 ("at most one Convention/Export/Import pragma is allowed",
2770 end Diagnose_Multiple_Pragmas;
2772 --------------------------------
2773 -- Set_Convention_From_Pragma --
2774 --------------------------------
2776 procedure Set_Convention_From_Pragma (E : Entity_Id) is
2778 -- Ada 2005 (AI-430): Check invalid attempt to change convention
2779 -- for an overridden dispatching operation. Technically this is
2780 -- an amendment and should only be done in Ada 2005 mode. However,
2781 -- this is clearly a mistake, since the problem that is addressed
2782 -- by this AI is that there is a clear gap in the RM!
2784 if Is_Dispatching_Operation (E)
2785 and then Present (Overridden_Operation (E))
2786 and then C /= Convention (Overridden_Operation (E))
2789 ("cannot change convention for " &
2790 "overridden dispatching operation",
2794 -- Set the convention
2796 Set_Convention (E, C);
2797 Set_Has_Convention_Pragma (E);
2799 if Is_Incomplete_Or_Private_Type (E) then
2800 Set_Convention (Underlying_Type (E), C);
2801 Set_Has_Convention_Pragma (Underlying_Type (E), True);
2804 -- A class-wide type should inherit the convention of the specific
2805 -- root type (although this isn't specified clearly by the RM).
2807 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
2808 Set_Convention (Class_Wide_Type (E), C);
2811 -- If the entity is a record type, then check for special case of
2812 -- C_Pass_By_Copy, which is treated the same as C except that the
2813 -- special record flag is set. This convention is only permitted
2814 -- on record types (see AI95-00131).
2816 if Cname = Name_C_Pass_By_Copy then
2817 if Is_Record_Type (E) then
2818 Set_C_Pass_By_Copy (Base_Type (E));
2819 elsif Is_Incomplete_Or_Private_Type (E)
2820 and then Is_Record_Type (Underlying_Type (E))
2822 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
2825 ("C_Pass_By_Copy convention allowed only for record type",
2830 -- If the entity is a derived boolean type, check for the special
2831 -- case of convention C, C++, or Fortran, where we consider any
2832 -- nonzero value to represent true.
2834 if Is_Discrete_Type (E)
2835 and then Root_Type (Etype (E)) = Standard_Boolean
2841 C = Convention_Fortran)
2843 Set_Nonzero_Is_True (Base_Type (E));
2845 end Set_Convention_From_Pragma;
2847 -- Start of processing for Process_Convention
2850 Check_At_Least_N_Arguments (2);
2851 Check_Optional_Identifier (Arg1, Name_Convention);
2852 Check_Arg_Is_Identifier (Arg1);
2853 Cname := Chars (Get_Pragma_Arg (Arg1));
2855 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
2856 -- tested again below to set the critical flag).
2857 if Cname = Name_C_Pass_By_Copy then
2860 -- Otherwise we must have something in the standard convention list
2862 elsif Is_Convention_Name (Cname) then
2863 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
2865 -- In DEC VMS, it seems that there is an undocumented feature that
2866 -- any unrecognized convention is treated as the default, which for
2867 -- us is convention C. It does not seem so terrible to do this
2868 -- unconditionally, silently in the VMS case, and with a warning
2869 -- in the non-VMS case.
2872 if Warn_On_Export_Import and not OpenVMS_On_Target then
2874 ("?unrecognized convention name, C assumed",
2875 Get_Pragma_Arg (Arg1));
2881 Check_Optional_Identifier (Arg2, Name_Entity);
2882 Check_Arg_Is_Local_Name (Arg2);
2884 Id := Get_Pragma_Arg (Arg2);
2887 if not Is_Entity_Name (Id) then
2888 Error_Pragma_Arg ("entity name required", Arg2);
2893 -- Set entity to return
2897 -- Go to renamed subprogram if present, since convention applies to
2898 -- the actual renamed entity, not to the renaming entity. If the
2899 -- subprogram is inherited, go to parent subprogram.
2901 if Is_Subprogram (E)
2902 and then Present (Alias (E))
2904 if Nkind (Parent (Declaration_Node (E))) =
2905 N_Subprogram_Renaming_Declaration
2907 if Scope (E) /= Scope (Alias (E)) then
2909 ("cannot apply pragma% to non-local entity&#", E);
2914 elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
2915 N_Private_Extension_Declaration)
2916 and then Scope (E) = Scope (Alias (E))
2920 -- Return the parent subprogram the entity was inherited from
2926 -- Check that we are not applying this to a specless body
2928 if Is_Subprogram (E)
2929 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
2932 ("pragma% requires separate spec and must come before body");
2935 -- Check that we are not applying this to a named constant
2937 if Ekind_In (E, E_Named_Integer, E_Named_Real) then
2938 Error_Msg_Name_1 := Pname;
2940 ("cannot apply pragma% to named constant!",
2941 Get_Pragma_Arg (Arg2));
2943 ("\supply appropriate type for&!", Arg2);
2946 if Ekind (E) = E_Enumeration_Literal then
2947 Error_Pragma ("enumeration literal not allowed for pragma%");
2950 -- Check for rep item appearing too early or too late
2952 if Etype (E) = Any_Type
2953 or else Rep_Item_Too_Early (E, N)
2957 E := Underlying_Type (E);
2960 if Rep_Item_Too_Late (E, N) then
2964 if Has_Convention_Pragma (E) then
2965 Diagnose_Multiple_Pragmas (E);
2967 elsif Convention (E) = Convention_Protected
2968 or else Ekind (Scope (E)) = E_Protected_Type
2971 ("a protected operation cannot be given a different convention",
2975 -- For Intrinsic, a subprogram is required
2977 if C = Convention_Intrinsic
2978 and then not Is_Subprogram (E)
2979 and then not Is_Generic_Subprogram (E)
2982 ("second argument of pragma% must be a subprogram", Arg2);
2985 -- For Stdcall, a subprogram, variable or subprogram type is required
2987 if C = Convention_Stdcall
2988 and then not Is_Subprogram (E)
2989 and then not Is_Generic_Subprogram (E)
2990 and then Ekind (E) /= E_Variable
2993 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
2996 ("second argument of pragma% must be subprogram (type)",
3000 if not Is_Subprogram (E)
3001 and then not Is_Generic_Subprogram (E)
3003 Set_Convention_From_Pragma (E);
3006 Check_First_Subtype (Arg2);
3007 Set_Convention_From_Pragma (Base_Type (E));
3009 -- For subprograms, we must set the convention on the
3010 -- internally generated directly designated type as well.
3012 if Ekind (E) = E_Access_Subprogram_Type then
3013 Set_Convention_From_Pragma (Directly_Designated_Type (E));
3017 -- For the subprogram case, set proper convention for all homonyms
3018 -- in same scope and the same declarative part, i.e. the same
3019 -- compilation unit.
3022 Comp_Unit := Get_Source_Unit (E);
3023 Set_Convention_From_Pragma (E);
3025 -- Treat a pragma Import as an implicit body, for GPS use
3027 if Prag_Id = Pragma_Import then
3028 Generate_Reference (E, Id, 'b');
3031 -- Loop through the homonyms of the pragma argument's entity
3036 exit when No (E1) or else Scope (E1) /= Current_Scope;
3038 -- Do not set the pragma on inherited operations or on formal
3041 if Comes_From_Source (E1)
3042 and then Comp_Unit = Get_Source_Unit (E1)
3043 and then not Is_Formal_Subprogram (E1)
3044 and then Nkind (Original_Node (Parent (E1))) /=
3045 N_Full_Type_Declaration
3047 if Present (Alias (E1))
3048 and then Scope (E1) /= Scope (Alias (E1))
3051 ("cannot apply pragma% to non-local entity& declared#",
3055 Set_Convention_From_Pragma (E1);
3057 if Prag_Id = Pragma_Import then
3058 Generate_Reference (E1, Id, 'b');
3062 -- For aspect case, do NOT apply to homonyms
3064 exit when From_Aspect_Specification (N);
3067 end Process_Convention;
3069 -----------------------------------------------------
3070 -- Process_Extended_Import_Export_Exception_Pragma --
3071 -----------------------------------------------------
3073 procedure Process_Extended_Import_Export_Exception_Pragma
3074 (Arg_Internal : Node_Id;
3075 Arg_External : Node_Id;
3083 if not OpenVMS_On_Target then
3085 ("?pragma% ignored (applies only to Open'V'M'S)");
3088 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
3089 Def_Id := Entity (Arg_Internal);
3091 if Ekind (Def_Id) /= E_Exception then
3093 ("pragma% must refer to declared exception", Arg_Internal);
3096 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
3098 if Present (Arg_Form) then
3099 Check_Arg_Is_One_Of (Arg_Form, Name_Ada, Name_VMS);
3102 if Present (Arg_Form)
3103 and then Chars (Arg_Form) = Name_Ada
3107 Set_Is_VMS_Exception (Def_Id);
3108 Set_Exception_Code (Def_Id, No_Uint);
3111 if Present (Arg_Code) then
3112 if not Is_VMS_Exception (Def_Id) then
3114 ("Code option for pragma% not allowed for Ada case",
3118 Check_Arg_Is_Static_Expression (Arg_Code, Any_Integer);
3119 Code_Val := Expr_Value (Arg_Code);
3121 if not UI_Is_In_Int_Range (Code_Val) then
3123 ("Code option for pragma% must be in 32-bit range",
3127 Set_Exception_Code (Def_Id, Code_Val);
3130 end Process_Extended_Import_Export_Exception_Pragma;
3132 -------------------------------------------------
3133 -- Process_Extended_Import_Export_Internal_Arg --
3134 -------------------------------------------------
3136 procedure Process_Extended_Import_Export_Internal_Arg
3137 (Arg_Internal : Node_Id := Empty)
3140 if No (Arg_Internal) then
3141 Error_Pragma ("Internal parameter required for pragma%");
3144 if Nkind (Arg_Internal) = N_Identifier then
3147 elsif Nkind (Arg_Internal) = N_Operator_Symbol
3148 and then (Prag_Id = Pragma_Import_Function
3150 Prag_Id = Pragma_Export_Function)
3156 ("wrong form for Internal parameter for pragma%", Arg_Internal);
3159 Check_Arg_Is_Local_Name (Arg_Internal);
3160 end Process_Extended_Import_Export_Internal_Arg;
3162 --------------------------------------------------
3163 -- Process_Extended_Import_Export_Object_Pragma --
3164 --------------------------------------------------
3166 procedure Process_Extended_Import_Export_Object_Pragma
3167 (Arg_Internal : Node_Id;
3168 Arg_External : Node_Id;
3174 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
3175 Def_Id := Entity (Arg_Internal);
3177 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
3179 ("pragma% must designate an object", Arg_Internal);
3182 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
3184 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
3187 ("previous Common/Psect_Object applies, pragma % not permitted",
3191 if Rep_Item_Too_Late (Def_Id, N) then
3195 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
3197 if Present (Arg_Size) then
3198 Check_Arg_Is_External_Name (Arg_Size);
3201 -- Export_Object case
3203 if Prag_Id = Pragma_Export_Object then
3204 if not Is_Library_Level_Entity (Def_Id) then
3206 ("argument for pragma% must be library level entity",
3210 if Ekind (Current_Scope) = E_Generic_Package then
3211 Error_Pragma ("pragma& cannot appear in a generic unit");
3214 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
3216 ("exported object must have compile time known size",
3220 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
3221 Error_Msg_N ("?duplicate Export_Object pragma", N);
3223 Set_Exported (Def_Id, Arg_Internal);
3226 -- Import_Object case
3229 if Is_Concurrent_Type (Etype (Def_Id)) then
3231 ("cannot use pragma% for task/protected object",
3235 if Ekind (Def_Id) = E_Constant then
3237 ("cannot import a constant", Arg_Internal);
3240 if Warn_On_Export_Import
3241 and then Has_Discriminants (Etype (Def_Id))
3244 ("imported value must be initialized?", Arg_Internal);
3247 if Warn_On_Export_Import
3248 and then Is_Access_Type (Etype (Def_Id))
3251 ("cannot import object of an access type?", Arg_Internal);
3254 if Warn_On_Export_Import
3255 and then Is_Imported (Def_Id)
3258 ("?duplicate Import_Object pragma", N);
3260 -- Check for explicit initialization present. Note that an
3261 -- initialization generated by the code generator, e.g. for an
3262 -- access type, does not count here.
3264 elsif Present (Expression (Parent (Def_Id)))
3267 (Original_Node (Expression (Parent (Def_Id))))
3269 Error_Msg_Sloc := Sloc (Def_Id);
3271 ("imported entities cannot be initialized (RM B.1(24))",
3272 "\no initialization allowed for & declared#", Arg1);
3274 Set_Imported (Def_Id);
3275 Note_Possible_Modification (Arg_Internal, Sure => False);
3278 end Process_Extended_Import_Export_Object_Pragma;
3280 ------------------------------------------------------
3281 -- Process_Extended_Import_Export_Subprogram_Pragma --
3282 ------------------------------------------------------
3284 procedure Process_Extended_Import_Export_Subprogram_Pragma
3285 (Arg_Internal : Node_Id;
3286 Arg_External : Node_Id;
3287 Arg_Parameter_Types : Node_Id;
3288 Arg_Result_Type : Node_Id := Empty;
3289 Arg_Mechanism : Node_Id;
3290 Arg_Result_Mechanism : Node_Id := Empty;
3291 Arg_First_Optional_Parameter : Node_Id := Empty)
3297 Ambiguous : Boolean;
3301 function Same_Base_Type
3303 Formal : Entity_Id) return Boolean;
3304 -- Determines if Ptype references the type of Formal. Note that only
3305 -- the base types need to match according to the spec. Ptype here is
3306 -- the argument from the pragma, which is either a type name, or an
3307 -- access attribute.
3309 --------------------
3310 -- Same_Base_Type --
3311 --------------------
3313 function Same_Base_Type
3315 Formal : Entity_Id) return Boolean
3317 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
3321 -- Case where pragma argument is typ'Access
3323 if Nkind (Ptype) = N_Attribute_Reference
3324 and then Attribute_Name (Ptype) = Name_Access
3326 Pref := Prefix (Ptype);
3329 if not Is_Entity_Name (Pref)
3330 or else Entity (Pref) = Any_Type
3335 -- We have a match if the corresponding argument is of an
3336 -- anonymous access type, and its designated type matches the
3337 -- type of the prefix of the access attribute
3339 return Ekind (Ftyp) = E_Anonymous_Access_Type
3340 and then Base_Type (Entity (Pref)) =
3341 Base_Type (Etype (Designated_Type (Ftyp)));
3343 -- Case where pragma argument is a type name
3348 if not Is_Entity_Name (Ptype)
3349 or else Entity (Ptype) = Any_Type
3354 -- We have a match if the corresponding argument is of the type
3355 -- given in the pragma (comparing base types)
3357 return Base_Type (Entity (Ptype)) = Ftyp;
3361 -- Start of processing for
3362 -- Process_Extended_Import_Export_Subprogram_Pragma
3365 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
3369 -- Loop through homonyms (overloadings) of the entity
3371 Hom_Id := Entity (Arg_Internal);
3372 while Present (Hom_Id) loop
3373 Def_Id := Get_Base_Subprogram (Hom_Id);
3375 -- We need a subprogram in the current scope
3377 if not Is_Subprogram (Def_Id)
3378 or else Scope (Def_Id) /= Current_Scope
3385 -- Pragma cannot apply to subprogram body
3387 if Is_Subprogram (Def_Id)
3388 and then Nkind (Parent (Declaration_Node (Def_Id))) =
3392 ("pragma% requires separate spec"
3393 & " and must come before body");
3396 -- Test result type if given, note that the result type
3397 -- parameter can only be present for the function cases.
3399 if Present (Arg_Result_Type)
3400 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
3404 elsif Etype (Def_Id) /= Standard_Void_Type
3406 (Pname = Name_Export_Procedure
3408 Pname = Name_Import_Procedure)
3412 -- Test parameter types if given. Note that this parameter
3413 -- has not been analyzed (and must not be, since it is
3414 -- semantic nonsense), so we get it as the parser left it.
3416 elsif Present (Arg_Parameter_Types) then
3417 Check_Matching_Types : declare
3422 Formal := First_Formal (Def_Id);
3424 if Nkind (Arg_Parameter_Types) = N_Null then
3425 if Present (Formal) then
3429 -- A list of one type, e.g. (List) is parsed as
3430 -- a parenthesized expression.
3432 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
3433 and then Paren_Count (Arg_Parameter_Types) = 1
3436 or else Present (Next_Formal (Formal))
3441 Same_Base_Type (Arg_Parameter_Types, Formal);
3444 -- A list of more than one type is parsed as a aggregate
3446 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
3447 and then Paren_Count (Arg_Parameter_Types) = 0
3449 Ptype := First (Expressions (Arg_Parameter_Types));
3450 while Present (Ptype) or else Present (Formal) loop
3453 or else not Same_Base_Type (Ptype, Formal)
3458 Next_Formal (Formal);
3463 -- Anything else is of the wrong form
3467 ("wrong form for Parameter_Types parameter",
3468 Arg_Parameter_Types);
3470 end Check_Matching_Types;
3473 -- Match is now False if the entry we found did not match
3474 -- either a supplied Parameter_Types or Result_Types argument
3480 -- Ambiguous case, the flag Ambiguous shows if we already
3481 -- detected this and output the initial messages.
3484 if not Ambiguous then
3486 Error_Msg_Name_1 := Pname;
3488 ("pragma% does not uniquely identify subprogram!",
3490 Error_Msg_Sloc := Sloc (Ent);
3491 Error_Msg_N ("matching subprogram #!", N);
3495 Error_Msg_Sloc := Sloc (Def_Id);
3496 Error_Msg_N ("matching subprogram #!", N);
3501 Hom_Id := Homonym (Hom_Id);
3504 -- See if we found an entry
3507 if not Ambiguous then
3508 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
3510 ("pragma% cannot be given for generic subprogram");
3513 ("pragma% does not identify local subprogram");
3520 -- Import pragmas must be for imported entities
3522 if Prag_Id = Pragma_Import_Function
3524 Prag_Id = Pragma_Import_Procedure
3526 Prag_Id = Pragma_Import_Valued_Procedure
3528 if not Is_Imported (Ent) then
3530 ("pragma Import or Interface must precede pragma%");
3533 -- Here we have the Export case which can set the entity as exported
3535 -- But does not do so if the specified external name is null, since
3536 -- that is taken as a signal in DEC Ada 83 (with which we want to be
3537 -- compatible) to request no external name.
3539 elsif Nkind (Arg_External) = N_String_Literal
3540 and then String_Length (Strval (Arg_External)) = 0
3544 -- In all other cases, set entity as exported
3547 Set_Exported (Ent, Arg_Internal);
3550 -- Special processing for Valued_Procedure cases
3552 if Prag_Id = Pragma_Import_Valued_Procedure
3554 Prag_Id = Pragma_Export_Valued_Procedure
3556 Formal := First_Formal (Ent);
3559 Error_Pragma ("at least one parameter required for pragma%");
3561 elsif Ekind (Formal) /= E_Out_Parameter then
3562 Error_Pragma ("first parameter must have mode out for pragma%");
3565 Set_Is_Valued_Procedure (Ent);
3569 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
3571 -- Process Result_Mechanism argument if present. We have already
3572 -- checked that this is only allowed for the function case.
3574 if Present (Arg_Result_Mechanism) then
3575 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
3578 -- Process Mechanism parameter if present. Note that this parameter
3579 -- is not analyzed, and must not be analyzed since it is semantic
3580 -- nonsense, so we get it in exactly as the parser left it.
3582 if Present (Arg_Mechanism) then
3590 -- A single mechanism association without a formal parameter
3591 -- name is parsed as a parenthesized expression. All other
3592 -- cases are parsed as aggregates, so we rewrite the single
3593 -- parameter case as an aggregate for consistency.
3595 if Nkind (Arg_Mechanism) /= N_Aggregate
3596 and then Paren_Count (Arg_Mechanism) = 1
3598 Rewrite (Arg_Mechanism,
3599 Make_Aggregate (Sloc (Arg_Mechanism),
3600 Expressions => New_List (
3601 Relocate_Node (Arg_Mechanism))));
3604 -- Case of only mechanism name given, applies to all formals
3606 if Nkind (Arg_Mechanism) /= N_Aggregate then
3607 Formal := First_Formal (Ent);
3608 while Present (Formal) loop
3609 Set_Mechanism_Value (Formal, Arg_Mechanism);
3610 Next_Formal (Formal);
3613 -- Case of list of mechanism associations given
3616 if Null_Record_Present (Arg_Mechanism) then
3618 ("inappropriate form for Mechanism parameter",
3622 -- Deal with positional ones first
3624 Formal := First_Formal (Ent);
3626 if Present (Expressions (Arg_Mechanism)) then
3627 Mname := First (Expressions (Arg_Mechanism));
3628 while Present (Mname) loop
3631 ("too many mechanism associations", Mname);
3634 Set_Mechanism_Value (Formal, Mname);
3635 Next_Formal (Formal);
3640 -- Deal with named entries
3642 if Present (Component_Associations (Arg_Mechanism)) then
3643 Massoc := First (Component_Associations (Arg_Mechanism));
3644 while Present (Massoc) loop
3645 Choice := First (Choices (Massoc));
3647 if Nkind (Choice) /= N_Identifier
3648 or else Present (Next (Choice))
3651 ("incorrect form for mechanism association",
3655 Formal := First_Formal (Ent);
3659 ("parameter name & not present", Choice);
3662 if Chars (Choice) = Chars (Formal) then
3664 (Formal, Expression (Massoc));
3666 -- Set entity on identifier (needed by ASIS)
3668 Set_Entity (Choice, Formal);
3673 Next_Formal (Formal);
3683 -- Process First_Optional_Parameter argument if present. We have
3684 -- already checked that this is only allowed for the Import case.
3686 if Present (Arg_First_Optional_Parameter) then
3687 if Nkind (Arg_First_Optional_Parameter) /= N_Identifier then
3689 ("first optional parameter must be formal parameter name",
3690 Arg_First_Optional_Parameter);
3693 Formal := First_Formal (Ent);
3697 ("specified formal parameter& not found",
3698 Arg_First_Optional_Parameter);
3701 exit when Chars (Formal) =
3702 Chars (Arg_First_Optional_Parameter);
3704 Next_Formal (Formal);
3707 Set_First_Optional_Parameter (Ent, Formal);
3709 -- Check specified and all remaining formals have right form
3711 while Present (Formal) loop
3712 if Ekind (Formal) /= E_In_Parameter then
3714 ("optional formal& is not of mode in!",
3715 Arg_First_Optional_Parameter, Formal);
3718 Dval := Default_Value (Formal);
3722 ("optional formal& does not have default value!",
3723 Arg_First_Optional_Parameter, Formal);
3725 elsif Compile_Time_Known_Value_Or_Aggr (Dval) then
3730 ("default value for optional formal& is non-static!",
3731 Arg_First_Optional_Parameter, Formal);
3735 Set_Is_Optional_Parameter (Formal);
3736 Next_Formal (Formal);
3739 end Process_Extended_Import_Export_Subprogram_Pragma;
3741 --------------------------
3742 -- Process_Generic_List --
3743 --------------------------
3745 procedure Process_Generic_List is
3750 Check_No_Identifiers;
3751 Check_At_Least_N_Arguments (1);
3754 while Present (Arg) loop
3755 Exp := Get_Pragma_Arg (Arg);
3758 if not Is_Entity_Name (Exp)
3760 (not Is_Generic_Instance (Entity (Exp))
3762 not Is_Generic_Unit (Entity (Exp)))
3765 ("pragma% argument must be name of generic unit/instance",
3771 end Process_Generic_List;
3773 ---------------------------------
3774 -- Process_Import_Or_Interface --
3775 ---------------------------------
3777 procedure Process_Import_Or_Interface is
3783 Process_Convention (C, Def_Id);
3784 Kill_Size_Check_Code (Def_Id);
3785 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
3787 if Ekind_In (Def_Id, E_Variable, E_Constant) then
3789 -- We do not permit Import to apply to a renaming declaration
3791 if Present (Renamed_Object (Def_Id)) then
3793 ("pragma% not allowed for object renaming", Arg2);
3795 -- User initialization is not allowed for imported object, but
3796 -- the object declaration may contain a default initialization,
3797 -- that will be discarded. Note that an explicit initialization
3798 -- only counts if it comes from source, otherwise it is simply
3799 -- the code generator making an implicit initialization explicit.
3801 elsif Present (Expression (Parent (Def_Id)))
3802 and then Comes_From_Source (Expression (Parent (Def_Id)))
3804 Error_Msg_Sloc := Sloc (Def_Id);
3806 ("no initialization allowed for declaration of& #",
3807 "\imported entities cannot be initialized (RM B.1(24))",
3811 Set_Imported (Def_Id);
3812 Process_Interface_Name (Def_Id, Arg3, Arg4);
3814 -- Note that we do not set Is_Public here. That's because we
3815 -- only want to set it if there is no address clause, and we
3816 -- don't know that yet, so we delay that processing till
3819 -- pragma Import completes deferred constants
3821 if Ekind (Def_Id) = E_Constant then
3822 Set_Has_Completion (Def_Id);
3825 -- It is not possible to import a constant of an unconstrained
3826 -- array type (e.g. string) because there is no simple way to
3827 -- write a meaningful subtype for it.
3829 if Is_Array_Type (Etype (Def_Id))
3830 and then not Is_Constrained (Etype (Def_Id))
3833 ("imported constant& must have a constrained subtype",
3838 elsif Is_Subprogram (Def_Id)
3839 or else Is_Generic_Subprogram (Def_Id)
3841 -- If the name is overloaded, pragma applies to all of the denoted
3842 -- entities in the same declarative part.
3845 while Present (Hom_Id) loop
3846 Def_Id := Get_Base_Subprogram (Hom_Id);
3848 -- Ignore inherited subprograms because the pragma will apply
3849 -- to the parent operation, which is the one called.
3851 if Is_Overloadable (Def_Id)
3852 and then Present (Alias (Def_Id))
3856 -- If it is not a subprogram, it must be in an outer scope and
3857 -- pragma does not apply.
3859 elsif not Is_Subprogram (Def_Id)
3860 and then not Is_Generic_Subprogram (Def_Id)
3864 -- Verify that the homonym is in the same declarative part (not
3865 -- just the same scope).
3867 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
3868 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
3873 Set_Imported (Def_Id);
3875 -- Reject an Import applied to an abstract subprogram
3877 if Is_Subprogram (Def_Id)
3878 and then Is_Abstract_Subprogram (Def_Id)
3880 Error_Msg_Sloc := Sloc (Def_Id);
3882 ("cannot import abstract subprogram& declared#",
3886 -- Special processing for Convention_Intrinsic
3888 if C = Convention_Intrinsic then
3890 -- Link_Name argument not allowed for intrinsic
3893 and then Chars (Arg3) = Name_Link_Name
3898 if Present (Arg4) then
3900 ("Link_Name argument not allowed for " &
3905 Set_Is_Intrinsic_Subprogram (Def_Id);
3907 -- If no external name is present, then check that this
3908 -- is a valid intrinsic subprogram. If an external name
3909 -- is present, then this is handled by the back end.
3912 Check_Intrinsic_Subprogram
3913 (Def_Id, Get_Pragma_Arg (Arg2));
3917 -- All interfaced procedures need an external symbol created
3918 -- for them since they are always referenced from another
3921 Set_Is_Public (Def_Id);
3923 -- Verify that the subprogram does not have a completion
3924 -- through a renaming declaration. For other completions the
3925 -- pragma appears as a too late representation.
3928 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
3932 and then Nkind (Decl) = N_Subprogram_Declaration
3933 and then Present (Corresponding_Body (Decl))
3934 and then Nkind (Unit_Declaration_Node
3935 (Corresponding_Body (Decl))) =
3936 N_Subprogram_Renaming_Declaration
3938 Error_Msg_Sloc := Sloc (Def_Id);
3940 ("cannot import&, renaming already provided for " &
3941 "declaration #", N, Def_Id);
3945 Set_Has_Completion (Def_Id);
3946 Process_Interface_Name (Def_Id, Arg3, Arg4);
3949 if Is_Compilation_Unit (Hom_Id) then
3951 -- Its possible homonyms are not affected by the pragma.
3952 -- Such homonyms might be present in the context of other
3953 -- units being compiled.
3958 Hom_Id := Homonym (Hom_Id);
3962 -- When the convention is Java or CIL, we also allow Import to be
3963 -- given for packages, generic packages, exceptions, record
3964 -- components, and access to subprograms.
3966 elsif (C = Convention_Java or else C = Convention_CIL)
3968 (Is_Package_Or_Generic_Package (Def_Id)
3969 or else Ekind (Def_Id) = E_Exception
3970 or else Ekind (Def_Id) = E_Access_Subprogram_Type
3971 or else Nkind (Parent (Def_Id)) = N_Component_Declaration)
3973 Set_Imported (Def_Id);
3974 Set_Is_Public (Def_Id);
3975 Process_Interface_Name (Def_Id, Arg3, Arg4);
3977 -- Import a CPP class
3979 elsif Is_Record_Type (Def_Id)
3980 and then C = Convention_CPP
3982 -- Types treated as CPP classes are treated as limited, but we
3983 -- don't require them to be declared this way. A warning is
3984 -- issued to encourage the user to declare them as limited.
3985 -- This is not an error, for compatibility reasons, because
3986 -- these types have been supported this way for some time.
3988 if not Is_Limited_Type (Def_Id) then
3990 ("imported 'C'P'P type should be " &
3991 "explicitly declared limited?",
3992 Get_Pragma_Arg (Arg2));
3994 ("\type will be considered limited",
3995 Get_Pragma_Arg (Arg2));
3998 Set_Is_CPP_Class (Def_Id);
3999 Set_Is_Limited_Record (Def_Id);
4001 -- Imported CPP types must not have discriminants (because C++
4002 -- classes do not have discriminants).
4004 if Has_Discriminants (Def_Id) then
4006 ("imported 'C'P'P type cannot have discriminants",
4007 First (Discriminant_Specifications
4008 (Declaration_Node (Def_Id))));
4011 -- Components of imported CPP types must not have default
4012 -- expressions because the constructor (if any) is on the
4016 Tdef : constant Node_Id :=
4017 Type_Definition (Declaration_Node (Def_Id));
4022 if Nkind (Tdef) = N_Record_Definition then
4023 Clist := Component_List (Tdef);
4026 pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition);
4027 Clist := Component_List (Record_Extension_Part (Tdef));
4030 if Present (Clist) then
4031 Comp := First (Component_Items (Clist));
4032 while Present (Comp) loop
4033 if Present (Expression (Comp)) then
4035 ("component of imported 'C'P'P type cannot have" &
4036 " default expression", Expression (Comp));
4046 ("second argument of pragma% must be object or subprogram",
4050 -- If this pragma applies to a compilation unit, then the unit, which
4051 -- is a subprogram, does not require (or allow) a body. We also do
4052 -- not need to elaborate imported procedures.
4054 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
4056 Cunit : constant Node_Id := Parent (Parent (N));
4058 Set_Body_Required (Cunit, False);
4061 end Process_Import_Or_Interface;
4063 --------------------
4064 -- Process_Inline --
4065 --------------------
4067 procedure Process_Inline (Active : Boolean) is
4073 Effective : Boolean := False;
4075 procedure Make_Inline (Subp : Entity_Id);
4076 -- Subp is the defining unit name of the subprogram declaration. Set
4077 -- the flag, as well as the flag in the corresponding body, if there
4080 procedure Set_Inline_Flags (Subp : Entity_Id);
4081 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
4082 -- Has_Pragma_Inline_Always for the Inline_Always case.
4084 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
4085 -- Returns True if it can be determined at this stage that inlining
4086 -- is not possible, for example if the body is available and contains
4087 -- exception handlers, we prevent inlining, since otherwise we can
4088 -- get undefined symbols at link time. This function also emits a
4089 -- warning if front-end inlining is enabled and the pragma appears
4092 -- ??? is business with link symbols still valid, or does it relate
4093 -- to front end ZCX which is being phased out ???
4095 ---------------------------
4096 -- Inlining_Not_Possible --
4097 ---------------------------
4099 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
4100 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
4104 if Nkind (Decl) = N_Subprogram_Body then
4105 Stats := Handled_Statement_Sequence (Decl);
4106 return Present (Exception_Handlers (Stats))
4107 or else Present (At_End_Proc (Stats));
4109 elsif Nkind (Decl) = N_Subprogram_Declaration
4110 and then Present (Corresponding_Body (Decl))
4112 if Front_End_Inlining
4113 and then Analyzed (Corresponding_Body (Decl))
4115 Error_Msg_N ("pragma appears too late, ignored?", N);
4118 -- If the subprogram is a renaming as body, the body is just a
4119 -- call to the renamed subprogram, and inlining is trivially
4123 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
4124 N_Subprogram_Renaming_Declaration
4130 Handled_Statement_Sequence
4131 (Unit_Declaration_Node (Corresponding_Body (Decl)));
4134 Present (Exception_Handlers (Stats))
4135 or else Present (At_End_Proc (Stats));
4139 -- If body is not available, assume the best, the check is
4140 -- performed again when compiling enclosing package bodies.
4144 end Inlining_Not_Possible;
4150 procedure Make_Inline (Subp : Entity_Id) is
4151 Kind : constant Entity_Kind := Ekind (Subp);
4152 Inner_Subp : Entity_Id := Subp;
4155 -- Ignore if bad type, avoid cascaded error
4157 if Etype (Subp) = Any_Type then
4161 -- Ignore if all inlining is suppressed
4163 elsif Suppress_All_Inlining then
4167 -- If inlining is not possible, for now do not treat as an error
4169 elsif Inlining_Not_Possible (Subp) then
4173 -- Here we have a candidate for inlining, but we must exclude
4174 -- derived operations. Otherwise we would end up trying to inline
4175 -- a phantom declaration, and the result would be to drag in a
4176 -- body which has no direct inlining associated with it. That
4177 -- would not only be inefficient but would also result in the
4178 -- backend doing cross-unit inlining in cases where it was
4179 -- definitely inappropriate to do so.
4181 -- However, a simple Comes_From_Source test is insufficient, since
4182 -- we do want to allow inlining of generic instances which also do
4183 -- not come from source. We also need to recognize specs generated
4184 -- by the front-end for bodies that carry the pragma. Finally,
4185 -- predefined operators do not come from source but are not
4186 -- inlineable either.
4188 elsif Is_Generic_Instance (Subp)
4189 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
4193 elsif not Comes_From_Source (Subp)
4194 and then Scope (Subp) /= Standard_Standard
4200 -- The referenced entity must either be the enclosing entity, or
4201 -- an entity declared within the current open scope.
4203 if Present (Scope (Subp))
4204 and then Scope (Subp) /= Current_Scope
4205 and then Subp /= Current_Scope
4208 ("argument of% must be entity in current scope", Assoc);
4212 -- Processing for procedure, operator or function. If subprogram
4213 -- is aliased (as for an instance) indicate that the renamed
4214 -- entity (if declared in the same unit) is inlined.
4216 if Is_Subprogram (Subp) then
4222 Inner_Subp := Ultimate_Alias (Inner_Subp);
4224 if In_Same_Source_Unit (Subp, Inner_Subp) then
4225 Set_Inline_Flags (Inner_Subp);
4227 Decl := Parent (Parent (Inner_Subp));
4229 if Nkind (Decl) = N_Subprogram_Declaration
4230 and then Present (Corresponding_Body (Decl))
4232 Set_Inline_Flags (Corresponding_Body (Decl));
4234 elsif Is_Generic_Instance (Subp) then
4236 -- Indicate that the body needs to be created for
4237 -- inlining subsequent calls. The instantiation node
4238 -- follows the declaration of the wrapper package
4241 if Scope (Subp) /= Standard_Standard
4243 Need_Subprogram_Instance_Body
4244 (Next (Unit_Declaration_Node (Scope (Alias (Subp)))),
4254 -- For a generic subprogram set flag as well, for use at the point
4255 -- of instantiation, to determine whether the body should be
4258 elsif Is_Generic_Subprogram (Subp) then
4259 Set_Inline_Flags (Subp);
4262 -- Literals are by definition inlined
4264 elsif Kind = E_Enumeration_Literal then
4267 -- Anything else is an error
4271 ("expect subprogram name for pragma%", Assoc);
4275 ----------------------
4276 -- Set_Inline_Flags --
4277 ----------------------
4279 procedure Set_Inline_Flags (Subp : Entity_Id) is
4282 Set_Is_Inlined (Subp, Sense);
4285 if not Has_Pragma_Inline (Subp) then
4286 Set_Has_Pragma_Inline (Subp, Sense);
4290 if Prag_Id = Pragma_Inline_Always then
4291 Set_Has_Pragma_Inline_Always (Subp, Sense);
4293 end Set_Inline_Flags;
4295 -- Start of processing for Process_Inline
4298 Check_No_Identifiers;
4299 Check_At_Least_N_Arguments (1);
4302 Inline_Processing_Required := True;
4306 while Present (Assoc) loop
4307 Subp_Id := Get_Pragma_Arg (Assoc);
4311 if Is_Entity_Name (Subp_Id) then
4312 Subp := Entity (Subp_Id);
4314 if Subp = Any_Id then
4316 -- If previous error, avoid cascaded errors
4324 if not From_Aspect_Specification (N) then
4325 while Present (Homonym (Subp))
4326 and then Scope (Homonym (Subp)) = Current_Scope
4328 Make_Inline (Homonym (Subp));
4329 Subp := Homonym (Subp);
4337 ("inappropriate argument for pragma%", Assoc);
4340 and then Warn_On_Redundant_Constructs
4341 and then not Suppress_All_Inlining
4343 if Inlining_Not_Possible (Subp) then
4345 ("pragma Inline for& is ignored?", N, Entity (Subp_Id));
4348 ("pragma Inline for& is redundant?", N, Entity (Subp_Id));
4356 ----------------------------
4357 -- Process_Interface_Name --
4358 ----------------------------
4360 procedure Process_Interface_Name
4361 (Subprogram_Def : Entity_Id;
4367 String_Val : String_Id;
4369 procedure Check_Form_Of_Interface_Name
4371 Ext_Name_Case : Boolean);
4372 -- SN is a string literal node for an interface name. This routine
4373 -- performs some minimal checks that the name is reasonable. In
4374 -- particular that no spaces or other obviously incorrect characters
4375 -- appear. This is only a warning, since any characters are allowed.
4376 -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
4378 ----------------------------------
4379 -- Check_Form_Of_Interface_Name --
4380 ----------------------------------
4382 procedure Check_Form_Of_Interface_Name
4384 Ext_Name_Case : Boolean)
4386 S : constant String_Id := Strval (Expr_Value_S (SN));
4387 SL : constant Nat := String_Length (S);
4392 Error_Msg_N ("interface name cannot be null string", SN);
4395 for J in 1 .. SL loop
4396 C := Get_String_Char (S, J);
4398 -- Look for dubious character and issue unconditional warning.
4399 -- Definitely dubious if not in character range.
4401 if not In_Character_Range (C)
4403 -- For all cases except CLI target,
4404 -- commas, spaces and slashes are dubious (in CLI, we use
4405 -- commas and backslashes in external names to specify
4406 -- assembly version and public key, while slashes and spaces
4407 -- can be used in names to mark nested classes and
4410 or else ((not Ext_Name_Case or else VM_Target /= CLI_Target)
4411 and then (Get_Character (C) = ','
4413 Get_Character (C) = '\'))
4414 or else (VM_Target /= CLI_Target
4415 and then (Get_Character (C) = ' '
4417 Get_Character (C) = '/'))
4420 ("?interface name contains illegal character",
4421 Sloc (SN) + Source_Ptr (J));
4424 end Check_Form_Of_Interface_Name;
4426 -- Start of processing for Process_Interface_Name
4429 if No (Link_Arg) then
4430 if No (Ext_Arg) then
4431 if VM_Target = CLI_Target
4432 and then Ekind (Subprogram_Def) = E_Package
4433 and then Nkind (Parent (Subprogram_Def)) =
4434 N_Package_Specification
4435 and then Present (Generic_Parent (Parent (Subprogram_Def)))
4440 (Generic_Parent (Parent (Subprogram_Def))));
4445 elsif Chars (Ext_Arg) = Name_Link_Name then
4447 Link_Nam := Expression (Ext_Arg);
4450 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
4451 Ext_Nam := Expression (Ext_Arg);
4456 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
4457 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
4458 Ext_Nam := Expression (Ext_Arg);
4459 Link_Nam := Expression (Link_Arg);
4462 -- Check expressions for external name and link name are static
4464 if Present (Ext_Nam) then
4465 Check_Arg_Is_Static_Expression (Ext_Nam, Standard_String);
4466 Check_Form_Of_Interface_Name (Ext_Nam, Ext_Name_Case => True);
4468 -- Verify that external name is not the name of a local entity,
4469 -- which would hide the imported one and could lead to run-time
4470 -- surprises. The problem can only arise for entities declared in
4471 -- a package body (otherwise the external name is fully qualified
4472 -- and will not conflict).
4480 if Prag_Id = Pragma_Import then
4481 String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam)));
4483 E := Entity_Id (Get_Name_Table_Info (Nam));
4485 if Nam /= Chars (Subprogram_Def)
4486 and then Present (E)
4487 and then not Is_Overloadable (E)
4488 and then Is_Immediately_Visible (E)
4489 and then not Is_Imported (E)
4490 and then Ekind (Scope (E)) = E_Package
4493 while Present (Par) loop
4494 if Nkind (Par) = N_Package_Body then
4495 Error_Msg_Sloc := Sloc (E);
4497 ("imported entity is hidden by & declared#",
4502 Par := Parent (Par);
4509 if Present (Link_Nam) then
4510 Check_Arg_Is_Static_Expression (Link_Nam, Standard_String);
4511 Check_Form_Of_Interface_Name (Link_Nam, Ext_Name_Case => False);
4514 -- If there is no link name, just set the external name
4516 if No (Link_Nam) then
4517 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
4519 -- For the Link_Name case, the given literal is preceded by an
4520 -- asterisk, which indicates to GCC that the given name should be
4521 -- taken literally, and in particular that no prepending of
4522 -- underlines should occur, even in systems where this is the
4528 if VM_Target = No_VM then
4529 Store_String_Char (Get_Char_Code ('*'));
4532 String_Val := Strval (Expr_Value_S (Link_Nam));
4533 Store_String_Chars (String_Val);
4535 Make_String_Literal (Sloc (Link_Nam),
4536 Strval => End_String);
4539 Set_Encoded_Interface_Name
4540 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
4542 -- We allow duplicated export names in CIL, as they are always
4543 -- enclosed in a namespace that differentiates them, and overloaded
4544 -- entities are supported by the VM.
4546 if Convention (Subprogram_Def) /= Convention_CIL then
4547 Check_Duplicated_Export_Name (Link_Nam);
4549 end Process_Interface_Name;
4551 -----------------------------------------
4552 -- Process_Interrupt_Or_Attach_Handler --
4553 -----------------------------------------
4555 procedure Process_Interrupt_Or_Attach_Handler is
4556 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
4557 Handler_Proc : constant Entity_Id := Entity (Arg1_X);
4558 Proc_Scope : constant Entity_Id := Scope (Handler_Proc);
4561 Set_Is_Interrupt_Handler (Handler_Proc);
4563 -- If the pragma is not associated with a handler procedure within a
4564 -- protected type, then it must be for a nonprotected procedure for
4565 -- the AAMP target, in which case we don't associate a representation
4566 -- item with the procedure's scope.
4568 if Ekind (Proc_Scope) = E_Protected_Type then
4569 if Prag_Id = Pragma_Interrupt_Handler
4571 Prag_Id = Pragma_Attach_Handler
4573 Record_Rep_Item (Proc_Scope, N);
4576 end Process_Interrupt_Or_Attach_Handler;
4578 --------------------------------------------------
4579 -- Process_Restrictions_Or_Restriction_Warnings --
4580 --------------------------------------------------
4582 -- Note: some of the simple identifier cases were handled in par-prag,
4583 -- but it is harmless (and more straightforward) to simply handle all
4584 -- cases here, even if it means we repeat a bit of work in some cases.
4586 procedure Process_Restrictions_Or_Restriction_Warnings
4590 R_Id : Restriction_Id;
4595 procedure Check_Unit_Name (N : Node_Id);
4596 -- Checks unit name parameter for No_Dependence. Returns if it has
4597 -- an appropriate form, otherwise raises pragma argument error.
4599 ---------------------
4600 -- Check_Unit_Name --
4601 ---------------------
4603 procedure Check_Unit_Name (N : Node_Id) is
4605 if Nkind (N) = N_Selected_Component then
4606 Check_Unit_Name (Prefix (N));
4607 Check_Unit_Name (Selector_Name (N));
4609 elsif Nkind (N) = N_Identifier then
4614 ("wrong form for unit name for No_Dependence", N);
4616 end Check_Unit_Name;
4618 -- Start of processing for Process_Restrictions_Or_Restriction_Warnings
4621 -- Ignore all Restrictions pragma in CodePeer mode
4623 if CodePeer_Mode then
4627 Check_Ada_83_Warning;
4628 Check_At_Least_N_Arguments (1);
4629 Check_Valid_Configuration_Pragma;
4632 while Present (Arg) loop
4634 Expr := Get_Pragma_Arg (Arg);
4636 -- Case of no restriction identifier present
4638 if Id = No_Name then
4639 if Nkind (Expr) /= N_Identifier then
4641 ("invalid form for restriction", Arg);
4646 (Process_Restriction_Synonyms (Expr));
4648 if R_Id not in All_Boolean_Restrictions then
4649 Error_Msg_Name_1 := Pname;
4651 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
4653 -- Check for possible misspelling
4655 for J in Restriction_Id loop
4657 Rnm : constant String := Restriction_Id'Image (J);
4660 Name_Buffer (1 .. Rnm'Length) := Rnm;
4661 Name_Len := Rnm'Length;
4662 Set_Casing (All_Lower_Case);
4664 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
4666 (Identifier_Casing (Current_Source_File));
4667 Error_Msg_String (1 .. Rnm'Length) :=
4668 Name_Buffer (1 .. Name_Len);
4669 Error_Msg_Strlen := Rnm'Length;
4670 Error_Msg_N -- CODEFIX
4671 ("\possible misspelling of ""~""",
4672 Get_Pragma_Arg (Arg));
4681 if Implementation_Restriction (R_Id) then
4682 Check_Restriction (No_Implementation_Restrictions, Arg);
4685 -- If this is a warning, then set the warning unless we already
4686 -- have a real restriction active (we never want a warning to
4687 -- override a real restriction).
4690 if not Restriction_Active (R_Id) then
4691 Set_Restriction (R_Id, N);
4692 Restriction_Warnings (R_Id) := True;
4695 -- If real restriction case, then set it and make sure that the
4696 -- restriction warning flag is off, since a real restriction
4697 -- always overrides a warning.
4700 Set_Restriction (R_Id, N);
4701 Restriction_Warnings (R_Id) := False;
4704 -- Check for obsolescent restrictions in Ada 2005 mode
4707 and then Ada_Version >= Ada_2005
4708 and then (R_Id = No_Asynchronous_Control
4710 R_Id = No_Unchecked_Deallocation
4712 R_Id = No_Unchecked_Conversion)
4714 Check_Restriction (No_Obsolescent_Features, N);
4717 -- A very special case that must be processed here: pragma
4718 -- Restrictions (No_Exceptions) turns off all run-time
4719 -- checking. This is a bit dubious in terms of the formal
4720 -- language definition, but it is what is intended by RM
4721 -- H.4(12). Restriction_Warnings never affects generated code
4722 -- so this is done only in the real restriction case.
4724 if R_Id = No_Exceptions and then not Warn then
4725 Scope_Suppress := (others => True);
4728 -- Case of No_Dependence => unit-name. Note that the parser
4729 -- already made the necessary entry in the No_Dependence table.
4731 elsif Id = Name_No_Dependence then
4732 Check_Unit_Name (Expr);
4734 -- All other cases of restriction identifier present
4737 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
4738 Analyze_And_Resolve (Expr, Any_Integer);
4740 if R_Id not in All_Parameter_Restrictions then
4742 ("invalid restriction parameter identifier", Arg);
4744 elsif not Is_OK_Static_Expression (Expr) then
4745 Flag_Non_Static_Expr
4746 ("value must be static expression!", Expr);
4749 elsif not Is_Integer_Type (Etype (Expr))
4750 or else Expr_Value (Expr) < 0
4753 ("value must be non-negative integer", Arg);
4756 -- Restriction pragma is active
4758 Val := Expr_Value (Expr);
4760 if not UI_Is_In_Int_Range (Val) then
4762 ("pragma ignored, value too large?", Arg);
4765 -- Warning case. If the real restriction is active, then we
4766 -- ignore the request, since warning never overrides a real
4767 -- restriction. Otherwise we set the proper warning. Note that
4768 -- this circuit sets the warning again if it is already set,
4769 -- which is what we want, since the constant may have changed.
4772 if not Restriction_Active (R_Id) then
4774 (R_Id, N, Integer (UI_To_Int (Val)));
4775 Restriction_Warnings (R_Id) := True;
4778 -- Real restriction case, set restriction and make sure warning
4779 -- flag is off since real restriction always overrides warning.
4782 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
4783 Restriction_Warnings (R_Id) := False;
4789 end Process_Restrictions_Or_Restriction_Warnings;
4791 ---------------------------------
4792 -- Process_Suppress_Unsuppress --
4793 ---------------------------------
4795 -- Note: this procedure makes entries in the check suppress data
4796 -- structures managed by Sem. See spec of package Sem for full
4797 -- details on how we handle recording of check suppression.
4799 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
4804 In_Package_Spec : constant Boolean :=
4805 Is_Package_Or_Generic_Package (Current_Scope)
4806 and then not In_Package_Body (Current_Scope);
4808 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
4809 -- Used to suppress a single check on the given entity
4811 --------------------------------
4812 -- Suppress_Unsuppress_Echeck --
4813 --------------------------------
4815 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
4817 Set_Checks_May_Be_Suppressed (E);
4819 if In_Package_Spec then
4820 Push_Global_Suppress_Stack_Entry
4823 Suppress => Suppress_Case);
4826 Push_Local_Suppress_Stack_Entry
4829 Suppress => Suppress_Case);
4832 -- If this is a first subtype, and the base type is distinct,
4833 -- then also set the suppress flags on the base type.
4835 if Is_First_Subtype (E)
4836 and then Etype (E) /= E
4838 Suppress_Unsuppress_Echeck (Etype (E), C);
4840 end Suppress_Unsuppress_Echeck;
4842 -- Start of processing for Process_Suppress_Unsuppress
4845 -- Ignore pragma Suppress/Unsuppress in codepeer mode on user code:
4846 -- we want to generate checks for analysis purposes, as set by -gnatC
4848 if CodePeer_Mode and then Comes_From_Source (N) then
4852 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
4853 -- declarative part or a package spec (RM 11.5(5)).
4855 if not Is_Configuration_Pragma then
4856 Check_Is_In_Decl_Part_Or_Package_Spec;
4859 Check_At_Least_N_Arguments (1);
4860 Check_At_Most_N_Arguments (2);
4861 Check_No_Identifier (Arg1);
4862 Check_Arg_Is_Identifier (Arg1);
4864 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
4866 if C = No_Check_Id then
4868 ("argument of pragma% is not valid check name", Arg1);
4871 if not Suppress_Case
4872 and then (C = All_Checks or else C = Overflow_Check)
4874 Opt.Overflow_Checks_Unsuppressed := True;
4877 if Arg_Count = 1 then
4879 -- Make an entry in the local scope suppress table. This is the
4880 -- table that directly shows the current value of the scope
4881 -- suppress check for any check id value.
4883 if C = All_Checks then
4885 -- For All_Checks, we set all specific predefined checks with
4886 -- the exception of Elaboration_Check, which is handled
4887 -- specially because of not wanting All_Checks to have the
4888 -- effect of deactivating static elaboration order processing.
4890 for J in Scope_Suppress'Range loop
4891 if J /= Elaboration_Check then
4892 Scope_Suppress (J) := Suppress_Case;
4896 -- If not All_Checks, and predefined check, then set appropriate
4897 -- scope entry. Note that we will set Elaboration_Check if this
4898 -- is explicitly specified.
4900 elsif C in Predefined_Check_Id then
4901 Scope_Suppress (C) := Suppress_Case;
4904 -- Also make an entry in the Local_Entity_Suppress table
4906 Push_Local_Suppress_Stack_Entry
4909 Suppress => Suppress_Case);
4911 -- Case of two arguments present, where the check is suppressed for
4912 -- a specified entity (given as the second argument of the pragma)
4915 -- This is obsolescent in Ada 2005 mode
4917 if Ada_Version >= Ada_2005 then
4918 Check_Restriction (No_Obsolescent_Features, Arg2);
4921 Check_Optional_Identifier (Arg2, Name_On);
4922 E_Id := Get_Pragma_Arg (Arg2);
4925 if not Is_Entity_Name (E_Id) then
4927 ("second argument of pragma% must be entity name", Arg2);
4936 -- Enforce RM 11.5(7) which requires that for a pragma that
4937 -- appears within a package spec, the named entity must be
4938 -- within the package spec. We allow the package name itself
4939 -- to be mentioned since that makes sense, although it is not
4940 -- strictly allowed by 11.5(7).
4943 and then E /= Current_Scope
4944 and then Scope (E) /= Current_Scope
4947 ("entity in pragma% is not in package spec (RM 11.5(7))",
4951 -- Loop through homonyms. As noted below, in the case of a package
4952 -- spec, only homonyms within the package spec are considered.
4955 Suppress_Unsuppress_Echeck (E, C);
4957 if Is_Generic_Instance (E)
4958 and then Is_Subprogram (E)
4959 and then Present (Alias (E))
4961 Suppress_Unsuppress_Echeck (Alias (E), C);
4964 -- Move to next homonym if not aspect spec case
4966 exit when From_Aspect_Specification (N);
4970 -- If we are within a package specification, the pragma only
4971 -- applies to homonyms in the same scope.
4973 exit when In_Package_Spec
4974 and then Scope (E) /= Current_Scope;
4977 end Process_Suppress_Unsuppress;
4983 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
4985 if Is_Imported (E) then
4987 ("cannot export entity& that was previously imported", Arg);
4989 elsif Present (Address_Clause (E)) and then not CodePeer_Mode then
4991 ("cannot export entity& that has an address clause", Arg);
4994 Set_Is_Exported (E);
4996 -- Generate a reference for entity explicitly, because the
4997 -- identifier may be overloaded and name resolution will not
5000 Generate_Reference (E, Arg);
5002 -- Deal with exporting non-library level entity
5004 if not Is_Library_Level_Entity (E) then
5006 -- Not allowed at all for subprograms
5008 if Is_Subprogram (E) then
5009 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
5011 -- Otherwise set public and statically allocated
5015 Set_Is_Statically_Allocated (E);
5017 -- Warn if the corresponding W flag is set and the pragma comes
5018 -- from source. The latter may not be true e.g. on VMS where we
5019 -- expand export pragmas for exception codes associated with
5020 -- imported or exported exceptions. We do not want to generate
5021 -- a warning for something that the user did not write.
5023 if Warn_On_Export_Import
5024 and then Comes_From_Source (Arg)
5027 ("?& has been made static as a result of Export", Arg, E);
5029 ("\this usage is non-standard and non-portable", Arg);
5034 if Warn_On_Export_Import and then Is_Type (E) then
5035 Error_Msg_NE ("exporting a type has no effect?", Arg, E);
5038 if Warn_On_Export_Import and Inside_A_Generic then
5040 ("all instances of& will have the same external name?", Arg, E);
5044 ----------------------------------------------
5045 -- Set_Extended_Import_Export_External_Name --
5046 ----------------------------------------------
5048 procedure Set_Extended_Import_Export_External_Name
5049 (Internal_Ent : Entity_Id;
5050 Arg_External : Node_Id)
5052 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
5056 if No (Arg_External) then
5060 Check_Arg_Is_External_Name (Arg_External);
5062 if Nkind (Arg_External) = N_String_Literal then
5063 if String_Length (Strval (Arg_External)) = 0 then
5066 New_Name := Adjust_External_Name_Case (Arg_External);
5069 elsif Nkind (Arg_External) = N_Identifier then
5070 New_Name := Get_Default_External_Name (Arg_External);
5072 -- Check_Arg_Is_External_Name should let through only identifiers and
5073 -- string literals or static string expressions (which are folded to
5074 -- string literals).
5077 raise Program_Error;
5080 -- If we already have an external name set (by a prior normal Import
5081 -- or Export pragma), then the external names must match
5083 if Present (Interface_Name (Internal_Ent)) then
5084 Check_Matching_Internal_Names : declare
5085 S1 : constant String_Id := Strval (Old_Name);
5086 S2 : constant String_Id := Strval (New_Name);
5089 -- Called if names do not match
5095 procedure Mismatch is
5097 Error_Msg_Sloc := Sloc (Old_Name);
5099 ("external name does not match that given #",
5103 -- Start of processing for Check_Matching_Internal_Names
5106 if String_Length (S1) /= String_Length (S2) then
5110 for J in 1 .. String_Length (S1) loop
5111 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
5116 end Check_Matching_Internal_Names;
5118 -- Otherwise set the given name
5121 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
5122 Check_Duplicated_Export_Name (New_Name);
5124 end Set_Extended_Import_Export_External_Name;
5130 procedure Set_Imported (E : Entity_Id) is
5132 -- Error message if already imported or exported
5134 if Is_Exported (E) or else Is_Imported (E) then
5136 -- Error if being set Exported twice
5138 if Is_Exported (E) then
5139 Error_Msg_NE ("entity& was previously exported", N, E);
5141 -- OK if Import/Interface case
5143 elsif Import_Interface_Present (N) then
5146 -- Error if being set Imported twice
5149 Error_Msg_NE ("entity& was previously imported", N, E);
5152 Error_Msg_Name_1 := Pname;
5154 ("\(pragma% applies to all previous entities)", N);
5156 Error_Msg_Sloc := Sloc (E);
5157 Error_Msg_NE ("\import not allowed for& declared#", N, E);
5159 -- Here if not previously imported or exported, OK to import
5162 Set_Is_Imported (E);
5164 -- If the entity is an object that is not at the library level,
5165 -- then it is statically allocated. We do not worry about objects
5166 -- with address clauses in this context since they are not really
5167 -- imported in the linker sense.
5170 and then not Is_Library_Level_Entity (E)
5171 and then No (Address_Clause (E))
5173 Set_Is_Statically_Allocated (E);
5180 -------------------------
5181 -- Set_Mechanism_Value --
5182 -------------------------
5184 -- Note: the mechanism name has not been analyzed (and cannot indeed be
5185 -- analyzed, since it is semantic nonsense), so we get it in the exact
5186 -- form created by the parser.
5188 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
5191 Mech_Name_Id : Name_Id;
5193 procedure Bad_Class;
5194 -- Signal bad descriptor class name
5196 procedure Bad_Mechanism;
5197 -- Signal bad mechanism name
5203 procedure Bad_Class is
5205 Error_Pragma_Arg ("unrecognized descriptor class name", Class);
5208 -------------------------
5209 -- Bad_Mechanism_Value --
5210 -------------------------
5212 procedure Bad_Mechanism is
5214 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
5217 -- Start of processing for Set_Mechanism_Value
5220 if Mechanism (Ent) /= Default_Mechanism then
5222 ("mechanism for & has already been set", Mech_Name, Ent);
5225 -- MECHANISM_NAME ::= value | reference | descriptor |
5228 if Nkind (Mech_Name) = N_Identifier then
5229 if Chars (Mech_Name) = Name_Value then
5230 Set_Mechanism (Ent, By_Copy);
5233 elsif Chars (Mech_Name) = Name_Reference then
5234 Set_Mechanism (Ent, By_Reference);
5237 elsif Chars (Mech_Name) = Name_Descriptor then
5238 Check_VMS (Mech_Name);
5240 -- Descriptor => Short_Descriptor if pragma was given
5242 if Short_Descriptors then
5243 Set_Mechanism (Ent, By_Short_Descriptor);
5245 Set_Mechanism (Ent, By_Descriptor);
5250 elsif Chars (Mech_Name) = Name_Short_Descriptor then
5251 Check_VMS (Mech_Name);
5252 Set_Mechanism (Ent, By_Short_Descriptor);
5255 elsif Chars (Mech_Name) = Name_Copy then
5257 ("bad mechanism name, Value assumed", Mech_Name);
5263 -- MECHANISM_NAME ::= descriptor (CLASS_NAME) |
5264 -- short_descriptor (CLASS_NAME)
5265 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
5267 -- Note: this form is parsed as an indexed component
5269 elsif Nkind (Mech_Name) = N_Indexed_Component then
5270 Class := First (Expressions (Mech_Name));
5272 if Nkind (Prefix (Mech_Name)) /= N_Identifier
5273 or else not (Chars (Prefix (Mech_Name)) = Name_Descriptor or else
5274 Chars (Prefix (Mech_Name)) = Name_Short_Descriptor)
5275 or else Present (Next (Class))
5279 Mech_Name_Id := Chars (Prefix (Mech_Name));
5281 -- Change Descriptor => Short_Descriptor if pragma was given
5283 if Mech_Name_Id = Name_Descriptor
5284 and then Short_Descriptors
5286 Mech_Name_Id := Name_Short_Descriptor;
5290 -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) |
5291 -- short_descriptor (Class => CLASS_NAME)
5292 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
5294 -- Note: this form is parsed as a function call
5296 elsif Nkind (Mech_Name) = N_Function_Call then
5297 Param := First (Parameter_Associations (Mech_Name));
5299 if Nkind (Name (Mech_Name)) /= N_Identifier
5300 or else not (Chars (Name (Mech_Name)) = Name_Descriptor or else
5301 Chars (Name (Mech_Name)) = Name_Short_Descriptor)
5302 or else Present (Next (Param))
5303 or else No (Selector_Name (Param))
5304 or else Chars (Selector_Name (Param)) /= Name_Class
5308 Class := Explicit_Actual_Parameter (Param);
5309 Mech_Name_Id := Chars (Name (Mech_Name));
5316 -- Fall through here with Class set to descriptor class name
5318 Check_VMS (Mech_Name);
5320 if Nkind (Class) /= N_Identifier then
5323 elsif Mech_Name_Id = Name_Descriptor
5324 and then Chars (Class) = Name_UBS
5326 Set_Mechanism (Ent, By_Descriptor_UBS);
5328 elsif Mech_Name_Id = Name_Descriptor
5329 and then Chars (Class) = Name_UBSB
5331 Set_Mechanism (Ent, By_Descriptor_UBSB);
5333 elsif Mech_Name_Id = Name_Descriptor
5334 and then Chars (Class) = Name_UBA
5336 Set_Mechanism (Ent, By_Descriptor_UBA);
5338 elsif Mech_Name_Id = Name_Descriptor
5339 and then Chars (Class) = Name_S
5341 Set_Mechanism (Ent, By_Descriptor_S);
5343 elsif Mech_Name_Id = Name_Descriptor
5344 and then Chars (Class) = Name_SB
5346 Set_Mechanism (Ent, By_Descriptor_SB);
5348 elsif Mech_Name_Id = Name_Descriptor
5349 and then Chars (Class) = Name_A
5351 Set_Mechanism (Ent, By_Descriptor_A);
5353 elsif Mech_Name_Id = Name_Descriptor
5354 and then Chars (Class) = Name_NCA
5356 Set_Mechanism (Ent, By_Descriptor_NCA);
5358 elsif Mech_Name_Id = Name_Short_Descriptor
5359 and then Chars (Class) = Name_UBS
5361 Set_Mechanism (Ent, By_Short_Descriptor_UBS);
5363 elsif Mech_Name_Id = Name_Short_Descriptor
5364 and then Chars (Class) = Name_UBSB
5366 Set_Mechanism (Ent, By_Short_Descriptor_UBSB);
5368 elsif Mech_Name_Id = Name_Short_Descriptor
5369 and then Chars (Class) = Name_UBA
5371 Set_Mechanism (Ent, By_Short_Descriptor_UBA);
5373 elsif Mech_Name_Id = Name_Short_Descriptor
5374 and then Chars (Class) = Name_S
5376 Set_Mechanism (Ent, By_Short_Descriptor_S);
5378 elsif Mech_Name_Id = Name_Short_Descriptor
5379 and then Chars (Class) = Name_SB
5381 Set_Mechanism (Ent, By_Short_Descriptor_SB);
5383 elsif Mech_Name_Id = Name_Short_Descriptor
5384 and then Chars (Class) = Name_A
5386 Set_Mechanism (Ent, By_Short_Descriptor_A);
5388 elsif Mech_Name_Id = Name_Short_Descriptor
5389 and then Chars (Class) = Name_NCA
5391 Set_Mechanism (Ent, By_Short_Descriptor_NCA);
5396 end Set_Mechanism_Value;
5398 ---------------------------
5399 -- Set_Ravenscar_Profile --
5400 ---------------------------
5402 -- The tasks to be done here are
5404 -- Set required policies
5406 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
5407 -- pragma Locking_Policy (Ceiling_Locking)
5409 -- Set Detect_Blocking mode
5411 -- Set required restrictions (see System.Rident for detailed list)
5413 -- Set the No_Dependence rules
5414 -- No_Dependence => Ada.Asynchronous_Task_Control
5415 -- No_Dependence => Ada.Calendar
5416 -- No_Dependence => Ada.Execution_Time.Group_Budget
5417 -- No_Dependence => Ada.Execution_Time.Timers
5418 -- No_Dependence => Ada.Task_Attributes
5419 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
5421 procedure Set_Ravenscar_Profile (N : Node_Id) is
5422 Prefix_Entity : Entity_Id;
5423 Selector_Entity : Entity_Id;
5424 Prefix_Node : Node_Id;
5428 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
5430 if Task_Dispatching_Policy /= ' '
5431 and then Task_Dispatching_Policy /= 'F'
5433 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
5434 Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
5436 -- Set the FIFO_Within_Priorities policy, but always preserve
5437 -- System_Location since we like the error message with the run time
5441 Task_Dispatching_Policy := 'F';
5443 if Task_Dispatching_Policy_Sloc /= System_Location then
5444 Task_Dispatching_Policy_Sloc := Loc;
5448 -- pragma Locking_Policy (Ceiling_Locking)
5450 if Locking_Policy /= ' '
5451 and then Locking_Policy /= 'C'
5453 Error_Msg_Sloc := Locking_Policy_Sloc;
5454 Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
5456 -- Set the Ceiling_Locking policy, but preserve System_Location since
5457 -- we like the error message with the run time name.
5460 Locking_Policy := 'C';
5462 if Locking_Policy_Sloc /= System_Location then
5463 Locking_Policy_Sloc := Loc;
5467 -- pragma Detect_Blocking
5469 Detect_Blocking := True;
5471 -- Set the corresponding restrictions
5473 Set_Profile_Restrictions
5474 (Ravenscar, N, Warn => Treat_Restrictions_As_Warnings);
5476 -- Set the No_Dependence restrictions
5478 -- The following No_Dependence restrictions:
5479 -- No_Dependence => Ada.Asynchronous_Task_Control
5480 -- No_Dependence => Ada.Calendar
5481 -- No_Dependence => Ada.Task_Attributes
5482 -- are already set by previous call to Set_Profile_Restrictions.
5484 -- Set the following restrictions which were added to Ada 2005:
5485 -- No_Dependence => Ada.Execution_Time.Group_Budget
5486 -- No_Dependence => Ada.Execution_Time.Timers
5488 if Ada_Version >= Ada_2005 then
5489 Name_Buffer (1 .. 3) := "ada";
5492 Prefix_Entity := Make_Identifier (Loc, Name_Find);
5494 Name_Buffer (1 .. 14) := "execution_time";
5497 Selector_Entity := Make_Identifier (Loc, Name_Find);
5500 Make_Selected_Component
5502 Prefix => Prefix_Entity,
5503 Selector_Name => Selector_Entity);
5505 Name_Buffer (1 .. 13) := "group_budgets";
5508 Selector_Entity := Make_Identifier (Loc, Name_Find);
5511 Make_Selected_Component
5513 Prefix => Prefix_Node,
5514 Selector_Name => Selector_Entity);
5516 Set_Restriction_No_Dependence
5518 Warn => Treat_Restrictions_As_Warnings,
5519 Profile => Ravenscar);
5521 Name_Buffer (1 .. 6) := "timers";
5524 Selector_Entity := Make_Identifier (Loc, Name_Find);
5527 Make_Selected_Component
5529 Prefix => Prefix_Node,
5530 Selector_Name => Selector_Entity);
5532 Set_Restriction_No_Dependence
5534 Warn => Treat_Restrictions_As_Warnings,
5535 Profile => Ravenscar);
5538 -- Set the following restrictions which was added to Ada 2012 (see
5540 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
5542 if Ada_Version >= Ada_2012 then
5543 Name_Buffer (1 .. 6) := "system";
5546 Prefix_Entity := Make_Identifier (Loc, Name_Find);
5548 Name_Buffer (1 .. 15) := "multiprocessors";
5551 Selector_Entity := Make_Identifier (Loc, Name_Find);
5554 Make_Selected_Component
5556 Prefix => Prefix_Entity,
5557 Selector_Name => Selector_Entity);
5559 Name_Buffer (1 .. 19) := "dispatching_domains";
5562 Selector_Entity := Make_Identifier (Loc, Name_Find);
5565 Make_Selected_Component
5567 Prefix => Prefix_Node,
5568 Selector_Name => Selector_Entity);
5570 Set_Restriction_No_Dependence
5572 Warn => Treat_Restrictions_As_Warnings,
5573 Profile => Ravenscar);
5575 end Set_Ravenscar_Profile;
5577 -- Start of processing for Analyze_Pragma
5580 -- Deal with unrecognized pragma
5582 if not Is_Pragma_Name (Pname) then
5583 if Warn_On_Unrecognized_Pragma then
5584 Error_Msg_Name_1 := Pname;
5585 Error_Msg_N ("?unrecognized pragma%!", Pragma_Identifier (N));
5587 for PN in First_Pragma_Name .. Last_Pragma_Name loop
5588 if Is_Bad_Spelling_Of (Pname, PN) then
5589 Error_Msg_Name_1 := PN;
5590 Error_Msg_N -- CODEFIX
5591 ("\?possible misspelling of %!", Pragma_Identifier (N));
5600 -- Here to start processing for recognized pragma
5602 Prag_Id := Get_Pragma_Id (Pname);
5611 if Present (Pragma_Argument_Associations (N)) then
5612 Arg1 := First (Pragma_Argument_Associations (N));
5614 if Present (Arg1) then
5615 Arg2 := Next (Arg1);
5617 if Present (Arg2) then
5618 Arg3 := Next (Arg2);
5620 if Present (Arg3) then
5621 Arg4 := Next (Arg3);
5627 -- Count number of arguments
5634 while Present (Arg_Node) loop
5635 Arg_Count := Arg_Count + 1;
5640 -- An enumeration type defines the pragmas that are supported by the
5641 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
5642 -- into the corresponding enumeration value for the following case.
5650 -- pragma Abort_Defer;
5652 when Pragma_Abort_Defer =>
5654 Check_Arg_Count (0);
5656 -- The only required semantic processing is to check the
5657 -- placement. This pragma must appear at the start of the
5658 -- statement sequence of a handled sequence of statements.
5660 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
5661 or else N /= First (Statements (Parent (N)))
5672 -- Note: this pragma also has some specific processing in Par.Prag
5673 -- because we want to set the Ada version mode during parsing.
5675 when Pragma_Ada_83 =>
5677 Check_Arg_Count (0);
5679 -- We really should check unconditionally for proper configuration
5680 -- pragma placement, since we really don't want mixed Ada modes
5681 -- within a single unit, and the GNAT reference manual has always
5682 -- said this was a configuration pragma, but we did not check and
5683 -- are hesitant to add the check now.
5685 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
5686 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
5687 -- or Ada 2012 mode.
5689 if Ada_Version >= Ada_2005 then
5690 Check_Valid_Configuration_Pragma;
5693 -- Now set Ada 83 mode
5695 Ada_Version := Ada_83;
5696 Ada_Version_Explicit := Ada_Version;
5704 -- Note: this pragma also has some specific processing in Par.Prag
5705 -- because we want to set the Ada 83 version mode during parsing.
5707 when Pragma_Ada_95 =>
5709 Check_Arg_Count (0);
5711 -- We really should check unconditionally for proper configuration
5712 -- pragma placement, since we really don't want mixed Ada modes
5713 -- within a single unit, and the GNAT reference manual has always
5714 -- said this was a configuration pragma, but we did not check and
5715 -- are hesitant to add the check now.
5717 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
5718 -- or Ada 95, so we must check if we are in Ada 2005 mode.
5720 if Ada_Version >= Ada_2005 then
5721 Check_Valid_Configuration_Pragma;
5724 -- Now set Ada 95 mode
5726 Ada_Version := Ada_95;
5727 Ada_Version_Explicit := Ada_Version;
5729 ---------------------
5730 -- Ada_05/Ada_2005 --
5731 ---------------------
5734 -- pragma Ada_05 (LOCAL_NAME);
5737 -- pragma Ada_2005 (LOCAL_NAME):
5739 -- Note: these pragmas also have some specific processing in Par.Prag
5740 -- because we want to set the Ada 2005 version mode during parsing.
5742 when Pragma_Ada_05 | Pragma_Ada_2005 => declare
5748 if Arg_Count = 1 then
5749 Check_Arg_Is_Local_Name (Arg1);
5750 E_Id := Get_Pragma_Arg (Arg1);
5752 if Etype (E_Id) = Any_Type then
5756 Set_Is_Ada_2005_Only (Entity (E_Id));
5759 Check_Arg_Count (0);
5761 -- For Ada_2005 we unconditionally enforce the documented
5762 -- configuration pragma placement, since we do not want to
5763 -- tolerate mixed modes in a unit involving Ada 2005. That
5764 -- would cause real difficulties for those cases where there
5765 -- are incompatibilities between Ada 95 and Ada 2005.
5767 Check_Valid_Configuration_Pragma;
5769 -- Now set appropriate Ada mode
5772 Ada_Version := Ada_2005;
5774 Ada_Version := Ada_Version_Default;
5777 Ada_Version_Explicit := Ada_2005;
5781 ---------------------
5782 -- Ada_12/Ada_2012 --
5783 ---------------------
5786 -- pragma Ada_12 (LOCAL_NAME);
5789 -- pragma Ada_2012 (LOCAL_NAME):
5791 -- Note: these pragmas also have some specific processing in Par.Prag
5792 -- because we want to set the Ada 2012 version mode during parsing.
5794 when Pragma_Ada_12 | Pragma_Ada_2012 => declare
5800 if Arg_Count = 1 then
5801 Check_Arg_Is_Local_Name (Arg1);
5802 E_Id := Get_Pragma_Arg (Arg1);
5804 if Etype (E_Id) = Any_Type then
5808 Set_Is_Ada_2012_Only (Entity (E_Id));
5811 Check_Arg_Count (0);
5813 -- For Ada_2012 we unconditionally enforce the documented
5814 -- configuration pragma placement, since we do not want to
5815 -- tolerate mixed modes in a unit involving Ada 2012. That
5816 -- would cause real difficulties for those cases where there
5817 -- are incompatibilities between Ada 95 and Ada 2012. We could
5818 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
5820 Check_Valid_Configuration_Pragma;
5822 -- Now set appropriate Ada mode
5825 Ada_Version := Ada_2012;
5827 Ada_Version := Ada_Version_Default;
5830 Ada_Version_Explicit := Ada_2012;
5834 ----------------------
5835 -- All_Calls_Remote --
5836 ----------------------
5838 -- pragma All_Calls_Remote [(library_package_NAME)];
5840 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
5841 Lib_Entity : Entity_Id;
5844 Check_Ada_83_Warning;
5845 Check_Valid_Library_Unit_Pragma;
5847 if Nkind (N) = N_Null_Statement then
5851 Lib_Entity := Find_Lib_Unit_Name;
5853 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
5855 if Present (Lib_Entity)
5856 and then not Debug_Flag_U
5858 if not Is_Remote_Call_Interface (Lib_Entity) then
5859 Error_Pragma ("pragma% only apply to rci unit");
5861 -- Set flag for entity of the library unit
5864 Set_Has_All_Calls_Remote (Lib_Entity);
5868 end All_Calls_Remote;
5874 -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]);
5875 -- ARG ::= NAME | EXPRESSION
5877 -- The first two arguments are by convention intended to refer to an
5878 -- external tool and a tool-specific function. These arguments are
5881 when Pragma_Annotate => Annotate : begin
5883 Check_At_Least_N_Arguments (1);
5884 Check_Arg_Is_Identifier (Arg1);
5885 Check_No_Identifiers;
5893 -- Second unanalyzed parameter is optional
5899 while Present (Arg) loop
5900 Exp := Get_Pragma_Arg (Arg);
5903 if Is_Entity_Name (Exp) then
5906 -- For string literals, we assume Standard_String as the
5907 -- type, unless the string contains wide or wide_wide
5910 elsif Nkind (Exp) = N_String_Literal then
5911 if Has_Wide_Wide_Character (Exp) then
5912 Resolve (Exp, Standard_Wide_Wide_String);
5913 elsif Has_Wide_Character (Exp) then
5914 Resolve (Exp, Standard_Wide_String);
5916 Resolve (Exp, Standard_String);
5919 elsif Is_Overloaded (Exp) then
5921 ("ambiguous argument for pragma%", Exp);
5937 -- pragma Assert ([Check =>] Boolean_EXPRESSION
5938 -- [, [Message =>] Static_String_EXPRESSION]);
5940 when Pragma_Assert => Assert : declare
5946 Check_At_Least_N_Arguments (1);
5947 Check_At_Most_N_Arguments (2);
5948 Check_Arg_Order ((Name_Check, Name_Message));
5949 Check_Optional_Identifier (Arg1, Name_Check);
5951 -- We treat pragma Assert as equivalent to:
5953 -- pragma Check (Assertion, condition [, msg]);
5955 -- So rewrite pragma in this manner, and analyze the result
5957 Expr := Get_Pragma_Arg (Arg1);
5959 Make_Pragma_Argument_Association (Loc,
5961 Make_Identifier (Loc,
5962 Chars => Name_Assertion)),
5964 Make_Pragma_Argument_Association (Sloc (Expr),
5965 Expression => Expr));
5967 if Arg_Count > 1 then
5968 Check_Optional_Identifier (Arg2, Name_Message);
5969 Analyze_And_Resolve (Get_Pragma_Arg (Arg2), Standard_String);
5970 Append_To (Newa, Relocate_Node (Arg2));
5975 Chars => Name_Check,
5976 Pragma_Argument_Associations => Newa));
5980 ----------------------
5981 -- Assertion_Policy --
5982 ----------------------
5984 -- pragma Assertion_Policy (Check | Ignore)
5986 when Pragma_Assertion_Policy => Assertion_Policy : declare
5991 Check_Valid_Configuration_Pragma;
5992 Check_Arg_Count (1);
5993 Check_No_Identifiers;
5994 Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Ignore);
5996 -- We treat pragma Assertion_Policy as equivalent to:
5998 -- pragma Check_Policy (Assertion, policy)
6000 -- So rewrite the pragma in that manner and link on to the chain
6001 -- of Check_Policy pragmas, marking the pragma as analyzed.
6003 Policy := Get_Pragma_Arg (Arg1);
6007 Chars => Name_Check_Policy,
6009 Pragma_Argument_Associations => New_List (
6010 Make_Pragma_Argument_Association (Loc,
6012 Make_Identifier (Loc,
6013 Chars => Name_Assertion)),
6015 Make_Pragma_Argument_Association (Loc,
6017 Make_Identifier (Sloc (Policy),
6018 Chars => Chars (Policy))))));
6021 Set_Next_Pragma (N, Opt.Check_Policy_List);
6022 Opt.Check_Policy_List := N;
6023 end Assertion_Policy;
6025 ------------------------------
6026 -- Assume_No_Invalid_Values --
6027 ------------------------------
6029 -- pragma Assume_No_Invalid_Values (On | Off);
6031 when Pragma_Assume_No_Invalid_Values =>
6033 Check_Valid_Configuration_Pragma;
6034 Check_Arg_Count (1);
6035 Check_No_Identifiers;
6036 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
6038 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
6039 Assume_No_Invalid_Values := True;
6041 Assume_No_Invalid_Values := False;
6048 -- pragma AST_Entry (entry_IDENTIFIER);
6050 when Pragma_AST_Entry => AST_Entry : declare
6056 Check_Arg_Count (1);
6057 Check_No_Identifiers;
6058 Check_Arg_Is_Local_Name (Arg1);
6059 Ent := Entity (Get_Pragma_Arg (Arg1));
6061 -- Note: the implementation of the AST_Entry pragma could handle
6062 -- the entry family case fine, but for now we are consistent with
6063 -- the DEC rules, and do not allow the pragma, which of course
6064 -- has the effect of also forbidding the attribute.
6066 if Ekind (Ent) /= E_Entry then
6068 ("pragma% argument must be simple entry name", Arg1);
6070 elsif Is_AST_Entry (Ent) then
6072 ("duplicate % pragma for entry", Arg1);
6074 elsif Has_Homonym (Ent) then
6076 ("pragma% argument cannot specify overloaded entry", Arg1);
6080 FF : constant Entity_Id := First_Formal (Ent);
6083 if Present (FF) then
6084 if Present (Next_Formal (FF)) then
6086 ("entry for pragma% can have only one argument",
6089 elsif Parameter_Mode (FF) /= E_In_Parameter then
6091 ("entry parameter for pragma% must have mode IN",
6097 Set_Is_AST_Entry (Ent);
6105 -- pragma Asynchronous (LOCAL_NAME);
6107 when Pragma_Asynchronous => Asynchronous : declare
6115 procedure Process_Async_Pragma;
6116 -- Common processing for procedure and access-to-procedure case
6118 --------------------------
6119 -- Process_Async_Pragma --
6120 --------------------------
6122 procedure Process_Async_Pragma is
6125 Set_Is_Asynchronous (Nm);
6129 -- The formals should be of mode IN (RM E.4.1(6))
6132 while Present (S) loop
6133 Formal := Defining_Identifier (S);
6135 if Nkind (Formal) = N_Defining_Identifier
6136 and then Ekind (Formal) /= E_In_Parameter
6139 ("pragma% procedure can only have IN parameter",
6146 Set_Is_Asynchronous (Nm);
6147 end Process_Async_Pragma;
6149 -- Start of processing for pragma Asynchronous
6152 Check_Ada_83_Warning;
6153 Check_No_Identifiers;
6154 Check_Arg_Count (1);
6155 Check_Arg_Is_Local_Name (Arg1);
6157 if Debug_Flag_U then
6161 C_Ent := Cunit_Entity (Current_Sem_Unit);
6162 Analyze (Get_Pragma_Arg (Arg1));
6163 Nm := Entity (Get_Pragma_Arg (Arg1));
6165 if not Is_Remote_Call_Interface (C_Ent)
6166 and then not Is_Remote_Types (C_Ent)
6168 -- This pragma should only appear in an RCI or Remote Types
6169 -- unit (RM E.4.1(4)).
6172 ("pragma% not in Remote_Call_Interface or " &
6173 "Remote_Types unit");
6176 if Ekind (Nm) = E_Procedure
6177 and then Nkind (Parent (Nm)) = N_Procedure_Specification
6179 if not Is_Remote_Call_Interface (Nm) then
6181 ("pragma% cannot be applied on non-remote procedure",
6185 L := Parameter_Specifications (Parent (Nm));
6186 Process_Async_Pragma;
6189 elsif Ekind (Nm) = E_Function then
6191 ("pragma% cannot be applied to function", Arg1);
6193 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
6195 if Is_Record_Type (Nm) then
6197 -- A record type that is the Equivalent_Type for a remote
6198 -- access-to-subprogram type.
6200 N := Declaration_Node (Corresponding_Remote_Type (Nm));
6203 -- A non-expanded RAS type (distribution is not enabled)
6205 N := Declaration_Node (Nm);
6208 if Nkind (N) = N_Full_Type_Declaration
6209 and then Nkind (Type_Definition (N)) =
6210 N_Access_Procedure_Definition
6212 L := Parameter_Specifications (Type_Definition (N));
6213 Process_Async_Pragma;
6215 if Is_Asynchronous (Nm)
6216 and then Expander_Active
6217 and then Get_PCS_Name /= Name_No_DSA
6219 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
6224 ("pragma% cannot reference access-to-function type",
6228 -- Only other possibility is Access-to-class-wide type
6230 elsif Is_Access_Type (Nm)
6231 and then Is_Class_Wide_Type (Designated_Type (Nm))
6233 Check_First_Subtype (Arg1);
6234 Set_Is_Asynchronous (Nm);
6235 if Expander_Active then
6236 RACW_Type_Is_Asynchronous (Nm);
6240 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
6248 -- pragma Atomic (LOCAL_NAME);
6250 when Pragma_Atomic =>
6251 Process_Atomic_Shared_Volatile;
6253 -----------------------
6254 -- Atomic_Components --
6255 -----------------------
6257 -- pragma Atomic_Components (array_LOCAL_NAME);
6259 -- This processing is shared by Volatile_Components
6261 when Pragma_Atomic_Components |
6262 Pragma_Volatile_Components =>
6264 Atomic_Components : declare
6271 Check_Ada_83_Warning;
6272 Check_No_Identifiers;
6273 Check_Arg_Count (1);
6274 Check_Arg_Is_Local_Name (Arg1);
6275 E_Id := Get_Pragma_Arg (Arg1);
6277 if Etype (E_Id) = Any_Type then
6283 Check_Duplicate_Pragma (E);
6285 if Rep_Item_Too_Early (E, N)
6287 Rep_Item_Too_Late (E, N)
6292 D := Declaration_Node (E);
6295 if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
6297 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
6298 and then Nkind (D) = N_Object_Declaration
6299 and then Nkind (Object_Definition (D)) =
6300 N_Constrained_Array_Definition)
6302 -- The flag is set on the object, or on the base type
6304 if Nkind (D) /= N_Object_Declaration then
6308 Set_Has_Volatile_Components (E, Sense);
6310 if Prag_Id = Pragma_Atomic_Components then
6311 Set_Has_Atomic_Components (E, Sense);
6315 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
6317 end Atomic_Components;
6319 --------------------
6320 -- Attach_Handler --
6321 --------------------
6323 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
6325 when Pragma_Attach_Handler =>
6326 Check_Ada_83_Warning;
6327 Check_No_Identifiers;
6328 Check_Arg_Count (2);
6330 if No_Run_Time_Mode then
6331 Error_Msg_CRT ("Attach_Handler pragma", N);
6333 Check_Interrupt_Or_Attach_Handler;
6335 -- The expression that designates the attribute may depend on a
6336 -- discriminant, and is therefore a per- object expression, to
6337 -- be expanded in the init proc. If expansion is enabled, then
6338 -- perform semantic checks on a copy only.
6340 if Expander_Active then
6342 Temp : constant Node_Id :=
6343 New_Copy_Tree (Get_Pragma_Arg (Arg2));
6345 Set_Parent (Temp, N);
6346 Preanalyze_And_Resolve (Temp, RTE (RE_Interrupt_ID));
6350 Analyze (Get_Pragma_Arg (Arg2));
6351 Resolve (Get_Pragma_Arg (Arg2), RTE (RE_Interrupt_ID));
6354 Process_Interrupt_Or_Attach_Handler;
6357 --------------------
6358 -- C_Pass_By_Copy --
6359 --------------------
6361 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
6363 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
6369 Check_Valid_Configuration_Pragma;
6370 Check_Arg_Count (1);
6371 Check_Optional_Identifier (Arg1, "max_size");
6373 Arg := Get_Pragma_Arg (Arg1);
6374 Check_Arg_Is_Static_Expression (Arg, Any_Integer);
6376 Val := Expr_Value (Arg);
6380 ("maximum size for pragma% must be positive", Arg1);
6382 elsif UI_Is_In_Int_Range (Val) then
6383 Default_C_Record_Mechanism := UI_To_Int (Val);
6385 -- If a giant value is given, Int'Last will do well enough.
6386 -- If sometime someone complains that a record larger than
6387 -- two gigabytes is not copied, we will worry about it then!
6390 Default_C_Record_Mechanism := Mechanism_Type'Last;
6398 -- pragma Check ([Name =>] Identifier,
6399 -- [Check =>] Boolean_Expression
6400 -- [,[Message =>] String_Expression]);
6402 when Pragma_Check => Check : declare
6407 -- Set True if category of assertions referenced by Name enabled
6411 Check_At_Least_N_Arguments (2);
6412 Check_At_Most_N_Arguments (3);
6413 Check_Optional_Identifier (Arg1, Name_Name);
6414 Check_Optional_Identifier (Arg2, Name_Check);
6416 if Arg_Count = 3 then
6417 Check_Optional_Identifier (Arg3, Name_Message);
6418 Analyze_And_Resolve (Get_Pragma_Arg (Arg3), Standard_String);
6421 Check_Arg_Is_Identifier (Arg1);
6423 -- Indicate if pragma is enabled. The Original_Node reference here
6424 -- is to deal with pragma Assert rewritten as a Check pragma.
6426 Check_On := Check_Enabled (Chars (Get_Pragma_Arg (Arg1)));
6429 Set_Pragma_Enabled (N);
6430 Set_Pragma_Enabled (Original_Node (N));
6431 Set_SCO_Pragma_Enabled (Loc);
6434 -- If expansion is active and the check is not enabled then we
6435 -- rewrite the Check as:
6437 -- if False and then condition then
6441 -- The reason we do this rewriting during semantic analysis rather
6442 -- than as part of normal expansion is that we cannot analyze and
6443 -- expand the code for the boolean expression directly, or it may
6444 -- cause insertion of actions that would escape the attempt to
6445 -- suppress the check code.
6447 -- Note that the Sloc for the if statement corresponds to the
6448 -- argument condition, not the pragma itself. The reason for this
6449 -- is that we may generate a warning if the condition is False at
6450 -- compile time, and we do not want to delete this warning when we
6451 -- delete the if statement.
6453 Expr := Get_Pragma_Arg (Arg2);
6455 if Expander_Active and then not Check_On then
6456 Eloc := Sloc (Expr);
6459 Make_If_Statement (Eloc,
6461 Make_And_Then (Eloc,
6462 Left_Opnd => New_Occurrence_Of (Standard_False, Eloc),
6463 Right_Opnd => Expr),
6464 Then_Statements => New_List (
6465 Make_Null_Statement (Eloc))));
6472 Analyze_And_Resolve (Expr, Any_Boolean);
6480 -- pragma Check_Name (check_IDENTIFIER);
6482 when Pragma_Check_Name =>
6483 Check_No_Identifiers;
6485 Check_Valid_Configuration_Pragma;
6486 Check_Arg_Count (1);
6487 Check_Arg_Is_Identifier (Arg1);
6490 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
6493 for J in Check_Names.First .. Check_Names.Last loop
6494 if Check_Names.Table (J) = Nam then
6499 Check_Names.Append (Nam);
6506 -- pragma Check_Policy (
6507 -- [Name =>] IDENTIFIER,
6508 -- [Policy =>] POLICY_IDENTIFIER);
6510 -- POLICY_IDENTIFIER ::= ON | OFF | CHECK | IGNORE
6512 -- Note: this is a configuration pragma, but it is allowed to appear
6515 when Pragma_Check_Policy =>
6517 Check_Arg_Count (2);
6518 Check_Optional_Identifier (Arg1, Name_Name);
6519 Check_Optional_Identifier (Arg2, Name_Policy);
6521 (Arg2, Name_On, Name_Off, Name_Check, Name_Ignore);
6523 -- A Check_Policy pragma can appear either as a configuration
6524 -- pragma, or in a declarative part or a package spec (see RM
6525 -- 11.5(5) for rules for Suppress/Unsuppress which are also
6526 -- followed for Check_Policy).
6528 if not Is_Configuration_Pragma then
6529 Check_Is_In_Decl_Part_Or_Package_Spec;
6532 Set_Next_Pragma (N, Opt.Check_Policy_List);
6533 Opt.Check_Policy_List := N;
6535 ---------------------
6536 -- CIL_Constructor --
6537 ---------------------
6539 -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
6541 -- Processing for this pragma is shared with Java_Constructor
6547 -- pragma Comment (static_string_EXPRESSION)
6549 -- Processing for pragma Comment shares the circuitry for pragma
6550 -- Ident. The only differences are that Ident enforces a limit of 31
6551 -- characters on its argument, and also enforces limitations on
6552 -- placement for DEC compatibility. Pragma Comment shares neither of
6553 -- these restrictions.
6559 -- pragma Common_Object (
6560 -- [Internal =>] LOCAL_NAME
6561 -- [, [External =>] EXTERNAL_SYMBOL]
6562 -- [, [Size =>] EXTERNAL_SYMBOL]);
6564 -- Processing for this pragma is shared with Psect_Object
6566 ------------------------
6567 -- Compile_Time_Error --
6568 ------------------------
6570 -- pragma Compile_Time_Error
6571 -- (boolean_EXPRESSION, static_string_EXPRESSION);
6573 when Pragma_Compile_Time_Error =>
6575 Process_Compile_Time_Warning_Or_Error;
6577 --------------------------
6578 -- Compile_Time_Warning --
6579 --------------------------
6581 -- pragma Compile_Time_Warning
6582 -- (boolean_EXPRESSION, static_string_EXPRESSION);
6584 when Pragma_Compile_Time_Warning =>
6586 Process_Compile_Time_Warning_Or_Error;
6592 when Pragma_Compiler_Unit =>
6594 Check_Arg_Count (0);
6595 Set_Is_Compiler_Unit (Get_Source_Unit (N));
6597 -----------------------------
6598 -- Complete_Representation --
6599 -----------------------------
6601 -- pragma Complete_Representation;
6603 when Pragma_Complete_Representation =>
6605 Check_Arg_Count (0);
6607 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
6609 ("pragma & must appear within record representation clause");
6612 ----------------------------
6613 -- Complex_Representation --
6614 ----------------------------
6616 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
6618 when Pragma_Complex_Representation => Complex_Representation : declare
6625 Check_Arg_Count (1);
6626 Check_Optional_Identifier (Arg1, Name_Entity);
6627 Check_Arg_Is_Local_Name (Arg1);
6628 E_Id := Get_Pragma_Arg (Arg1);
6630 if Etype (E_Id) = Any_Type then
6636 if not Is_Record_Type (E) then
6638 ("argument for pragma% must be record type", Arg1);
6641 Ent := First_Entity (E);
6644 or else No (Next_Entity (Ent))
6645 or else Present (Next_Entity (Next_Entity (Ent)))
6646 or else not Is_Floating_Point_Type (Etype (Ent))
6647 or else Etype (Ent) /= Etype (Next_Entity (Ent))
6650 ("record for pragma% must have two fields of the same "
6651 & "floating-point type", Arg1);
6654 Set_Has_Complex_Representation (Base_Type (E));
6656 -- We need to treat the type has having a non-standard
6657 -- representation, for back-end purposes, even though in
6658 -- general a complex will have the default representation
6659 -- of a record with two real components.
6661 Set_Has_Non_Standard_Rep (Base_Type (E));
6663 end Complex_Representation;
6665 -------------------------
6666 -- Component_Alignment --
6667 -------------------------
6669 -- pragma Component_Alignment (
6670 -- [Form =>] ALIGNMENT_CHOICE
6671 -- [, [Name =>] type_LOCAL_NAME]);
6673 -- ALIGNMENT_CHOICE ::=
6675 -- | Component_Size_4
6679 when Pragma_Component_Alignment => Component_AlignmentP : declare
6680 Args : Args_List (1 .. 2);
6681 Names : constant Name_List (1 .. 2) := (
6685 Form : Node_Id renames Args (1);
6686 Name : Node_Id renames Args (2);
6688 Atype : Component_Alignment_Kind;
6693 Gather_Associations (Names, Args);
6696 Error_Pragma ("missing Form argument for pragma%");
6699 Check_Arg_Is_Identifier (Form);
6701 -- Get proper alignment, note that Default = Component_Size on all
6702 -- machines we have so far, and we want to set this value rather
6703 -- than the default value to indicate that it has been explicitly
6704 -- set (and thus will not get overridden by the default component
6705 -- alignment for the current scope)
6707 if Chars (Form) = Name_Component_Size then
6708 Atype := Calign_Component_Size;
6710 elsif Chars (Form) = Name_Component_Size_4 then
6711 Atype := Calign_Component_Size_4;
6713 elsif Chars (Form) = Name_Default then
6714 Atype := Calign_Component_Size;
6716 elsif Chars (Form) = Name_Storage_Unit then
6717 Atype := Calign_Storage_Unit;
6721 ("invalid Form parameter for pragma%", Form);
6724 -- Case with no name, supplied, affects scope table entry
6728 (Scope_Stack.Last).Component_Alignment_Default := Atype;
6730 -- Case of name supplied
6733 Check_Arg_Is_Local_Name (Name);
6735 Typ := Entity (Name);
6738 or else Rep_Item_Too_Early (Typ, N)
6742 Typ := Underlying_Type (Typ);
6745 if not Is_Record_Type (Typ)
6746 and then not Is_Array_Type (Typ)
6749 ("Name parameter of pragma% must identify record or " &
6750 "array type", Name);
6753 -- An explicit Component_Alignment pragma overrides an
6754 -- implicit pragma Pack, but not an explicit one.
6756 if not Has_Pragma_Pack (Base_Type (Typ)) then
6757 Set_Is_Packed (Base_Type (Typ), False);
6758 Set_Component_Alignment (Base_Type (Typ), Atype);
6761 end Component_AlignmentP;
6767 -- pragma Controlled (first_subtype_LOCAL_NAME);
6769 when Pragma_Controlled => Controlled : declare
6773 Check_No_Identifiers;
6774 Check_Arg_Count (1);
6775 Check_Arg_Is_Local_Name (Arg1);
6776 Arg := Get_Pragma_Arg (Arg1);
6778 if not Is_Entity_Name (Arg)
6779 or else not Is_Access_Type (Entity (Arg))
6781 Error_Pragma_Arg ("pragma% requires access type", Arg1);
6783 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
6791 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
6792 -- [Entity =>] LOCAL_NAME);
6794 when Pragma_Convention => Convention : declare
6797 pragma Warnings (Off, C);
6798 pragma Warnings (Off, E);
6800 Check_Arg_Order ((Name_Convention, Name_Entity));
6801 Check_Ada_83_Warning;
6802 Check_Arg_Count (2);
6803 Process_Convention (C, E);
6806 ---------------------------
6807 -- Convention_Identifier --
6808 ---------------------------
6810 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
6811 -- [Convention =>] convention_IDENTIFIER);
6813 when Pragma_Convention_Identifier => Convention_Identifier : declare
6819 Check_Arg_Order ((Name_Name, Name_Convention));
6820 Check_Arg_Count (2);
6821 Check_Optional_Identifier (Arg1, Name_Name);
6822 Check_Optional_Identifier (Arg2, Name_Convention);
6823 Check_Arg_Is_Identifier (Arg1);
6824 Check_Arg_Is_Identifier (Arg2);
6825 Idnam := Chars (Get_Pragma_Arg (Arg1));
6826 Cname := Chars (Get_Pragma_Arg (Arg2));
6828 if Is_Convention_Name (Cname) then
6829 Record_Convention_Identifier
6830 (Idnam, Get_Convention_Id (Cname));
6833 ("second arg for % pragma must be convention", Arg2);
6835 end Convention_Identifier;
6841 -- pragma CPP_Class ([Entity =>] local_NAME)
6843 when Pragma_CPP_Class => CPP_Class : declare
6848 if Warn_On_Obsolescent_Feature then
6850 ("'G'N'A'T pragma cpp'_class is now obsolete; replace it" &
6851 " by pragma import?", N);
6855 Check_Arg_Count (1);
6856 Check_Optional_Identifier (Arg1, Name_Entity);
6857 Check_Arg_Is_Local_Name (Arg1);
6859 Arg := Get_Pragma_Arg (Arg1);
6862 if Etype (Arg) = Any_Type then
6866 if not Is_Entity_Name (Arg)
6867 or else not Is_Type (Entity (Arg))
6869 Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
6872 Typ := Entity (Arg);
6874 if not Is_Tagged_Type (Typ) then
6875 Error_Pragma_Arg ("pragma% applicable to tagged types ", Arg1);
6878 -- Types treated as CPP classes are treated as limited, but we
6879 -- don't require them to be declared this way. A warning is issued
6880 -- to encourage the user to declare them as limited. This is not
6881 -- an error, for compatibility reasons, because these types have
6882 -- been supported this way for some time.
6884 if not Is_Limited_Type (Typ) then
6886 ("imported 'C'P'P type should be " &
6887 "explicitly declared limited?",
6888 Get_Pragma_Arg (Arg1));
6890 ("\type will be considered limited",
6891 Get_Pragma_Arg (Arg1));
6894 Set_Is_CPP_Class (Typ);
6895 Set_Is_Limited_Record (Typ);
6896 Set_Convention (Typ, Convention_CPP);
6898 -- Imported CPP types must not have discriminants (because C++
6899 -- classes do not have discriminants).
6901 if Has_Discriminants (Typ) then
6903 ("imported 'C'P'P type cannot have discriminants",
6904 First (Discriminant_Specifications
6905 (Declaration_Node (Typ))));
6908 -- Components of imported CPP types must not have default
6909 -- expressions because the constructor (if any) is in the
6912 if Is_Incomplete_Or_Private_Type (Typ)
6913 and then No (Underlying_Type (Typ))
6915 -- It should be an error to apply pragma CPP to a private
6916 -- type if the underlying type is not visible (as it is
6917 -- for any representation item). For now, for backward
6918 -- compatibility we do nothing but we cannot check components
6919 -- because they are not available at this stage. All this code
6920 -- will be removed when we cleanup this obsolete GNAT pragma???
6926 Tdef : constant Node_Id :=
6927 Type_Definition (Declaration_Node (Typ));
6932 if Nkind (Tdef) = N_Record_Definition then
6933 Clist := Component_List (Tdef);
6935 pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition);
6936 Clist := Component_List (Record_Extension_Part (Tdef));
6939 if Present (Clist) then
6940 Comp := First (Component_Items (Clist));
6941 while Present (Comp) loop
6942 if Present (Expression (Comp)) then
6944 ("component of imported 'C'P'P type cannot have" &
6945 " default expression", Expression (Comp));
6955 ---------------------
6956 -- CPP_Constructor --
6957 ---------------------
6959 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
6960 -- [, [External_Name =>] static_string_EXPRESSION ]
6961 -- [, [Link_Name =>] static_string_EXPRESSION ]);
6963 when Pragma_CPP_Constructor => CPP_Constructor : declare
6967 Tag_Typ : Entity_Id;
6971 Check_At_Least_N_Arguments (1);
6972 Check_At_Most_N_Arguments (3);
6973 Check_Optional_Identifier (Arg1, Name_Entity);
6974 Check_Arg_Is_Local_Name (Arg1);
6976 Id := Get_Pragma_Arg (Arg1);
6977 Find_Program_Unit_Name (Id);
6979 -- If we did not find the name, we are done
6981 if Etype (Id) = Any_Type then
6985 Def_Id := Entity (Id);
6987 -- Check if already defined as constructor
6989 if Is_Constructor (Def_Id) then
6991 ("?duplicate argument for pragma 'C'P'P_Constructor", Arg1);
6995 if Ekind (Def_Id) = E_Function
6996 and then (Is_CPP_Class (Etype (Def_Id))
6997 or else (Is_Class_Wide_Type (Etype (Def_Id))
6999 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
7001 if Arg_Count >= 2 then
7002 Set_Imported (Def_Id);
7003 Set_Is_Public (Def_Id);
7004 Process_Interface_Name (Def_Id, Arg2, Arg3);
7007 Set_Has_Completion (Def_Id);
7008 Set_Is_Constructor (Def_Id);
7010 -- Imported C++ constructors are not dispatching primitives
7011 -- because in C++ they don't have a dispatch table slot.
7012 -- However, in Ada the constructor has the profile of a
7013 -- function that returns a tagged type and therefore it has
7014 -- been treated as a primitive operation during semantic
7015 -- analysis. We now remove it from the list of primitive
7016 -- operations of the type.
7018 if Is_Tagged_Type (Etype (Def_Id))
7019 and then not Is_Class_Wide_Type (Etype (Def_Id))
7021 pragma Assert (Is_Dispatching_Operation (Def_Id));
7022 Tag_Typ := Etype (Def_Id);
7024 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
7025 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
7029 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
7030 Set_Is_Dispatching_Operation (Def_Id, False);
7033 -- For backward compatibility, if the constructor returns a
7034 -- class wide type, and we internally change the return type to
7035 -- the corresponding root type.
7037 if Is_Class_Wide_Type (Etype (Def_Id)) then
7038 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
7042 ("pragma% requires function returning a 'C'P'P_Class type",
7045 end CPP_Constructor;
7051 when Pragma_CPP_Virtual => CPP_Virtual : declare
7055 if Warn_On_Obsolescent_Feature then
7057 ("'G'N'A'T pragma cpp'_virtual is now obsolete and has " &
7066 when Pragma_CPP_Vtable => CPP_Vtable : declare
7070 if Warn_On_Obsolescent_Feature then
7072 ("'G'N'A'T pragma cpp'_vtable is now obsolete and has " &
7081 -- pragma CPU (EXPRESSION);
7083 when Pragma_CPU => CPU : declare
7084 P : constant Node_Id := Parent (N);
7089 Check_No_Identifiers;
7090 Check_Arg_Count (1);
7094 if Nkind (P) = N_Subprogram_Body then
7095 Check_In_Main_Program;
7097 Arg := Get_Pragma_Arg (Arg1);
7098 Analyze_And_Resolve (Arg, Any_Integer);
7102 if not Is_Static_Expression (Arg) then
7103 Flag_Non_Static_Expr
7104 ("main subprogram affinity is not static!", Arg);
7107 -- If constraint error, then we already signalled an error
7109 elsif Raises_Constraint_Error (Arg) then
7112 -- Otherwise check in range
7116 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
7117 -- This is the entity System.Multiprocessors.CPU_Range;
7119 Val : constant Uint := Expr_Value (Arg);
7122 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
7124 Val > Expr_Value (Type_High_Bound (CPU_Id))
7127 ("main subprogram CPU is out of range", Arg1);
7133 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
7137 elsif Nkind (P) = N_Task_Definition then
7138 Arg := Get_Pragma_Arg (Arg1);
7140 -- The expression must be analyzed in the special manner
7141 -- described in "Handling of Default and Per-Object
7142 -- Expressions" in sem.ads.
7144 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
7146 -- Anything else is incorrect
7152 if Has_Pragma_CPU (P) then
7153 Error_Pragma ("duplicate pragma% not allowed");
7155 Set_Has_Pragma_CPU (P, True);
7157 if Nkind (P) = N_Task_Definition then
7158 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
7167 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
7169 when Pragma_Debug => Debug : declare
7177 (Boolean_Literals (Debug_Pragmas_Enabled and Expander_Active),
7180 if Arg_Count = 2 then
7183 Left_Opnd => Relocate_Node (Cond),
7184 Right_Opnd => Get_Pragma_Arg (Arg1));
7187 -- Rewrite into a conditional with an appropriate condition. We
7188 -- wrap the procedure call in a block so that overhead from e.g.
7189 -- use of the secondary stack does not generate execution overhead
7190 -- for suppressed conditions.
7192 Rewrite (N, Make_Implicit_If_Statement (N,
7194 Then_Statements => New_List (
7195 Make_Block_Statement (Loc,
7196 Handled_Statement_Sequence =>
7197 Make_Handled_Sequence_Of_Statements (Loc,
7198 Statements => New_List (
7199 Relocate_Node (Debug_Statement (N))))))));
7207 -- pragma Debug_Policy (Check | Ignore)
7209 when Pragma_Debug_Policy =>
7211 Check_Arg_Count (1);
7212 Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Ignore);
7213 Debug_Pragmas_Enabled :=
7214 Chars (Get_Pragma_Arg (Arg1)) = Name_Check;
7216 ---------------------
7217 -- Detect_Blocking --
7218 ---------------------
7220 -- pragma Detect_Blocking;
7222 when Pragma_Detect_Blocking =>
7224 Check_Arg_Count (0);
7225 Check_Valid_Configuration_Pragma;
7226 Detect_Blocking := True;
7228 --------------------------
7229 -- Default_Storage_Pool --
7230 --------------------------
7232 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
7234 when Pragma_Default_Storage_Pool =>
7236 Check_Arg_Count (1);
7238 -- Default_Storage_Pool can appear as a configuration pragma, or
7239 -- in a declarative part or a package spec.
7241 if not Is_Configuration_Pragma then
7242 Check_Is_In_Decl_Part_Or_Package_Spec;
7245 -- Case of Default_Storage_Pool (null);
7247 if Nkind (Expression (Arg1)) = N_Null then
7248 Analyze (Expression (Arg1));
7250 -- This is an odd case, this is not really an expression, so
7251 -- we don't have a type for it. So just set the type to Empty.
7253 Set_Etype (Expression (Arg1), Empty);
7255 -- Case of Default_Storage_Pool (storage_pool_NAME);
7258 -- If it's a configuration pragma, then the only allowed
7259 -- argument is "null".
7261 if Is_Configuration_Pragma then
7262 Error_Pragma_Arg ("NULL expected", Arg1);
7265 -- The expected type for a non-"null" argument is
7266 -- Root_Storage_Pool'Class.
7269 (Get_Pragma_Arg (Arg1),
7270 Typ => Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
7273 -- Finally, record the pool name (or null). Freeze.Freeze_Entity
7274 -- for an access type will use this information to set the
7275 -- appropriate attributes of the access type.
7277 Default_Pool := Expression (Arg1);
7283 when Pragma_Dimension =>
7285 Check_Arg_Count (4);
7286 Check_No_Identifiers;
7287 Check_Arg_Is_Local_Name (Arg1);
7289 if not Is_Type (Arg1) then
7290 Error_Pragma ("first argument for pragma% must be subtype");
7293 Check_Arg_Is_Static_Expression (Arg2, Standard_Integer);
7294 Check_Arg_Is_Static_Expression (Arg3, Standard_Integer);
7295 Check_Arg_Is_Static_Expression (Arg4, Standard_Integer);
7301 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
7303 when Pragma_Discard_Names => Discard_Names : declare
7308 Check_Ada_83_Warning;
7310 -- Deal with configuration pragma case
7312 if Arg_Count = 0 and then Is_Configuration_Pragma then
7313 Global_Discard_Names := True;
7316 -- Otherwise, check correct appropriate context
7319 Check_Is_In_Decl_Part_Or_Package_Spec;
7321 if Arg_Count = 0 then
7323 -- If there is no parameter, then from now on this pragma
7324 -- applies to any enumeration, exception or tagged type
7325 -- defined in the current declarative part, and recursively
7326 -- to any nested scope.
7328 Set_Discard_Names (Current_Scope, Sense);
7332 Check_Arg_Count (1);
7333 Check_Optional_Identifier (Arg1, Name_On);
7334 Check_Arg_Is_Local_Name (Arg1);
7336 E_Id := Get_Pragma_Arg (Arg1);
7338 if Etype (E_Id) = Any_Type then
7344 if (Is_First_Subtype (E)
7346 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
7347 or else Ekind (E) = E_Exception
7349 Set_Discard_Names (E, Sense);
7352 ("inappropriate entity for pragma%", Arg1);
7363 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
7365 when Pragma_Elaborate => Elaborate : declare
7370 -- Pragma must be in context items list of a compilation unit
7372 if not Is_In_Context_Clause then
7376 -- Must be at least one argument
7378 if Arg_Count = 0 then
7379 Error_Pragma ("pragma% requires at least one argument");
7382 -- In Ada 83 mode, there can be no items following it in the
7383 -- context list except other pragmas and implicit with clauses
7384 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
7385 -- placement rule does not apply.
7387 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
7389 while Present (Citem) loop
7390 if Nkind (Citem) = N_Pragma
7391 or else (Nkind (Citem) = N_With_Clause
7392 and then Implicit_With (Citem))
7397 ("(Ada 83) pragma% must be at end of context clause");
7404 -- Finally, the arguments must all be units mentioned in a with
7405 -- clause in the same context clause. Note we already checked (in
7406 -- Par.Prag) that the arguments are all identifiers or selected
7410 Outer : while Present (Arg) loop
7411 Citem := First (List_Containing (N));
7412 Inner : while Citem /= N loop
7413 if Nkind (Citem) = N_With_Clause
7414 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
7416 Set_Elaborate_Present (Citem, True);
7417 Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
7419 -- With the pragma present, elaboration calls on
7420 -- subprograms from the named unit need no further
7421 -- checks, as long as the pragma appears in the current
7422 -- compilation unit. If the pragma appears in some unit
7423 -- in the context, there might still be a need for an
7424 -- Elaborate_All_Desirable from the current compilation
7425 -- to the named unit, so we keep the check enabled.
7427 if In_Extended_Main_Source_Unit (N) then
7428 Set_Suppress_Elaboration_Warnings
7429 (Entity (Name (Citem)));
7440 ("argument of pragma% is not with'ed unit", Arg);
7446 -- Give a warning if operating in static mode with -gnatwl
7447 -- (elaboration warnings enabled) switch set.
7449 if Elab_Warnings and not Dynamic_Elaboration_Checks then
7451 ("?use of pragma Elaborate may not be safe", N);
7453 ("?use pragma Elaborate_All instead if possible", N);
7461 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
7463 when Pragma_Elaborate_All => Elaborate_All : declare
7468 Check_Ada_83_Warning;
7470 -- Pragma must be in context items list of a compilation unit
7472 if not Is_In_Context_Clause then
7476 -- Must be at least one argument
7478 if Arg_Count = 0 then
7479 Error_Pragma ("pragma% requires at least one argument");
7482 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
7483 -- have to appear at the end of the context clause, but may
7484 -- appear mixed in with other items, even in Ada 83 mode.
7486 -- Final check: the arguments must all be units mentioned in
7487 -- a with clause in the same context clause. Note that we
7488 -- already checked (in Par.Prag) that all the arguments are
7489 -- either identifiers or selected components.
7492 Outr : while Present (Arg) loop
7493 Citem := First (List_Containing (N));
7494 Innr : while Citem /= N loop
7495 if Nkind (Citem) = N_With_Clause
7496 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
7498 Set_Elaborate_All_Present (Citem, True);
7499 Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
7501 -- Suppress warnings and elaboration checks on the named
7502 -- unit if the pragma is in the current compilation, as
7503 -- for pragma Elaborate.
7505 if In_Extended_Main_Source_Unit (N) then
7506 Set_Suppress_Elaboration_Warnings
7507 (Entity (Name (Citem)));
7516 Set_Error_Posted (N);
7518 ("argument of pragma% is not with'ed unit", Arg);
7525 --------------------
7526 -- Elaborate_Body --
7527 --------------------
7529 -- pragma Elaborate_Body [( library_unit_NAME )];
7531 when Pragma_Elaborate_Body => Elaborate_Body : declare
7532 Cunit_Node : Node_Id;
7533 Cunit_Ent : Entity_Id;
7536 Check_Ada_83_Warning;
7537 Check_Valid_Library_Unit_Pragma;
7539 if Nkind (N) = N_Null_Statement then
7543 Cunit_Node := Cunit (Current_Sem_Unit);
7544 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
7546 if Nkind_In (Unit (Cunit_Node), N_Package_Body,
7549 Error_Pragma ("pragma% must refer to a spec, not a body");
7551 Set_Body_Required (Cunit_Node, True);
7552 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
7554 -- If we are in dynamic elaboration mode, then we suppress
7555 -- elaboration warnings for the unit, since it is definitely
7556 -- fine NOT to do dynamic checks at the first level (and such
7557 -- checks will be suppressed because no elaboration boolean
7558 -- is created for Elaborate_Body packages).
7560 -- But in the static model of elaboration, Elaborate_Body is
7561 -- definitely NOT good enough to ensure elaboration safety on
7562 -- its own, since the body may WITH other units that are not
7563 -- safe from an elaboration point of view, so a client must
7564 -- still do an Elaborate_All on such units.
7566 -- Debug flag -gnatdD restores the old behavior of 3.13, where
7567 -- Elaborate_Body always suppressed elab warnings.
7569 if Dynamic_Elaboration_Checks or Debug_Flag_DD then
7570 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
7575 ------------------------
7576 -- Elaboration_Checks --
7577 ------------------------
7579 -- pragma Elaboration_Checks (Static | Dynamic);
7581 when Pragma_Elaboration_Checks =>
7583 Check_Arg_Count (1);
7584 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
7585 Dynamic_Elaboration_Checks :=
7586 (Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic);
7592 -- pragma Eliminate (
7593 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
7594 -- [,[Entity =>] IDENTIFIER |
7595 -- SELECTED_COMPONENT |
7597 -- [, OVERLOADING_RESOLUTION]);
7599 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
7602 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
7605 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
7607 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
7608 -- Result_Type => result_SUBTYPE_NAME]
7610 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
7611 -- SUBTYPE_NAME ::= STRING_LITERAL
7613 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
7614 -- SOURCE_TRACE ::= STRING_LITERAL
7616 when Pragma_Eliminate => Eliminate : declare
7617 Args : Args_List (1 .. 5);
7618 Names : constant Name_List (1 .. 5) := (
7621 Name_Parameter_Types,
7623 Name_Source_Location);
7625 Unit_Name : Node_Id renames Args (1);
7626 Entity : Node_Id renames Args (2);
7627 Parameter_Types : Node_Id renames Args (3);
7628 Result_Type : Node_Id renames Args (4);
7629 Source_Location : Node_Id renames Args (5);
7633 Check_Valid_Configuration_Pragma;
7634 Gather_Associations (Names, Args);
7636 if No (Unit_Name) then
7637 Error_Pragma ("missing Unit_Name argument for pragma%");
7641 and then (Present (Parameter_Types)
7643 Present (Result_Type)
7645 Present (Source_Location))
7647 Error_Pragma ("missing Entity argument for pragma%");
7650 if (Present (Parameter_Types)
7652 Present (Result_Type))
7654 Present (Source_Location)
7657 ("parameter profile and source location cannot " &
7658 "be used together in pragma%");
7661 Process_Eliminate_Pragma
7675 -- [ Convention =>] convention_IDENTIFIER,
7676 -- [ Entity =>] local_NAME
7677 -- [, [External_Name =>] static_string_EXPRESSION ]
7678 -- [, [Link_Name =>] static_string_EXPRESSION ]);
7680 when Pragma_Export => Export : declare
7684 pragma Warnings (Off, C);
7687 Check_Ada_83_Warning;
7693 Check_At_Least_N_Arguments (2);
7694 Check_At_Most_N_Arguments (4);
7695 Process_Convention (C, Def_Id);
7697 if Ekind (Def_Id) /= E_Constant then
7698 Note_Possible_Modification
7699 (Get_Pragma_Arg (Arg2), Sure => False);
7702 Process_Interface_Name (Def_Id, Arg3, Arg4);
7703 Set_Exported (Def_Id, Arg2);
7705 -- If the entity is a deferred constant, propagate the information
7706 -- to the full view, because gigi elaborates the full view only.
7708 if Ekind (Def_Id) = E_Constant
7709 and then Present (Full_View (Def_Id))
7712 Id2 : constant Entity_Id := Full_View (Def_Id);
7714 Set_Is_Exported (Id2, Is_Exported (Def_Id));
7715 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
7716 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
7721 ----------------------
7722 -- Export_Exception --
7723 ----------------------
7725 -- pragma Export_Exception (
7726 -- [Internal =>] LOCAL_NAME
7727 -- [, [External =>] EXTERNAL_SYMBOL]
7728 -- [, [Form =>] Ada | VMS]
7729 -- [, [Code =>] static_integer_EXPRESSION]);
7731 when Pragma_Export_Exception => Export_Exception : declare
7732 Args : Args_List (1 .. 4);
7733 Names : constant Name_List (1 .. 4) := (
7739 Internal : Node_Id renames Args (1);
7740 External : Node_Id renames Args (2);
7741 Form : Node_Id renames Args (3);
7742 Code : Node_Id renames Args (4);
7747 if Inside_A_Generic then
7748 Error_Pragma ("pragma% cannot be used for generic entities");
7751 Gather_Associations (Names, Args);
7752 Process_Extended_Import_Export_Exception_Pragma (
7753 Arg_Internal => Internal,
7754 Arg_External => External,
7758 if not Is_VMS_Exception (Entity (Internal)) then
7759 Set_Exported (Entity (Internal), Internal);
7761 end Export_Exception;
7763 ---------------------
7764 -- Export_Function --
7765 ---------------------
7767 -- pragma Export_Function (
7768 -- [Internal =>] LOCAL_NAME
7769 -- [, [External =>] EXTERNAL_SYMBOL]
7770 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
7771 -- [, [Result_Type =>] TYPE_DESIGNATOR]
7772 -- [, [Mechanism =>] MECHANISM]
7773 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
7775 -- EXTERNAL_SYMBOL ::=
7777 -- | static_string_EXPRESSION
7779 -- PARAMETER_TYPES ::=
7781 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
7783 -- TYPE_DESIGNATOR ::=
7785 -- | subtype_Name ' Access
7789 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
7791 -- MECHANISM_ASSOCIATION ::=
7792 -- [formal_parameter_NAME =>] MECHANISM_NAME
7794 -- MECHANISM_NAME ::=
7797 -- | Descriptor [([Class =>] CLASS_NAME)]
7799 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7801 when Pragma_Export_Function => Export_Function : declare
7802 Args : Args_List (1 .. 6);
7803 Names : constant Name_List (1 .. 6) := (
7806 Name_Parameter_Types,
7809 Name_Result_Mechanism);
7811 Internal : Node_Id renames Args (1);
7812 External : Node_Id renames Args (2);
7813 Parameter_Types : Node_Id renames Args (3);
7814 Result_Type : Node_Id renames Args (4);
7815 Mechanism : Node_Id renames Args (5);
7816 Result_Mechanism : Node_Id renames Args (6);
7820 Gather_Associations (Names, Args);
7821 Process_Extended_Import_Export_Subprogram_Pragma (
7822 Arg_Internal => Internal,
7823 Arg_External => External,
7824 Arg_Parameter_Types => Parameter_Types,
7825 Arg_Result_Type => Result_Type,
7826 Arg_Mechanism => Mechanism,
7827 Arg_Result_Mechanism => Result_Mechanism);
7828 end Export_Function;
7834 -- pragma Export_Object (
7835 -- [Internal =>] LOCAL_NAME
7836 -- [, [External =>] EXTERNAL_SYMBOL]
7837 -- [, [Size =>] EXTERNAL_SYMBOL]);
7839 -- EXTERNAL_SYMBOL ::=
7841 -- | static_string_EXPRESSION
7843 -- PARAMETER_TYPES ::=
7845 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
7847 -- TYPE_DESIGNATOR ::=
7849 -- | subtype_Name ' Access
7853 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
7855 -- MECHANISM_ASSOCIATION ::=
7856 -- [formal_parameter_NAME =>] MECHANISM_NAME
7858 -- MECHANISM_NAME ::=
7861 -- | Descriptor [([Class =>] CLASS_NAME)]
7863 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7865 when Pragma_Export_Object => Export_Object : declare
7866 Args : Args_List (1 .. 3);
7867 Names : constant Name_List (1 .. 3) := (
7872 Internal : Node_Id renames Args (1);
7873 External : Node_Id renames Args (2);
7874 Size : Node_Id renames Args (3);
7878 Gather_Associations (Names, Args);
7879 Process_Extended_Import_Export_Object_Pragma (
7880 Arg_Internal => Internal,
7881 Arg_External => External,
7885 ----------------------
7886 -- Export_Procedure --
7887 ----------------------
7889 -- pragma Export_Procedure (
7890 -- [Internal =>] LOCAL_NAME
7891 -- [, [External =>] EXTERNAL_SYMBOL]
7892 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
7893 -- [, [Mechanism =>] MECHANISM]);
7895 -- EXTERNAL_SYMBOL ::=
7897 -- | static_string_EXPRESSION
7899 -- PARAMETER_TYPES ::=
7901 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
7903 -- TYPE_DESIGNATOR ::=
7905 -- | subtype_Name ' Access
7909 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
7911 -- MECHANISM_ASSOCIATION ::=
7912 -- [formal_parameter_NAME =>] MECHANISM_NAME
7914 -- MECHANISM_NAME ::=
7917 -- | Descriptor [([Class =>] CLASS_NAME)]
7919 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7921 when Pragma_Export_Procedure => Export_Procedure : declare
7922 Args : Args_List (1 .. 4);
7923 Names : constant Name_List (1 .. 4) := (
7926 Name_Parameter_Types,
7929 Internal : Node_Id renames Args (1);
7930 External : Node_Id renames Args (2);
7931 Parameter_Types : Node_Id renames Args (3);
7932 Mechanism : Node_Id renames Args (4);
7936 Gather_Associations (Names, Args);
7937 Process_Extended_Import_Export_Subprogram_Pragma (
7938 Arg_Internal => Internal,
7939 Arg_External => External,
7940 Arg_Parameter_Types => Parameter_Types,
7941 Arg_Mechanism => Mechanism);
7942 end Export_Procedure;
7948 -- pragma Export_Value (
7949 -- [Value =>] static_integer_EXPRESSION,
7950 -- [Link_Name =>] static_string_EXPRESSION);
7952 when Pragma_Export_Value =>
7954 Check_Arg_Order ((Name_Value, Name_Link_Name));
7955 Check_Arg_Count (2);
7957 Check_Optional_Identifier (Arg1, Name_Value);
7958 Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
7960 Check_Optional_Identifier (Arg2, Name_Link_Name);
7961 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
7963 -----------------------------
7964 -- Export_Valued_Procedure --
7965 -----------------------------
7967 -- pragma Export_Valued_Procedure (
7968 -- [Internal =>] LOCAL_NAME
7969 -- [, [External =>] EXTERNAL_SYMBOL,]
7970 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
7971 -- [, [Mechanism =>] MECHANISM]);
7973 -- EXTERNAL_SYMBOL ::=
7975 -- | static_string_EXPRESSION
7977 -- PARAMETER_TYPES ::=
7979 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
7981 -- TYPE_DESIGNATOR ::=
7983 -- | subtype_Name ' Access
7987 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
7989 -- MECHANISM_ASSOCIATION ::=
7990 -- [formal_parameter_NAME =>] MECHANISM_NAME
7992 -- MECHANISM_NAME ::=
7995 -- | Descriptor [([Class =>] CLASS_NAME)]
7997 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7999 when Pragma_Export_Valued_Procedure =>
8000 Export_Valued_Procedure : declare
8001 Args : Args_List (1 .. 4);
8002 Names : constant Name_List (1 .. 4) := (
8005 Name_Parameter_Types,
8008 Internal : Node_Id renames Args (1);
8009 External : Node_Id renames Args (2);
8010 Parameter_Types : Node_Id renames Args (3);
8011 Mechanism : Node_Id renames Args (4);
8015 Gather_Associations (Names, Args);
8016 Process_Extended_Import_Export_Subprogram_Pragma (
8017 Arg_Internal => Internal,
8018 Arg_External => External,
8019 Arg_Parameter_Types => Parameter_Types,
8020 Arg_Mechanism => Mechanism);
8021 end Export_Valued_Procedure;
8027 -- pragma Extend_System ([Name =>] Identifier);
8029 when Pragma_Extend_System => Extend_System : declare
8032 Check_Valid_Configuration_Pragma;
8033 Check_Arg_Count (1);
8034 Check_Optional_Identifier (Arg1, Name_Name);
8035 Check_Arg_Is_Identifier (Arg1);
8037 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
8040 and then Name_Buffer (1 .. 4) = "aux_"
8042 if Present (System_Extend_Pragma_Arg) then
8043 if Chars (Get_Pragma_Arg (Arg1)) =
8044 Chars (Expression (System_Extend_Pragma_Arg))
8048 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
8049 Error_Pragma ("pragma% conflicts with that #");
8053 System_Extend_Pragma_Arg := Arg1;
8055 if not GNAT_Mode then
8056 System_Extend_Unit := Arg1;
8060 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
8064 ------------------------
8065 -- Extensions_Allowed --
8066 ------------------------
8068 -- pragma Extensions_Allowed (ON | OFF);
8070 when Pragma_Extensions_Allowed =>
8072 Check_Arg_Count (1);
8073 Check_No_Identifiers;
8074 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
8076 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
8077 Extensions_Allowed := True;
8078 Ada_Version := Ada_Version_Type'Last;
8081 Extensions_Allowed := False;
8082 Ada_Version := Ada_Version_Explicit;
8089 -- pragma External (
8090 -- [ Convention =>] convention_IDENTIFIER,
8091 -- [ Entity =>] local_NAME
8092 -- [, [External_Name =>] static_string_EXPRESSION ]
8093 -- [, [Link_Name =>] static_string_EXPRESSION ]);
8095 when Pragma_External => External : declare
8099 pragma Warnings (Off, C);
8108 Check_At_Least_N_Arguments (2);
8109 Check_At_Most_N_Arguments (4);
8110 Process_Convention (C, Def_Id);
8111 Note_Possible_Modification
8112 (Get_Pragma_Arg (Arg2), Sure => False);
8113 Process_Interface_Name (Def_Id, Arg3, Arg4);
8114 Set_Exported (Def_Id, Arg2);
8117 --------------------------
8118 -- External_Name_Casing --
8119 --------------------------
8121 -- pragma External_Name_Casing (
8122 -- UPPERCASE | LOWERCASE
8123 -- [, AS_IS | UPPERCASE | LOWERCASE]);
8125 when Pragma_External_Name_Casing => External_Name_Casing : declare
8128 Check_No_Identifiers;
8130 if Arg_Count = 2 then
8132 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
8134 case Chars (Get_Pragma_Arg (Arg2)) is
8136 Opt.External_Name_Exp_Casing := As_Is;
8138 when Name_Uppercase =>
8139 Opt.External_Name_Exp_Casing := Uppercase;
8141 when Name_Lowercase =>
8142 Opt.External_Name_Exp_Casing := Lowercase;
8149 Check_Arg_Count (1);
8152 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
8154 case Chars (Get_Pragma_Arg (Arg1)) is
8155 when Name_Uppercase =>
8156 Opt.External_Name_Imp_Casing := Uppercase;
8158 when Name_Lowercase =>
8159 Opt.External_Name_Imp_Casing := Lowercase;
8164 end External_Name_Casing;
8166 --------------------------
8167 -- Favor_Top_Level --
8168 --------------------------
8170 -- pragma Favor_Top_Level (type_NAME);
8172 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
8173 Named_Entity : Entity_Id;
8177 Check_No_Identifiers;
8178 Check_Arg_Count (1);
8179 Check_Arg_Is_Local_Name (Arg1);
8180 Named_Entity := Entity (Get_Pragma_Arg (Arg1));
8182 -- If it's an access-to-subprogram type (in particular, not a
8183 -- subtype), set the flag on that type.
8185 if Is_Access_Subprogram_Type (Named_Entity) then
8187 Set_Can_Use_Internal_Rep (Named_Entity, False);
8190 -- Otherwise it's an error (name denotes the wrong sort of entity)
8194 ("access-to-subprogram type expected",
8195 Get_Pragma_Arg (Arg1));
8197 end Favor_Top_Level;
8203 -- pragma Fast_Math;
8205 when Pragma_Fast_Math =>
8207 Check_No_Identifiers;
8208 Check_Valid_Configuration_Pragma;
8211 ---------------------------
8212 -- Finalize_Storage_Only --
8213 ---------------------------
8215 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
8217 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
8218 Assoc : constant Node_Id := Arg1;
8219 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
8224 Check_No_Identifiers;
8225 Check_Arg_Count (1);
8226 Check_Arg_Is_Local_Name (Arg1);
8228 Find_Type (Type_Id);
8229 Typ := Entity (Type_Id);
8232 or else Rep_Item_Too_Early (Typ, N)
8236 Typ := Underlying_Type (Typ);
8239 if not Is_Controlled (Typ) then
8240 Error_Pragma ("pragma% must specify controlled type");
8243 Check_First_Subtype (Arg1);
8245 if Finalize_Storage_Only (Typ) then
8246 Error_Pragma ("duplicate pragma%, only one allowed");
8248 elsif not Rep_Item_Too_Late (Typ, N) then
8249 Set_Finalize_Storage_Only (Base_Type (Typ), True);
8251 end Finalize_Storage;
8253 --------------------------
8254 -- Float_Representation --
8255 --------------------------
8257 -- pragma Float_Representation (FLOAT_REP[, float_type_LOCAL_NAME]);
8259 -- FLOAT_REP ::= VAX_Float | IEEE_Float
8261 when Pragma_Float_Representation => Float_Representation : declare
8269 if Arg_Count = 1 then
8270 Check_Valid_Configuration_Pragma;
8272 Check_Arg_Count (2);
8273 Check_Optional_Identifier (Arg2, Name_Entity);
8274 Check_Arg_Is_Local_Name (Arg2);
8277 Check_No_Identifier (Arg1);
8278 Check_Arg_Is_One_Of (Arg1, Name_VAX_Float, Name_IEEE_Float);
8280 if not OpenVMS_On_Target then
8281 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
8283 ("?pragma% ignored (applies only to Open'V'M'S)");
8289 -- One argument case
8291 if Arg_Count = 1 then
8292 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
8293 if Opt.Float_Format = 'I' then
8294 Error_Pragma ("'I'E'E'E format previously specified");
8297 Opt.Float_Format := 'V';
8300 if Opt.Float_Format = 'V' then
8301 Error_Pragma ("'V'A'X format previously specified");
8304 Opt.Float_Format := 'I';
8307 Set_Standard_Fpt_Formats;
8309 -- Two argument case
8312 Argx := Get_Pragma_Arg (Arg2);
8314 if not Is_Entity_Name (Argx)
8315 or else not Is_Floating_Point_Type (Entity (Argx))
8318 ("second argument of% pragma must be floating-point type",
8322 Ent := Entity (Argx);
8323 Digs := UI_To_Int (Digits_Value (Ent));
8325 -- Two arguments, VAX_Float case
8327 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
8329 when 6 => Set_F_Float (Ent);
8330 when 9 => Set_D_Float (Ent);
8331 when 15 => Set_G_Float (Ent);
8335 ("wrong digits value, must be 6,9 or 15", Arg2);
8338 -- Two arguments, IEEE_Float case
8342 when 6 => Set_IEEE_Short (Ent);
8343 when 15 => Set_IEEE_Long (Ent);
8347 ("wrong digits value, must be 6 or 15", Arg2);
8351 end Float_Representation;
8357 -- pragma Ident (static_string_EXPRESSION)
8359 -- Note: pragma Comment shares this processing. Pragma Comment is
8360 -- identical to Ident, except that the restriction of the argument to
8361 -- 31 characters and the placement restrictions are not enforced for
8364 when Pragma_Ident | Pragma_Comment => Ident : declare
8369 Check_Arg_Count (1);
8370 Check_No_Identifiers;
8371 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
8374 -- For pragma Ident, preserve DEC compatibility by requiring the
8375 -- pragma to appear in a declarative part or package spec.
8377 if Prag_Id = Pragma_Ident then
8378 Check_Is_In_Decl_Part_Or_Package_Spec;
8381 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
8388 GP := Parent (Parent (N));
8390 if Nkind_In (GP, N_Package_Declaration,
8391 N_Generic_Package_Declaration)
8396 -- If we have a compilation unit, then record the ident value,
8397 -- checking for improper duplication.
8399 if Nkind (GP) = N_Compilation_Unit then
8400 CS := Ident_String (Current_Sem_Unit);
8402 if Present (CS) then
8404 -- For Ident, we do not permit multiple instances
8406 if Prag_Id = Pragma_Ident then
8407 Error_Pragma ("duplicate% pragma not permitted");
8409 -- For Comment, we concatenate the string, unless we want
8410 -- to preserve the tree structure for ASIS.
8412 elsif not ASIS_Mode then
8413 Start_String (Strval (CS));
8414 Store_String_Char (' ');
8415 Store_String_Chars (Strval (Str));
8416 Set_Strval (CS, End_String);
8420 -- In VMS, the effect of IDENT is achieved by passing
8421 -- --identification=name as a --for-linker switch.
8423 if OpenVMS_On_Target then
8426 ("--for-linker=--identification=");
8427 String_To_Name_Buffer (Strval (Str));
8428 Store_String_Chars (Name_Buffer (1 .. Name_Len));
8430 -- Only the last processed IDENT is saved. The main
8431 -- purpose is so an IDENT associated with a main
8432 -- procedure will be used in preference to an IDENT
8433 -- associated with a with'd package.
8435 Replace_Linker_Option_String
8436 (End_String, "--for-linker=--identification=");
8439 Set_Ident_String (Current_Sem_Unit, Str);
8442 -- For subunits, we just ignore the Ident, since in GNAT these
8443 -- are not separate object files, and hence not separate units
8444 -- in the unit table.
8446 elsif Nkind (GP) = N_Subunit then
8449 -- Otherwise we have a misplaced pragma Ident, but we ignore
8450 -- this if we are in an instantiation, since it comes from
8451 -- a generic, and has no relevance to the instantiation.
8453 elsif Prag_Id = Pragma_Ident then
8454 if Instantiation_Location (Loc) = No_Location then
8455 Error_Pragma ("pragma% only allowed at outer level");
8465 -- pragma Implemented (procedure_LOCAL_NAME, implementation_kind);
8466 -- implementation_kind ::= By_Entry | By_Protected_Procedure | By_Any
8468 when Pragma_Implemented => Implemented : declare
8469 Proc_Id : Entity_Id;
8474 Check_Arg_Count (2);
8475 Check_No_Identifiers;
8476 Check_Arg_Is_Identifier (Arg1);
8477 Check_Arg_Is_Local_Name (Arg1);
8479 (Arg2, Name_By_Any, Name_By_Entry, Name_By_Protected_Procedure);
8481 -- Extract the name of the local procedure
8483 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
8485 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
8486 -- primitive procedure of a synchronized tagged type.
8488 if Ekind (Proc_Id) = E_Procedure
8489 and then Is_Primitive (Proc_Id)
8490 and then Present (First_Formal (Proc_Id))
8492 Typ := Etype (First_Formal (Proc_Id));
8494 if Is_Tagged_Type (Typ)
8497 -- Check for a protected, a synchronized or a task interface
8499 ((Is_Interface (Typ)
8500 and then Is_Synchronized_Interface (Typ))
8502 -- Check for a protected type or a task type that implements
8506 (Is_Concurrent_Record_Type (Typ)
8507 and then Present (Interfaces (Typ)))
8509 -- Check for a private record extension with keyword
8513 (Ekind_In (Typ, E_Record_Type_With_Private,
8514 E_Record_Subtype_With_Private)
8515 and then Synchronized_Present (Parent (Typ))))
8520 ("controlling formal must be of synchronized " &
8521 "tagged type", Arg1);
8525 -- Procedures declared inside a protected type must be accepted
8527 elsif Ekind (Proc_Id) = E_Procedure
8528 and then Is_Protected_Type (Scope (Proc_Id))
8532 -- The first argument is not a primitive procedure
8536 ("pragma % must be applied to a primitive procedure", Arg1);
8540 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
8541 -- By_Protected_Procedure to the primitive procedure of a task
8544 if Chars (Arg2) = Name_By_Protected_Procedure
8545 and then Is_Interface (Typ)
8546 and then Is_Task_Interface (Typ)
8549 ("implementation kind By_Protected_Procedure cannot be " &
8550 "applied to a task interface primitive", Arg2);
8554 Record_Rep_Item (Proc_Id, N);
8557 ----------------------
8558 -- Implicit_Packing --
8559 ----------------------
8561 -- pragma Implicit_Packing;
8563 when Pragma_Implicit_Packing =>
8565 Check_Arg_Count (0);
8566 Implicit_Packing := True;
8573 -- [Convention =>] convention_IDENTIFIER,
8574 -- [Entity =>] local_NAME
8575 -- [, [External_Name =>] static_string_EXPRESSION ]
8576 -- [, [Link_Name =>] static_string_EXPRESSION ]);
8578 when Pragma_Import =>
8579 Check_Ada_83_Warning;
8585 Check_At_Least_N_Arguments (2);
8586 Check_At_Most_N_Arguments (4);
8587 Process_Import_Or_Interface;
8589 ----------------------
8590 -- Import_Exception --
8591 ----------------------
8593 -- pragma Import_Exception (
8594 -- [Internal =>] LOCAL_NAME
8595 -- [, [External =>] EXTERNAL_SYMBOL]
8596 -- [, [Form =>] Ada | VMS]
8597 -- [, [Code =>] static_integer_EXPRESSION]);
8599 when Pragma_Import_Exception => Import_Exception : declare
8600 Args : Args_List (1 .. 4);
8601 Names : constant Name_List (1 .. 4) := (
8607 Internal : Node_Id renames Args (1);
8608 External : Node_Id renames Args (2);
8609 Form : Node_Id renames Args (3);
8610 Code : Node_Id renames Args (4);
8614 Gather_Associations (Names, Args);
8616 if Present (External) and then Present (Code) then
8618 ("cannot give both External and Code options for pragma%");
8621 Process_Extended_Import_Export_Exception_Pragma (
8622 Arg_Internal => Internal,
8623 Arg_External => External,
8627 if not Is_VMS_Exception (Entity (Internal)) then
8628 Set_Imported (Entity (Internal));
8630 end Import_Exception;
8632 ---------------------
8633 -- Import_Function --
8634 ---------------------
8636 -- pragma Import_Function (
8637 -- [Internal =>] LOCAL_NAME,
8638 -- [, [External =>] EXTERNAL_SYMBOL]
8639 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
8640 -- [, [Result_Type =>] SUBTYPE_MARK]
8641 -- [, [Mechanism =>] MECHANISM]
8642 -- [, [Result_Mechanism =>] MECHANISM_NAME]
8643 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
8645 -- EXTERNAL_SYMBOL ::=
8647 -- | static_string_EXPRESSION
8649 -- PARAMETER_TYPES ::=
8651 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
8653 -- TYPE_DESIGNATOR ::=
8655 -- | subtype_Name ' Access
8659 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
8661 -- MECHANISM_ASSOCIATION ::=
8662 -- [formal_parameter_NAME =>] MECHANISM_NAME
8664 -- MECHANISM_NAME ::=
8667 -- | Descriptor [([Class =>] CLASS_NAME)]
8669 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
8671 when Pragma_Import_Function => Import_Function : declare
8672 Args : Args_List (1 .. 7);
8673 Names : constant Name_List (1 .. 7) := (
8676 Name_Parameter_Types,
8679 Name_Result_Mechanism,
8680 Name_First_Optional_Parameter);
8682 Internal : Node_Id renames Args (1);
8683 External : Node_Id renames Args (2);
8684 Parameter_Types : Node_Id renames Args (3);
8685 Result_Type : Node_Id renames Args (4);
8686 Mechanism : Node_Id renames Args (5);
8687 Result_Mechanism : Node_Id renames Args (6);
8688 First_Optional_Parameter : Node_Id renames Args (7);
8692 Gather_Associations (Names, Args);
8693 Process_Extended_Import_Export_Subprogram_Pragma (
8694 Arg_Internal => Internal,
8695 Arg_External => External,
8696 Arg_Parameter_Types => Parameter_Types,
8697 Arg_Result_Type => Result_Type,
8698 Arg_Mechanism => Mechanism,
8699 Arg_Result_Mechanism => Result_Mechanism,
8700 Arg_First_Optional_Parameter => First_Optional_Parameter);
8701 end Import_Function;
8707 -- pragma Import_Object (
8708 -- [Internal =>] LOCAL_NAME
8709 -- [, [External =>] EXTERNAL_SYMBOL]
8710 -- [, [Size =>] EXTERNAL_SYMBOL]);
8712 -- EXTERNAL_SYMBOL ::=
8714 -- | static_string_EXPRESSION
8716 when Pragma_Import_Object => Import_Object : declare
8717 Args : Args_List (1 .. 3);
8718 Names : constant Name_List (1 .. 3) := (
8723 Internal : Node_Id renames Args (1);
8724 External : Node_Id renames Args (2);
8725 Size : Node_Id renames Args (3);
8729 Gather_Associations (Names, Args);
8730 Process_Extended_Import_Export_Object_Pragma (
8731 Arg_Internal => Internal,
8732 Arg_External => External,
8736 ----------------------
8737 -- Import_Procedure --
8738 ----------------------
8740 -- pragma Import_Procedure (
8741 -- [Internal =>] LOCAL_NAME
8742 -- [, [External =>] EXTERNAL_SYMBOL]
8743 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
8744 -- [, [Mechanism =>] MECHANISM]
8745 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
8747 -- EXTERNAL_SYMBOL ::=
8749 -- | static_string_EXPRESSION
8751 -- PARAMETER_TYPES ::=
8753 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
8755 -- TYPE_DESIGNATOR ::=
8757 -- | subtype_Name ' Access
8761 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
8763 -- MECHANISM_ASSOCIATION ::=
8764 -- [formal_parameter_NAME =>] MECHANISM_NAME
8766 -- MECHANISM_NAME ::=
8769 -- | Descriptor [([Class =>] CLASS_NAME)]
8771 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
8773 when Pragma_Import_Procedure => Import_Procedure : declare
8774 Args : Args_List (1 .. 5);
8775 Names : constant Name_List (1 .. 5) := (
8778 Name_Parameter_Types,
8780 Name_First_Optional_Parameter);
8782 Internal : Node_Id renames Args (1);
8783 External : Node_Id renames Args (2);
8784 Parameter_Types : Node_Id renames Args (3);
8785 Mechanism : Node_Id renames Args (4);
8786 First_Optional_Parameter : Node_Id renames Args (5);
8790 Gather_Associations (Names, Args);
8791 Process_Extended_Import_Export_Subprogram_Pragma (
8792 Arg_Internal => Internal,
8793 Arg_External => External,
8794 Arg_Parameter_Types => Parameter_Types,
8795 Arg_Mechanism => Mechanism,
8796 Arg_First_Optional_Parameter => First_Optional_Parameter);
8797 end Import_Procedure;
8799 -----------------------------
8800 -- Import_Valued_Procedure --
8801 -----------------------------
8803 -- pragma Import_Valued_Procedure (
8804 -- [Internal =>] LOCAL_NAME
8805 -- [, [External =>] EXTERNAL_SYMBOL]
8806 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
8807 -- [, [Mechanism =>] MECHANISM]
8808 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
8810 -- EXTERNAL_SYMBOL ::=
8812 -- | static_string_EXPRESSION
8814 -- PARAMETER_TYPES ::=
8816 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
8818 -- TYPE_DESIGNATOR ::=
8820 -- | subtype_Name ' Access
8824 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
8826 -- MECHANISM_ASSOCIATION ::=
8827 -- [formal_parameter_NAME =>] MECHANISM_NAME
8829 -- MECHANISM_NAME ::=
8832 -- | Descriptor [([Class =>] CLASS_NAME)]
8834 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
8836 when Pragma_Import_Valued_Procedure =>
8837 Import_Valued_Procedure : declare
8838 Args : Args_List (1 .. 5);
8839 Names : constant Name_List (1 .. 5) := (
8842 Name_Parameter_Types,
8844 Name_First_Optional_Parameter);
8846 Internal : Node_Id renames Args (1);
8847 External : Node_Id renames Args (2);
8848 Parameter_Types : Node_Id renames Args (3);
8849 Mechanism : Node_Id renames Args (4);
8850 First_Optional_Parameter : Node_Id renames Args (5);
8854 Gather_Associations (Names, Args);
8855 Process_Extended_Import_Export_Subprogram_Pragma (
8856 Arg_Internal => Internal,
8857 Arg_External => External,
8858 Arg_Parameter_Types => Parameter_Types,
8859 Arg_Mechanism => Mechanism,
8860 Arg_First_Optional_Parameter => First_Optional_Parameter);
8861 end Import_Valued_Procedure;
8867 -- pragma Independent (LOCAL_NAME);
8869 when Pragma_Independent => Independent : declare
8876 Check_Ada_83_Warning;
8878 Check_No_Identifiers;
8879 Check_Arg_Count (1);
8880 Check_Arg_Is_Local_Name (Arg1);
8881 E_Id := Get_Pragma_Arg (Arg1);
8883 if Etype (E_Id) = Any_Type then
8888 D := Declaration_Node (E);
8891 -- Check duplicate before we chain ourselves!
8893 Check_Duplicate_Pragma (E);
8895 -- Check appropriate entity
8898 if Rep_Item_Too_Early (E, N)
8900 Rep_Item_Too_Late (E, N)
8904 Check_First_Subtype (Arg1);
8907 elsif K = N_Object_Declaration
8908 or else (K = N_Component_Declaration
8909 and then Original_Record_Component (E) = E)
8911 if Rep_Item_Too_Late (E, N) then
8917 ("inappropriate entity for pragma%", Arg1);
8920 Independence_Checks.Append ((N, E));
8923 ----------------------------
8924 -- Independent_Components --
8925 ----------------------------
8927 -- pragma Atomic_Components (array_LOCAL_NAME);
8929 -- This processing is shared by Volatile_Components
8931 when Pragma_Independent_Components => Independent_Components : declare
8938 Check_Ada_83_Warning;
8940 Check_No_Identifiers;
8941 Check_Arg_Count (1);
8942 Check_Arg_Is_Local_Name (Arg1);
8943 E_Id := Get_Pragma_Arg (Arg1);
8945 if Etype (E_Id) = Any_Type then
8951 -- Check duplicate before we chain ourselves!
8953 Check_Duplicate_Pragma (E);
8955 -- Check appropriate entity
8957 if Rep_Item_Too_Early (E, N)
8959 Rep_Item_Too_Late (E, N)
8964 D := Declaration_Node (E);
8967 if (K = N_Full_Type_Declaration
8968 and then (Is_Array_Type (E) or else Is_Record_Type (E)))
8970 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
8971 and then Nkind (D) = N_Object_Declaration
8972 and then Nkind (Object_Definition (D)) =
8973 N_Constrained_Array_Definition)
8975 Independence_Checks.Append ((N, E));
8978 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
8980 end Independent_Components;
8982 ------------------------
8983 -- Initialize_Scalars --
8984 ------------------------
8986 -- pragma Initialize_Scalars;
8988 when Pragma_Initialize_Scalars =>
8990 Check_Arg_Count (0);
8991 Check_Valid_Configuration_Pragma;
8992 Check_Restriction (No_Initialize_Scalars, N);
8994 -- Initialize_Scalars creates false positives in CodePeer,
8995 -- so ignore this pragma in this mode.
8997 if not Restriction_Active (No_Initialize_Scalars)
8998 and then not CodePeer_Mode
9000 Init_Or_Norm_Scalars := True;
9001 Initialize_Scalars := True;
9008 -- pragma Inline ( NAME {, NAME} );
9010 when Pragma_Inline =>
9012 -- Pragma is active if inlining option is active
9014 Process_Inline (Inline_Active);
9020 -- pragma Inline_Always ( NAME {, NAME} );
9022 when Pragma_Inline_Always =>
9025 -- Pragma always active unless in CodePeer mode, since this causes
9026 -- walk order issues.
9028 if not CodePeer_Mode then
9029 Process_Inline (True);
9032 --------------------
9033 -- Inline_Generic --
9034 --------------------
9036 -- pragma Inline_Generic (NAME {, NAME});
9038 when Pragma_Inline_Generic =>
9040 Process_Generic_List;
9042 ----------------------
9043 -- Inspection_Point --
9044 ----------------------
9046 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
9048 when Pragma_Inspection_Point => Inspection_Point : declare
9053 if Arg_Count > 0 then
9056 Exp := Get_Pragma_Arg (Arg);
9059 if not Is_Entity_Name (Exp)
9060 or else not Is_Object (Entity (Exp))
9062 Error_Pragma_Arg ("object name required", Arg);
9069 end Inspection_Point;
9075 -- pragma Interface (
9076 -- [ Convention =>] convention_IDENTIFIER,
9077 -- [ Entity =>] local_NAME
9078 -- [, [External_Name =>] static_string_EXPRESSION ]
9079 -- [, [Link_Name =>] static_string_EXPRESSION ]);
9081 when Pragma_Interface =>
9088 Check_At_Least_N_Arguments (2);
9089 Check_At_Most_N_Arguments (4);
9090 Process_Import_Or_Interface;
9092 -- In Ada 2005, the permission to use Interface (a reserved word)
9093 -- as a pragma name is considered an obsolescent feature.
9095 if Ada_Version >= Ada_2005 then
9097 (No_Obsolescent_Features, Pragma_Identifier (N));
9100 --------------------
9101 -- Interface_Name --
9102 --------------------
9104 -- pragma Interface_Name (
9105 -- [ Entity =>] local_NAME
9106 -- [,[External_Name =>] static_string_EXPRESSION ]
9107 -- [,[Link_Name =>] static_string_EXPRESSION ]);
9109 when Pragma_Interface_Name => Interface_Name : declare
9118 ((Name_Entity, Name_External_Name, Name_Link_Name));
9119 Check_At_Least_N_Arguments (2);
9120 Check_At_Most_N_Arguments (3);
9121 Id := Get_Pragma_Arg (Arg1);
9124 if not Is_Entity_Name (Id) then
9126 ("first argument for pragma% must be entity name", Arg1);
9127 elsif Etype (Id) = Any_Type then
9130 Def_Id := Entity (Id);
9133 -- Special DEC-compatible processing for the object case, forces
9134 -- object to be imported.
9136 if Ekind (Def_Id) = E_Variable then
9137 Kill_Size_Check_Code (Def_Id);
9138 Note_Possible_Modification (Id, Sure => False);
9140 -- Initialization is not allowed for imported variable
9142 if Present (Expression (Parent (Def_Id)))
9143 and then Comes_From_Source (Expression (Parent (Def_Id)))
9145 Error_Msg_Sloc := Sloc (Def_Id);
9147 ("no initialization allowed for declaration of& #",
9151 -- For compatibility, support VADS usage of providing both
9152 -- pragmas Interface and Interface_Name to obtain the effect
9153 -- of a single Import pragma.
9155 if Is_Imported (Def_Id)
9156 and then Present (First_Rep_Item (Def_Id))
9157 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
9159 Pragma_Name (First_Rep_Item (Def_Id)) = Name_Interface
9163 Set_Imported (Def_Id);
9166 Set_Is_Public (Def_Id);
9167 Process_Interface_Name (Def_Id, Arg2, Arg3);
9170 -- Otherwise must be subprogram
9172 elsif not Is_Subprogram (Def_Id) then
9174 ("argument of pragma% is not subprogram", Arg1);
9177 Check_At_Most_N_Arguments (3);
9181 -- Loop through homonyms
9184 Def_Id := Get_Base_Subprogram (Hom_Id);
9186 if Is_Imported (Def_Id) then
9187 Process_Interface_Name (Def_Id, Arg2, Arg3);
9191 exit when From_Aspect_Specification (N);
9192 Hom_Id := Homonym (Hom_Id);
9194 exit when No (Hom_Id)
9195 or else Scope (Hom_Id) /= Current_Scope;
9200 ("argument of pragma% is not imported subprogram",
9206 -----------------------
9207 -- Interrupt_Handler --
9208 -----------------------
9210 -- pragma Interrupt_Handler (handler_NAME);
9212 when Pragma_Interrupt_Handler =>
9213 Check_Ada_83_Warning;
9214 Check_Arg_Count (1);
9215 Check_No_Identifiers;
9217 if No_Run_Time_Mode then
9218 Error_Msg_CRT ("Interrupt_Handler pragma", N);
9220 Check_Interrupt_Or_Attach_Handler;
9221 Process_Interrupt_Or_Attach_Handler;
9224 ------------------------
9225 -- Interrupt_Priority --
9226 ------------------------
9228 -- pragma Interrupt_Priority [(EXPRESSION)];
9230 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
9231 P : constant Node_Id := Parent (N);
9235 Check_Ada_83_Warning;
9237 if Arg_Count /= 0 then
9238 Arg := Get_Pragma_Arg (Arg1);
9239 Check_Arg_Count (1);
9240 Check_No_Identifiers;
9242 -- The expression must be analyzed in the special manner
9243 -- described in "Handling of Default and Per-Object
9244 -- Expressions" in sem.ads.
9246 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
9249 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
9253 elsif Has_Pragma_Priority (P) then
9254 Error_Pragma ("duplicate pragma% not allowed");
9257 Set_Has_Pragma_Priority (P, True);
9258 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
9260 end Interrupt_Priority;
9262 ---------------------
9263 -- Interrupt_State --
9264 ---------------------
9266 -- pragma Interrupt_State (
9267 -- [Name =>] INTERRUPT_ID,
9268 -- [State =>] INTERRUPT_STATE);
9270 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
9271 -- INTERRUPT_STATE => System | Runtime | User
9273 -- Note: if the interrupt id is given as an identifier, then it must
9274 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
9275 -- given as a static integer expression which must be in the range of
9276 -- Ada.Interrupts.Interrupt_ID.
9278 when Pragma_Interrupt_State => Interrupt_State : declare
9280 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
9281 -- This is the entity Ada.Interrupts.Interrupt_ID;
9283 State_Type : Character;
9284 -- Set to 's'/'r'/'u' for System/Runtime/User
9287 -- Index to entry in Interrupt_States table
9290 -- Value of interrupt
9292 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
9293 -- The first argument to the pragma
9295 Int_Ent : Entity_Id;
9296 -- Interrupt entity in Ada.Interrupts.Names
9300 Check_Arg_Order ((Name_Name, Name_State));
9301 Check_Arg_Count (2);
9303 Check_Optional_Identifier (Arg1, Name_Name);
9304 Check_Optional_Identifier (Arg2, Name_State);
9305 Check_Arg_Is_Identifier (Arg2);
9307 -- First argument is identifier
9309 if Nkind (Arg1X) = N_Identifier then
9311 -- Search list of names in Ada.Interrupts.Names
9313 Int_Ent := First_Entity (RTE (RE_Names));
9315 if No (Int_Ent) then
9316 Error_Pragma_Arg ("invalid interrupt name", Arg1);
9318 elsif Chars (Int_Ent) = Chars (Arg1X) then
9319 Int_Val := Expr_Value (Constant_Value (Int_Ent));
9323 Next_Entity (Int_Ent);
9326 -- First argument is not an identifier, so it must be a static
9327 -- expression of type Ada.Interrupts.Interrupt_ID.
9330 Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
9331 Int_Val := Expr_Value (Arg1X);
9333 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
9335 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
9338 ("value not in range of type " &
9339 """Ada.Interrupts.Interrupt_'I'D""", Arg1);
9345 case Chars (Get_Pragma_Arg (Arg2)) is
9346 when Name_Runtime => State_Type := 'r';
9347 when Name_System => State_Type := 's';
9348 when Name_User => State_Type := 'u';
9351 Error_Pragma_Arg ("invalid interrupt state", Arg2);
9354 -- Check if entry is already stored
9356 IST_Num := Interrupt_States.First;
9358 -- If entry not found, add it
9360 if IST_Num > Interrupt_States.Last then
9361 Interrupt_States.Append
9362 ((Interrupt_Number => UI_To_Int (Int_Val),
9363 Interrupt_State => State_Type,
9364 Pragma_Loc => Loc));
9367 -- Case of entry for the same entry
9369 elsif Int_Val = Interrupt_States.Table (IST_Num).
9372 -- If state matches, done, no need to make redundant entry
9375 State_Type = Interrupt_States.Table (IST_Num).
9378 -- Otherwise if state does not match, error
9381 Interrupt_States.Table (IST_Num).Pragma_Loc;
9383 ("state conflicts with that given #", Arg2);
9387 IST_Num := IST_Num + 1;
9389 end Interrupt_State;
9396 -- ([Entity =>] type_LOCAL_NAME,
9397 -- [Check =>] EXPRESSION
9398 -- [,[Message =>] String_Expression]);
9400 when Pragma_Invariant => Invariant : declare
9405 pragma Unreferenced (Discard);
9409 Check_At_Least_N_Arguments (2);
9410 Check_At_Most_N_Arguments (3);
9411 Check_Optional_Identifier (Arg1, Name_Entity);
9412 Check_Optional_Identifier (Arg2, Name_Check);
9414 if Arg_Count = 3 then
9415 Check_Optional_Identifier (Arg3, Name_Message);
9416 Check_Arg_Is_Static_Expression (Arg3, Standard_String);
9419 Check_Arg_Is_Local_Name (Arg1);
9421 Type_Id := Get_Pragma_Arg (Arg1);
9422 Find_Type (Type_Id);
9423 Typ := Entity (Type_Id);
9425 if Typ = Any_Type then
9428 elsif not Ekind_In (Typ, E_Private_Type,
9429 E_Record_Type_With_Private,
9430 E_Limited_Private_Type)
9433 ("pragma% only allowed for private type", Arg1);
9436 -- Note that the type has at least one invariant, and also that
9437 -- it has inheritable invariants if we have Invariant'Class.
9439 Set_Has_Invariants (Typ);
9441 if Class_Present (N) then
9442 Set_Has_Inheritable_Invariants (Typ);
9445 -- The remaining processing is simply to link the pragma on to
9446 -- the rep item chain, for processing when the type is frozen.
9447 -- This is accomplished by a call to Rep_Item_Too_Late.
9449 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
9452 ----------------------
9453 -- Java_Constructor --
9454 ----------------------
9456 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
9458 -- Also handles pragma CIL_Constructor
9460 when Pragma_CIL_Constructor | Pragma_Java_Constructor =>
9461 Java_Constructor : declare
9462 Convention : Convention_Id;
9466 This_Formal : Entity_Id;
9470 Check_Arg_Count (1);
9471 Check_Optional_Identifier (Arg1, Name_Entity);
9472 Check_Arg_Is_Local_Name (Arg1);
9474 Id := Get_Pragma_Arg (Arg1);
9475 Find_Program_Unit_Name (Id);
9477 -- If we did not find the name, we are done
9479 if Etype (Id) = Any_Type then
9483 -- Check wrong use of pragma in wrong VM target
9485 if VM_Target = No_VM then
9488 elsif VM_Target = CLI_Target
9489 and then Prag_Id = Pragma_Java_Constructor
9491 Error_Pragma ("must use pragma 'C'I'L_'Constructor");
9493 elsif VM_Target = JVM_Target
9494 and then Prag_Id = Pragma_CIL_Constructor
9496 Error_Pragma ("must use pragma 'Java_'Constructor");
9500 when Pragma_CIL_Constructor => Convention := Convention_CIL;
9501 when Pragma_Java_Constructor => Convention := Convention_Java;
9502 when others => null;
9505 Hom_Id := Entity (Id);
9507 -- Loop through homonyms
9510 Def_Id := Get_Base_Subprogram (Hom_Id);
9512 -- The constructor is required to be a function
9514 if Ekind (Def_Id) /= E_Function then
9515 if VM_Target = JVM_Target then
9517 ("pragma% requires function returning a " &
9518 "'Java access type", Def_Id);
9521 ("pragma% requires function returning a " &
9522 "'C'I'L access type", Def_Id);
9526 -- Check arguments: For tagged type the first formal must be
9527 -- named "this" and its type must be a named access type
9528 -- designating a class-wide tagged type that has convention
9529 -- CIL/Java. The first formal must also have a null default
9530 -- value. For example:
9532 -- type Typ is tagged ...
9533 -- type Ref is access all Typ;
9534 -- pragma Convention (CIL, Typ);
9536 -- function New_Typ (This : Ref) return Ref;
9537 -- function New_Typ (This : Ref; I : Integer) return Ref;
9538 -- pragma Cil_Constructor (New_Typ);
9540 -- Reason: The first formal must NOT be a primitive of the
9543 -- This rule also applies to constructors of delegates used
9544 -- to interface with standard target libraries. For example:
9546 -- type Delegate is access procedure ...
9547 -- pragma Import (CIL, Delegate, ...);
9549 -- function new_Delegate
9550 -- (This : Delegate := null; ... ) return Delegate;
9552 -- For value-types this rule does not apply.
9554 if not Is_Value_Type (Etype (Def_Id)) then
9555 if No (First_Formal (Def_Id)) then
9556 Error_Msg_Name_1 := Pname;
9557 Error_Msg_N ("% function must have parameters", Def_Id);
9561 -- In the JRE library we have several occurrences in which
9562 -- the "this" parameter is not the first formal.
9564 This_Formal := First_Formal (Def_Id);
9566 -- In the JRE library we have several occurrences in which
9567 -- the "this" parameter is not the first formal. Search for
9570 if VM_Target = JVM_Target then
9571 while Present (This_Formal)
9572 and then Get_Name_String (Chars (This_Formal)) /= "this"
9574 Next_Formal (This_Formal);
9577 if No (This_Formal) then
9578 This_Formal := First_Formal (Def_Id);
9582 -- Warning: The first parameter should be named "this".
9583 -- We temporarily allow it because we have the following
9584 -- case in the Java runtime (file s-osinte.ads) ???
9586 -- function new_Thread
9587 -- (Self_Id : System.Address) return Thread_Id;
9588 -- pragma Java_Constructor (new_Thread);
9590 if VM_Target = JVM_Target
9591 and then Get_Name_String (Chars (First_Formal (Def_Id)))
9593 and then Etype (First_Formal (Def_Id)) = RTE (RE_Address)
9597 elsif Get_Name_String (Chars (This_Formal)) /= "this" then
9598 Error_Msg_Name_1 := Pname;
9600 ("first formal of % function must be named `this`",
9601 Parent (This_Formal));
9603 elsif not Is_Access_Type (Etype (This_Formal)) then
9604 Error_Msg_Name_1 := Pname;
9606 ("first formal of % function must be an access type",
9607 Parameter_Type (Parent (This_Formal)));
9609 -- For delegates the type of the first formal must be a
9610 -- named access-to-subprogram type (see previous example)
9612 elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type
9613 and then Ekind (Etype (This_Formal))
9614 /= E_Access_Subprogram_Type
9616 Error_Msg_Name_1 := Pname;
9618 ("first formal of % function must be a named access" &
9619 " to subprogram type",
9620 Parameter_Type (Parent (This_Formal)));
9622 -- Warning: We should reject anonymous access types because
9623 -- the constructor must not be handled as a primitive of the
9624 -- tagged type. We temporarily allow it because this profile
9625 -- is currently generated by cil2ada???
9627 elsif Ekind (Etype (Def_Id)) /= E_Access_Subprogram_Type
9628 and then not Ekind_In (Etype (This_Formal),
9630 E_General_Access_Type,
9631 E_Anonymous_Access_Type)
9633 Error_Msg_Name_1 := Pname;
9635 ("first formal of % function must be a named access" &
9637 Parameter_Type (Parent (This_Formal)));
9639 elsif Atree.Convention
9640 (Designated_Type (Etype (This_Formal))) /= Convention
9642 Error_Msg_Name_1 := Pname;
9644 if Convention = Convention_Java then
9646 ("pragma% requires convention 'Cil in designated" &
9648 Parameter_Type (Parent (This_Formal)));
9651 ("pragma% requires convention 'Java in designated" &
9653 Parameter_Type (Parent (This_Formal)));
9656 elsif No (Expression (Parent (This_Formal)))
9657 or else Nkind (Expression (Parent (This_Formal))) /= N_Null
9659 Error_Msg_Name_1 := Pname;
9661 ("pragma% requires first formal with default `null`",
9662 Parameter_Type (Parent (This_Formal)));
9666 -- Check result type: the constructor must be a function
9668 -- * a value type (only allowed in the CIL compiler)
9669 -- * an access-to-subprogram type with convention Java/CIL
9670 -- * an access-type designating a type that has convention
9673 if Is_Value_Type (Etype (Def_Id)) then
9676 -- Access-to-subprogram type with convention Java/CIL
9678 elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type then
9679 if Atree.Convention (Etype (Def_Id)) /= Convention then
9680 if Convention = Convention_Java then
9682 ("pragma% requires function returning a " &
9683 "'Java access type", Arg1);
9685 pragma Assert (Convention = Convention_CIL);
9687 ("pragma% requires function returning a " &
9688 "'C'I'L access type", Arg1);
9692 elsif Ekind (Etype (Def_Id)) in Access_Kind then
9693 if not Ekind_In (Etype (Def_Id), E_Access_Type,
9694 E_General_Access_Type)
9697 (Designated_Type (Etype (Def_Id))) /= Convention
9699 Error_Msg_Name_1 := Pname;
9701 if Convention = Convention_Java then
9703 ("pragma% requires function returning a named" &
9704 "'Java access type", Arg1);
9707 ("pragma% requires function returning a named" &
9708 "'C'I'L access type", Arg1);
9713 Set_Is_Constructor (Def_Id);
9714 Set_Convention (Def_Id, Convention);
9715 Set_Is_Imported (Def_Id);
9717 exit when From_Aspect_Specification (N);
9718 Hom_Id := Homonym (Hom_Id);
9720 exit when No (Hom_Id) or else Scope (Hom_Id) /= Current_Scope;
9722 end Java_Constructor;
9724 ----------------------
9725 -- Java_Interface --
9726 ----------------------
9728 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
9730 when Pragma_Java_Interface => Java_Interface : declare
9736 Check_Arg_Count (1);
9737 Check_Optional_Identifier (Arg1, Name_Entity);
9738 Check_Arg_Is_Local_Name (Arg1);
9740 Arg := Get_Pragma_Arg (Arg1);
9743 if Etype (Arg) = Any_Type then
9747 if not Is_Entity_Name (Arg)
9748 or else not Is_Type (Entity (Arg))
9750 Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
9753 Typ := Underlying_Type (Entity (Arg));
9755 -- For now simply check some of the semantic constraints on the
9756 -- type. This currently leaves out some restrictions on interface
9757 -- types, namely that the parent type must be java.lang.Object.Typ
9758 -- and that all primitives of the type should be declared
9761 if not Is_Tagged_Type (Typ) or else not Is_Abstract_Type (Typ) then
9762 Error_Pragma_Arg ("pragma% requires an abstract "
9763 & "tagged type", Arg1);
9765 elsif not Has_Discriminants (Typ)
9766 or else Ekind (Etype (First_Discriminant (Typ)))
9767 /= E_Anonymous_Access_Type
9769 not Is_Class_Wide_Type
9770 (Designated_Type (Etype (First_Discriminant (Typ))))
9773 ("type must have a class-wide access discriminant", Arg1);
9781 -- pragma Keep_Names ([On => ] local_NAME);
9783 when Pragma_Keep_Names => Keep_Names : declare
9788 Check_Arg_Count (1);
9789 Check_Optional_Identifier (Arg1, Name_On);
9790 Check_Arg_Is_Local_Name (Arg1);
9792 Arg := Get_Pragma_Arg (Arg1);
9795 if Etype (Arg) = Any_Type then
9799 if not Is_Entity_Name (Arg)
9800 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
9803 ("pragma% requires a local enumeration type", Arg1);
9806 Set_Discard_Names (Entity (Arg), False);
9813 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
9815 when Pragma_License =>
9817 Check_Arg_Count (1);
9818 Check_No_Identifiers;
9819 Check_Valid_Configuration_Pragma;
9820 Check_Arg_Is_Identifier (Arg1);
9823 Sind : constant Source_File_Index :=
9824 Source_Index (Current_Sem_Unit);
9827 case Chars (Get_Pragma_Arg (Arg1)) is
9829 Set_License (Sind, GPL);
9831 when Name_Modified_GPL =>
9832 Set_License (Sind, Modified_GPL);
9834 when Name_Restricted =>
9835 Set_License (Sind, Restricted);
9837 when Name_Unrestricted =>
9838 Set_License (Sind, Unrestricted);
9841 Error_Pragma_Arg ("invalid license name", Arg1);
9849 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
9851 when Pragma_Link_With => Link_With : declare
9857 if Operating_Mode = Generate_Code
9858 and then In_Extended_Main_Source_Unit (N)
9860 Check_At_Least_N_Arguments (1);
9861 Check_No_Identifiers;
9862 Check_Is_In_Decl_Part_Or_Package_Spec;
9863 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
9867 while Present (Arg) loop
9868 Check_Arg_Is_Static_Expression (Arg, Standard_String);
9870 -- Store argument, converting sequences of spaces to a
9871 -- single null character (this is one of the differences
9872 -- in processing between Link_With and Linker_Options).
9875 C : constant Char_Code := Get_Char_Code (' ');
9876 S : constant String_Id :=
9877 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
9878 L : constant Nat := String_Length (S);
9881 procedure Skip_Spaces;
9882 -- Advance F past any spaces
9888 procedure Skip_Spaces is
9890 while F <= L and then Get_String_Char (S, F) = C loop
9895 -- Start of processing for Arg_Store
9898 Skip_Spaces; -- skip leading spaces
9900 -- Loop through characters, changing any embedded
9901 -- sequence of spaces to a single null character (this
9902 -- is how Link_With/Linker_Options differ)
9905 if Get_String_Char (S, F) = C then
9908 Store_String_Char (ASCII.NUL);
9911 Store_String_Char (Get_String_Char (S, F));
9919 if Present (Arg) then
9920 Store_String_Char (ASCII.NUL);
9924 Store_Linker_Option_String (End_String);
9932 -- pragma Linker_Alias (
9933 -- [Entity =>] LOCAL_NAME
9934 -- [Target =>] static_string_EXPRESSION);
9936 when Pragma_Linker_Alias =>
9938 Check_Arg_Order ((Name_Entity, Name_Target));
9939 Check_Arg_Count (2);
9940 Check_Optional_Identifier (Arg1, Name_Entity);
9941 Check_Optional_Identifier (Arg2, Name_Target);
9942 Check_Arg_Is_Library_Level_Local_Name (Arg1);
9943 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
9945 -- The only processing required is to link this item on to the
9946 -- list of rep items for the given entity. This is accomplished
9947 -- by the call to Rep_Item_Too_Late (when no error is detected
9948 -- and False is returned).
9950 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
9953 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
9956 ------------------------
9957 -- Linker_Constructor --
9958 ------------------------
9960 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
9962 -- Code is shared with Linker_Destructor
9964 -----------------------
9965 -- Linker_Destructor --
9966 -----------------------
9968 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
9970 when Pragma_Linker_Constructor |
9971 Pragma_Linker_Destructor =>
9972 Linker_Constructor : declare
9978 Check_Arg_Count (1);
9979 Check_No_Identifiers;
9980 Check_Arg_Is_Local_Name (Arg1);
9981 Arg1_X := Get_Pragma_Arg (Arg1);
9983 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
9985 if not Is_Library_Level_Entity (Proc) then
9987 ("argument for pragma% must be library level entity", Arg1);
9990 -- The only processing required is to link this item on to the
9991 -- list of rep items for the given entity. This is accomplished
9992 -- by the call to Rep_Item_Too_Late (when no error is detected
9993 -- and False is returned).
9995 if Rep_Item_Too_Late (Proc, N) then
9998 Set_Has_Gigi_Rep_Item (Proc);
10000 end Linker_Constructor;
10002 --------------------
10003 -- Linker_Options --
10004 --------------------
10006 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
10008 when Pragma_Linker_Options => Linker_Options : declare
10012 Check_Ada_83_Warning;
10013 Check_No_Identifiers;
10014 Check_Arg_Count (1);
10015 Check_Is_In_Decl_Part_Or_Package_Spec;
10016 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
10017 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
10020 while Present (Arg) loop
10021 Check_Arg_Is_Static_Expression (Arg, Standard_String);
10022 Store_String_Char (ASCII.NUL);
10024 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
10028 if Operating_Mode = Generate_Code
10029 and then In_Extended_Main_Source_Unit (N)
10031 Store_Linker_Option_String (End_String);
10033 end Linker_Options;
10035 --------------------
10036 -- Linker_Section --
10037 --------------------
10039 -- pragma Linker_Section (
10040 -- [Entity =>] LOCAL_NAME
10041 -- [Section =>] static_string_EXPRESSION);
10043 when Pragma_Linker_Section =>
10045 Check_Arg_Order ((Name_Entity, Name_Section));
10046 Check_Arg_Count (2);
10047 Check_Optional_Identifier (Arg1, Name_Entity);
10048 Check_Optional_Identifier (Arg2, Name_Section);
10049 Check_Arg_Is_Library_Level_Local_Name (Arg1);
10050 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
10052 -- This pragma applies only to objects
10054 if not Is_Object (Entity (Get_Pragma_Arg (Arg1))) then
10055 Error_Pragma_Arg ("pragma% applies only to objects", Arg1);
10058 -- The only processing required is to link this item on to the
10059 -- list of rep items for the given entity. This is accomplished
10060 -- by the call to Rep_Item_Too_Late (when no error is detected
10061 -- and False is returned).
10063 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
10066 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
10073 -- pragma List (On | Off)
10075 -- There is nothing to do here, since we did all the processing for
10076 -- this pragma in Par.Prag (so that it works properly even in syntax
10079 when Pragma_List =>
10082 --------------------
10083 -- Locking_Policy --
10084 --------------------
10086 -- pragma Locking_Policy (policy_IDENTIFIER);
10088 when Pragma_Locking_Policy => declare
10092 Check_Ada_83_Warning;
10093 Check_Arg_Count (1);
10094 Check_No_Identifiers;
10095 Check_Arg_Is_Locking_Policy (Arg1);
10096 Check_Valid_Configuration_Pragma;
10097 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
10098 LP := Fold_Upper (Name_Buffer (1));
10100 if Locking_Policy /= ' '
10101 and then Locking_Policy /= LP
10103 Error_Msg_Sloc := Locking_Policy_Sloc;
10104 Error_Pragma ("locking policy incompatible with policy#");
10106 -- Set new policy, but always preserve System_Location since we
10107 -- like the error message with the run time name.
10110 Locking_Policy := LP;
10112 if Locking_Policy_Sloc /= System_Location then
10113 Locking_Policy_Sloc := Loc;
10122 -- pragma Long_Float (D_Float | G_Float);
10124 when Pragma_Long_Float =>
10126 Check_Valid_Configuration_Pragma;
10127 Check_Arg_Count (1);
10128 Check_No_Identifier (Arg1);
10129 Check_Arg_Is_One_Of (Arg1, Name_D_Float, Name_G_Float);
10131 if not OpenVMS_On_Target then
10132 Error_Pragma ("?pragma% ignored (applies only to Open'V'M'S)");
10137 if Chars (Get_Pragma_Arg (Arg1)) = Name_D_Float then
10138 if Opt.Float_Format_Long = 'G' then
10139 Error_Pragma ("G_Float previously specified");
10142 Opt.Float_Format_Long := 'D';
10144 -- G_Float case (this is the default, does not need overriding)
10147 if Opt.Float_Format_Long = 'D' then
10148 Error_Pragma ("D_Float previously specified");
10151 Opt.Float_Format_Long := 'G';
10154 Set_Standard_Fpt_Formats;
10156 -----------------------
10157 -- Machine_Attribute --
10158 -----------------------
10160 -- pragma Machine_Attribute (
10161 -- [Entity =>] LOCAL_NAME,
10162 -- [Attribute_Name =>] static_string_EXPRESSION
10163 -- [, [Info =>] static_EXPRESSION] );
10165 when Pragma_Machine_Attribute => Machine_Attribute : declare
10166 Def_Id : Entity_Id;
10170 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
10172 if Arg_Count = 3 then
10173 Check_Optional_Identifier (Arg3, Name_Info);
10174 Check_Arg_Is_Static_Expression (Arg3);
10176 Check_Arg_Count (2);
10179 Check_Optional_Identifier (Arg1, Name_Entity);
10180 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
10181 Check_Arg_Is_Local_Name (Arg1);
10182 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
10183 Def_Id := Entity (Get_Pragma_Arg (Arg1));
10185 if Is_Access_Type (Def_Id) then
10186 Def_Id := Designated_Type (Def_Id);
10189 if Rep_Item_Too_Early (Def_Id, N) then
10193 Def_Id := Underlying_Type (Def_Id);
10195 -- The only processing required is to link this item on to the
10196 -- list of rep items for the given entity. This is accomplished
10197 -- by the call to Rep_Item_Too_Late (when no error is detected
10198 -- and False is returned).
10200 if Rep_Item_Too_Late (Def_Id, N) then
10203 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
10205 end Machine_Attribute;
10212 -- (MAIN_OPTION [, MAIN_OPTION]);
10215 -- [STACK_SIZE =>] static_integer_EXPRESSION
10216 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
10217 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
10219 when Pragma_Main => Main : declare
10220 Args : Args_List (1 .. 3);
10221 Names : constant Name_List (1 .. 3) := (
10223 Name_Task_Stack_Size_Default,
10224 Name_Time_Slicing_Enabled);
10230 Gather_Associations (Names, Args);
10232 for J in 1 .. 2 loop
10233 if Present (Args (J)) then
10234 Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
10238 if Present (Args (3)) then
10239 Check_Arg_Is_Static_Expression (Args (3), Standard_Boolean);
10243 while Present (Nod) loop
10244 if Nkind (Nod) = N_Pragma
10245 and then Pragma_Name (Nod) = Name_Main
10247 Error_Msg_Name_1 := Pname;
10248 Error_Msg_N ("duplicate pragma% not permitted", Nod);
10259 -- pragma Main_Storage
10260 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
10262 -- MAIN_STORAGE_OPTION ::=
10263 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
10264 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
10266 when Pragma_Main_Storage => Main_Storage : declare
10267 Args : Args_List (1 .. 2);
10268 Names : constant Name_List (1 .. 2) := (
10269 Name_Working_Storage,
10276 Gather_Associations (Names, Args);
10278 for J in 1 .. 2 loop
10279 if Present (Args (J)) then
10280 Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
10284 Check_In_Main_Program;
10287 while Present (Nod) loop
10288 if Nkind (Nod) = N_Pragma
10289 and then Pragma_Name (Nod) = Name_Main_Storage
10291 Error_Msg_Name_1 := Pname;
10292 Error_Msg_N ("duplicate pragma% not permitted", Nod);
10303 -- pragma Memory_Size (NUMERIC_LITERAL)
10305 when Pragma_Memory_Size =>
10308 -- Memory size is simply ignored
10310 Check_No_Identifiers;
10311 Check_Arg_Count (1);
10312 Check_Arg_Is_Integer_Literal (Arg1);
10320 -- The only correct use of this pragma is on its own in a file, in
10321 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
10322 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
10323 -- check for a file containing nothing but a No_Body pragma). If we
10324 -- attempt to process it during normal semantics processing, it means
10325 -- it was misplaced.
10327 when Pragma_No_Body =>
10335 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
10337 when Pragma_No_Return => No_Return : declare
10345 Check_At_Least_N_Arguments (1);
10347 -- Loop through arguments of pragma
10350 while Present (Arg) loop
10351 Check_Arg_Is_Local_Name (Arg);
10352 Id := Get_Pragma_Arg (Arg);
10355 if not Is_Entity_Name (Id) then
10356 Error_Pragma_Arg ("entity name required", Arg);
10359 if Etype (Id) = Any_Type then
10363 -- Loop to find matching procedures
10368 and then Scope (E) = Current_Scope
10370 if Ekind_In (E, E_Procedure, E_Generic_Procedure) then
10373 -- Set flag on any alias as well
10375 if Is_Overloadable (E) and then Present (Alias (E)) then
10376 Set_No_Return (Alias (E));
10382 exit when From_Aspect_Specification (N);
10387 Error_Pragma_Arg ("no procedure & found for pragma%", Arg);
10398 -- pragma No_Run_Time;
10400 -- Note: this pragma is retained for backwards compatibility. See
10401 -- body of Rtsfind for full details on its handling.
10403 when Pragma_No_Run_Time =>
10405 Check_Valid_Configuration_Pragma;
10406 Check_Arg_Count (0);
10408 No_Run_Time_Mode := True;
10409 Configurable_Run_Time_Mode := True;
10411 -- Set Duration to 32 bits if word size is 32
10413 if Ttypes.System_Word_Size = 32 then
10414 Duration_32_Bits_On_Target := True;
10417 -- Set appropriate restrictions
10419 Set_Restriction (No_Finalization, N);
10420 Set_Restriction (No_Exception_Handlers, N);
10421 Set_Restriction (Max_Tasks, N, 0);
10422 Set_Restriction (No_Tasking, N);
10424 ------------------------
10425 -- No_Strict_Aliasing --
10426 ------------------------
10428 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
10430 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
10435 Check_At_Most_N_Arguments (1);
10437 if Arg_Count = 0 then
10438 Check_Valid_Configuration_Pragma;
10439 Opt.No_Strict_Aliasing := True;
10442 Check_Optional_Identifier (Arg2, Name_Entity);
10443 Check_Arg_Is_Local_Name (Arg1);
10444 E_Id := Entity (Get_Pragma_Arg (Arg1));
10446 if E_Id = Any_Type then
10448 elsif No (E_Id) or else not Is_Access_Type (E_Id) then
10449 Error_Pragma_Arg ("pragma% requires access type", Arg1);
10452 Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id));
10454 end No_Strict_Aliasing;
10456 -----------------------
10457 -- Normalize_Scalars --
10458 -----------------------
10460 -- pragma Normalize_Scalars;
10462 when Pragma_Normalize_Scalars =>
10463 Check_Ada_83_Warning;
10464 Check_Arg_Count (0);
10465 Check_Valid_Configuration_Pragma;
10467 -- Normalize_Scalars creates false positives in CodePeer, so
10468 -- ignore this pragma in this mode.
10470 if not CodePeer_Mode then
10471 Normalize_Scalars := True;
10472 Init_Or_Norm_Scalars := True;
10479 -- pragma Obsolescent;
10481 -- pragma Obsolescent (
10482 -- [Message =>] static_string_EXPRESSION
10483 -- [,[Version =>] Ada_05]]);
10485 -- pragma Obsolescent (
10486 -- [Entity =>] NAME
10487 -- [,[Message =>] static_string_EXPRESSION
10488 -- [,[Version =>] Ada_05]] );
10490 when Pragma_Obsolescent => Obsolescent : declare
10494 procedure Set_Obsolescent (E : Entity_Id);
10495 -- Given an entity Ent, mark it as obsolescent if appropriate
10497 ---------------------
10498 -- Set_Obsolescent --
10499 ---------------------
10501 procedure Set_Obsolescent (E : Entity_Id) is
10510 -- Entity name was given
10512 if Present (Ename) then
10514 -- If entity name matches, we are fine. Save entity in
10515 -- pragma argument, for ASIS use.
10517 if Chars (Ename) = Chars (Ent) then
10518 Set_Entity (Ename, Ent);
10519 Generate_Reference (Ent, Ename);
10521 -- If entity name does not match, only possibility is an
10522 -- enumeration literal from an enumeration type declaration.
10524 elsif Ekind (Ent) /= E_Enumeration_Type then
10526 ("pragma % entity name does not match declaration");
10529 Ent := First_Literal (E);
10533 ("pragma % entity name does not match any " &
10534 "enumeration literal");
10536 elsif Chars (Ent) = Chars (Ename) then
10537 Set_Entity (Ename, Ent);
10538 Generate_Reference (Ent, Ename);
10542 Ent := Next_Literal (Ent);
10548 -- Ent points to entity to be marked
10550 if Arg_Count >= 1 then
10552 -- Deal with static string argument
10554 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
10555 S := Strval (Get_Pragma_Arg (Arg1));
10557 for J in 1 .. String_Length (S) loop
10558 if not In_Character_Range (Get_String_Char (S, J)) then
10560 ("pragma% argument does not allow wide characters",
10565 Obsolescent_Warnings.Append
10566 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
10568 -- Check for Ada_05 parameter
10570 if Arg_Count /= 1 then
10571 Check_Arg_Count (2);
10574 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
10577 Check_Arg_Is_Identifier (Argx);
10579 if Chars (Argx) /= Name_Ada_05 then
10580 Error_Msg_Name_2 := Name_Ada_05;
10582 ("only allowed argument for pragma% is %", Argx);
10585 if Ada_Version_Explicit < Ada_2005
10586 or else not Warn_On_Ada_2005_Compatibility
10594 -- Set flag if pragma active
10597 Set_Is_Obsolescent (Ent);
10601 end Set_Obsolescent;
10603 -- Start of processing for pragma Obsolescent
10608 Check_At_Most_N_Arguments (3);
10610 -- See if first argument specifies an entity name
10614 (Chars (Arg1) = Name_Entity
10616 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
10618 N_Operator_Symbol))
10620 Ename := Get_Pragma_Arg (Arg1);
10622 -- Eliminate first argument, so we can share processing
10626 Arg_Count := Arg_Count - 1;
10628 -- No Entity name argument given
10634 if Arg_Count >= 1 then
10635 Check_Optional_Identifier (Arg1, Name_Message);
10637 if Arg_Count = 2 then
10638 Check_Optional_Identifier (Arg2, Name_Version);
10642 -- Get immediately preceding declaration
10645 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
10649 -- Cases where we do not follow anything other than another pragma
10653 -- First case: library level compilation unit declaration with
10654 -- the pragma immediately following the declaration.
10656 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
10658 (Defining_Entity (Unit (Parent (Parent (N)))));
10661 -- Case 2: library unit placement for package
10665 Ent : constant Entity_Id := Find_Lib_Unit_Name;
10667 if Is_Package_Or_Generic_Package (Ent) then
10668 Set_Obsolescent (Ent);
10674 -- Cases where we must follow a declaration
10677 if Nkind (Decl) not in N_Declaration
10678 and then Nkind (Decl) not in N_Later_Decl_Item
10679 and then Nkind (Decl) not in N_Generic_Declaration
10680 and then Nkind (Decl) not in N_Renaming_Declaration
10683 ("pragma% misplaced, "
10684 & "must immediately follow a declaration");
10687 Set_Obsolescent (Defining_Entity (Decl));
10697 -- pragma Optimize (Time | Space | Off);
10699 -- The actual check for optimize is done in Gigi. Note that this
10700 -- pragma does not actually change the optimization setting, it
10701 -- simply checks that it is consistent with the pragma.
10703 when Pragma_Optimize =>
10704 Check_No_Identifiers;
10705 Check_Arg_Count (1);
10706 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
10708 ------------------------
10709 -- Optimize_Alignment --
10710 ------------------------
10712 -- pragma Optimize_Alignment (Time | Space | Off);
10714 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
10716 Check_No_Identifiers;
10717 Check_Arg_Count (1);
10718 Check_Valid_Configuration_Pragma;
10721 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
10725 Opt.Optimize_Alignment := 'T';
10727 Opt.Optimize_Alignment := 'S';
10729 Opt.Optimize_Alignment := 'O';
10731 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
10735 -- Set indication that mode is set locally. If we are in fact in a
10736 -- configuration pragma file, this setting is harmless since the
10737 -- switch will get reset anyway at the start of each unit.
10739 Optimize_Alignment_Local := True;
10740 end Optimize_Alignment;
10746 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
10748 when Pragma_Ordered => Ordered : declare
10749 Assoc : constant Node_Id := Arg1;
10755 Check_No_Identifiers;
10756 Check_Arg_Count (1);
10757 Check_Arg_Is_Local_Name (Arg1);
10759 Type_Id := Get_Pragma_Arg (Assoc);
10760 Find_Type (Type_Id);
10761 Typ := Entity (Type_Id);
10763 if Typ = Any_Type then
10766 Typ := Underlying_Type (Typ);
10769 if not Is_Enumeration_Type (Typ) then
10770 Error_Pragma ("pragma% must specify enumeration type");
10773 Check_First_Subtype (Arg1);
10774 Set_Has_Pragma_Ordered (Base_Type (Typ));
10781 -- pragma Pack (first_subtype_LOCAL_NAME);
10783 when Pragma_Pack => Pack : declare
10784 Assoc : constant Node_Id := Arg1;
10788 Ignore : Boolean := False;
10791 Check_No_Identifiers;
10792 Check_Arg_Count (1);
10793 Check_Arg_Is_Local_Name (Arg1);
10795 Type_Id := Get_Pragma_Arg (Assoc);
10796 Find_Type (Type_Id);
10797 Typ := Entity (Type_Id);
10800 or else Rep_Item_Too_Early (Typ, N)
10804 Typ := Underlying_Type (Typ);
10807 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
10808 Error_Pragma ("pragma% must specify array or record type");
10811 Check_First_Subtype (Arg1);
10812 Check_Duplicate_Pragma (Typ);
10816 if Is_Array_Type (Typ) then
10817 Ctyp := Component_Type (Typ);
10819 -- Ignore pack that does nothing
10821 if Known_Static_Esize (Ctyp)
10822 and then Known_Static_RM_Size (Ctyp)
10823 and then Esize (Ctyp) = RM_Size (Ctyp)
10824 and then Addressable (Esize (Ctyp))
10829 -- Process OK pragma Pack. Note that if there is a separate
10830 -- component clause present, the Pack will be cancelled. This
10831 -- processing is in Freeze.
10833 if not Rep_Item_Too_Late (Typ, N) then
10835 -- In the context of static code analysis, we do not need
10836 -- complex front-end expansions related to pragma Pack,
10837 -- so disable handling of pragma Pack in this case.
10839 if CodePeer_Mode then
10842 -- Don't attempt any packing for VM targets. We possibly
10843 -- could deal with some cases of array bit-packing, but we
10844 -- don't bother, since this is not a typical kind of
10845 -- representation in the VM context anyway (and would not
10846 -- for example work nicely with the debugger).
10848 elsif VM_Target /= No_VM then
10849 if not GNAT_Mode then
10851 ("?pragma% ignored in this configuration");
10854 -- Normal case where we do the pack action
10858 Set_Is_Packed (Base_Type (Typ), Sense);
10859 Set_Has_Non_Standard_Rep (Base_Type (Typ), Sense);
10862 Set_Has_Pragma_Pack (Base_Type (Typ), Sense);
10864 -- Complete reset action for Aspect_Cancel case
10866 if Sense = False then
10868 -- Cancel size unless explicitly set
10870 if not Has_Size_Clause (Typ)
10871 and then not Has_Object_Size_Clause (Typ)
10873 Set_Esize (Typ, Uint_0);
10874 Set_RM_Size (Typ, Uint_0);
10875 Set_Alignment (Typ, Uint_0);
10876 Set_Packed_Array_Type (Typ, Empty);
10879 -- Reset component size unless explicitly set
10881 if not Has_Component_Size_Clause (Typ) then
10882 if Known_Static_Esize (Ctyp)
10883 and then Known_Static_RM_Size (Ctyp)
10884 and then Esize (Ctyp) = RM_Size (Ctyp)
10885 and then Addressable (Esize (Ctyp))
10888 (Base_Type (Typ), Esize (Ctyp));
10891 (Base_Type (Typ), Uint_0);
10898 -- For record types, the pack is always effective
10900 else pragma Assert (Is_Record_Type (Typ));
10901 if not Rep_Item_Too_Late (Typ, N) then
10903 -- Ignore pack request with warning in VM mode (skip warning
10904 -- if we are compiling GNAT run time library).
10906 if VM_Target /= No_VM then
10907 if not GNAT_Mode then
10909 ("?pragma% ignored in this configuration");
10912 -- Normal case of pack request active
10915 Set_Is_Packed (Base_Type (Typ), Sense);
10916 Set_Has_Pragma_Pack (Base_Type (Typ), Sense);
10917 Set_Has_Non_Standard_Rep (Base_Type (Typ), Sense);
10919 -- Complete reset action for Aspect_Cancel case
10921 if Sense = False then
10923 -- Cancel size if not explicitly given
10925 if not Has_Size_Clause (Typ)
10926 and then not Has_Object_Size_Clause (Typ)
10928 Set_Esize (Typ, Uint_0);
10929 Set_Alignment (Typ, Uint_0);
10943 -- There is nothing to do here, since we did all the processing for
10944 -- this pragma in Par.Prag (so that it works properly even in syntax
10947 when Pragma_Page =>
10954 -- pragma Passive [(PASSIVE_FORM)];
10956 -- PASSIVE_FORM ::= Semaphore | No
10958 when Pragma_Passive =>
10961 if Nkind (Parent (N)) /= N_Task_Definition then
10962 Error_Pragma ("pragma% must be within task definition");
10965 if Arg_Count /= 0 then
10966 Check_Arg_Count (1);
10967 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
10970 ----------------------------------
10971 -- Preelaborable_Initialization --
10972 ----------------------------------
10974 -- pragma Preelaborable_Initialization (DIRECT_NAME);
10976 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
10981 Check_Arg_Count (1);
10982 Check_No_Identifiers;
10983 Check_Arg_Is_Identifier (Arg1);
10984 Check_Arg_Is_Local_Name (Arg1);
10985 Check_First_Subtype (Arg1);
10986 Ent := Entity (Get_Pragma_Arg (Arg1));
10988 if not Is_Private_Type (Ent)
10989 and then not Is_Protected_Type (Ent)
10992 ("pragma % can only be applied to private or protected type",
10996 -- Give an error if the pragma is applied to a protected type that
10997 -- does not qualify (due to having entries, or due to components
10998 -- that do not qualify).
11000 if Is_Protected_Type (Ent)
11001 and then not Has_Preelaborable_Initialization (Ent)
11004 ("protected type & does not have preelaborable " &
11005 "initialization", Ent);
11007 -- Otherwise mark the type as definitely having preelaborable
11011 Set_Known_To_Have_Preelab_Init (Ent);
11014 if Has_Pragma_Preelab_Init (Ent)
11015 and then Warn_On_Redundant_Constructs
11017 Error_Pragma ("?duplicate pragma%!");
11019 Set_Has_Pragma_Preelab_Init (Ent);
11023 --------------------
11024 -- Persistent_BSS --
11025 --------------------
11027 -- pragma Persistent_BSS [(object_NAME)];
11029 when Pragma_Persistent_BSS => Persistent_BSS : declare
11036 Check_At_Most_N_Arguments (1);
11038 -- Case of application to specific object (one argument)
11040 if Arg_Count = 1 then
11041 Check_Arg_Is_Library_Level_Local_Name (Arg1);
11043 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
11045 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
11048 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
11051 Ent := Entity (Get_Pragma_Arg (Arg1));
11052 Decl := Parent (Ent);
11054 if Rep_Item_Too_Late (Ent, N) then
11058 if Present (Expression (Decl)) then
11060 ("object for pragma% cannot have initialization", Arg1);
11063 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
11065 ("object type for pragma% is not potentially persistent",
11069 Check_Duplicate_Pragma (Ent);
11073 Make_Linker_Section_Pragma
11074 (Ent, Sloc (N), ".persistent.bss");
11075 Insert_After (N, Prag);
11079 -- Case of use as configuration pragma with no arguments
11082 Check_Valid_Configuration_Pragma;
11083 Persistent_BSS_Mode := True;
11085 end Persistent_BSS;
11091 -- pragma Polling (ON | OFF);
11093 when Pragma_Polling =>
11095 Check_Arg_Count (1);
11096 Check_No_Identifiers;
11097 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
11098 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
11100 -------------------
11101 -- Postcondition --
11102 -------------------
11104 -- pragma Postcondition ([Check =>] Boolean_Expression
11105 -- [,[Message =>] String_Expression]);
11107 when Pragma_Postcondition => Postcondition : declare
11109 pragma Warnings (Off, In_Body);
11113 Check_At_Least_N_Arguments (1);
11114 Check_At_Most_N_Arguments (2);
11115 Check_Optional_Identifier (Arg1, Name_Check);
11117 -- All we need to do here is call the common check procedure,
11118 -- the remainder of the processing is found in Sem_Ch6/Sem_Ch7.
11120 Check_Precondition_Postcondition (In_Body);
11127 -- pragma Precondition ([Check =>] Boolean_Expression
11128 -- [,[Message =>] String_Expression]);
11130 when Pragma_Precondition => Precondition : declare
11135 Check_At_Least_N_Arguments (1);
11136 Check_At_Most_N_Arguments (2);
11137 Check_Optional_Identifier (Arg1, Name_Check);
11138 Check_Precondition_Postcondition (In_Body);
11140 -- If in spec, nothing more to do. If in body, then we convert the
11141 -- pragma to pragma Check (Precondition, cond [, msg]). Note we do
11142 -- this whether or not precondition checks are enabled. That works
11143 -- fine since pragma Check will do this check, and will also
11144 -- analyze the condition itself in the proper context.
11149 Chars => Name_Check,
11150 Pragma_Argument_Associations => New_List (
11151 Make_Pragma_Argument_Association (Loc,
11153 Make_Identifier (Loc,
11154 Chars => Name_Precondition)),
11156 Make_Pragma_Argument_Association (Sloc (Arg1),
11157 Expression => Relocate_Node (Get_Pragma_Arg (Arg1))))));
11159 if Arg_Count = 2 then
11160 Append_To (Pragma_Argument_Associations (N),
11161 Make_Pragma_Argument_Association (Sloc (Arg2),
11162 Expression => Relocate_Node (Get_Pragma_Arg (Arg2))));
11173 -- pragma Preelaborate [(library_unit_NAME)];
11175 -- Set the flag Is_Preelaborated of program unit name entity
11177 when Pragma_Preelaborate => Preelaborate : declare
11178 Pa : constant Node_Id := Parent (N);
11179 Pk : constant Node_Kind := Nkind (Pa);
11183 Check_Ada_83_Warning;
11184 Check_Valid_Library_Unit_Pragma;
11186 if Nkind (N) = N_Null_Statement then
11190 Ent := Find_Lib_Unit_Name;
11191 Check_Duplicate_Pragma (Ent);
11193 -- This filters out pragmas inside generic parent then
11194 -- show up inside instantiation
11197 and then not (Pk = N_Package_Specification
11198 and then Present (Generic_Parent (Pa)))
11200 if not Debug_Flag_U then
11201 Set_Is_Preelaborated (Ent, Sense);
11202 Set_Suppress_Elaboration_Warnings (Ent, Sense);
11207 ---------------------
11208 -- Preelaborate_05 --
11209 ---------------------
11211 -- pragma Preelaborate_05 [(library_unit_NAME)];
11213 -- This pragma is useable only in GNAT_Mode, where it is used like
11214 -- pragma Preelaborate but it is only effective in Ada 2005 mode
11215 -- (otherwise it is ignored). This is used to implement AI-362 which
11216 -- recategorizes some run-time packages in Ada 2005 mode.
11218 when Pragma_Preelaborate_05 => Preelaborate_05 : declare
11223 Check_Valid_Library_Unit_Pragma;
11225 if not GNAT_Mode then
11226 Error_Pragma ("pragma% only available in GNAT mode");
11229 if Nkind (N) = N_Null_Statement then
11233 -- This is one of the few cases where we need to test the value of
11234 -- Ada_Version_Explicit rather than Ada_Version (which is always
11235 -- set to Ada_2012 in a predefined unit), we need to know the
11236 -- explicit version set to know if this pragma is active.
11238 if Ada_Version_Explicit >= Ada_2005 then
11239 Ent := Find_Lib_Unit_Name;
11240 Set_Is_Preelaborated (Ent);
11241 Set_Suppress_Elaboration_Warnings (Ent);
11243 end Preelaborate_05;
11249 -- pragma Priority (EXPRESSION);
11251 when Pragma_Priority => Priority : declare
11252 P : constant Node_Id := Parent (N);
11256 Check_No_Identifiers;
11257 Check_Arg_Count (1);
11261 if Nkind (P) = N_Subprogram_Body then
11262 Check_In_Main_Program;
11264 Arg := Get_Pragma_Arg (Arg1);
11265 Analyze_And_Resolve (Arg, Standard_Integer);
11269 if not Is_Static_Expression (Arg) then
11270 Flag_Non_Static_Expr
11271 ("main subprogram priority is not static!", Arg);
11274 -- If constraint error, then we already signalled an error
11276 elsif Raises_Constraint_Error (Arg) then
11279 -- Otherwise check in range
11283 Val : constant Uint := Expr_Value (Arg);
11287 or else Val > Expr_Value (Expression
11288 (Parent (RTE (RE_Max_Priority))))
11291 ("main subprogram priority is out of range", Arg1);
11297 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
11299 -- Load an arbitrary entity from System.Tasking to make sure
11300 -- this package is implicitly with'ed, since we need to have
11301 -- the tasking run-time active for the pragma Priority to have
11305 Discard : Entity_Id;
11306 pragma Warnings (Off, Discard);
11308 Discard := RTE (RE_Task_List);
11311 -- Task or Protected, must be of type Integer
11313 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
11314 Arg := Get_Pragma_Arg (Arg1);
11316 -- The expression must be analyzed in the special manner
11317 -- described in "Handling of Default and Per-Object
11318 -- Expressions" in sem.ads.
11320 Preanalyze_Spec_Expression (Arg, Standard_Integer);
11322 if not Is_Static_Expression (Arg) then
11323 Check_Restriction (Static_Priorities, Arg);
11326 -- Anything else is incorrect
11332 if Has_Pragma_Priority (P) then
11333 Error_Pragma ("duplicate pragma% not allowed");
11335 Set_Has_Pragma_Priority (P, True);
11337 if Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
11338 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
11339 -- exp_ch9 should use this ???
11344 -----------------------------------
11345 -- Priority_Specific_Dispatching --
11346 -----------------------------------
11348 -- pragma Priority_Specific_Dispatching (
11349 -- policy_IDENTIFIER,
11350 -- first_priority_EXPRESSION,
11351 -- last_priority_EXPRESSION);
11353 when Pragma_Priority_Specific_Dispatching =>
11354 Priority_Specific_Dispatching : declare
11355 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
11356 -- This is the entity System.Any_Priority;
11359 Lower_Bound : Node_Id;
11360 Upper_Bound : Node_Id;
11366 Check_Arg_Count (3);
11367 Check_No_Identifiers;
11368 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
11369 Check_Valid_Configuration_Pragma;
11370 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
11371 DP := Fold_Upper (Name_Buffer (1));
11373 Lower_Bound := Get_Pragma_Arg (Arg2);
11374 Check_Arg_Is_Static_Expression (Lower_Bound, Standard_Integer);
11375 Lower_Val := Expr_Value (Lower_Bound);
11377 Upper_Bound := Get_Pragma_Arg (Arg3);
11378 Check_Arg_Is_Static_Expression (Upper_Bound, Standard_Integer);
11379 Upper_Val := Expr_Value (Upper_Bound);
11381 -- It is not allowed to use Task_Dispatching_Policy and
11382 -- Priority_Specific_Dispatching in the same partition.
11384 if Task_Dispatching_Policy /= ' ' then
11385 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
11387 ("pragma% incompatible with Task_Dispatching_Policy#");
11389 -- Check lower bound in range
11391 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
11393 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
11396 ("first_priority is out of range", Arg2);
11398 -- Check upper bound in range
11400 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
11402 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
11405 ("last_priority is out of range", Arg3);
11407 -- Check that the priority range is valid
11409 elsif Lower_Val > Upper_Val then
11411 ("last_priority_expression must be greater than" &
11412 " or equal to first_priority_expression");
11414 -- Store the new policy, but always preserve System_Location since
11415 -- we like the error message with the run-time name.
11418 -- Check overlapping in the priority ranges specified in other
11419 -- Priority_Specific_Dispatching pragmas within the same
11420 -- partition. We can only check those we know about!
11423 Specific_Dispatching.First .. Specific_Dispatching.Last
11425 if Specific_Dispatching.Table (J).First_Priority in
11426 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
11427 or else Specific_Dispatching.Table (J).Last_Priority in
11428 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
11431 Specific_Dispatching.Table (J).Pragma_Loc;
11433 ("priority range overlaps with "
11434 & "Priority_Specific_Dispatching#");
11438 -- The use of Priority_Specific_Dispatching is incompatible
11439 -- with Task_Dispatching_Policy.
11441 if Task_Dispatching_Policy /= ' ' then
11442 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
11444 ("Priority_Specific_Dispatching incompatible "
11445 & "with Task_Dispatching_Policy#");
11448 -- The use of Priority_Specific_Dispatching forces ceiling
11451 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
11452 Error_Msg_Sloc := Locking_Policy_Sloc;
11454 ("Priority_Specific_Dispatching incompatible "
11455 & "with Locking_Policy#");
11457 -- Set the Ceiling_Locking policy, but preserve System_Location
11458 -- since we like the error message with the run time name.
11461 Locking_Policy := 'C';
11463 if Locking_Policy_Sloc /= System_Location then
11464 Locking_Policy_Sloc := Loc;
11468 -- Add entry in the table
11470 Specific_Dispatching.Append
11471 ((Dispatching_Policy => DP,
11472 First_Priority => UI_To_Int (Lower_Val),
11473 Last_Priority => UI_To_Int (Upper_Val),
11474 Pragma_Loc => Loc));
11476 end Priority_Specific_Dispatching;
11482 -- pragma Profile (profile_IDENTIFIER);
11484 -- profile_IDENTIFIER => Restricted | Ravenscar
11486 when Pragma_Profile =>
11488 Check_Arg_Count (1);
11489 Check_Valid_Configuration_Pragma;
11490 Check_No_Identifiers;
11493 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
11495 if Chars (Argx) = Name_Ravenscar then
11496 Set_Ravenscar_Profile (N);
11497 elsif Chars (Argx) = Name_Restricted then
11498 Set_Profile_Restrictions
11499 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
11501 Error_Pragma_Arg ("& is not a valid profile", Argx);
11505 ----------------------
11506 -- Profile_Warnings --
11507 ----------------------
11509 -- pragma Profile_Warnings (profile_IDENTIFIER);
11511 -- profile_IDENTIFIER => Restricted | Ravenscar
11513 when Pragma_Profile_Warnings =>
11515 Check_Arg_Count (1);
11516 Check_Valid_Configuration_Pragma;
11517 Check_No_Identifiers;
11520 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
11522 if Chars (Argx) = Name_Ravenscar then
11523 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
11524 elsif Chars (Argx) = Name_Restricted then
11525 Set_Profile_Restrictions (Restricted, N, Warn => True);
11527 Error_Pragma_Arg ("& is not a valid profile", Argx);
11531 --------------------------
11532 -- Propagate_Exceptions --
11533 --------------------------
11535 -- pragma Propagate_Exceptions;
11537 -- Note: this pragma is obsolete and has no effect
11539 when Pragma_Propagate_Exceptions =>
11541 Check_Arg_Count (0);
11543 if In_Extended_Main_Source_Unit (N) then
11544 Propagate_Exceptions := True;
11551 -- pragma Psect_Object (
11552 -- [Internal =>] LOCAL_NAME,
11553 -- [, [External =>] EXTERNAL_SYMBOL]
11554 -- [, [Size =>] EXTERNAL_SYMBOL]);
11556 when Pragma_Psect_Object | Pragma_Common_Object =>
11557 Psect_Object : declare
11558 Args : Args_List (1 .. 3);
11559 Names : constant Name_List (1 .. 3) := (
11564 Internal : Node_Id renames Args (1);
11565 External : Node_Id renames Args (2);
11566 Size : Node_Id renames Args (3);
11568 Def_Id : Entity_Id;
11570 procedure Check_Too_Long (Arg : Node_Id);
11571 -- Posts message if the argument is an identifier with more
11572 -- than 31 characters, or a string literal with more than
11573 -- 31 characters, and we are operating under VMS
11575 --------------------
11576 -- Check_Too_Long --
11577 --------------------
11579 procedure Check_Too_Long (Arg : Node_Id) is
11580 X : constant Node_Id := Original_Node (Arg);
11583 if not Nkind_In (X, N_String_Literal, N_Identifier) then
11585 ("inappropriate argument for pragma %", Arg);
11588 if OpenVMS_On_Target then
11589 if (Nkind (X) = N_String_Literal
11590 and then String_Length (Strval (X)) > 31)
11592 (Nkind (X) = N_Identifier
11593 and then Length_Of_Name (Chars (X)) > 31)
11596 ("argument for pragma % is longer than 31 characters",
11600 end Check_Too_Long;
11602 -- Start of processing for Common_Object/Psect_Object
11606 Gather_Associations (Names, Args);
11607 Process_Extended_Import_Export_Internal_Arg (Internal);
11609 Def_Id := Entity (Internal);
11611 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
11613 ("pragma% must designate an object", Internal);
11616 Check_Too_Long (Internal);
11618 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
11620 ("cannot use pragma% for imported/exported object",
11624 if Is_Concurrent_Type (Etype (Internal)) then
11626 ("cannot specify pragma % for task/protected object",
11630 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
11632 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
11634 Error_Msg_N ("?duplicate Common/Psect_Object pragma", N);
11637 if Ekind (Def_Id) = E_Constant then
11639 ("cannot specify pragma % for a constant", Internal);
11642 if Is_Record_Type (Etype (Internal)) then
11648 Ent := First_Entity (Etype (Internal));
11649 while Present (Ent) loop
11650 Decl := Declaration_Node (Ent);
11652 if Ekind (Ent) = E_Component
11653 and then Nkind (Decl) = N_Component_Declaration
11654 and then Present (Expression (Decl))
11655 and then Warn_On_Export_Import
11658 ("?object for pragma % has defaults", Internal);
11668 if Present (Size) then
11669 Check_Too_Long (Size);
11672 if Present (External) then
11673 Check_Arg_Is_External_Name (External);
11674 Check_Too_Long (External);
11677 -- If all error tests pass, link pragma on to the rep item chain
11679 Record_Rep_Item (Def_Id, N);
11686 -- pragma Pure [(library_unit_NAME)];
11688 when Pragma_Pure => Pure : declare
11692 Check_Ada_83_Warning;
11693 Check_Valid_Library_Unit_Pragma;
11695 if Nkind (N) = N_Null_Statement then
11699 Ent := Find_Lib_Unit_Name;
11701 Set_Has_Pragma_Pure (Ent);
11702 Set_Suppress_Elaboration_Warnings (Ent);
11709 -- pragma Pure_05 [(library_unit_NAME)];
11711 -- This pragma is useable only in GNAT_Mode, where it is used like
11712 -- pragma Pure but it is only effective in Ada 2005 mode (otherwise
11713 -- it is ignored). It may be used after a pragma Preelaborate, in
11714 -- which case it overrides the effect of the pragma Preelaborate.
11715 -- This is used to implement AI-362 which recategorizes some run-time
11716 -- packages in Ada 2005 mode.
11718 when Pragma_Pure_05 => Pure_05 : declare
11723 Check_Valid_Library_Unit_Pragma;
11725 if not GNAT_Mode then
11726 Error_Pragma ("pragma% only available in GNAT mode");
11729 if Nkind (N) = N_Null_Statement then
11733 -- This is one of the few cases where we need to test the value of
11734 -- Ada_Version_Explicit rather than Ada_Version (which is always
11735 -- set to Ada_2012 in a predefined unit), we need to know the
11736 -- explicit version set to know if this pragma is active.
11738 if Ada_Version_Explicit >= Ada_2005 then
11739 Ent := Find_Lib_Unit_Name;
11740 Set_Is_Preelaborated (Ent, False);
11742 Set_Suppress_Elaboration_Warnings (Ent);
11746 -------------------
11747 -- Pure_Function --
11748 -------------------
11750 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
11752 when Pragma_Pure_Function => Pure_Function : declare
11755 Def_Id : Entity_Id;
11756 Effective : Boolean := False;
11760 Check_Arg_Count (1);
11761 Check_Optional_Identifier (Arg1, Name_Entity);
11762 Check_Arg_Is_Local_Name (Arg1);
11763 E_Id := Get_Pragma_Arg (Arg1);
11765 if Error_Posted (E_Id) then
11769 -- Loop through homonyms (overloadings) of referenced entity
11771 E := Entity (E_Id);
11773 if Present (E) then
11775 Def_Id := Get_Base_Subprogram (E);
11777 if not Ekind_In (Def_Id, E_Function,
11778 E_Generic_Function,
11782 ("pragma% requires a function name", Arg1);
11785 Set_Is_Pure (Def_Id, Sense);
11787 if not Has_Pragma_Pure_Function (Def_Id) then
11788 Set_Has_Pragma_Pure_Function (Def_Id, Sense);
11789 Effective := Sense;
11792 exit when From_Aspect_Specification (N);
11794 exit when No (E) or else Scope (E) /= Current_Scope;
11797 if Sense and then not Effective
11798 and then Warn_On_Redundant_Constructs
11801 ("pragma Pure_Function on& is redundant?",
11807 --------------------
11808 -- Queuing_Policy --
11809 --------------------
11811 -- pragma Queuing_Policy (policy_IDENTIFIER);
11813 when Pragma_Queuing_Policy => declare
11817 Check_Ada_83_Warning;
11818 Check_Arg_Count (1);
11819 Check_No_Identifiers;
11820 Check_Arg_Is_Queuing_Policy (Arg1);
11821 Check_Valid_Configuration_Pragma;
11822 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
11823 QP := Fold_Upper (Name_Buffer (1));
11825 if Queuing_Policy /= ' '
11826 and then Queuing_Policy /= QP
11828 Error_Msg_Sloc := Queuing_Policy_Sloc;
11829 Error_Pragma ("queuing policy incompatible with policy#");
11831 -- Set new policy, but always preserve System_Location since we
11832 -- like the error message with the run time name.
11835 Queuing_Policy := QP;
11837 if Queuing_Policy_Sloc /= System_Location then
11838 Queuing_Policy_Sloc := Loc;
11843 -----------------------
11844 -- Relative_Deadline --
11845 -----------------------
11847 -- pragma Relative_Deadline (time_span_EXPRESSION);
11849 when Pragma_Relative_Deadline => Relative_Deadline : declare
11850 P : constant Node_Id := Parent (N);
11855 Check_No_Identifiers;
11856 Check_Arg_Count (1);
11858 Arg := Get_Pragma_Arg (Arg1);
11860 -- The expression must be analyzed in the special manner described
11861 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
11863 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
11867 if Nkind (P) = N_Subprogram_Body then
11868 Check_In_Main_Program;
11872 elsif Nkind (P) = N_Task_Definition then
11875 -- Anything else is incorrect
11881 if Has_Relative_Deadline_Pragma (P) then
11882 Error_Pragma ("duplicate pragma% not allowed");
11884 Set_Has_Relative_Deadline_Pragma (P, True);
11886 if Nkind (P) = N_Task_Definition then
11887 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
11890 end Relative_Deadline;
11892 ---------------------------
11893 -- Remote_Call_Interface --
11894 ---------------------------
11896 -- pragma Remote_Call_Interface [(library_unit_NAME)];
11898 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
11899 Cunit_Node : Node_Id;
11900 Cunit_Ent : Entity_Id;
11904 Check_Ada_83_Warning;
11905 Check_Valid_Library_Unit_Pragma;
11907 if Nkind (N) = N_Null_Statement then
11911 Cunit_Node := Cunit (Current_Sem_Unit);
11912 K := Nkind (Unit (Cunit_Node));
11913 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
11915 if K = N_Package_Declaration
11916 or else K = N_Generic_Package_Declaration
11917 or else K = N_Subprogram_Declaration
11918 or else K = N_Generic_Subprogram_Declaration
11919 or else (K = N_Subprogram_Body
11920 and then Acts_As_Spec (Unit (Cunit_Node)))
11925 "pragma% must apply to package or subprogram declaration");
11928 Set_Is_Remote_Call_Interface (Cunit_Ent);
11929 end Remote_Call_Interface;
11935 -- pragma Remote_Types [(library_unit_NAME)];
11937 when Pragma_Remote_Types => Remote_Types : declare
11938 Cunit_Node : Node_Id;
11939 Cunit_Ent : Entity_Id;
11942 Check_Ada_83_Warning;
11943 Check_Valid_Library_Unit_Pragma;
11945 if Nkind (N) = N_Null_Statement then
11949 Cunit_Node := Cunit (Current_Sem_Unit);
11950 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
11952 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
11953 N_Generic_Package_Declaration)
11956 ("pragma% can only apply to a package declaration");
11959 Set_Is_Remote_Types (Cunit_Ent);
11966 -- pragma Ravenscar;
11968 when Pragma_Ravenscar =>
11970 Check_Arg_Count (0);
11971 Check_Valid_Configuration_Pragma;
11972 Set_Ravenscar_Profile (N);
11974 if Warn_On_Obsolescent_Feature then
11975 Error_Msg_N ("pragma Ravenscar is an obsolescent feature?", N);
11976 Error_Msg_N ("|use pragma Profile (Ravenscar) instead", N);
11979 -------------------------
11980 -- Restricted_Run_Time --
11981 -------------------------
11983 -- pragma Restricted_Run_Time;
11985 when Pragma_Restricted_Run_Time =>
11987 Check_Arg_Count (0);
11988 Check_Valid_Configuration_Pragma;
11989 Set_Profile_Restrictions
11990 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
11992 if Warn_On_Obsolescent_Feature then
11994 ("pragma Restricted_Run_Time is an obsolescent feature?", N);
11995 Error_Msg_N ("|use pragma Profile (Restricted) instead", N);
12002 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
12005 -- restriction_IDENTIFIER
12006 -- | restriction_parameter_IDENTIFIER => EXPRESSION
12008 when Pragma_Restrictions =>
12009 Process_Restrictions_Or_Restriction_Warnings
12010 (Warn => Treat_Restrictions_As_Warnings);
12012 --------------------------
12013 -- Restriction_Warnings --
12014 --------------------------
12016 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
12019 -- restriction_IDENTIFIER
12020 -- | restriction_parameter_IDENTIFIER => EXPRESSION
12022 when Pragma_Restriction_Warnings =>
12024 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
12030 -- pragma Reviewable;
12032 when Pragma_Reviewable =>
12033 Check_Ada_83_Warning;
12034 Check_Arg_Count (0);
12036 -- Call dummy debugging function rv. This is done to assist front
12037 -- end debugging. By placing a Reviewable pragma in the source
12038 -- program, a breakpoint on rv catches this place in the source,
12039 -- allowing convenient stepping to the point of interest.
12043 --------------------------
12044 -- Short_Circuit_And_Or --
12045 --------------------------
12047 when Pragma_Short_Circuit_And_Or =>
12049 Check_Arg_Count (0);
12050 Check_Valid_Configuration_Pragma;
12051 Short_Circuit_And_Or := True;
12053 -------------------
12054 -- Share_Generic --
12055 -------------------
12057 -- pragma Share_Generic (NAME {, NAME});
12059 when Pragma_Share_Generic =>
12061 Process_Generic_List;
12067 -- pragma Shared (LOCAL_NAME);
12069 when Pragma_Shared =>
12071 Process_Atomic_Shared_Volatile;
12073 --------------------
12074 -- Shared_Passive --
12075 --------------------
12077 -- pragma Shared_Passive [(library_unit_NAME)];
12079 -- Set the flag Is_Shared_Passive of program unit name entity
12081 when Pragma_Shared_Passive => Shared_Passive : declare
12082 Cunit_Node : Node_Id;
12083 Cunit_Ent : Entity_Id;
12086 Check_Ada_83_Warning;
12087 Check_Valid_Library_Unit_Pragma;
12089 if Nkind (N) = N_Null_Statement then
12093 Cunit_Node := Cunit (Current_Sem_Unit);
12094 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
12096 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
12097 N_Generic_Package_Declaration)
12100 ("pragma% can only apply to a package declaration");
12103 Set_Is_Shared_Passive (Cunit_Ent);
12104 end Shared_Passive;
12106 -----------------------
12107 -- Short_Descriptors --
12108 -----------------------
12110 -- pragma Short_Descriptors;
12112 when Pragma_Short_Descriptors =>
12114 Check_Arg_Count (0);
12115 Check_Valid_Configuration_Pragma;
12116 Short_Descriptors := True;
12118 ----------------------
12119 -- Source_File_Name --
12120 ----------------------
12122 -- There are five forms for this pragma:
12124 -- pragma Source_File_Name (
12125 -- [UNIT_NAME =>] unit_NAME,
12126 -- BODY_FILE_NAME => STRING_LITERAL
12127 -- [, [INDEX =>] INTEGER_LITERAL]);
12129 -- pragma Source_File_Name (
12130 -- [UNIT_NAME =>] unit_NAME,
12131 -- SPEC_FILE_NAME => STRING_LITERAL
12132 -- [, [INDEX =>] INTEGER_LITERAL]);
12134 -- pragma Source_File_Name (
12135 -- BODY_FILE_NAME => STRING_LITERAL
12136 -- [, DOT_REPLACEMENT => STRING_LITERAL]
12137 -- [, CASING => CASING_SPEC]);
12139 -- pragma Source_File_Name (
12140 -- SPEC_FILE_NAME => STRING_LITERAL
12141 -- [, DOT_REPLACEMENT => STRING_LITERAL]
12142 -- [, CASING => CASING_SPEC]);
12144 -- pragma Source_File_Name (
12145 -- SUBUNIT_FILE_NAME => STRING_LITERAL
12146 -- [, DOT_REPLACEMENT => STRING_LITERAL]
12147 -- [, CASING => CASING_SPEC]);
12149 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
12151 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
12152 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
12153 -- only be used when no project file is used, while SFNP can only be
12154 -- used when a project file is used.
12156 -- No processing here. Processing was completed during parsing, since
12157 -- we need to have file names set as early as possible. Units are
12158 -- loaded well before semantic processing starts.
12160 -- The only processing we defer to this point is the check for
12161 -- correct placement.
12163 when Pragma_Source_File_Name =>
12165 Check_Valid_Configuration_Pragma;
12167 ------------------------------
12168 -- Source_File_Name_Project --
12169 ------------------------------
12171 -- See Source_File_Name for syntax
12173 -- No processing here. Processing was completed during parsing, since
12174 -- we need to have file names set as early as possible. Units are
12175 -- loaded well before semantic processing starts.
12177 -- The only processing we defer to this point is the check for
12178 -- correct placement.
12180 when Pragma_Source_File_Name_Project =>
12182 Check_Valid_Configuration_Pragma;
12184 -- Check that a pragma Source_File_Name_Project is used only in a
12185 -- configuration pragmas file.
12187 -- Pragmas Source_File_Name_Project should only be generated by
12188 -- the Project Manager in configuration pragmas files.
12190 -- This is really an ugly test. It seems to depend on some
12191 -- accidental and undocumented property. At the very least it
12192 -- needs to be documented, but it would be better to have a
12193 -- clean way of testing if we are in a configuration file???
12195 if Present (Parent (N)) then
12197 ("pragma% can only appear in a configuration pragmas file");
12200 ----------------------
12201 -- Source_Reference --
12202 ----------------------
12204 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
12206 -- Nothing to do, all processing completed in Par.Prag, since we need
12207 -- the information for possible parser messages that are output.
12209 when Pragma_Source_Reference =>
12212 --------------------------------
12213 -- Static_Elaboration_Desired --
12214 --------------------------------
12216 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
12218 when Pragma_Static_Elaboration_Desired =>
12220 Check_At_Most_N_Arguments (1);
12222 if Is_Compilation_Unit (Current_Scope)
12223 and then Ekind (Current_Scope) = E_Package
12225 Set_Static_Elaboration_Desired (Current_Scope, True);
12227 Error_Pragma ("pragma% must apply to a library-level package");
12234 -- pragma Storage_Size (EXPRESSION);
12236 when Pragma_Storage_Size => Storage_Size : declare
12237 P : constant Node_Id := Parent (N);
12241 Check_No_Identifiers;
12242 Check_Arg_Count (1);
12244 -- The expression must be analyzed in the special manner described
12245 -- in "Handling of Default Expressions" in sem.ads.
12247 Arg := Get_Pragma_Arg (Arg1);
12248 Preanalyze_Spec_Expression (Arg, Any_Integer);
12250 if not Is_Static_Expression (Arg) then
12251 Check_Restriction (Static_Storage_Size, Arg);
12254 if Nkind (P) /= N_Task_Definition then
12259 if Has_Storage_Size_Pragma (P) then
12260 Error_Pragma ("duplicate pragma% not allowed");
12262 Set_Has_Storage_Size_Pragma (P, True);
12265 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
12266 -- ??? exp_ch9 should use this!
12274 -- pragma Storage_Unit (NUMERIC_LITERAL);
12276 -- Only permitted argument is System'Storage_Unit value
12278 when Pragma_Storage_Unit =>
12279 Check_No_Identifiers;
12280 Check_Arg_Count (1);
12281 Check_Arg_Is_Integer_Literal (Arg1);
12283 if Intval (Get_Pragma_Arg (Arg1)) /=
12284 UI_From_Int (Ttypes.System_Storage_Unit)
12286 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
12288 ("the only allowed argument for pragma% is ^", Arg1);
12291 --------------------
12292 -- Stream_Convert --
12293 --------------------
12295 -- pragma Stream_Convert (
12296 -- [Entity =>] type_LOCAL_NAME,
12297 -- [Read =>] function_NAME,
12298 -- [Write =>] function NAME);
12300 when Pragma_Stream_Convert => Stream_Convert : declare
12302 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
12303 -- Check that the given argument is the name of a local function
12304 -- of one argument that is not overloaded earlier in the current
12305 -- local scope. A check is also made that the argument is a
12306 -- function with one parameter.
12308 --------------------------------------
12309 -- Check_OK_Stream_Convert_Function --
12310 --------------------------------------
12312 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
12316 Check_Arg_Is_Local_Name (Arg);
12317 Ent := Entity (Get_Pragma_Arg (Arg));
12319 if Has_Homonym (Ent) then
12321 ("argument for pragma% may not be overloaded", Arg);
12324 if Ekind (Ent) /= E_Function
12325 or else No (First_Formal (Ent))
12326 or else Present (Next_Formal (First_Formal (Ent)))
12329 ("argument for pragma% must be" &
12330 " function of one argument", Arg);
12332 end Check_OK_Stream_Convert_Function;
12334 -- Start of processing for Stream_Convert
12338 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
12339 Check_Arg_Count (3);
12340 Check_Optional_Identifier (Arg1, Name_Entity);
12341 Check_Optional_Identifier (Arg2, Name_Read);
12342 Check_Optional_Identifier (Arg3, Name_Write);
12343 Check_Arg_Is_Local_Name (Arg1);
12344 Check_OK_Stream_Convert_Function (Arg2);
12345 Check_OK_Stream_Convert_Function (Arg3);
12348 Typ : constant Entity_Id :=
12349 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
12350 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
12351 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
12354 Check_First_Subtype (Arg1);
12356 -- Check for too early or too late. Note that we don't enforce
12357 -- the rule about primitive operations in this case, since, as
12358 -- is the case for explicit stream attributes themselves, these
12359 -- restrictions are not appropriate. Note that the chaining of
12360 -- the pragma by Rep_Item_Too_Late is actually the critical
12361 -- processing done for this pragma.
12363 if Rep_Item_Too_Early (Typ, N)
12365 Rep_Item_Too_Late (Typ, N, FOnly => True)
12370 -- Return if previous error
12372 if Etype (Typ) = Any_Type
12374 Etype (Read) = Any_Type
12376 Etype (Write) = Any_Type
12383 if Underlying_Type (Etype (Read)) /= Typ then
12385 ("incorrect return type for function&", Arg2);
12388 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
12390 ("incorrect parameter type for function&", Arg3);
12393 if Underlying_Type (Etype (First_Formal (Read))) /=
12394 Underlying_Type (Etype (Write))
12397 ("result type of & does not match Read parameter type",
12401 end Stream_Convert;
12403 -------------------------
12404 -- Style_Checks (GNAT) --
12405 -------------------------
12407 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
12409 -- This is processed by the parser since some of the style checks
12410 -- take place during source scanning and parsing. This means that
12411 -- we don't need to issue error messages here.
12413 when Pragma_Style_Checks => Style_Checks : declare
12414 A : constant Node_Id := Get_Pragma_Arg (Arg1);
12420 Check_No_Identifiers;
12422 -- Two argument form
12424 if Arg_Count = 2 then
12425 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
12432 E_Id := Get_Pragma_Arg (Arg2);
12435 if not Is_Entity_Name (E_Id) then
12437 ("second argument of pragma% must be entity name",
12441 E := Entity (E_Id);
12447 Set_Suppress_Style_Checks (E,
12448 (Chars (Get_Pragma_Arg (Arg1)) = Name_Off));
12449 exit when No (Homonym (E));
12455 -- One argument form
12458 Check_Arg_Count (1);
12460 if Nkind (A) = N_String_Literal then
12464 Slen : constant Natural := Natural (String_Length (S));
12465 Options : String (1 .. Slen);
12471 C := Get_String_Char (S, Int (J));
12472 exit when not In_Character_Range (C);
12473 Options (J) := Get_Character (C);
12475 -- If at end of string, set options. As per discussion
12476 -- above, no need to check for errors, since we issued
12477 -- them in the parser.
12480 Set_Style_Check_Options (Options);
12488 elsif Nkind (A) = N_Identifier then
12489 if Chars (A) = Name_All_Checks then
12491 Set_GNAT_Style_Check_Options;
12493 Set_Default_Style_Check_Options;
12496 elsif Chars (A) = Name_On then
12497 Style_Check := True;
12499 elsif Chars (A) = Name_Off then
12500 Style_Check := False;
12510 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
12512 when Pragma_Subtitle =>
12514 Check_Arg_Count (1);
12515 Check_Optional_Identifier (Arg1, Name_Subtitle);
12516 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
12523 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
12525 when Pragma_Suppress =>
12526 Process_Suppress_Unsuppress (True);
12532 -- pragma Suppress_All;
12534 -- The only check made here is that the pragma has no arguments.
12535 -- There are no placement rules, and the processing required (setting
12536 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
12537 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
12538 -- then creates and inserts a pragma Suppress (All_Checks).
12540 when Pragma_Suppress_All =>
12542 Check_Arg_Count (0);
12544 -------------------------
12545 -- Suppress_Debug_Info --
12546 -------------------------
12548 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
12550 when Pragma_Suppress_Debug_Info =>
12552 Check_Arg_Count (1);
12553 Check_Optional_Identifier (Arg1, Name_Entity);
12554 Check_Arg_Is_Local_Name (Arg1);
12555 Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1)), Sense);
12557 ----------------------------------
12558 -- Suppress_Exception_Locations --
12559 ----------------------------------
12561 -- pragma Suppress_Exception_Locations;
12563 when Pragma_Suppress_Exception_Locations =>
12565 Check_Arg_Count (0);
12566 Check_Valid_Configuration_Pragma;
12567 Exception_Locations_Suppressed := True;
12569 -----------------------------
12570 -- Suppress_Initialization --
12571 -----------------------------
12573 -- pragma Suppress_Initialization ([Entity =>] type_Name);
12575 when Pragma_Suppress_Initialization => Suppress_Init : declare
12581 Check_Arg_Count (1);
12582 Check_Optional_Identifier (Arg1, Name_Entity);
12583 Check_Arg_Is_Local_Name (Arg1);
12585 E_Id := Get_Pragma_Arg (Arg1);
12587 if Etype (E_Id) = Any_Type then
12591 E := Entity (E_Id);
12593 if Is_Type (E) then
12594 if Is_Incomplete_Or_Private_Type (E) then
12595 if No (Full_View (Base_Type (E))) then
12597 ("argument of pragma% cannot be an incomplete type",
12600 Set_Suppress_Init_Proc (Full_View (Base_Type (E)));
12603 Set_Suppress_Init_Proc (Base_Type (E));
12608 ("pragma% requires argument that is a type name", Arg1);
12616 -- pragma System_Name (DIRECT_NAME);
12618 -- Syntax check: one argument, which must be the identifier GNAT or
12619 -- the identifier GCC, no other identifiers are acceptable.
12621 when Pragma_System_Name =>
12623 Check_No_Identifiers;
12624 Check_Arg_Count (1);
12625 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
12627 -----------------------------
12628 -- Task_Dispatching_Policy --
12629 -----------------------------
12631 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
12633 when Pragma_Task_Dispatching_Policy => declare
12637 Check_Ada_83_Warning;
12638 Check_Arg_Count (1);
12639 Check_No_Identifiers;
12640 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
12641 Check_Valid_Configuration_Pragma;
12642 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
12643 DP := Fold_Upper (Name_Buffer (1));
12645 if Task_Dispatching_Policy /= ' '
12646 and then Task_Dispatching_Policy /= DP
12648 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
12650 ("task dispatching policy incompatible with policy#");
12652 -- Set new policy, but always preserve System_Location since we
12653 -- like the error message with the run time name.
12656 Task_Dispatching_Policy := DP;
12658 if Task_Dispatching_Policy_Sloc /= System_Location then
12659 Task_Dispatching_Policy_Sloc := Loc;
12668 -- pragma Task_Info (EXPRESSION);
12670 when Pragma_Task_Info => Task_Info : declare
12671 P : constant Node_Id := Parent (N);
12676 if Nkind (P) /= N_Task_Definition then
12677 Error_Pragma ("pragma% must appear in task definition");
12680 Check_No_Identifiers;
12681 Check_Arg_Count (1);
12683 Analyze_And_Resolve
12684 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
12686 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
12690 if Has_Task_Info_Pragma (P) then
12691 Error_Pragma ("duplicate pragma% not allowed");
12693 Set_Has_Task_Info_Pragma (P, True);
12701 -- pragma Task_Name (string_EXPRESSION);
12703 when Pragma_Task_Name => Task_Name : declare
12704 P : constant Node_Id := Parent (N);
12708 Check_No_Identifiers;
12709 Check_Arg_Count (1);
12711 Arg := Get_Pragma_Arg (Arg1);
12713 -- The expression is used in the call to Create_Task, and must be
12714 -- expanded there, not in the context of the current spec. It must
12715 -- however be analyzed to capture global references, in case it
12716 -- appears in a generic context.
12718 Preanalyze_And_Resolve (Arg, Standard_String);
12720 if Nkind (P) /= N_Task_Definition then
12724 if Has_Task_Name_Pragma (P) then
12725 Error_Pragma ("duplicate pragma% not allowed");
12727 Set_Has_Task_Name_Pragma (P, True);
12728 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
12736 -- pragma Task_Storage (
12737 -- [Task_Type =>] LOCAL_NAME,
12738 -- [Top_Guard =>] static_integer_EXPRESSION);
12740 when Pragma_Task_Storage => Task_Storage : declare
12741 Args : Args_List (1 .. 2);
12742 Names : constant Name_List (1 .. 2) := (
12746 Task_Type : Node_Id renames Args (1);
12747 Top_Guard : Node_Id renames Args (2);
12753 Gather_Associations (Names, Args);
12755 if No (Task_Type) then
12757 ("missing task_type argument for pragma%");
12760 Check_Arg_Is_Local_Name (Task_Type);
12762 Ent := Entity (Task_Type);
12764 if not Is_Task_Type (Ent) then
12766 ("argument for pragma% must be task type", Task_Type);
12769 if No (Top_Guard) then
12771 ("pragma% takes two arguments", Task_Type);
12773 Check_Arg_Is_Static_Expression (Top_Guard, Any_Integer);
12776 Check_First_Subtype (Task_Type);
12778 if Rep_Item_Too_Late (Ent, N) then
12783 --------------------------
12784 -- Thread_Local_Storage --
12785 --------------------------
12787 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
12789 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
12795 Check_Arg_Count (1);
12796 Check_Optional_Identifier (Arg1, Name_Entity);
12797 Check_Arg_Is_Library_Level_Local_Name (Arg1);
12799 Id := Get_Pragma_Arg (Arg1);
12802 if not Is_Entity_Name (Id)
12803 or else Ekind (Entity (Id)) /= E_Variable
12805 Error_Pragma_Arg ("local variable name required", Arg1);
12810 if Rep_Item_Too_Early (E, N)
12811 or else Rep_Item_Too_Late (E, N)
12816 Set_Has_Pragma_Thread_Local_Storage (E);
12817 Set_Has_Gigi_Rep_Item (E);
12818 end Thread_Local_Storage;
12824 -- pragma Time_Slice (static_duration_EXPRESSION);
12826 when Pragma_Time_Slice => Time_Slice : declare
12832 Check_Arg_Count (1);
12833 Check_No_Identifiers;
12834 Check_In_Main_Program;
12835 Check_Arg_Is_Static_Expression (Arg1, Standard_Duration);
12837 if not Error_Posted (Arg1) then
12839 while Present (Nod) loop
12840 if Nkind (Nod) = N_Pragma
12841 and then Pragma_Name (Nod) = Name_Time_Slice
12843 Error_Msg_Name_1 := Pname;
12844 Error_Msg_N ("duplicate pragma% not permitted", Nod);
12851 -- Process only if in main unit
12853 if Get_Source_Unit (Loc) = Main_Unit then
12854 Opt.Time_Slice_Set := True;
12855 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
12857 if Val <= Ureal_0 then
12858 Opt.Time_Slice_Value := 0;
12860 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
12861 Opt.Time_Slice_Value := 1_000_000_000;
12864 Opt.Time_Slice_Value :=
12865 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
12874 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
12876 -- TITLING_OPTION ::=
12877 -- [Title =>] STRING_LITERAL
12878 -- | [Subtitle =>] STRING_LITERAL
12880 when Pragma_Title => Title : declare
12881 Args : Args_List (1 .. 2);
12882 Names : constant Name_List (1 .. 2) := (
12888 Gather_Associations (Names, Args);
12891 for J in 1 .. 2 loop
12892 if Present (Args (J)) then
12893 Check_Arg_Is_Static_Expression (Args (J), Standard_String);
12898 ---------------------
12899 -- Unchecked_Union --
12900 ---------------------
12902 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
12904 when Pragma_Unchecked_Union => Unchecked_Union : declare
12905 Assoc : constant Node_Id := Arg1;
12906 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
12917 Check_No_Identifiers;
12918 Check_Arg_Count (1);
12919 Check_Arg_Is_Local_Name (Arg1);
12921 Find_Type (Type_Id);
12922 Typ := Entity (Type_Id);
12925 or else Rep_Item_Too_Early (Typ, N)
12929 Typ := Underlying_Type (Typ);
12932 if Rep_Item_Too_Late (Typ, N) then
12936 Check_First_Subtype (Arg1);
12938 -- Note remaining cases are references to a type in the current
12939 -- declarative part. If we find an error, we post the error on
12940 -- the relevant type declaration at an appropriate point.
12942 if not Is_Record_Type (Typ) then
12943 Error_Msg_N ("Unchecked_Union must be record type", Typ);
12946 elsif Is_Tagged_Type (Typ) then
12947 Error_Msg_N ("Unchecked_Union must not be tagged", Typ);
12950 elsif Is_Limited_Type (Typ) then
12952 ("Unchecked_Union must not be limited record type", Typ);
12953 Explain_Limited_Type (Typ, Typ);
12957 if not Has_Discriminants (Typ) then
12959 ("Unchecked_Union must have one discriminant", Typ);
12963 Discr := First_Discriminant (Typ);
12964 while Present (Discr) loop
12965 if No (Discriminant_Default_Value (Discr)) then
12967 ("Unchecked_Union discriminant must have default value",
12971 Next_Discriminant (Discr);
12974 Tdef := Type_Definition (Declaration_Node (Typ));
12975 Clist := Component_List (Tdef);
12977 Comp := First (Component_Items (Clist));
12978 while Present (Comp) loop
12979 Check_Component (Comp, Typ);
12983 if No (Clist) or else No (Variant_Part (Clist)) then
12985 ("Unchecked_Union must have variant part",
12990 Vpart := Variant_Part (Clist);
12992 Variant := First (Variants (Vpart));
12993 while Present (Variant) loop
12994 Check_Variant (Variant, Typ);
12999 Set_Is_Unchecked_Union (Typ, Sense);
13002 Set_Convention (Typ, Convention_C);
13005 Set_Has_Unchecked_Union (Base_Type (Typ), Sense);
13006 Set_Is_Unchecked_Union (Base_Type (Typ), Sense);
13007 end Unchecked_Union;
13009 ------------------------
13010 -- Unimplemented_Unit --
13011 ------------------------
13013 -- pragma Unimplemented_Unit;
13015 -- Note: this only gives an error if we are generating code, or if
13016 -- we are in a generic library unit (where the pragma appears in the
13017 -- body, not in the spec).
13019 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
13020 Cunitent : constant Entity_Id :=
13021 Cunit_Entity (Get_Source_Unit (Loc));
13022 Ent_Kind : constant Entity_Kind :=
13027 Check_Arg_Count (0);
13029 if Operating_Mode = Generate_Code
13030 or else Ent_Kind = E_Generic_Function
13031 or else Ent_Kind = E_Generic_Procedure
13032 or else Ent_Kind = E_Generic_Package
13034 Get_Name_String (Chars (Cunitent));
13035 Set_Casing (Mixed_Case);
13036 Write_Str (Name_Buffer (1 .. Name_Len));
13037 Write_Str (" is not supported in this configuration");
13039 raise Unrecoverable_Error;
13041 end Unimplemented_Unit;
13043 ------------------------
13044 -- Universal_Aliasing --
13045 ------------------------
13047 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
13049 when Pragma_Universal_Aliasing => Universal_Alias : declare
13054 Check_Arg_Count (1);
13055 Check_Optional_Identifier (Arg2, Name_Entity);
13056 Check_Arg_Is_Local_Name (Arg1);
13057 E_Id := Entity (Get_Pragma_Arg (Arg1));
13059 if E_Id = Any_Type then
13061 elsif No (E_Id) or else not Is_Type (E_Id) then
13062 Error_Pragma_Arg ("pragma% requires type", Arg1);
13065 Set_Universal_Aliasing (Implementation_Base_Type (E_Id), Sense);
13066 end Universal_Alias;
13068 --------------------
13069 -- Universal_Data --
13070 --------------------
13072 -- pragma Universal_Data [(library_unit_NAME)];
13074 when Pragma_Universal_Data =>
13077 -- If this is a configuration pragma, then set the universal
13078 -- addressing option, otherwise confirm that the pragma satisfies
13079 -- the requirements of library unit pragma placement and leave it
13080 -- to the GNAAMP back end to detect the pragma (avoids transitive
13081 -- setting of the option due to withed units).
13083 if Is_Configuration_Pragma then
13084 Universal_Addressing_On_AAMP := True;
13086 Check_Valid_Library_Unit_Pragma;
13089 if not AAMP_On_Target then
13090 Error_Pragma ("?pragma% ignored (applies only to AAMP)");
13097 -- pragma Unmodified (local_Name {, local_Name});
13099 when Pragma_Unmodified => Unmodified : declare
13100 Arg_Node : Node_Id;
13101 Arg_Expr : Node_Id;
13102 Arg_Ent : Entity_Id;
13106 Check_At_Least_N_Arguments (1);
13108 -- Loop through arguments
13111 while Present (Arg_Node) loop
13112 Check_No_Identifier (Arg_Node);
13114 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
13115 -- in fact generate reference, so that the entity will have a
13116 -- reference, which will inhibit any warnings about it not
13117 -- being referenced, and also properly show up in the ali file
13118 -- as a reference. But this reference is recorded before the
13119 -- Has_Pragma_Unreferenced flag is set, so that no warning is
13120 -- generated for this reference.
13122 Check_Arg_Is_Local_Name (Arg_Node);
13123 Arg_Expr := Get_Pragma_Arg (Arg_Node);
13125 if Is_Entity_Name (Arg_Expr) then
13126 Arg_Ent := Entity (Arg_Expr);
13128 if not Is_Assignable (Arg_Ent) then
13130 ("pragma% can only be applied to a variable",
13133 Set_Has_Pragma_Unmodified (Arg_Ent, Sense);
13145 -- pragma Unreferenced (local_Name {, local_Name});
13147 -- or when used in a context clause:
13149 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
13151 when Pragma_Unreferenced => Unreferenced : declare
13152 Arg_Node : Node_Id;
13153 Arg_Expr : Node_Id;
13154 Arg_Ent : Entity_Id;
13159 Check_At_Least_N_Arguments (1);
13161 -- Check case of appearing within context clause
13163 if Is_In_Context_Clause then
13165 -- The arguments must all be units mentioned in a with clause
13166 -- in the same context clause. Note we already checked (in
13167 -- Par.Prag) that the arguments are either identifiers or
13168 -- selected components.
13171 while Present (Arg_Node) loop
13172 Citem := First (List_Containing (N));
13173 while Citem /= N loop
13174 if Nkind (Citem) = N_With_Clause
13176 Same_Name (Name (Citem), Get_Pragma_Arg (Arg_Node))
13178 Set_Has_Pragma_Unreferenced
13181 (Library_Unit (Citem))));
13183 (Get_Pragma_Arg (Arg_Node), Name (Citem));
13192 ("argument of pragma% is not with'ed unit", Arg_Node);
13198 -- Case of not in list of context items
13202 while Present (Arg_Node) loop
13203 Check_No_Identifier (Arg_Node);
13205 -- Note: the analyze call done by Check_Arg_Is_Local_Name
13206 -- will in fact generate reference, so that the entity will
13207 -- have a reference, which will inhibit any warnings about
13208 -- it not being referenced, and also properly show up in the
13209 -- ali file as a reference. But this reference is recorded
13210 -- before the Has_Pragma_Unreferenced flag is set, so that
13211 -- no warning is generated for this reference.
13213 Check_Arg_Is_Local_Name (Arg_Node);
13214 Arg_Expr := Get_Pragma_Arg (Arg_Node);
13216 if Is_Entity_Name (Arg_Expr) then
13217 Arg_Ent := Entity (Arg_Expr);
13219 -- If the entity is overloaded, the pragma applies to the
13220 -- most recent overloading, as documented. In this case,
13221 -- name resolution does not generate a reference, so it
13222 -- must be done here explicitly.
13224 if Is_Overloaded (Arg_Expr) then
13225 Generate_Reference (Arg_Ent, N);
13228 Set_Has_Pragma_Unreferenced (Arg_Ent, Sense);
13236 --------------------------
13237 -- Unreferenced_Objects --
13238 --------------------------
13240 -- pragma Unreferenced_Objects (local_Name {, local_Name});
13242 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
13243 Arg_Node : Node_Id;
13244 Arg_Expr : Node_Id;
13248 Check_At_Least_N_Arguments (1);
13251 while Present (Arg_Node) loop
13252 Check_No_Identifier (Arg_Node);
13253 Check_Arg_Is_Local_Name (Arg_Node);
13254 Arg_Expr := Get_Pragma_Arg (Arg_Node);
13256 if not Is_Entity_Name (Arg_Expr)
13257 or else not Is_Type (Entity (Arg_Expr))
13260 ("argument for pragma% must be type or subtype", Arg_Node);
13263 Set_Has_Pragma_Unreferenced_Objects (Entity (Arg_Expr), Sense);
13266 end Unreferenced_Objects;
13268 ------------------------------
13269 -- Unreserve_All_Interrupts --
13270 ------------------------------
13272 -- pragma Unreserve_All_Interrupts;
13274 when Pragma_Unreserve_All_Interrupts =>
13276 Check_Arg_Count (0);
13278 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
13279 Unreserve_All_Interrupts := True;
13286 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
13288 when Pragma_Unsuppress =>
13290 Process_Suppress_Unsuppress (False);
13292 -------------------
13293 -- Use_VADS_Size --
13294 -------------------
13296 -- pragma Use_VADS_Size;
13298 when Pragma_Use_VADS_Size =>
13300 Check_Arg_Count (0);
13301 Check_Valid_Configuration_Pragma;
13302 Use_VADS_Size := True;
13304 ---------------------
13305 -- Validity_Checks --
13306 ---------------------
13308 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
13310 when Pragma_Validity_Checks => Validity_Checks : declare
13311 A : constant Node_Id := Get_Pragma_Arg (Arg1);
13317 Check_Arg_Count (1);
13318 Check_No_Identifiers;
13320 if Nkind (A) = N_String_Literal then
13324 Slen : constant Natural := Natural (String_Length (S));
13325 Options : String (1 .. Slen);
13331 C := Get_String_Char (S, Int (J));
13332 exit when not In_Character_Range (C);
13333 Options (J) := Get_Character (C);
13336 Set_Validity_Check_Options (Options);
13344 elsif Nkind (A) = N_Identifier then
13346 if Chars (A) = Name_All_Checks then
13347 Set_Validity_Check_Options ("a");
13349 elsif Chars (A) = Name_On then
13350 Validity_Checks_On := True;
13352 elsif Chars (A) = Name_Off then
13353 Validity_Checks_On := False;
13357 end Validity_Checks;
13363 -- pragma Volatile (LOCAL_NAME);
13365 when Pragma_Volatile =>
13366 Process_Atomic_Shared_Volatile;
13368 -------------------------
13369 -- Volatile_Components --
13370 -------------------------
13372 -- pragma Volatile_Components (array_LOCAL_NAME);
13374 -- Volatile is handled by the same circuit as Atomic_Components
13380 -- pragma Warnings (On | Off);
13381 -- pragma Warnings (On | Off, LOCAL_NAME);
13382 -- pragma Warnings (static_string_EXPRESSION);
13383 -- pragma Warnings (On | Off, STRING_LITERAL);
13385 when Pragma_Warnings => Warnings : begin
13387 Check_At_Least_N_Arguments (1);
13388 Check_No_Identifiers;
13390 -- If debug flag -gnatd.i is set, pragma is ignored
13392 if Debug_Flag_Dot_I then
13396 -- Process various forms of the pragma
13399 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
13402 -- One argument case
13404 if Arg_Count = 1 then
13406 -- On/Off one argument case was processed by parser
13408 if Nkind (Argx) = N_Identifier
13410 (Chars (Argx) = Name_On
13412 Chars (Argx) = Name_Off)
13416 -- One argument case must be ON/OFF or static string expr
13418 elsif not Is_Static_String_Expression (Arg1) then
13420 ("argument of pragma% must be On/Off or " &
13421 "static string expression", Arg1);
13423 -- One argument string expression case
13427 Lit : constant Node_Id := Expr_Value_S (Argx);
13428 Str : constant String_Id := Strval (Lit);
13429 Len : constant Nat := String_Length (Str);
13437 while J <= Len loop
13438 C := Get_String_Char (Str, J);
13439 OK := In_Character_Range (C);
13442 Chr := Get_Character (C);
13446 if J < Len and then Chr = '.' then
13448 C := Get_String_Char (Str, J);
13449 Chr := Get_Character (C);
13451 if not Set_Dot_Warning_Switch (Chr) then
13453 ("invalid warning switch character " &
13460 OK := Set_Warning_Switch (Chr);
13466 ("invalid warning switch character " & Chr,
13475 -- Two or more arguments (must be two)
13478 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
13479 Check_At_Most_N_Arguments (2);
13487 E_Id := Get_Pragma_Arg (Arg2);
13490 -- In the expansion of an inlined body, a reference to
13491 -- the formal may be wrapped in a conversion if the
13492 -- actual is a conversion. Retrieve the real entity name.
13494 if (In_Instance_Body
13495 or else In_Inlined_Body)
13496 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
13498 E_Id := Expression (E_Id);
13501 -- Entity name case
13503 if Is_Entity_Name (E_Id) then
13504 E := Entity (E_Id);
13511 (E, (Chars (Get_Pragma_Arg (Arg1)) =
13514 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
13515 and then Warn_On_Warnings_Off
13517 Warnings_Off_Pragmas.Append ((N, E));
13520 if Is_Enumeration_Type (E) then
13524 Lit := First_Literal (E);
13525 while Present (Lit) loop
13526 Set_Warnings_Off (Lit);
13527 Next_Literal (Lit);
13532 exit when No (Homonym (E));
13537 -- Error if not entity or static string literal case
13539 elsif not Is_Static_String_Expression (Arg2) then
13541 ("second argument of pragma% must be entity " &
13542 "name or static string expression", Arg2);
13544 -- String literal case
13547 String_To_Name_Buffer
13548 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg2))));
13550 -- Note on configuration pragma case: If this is a
13551 -- configuration pragma, then for an OFF pragma, we
13552 -- just set Config True in the call, which is all
13553 -- that needs to be done. For the case of ON, this
13554 -- is normally an error, unless it is canceling the
13555 -- effect of a previous OFF pragma in the same file.
13556 -- In any other case, an error will be signalled (ON
13557 -- with no matching OFF).
13559 if Chars (Argx) = Name_Off then
13560 Set_Specific_Warning_Off
13561 (Loc, Name_Buffer (1 .. Name_Len),
13562 Config => Is_Configuration_Pragma);
13564 elsif Chars (Argx) = Name_On then
13565 Set_Specific_Warning_On
13566 (Loc, Name_Buffer (1 .. Name_Len), Err);
13570 ("?pragma Warnings On with no " &
13571 "matching Warnings Off",
13581 -------------------
13582 -- Weak_External --
13583 -------------------
13585 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
13587 when Pragma_Weak_External => Weak_External : declare
13592 Check_Arg_Count (1);
13593 Check_Optional_Identifier (Arg1, Name_Entity);
13594 Check_Arg_Is_Library_Level_Local_Name (Arg1);
13595 Ent := Entity (Get_Pragma_Arg (Arg1));
13597 if Rep_Item_Too_Early (Ent, N) then
13600 Ent := Underlying_Type (Ent);
13603 -- The only processing required is to link this item on to the
13604 -- list of rep items for the given entity. This is accomplished
13605 -- by the call to Rep_Item_Too_Late (when no error is detected
13606 -- and False is returned).
13608 if Rep_Item_Too_Late (Ent, N) then
13611 Set_Has_Gigi_Rep_Item (Ent);
13615 -----------------------------
13616 -- Wide_Character_Encoding --
13617 -----------------------------
13619 -- pragma Wide_Character_Encoding (IDENTIFIER);
13621 when Pragma_Wide_Character_Encoding =>
13624 -- Nothing to do, handled in parser. Note that we do not enforce
13625 -- configuration pragma placement, this pragma can appear at any
13626 -- place in the source, allowing mixed encodings within a single
13631 --------------------
13632 -- Unknown_Pragma --
13633 --------------------
13635 -- Should be impossible, since the case of an unknown pragma is
13636 -- separately processed before the case statement is entered.
13638 when Unknown_Pragma =>
13639 raise Program_Error;
13642 -- AI05-0144: detect dangerous order dependence. Disabled for now,
13643 -- until AI is formally approved.
13645 -- Check_Order_Dependence;
13648 when Pragma_Exit => null;
13649 end Analyze_Pragma;
13651 -------------------
13652 -- Check_Enabled --
13653 -------------------
13655 function Check_Enabled (Nam : Name_Id) return Boolean is
13659 PP := Opt.Check_Policy_List;
13662 return Assertions_Enabled;
13665 Nam = Chars (Expression (First (Pragma_Argument_Associations (PP))))
13668 Chars (Expression (Last (Pragma_Argument_Associations (PP))))
13670 when Name_On | Name_Check =>
13672 when Name_Off | Name_Ignore =>
13675 raise Program_Error;
13679 PP := Next_Pragma (PP);
13684 ---------------------------------
13685 -- Delay_Config_Pragma_Analyze --
13686 ---------------------------------
13688 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
13690 return Pragma_Name (N) = Name_Interrupt_State
13692 Pragma_Name (N) = Name_Priority_Specific_Dispatching;
13693 end Delay_Config_Pragma_Analyze;
13695 -------------------------
13696 -- Get_Base_Subprogram --
13697 -------------------------
13699 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
13700 Result : Entity_Id;
13703 -- Follow subprogram renaming chain
13706 while Is_Subprogram (Result)
13708 (Is_Generic_Instance (Result)
13709 or else Nkind (Parent (Declaration_Node (Result))) =
13710 N_Subprogram_Renaming_Declaration)
13711 and then Present (Alias (Result))
13713 Result := Alias (Result);
13717 end Get_Base_Subprogram;
13723 procedure Initialize is
13728 -----------------------------
13729 -- Is_Config_Static_String --
13730 -----------------------------
13732 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
13734 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
13735 -- This is an internal recursive function that is just like the outer
13736 -- function except that it adds the string to the name buffer rather
13737 -- than placing the string in the name buffer.
13739 ------------------------------
13740 -- Add_Config_Static_String --
13741 ------------------------------
13743 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
13750 if Nkind (N) = N_Op_Concat then
13751 if Add_Config_Static_String (Left_Opnd (N)) then
13752 N := Right_Opnd (N);
13758 if Nkind (N) /= N_String_Literal then
13759 Error_Msg_N ("string literal expected for pragma argument", N);
13763 for J in 1 .. String_Length (Strval (N)) loop
13764 C := Get_String_Char (Strval (N), J);
13766 if not In_Character_Range (C) then
13768 ("string literal contains invalid wide character",
13769 Sloc (N) + 1 + Source_Ptr (J));
13773 Add_Char_To_Name_Buffer (Get_Character (C));
13778 end Add_Config_Static_String;
13780 -- Start of processing for Is_Config_Static_String
13785 return Add_Config_Static_String (Arg);
13786 end Is_Config_Static_String;
13788 -----------------------------------------
13789 -- Is_Non_Significant_Pragma_Reference --
13790 -----------------------------------------
13792 -- This function makes use of the following static table which indicates
13793 -- whether a given pragma is significant.
13795 -- -1 indicates that references in any argument position are significant
13796 -- 0 indicates that appearence in any argument is not significant
13797 -- +n indicates that appearence as argument n is significant, but all
13798 -- other arguments are not significant
13799 -- 99 special processing required (e.g. for pragma Check)
13801 Sig_Flags : constant array (Pragma_Id) of Int :=
13802 (Pragma_AST_Entry => -1,
13803 Pragma_Abort_Defer => -1,
13804 Pragma_Ada_83 => -1,
13805 Pragma_Ada_95 => -1,
13806 Pragma_Ada_05 => -1,
13807 Pragma_Ada_2005 => -1,
13808 Pragma_Ada_12 => -1,
13809 Pragma_Ada_2012 => -1,
13810 Pragma_All_Calls_Remote => -1,
13811 Pragma_Annotate => -1,
13812 Pragma_Assert => -1,
13813 Pragma_Assertion_Policy => 0,
13814 Pragma_Assume_No_Invalid_Values => 0,
13815 Pragma_Asynchronous => -1,
13816 Pragma_Atomic => 0,
13817 Pragma_Atomic_Components => 0,
13818 Pragma_Attach_Handler => -1,
13819 Pragma_Check => 99,
13820 Pragma_Check_Name => 0,
13821 Pragma_Check_Policy => 0,
13822 Pragma_CIL_Constructor => -1,
13823 Pragma_CPP_Class => 0,
13824 Pragma_CPP_Constructor => 0,
13825 Pragma_CPP_Virtual => 0,
13826 Pragma_CPP_Vtable => 0,
13828 Pragma_C_Pass_By_Copy => 0,
13829 Pragma_Comment => 0,
13830 Pragma_Common_Object => -1,
13831 Pragma_Compile_Time_Error => -1,
13832 Pragma_Compile_Time_Warning => -1,
13833 Pragma_Compiler_Unit => 0,
13834 Pragma_Complete_Representation => 0,
13835 Pragma_Complex_Representation => 0,
13836 Pragma_Component_Alignment => -1,
13837 Pragma_Controlled => 0,
13838 Pragma_Convention => 0,
13839 Pragma_Convention_Identifier => 0,
13840 Pragma_Debug => -1,
13841 Pragma_Debug_Policy => 0,
13842 Pragma_Detect_Blocking => -1,
13843 Pragma_Default_Storage_Pool => -1,
13844 Pragma_Dimension => -1,
13845 Pragma_Discard_Names => 0,
13846 Pragma_Elaborate => -1,
13847 Pragma_Elaborate_All => -1,
13848 Pragma_Elaborate_Body => -1,
13849 Pragma_Elaboration_Checks => -1,
13850 Pragma_Eliminate => -1,
13851 Pragma_Export => -1,
13852 Pragma_Export_Exception => -1,
13853 Pragma_Export_Function => -1,
13854 Pragma_Export_Object => -1,
13855 Pragma_Export_Procedure => -1,
13856 Pragma_Export_Value => -1,
13857 Pragma_Export_Valued_Procedure => -1,
13858 Pragma_Extend_System => -1,
13859 Pragma_Extensions_Allowed => -1,
13860 Pragma_External => -1,
13861 Pragma_Favor_Top_Level => -1,
13862 Pragma_External_Name_Casing => -1,
13863 Pragma_Fast_Math => -1,
13864 Pragma_Finalize_Storage_Only => 0,
13865 Pragma_Float_Representation => 0,
13866 Pragma_Ident => -1,
13867 Pragma_Implemented => -1,
13868 Pragma_Implicit_Packing => 0,
13869 Pragma_Import => +2,
13870 Pragma_Import_Exception => 0,
13871 Pragma_Import_Function => 0,
13872 Pragma_Import_Object => 0,
13873 Pragma_Import_Procedure => 0,
13874 Pragma_Import_Valued_Procedure => 0,
13875 Pragma_Independent => 0,
13876 Pragma_Independent_Components => 0,
13877 Pragma_Initialize_Scalars => -1,
13878 Pragma_Inline => 0,
13879 Pragma_Inline_Always => 0,
13880 Pragma_Inline_Generic => 0,
13881 Pragma_Inspection_Point => -1,
13882 Pragma_Interface => +2,
13883 Pragma_Interface_Name => +2,
13884 Pragma_Interrupt_Handler => -1,
13885 Pragma_Interrupt_Priority => -1,
13886 Pragma_Interrupt_State => -1,
13887 Pragma_Invariant => -1,
13888 Pragma_Java_Constructor => -1,
13889 Pragma_Java_Interface => -1,
13890 Pragma_Keep_Names => 0,
13891 Pragma_License => -1,
13892 Pragma_Link_With => -1,
13893 Pragma_Linker_Alias => -1,
13894 Pragma_Linker_Constructor => -1,
13895 Pragma_Linker_Destructor => -1,
13896 Pragma_Linker_Options => -1,
13897 Pragma_Linker_Section => -1,
13899 Pragma_Locking_Policy => -1,
13900 Pragma_Long_Float => -1,
13901 Pragma_Machine_Attribute => -1,
13903 Pragma_Main_Storage => -1,
13904 Pragma_Memory_Size => -1,
13905 Pragma_No_Return => 0,
13906 Pragma_No_Body => 0,
13907 Pragma_No_Run_Time => -1,
13908 Pragma_No_Strict_Aliasing => -1,
13909 Pragma_Normalize_Scalars => -1,
13910 Pragma_Obsolescent => 0,
13911 Pragma_Optimize => -1,
13912 Pragma_Optimize_Alignment => -1,
13913 Pragma_Ordered => 0,
13916 Pragma_Passive => -1,
13917 Pragma_Preelaborable_Initialization => -1,
13918 Pragma_Polling => -1,
13919 Pragma_Persistent_BSS => 0,
13920 Pragma_Postcondition => -1,
13921 Pragma_Precondition => -1,
13922 Pragma_Preelaborate => -1,
13923 Pragma_Preelaborate_05 => -1,
13924 Pragma_Priority => -1,
13925 Pragma_Priority_Specific_Dispatching => -1,
13926 Pragma_Profile => 0,
13927 Pragma_Profile_Warnings => 0,
13928 Pragma_Propagate_Exceptions => -1,
13929 Pragma_Psect_Object => -1,
13931 Pragma_Pure_05 => -1,
13932 Pragma_Pure_Function => -1,
13933 Pragma_Queuing_Policy => -1,
13934 Pragma_Ravenscar => -1,
13935 Pragma_Relative_Deadline => -1,
13936 Pragma_Remote_Call_Interface => -1,
13937 Pragma_Remote_Types => -1,
13938 Pragma_Restricted_Run_Time => -1,
13939 Pragma_Restriction_Warnings => -1,
13940 Pragma_Restrictions => -1,
13941 Pragma_Reviewable => -1,
13942 Pragma_Short_Circuit_And_Or => -1,
13943 Pragma_Share_Generic => -1,
13944 Pragma_Shared => -1,
13945 Pragma_Shared_Passive => -1,
13946 Pragma_Short_Descriptors => 0,
13947 Pragma_Source_File_Name => -1,
13948 Pragma_Source_File_Name_Project => -1,
13949 Pragma_Source_Reference => -1,
13950 Pragma_Storage_Size => -1,
13951 Pragma_Storage_Unit => -1,
13952 Pragma_Static_Elaboration_Desired => -1,
13953 Pragma_Stream_Convert => -1,
13954 Pragma_Style_Checks => -1,
13955 Pragma_Subtitle => -1,
13956 Pragma_Suppress => 0,
13957 Pragma_Suppress_Exception_Locations => 0,
13958 Pragma_Suppress_All => -1,
13959 Pragma_Suppress_Debug_Info => 0,
13960 Pragma_Suppress_Initialization => 0,
13961 Pragma_System_Name => -1,
13962 Pragma_Task_Dispatching_Policy => -1,
13963 Pragma_Task_Info => -1,
13964 Pragma_Task_Name => -1,
13965 Pragma_Task_Storage => 0,
13966 Pragma_Thread_Local_Storage => 0,
13967 Pragma_Time_Slice => -1,
13968 Pragma_Title => -1,
13969 Pragma_Unchecked_Union => 0,
13970 Pragma_Unimplemented_Unit => -1,
13971 Pragma_Universal_Aliasing => -1,
13972 Pragma_Universal_Data => -1,
13973 Pragma_Unmodified => -1,
13974 Pragma_Unreferenced => -1,
13975 Pragma_Unreferenced_Objects => -1,
13976 Pragma_Unreserve_All_Interrupts => -1,
13977 Pragma_Unsuppress => 0,
13978 Pragma_Use_VADS_Size => -1,
13979 Pragma_Validity_Checks => -1,
13980 Pragma_Volatile => 0,
13981 Pragma_Volatile_Components => 0,
13982 Pragma_Warnings => -1,
13983 Pragma_Weak_External => -1,
13984 Pragma_Wide_Character_Encoding => 0,
13985 Unknown_Pragma => 0);
13987 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
13996 if Nkind (P) /= N_Pragma_Argument_Association then
14000 Id := Get_Pragma_Id (Parent (P));
14001 C := Sig_Flags (Id);
14013 -- For pragma Check, the first argument is not significant,
14014 -- the second and the third (if present) arguments are
14017 when Pragma_Check =>
14019 P = First (Pragma_Argument_Associations (Parent (P)));
14022 raise Program_Error;
14026 A := First (Pragma_Argument_Associations (Parent (P)));
14027 for J in 1 .. C - 1 loop
14035 return A = P; -- is this wrong way round ???
14038 end Is_Non_Significant_Pragma_Reference;
14040 ------------------------------
14041 -- Is_Pragma_String_Literal --
14042 ------------------------------
14044 -- This function returns true if the corresponding pragma argument is a
14045 -- static string expression. These are the only cases in which string
14046 -- literals can appear as pragma arguments. We also allow a string literal
14047 -- as the first argument to pragma Assert (although it will of course
14048 -- always generate a type error).
14050 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
14051 Pragn : constant Node_Id := Parent (Par);
14052 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
14053 Pname : constant Name_Id := Pragma_Name (Pragn);
14059 N := First (Assoc);
14066 if Pname = Name_Assert then
14069 elsif Pname = Name_Export then
14072 elsif Pname = Name_Ident then
14075 elsif Pname = Name_Import then
14078 elsif Pname = Name_Interface_Name then
14081 elsif Pname = Name_Linker_Alias then
14084 elsif Pname = Name_Linker_Section then
14087 elsif Pname = Name_Machine_Attribute then
14090 elsif Pname = Name_Source_File_Name then
14093 elsif Pname = Name_Source_Reference then
14096 elsif Pname = Name_Title then
14099 elsif Pname = Name_Subtitle then
14105 end Is_Pragma_String_Literal;
14107 --------------------------------------
14108 -- Process_Compilation_Unit_Pragmas --
14109 --------------------------------------
14111 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
14113 -- A special check for pragma Suppress_All, a very strange DEC pragma,
14114 -- strange because it comes at the end of the unit. Rational has the
14115 -- same name for a pragma, but treats it as a program unit pragma, In
14116 -- GNAT we just decide to allow it anywhere at all. If it appeared then
14117 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
14118 -- node, and we insert a pragma Suppress (All_Checks) at the start of
14119 -- the context clause to ensure the correct processing.
14121 if Has_Pragma_Suppress_All (N) then
14122 Prepend_To (Context_Items (N),
14123 Make_Pragma (Sloc (N),
14124 Chars => Name_Suppress,
14125 Pragma_Argument_Associations => New_List (
14126 Make_Pragma_Argument_Association (Sloc (N),
14128 Make_Identifier (Sloc (N),
14129 Chars => Name_All_Checks)))));
14132 -- Nothing else to do at the current time!
14134 end Process_Compilation_Unit_Pragmas;
14145 --------------------------------
14146 -- Set_Encoded_Interface_Name --
14147 --------------------------------
14149 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
14150 Str : constant String_Id := Strval (S);
14151 Len : constant Int := String_Length (Str);
14156 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
14159 -- Stores encoded value of character code CC. The encoding we use an
14160 -- underscore followed by four lower case hex digits.
14166 procedure Encode is
14168 Store_String_Char (Get_Char_Code ('_'));
14170 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
14172 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
14174 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
14176 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
14179 -- Start of processing for Set_Encoded_Interface_Name
14182 -- If first character is asterisk, this is a link name, and we leave it
14183 -- completely unmodified. We also ignore null strings (the latter case
14184 -- happens only in error cases) and no encoding should occur for Java or
14185 -- AAMP interface names.
14188 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
14189 or else VM_Target /= No_VM
14190 or else AAMP_On_Target
14192 Set_Interface_Name (E, S);
14197 CC := Get_String_Char (Str, J);
14199 exit when not In_Character_Range (CC);
14201 C := Get_Character (CC);
14203 exit when C /= '_' and then C /= '$'
14204 and then C not in '0' .. '9'
14205 and then C not in 'a' .. 'z'
14206 and then C not in 'A' .. 'Z';
14209 Set_Interface_Name (E, S);
14217 -- Here we need to encode. The encoding we use as follows:
14218 -- three underscores + four hex digits (lower case)
14222 for J in 1 .. String_Length (Str) loop
14223 CC := Get_String_Char (Str, J);
14225 if not In_Character_Range (CC) then
14228 C := Get_Character (CC);
14230 if C = '_' or else C = '$'
14231 or else C in '0' .. '9'
14232 or else C in 'a' .. 'z'
14233 or else C in 'A' .. 'Z'
14235 Store_String_Char (CC);
14242 Set_Interface_Name (E,
14243 Make_String_Literal (Sloc (S),
14244 Strval => End_String));
14246 end Set_Encoded_Interface_Name;
14248 -------------------
14249 -- Set_Unit_Name --
14250 -------------------
14252 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id) is
14257 if Nkind (N) = N_Identifier
14258 and then Nkind (With_Item) = N_Identifier
14260 Set_Entity (N, Entity (With_Item));
14262 elsif Nkind (N) = N_Selected_Component then
14263 Change_Selected_Component_To_Expanded_Name (N);
14264 Set_Entity (N, Entity (With_Item));
14265 Set_Entity (Selector_Name (N), Entity (N));
14267 Pref := Prefix (N);
14268 Scop := Scope (Entity (N));
14269 while Nkind (Pref) = N_Selected_Component loop
14270 Change_Selected_Component_To_Expanded_Name (Pref);
14271 Set_Entity (Selector_Name (Pref), Scop);
14272 Set_Entity (Pref, Scop);
14273 Pref := Prefix (Pref);
14274 Scop := Scope (Scop);
14277 Set_Entity (Pref, Scop);