1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This unit contains the semantic processing for all pragmas, both language
27 -- and implementation defined. For most pragmas, the parser only does the
28 -- most basic job of checking the syntax, so Sem_Prag also contains the code
29 -- to complete the syntax checks. Certain pragmas are handled partially or
30 -- completely by the parser (see Par.Prag for further details).
32 with Atree; use Atree;
33 with Casing; use Casing;
34 with Checks; use Checks;
35 with Csets; use Csets;
36 with Debug; use Debug;
37 with Einfo; use Einfo;
38 with Elists; use Elists;
39 with Errout; use Errout;
40 with Exp_Dist; use Exp_Dist;
41 with Exp_Util; use Exp_Util;
42 with Freeze; use Freeze;
44 with Lib.Writ; use Lib.Writ;
45 with Lib.Xref; use Lib.Xref;
46 with Namet.Sp; use Namet.Sp;
47 with Nlists; use Nlists;
48 with Nmake; use Nmake;
50 with Output; use Output;
51 with Par_SCO; use Par_SCO;
52 with Restrict; use Restrict;
53 with Rident; use Rident;
54 with Rtsfind; use Rtsfind;
56 with Sem_Aux; use Sem_Aux;
57 with Sem_Ch3; use Sem_Ch3;
58 with Sem_Ch6; use Sem_Ch6;
59 with Sem_Ch8; use Sem_Ch8;
60 with Sem_Ch12; use Sem_Ch12;
61 with Sem_Ch13; use Sem_Ch13;
62 with Sem_Disp; use Sem_Disp;
63 with Sem_Dist; use Sem_Dist;
64 with Sem_Elim; use Sem_Elim;
65 with Sem_Eval; use Sem_Eval;
66 with Sem_Intr; use Sem_Intr;
67 with Sem_Mech; use Sem_Mech;
68 with Sem_Res; use Sem_Res;
69 with Sem_Type; use Sem_Type;
70 with Sem_Util; use Sem_Util;
71 with Sem_VFpt; use Sem_VFpt;
72 with Sem_Warn; use Sem_Warn;
73 with Stand; use Stand;
74 with Sinfo; use Sinfo;
75 with Sinfo.CN; use Sinfo.CN;
76 with Sinput; use Sinput;
77 with Snames; use Snames;
78 with Stringt; use Stringt;
79 with Stylesw; use Stylesw;
81 with Targparm; use Targparm;
82 with Tbuild; use Tbuild;
84 with Uintp; use Uintp;
85 with Uname; use Uname;
86 with Urealp; use Urealp;
87 with Validsw; use Validsw;
88 with Warnsw; use Warnsw;
90 package body Sem_Prag is
92 ----------------------------------------------
93 -- Common Handling of Import-Export Pragmas --
94 ----------------------------------------------
96 -- In the following section, a number of Import_xxx and Export_xxx pragmas
97 -- are defined by GNAT. These are compatible with the DEC pragmas of the
98 -- same name, and all have the following common form and processing:
101 -- [Internal =>] LOCAL_NAME
102 -- [, [External =>] EXTERNAL_SYMBOL]
103 -- [, other optional parameters ]);
106 -- [Internal =>] LOCAL_NAME
107 -- [, [External =>] EXTERNAL_SYMBOL]
108 -- [, other optional parameters ]);
110 -- EXTERNAL_SYMBOL ::=
112 -- | static_string_EXPRESSION
114 -- The internal LOCAL_NAME designates the entity that is imported or
115 -- exported, and must refer to an entity in the current declarative
116 -- part (as required by the rules for LOCAL_NAME).
118 -- The external linker name is designated by the External parameter if
119 -- given, or the Internal parameter if not (if there is no External
120 -- parameter, the External parameter is a copy of the Internal name).
122 -- If the External parameter is given as a string, then this string is
123 -- treated as an external name (exactly as though it had been given as an
124 -- External_Name parameter for a normal Import pragma).
126 -- If the External parameter is given as an identifier (or there is no
127 -- External parameter, so that the Internal identifier is used), then
128 -- the external name is the characters of the identifier, translated
129 -- to all upper case letters for OpenVMS versions of GNAT, and to all
130 -- lower case letters for all other versions
132 -- Note: the external name specified or implied by any of these special
133 -- Import_xxx or Export_xxx pragmas override an external or link name
134 -- specified in a previous Import or Export pragma.
136 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
137 -- named notation, following the standard rules for subprogram calls, i.e.
138 -- parameters can be given in any order if named notation is used, and
139 -- positional and named notation can be mixed, subject to the rule that all
140 -- positional parameters must appear first.
142 -- Note: All these pragmas are implemented exactly following the DEC design
143 -- and implementation and are intended to be fully compatible with the use
144 -- of these pragmas in the DEC Ada compiler.
146 --------------------------------------------
147 -- Checking for Duplicated External Names --
148 --------------------------------------------
150 -- It is suspicious if two separate Export pragmas use the same external
151 -- name. The following table is used to diagnose this situation so that
152 -- an appropriate warning can be issued.
154 -- The Node_Id stored is for the N_String_Literal node created to hold
155 -- the value of the external name. The Sloc of this node is used to
156 -- cross-reference the location of the duplication.
158 package Externals is new Table.Table (
159 Table_Component_Type => Node_Id,
160 Table_Index_Type => Int,
161 Table_Low_Bound => 0,
162 Table_Initial => 100,
163 Table_Increment => 100,
164 Table_Name => "Name_Externals");
166 -------------------------------------
167 -- Local Subprograms and Variables --
168 -------------------------------------
170 function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
171 -- This routine is used for possible casing adjustment of an explicit
172 -- external name supplied as a string literal (the node N), according to
173 -- the casing requirement of Opt.External_Name_Casing. If this is set to
174 -- As_Is, then the string literal is returned unchanged, but if it is set
175 -- to Uppercase or Lowercase, then a new string literal with appropriate
176 -- casing is constructed.
178 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
179 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
180 -- original one, following the renaming chain) is returned. Otherwise the
181 -- entity is returned unchanged. Should be in Einfo???
183 procedure Preanalyze_TC_Args (Arg_Req, Arg_Ens : Node_Id);
184 -- Preanalyze the boolean expressions in the Requires and Ensures arguments
185 -- of a Test_Case pragma if present (possibly Empty). We treat these as
186 -- spec expressions (i.e. similar to a default expression).
189 -- This is a dummy function called by the processing for pragma Reviewable.
190 -- It is there for assisting front end debugging. By placing a Reviewable
191 -- pragma in the source program, a breakpoint on rv catches this place in
192 -- the source, allowing convenient stepping to the point of interest.
194 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id);
195 -- Place semantic information on the argument of an Elaborate/Elaborate_All
196 -- pragma. Entity name for unit and its parents is taken from item in
197 -- previous with_clause that mentions the unit.
199 -------------------------------
200 -- Adjust_External_Name_Case --
201 -------------------------------
203 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
207 -- Adjust case of literal if required
209 if Opt.External_Name_Exp_Casing = As_Is then
213 -- Copy existing string
219 for J in 1 .. String_Length (Strval (N)) loop
220 CC := Get_String_Char (Strval (N), J);
222 if Opt.External_Name_Exp_Casing = Uppercase
223 and then CC >= Get_Char_Code ('a')
224 and then CC <= Get_Char_Code ('z')
226 Store_String_Char (CC - 32);
228 elsif Opt.External_Name_Exp_Casing = Lowercase
229 and then CC >= Get_Char_Code ('A')
230 and then CC <= Get_Char_Code ('Z')
232 Store_String_Char (CC + 32);
235 Store_String_Char (CC);
240 Make_String_Literal (Sloc (N),
241 Strval => End_String);
243 end Adjust_External_Name_Case;
245 ------------------------------
246 -- Analyze_PPC_In_Decl_Part --
247 ------------------------------
249 procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id) is
250 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
253 -- Install formals and push subprogram spec onto scope stack so that we
254 -- can see the formals from the pragma.
259 -- Preanalyze the boolean expression, we treat this as a spec expression
260 -- (i.e. similar to a default expression).
262 Preanalyze_Spec_Expression
263 (Get_Pragma_Arg (Arg1), Standard_Boolean);
265 if Class_Present (N) then
267 T : constant Entity_Id := Find_Dispatching_Type (S);
269 ACW : Entity_Id := Empty;
270 -- Access to T'class, created if there is a controlling formal
271 -- that is an access parameter.
273 function Get_ACW return Entity_Id;
274 -- If the expression has a reference to an controlling access
275 -- parameter, create an access to T'class for the necessary
276 -- conversions if one does not exist.
278 function Process (N : Node_Id) return Traverse_Result;
279 -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
280 -- aspect for a primitive subprogram of a tagged type T, a name
281 -- that denotes a formal parameter of type T is interpreted as
282 -- having type T'Class. Similarly, a name that denotes a formal
283 -- accessparameter of type access-to-T is interpreted as having
284 -- type access-to-T'Class. This ensures the expression is well-
285 -- defined for a primitive subprogram of a type descended from T.
291 function Get_ACW return Entity_Id is
292 Loc : constant Source_Ptr := Sloc (N);
297 Decl := Make_Full_Type_Declaration (Loc,
298 Defining_Identifier => Make_Temporary (Loc, 'T'),
300 Make_Access_To_Object_Definition (Loc,
301 Subtype_Indication =>
302 New_Occurrence_Of (Class_Wide_Type (T), Loc),
303 All_Present => True));
305 Insert_Before (Unit_Declaration_Node (S), Decl);
307 ACW := Defining_Identifier (Decl);
308 Freeze_Before (Unit_Declaration_Node (S), ACW);
318 function Process (N : Node_Id) return Traverse_Result is
319 Loc : constant Source_Ptr := Sloc (N);
323 if Is_Entity_Name (N)
324 and then Is_Formal (Entity (N))
325 and then Nkind (Parent (N)) /= N_Type_Conversion
327 if Etype (Entity (N)) = T then
328 Typ := Class_Wide_Type (T);
330 elsif Is_Access_Type (Etype (Entity (N)))
331 and then Designated_Type (Etype (Entity (N))) = T
338 if Present (Typ) then
340 Make_Type_Conversion (Loc,
342 New_Occurrence_Of (Typ, Loc),
343 Expression => New_Occurrence_Of (Entity (N), Loc)));
351 procedure Replace_Type is new Traverse_Proc (Process);
354 Replace_Type (Get_Pragma_Arg (Arg1));
358 -- Remove the subprogram from the scope stack now that the pre-analysis
359 -- of the precondition/postcondition is done.
362 end Analyze_PPC_In_Decl_Part;
368 procedure Analyze_Pragma (N : Node_Id) is
369 Loc : constant Source_Ptr := Sloc (N);
370 Pname : constant Name_Id := Pragma_Name (N);
373 Pragma_Exit : exception;
374 -- This exception is used to exit pragma processing completely. It is
375 -- used when an error is detected, and no further processing is
376 -- required. It is also used if an earlier error has left the tree in
377 -- a state where the pragma should not be processed.
380 -- Number of pragma argument associations
386 -- First four pragma arguments (pragma argument association nodes, or
387 -- Empty if the corresponding argument does not exist).
389 type Name_List is array (Natural range <>) of Name_Id;
390 type Args_List is array (Natural range <>) of Node_Id;
391 -- Types used for arguments to Check_Arg_Order and Gather_Associations
393 procedure Ada_2005_Pragma;
394 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
395 -- Ada 95 mode, these are implementation defined pragmas, so should be
396 -- caught by the No_Implementation_Pragmas restriction.
398 procedure Ada_2012_Pragma;
399 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
400 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
401 -- should be caught by the No_Implementation_Pragmas restriction.
403 procedure Check_Ada_83_Warning;
404 -- Issues a warning message for the current pragma if operating in Ada
405 -- 83 mode (used for language pragmas that are not a standard part of
406 -- Ada 83). This procedure does not raise Error_Pragma. Also notes use
409 procedure Check_Arg_Count (Required : Nat);
410 -- Check argument count for pragma is equal to given parameter. If not,
411 -- then issue an error message and raise Pragma_Exit.
413 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
414 -- Arg which can either be a pragma argument association, in which case
415 -- the check is applied to the expression of the association or an
416 -- expression directly.
418 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
419 -- Check that an argument has the right form for an EXTERNAL_NAME
420 -- parameter of an extended import/export pragma. The rule is that the
421 -- name must be an identifier or string literal (in Ada 83 mode) or a
422 -- static string expression (in Ada 95 mode).
424 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
425 -- Check the specified argument Arg to make sure that it is an
426 -- identifier. If not give error and raise Pragma_Exit.
428 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
429 -- Check the specified argument Arg to make sure that it is an integer
430 -- literal. If not give error and raise Pragma_Exit.
432 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
433 -- Check the specified argument Arg to make sure that it has the proper
434 -- syntactic form for a local name and meets the semantic requirements
435 -- for a local name. The local name is analyzed as part of the
436 -- processing for this call. In addition, the local name is required
437 -- to represent an entity at the library level.
439 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
440 -- Check the specified argument Arg to make sure that it has the proper
441 -- syntactic form for a local name and meets the semantic requirements
442 -- for a local name. The local name is analyzed as part of the
443 -- processing for this call.
445 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
446 -- Check the specified argument Arg to make sure that it is a valid
447 -- locking policy name. If not give error and raise Pragma_Exit.
449 procedure Check_Arg_Is_One_Of
452 procedure Check_Arg_Is_One_Of
454 N1, N2, N3 : Name_Id);
455 procedure Check_Arg_Is_One_Of
457 N1, N2, N3, N4, N5 : Name_Id);
458 -- Check the specified argument Arg to make sure that it is an
459 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
460 -- present). If not then give error and raise Pragma_Exit.
462 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
463 -- Check the specified argument Arg to make sure that it is a valid
464 -- queuing policy name. If not give error and raise Pragma_Exit.
466 procedure Check_Arg_Is_Static_Expression
468 Typ : Entity_Id := Empty);
469 -- Check the specified argument Arg to make sure that it is a static
470 -- expression of the given type (i.e. it will be analyzed and resolved
471 -- using this type, which can be any valid argument to Resolve, e.g.
472 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
473 -- Typ is left Empty, then any static expression is allowed.
475 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
476 -- Check the specified argument Arg to make sure that it is a valid task
477 -- dispatching policy name. If not give error and raise Pragma_Exit.
479 procedure Check_Arg_Order (Names : Name_List);
480 -- Checks for an instance of two arguments with identifiers for the
481 -- current pragma which are not in the sequence indicated by Names,
482 -- and if so, generates a fatal message about bad order of arguments.
484 procedure Check_At_Least_N_Arguments (N : Nat);
485 -- Check there are at least N arguments present
487 procedure Check_At_Most_N_Arguments (N : Nat);
488 -- Check there are no more than N arguments present
490 procedure Check_Component
493 In_Variant_Part : Boolean := False);
494 -- Examine an Unchecked_Union component for correct use of per-object
495 -- constrained subtypes, and for restrictions on finalizable components.
496 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
497 -- should be set when Comp comes from a record variant.
499 procedure Check_Duplicate_Pragma (E : Entity_Id);
500 -- Check if a pragma of the same name as the current pragma is already
501 -- chained as a rep pragma to the given entity. If so give a message
502 -- about the duplicate, and then raise Pragma_Exit so does not return.
503 -- Also checks for delayed aspect specification node in the chain.
505 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
506 -- Nam is an N_String_Literal node containing the external name set by
507 -- an Import or Export pragma (or extended Import or Export pragma).
508 -- This procedure checks for possible duplications if this is the export
509 -- case, and if found, issues an appropriate error message.
511 procedure Check_First_Subtype (Arg : Node_Id);
512 -- Checks that Arg, whose expression is an entity name, references a
515 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
516 -- Checks that the given argument has an identifier, and if so, requires
517 -- it to match the given identifier name. If there is no identifier, or
518 -- a non-matching identifier, then an error message is given and
519 -- Pragma_Exit is raised.
521 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
522 -- Checks that the given argument has an identifier, and if so, requires
523 -- it to match one of the given identifier names. If there is no
524 -- identifier, or a non-matching identifier, then an error message is
525 -- given and Pragma_Exit is raised.
527 procedure Check_In_Main_Program;
528 -- Common checks for pragmas that appear within a main program
529 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
531 procedure Check_Interrupt_Or_Attach_Handler;
532 -- Common processing for first argument of pragma Interrupt_Handler or
533 -- pragma Attach_Handler.
535 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
536 -- Check that pragma appears in a declarative part, or in a package
537 -- specification, i.e. that it does not occur in a statement sequence
540 procedure Check_No_Identifier (Arg : Node_Id);
541 -- Checks that the given argument does not have an identifier. If
542 -- an identifier is present, then an error message is issued, and
543 -- Pragma_Exit is raised.
545 procedure Check_No_Identifiers;
546 -- Checks that none of the arguments to the pragma has an identifier.
547 -- If any argument has an identifier, then an error message is issued,
548 -- and Pragma_Exit is raised.
550 procedure Check_No_Link_Name;
551 -- Checks that no link name is specified
553 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
554 -- Checks if the given argument has an identifier, and if so, requires
555 -- it to match the given identifier name. If there is a non-matching
556 -- identifier, then an error message is given and Pragma_Exit is raised.
558 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
559 -- Checks if the given argument has an identifier, and if so, requires
560 -- it to match the given identifier name. If there is a non-matching
561 -- identifier, then an error message is given and Pragma_Exit is raised.
562 -- In this version of the procedure, the identifier name is given as
563 -- a string with lower case letters.
565 procedure Check_Precondition_Postcondition (In_Body : out Boolean);
566 -- Called to process a precondition or postcondition pragma. There are
569 -- The pragma appears after a subprogram spec
571 -- If the corresponding check is not enabled, the pragma is analyzed
572 -- but otherwise ignored and control returns with In_Body set False.
574 -- If the check is enabled, then the first step is to analyze the
575 -- pragma, but this is skipped if the subprogram spec appears within
576 -- a package specification (because this is the case where we delay
577 -- analysis till the end of the spec). Then (whether or not it was
578 -- analyzed), the pragma is chained to the subprogram in question
579 -- (using Spec_PPC_List and Next_Pragma) and control returns to the
580 -- caller with In_Body set False.
582 -- The pragma appears at the start of subprogram body declarations
584 -- In this case an immediate return to the caller is made with
585 -- In_Body set True, and the pragma is NOT analyzed.
587 -- In all other cases, an error message for bad placement is given
589 procedure Check_Static_Constraint (Constr : Node_Id);
590 -- Constr is a constraint from an N_Subtype_Indication node from a
591 -- component constraint in an Unchecked_Union type. This routine checks
592 -- that the constraint is static as required by the restrictions for
595 procedure Check_Test_Case;
596 -- Called to process a test-case pragma. The treatment is similar to the
597 -- one for pre- and postcondition in Check_Precondition_Postcondition,
598 -- except the placement rules for the test-case pragma are stricter.
599 -- This pragma may only occur after a subprogram spec declared directly
600 -- in a package spec unit. In this case, the pragma is chained to the
601 -- subprogram in question (using Spec_TC_List and Next_Pragma) and
602 -- analysis of the pragma is delayed till the end of the spec. In
603 -- all other cases, an error message for bad placement is given.
605 procedure Check_Valid_Configuration_Pragma;
606 -- Legality checks for placement of a configuration pragma
608 procedure Check_Valid_Library_Unit_Pragma;
609 -- Legality checks for library unit pragmas. A special case arises for
610 -- pragmas in generic instances that come from copies of the original
611 -- library unit pragmas in the generic templates. In the case of other
612 -- than library level instantiations these can appear in contexts which
613 -- would normally be invalid (they only apply to the original template
614 -- and to library level instantiations), and they are simply ignored,
615 -- which is implemented by rewriting them as null statements.
617 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
618 -- Check an Unchecked_Union variant for lack of nested variants and
619 -- presence of at least one component. UU_Typ is the related Unchecked_
622 procedure Error_Pragma (Msg : String);
623 pragma No_Return (Error_Pragma);
624 -- Outputs error message for current pragma. The message contains a %
625 -- that will be replaced with the pragma name, and the flag is placed
626 -- on the pragma itself. Pragma_Exit is then raised.
628 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
629 pragma No_Return (Error_Pragma_Arg);
630 -- Outputs error message for current pragma. The message may contain
631 -- a % that will be replaced with the pragma name. The parameter Arg
632 -- may either be a pragma argument association, in which case the flag
633 -- is placed on the expression of this association, or an expression,
634 -- in which case the flag is placed directly on the expression. The
635 -- message is placed using Error_Msg_N, so the message may also contain
636 -- an & insertion character which will reference the given Arg value.
637 -- After placing the message, Pragma_Exit is raised.
639 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
640 pragma No_Return (Error_Pragma_Arg);
641 -- Similar to above form of Error_Pragma_Arg except that two messages
642 -- are provided, the second is a continuation comment starting with \.
644 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
645 pragma No_Return (Error_Pragma_Arg_Ident);
646 -- Outputs error message for current pragma. The message may contain
647 -- a % that will be replaced with the pragma name. The parameter Arg
648 -- must be a pragma argument association with a non-empty identifier
649 -- (i.e. its Chars field must be set), and the error message is placed
650 -- on the identifier. The message is placed using Error_Msg_N so
651 -- the message may also contain an & insertion character which will
652 -- reference the identifier. After placing the message, Pragma_Exit
655 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
656 pragma No_Return (Error_Pragma_Ref);
657 -- Outputs error message for current pragma. The message may contain
658 -- a % that will be replaced with the pragma name. The parameter Ref
659 -- must be an entity whose name can be referenced by & and sloc by #.
660 -- After placing the message, Pragma_Exit is raised.
662 function Find_Lib_Unit_Name return Entity_Id;
663 -- Used for a library unit pragma to find the entity to which the
664 -- library unit pragma applies, returns the entity found.
666 procedure Find_Program_Unit_Name (Id : Node_Id);
667 -- If the pragma is a compilation unit pragma, the id must denote the
668 -- compilation unit in the same compilation, and the pragma must appear
669 -- in the list of preceding or trailing pragmas. If it is a program
670 -- unit pragma that is not a compilation unit pragma, then the
671 -- identifier must be visible.
673 function Find_Unique_Parameterless_Procedure
675 Arg : Node_Id) return Entity_Id;
676 -- Used for a procedure pragma to find the unique parameterless
677 -- procedure identified by Name, returns it if it exists, otherwise
678 -- errors out and uses Arg as the pragma argument for the message.
680 procedure Fix_Error (Msg : in out String);
681 -- This is called prior to issuing an error message. Msg is a string
682 -- which typically contains the substring pragma. If the current pragma
683 -- comes from an aspect, each such "pragma" substring is replaced with
684 -- the characters "aspect", and if Error_Msg_Name_1 is Name_Precondition
685 -- (resp Name_Postcondition) it is changed to Name_Pre (resp Name_Post).
687 procedure Gather_Associations
689 Args : out Args_List);
690 -- This procedure is used to gather the arguments for a pragma that
691 -- permits arbitrary ordering of parameters using the normal rules
692 -- for named and positional parameters. The Names argument is a list
693 -- of Name_Id values that corresponds to the allowed pragma argument
694 -- association identifiers in order. The result returned in Args is
695 -- a list of corresponding expressions that are the pragma arguments.
696 -- Note that this is a list of expressions, not of pragma argument
697 -- associations (Gather_Associations has completely checked all the
698 -- optional identifiers when it returns). An entry in Args is Empty
699 -- on return if the corresponding argument is not present.
701 procedure GNAT_Pragma;
702 -- Called for all GNAT defined pragmas to check the relevant restriction
703 -- (No_Implementation_Pragmas).
705 function Is_Before_First_Decl
706 (Pragma_Node : Node_Id;
707 Decls : List_Id) return Boolean;
708 -- Return True if Pragma_Node is before the first declarative item in
709 -- Decls where Decls is the list of declarative items.
711 function Is_Configuration_Pragma return Boolean;
712 -- Determines if the placement of the current pragma is appropriate
713 -- for a configuration pragma.
715 function Is_In_Context_Clause return Boolean;
716 -- Returns True if pragma appears within the context clause of a unit,
717 -- and False for any other placement (does not generate any messages).
719 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
720 -- Analyzes the argument, and determines if it is a static string
721 -- expression, returns True if so, False if non-static or not String.
723 procedure Pragma_Misplaced;
724 pragma No_Return (Pragma_Misplaced);
725 -- Issue fatal error message for misplaced pragma
727 procedure Process_Atomic_Shared_Volatile;
728 -- Common processing for pragmas Atomic, Shared, Volatile. Note that
729 -- Shared is an obsolete Ada 83 pragma, treated as being identical
730 -- in effect to pragma Atomic.
732 procedure Process_Compile_Time_Warning_Or_Error;
733 -- Common processing for Compile_Time_Error and Compile_Time_Warning
735 procedure Process_Convention
736 (C : out Convention_Id;
737 Ent : out Entity_Id);
738 -- Common processing for Convention, Interface, Import and Export.
739 -- Checks first two arguments of pragma, and sets the appropriate
740 -- convention value in the specified entity or entities. On return
741 -- C is the convention, Ent is the referenced entity.
743 procedure Process_Extended_Import_Export_Exception_Pragma
744 (Arg_Internal : Node_Id;
745 Arg_External : Node_Id;
748 -- Common processing for the pragmas Import/Export_Exception. The three
749 -- arguments correspond to the three named parameters of the pragma. An
750 -- argument is empty if the corresponding parameter is not present in
753 procedure Process_Extended_Import_Export_Object_Pragma
754 (Arg_Internal : Node_Id;
755 Arg_External : Node_Id;
757 -- Common processing for the pragmas Import/Export_Object. The three
758 -- arguments correspond to the three named parameters of the pragmas. An
759 -- argument is empty if the corresponding parameter is not present in
762 procedure Process_Extended_Import_Export_Internal_Arg
763 (Arg_Internal : Node_Id := Empty);
764 -- Common processing for all extended Import and Export pragmas. The
765 -- argument is the pragma parameter for the Internal argument. If
766 -- Arg_Internal is empty or inappropriate, an error message is posted.
767 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
768 -- set to identify the referenced entity.
770 procedure Process_Extended_Import_Export_Subprogram_Pragma
771 (Arg_Internal : Node_Id;
772 Arg_External : Node_Id;
773 Arg_Parameter_Types : Node_Id;
774 Arg_Result_Type : Node_Id := Empty;
775 Arg_Mechanism : Node_Id;
776 Arg_Result_Mechanism : Node_Id := Empty;
777 Arg_First_Optional_Parameter : Node_Id := Empty);
778 -- Common processing for all extended Import and Export pragmas applying
779 -- to subprograms. The caller omits any arguments that do not apply to
780 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
781 -- only in the Import_Function and Export_Function cases). The argument
782 -- names correspond to the allowed pragma association identifiers.
784 procedure Process_Generic_List;
785 -- Common processing for Share_Generic and Inline_Generic
787 procedure Process_Import_Or_Interface;
788 -- Common processing for Import of Interface
790 procedure Process_Import_Predefined_Type;
791 -- Processing for completing a type with pragma Import. This is used
792 -- to declare types that match predefined C types, especially for cases
793 -- without corresponding Ada predefined type.
795 procedure Process_Inline (Active : Boolean);
796 -- Common processing for Inline and Inline_Always. The parameter
797 -- indicates if the inline pragma is active, i.e. if it should actually
798 -- cause inlining to occur.
800 procedure Process_Interface_Name
801 (Subprogram_Def : Entity_Id;
804 -- Given the last two arguments of pragma Import, pragma Export, or
805 -- pragma Interface_Name, performs validity checks and sets the
806 -- Interface_Name field of the given subprogram entity to the
807 -- appropriate external or link name, depending on the arguments given.
808 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
809 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
810 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
811 -- nor Link_Arg is present, the interface name is set to the default
812 -- from the subprogram name.
814 procedure Process_Interrupt_Or_Attach_Handler;
815 -- Common processing for Interrupt and Attach_Handler pragmas
817 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
818 -- Common processing for Restrictions and Restriction_Warnings pragmas.
819 -- Warn is True for Restriction_Warnings, or for Restrictions if the
820 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
821 -- is not set in the Restrictions case.
823 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
824 -- Common processing for Suppress and Unsuppress. The boolean parameter
825 -- Suppress_Case is True for the Suppress case, and False for the
828 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
829 -- This procedure sets the Is_Exported flag for the given entity,
830 -- checking that the entity was not previously imported. Arg is
831 -- the argument that specified the entity. A check is also made
832 -- for exporting inappropriate entities.
834 procedure Set_Extended_Import_Export_External_Name
835 (Internal_Ent : Entity_Id;
836 Arg_External : Node_Id);
837 -- Common processing for all extended import export pragmas. The first
838 -- argument, Internal_Ent, is the internal entity, which has already
839 -- been checked for validity by the caller. Arg_External is from the
840 -- Import or Export pragma, and may be null if no External parameter
841 -- was present. If Arg_External is present and is a non-null string
842 -- (a null string is treated as the default), then the Interface_Name
843 -- field of Internal_Ent is set appropriately.
845 procedure Set_Imported (E : Entity_Id);
846 -- This procedure sets the Is_Imported flag for the given entity,
847 -- checking that it is not previously exported or imported.
849 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
850 -- Mech is a parameter passing mechanism (see Import_Function syntax
851 -- for MECHANISM_NAME). This routine checks that the mechanism argument
852 -- has the right form, and if not issues an error message. If the
853 -- argument has the right form then the Mechanism field of Ent is
854 -- set appropriately.
856 procedure Set_Ravenscar_Profile (N : Node_Id);
857 -- Activate the set of configuration pragmas and restrictions that make
858 -- up the Ravenscar Profile. N is the corresponding pragma node, which
859 -- is used for error messages on any constructs that violate the
862 ---------------------
863 -- Ada_2005_Pragma --
864 ---------------------
866 procedure Ada_2005_Pragma is
868 if Ada_Version <= Ada_95 then
869 Check_Restriction (No_Implementation_Pragmas, N);
873 ---------------------
874 -- Ada_2012_Pragma --
875 ---------------------
877 procedure Ada_2012_Pragma is
879 if Ada_Version <= Ada_2005 then
880 Check_Restriction (No_Implementation_Pragmas, N);
884 --------------------------
885 -- Check_Ada_83_Warning --
886 --------------------------
888 procedure Check_Ada_83_Warning is
890 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
891 Error_Msg_N ("(Ada 83) pragma& is non-standard?", N);
893 end Check_Ada_83_Warning;
895 ---------------------
896 -- Check_Arg_Count --
897 ---------------------
899 procedure Check_Arg_Count (Required : Nat) is
901 if Arg_Count /= Required then
902 Error_Pragma ("wrong number of arguments for pragma%");
906 --------------------------------
907 -- Check_Arg_Is_External_Name --
908 --------------------------------
910 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
911 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
914 if Nkind (Argx) = N_Identifier then
918 Analyze_And_Resolve (Argx, Standard_String);
920 if Is_OK_Static_Expression (Argx) then
923 elsif Etype (Argx) = Any_Type then
926 -- An interesting special case, if we have a string literal and
927 -- we are in Ada 83 mode, then we allow it even though it will
928 -- not be flagged as static. This allows expected Ada 83 mode
929 -- use of external names which are string literals, even though
930 -- technically these are not static in Ada 83.
932 elsif Ada_Version = Ada_83
933 and then Nkind (Argx) = N_String_Literal
937 -- Static expression that raises Constraint_Error. This has
938 -- already been flagged, so just exit from pragma processing.
940 elsif Is_Static_Expression (Argx) then
943 -- Here we have a real error (non-static expression)
946 Error_Msg_Name_1 := Pname;
950 "argument for pragma% must be a identifier or "
951 & "static string expression!";
954 Flag_Non_Static_Expr (Msg, Argx);
959 end Check_Arg_Is_External_Name;
961 -----------------------------
962 -- Check_Arg_Is_Identifier --
963 -----------------------------
965 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
966 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
968 if Nkind (Argx) /= N_Identifier then
970 ("argument for pragma% must be identifier", Argx);
972 end Check_Arg_Is_Identifier;
974 ----------------------------------
975 -- Check_Arg_Is_Integer_Literal --
976 ----------------------------------
978 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
979 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
981 if Nkind (Argx) /= N_Integer_Literal then
983 ("argument for pragma% must be integer literal", Argx);
985 end Check_Arg_Is_Integer_Literal;
987 -------------------------------------------
988 -- Check_Arg_Is_Library_Level_Local_Name --
989 -------------------------------------------
993 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
994 -- | library_unit_NAME
996 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
998 Check_Arg_Is_Local_Name (Arg);
1000 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
1001 and then Comes_From_Source (N)
1004 ("argument for pragma% must be library level entity", Arg);
1006 end Check_Arg_Is_Library_Level_Local_Name;
1008 -----------------------------
1009 -- Check_Arg_Is_Local_Name --
1010 -----------------------------
1014 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
1015 -- | library_unit_NAME
1017 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
1018 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1023 if Nkind (Argx) not in N_Direct_Name
1024 and then (Nkind (Argx) /= N_Attribute_Reference
1025 or else Present (Expressions (Argx))
1026 or else Nkind (Prefix (Argx)) /= N_Identifier)
1027 and then (not Is_Entity_Name (Argx)
1028 or else not Is_Compilation_Unit (Entity (Argx)))
1030 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
1033 -- No further check required if not an entity name
1035 if not Is_Entity_Name (Argx) then
1041 Ent : constant Entity_Id := Entity (Argx);
1042 Scop : constant Entity_Id := Scope (Ent);
1044 -- Case of a pragma applied to a compilation unit: pragma must
1045 -- occur immediately after the program unit in the compilation.
1047 if Is_Compilation_Unit (Ent) then
1049 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
1051 -- Case of pragma placed immediately after spec
1053 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
1056 -- Case of pragma placed immediately after body
1058 elsif Nkind (Decl) = N_Subprogram_Declaration
1059 and then Present (Corresponding_Body (Decl))
1063 (Parent (Unit_Declaration_Node
1064 (Corresponding_Body (Decl))));
1066 -- All other cases are illegal
1073 -- Special restricted placement rule from 10.2.1(11.8/2)
1075 elsif Is_Generic_Formal (Ent)
1076 and then Prag_Id = Pragma_Preelaborable_Initialization
1078 OK := List_Containing (N) =
1079 Generic_Formal_Declarations
1080 (Unit_Declaration_Node (Scop));
1082 -- Default case, just check that the pragma occurs in the scope
1083 -- of the entity denoted by the name.
1086 OK := Current_Scope = Scop;
1091 ("pragma% argument must be in same declarative part", Arg);
1095 end Check_Arg_Is_Local_Name;
1097 ---------------------------------
1098 -- Check_Arg_Is_Locking_Policy --
1099 ---------------------------------
1101 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
1102 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1105 Check_Arg_Is_Identifier (Argx);
1107 if not Is_Locking_Policy_Name (Chars (Argx)) then
1108 Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
1110 end Check_Arg_Is_Locking_Policy;
1112 -------------------------
1113 -- Check_Arg_Is_One_Of --
1114 -------------------------
1116 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
1117 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1120 Check_Arg_Is_Identifier (Argx);
1122 if Chars (Argx) /= N1 and then Chars (Argx) /= N2 then
1123 Error_Msg_Name_2 := N1;
1124 Error_Msg_Name_3 := N2;
1125 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
1127 end Check_Arg_Is_One_Of;
1129 procedure Check_Arg_Is_One_Of
1131 N1, N2, N3 : Name_Id)
1133 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1136 Check_Arg_Is_Identifier (Argx);
1138 if Chars (Argx) /= N1
1139 and then Chars (Argx) /= N2
1140 and then Chars (Argx) /= N3
1142 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
1144 end Check_Arg_Is_One_Of;
1146 procedure Check_Arg_Is_One_Of
1148 N1, N2, N3, N4, N5 : Name_Id)
1150 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1153 Check_Arg_Is_Identifier (Argx);
1155 if Chars (Argx) /= N1
1156 and then Chars (Argx) /= N2
1157 and then Chars (Argx) /= N3
1158 and then Chars (Argx) /= N4
1159 and then Chars (Argx) /= N5
1161 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
1163 end Check_Arg_Is_One_Of;
1164 ---------------------------------
1165 -- Check_Arg_Is_Queuing_Policy --
1166 ---------------------------------
1168 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
1169 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1172 Check_Arg_Is_Identifier (Argx);
1174 if not Is_Queuing_Policy_Name (Chars (Argx)) then
1175 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
1177 end Check_Arg_Is_Queuing_Policy;
1179 ------------------------------------
1180 -- Check_Arg_Is_Static_Expression --
1181 ------------------------------------
1183 procedure Check_Arg_Is_Static_Expression
1185 Typ : Entity_Id := Empty)
1187 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1190 if Present (Typ) then
1191 Analyze_And_Resolve (Argx, Typ);
1193 Analyze_And_Resolve (Argx);
1196 if Is_OK_Static_Expression (Argx) then
1199 elsif Etype (Argx) = Any_Type then
1202 -- An interesting special case, if we have a string literal and we
1203 -- are in Ada 83 mode, then we allow it even though it will not be
1204 -- flagged as static. This allows the use of Ada 95 pragmas like
1205 -- Import in Ada 83 mode. They will of course be flagged with
1206 -- warnings as usual, but will not cause errors.
1208 elsif Ada_Version = Ada_83
1209 and then Nkind (Argx) = N_String_Literal
1213 -- Static expression that raises Constraint_Error. This has already
1214 -- been flagged, so just exit from pragma processing.
1216 elsif Is_Static_Expression (Argx) then
1219 -- Finally, we have a real error
1222 Error_Msg_Name_1 := Pname;
1226 "argument for pragma% must be a static expression!";
1229 Flag_Non_Static_Expr (Msg, Argx);
1234 end Check_Arg_Is_Static_Expression;
1236 ------------------------------------------
1237 -- Check_Arg_Is_Task_Dispatching_Policy --
1238 ------------------------------------------
1240 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
1241 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1244 Check_Arg_Is_Identifier (Argx);
1246 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
1248 ("& is not a valid task dispatching policy name", Argx);
1250 end Check_Arg_Is_Task_Dispatching_Policy;
1252 ---------------------
1253 -- Check_Arg_Order --
1254 ---------------------
1256 procedure Check_Arg_Order (Names : Name_List) is
1259 Highest_So_Far : Natural := 0;
1260 -- Highest index in Names seen do far
1264 for J in 1 .. Arg_Count loop
1265 if Chars (Arg) /= No_Name then
1266 for K in Names'Range loop
1267 if Chars (Arg) = Names (K) then
1268 if K < Highest_So_Far then
1269 Error_Msg_Name_1 := Pname;
1271 ("parameters out of order for pragma%", Arg);
1272 Error_Msg_Name_1 := Names (K);
1273 Error_Msg_Name_2 := Names (Highest_So_Far);
1274 Error_Msg_N ("\% must appear before %", Arg);
1278 Highest_So_Far := K;
1286 end Check_Arg_Order;
1288 --------------------------------
1289 -- Check_At_Least_N_Arguments --
1290 --------------------------------
1292 procedure Check_At_Least_N_Arguments (N : Nat) is
1294 if Arg_Count < N then
1295 Error_Pragma ("too few arguments for pragma%");
1297 end Check_At_Least_N_Arguments;
1299 -------------------------------
1300 -- Check_At_Most_N_Arguments --
1301 -------------------------------
1303 procedure Check_At_Most_N_Arguments (N : Nat) is
1306 if Arg_Count > N then
1308 for J in 1 .. N loop
1310 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
1313 end Check_At_Most_N_Arguments;
1315 ---------------------
1316 -- Check_Component --
1317 ---------------------
1319 procedure Check_Component
1322 In_Variant_Part : Boolean := False)
1324 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
1325 Sindic : constant Node_Id :=
1326 Subtype_Indication (Component_Definition (Comp));
1327 Typ : constant Entity_Id := Etype (Comp_Id);
1329 function Inside_Generic_Body (Id : Entity_Id) return Boolean;
1330 -- Determine whether entity Id appears inside a generic body.
1331 -- Shouldn't this be in a more general place ???
1333 -------------------------
1334 -- Inside_Generic_Body --
1335 -------------------------
1337 function Inside_Generic_Body (Id : Entity_Id) return Boolean is
1342 while Present (S) and then S /= Standard_Standard loop
1343 if Ekind (S) = E_Generic_Package
1344 and then In_Package_Body (S)
1353 end Inside_Generic_Body;
1355 -- Start of processing for Check_Component
1358 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
1359 -- object constraint, then the component type shall be an Unchecked_
1362 if Nkind (Sindic) = N_Subtype_Indication
1363 and then Has_Per_Object_Constraint (Comp_Id)
1364 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
1367 ("component subtype subject to per-object constraint " &
1368 "must be an Unchecked_Union", Comp);
1370 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
1371 -- the body of a generic unit, or within the body of any of its
1372 -- descendant library units, no part of the type of a component
1373 -- declared in a variant_part of the unchecked union type shall be of
1374 -- a formal private type or formal private extension declared within
1375 -- the formal part of the generic unit.
1377 elsif Ada_Version >= Ada_2012
1378 and then Inside_Generic_Body (UU_Typ)
1379 and then In_Variant_Part
1380 and then Is_Private_Type (Typ)
1381 and then Is_Generic_Type (Typ)
1384 ("component of Unchecked_Union cannot be of generic type", Comp);
1386 elsif Needs_Finalization (Typ) then
1388 ("component of Unchecked_Union cannot be controlled", Comp);
1390 elsif Has_Task (Typ) then
1392 ("component of Unchecked_Union cannot have tasks", Comp);
1394 end Check_Component;
1396 ----------------------------
1397 -- Check_Duplicate_Pragma --
1398 ----------------------------
1400 procedure Check_Duplicate_Pragma (E : Entity_Id) is
1404 -- Nothing to do if this pragma comes from an aspect specification,
1405 -- since we could not be duplicating a pragma, and we dealt with the
1406 -- case of duplicated aspects in Analyze_Aspect_Specifications.
1408 if From_Aspect_Specification (N) then
1412 -- Otherwise current pragma may duplicate previous pragma or a
1413 -- previously given aspect specification for the same pragma.
1415 P := Get_Rep_Item_For_Entity (E, Pragma_Name (N));
1418 Error_Msg_Name_1 := Pragma_Name (N);
1419 Error_Msg_Sloc := Sloc (P);
1421 if Nkind (P) = N_Aspect_Specification
1422 or else From_Aspect_Specification (P)
1424 Error_Msg_NE ("aspect% for & previously given#", N, E);
1426 Error_Msg_NE ("pragma% for & duplicates pragma#", N, E);
1431 end Check_Duplicate_Pragma;
1433 ----------------------------------
1434 -- Check_Duplicated_Export_Name --
1435 ----------------------------------
1437 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
1438 String_Val : constant String_Id := Strval (Nam);
1441 -- We are only interested in the export case, and in the case of
1442 -- generics, it is the instance, not the template, that is the
1443 -- problem (the template will generate a warning in any case).
1445 if not Inside_A_Generic
1446 and then (Prag_Id = Pragma_Export
1448 Prag_Id = Pragma_Export_Procedure
1450 Prag_Id = Pragma_Export_Valued_Procedure
1452 Prag_Id = Pragma_Export_Function)
1454 for J in Externals.First .. Externals.Last loop
1455 if String_Equal (String_Val, Strval (Externals.Table (J))) then
1456 Error_Msg_Sloc := Sloc (Externals.Table (J));
1457 Error_Msg_N ("external name duplicates name given#", Nam);
1462 Externals.Append (Nam);
1464 end Check_Duplicated_Export_Name;
1466 -------------------------
1467 -- Check_First_Subtype --
1468 -------------------------
1470 procedure Check_First_Subtype (Arg : Node_Id) is
1471 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1472 Ent : constant Entity_Id := Entity (Argx);
1475 if Is_First_Subtype (Ent) then
1478 elsif Is_Type (Ent) then
1480 ("pragma% cannot apply to subtype", Argx);
1482 elsif Is_Object (Ent) then
1484 ("pragma% cannot apply to object, requires a type", Argx);
1488 ("pragma% cannot apply to&, requires a type", Argx);
1490 end Check_First_Subtype;
1492 ----------------------
1493 -- Check_Identifier --
1494 ----------------------
1496 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
1499 and then Nkind (Arg) = N_Pragma_Argument_Association
1501 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
1502 Error_Msg_Name_1 := Pname;
1503 Error_Msg_Name_2 := Id;
1504 Error_Msg_N ("pragma% argument expects identifier%", Arg);
1508 end Check_Identifier;
1510 --------------------------------
1511 -- Check_Identifier_Is_One_Of --
1512 --------------------------------
1514 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
1517 and then Nkind (Arg) = N_Pragma_Argument_Association
1519 if Chars (Arg) = No_Name then
1520 Error_Msg_Name_1 := Pname;
1521 Error_Msg_N ("pragma% argument expects an identifier", Arg);
1524 elsif Chars (Arg) /= N1
1525 and then Chars (Arg) /= N2
1527 Error_Msg_Name_1 := Pname;
1528 Error_Msg_N ("invalid identifier for pragma% argument", Arg);
1532 end Check_Identifier_Is_One_Of;
1534 ---------------------------
1535 -- Check_In_Main_Program --
1536 ---------------------------
1538 procedure Check_In_Main_Program is
1539 P : constant Node_Id := Parent (N);
1542 -- Must be at in subprogram body
1544 if Nkind (P) /= N_Subprogram_Body then
1545 Error_Pragma ("% pragma allowed only in subprogram");
1547 -- Otherwise warn if obviously not main program
1549 elsif Present (Parameter_Specifications (Specification (P)))
1550 or else not Is_Compilation_Unit (Defining_Entity (P))
1552 Error_Msg_Name_1 := Pname;
1554 ("?pragma% is only effective in main program", N);
1556 end Check_In_Main_Program;
1558 ---------------------------------------
1559 -- Check_Interrupt_Or_Attach_Handler --
1560 ---------------------------------------
1562 procedure Check_Interrupt_Or_Attach_Handler is
1563 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
1564 Handler_Proc, Proc_Scope : Entity_Id;
1569 if Prag_Id = Pragma_Interrupt_Handler then
1570 Check_Restriction (No_Dynamic_Attachment, N);
1573 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
1574 Proc_Scope := Scope (Handler_Proc);
1576 -- On AAMP only, a pragma Interrupt_Handler is supported for
1577 -- nonprotected parameterless procedures.
1579 if not AAMP_On_Target
1580 or else Prag_Id = Pragma_Attach_Handler
1582 if Ekind (Proc_Scope) /= E_Protected_Type then
1584 ("argument of pragma% must be protected procedure", Arg1);
1587 if Parent (N) /= Protected_Definition (Parent (Proc_Scope)) then
1588 Error_Pragma ("pragma% must be in protected definition");
1592 if not Is_Library_Level_Entity (Proc_Scope)
1593 or else (AAMP_On_Target
1594 and then not Is_Library_Level_Entity (Handler_Proc))
1597 ("argument for pragma% must be library level entity", Arg1);
1600 -- AI05-0033: A pragma cannot appear within a generic body, because
1601 -- instance can be in a nested scope. The check that protected type
1602 -- is itself a library-level declaration is done elsewhere.
1604 -- Note: we omit this check in Codepeer mode to properly handle code
1605 -- prior to AI-0033 (pragmas don't matter to codepeer in any case).
1607 if Inside_A_Generic then
1608 if Ekind (Scope (Current_Scope)) = E_Generic_Package
1609 and then In_Package_Body (Scope (Current_Scope))
1610 and then not CodePeer_Mode
1612 Error_Pragma ("pragma% cannot be used inside a generic");
1615 end Check_Interrupt_Or_Attach_Handler;
1617 -------------------------------------------
1618 -- Check_Is_In_Decl_Part_Or_Package_Spec --
1619 -------------------------------------------
1621 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
1630 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
1633 elsif Nkind_In (P, N_Package_Specification,
1638 -- Note: the following tests seem a little peculiar, because
1639 -- they test for bodies, but if we were in the statement part
1640 -- of the body, we would already have hit the handled statement
1641 -- sequence, so the only way we get here is by being in the
1642 -- declarative part of the body.
1644 elsif Nkind_In (P, N_Subprogram_Body,
1655 Error_Pragma ("pragma% is not in declarative part or package spec");
1656 end Check_Is_In_Decl_Part_Or_Package_Spec;
1658 -------------------------
1659 -- Check_No_Identifier --
1660 -------------------------
1662 procedure Check_No_Identifier (Arg : Node_Id) is
1664 if Nkind (Arg) = N_Pragma_Argument_Association
1665 and then Chars (Arg) /= No_Name
1667 Error_Pragma_Arg_Ident
1668 ("pragma% does not permit identifier& here", Arg);
1670 end Check_No_Identifier;
1672 --------------------------
1673 -- Check_No_Identifiers --
1674 --------------------------
1676 procedure Check_No_Identifiers is
1679 if Arg_Count > 0 then
1681 while Present (Arg_Node) loop
1682 Check_No_Identifier (Arg_Node);
1686 end Check_No_Identifiers;
1688 ------------------------
1689 -- Check_No_Link_Name --
1690 ------------------------
1692 procedure Check_No_Link_Name is
1695 and then Chars (Arg3) = Name_Link_Name
1700 if Present (Arg4) then
1702 ("Link_Name argument not allowed for Import Intrinsic", Arg4);
1704 end Check_No_Link_Name;
1706 -------------------------------
1707 -- Check_Optional_Identifier --
1708 -------------------------------
1710 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
1713 and then Nkind (Arg) = N_Pragma_Argument_Association
1714 and then Chars (Arg) /= No_Name
1716 if Chars (Arg) /= Id then
1717 Error_Msg_Name_1 := Pname;
1718 Error_Msg_Name_2 := Id;
1719 Error_Msg_N ("pragma% argument expects identifier%", Arg);
1723 end Check_Optional_Identifier;
1725 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
1727 Name_Buffer (1 .. Id'Length) := Id;
1728 Name_Len := Id'Length;
1729 Check_Optional_Identifier (Arg, Name_Find);
1730 end Check_Optional_Identifier;
1732 --------------------------------------
1733 -- Check_Precondition_Postcondition --
1734 --------------------------------------
1736 procedure Check_Precondition_Postcondition (In_Body : out Boolean) is
1740 procedure Chain_PPC (PO : Node_Id);
1741 -- If PO is an entry or a [generic] subprogram declaration node, then
1742 -- the precondition/postcondition applies to this subprogram and the
1743 -- processing for the pragma is completed. Otherwise the pragma is
1750 procedure Chain_PPC (PO : Node_Id) is
1755 if Nkind (PO) = N_Abstract_Subprogram_Declaration then
1756 if not From_Aspect_Specification (N) then
1758 ("pragma% cannot be applied to abstract subprogram");
1760 elsif Class_Present (N) then
1765 ("aspect % requires ''Class for abstract subprogram");
1768 -- AI05-0230: The same restriction applies to null procedures. For
1769 -- compatibility with earlier uses of the Ada pragma, apply this
1770 -- rule only to aspect specifications.
1772 -- The above discrpency needs documentation. Robert is dubious
1773 -- about whether it is a good idea ???
1775 elsif Nkind (PO) = N_Subprogram_Declaration
1776 and then Nkind (Specification (PO)) = N_Procedure_Specification
1777 and then Null_Present (Specification (PO))
1778 and then From_Aspect_Specification (N)
1779 and then not Class_Present (N)
1782 ("aspect % requires ''Class for null procedure");
1784 elsif not Nkind_In (PO, N_Subprogram_Declaration,
1785 N_Generic_Subprogram_Declaration,
1786 N_Entry_Declaration)
1791 -- Here if we have [generic] subprogram or entry declaration
1793 if Nkind (PO) = N_Entry_Declaration then
1794 S := Defining_Entity (PO);
1796 S := Defining_Unit_Name (Specification (PO));
1799 -- Make sure we do not have the case of a precondition pragma when
1800 -- the Pre'Class aspect is present.
1802 -- We do this by looking at pragmas already chained to the entity
1803 -- since the aspect derived pragma will be put on this list first.
1805 if Pragma_Name (N) = Name_Precondition then
1806 if not From_Aspect_Specification (N) then
1807 P := Spec_PPC_List (Contract (S));
1808 while Present (P) loop
1809 if Pragma_Name (P) = Name_Precondition
1810 and then From_Aspect_Specification (P)
1811 and then Class_Present (P)
1813 Error_Msg_Sloc := Sloc (P);
1815 ("pragma% not allowed, `Pre''Class` aspect given#");
1818 P := Next_Pragma (P);
1823 -- Similarly check for Pre with inherited Pre'Class. Note that
1824 -- we cover the aspect case as well here.
1826 if Pragma_Name (N) = Name_Precondition
1827 and then not Class_Present (N)
1830 Inherited : constant Subprogram_List :=
1831 Inherited_Subprograms (S);
1835 for J in Inherited'Range loop
1836 P := Spec_PPC_List (Contract (Inherited (J)));
1837 while Present (P) loop
1838 if Pragma_Name (P) = Name_Precondition
1839 and then Class_Present (P)
1841 Error_Msg_Sloc := Sloc (P);
1843 ("pragma% not allowed, `Pre''Class` "
1844 & "aspect inherited from#");
1847 P := Next_Pragma (P);
1853 -- Note: we do not analyze the pragma at this point. Instead we
1854 -- delay this analysis until the end of the declarative part in
1855 -- which the pragma appears. This implements the required delay
1856 -- in this analysis, allowing forward references. The analysis
1857 -- happens at the end of Analyze_Declarations.
1859 -- Chain spec PPC pragma to list for subprogram
1861 Set_Next_Pragma (N, Spec_PPC_List (Contract (S)));
1862 Set_Spec_PPC_List (Contract (S), N);
1864 -- Return indicating spec case
1870 -- Start of processing for Check_Precondition_Postcondition
1873 if not Is_List_Member (N) then
1877 -- Preanalyze message argument if present. Visibility in this
1878 -- argument is established at the point of pragma occurrence.
1880 if Arg_Count = 2 then
1881 Check_Optional_Identifier (Arg2, Name_Message);
1882 Preanalyze_Spec_Expression
1883 (Get_Pragma_Arg (Arg2), Standard_String);
1886 -- Record if pragma is disabled
1888 if Check_Enabled (Pname) then
1889 Set_SCO_Pragma_Enabled (Loc);
1892 -- If we are within an inlined body, the legality of the pragma
1893 -- has been checked already.
1895 if In_Inlined_Body then
1900 -- Search prior declarations
1903 while Present (Prev (P)) loop
1906 -- If the previous node is a generic subprogram, do not go to to
1907 -- the original node, which is the unanalyzed tree: we need to
1908 -- attach the pre/postconditions to the analyzed version at this
1909 -- point. They get propagated to the original tree when analyzing
1910 -- the corresponding body.
1912 if Nkind (P) not in N_Generic_Declaration then
1913 PO := Original_Node (P);
1918 -- Skip past prior pragma
1920 if Nkind (PO) = N_Pragma then
1923 -- Skip stuff not coming from source
1925 elsif not Comes_From_Source (PO) then
1927 -- The condition may apply to a subprogram instantiation
1929 if Nkind (PO) = N_Subprogram_Declaration
1930 and then Present (Generic_Parent (Specification (PO)))
1935 elsif Nkind (PO) = N_Subprogram_Declaration
1936 and then In_Instance
1941 -- For all other cases of non source code, do nothing
1947 -- Only remaining possibility is subprogram declaration
1955 -- If we fall through loop, pragma is at start of list, so see if it
1956 -- is at the start of declarations of a subprogram body.
1958 if Nkind (Parent (N)) = N_Subprogram_Body
1959 and then List_Containing (N) = Declarations (Parent (N))
1961 if Operating_Mode /= Generate_Code
1962 or else Inside_A_Generic
1964 -- Analyze pragma expression for correctness and for ASIS use
1966 Preanalyze_Spec_Expression
1967 (Get_Pragma_Arg (Arg1), Standard_Boolean);
1973 -- See if it is in the pragmas after a library level subprogram
1975 elsif Nkind (Parent (N)) = N_Compilation_Unit_Aux then
1977 -- In formal verification mode, analyze pragma expression for
1978 -- correctness, as it is not expanded later.
1981 Analyze_PPC_In_Decl_Part
1982 (N, Defining_Entity (Unit (Parent (Parent (N)))));
1985 Chain_PPC (Unit (Parent (Parent (N))));
1989 -- If we fall through, pragma was misplaced
1992 end Check_Precondition_Postcondition;
1994 -----------------------------
1995 -- Check_Static_Constraint --
1996 -----------------------------
1998 -- Note: for convenience in writing this procedure, in addition to
1999 -- the officially (i.e. by spec) allowed argument which is always a
2000 -- constraint, it also allows ranges and discriminant associations.
2001 -- Above is not clear ???
2003 procedure Check_Static_Constraint (Constr : Node_Id) is
2005 procedure Require_Static (E : Node_Id);
2006 -- Require given expression to be static expression
2008 --------------------
2009 -- Require_Static --
2010 --------------------
2012 procedure Require_Static (E : Node_Id) is
2014 if not Is_OK_Static_Expression (E) then
2015 Flag_Non_Static_Expr
2016 ("non-static constraint not allowed in Unchecked_Union!", E);
2021 -- Start of processing for Check_Static_Constraint
2024 case Nkind (Constr) is
2025 when N_Discriminant_Association =>
2026 Require_Static (Expression (Constr));
2029 Require_Static (Low_Bound (Constr));
2030 Require_Static (High_Bound (Constr));
2032 when N_Attribute_Reference =>
2033 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
2034 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
2036 when N_Range_Constraint =>
2037 Check_Static_Constraint (Range_Expression (Constr));
2039 when N_Index_Or_Discriminant_Constraint =>
2043 IDC := First (Constraints (Constr));
2044 while Present (IDC) loop
2045 Check_Static_Constraint (IDC);
2053 end Check_Static_Constraint;
2055 ---------------------
2056 -- Check_Test_Case --
2057 ---------------------
2059 procedure Check_Test_Case is
2063 procedure Chain_TC (PO : Node_Id);
2064 -- If PO is a [generic] subprogram declaration node, then the
2065 -- test-case applies to this subprogram and the processing for the
2066 -- pragma is completed. Otherwise the pragma is misplaced.
2072 procedure Chain_TC (PO : Node_Id) is
2076 if Nkind (PO) = N_Abstract_Subprogram_Declaration then
2077 if From_Aspect_Specification (N) then
2079 ("aspect% cannot be applied to abstract subprogram");
2082 ("pragma% cannot be applied to abstract subprogram");
2085 elsif Nkind (PO) = N_Entry_Declaration then
2086 if From_Aspect_Specification (N) then
2087 Error_Pragma ("aspect% cannot be applied to entry");
2089 Error_Pragma ("pragma% cannot be applied to entry");
2092 elsif not Nkind_In (PO, N_Subprogram_Declaration,
2093 N_Generic_Subprogram_Declaration)
2098 -- Here if we have [generic] subprogram declaration
2100 S := Defining_Unit_Name (Specification (PO));
2102 -- Note: we do not analyze the pragma at this point. Instead we
2103 -- delay this analysis until the end of the declarative part in
2104 -- which the pragma appears. This implements the required delay
2105 -- in this analysis, allowing forward references. The analysis
2106 -- happens at the end of Analyze_Declarations.
2108 -- There should not be another test case with the same name
2109 -- associated to this subprogram.
2112 Name : constant String_Id := Get_Name_From_Test_Case_Pragma (N);
2116 TC := Spec_TC_List (Contract (S));
2117 while Present (TC) loop
2120 (Name, Get_Name_From_Test_Case_Pragma (TC))
2122 Error_Msg_Sloc := Sloc (TC);
2124 if From_Aspect_Specification (N) then
2125 Error_Pragma ("name for aspect% is already used#");
2127 Error_Pragma ("name for pragma% is already used#");
2131 TC := Next_Pragma (TC);
2135 -- Chain spec TC pragma to list for subprogram
2137 Set_Next_Pragma (N, Spec_TC_List (Contract (S)));
2138 Set_Spec_TC_List (Contract (S), N);
2141 -- Start of processing for Check_Test_Case
2144 if not Is_List_Member (N) then
2148 -- Test cases should only appear in package spec unit
2150 if Get_Source_Unit (N) = No_Unit
2151 or else not Nkind_In (Sinfo.Unit (Cunit (Get_Source_Unit (N))),
2152 N_Package_Declaration,
2153 N_Generic_Package_Declaration)
2158 -- Search prior declarations
2161 while Present (Prev (P)) loop
2164 -- If the previous node is a generic subprogram, do not go to to
2165 -- the original node, which is the unanalyzed tree: we need to
2166 -- attach the test-case to the analyzed version at this point.
2167 -- They get propagated to the original tree when analyzing the
2168 -- corresponding body.
2170 if Nkind (P) not in N_Generic_Declaration then
2171 PO := Original_Node (P);
2176 -- Skip past prior pragma
2178 if Nkind (PO) = N_Pragma then
2181 -- Skip stuff not coming from source
2183 elsif not Comes_From_Source (PO) then
2186 -- Only remaining possibility is subprogram declaration. First
2187 -- check that it is declared directly in a package declaration.
2188 -- This may be either the package declaration for the current unit
2189 -- being defined or a local package declaration.
2191 elsif not Present (Parent (Parent (PO)))
2192 or else not Present (Parent (Parent (Parent (PO))))
2193 or else not Nkind_In (Parent (Parent (PO)),
2194 N_Package_Declaration,
2195 N_Generic_Package_Declaration)
2205 -- If we fall through, pragma was misplaced
2208 end Check_Test_Case;
2210 --------------------------------------
2211 -- Check_Valid_Configuration_Pragma --
2212 --------------------------------------
2214 -- A configuration pragma must appear in the context clause of a
2215 -- compilation unit, and only other pragmas may precede it. Note that
2216 -- the test also allows use in a configuration pragma file.
2218 procedure Check_Valid_Configuration_Pragma is
2220 if not Is_Configuration_Pragma then
2221 Error_Pragma ("incorrect placement for configuration pragma%");
2223 end Check_Valid_Configuration_Pragma;
2225 -------------------------------------
2226 -- Check_Valid_Library_Unit_Pragma --
2227 -------------------------------------
2229 procedure Check_Valid_Library_Unit_Pragma is
2231 Parent_Node : Node_Id;
2232 Unit_Name : Entity_Id;
2233 Unit_Kind : Node_Kind;
2234 Unit_Node : Node_Id;
2235 Sindex : Source_File_Index;
2238 if not Is_List_Member (N) then
2242 Plist := List_Containing (N);
2243 Parent_Node := Parent (Plist);
2245 if Parent_Node = Empty then
2248 -- Case of pragma appearing after a compilation unit. In this case
2249 -- it must have an argument with the corresponding name and must
2250 -- be part of the following pragmas of its parent.
2252 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
2253 if Plist /= Pragmas_After (Parent_Node) then
2256 elsif Arg_Count = 0 then
2258 ("argument required if outside compilation unit");
2261 Check_No_Identifiers;
2262 Check_Arg_Count (1);
2263 Unit_Node := Unit (Parent (Parent_Node));
2264 Unit_Kind := Nkind (Unit_Node);
2266 Analyze (Get_Pragma_Arg (Arg1));
2268 if Unit_Kind = N_Generic_Subprogram_Declaration
2269 or else Unit_Kind = N_Subprogram_Declaration
2271 Unit_Name := Defining_Entity (Unit_Node);
2273 elsif Unit_Kind in N_Generic_Instantiation then
2274 Unit_Name := Defining_Entity (Unit_Node);
2277 Unit_Name := Cunit_Entity (Current_Sem_Unit);
2280 if Chars (Unit_Name) /=
2281 Chars (Entity (Get_Pragma_Arg (Arg1)))
2284 ("pragma% argument is not current unit name", Arg1);
2287 if Ekind (Unit_Name) = E_Package
2288 and then Present (Renamed_Entity (Unit_Name))
2290 Error_Pragma ("pragma% not allowed for renamed package");
2294 -- Pragma appears other than after a compilation unit
2297 -- Here we check for the generic instantiation case and also
2298 -- for the case of processing a generic formal package. We
2299 -- detect these cases by noting that the Sloc on the node
2300 -- does not belong to the current compilation unit.
2302 Sindex := Source_Index (Current_Sem_Unit);
2304 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
2305 Rewrite (N, Make_Null_Statement (Loc));
2308 -- If before first declaration, the pragma applies to the
2309 -- enclosing unit, and the name if present must be this name.
2311 elsif Is_Before_First_Decl (N, Plist) then
2312 Unit_Node := Unit_Declaration_Node (Current_Scope);
2313 Unit_Kind := Nkind (Unit_Node);
2315 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
2318 elsif Unit_Kind = N_Subprogram_Body
2319 and then not Acts_As_Spec (Unit_Node)
2323 elsif Nkind (Parent_Node) = N_Package_Body then
2326 elsif Nkind (Parent_Node) = N_Package_Specification
2327 and then Plist = Private_Declarations (Parent_Node)
2331 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
2332 or else Nkind (Parent_Node) =
2333 N_Generic_Subprogram_Declaration)
2334 and then Plist = Generic_Formal_Declarations (Parent_Node)
2338 elsif Arg_Count > 0 then
2339 Analyze (Get_Pragma_Arg (Arg1));
2341 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
2343 ("name in pragma% must be enclosing unit", Arg1);
2346 -- It is legal to have no argument in this context
2352 -- Error if not before first declaration. This is because a
2353 -- library unit pragma argument must be the name of a library
2354 -- unit (RM 10.1.5(7)), but the only names permitted in this
2355 -- context are (RM 10.1.5(6)) names of subprogram declarations,
2356 -- generic subprogram declarations or generic instantiations.
2360 ("pragma% misplaced, must be before first declaration");
2364 end Check_Valid_Library_Unit_Pragma;
2370 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
2371 Clist : constant Node_Id := Component_List (Variant);
2375 if not Is_Non_Empty_List (Component_Items (Clist)) then
2377 ("Unchecked_Union may not have empty component list",
2382 Comp := First (Component_Items (Clist));
2383 while Present (Comp) loop
2384 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
2393 procedure Error_Pragma (Msg : String) is
2394 MsgF : String := Msg;
2396 Error_Msg_Name_1 := Pname;
2398 Error_Msg_N (MsgF, N);
2402 ----------------------
2403 -- Error_Pragma_Arg --
2404 ----------------------
2406 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
2407 MsgF : String := Msg;
2409 Error_Msg_Name_1 := Pname;
2411 Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
2413 end Error_Pragma_Arg;
2415 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
2416 MsgF : String := Msg1;
2418 Error_Msg_Name_1 := Pname;
2420 Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
2421 Error_Pragma_Arg (Msg2, Arg);
2422 end Error_Pragma_Arg;
2424 ----------------------------
2425 -- Error_Pragma_Arg_Ident --
2426 ----------------------------
2428 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
2429 MsgF : String := Msg;
2431 Error_Msg_Name_1 := Pname;
2433 Error_Msg_N (MsgF, Arg);
2435 end Error_Pragma_Arg_Ident;
2437 ----------------------
2438 -- Error_Pragma_Ref --
2439 ----------------------
2441 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
2442 MsgF : String := Msg;
2444 Error_Msg_Name_1 := Pname;
2446 Error_Msg_Sloc := Sloc (Ref);
2447 Error_Msg_NE (MsgF, N, Ref);
2449 end Error_Pragma_Ref;
2451 ------------------------
2452 -- Find_Lib_Unit_Name --
2453 ------------------------
2455 function Find_Lib_Unit_Name return Entity_Id is
2457 -- Return inner compilation unit entity, for case of nested
2458 -- categorization pragmas. This happens in generic unit.
2460 if Nkind (Parent (N)) = N_Package_Specification
2461 and then Defining_Entity (Parent (N)) /= Current_Scope
2463 return Defining_Entity (Parent (N));
2465 return Current_Scope;
2467 end Find_Lib_Unit_Name;
2469 ----------------------------
2470 -- Find_Program_Unit_Name --
2471 ----------------------------
2473 procedure Find_Program_Unit_Name (Id : Node_Id) is
2474 Unit_Name : Entity_Id;
2475 Unit_Kind : Node_Kind;
2476 P : constant Node_Id := Parent (N);
2479 if Nkind (P) = N_Compilation_Unit then
2480 Unit_Kind := Nkind (Unit (P));
2482 if Unit_Kind = N_Subprogram_Declaration
2483 or else Unit_Kind = N_Package_Declaration
2484 or else Unit_Kind in N_Generic_Declaration
2486 Unit_Name := Defining_Entity (Unit (P));
2488 if Chars (Id) = Chars (Unit_Name) then
2489 Set_Entity (Id, Unit_Name);
2490 Set_Etype (Id, Etype (Unit_Name));
2492 Set_Etype (Id, Any_Type);
2494 ("cannot find program unit referenced by pragma%");
2498 Set_Etype (Id, Any_Type);
2499 Error_Pragma ("pragma% inapplicable to this unit");
2505 end Find_Program_Unit_Name;
2507 -----------------------------------------
2508 -- Find_Unique_Parameterless_Procedure --
2509 -----------------------------------------
2511 function Find_Unique_Parameterless_Procedure
2513 Arg : Node_Id) return Entity_Id
2515 Proc : Entity_Id := Empty;
2518 -- The body of this procedure needs some comments ???
2520 if not Is_Entity_Name (Name) then
2522 ("argument of pragma% must be entity name", Arg);
2524 elsif not Is_Overloaded (Name) then
2525 Proc := Entity (Name);
2527 if Ekind (Proc) /= E_Procedure
2528 or else Present (First_Formal (Proc))
2531 ("argument of pragma% must be parameterless procedure", Arg);
2536 Found : Boolean := False;
2538 Index : Interp_Index;
2541 Get_First_Interp (Name, Index, It);
2542 while Present (It.Nam) loop
2545 if Ekind (Proc) = E_Procedure
2546 and then No (First_Formal (Proc))
2550 Set_Entity (Name, Proc);
2551 Set_Is_Overloaded (Name, False);
2554 ("ambiguous handler name for pragma% ", Arg);
2558 Get_Next_Interp (Index, It);
2563 ("argument of pragma% must be parameterless procedure",
2566 Proc := Entity (Name);
2572 end Find_Unique_Parameterless_Procedure;
2578 procedure Fix_Error (Msg : in out String) is
2580 if From_Aspect_Specification (N) then
2581 for J in Msg'First .. Msg'Last - 5 loop
2582 if Msg (J .. J + 5) = "pragma" then
2583 Msg (J .. J + 5) := "aspect";
2587 if Error_Msg_Name_1 = Name_Precondition then
2588 Error_Msg_Name_1 := Name_Pre;
2589 elsif Error_Msg_Name_1 = Name_Postcondition then
2590 Error_Msg_Name_1 := Name_Post;
2595 -------------------------
2596 -- Gather_Associations --
2597 -------------------------
2599 procedure Gather_Associations
2601 Args : out Args_List)
2606 -- Initialize all parameters to Empty
2608 for J in Args'Range loop
2612 -- That's all we have to do if there are no argument associations
2614 if No (Pragma_Argument_Associations (N)) then
2618 -- Otherwise first deal with any positional parameters present
2620 Arg := First (Pragma_Argument_Associations (N));
2621 for Index in Args'Range loop
2622 exit when No (Arg) or else Chars (Arg) /= No_Name;
2623 Args (Index) := Get_Pragma_Arg (Arg);
2627 -- Positional parameters all processed, if any left, then we
2628 -- have too many positional parameters.
2630 if Present (Arg) and then Chars (Arg) = No_Name then
2632 ("too many positional associations for pragma%", Arg);
2635 -- Process named parameters if any are present
2637 while Present (Arg) loop
2638 if Chars (Arg) = No_Name then
2640 ("positional association cannot follow named association",
2644 for Index in Names'Range loop
2645 if Names (Index) = Chars (Arg) then
2646 if Present (Args (Index)) then
2648 ("duplicate argument association for pragma%", Arg);
2650 Args (Index) := Get_Pragma_Arg (Arg);
2655 if Index = Names'Last then
2656 Error_Msg_Name_1 := Pname;
2657 Error_Msg_N ("pragma% does not allow & argument", Arg);
2659 -- Check for possible misspelling
2661 for Index1 in Names'Range loop
2662 if Is_Bad_Spelling_Of
2663 (Chars (Arg), Names (Index1))
2665 Error_Msg_Name_1 := Names (Index1);
2666 Error_Msg_N -- CODEFIX
2667 ("\possible misspelling of%", Arg);
2679 end Gather_Associations;
2685 procedure GNAT_Pragma is
2687 Check_Restriction (No_Implementation_Pragmas, N);
2690 --------------------------
2691 -- Is_Before_First_Decl --
2692 --------------------------
2694 function Is_Before_First_Decl
2695 (Pragma_Node : Node_Id;
2696 Decls : List_Id) return Boolean
2698 Item : Node_Id := First (Decls);
2701 -- Only other pragmas can come before this pragma
2704 if No (Item) or else Nkind (Item) /= N_Pragma then
2707 elsif Item = Pragma_Node then
2713 end Is_Before_First_Decl;
2715 -----------------------------
2716 -- Is_Configuration_Pragma --
2717 -----------------------------
2719 -- A configuration pragma must appear in the context clause of a
2720 -- compilation unit, and only other pragmas may precede it. Note that
2721 -- the test below also permits use in a configuration pragma file.
2723 function Is_Configuration_Pragma return Boolean is
2724 Lis : constant List_Id := List_Containing (N);
2725 Par : constant Node_Id := Parent (N);
2729 -- If no parent, then we are in the configuration pragma file,
2730 -- so the placement is definitely appropriate.
2735 -- Otherwise we must be in the context clause of a compilation unit
2736 -- and the only thing allowed before us in the context list is more
2737 -- configuration pragmas.
2739 elsif Nkind (Par) = N_Compilation_Unit
2740 and then Context_Items (Par) = Lis
2747 elsif Nkind (Prg) /= N_Pragma then
2757 end Is_Configuration_Pragma;
2759 --------------------------
2760 -- Is_In_Context_Clause --
2761 --------------------------
2763 function Is_In_Context_Clause return Boolean is
2765 Parent_Node : Node_Id;
2768 if not Is_List_Member (N) then
2772 Plist := List_Containing (N);
2773 Parent_Node := Parent (Plist);
2775 if Parent_Node = Empty
2776 or else Nkind (Parent_Node) /= N_Compilation_Unit
2777 or else Context_Items (Parent_Node) /= Plist
2784 end Is_In_Context_Clause;
2786 ---------------------------------
2787 -- Is_Static_String_Expression --
2788 ---------------------------------
2790 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
2791 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
2794 Analyze_And_Resolve (Argx);
2795 return Is_OK_Static_Expression (Argx)
2796 and then Nkind (Argx) = N_String_Literal;
2797 end Is_Static_String_Expression;
2799 ----------------------
2800 -- Pragma_Misplaced --
2801 ----------------------
2803 procedure Pragma_Misplaced is
2805 Error_Pragma ("incorrect placement of pragma%");
2806 end Pragma_Misplaced;
2808 ------------------------------------
2809 -- Process Atomic_Shared_Volatile --
2810 ------------------------------------
2812 procedure Process_Atomic_Shared_Volatile is
2819 procedure Set_Atomic (E : Entity_Id);
2820 -- Set given type as atomic, and if no explicit alignment was given,
2821 -- set alignment to unknown, since back end knows what the alignment
2822 -- requirements are for atomic arrays. Note: this step is necessary
2823 -- for derived types.
2829 procedure Set_Atomic (E : Entity_Id) is
2833 if not Has_Alignment_Clause (E) then
2834 Set_Alignment (E, Uint_0);
2838 -- Start of processing for Process_Atomic_Shared_Volatile
2841 Check_Ada_83_Warning;
2842 Check_No_Identifiers;
2843 Check_Arg_Count (1);
2844 Check_Arg_Is_Local_Name (Arg1);
2845 E_Id := Get_Pragma_Arg (Arg1);
2847 if Etype (E_Id) = Any_Type then
2852 D := Declaration_Node (E);
2855 -- Check duplicate before we chain ourselves!
2857 Check_Duplicate_Pragma (E);
2859 -- Now check appropriateness of the entity
2862 if Rep_Item_Too_Early (E, N)
2864 Rep_Item_Too_Late (E, N)
2868 Check_First_Subtype (Arg1);
2871 if Prag_Id /= Pragma_Volatile then
2873 Set_Atomic (Underlying_Type (E));
2874 Set_Atomic (Base_Type (E));
2877 -- Attribute belongs on the base type. If the view of the type is
2878 -- currently private, it also belongs on the underlying type.
2880 Set_Is_Volatile (Base_Type (E));
2881 Set_Is_Volatile (Underlying_Type (E));
2883 Set_Treat_As_Volatile (E);
2884 Set_Treat_As_Volatile (Underlying_Type (E));
2886 elsif K = N_Object_Declaration
2887 or else (K = N_Component_Declaration
2888 and then Original_Record_Component (E) = E)
2890 if Rep_Item_Too_Late (E, N) then
2894 if Prag_Id /= Pragma_Volatile then
2897 -- If the object declaration has an explicit initialization, a
2898 -- temporary may have to be created to hold the expression, to
2899 -- ensure that access to the object remain atomic.
2901 if Nkind (Parent (E)) = N_Object_Declaration
2902 and then Present (Expression (Parent (E)))
2904 Set_Has_Delayed_Freeze (E);
2907 -- An interesting improvement here. If an object of type X is
2908 -- declared atomic, and the type X is not atomic, that's a
2909 -- pity, since it may not have appropriate alignment etc. We
2910 -- can rescue this in the special case where the object and
2911 -- type are in the same unit by just setting the type as
2912 -- atomic, so that the back end will process it as atomic.
2914 Utyp := Underlying_Type (Etype (E));
2917 and then Sloc (E) > No_Location
2918 and then Sloc (Utyp) > No_Location
2920 Get_Source_File_Index (Sloc (E)) =
2921 Get_Source_File_Index (Sloc (Underlying_Type (Etype (E))))
2923 Set_Is_Atomic (Underlying_Type (Etype (E)));
2927 Set_Is_Volatile (E);
2928 Set_Treat_As_Volatile (E);
2932 ("inappropriate entity for pragma%", Arg1);
2934 end Process_Atomic_Shared_Volatile;
2936 -------------------------------------------
2937 -- Process_Compile_Time_Warning_Or_Error --
2938 -------------------------------------------
2940 procedure Process_Compile_Time_Warning_Or_Error is
2941 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
2944 Check_Arg_Count (2);
2945 Check_No_Identifiers;
2946 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
2947 Analyze_And_Resolve (Arg1x, Standard_Boolean);
2949 if Compile_Time_Known_Value (Arg1x) then
2950 if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
2952 Str : constant String_Id :=
2953 Strval (Get_Pragma_Arg (Arg2));
2954 Len : constant Int := String_Length (Str);
2959 Cent : constant Entity_Id :=
2960 Cunit_Entity (Current_Sem_Unit);
2962 Force : constant Boolean :=
2963 Prag_Id = Pragma_Compile_Time_Warning
2965 Is_Spec_Name (Unit_Name (Current_Sem_Unit))
2966 and then (Ekind (Cent) /= E_Package
2967 or else not In_Private_Part (Cent));
2968 -- Set True if this is the warning case, and we are in the
2969 -- visible part of a package spec, or in a subprogram spec,
2970 -- in which case we want to force the client to see the
2971 -- warning, even though it is not in the main unit.
2974 -- Loop through segments of message separated by line feeds.
2975 -- We output these segments as separate messages with
2976 -- continuation marks for all but the first.
2981 Error_Msg_Strlen := 0;
2983 -- Loop to copy characters from argument to error message
2987 exit when Ptr > Len;
2988 CC := Get_String_Char (Str, Ptr);
2991 -- Ignore wide chars ??? else store character
2993 if In_Character_Range (CC) then
2994 C := Get_Character (CC);
2995 exit when C = ASCII.LF;
2996 Error_Msg_Strlen := Error_Msg_Strlen + 1;
2997 Error_Msg_String (Error_Msg_Strlen) := C;
3001 -- Here with one line ready to go
3003 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
3005 -- If this is a warning in a spec, then we want clients
3006 -- to see the warning, so mark the message with the
3007 -- special sequence !! to force the warning. In the case
3008 -- of a package spec, we do not force this if we are in
3009 -- the private part of the spec.
3012 if Cont = False then
3013 Error_Msg_N ("<~!!", Arg1);
3016 Error_Msg_N ("\<~!!", Arg1);
3019 -- Error, rather than warning, or in a body, so we do not
3020 -- need to force visibility for client (error will be
3021 -- output in any case, and this is the situation in which
3022 -- we do not want a client to get a warning, since the
3023 -- warning is in the body or the spec private part).
3026 if Cont = False then
3027 Error_Msg_N ("<~", Arg1);
3030 Error_Msg_N ("\<~", Arg1);
3034 exit when Ptr > Len;
3039 end Process_Compile_Time_Warning_Or_Error;
3041 ------------------------
3042 -- Process_Convention --
3043 ------------------------
3045 procedure Process_Convention
3046 (C : out Convention_Id;
3047 Ent : out Entity_Id)
3053 Comp_Unit : Unit_Number_Type;
3055 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
3056 -- Called if we have more than one Export/Import/Convention pragma.
3057 -- This is generally illegal, but we have a special case of allowing
3058 -- Import and Interface to coexist if they specify the convention in
3059 -- a consistent manner. We are allowed to do this, since Interface is
3060 -- an implementation defined pragma, and we choose to do it since we
3061 -- know Rational allows this combination. S is the entity id of the
3062 -- subprogram in question. This procedure also sets the special flag
3063 -- Import_Interface_Present in both pragmas in the case where we do
3064 -- have matching Import and Interface pragmas.
3066 procedure Set_Convention_From_Pragma (E : Entity_Id);
3067 -- Set convention in entity E, and also flag that the entity has a
3068 -- convention pragma. If entity is for a private or incomplete type,
3069 -- also set convention and flag on underlying type. This procedure
3070 -- also deals with the special case of C_Pass_By_Copy convention.
3072 -------------------------------
3073 -- Diagnose_Multiple_Pragmas --
3074 -------------------------------
3076 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
3077 Pdec : constant Node_Id := Declaration_Node (S);
3081 function Same_Convention (Decl : Node_Id) return Boolean;
3082 -- Decl is a pragma node. This function returns True if this
3083 -- pragma has a first argument that is an identifier with a
3084 -- Chars field corresponding to the Convention_Id C.
3086 function Same_Name (Decl : Node_Id) return Boolean;
3087 -- Decl is a pragma node. This function returns True if this
3088 -- pragma has a second argument that is an identifier with a
3089 -- Chars field that matches the Chars of the current subprogram.
3091 ---------------------
3092 -- Same_Convention --
3093 ---------------------
3095 function Same_Convention (Decl : Node_Id) return Boolean is
3096 Arg1 : constant Node_Id :=
3097 First (Pragma_Argument_Associations (Decl));
3100 if Present (Arg1) then
3102 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
3104 if Nkind (Arg) = N_Identifier
3105 and then Is_Convention_Name (Chars (Arg))
3106 and then Get_Convention_Id (Chars (Arg)) = C
3114 end Same_Convention;
3120 function Same_Name (Decl : Node_Id) return Boolean is
3121 Arg1 : constant Node_Id :=
3122 First (Pragma_Argument_Associations (Decl));
3130 Arg2 := Next (Arg1);
3137 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
3139 if Nkind (Arg) = N_Identifier
3140 and then Chars (Arg) = Chars (S)
3149 -- Start of processing for Diagnose_Multiple_Pragmas
3154 -- Definitely give message if we have Convention/Export here
3156 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
3159 -- If we have an Import or Export, scan back from pragma to
3160 -- find any previous pragma applying to the same procedure.
3161 -- The scan will be terminated by the start of the list, or
3162 -- hitting the subprogram declaration. This won't allow one
3163 -- pragma to appear in the public part and one in the private
3164 -- part, but that seems very unlikely in practice.
3168 while Present (Decl) and then Decl /= Pdec loop
3170 -- Look for pragma with same name as us
3172 if Nkind (Decl) = N_Pragma
3173 and then Same_Name (Decl)
3175 -- Give error if same as our pragma or Export/Convention
3177 if Pragma_Name (Decl) = Name_Export
3179 Pragma_Name (Decl) = Name_Convention
3181 Pragma_Name (Decl) = Pragma_Name (N)
3185 -- Case of Import/Interface or the other way round
3187 elsif Pragma_Name (Decl) = Name_Interface
3189 Pragma_Name (Decl) = Name_Import
3191 -- Here we know that we have Import and Interface. It
3192 -- doesn't matter which way round they are. See if
3193 -- they specify the same convention. If so, all OK,
3194 -- and set special flags to stop other messages
3196 if Same_Convention (Decl) then
3197 Set_Import_Interface_Present (N);
3198 Set_Import_Interface_Present (Decl);
3201 -- If different conventions, special message
3204 Error_Msg_Sloc := Sloc (Decl);
3206 ("convention differs from that given#", Arg1);
3216 -- Give message if needed if we fall through those tests
3220 ("at most one Convention/Export/Import pragma is allowed",
3223 end Diagnose_Multiple_Pragmas;
3225 --------------------------------
3226 -- Set_Convention_From_Pragma --
3227 --------------------------------
3229 procedure Set_Convention_From_Pragma (E : Entity_Id) is
3231 -- Ada 2005 (AI-430): Check invalid attempt to change convention
3232 -- for an overridden dispatching operation. Technically this is
3233 -- an amendment and should only be done in Ada 2005 mode. However,
3234 -- this is clearly a mistake, since the problem that is addressed
3235 -- by this AI is that there is a clear gap in the RM!
3237 if Is_Dispatching_Operation (E)
3238 and then Present (Overridden_Operation (E))
3239 and then C /= Convention (Overridden_Operation (E))
3242 ("cannot change convention for " &
3243 "overridden dispatching operation",
3247 -- Set the convention
3249 Set_Convention (E, C);
3250 Set_Has_Convention_Pragma (E);
3252 if Is_Incomplete_Or_Private_Type (E)
3253 and then Present (Underlying_Type (E))
3255 Set_Convention (Underlying_Type (E), C);
3256 Set_Has_Convention_Pragma (Underlying_Type (E), True);
3259 -- A class-wide type should inherit the convention of the specific
3260 -- root type (although this isn't specified clearly by the RM).
3262 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
3263 Set_Convention (Class_Wide_Type (E), C);
3266 -- If the entity is a record type, then check for special case of
3267 -- C_Pass_By_Copy, which is treated the same as C except that the
3268 -- special record flag is set. This convention is only permitted
3269 -- on record types (see AI95-00131).
3271 if Cname = Name_C_Pass_By_Copy then
3272 if Is_Record_Type (E) then
3273 Set_C_Pass_By_Copy (Base_Type (E));
3274 elsif Is_Incomplete_Or_Private_Type (E)
3275 and then Is_Record_Type (Underlying_Type (E))
3277 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
3280 ("C_Pass_By_Copy convention allowed only for record type",
3285 -- If the entity is a derived boolean type, check for the special
3286 -- case of convention C, C++, or Fortran, where we consider any
3287 -- nonzero value to represent true.
3289 if Is_Discrete_Type (E)
3290 and then Root_Type (Etype (E)) = Standard_Boolean
3296 C = Convention_Fortran)
3298 Set_Nonzero_Is_True (Base_Type (E));
3300 end Set_Convention_From_Pragma;
3302 -- Start of processing for Process_Convention
3305 Check_At_Least_N_Arguments (2);
3306 Check_Optional_Identifier (Arg1, Name_Convention);
3307 Check_Arg_Is_Identifier (Arg1);
3308 Cname := Chars (Get_Pragma_Arg (Arg1));
3310 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
3311 -- tested again below to set the critical flag).
3313 if Cname = Name_C_Pass_By_Copy then
3316 -- Otherwise we must have something in the standard convention list
3318 elsif Is_Convention_Name (Cname) then
3319 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
3321 -- In DEC VMS, it seems that there is an undocumented feature that
3322 -- any unrecognized convention is treated as the default, which for
3323 -- us is convention C. It does not seem so terrible to do this
3324 -- unconditionally, silently in the VMS case, and with a warning
3325 -- in the non-VMS case.
3328 if Warn_On_Export_Import and not OpenVMS_On_Target then
3330 ("?unrecognized convention name, C assumed",
3331 Get_Pragma_Arg (Arg1));
3337 Check_Optional_Identifier (Arg2, Name_Entity);
3338 Check_Arg_Is_Local_Name (Arg2);
3340 Id := Get_Pragma_Arg (Arg2);
3343 if not Is_Entity_Name (Id) then
3344 Error_Pragma_Arg ("entity name required", Arg2);
3349 -- Set entity to return
3353 -- Ada_Pass_By_Copy special checking
3355 if C = Convention_Ada_Pass_By_Copy then
3356 if not Is_First_Subtype (E) then
3358 ("convention `Ada_Pass_By_Copy` only "
3359 & "allowed for types", Arg2);
3362 if Is_By_Reference_Type (E) then
3364 ("convention `Ada_Pass_By_Copy` not allowed for "
3365 & "by-reference type", Arg1);
3369 -- Ada_Pass_By_Reference special checking
3371 if C = Convention_Ada_Pass_By_Reference then
3372 if not Is_First_Subtype (E) then
3374 ("convention `Ada_Pass_By_Reference` only "
3375 & "allowed for types", Arg2);
3378 if Is_By_Copy_Type (E) then
3380 ("convention `Ada_Pass_By_Reference` not allowed for "
3381 & "by-copy type", Arg1);
3385 -- Go to renamed subprogram if present, since convention applies to
3386 -- the actual renamed entity, not to the renaming entity. If the
3387 -- subprogram is inherited, go to parent subprogram.
3389 if Is_Subprogram (E)
3390 and then Present (Alias (E))
3392 if Nkind (Parent (Declaration_Node (E))) =
3393 N_Subprogram_Renaming_Declaration
3395 if Scope (E) /= Scope (Alias (E)) then
3397 ("cannot apply pragma% to non-local entity&#", E);
3402 elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
3403 N_Private_Extension_Declaration)
3404 and then Scope (E) = Scope (Alias (E))
3408 -- Return the parent subprogram the entity was inherited from
3414 -- Check that we are not applying this to a specless body
3416 if Is_Subprogram (E)
3417 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
3420 ("pragma% requires separate spec and must come before body");
3423 -- Check that we are not applying this to a named constant
3425 if Ekind_In (E, E_Named_Integer, E_Named_Real) then
3426 Error_Msg_Name_1 := Pname;
3428 ("cannot apply pragma% to named constant!",
3429 Get_Pragma_Arg (Arg2));
3431 ("\supply appropriate type for&!", Arg2);
3434 if Ekind (E) = E_Enumeration_Literal then
3435 Error_Pragma ("enumeration literal not allowed for pragma%");
3438 -- Check for rep item appearing too early or too late
3440 if Etype (E) = Any_Type
3441 or else Rep_Item_Too_Early (E, N)
3445 elsif Present (Underlying_Type (E)) then
3446 E := Underlying_Type (E);
3449 if Rep_Item_Too_Late (E, N) then
3453 if Has_Convention_Pragma (E) then
3454 Diagnose_Multiple_Pragmas (E);
3456 elsif Convention (E) = Convention_Protected
3457 or else Ekind (Scope (E)) = E_Protected_Type
3460 ("a protected operation cannot be given a different convention",
3464 -- For Intrinsic, a subprogram is required
3466 if C = Convention_Intrinsic
3467 and then not Is_Subprogram (E)
3468 and then not Is_Generic_Subprogram (E)
3471 ("second argument of pragma% must be a subprogram", Arg2);
3474 -- For Stdcall, a subprogram, variable or subprogram type is required
3476 if C = Convention_Stdcall
3477 and then not Is_Subprogram (E)
3478 and then not Is_Generic_Subprogram (E)
3479 and then Ekind (E) /= E_Variable
3482 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
3485 ("second argument of pragma% must be subprogram (type)",
3489 if not Is_Subprogram (E)
3490 and then not Is_Generic_Subprogram (E)
3492 Set_Convention_From_Pragma (E);
3495 Check_First_Subtype (Arg2);
3496 Set_Convention_From_Pragma (Base_Type (E));
3498 -- For subprograms, we must set the convention on the
3499 -- internally generated directly designated type as well.
3501 if Ekind (E) = E_Access_Subprogram_Type then
3502 Set_Convention_From_Pragma (Directly_Designated_Type (E));
3506 -- For the subprogram case, set proper convention for all homonyms
3507 -- in same scope and the same declarative part, i.e. the same
3508 -- compilation unit.
3511 Comp_Unit := Get_Source_Unit (E);
3512 Set_Convention_From_Pragma (E);
3514 -- Treat a pragma Import as an implicit body, for GPS use
3516 if Prag_Id = Pragma_Import then
3517 Generate_Reference (E, Id, 'b');
3520 -- Loop through the homonyms of the pragma argument's entity
3525 exit when No (E1) or else Scope (E1) /= Current_Scope;
3527 -- Do not set the pragma on inherited operations or on formal
3530 if Comes_From_Source (E1)
3531 and then Comp_Unit = Get_Source_Unit (E1)
3532 and then not Is_Formal_Subprogram (E1)
3533 and then Nkind (Original_Node (Parent (E1))) /=
3534 N_Full_Type_Declaration
3536 if Present (Alias (E1))
3537 and then Scope (E1) /= Scope (Alias (E1))
3540 ("cannot apply pragma% to non-local entity& declared#",
3544 Set_Convention_From_Pragma (E1);
3546 if Prag_Id = Pragma_Import then
3547 Generate_Reference (E1, Id, 'b');
3551 -- For aspect case, do NOT apply to homonyms
3553 exit when From_Aspect_Specification (N);
3556 end Process_Convention;
3558 -----------------------------------------------------
3559 -- Process_Extended_Import_Export_Exception_Pragma --
3560 -----------------------------------------------------
3562 procedure Process_Extended_Import_Export_Exception_Pragma
3563 (Arg_Internal : Node_Id;
3564 Arg_External : Node_Id;
3572 if not OpenVMS_On_Target then
3574 ("?pragma% ignored (applies only to Open'V'M'S)");
3577 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
3578 Def_Id := Entity (Arg_Internal);
3580 if Ekind (Def_Id) /= E_Exception then
3582 ("pragma% must refer to declared exception", Arg_Internal);
3585 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
3587 if Present (Arg_Form) then
3588 Check_Arg_Is_One_Of (Arg_Form, Name_Ada, Name_VMS);
3591 if Present (Arg_Form)
3592 and then Chars (Arg_Form) = Name_Ada
3596 Set_Is_VMS_Exception (Def_Id);
3597 Set_Exception_Code (Def_Id, No_Uint);
3600 if Present (Arg_Code) then
3601 if not Is_VMS_Exception (Def_Id) then
3603 ("Code option for pragma% not allowed for Ada case",
3607 Check_Arg_Is_Static_Expression (Arg_Code, Any_Integer);
3608 Code_Val := Expr_Value (Arg_Code);
3610 if not UI_Is_In_Int_Range (Code_Val) then
3612 ("Code option for pragma% must be in 32-bit range",
3616 Set_Exception_Code (Def_Id, Code_Val);
3619 end Process_Extended_Import_Export_Exception_Pragma;
3621 -------------------------------------------------
3622 -- Process_Extended_Import_Export_Internal_Arg --
3623 -------------------------------------------------
3625 procedure Process_Extended_Import_Export_Internal_Arg
3626 (Arg_Internal : Node_Id := Empty)
3629 if No (Arg_Internal) then
3630 Error_Pragma ("Internal parameter required for pragma%");
3633 if Nkind (Arg_Internal) = N_Identifier then
3636 elsif Nkind (Arg_Internal) = N_Operator_Symbol
3637 and then (Prag_Id = Pragma_Import_Function
3639 Prag_Id = Pragma_Export_Function)
3645 ("wrong form for Internal parameter for pragma%", Arg_Internal);
3648 Check_Arg_Is_Local_Name (Arg_Internal);
3649 end Process_Extended_Import_Export_Internal_Arg;
3651 --------------------------------------------------
3652 -- Process_Extended_Import_Export_Object_Pragma --
3653 --------------------------------------------------
3655 procedure Process_Extended_Import_Export_Object_Pragma
3656 (Arg_Internal : Node_Id;
3657 Arg_External : Node_Id;
3663 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
3664 Def_Id := Entity (Arg_Internal);
3666 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
3668 ("pragma% must designate an object", Arg_Internal);
3671 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
3673 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
3676 ("previous Common/Psect_Object applies, pragma % not permitted",
3680 if Rep_Item_Too_Late (Def_Id, N) then
3684 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
3686 if Present (Arg_Size) then
3687 Check_Arg_Is_External_Name (Arg_Size);
3690 -- Export_Object case
3692 if Prag_Id = Pragma_Export_Object then
3693 if not Is_Library_Level_Entity (Def_Id) then
3695 ("argument for pragma% must be library level entity",
3699 if Ekind (Current_Scope) = E_Generic_Package then
3700 Error_Pragma ("pragma& cannot appear in a generic unit");
3703 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
3705 ("exported object must have compile time known size",
3709 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
3710 Error_Msg_N ("?duplicate Export_Object pragma", N);
3712 Set_Exported (Def_Id, Arg_Internal);
3715 -- Import_Object case
3718 if Is_Concurrent_Type (Etype (Def_Id)) then
3720 ("cannot use pragma% for task/protected object",
3724 if Ekind (Def_Id) = E_Constant then
3726 ("cannot import a constant", Arg_Internal);
3729 if Warn_On_Export_Import
3730 and then Has_Discriminants (Etype (Def_Id))
3733 ("imported value must be initialized?", Arg_Internal);
3736 if Warn_On_Export_Import
3737 and then Is_Access_Type (Etype (Def_Id))
3740 ("cannot import object of an access type?", Arg_Internal);
3743 if Warn_On_Export_Import
3744 and then Is_Imported (Def_Id)
3747 ("?duplicate Import_Object pragma", N);
3749 -- Check for explicit initialization present. Note that an
3750 -- initialization generated by the code generator, e.g. for an
3751 -- access type, does not count here.
3753 elsif Present (Expression (Parent (Def_Id)))
3756 (Original_Node (Expression (Parent (Def_Id))))
3758 Error_Msg_Sloc := Sloc (Def_Id);
3760 ("imported entities cannot be initialized (RM B.1(24))",
3761 "\no initialization allowed for & declared#", Arg1);
3763 Set_Imported (Def_Id);
3764 Note_Possible_Modification (Arg_Internal, Sure => False);
3767 end Process_Extended_Import_Export_Object_Pragma;
3769 ------------------------------------------------------
3770 -- Process_Extended_Import_Export_Subprogram_Pragma --
3771 ------------------------------------------------------
3773 procedure Process_Extended_Import_Export_Subprogram_Pragma
3774 (Arg_Internal : Node_Id;
3775 Arg_External : Node_Id;
3776 Arg_Parameter_Types : Node_Id;
3777 Arg_Result_Type : Node_Id := Empty;
3778 Arg_Mechanism : Node_Id;
3779 Arg_Result_Mechanism : Node_Id := Empty;
3780 Arg_First_Optional_Parameter : Node_Id := Empty)
3786 Ambiguous : Boolean;
3790 function Same_Base_Type
3792 Formal : Entity_Id) return Boolean;
3793 -- Determines if Ptype references the type of Formal. Note that only
3794 -- the base types need to match according to the spec. Ptype here is
3795 -- the argument from the pragma, which is either a type name, or an
3796 -- access attribute.
3798 --------------------
3799 -- Same_Base_Type --
3800 --------------------
3802 function Same_Base_Type
3804 Formal : Entity_Id) return Boolean
3806 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
3810 -- Case where pragma argument is typ'Access
3812 if Nkind (Ptype) = N_Attribute_Reference
3813 and then Attribute_Name (Ptype) = Name_Access
3815 Pref := Prefix (Ptype);
3818 if not Is_Entity_Name (Pref)
3819 or else Entity (Pref) = Any_Type
3824 -- We have a match if the corresponding argument is of an
3825 -- anonymous access type, and its designated type matches the
3826 -- type of the prefix of the access attribute
3828 return Ekind (Ftyp) = E_Anonymous_Access_Type
3829 and then Base_Type (Entity (Pref)) =
3830 Base_Type (Etype (Designated_Type (Ftyp)));
3832 -- Case where pragma argument is a type name
3837 if not Is_Entity_Name (Ptype)
3838 or else Entity (Ptype) = Any_Type
3843 -- We have a match if the corresponding argument is of the type
3844 -- given in the pragma (comparing base types)
3846 return Base_Type (Entity (Ptype)) = Ftyp;
3850 -- Start of processing for
3851 -- Process_Extended_Import_Export_Subprogram_Pragma
3854 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
3858 -- Loop through homonyms (overloadings) of the entity
3860 Hom_Id := Entity (Arg_Internal);
3861 while Present (Hom_Id) loop
3862 Def_Id := Get_Base_Subprogram (Hom_Id);
3864 -- We need a subprogram in the current scope
3866 if not Is_Subprogram (Def_Id)
3867 or else Scope (Def_Id) /= Current_Scope
3874 -- Pragma cannot apply to subprogram body
3876 if Is_Subprogram (Def_Id)
3877 and then Nkind (Parent (Declaration_Node (Def_Id))) =
3881 ("pragma% requires separate spec"
3882 & " and must come before body");
3885 -- Test result type if given, note that the result type
3886 -- parameter can only be present for the function cases.
3888 if Present (Arg_Result_Type)
3889 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
3893 elsif Etype (Def_Id) /= Standard_Void_Type
3895 (Pname = Name_Export_Procedure
3897 Pname = Name_Import_Procedure)
3901 -- Test parameter types if given. Note that this parameter
3902 -- has not been analyzed (and must not be, since it is
3903 -- semantic nonsense), so we get it as the parser left it.
3905 elsif Present (Arg_Parameter_Types) then
3906 Check_Matching_Types : declare
3911 Formal := First_Formal (Def_Id);
3913 if Nkind (Arg_Parameter_Types) = N_Null then
3914 if Present (Formal) then
3918 -- A list of one type, e.g. (List) is parsed as
3919 -- a parenthesized expression.
3921 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
3922 and then Paren_Count (Arg_Parameter_Types) = 1
3925 or else Present (Next_Formal (Formal))
3930 Same_Base_Type (Arg_Parameter_Types, Formal);
3933 -- A list of more than one type is parsed as a aggregate
3935 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
3936 and then Paren_Count (Arg_Parameter_Types) = 0
3938 Ptype := First (Expressions (Arg_Parameter_Types));
3939 while Present (Ptype) or else Present (Formal) loop
3942 or else not Same_Base_Type (Ptype, Formal)
3947 Next_Formal (Formal);
3952 -- Anything else is of the wrong form
3956 ("wrong form for Parameter_Types parameter",
3957 Arg_Parameter_Types);
3959 end Check_Matching_Types;
3962 -- Match is now False if the entry we found did not match
3963 -- either a supplied Parameter_Types or Result_Types argument
3969 -- Ambiguous case, the flag Ambiguous shows if we already
3970 -- detected this and output the initial messages.
3973 if not Ambiguous then
3975 Error_Msg_Name_1 := Pname;
3977 ("pragma% does not uniquely identify subprogram!",
3979 Error_Msg_Sloc := Sloc (Ent);
3980 Error_Msg_N ("matching subprogram #!", N);
3984 Error_Msg_Sloc := Sloc (Def_Id);
3985 Error_Msg_N ("matching subprogram #!", N);
3990 Hom_Id := Homonym (Hom_Id);
3993 -- See if we found an entry
3996 if not Ambiguous then
3997 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
3999 ("pragma% cannot be given for generic subprogram");
4002 ("pragma% does not identify local subprogram");
4009 -- Import pragmas must be for imported entities
4011 if Prag_Id = Pragma_Import_Function
4013 Prag_Id = Pragma_Import_Procedure
4015 Prag_Id = Pragma_Import_Valued_Procedure
4017 if not Is_Imported (Ent) then
4019 ("pragma Import or Interface must precede pragma%");
4022 -- Here we have the Export case which can set the entity as exported
4024 -- But does not do so if the specified external name is null, since
4025 -- that is taken as a signal in DEC Ada 83 (with which we want to be
4026 -- compatible) to request no external name.
4028 elsif Nkind (Arg_External) = N_String_Literal
4029 and then String_Length (Strval (Arg_External)) = 0
4033 -- In all other cases, set entity as exported
4036 Set_Exported (Ent, Arg_Internal);
4039 -- Special processing for Valued_Procedure cases
4041 if Prag_Id = Pragma_Import_Valued_Procedure
4043 Prag_Id = Pragma_Export_Valued_Procedure
4045 Formal := First_Formal (Ent);
4048 Error_Pragma ("at least one parameter required for pragma%");
4050 elsif Ekind (Formal) /= E_Out_Parameter then
4051 Error_Pragma ("first parameter must have mode out for pragma%");
4054 Set_Is_Valued_Procedure (Ent);
4058 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
4060 -- Process Result_Mechanism argument if present. We have already
4061 -- checked that this is only allowed for the function case.
4063 if Present (Arg_Result_Mechanism) then
4064 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
4067 -- Process Mechanism parameter if present. Note that this parameter
4068 -- is not analyzed, and must not be analyzed since it is semantic
4069 -- nonsense, so we get it in exactly as the parser left it.
4071 if Present (Arg_Mechanism) then
4079 -- A single mechanism association without a formal parameter
4080 -- name is parsed as a parenthesized expression. All other
4081 -- cases are parsed as aggregates, so we rewrite the single
4082 -- parameter case as an aggregate for consistency.
4084 if Nkind (Arg_Mechanism) /= N_Aggregate
4085 and then Paren_Count (Arg_Mechanism) = 1
4087 Rewrite (Arg_Mechanism,
4088 Make_Aggregate (Sloc (Arg_Mechanism),
4089 Expressions => New_List (
4090 Relocate_Node (Arg_Mechanism))));
4093 -- Case of only mechanism name given, applies to all formals
4095 if Nkind (Arg_Mechanism) /= N_Aggregate then
4096 Formal := First_Formal (Ent);
4097 while Present (Formal) loop
4098 Set_Mechanism_Value (Formal, Arg_Mechanism);
4099 Next_Formal (Formal);
4102 -- Case of list of mechanism associations given
4105 if Null_Record_Present (Arg_Mechanism) then
4107 ("inappropriate form for Mechanism parameter",
4111 -- Deal with positional ones first
4113 Formal := First_Formal (Ent);
4115 if Present (Expressions (Arg_Mechanism)) then
4116 Mname := First (Expressions (Arg_Mechanism));
4117 while Present (Mname) loop
4120 ("too many mechanism associations", Mname);
4123 Set_Mechanism_Value (Formal, Mname);
4124 Next_Formal (Formal);
4129 -- Deal with named entries
4131 if Present (Component_Associations (Arg_Mechanism)) then
4132 Massoc := First (Component_Associations (Arg_Mechanism));
4133 while Present (Massoc) loop
4134 Choice := First (Choices (Massoc));
4136 if Nkind (Choice) /= N_Identifier
4137 or else Present (Next (Choice))
4140 ("incorrect form for mechanism association",
4144 Formal := First_Formal (Ent);
4148 ("parameter name & not present", Choice);
4151 if Chars (Choice) = Chars (Formal) then
4153 (Formal, Expression (Massoc));
4155 -- Set entity on identifier (needed by ASIS)
4157 Set_Entity (Choice, Formal);
4162 Next_Formal (Formal);
4172 -- Process First_Optional_Parameter argument if present. We have
4173 -- already checked that this is only allowed for the Import case.
4175 if Present (Arg_First_Optional_Parameter) then
4176 if Nkind (Arg_First_Optional_Parameter) /= N_Identifier then
4178 ("first optional parameter must be formal parameter name",
4179 Arg_First_Optional_Parameter);
4182 Formal := First_Formal (Ent);
4186 ("specified formal parameter& not found",
4187 Arg_First_Optional_Parameter);
4190 exit when Chars (Formal) =
4191 Chars (Arg_First_Optional_Parameter);
4193 Next_Formal (Formal);
4196 Set_First_Optional_Parameter (Ent, Formal);
4198 -- Check specified and all remaining formals have right form
4200 while Present (Formal) loop
4201 if Ekind (Formal) /= E_In_Parameter then
4203 ("optional formal& is not of mode in!",
4204 Arg_First_Optional_Parameter, Formal);
4207 Dval := Default_Value (Formal);
4211 ("optional formal& does not have default value!",
4212 Arg_First_Optional_Parameter, Formal);
4214 elsif Compile_Time_Known_Value_Or_Aggr (Dval) then
4219 ("default value for optional formal& is non-static!",
4220 Arg_First_Optional_Parameter, Formal);
4224 Set_Is_Optional_Parameter (Formal);
4225 Next_Formal (Formal);
4228 end Process_Extended_Import_Export_Subprogram_Pragma;
4230 --------------------------
4231 -- Process_Generic_List --
4232 --------------------------
4234 procedure Process_Generic_List is
4239 Check_No_Identifiers;
4240 Check_At_Least_N_Arguments (1);
4243 while Present (Arg) loop
4244 Exp := Get_Pragma_Arg (Arg);
4247 if not Is_Entity_Name (Exp)
4249 (not Is_Generic_Instance (Entity (Exp))
4251 not Is_Generic_Unit (Entity (Exp)))
4254 ("pragma% argument must be name of generic unit/instance",
4260 end Process_Generic_List;
4262 ------------------------------------
4263 -- Process_Import_Predefined_Type --
4264 ------------------------------------
4266 procedure Process_Import_Predefined_Type is
4267 Loc : constant Source_Ptr := Sloc (N);
4269 Ftyp : Node_Id := Empty;
4275 String_To_Name_Buffer (Strval (Expression (Arg3)));
4278 Elmt := First_Elmt (Predefined_Float_Types);
4279 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
4283 Ftyp := Node (Elmt);
4285 if Present (Ftyp) then
4287 -- Don't build a derived type declaration, because predefined C
4288 -- types have no declaration anywhere, so cannot really be named.
4289 -- Instead build a full type declaration, starting with an
4290 -- appropriate type definition is built
4292 if Is_Floating_Point_Type (Ftyp) then
4293 Def := Make_Floating_Point_Definition (Loc,
4294 Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
4295 Make_Real_Range_Specification (Loc,
4296 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
4297 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
4299 -- Should never have a predefined type we cannot handle
4302 raise Program_Error;
4305 -- Build and insert a Full_Type_Declaration, which will be
4306 -- analyzed as soon as this list entry has been analyzed.
4308 Decl := Make_Full_Type_Declaration (Loc,
4309 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
4310 Type_Definition => Def);
4312 Insert_After (N, Decl);
4313 Mark_Rewrite_Insertion (Decl);
4316 Error_Pragma_Arg ("no matching type found for pragma%",
4319 end Process_Import_Predefined_Type;
4321 ---------------------------------
4322 -- Process_Import_Or_Interface --
4323 ---------------------------------
4325 procedure Process_Import_Or_Interface is
4331 Process_Convention (C, Def_Id);
4332 Kill_Size_Check_Code (Def_Id);
4333 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
4335 if Ekind_In (Def_Id, E_Variable, E_Constant) then
4337 -- We do not permit Import to apply to a renaming declaration
4339 if Present (Renamed_Object (Def_Id)) then
4341 ("pragma% not allowed for object renaming", Arg2);
4343 -- User initialization is not allowed for imported object, but
4344 -- the object declaration may contain a default initialization,
4345 -- that will be discarded. Note that an explicit initialization
4346 -- only counts if it comes from source, otherwise it is simply
4347 -- the code generator making an implicit initialization explicit.
4349 elsif Present (Expression (Parent (Def_Id)))
4350 and then Comes_From_Source (Expression (Parent (Def_Id)))
4352 Error_Msg_Sloc := Sloc (Def_Id);
4354 ("no initialization allowed for declaration of& #",
4355 "\imported entities cannot be initialized (RM B.1(24))",
4359 Set_Imported (Def_Id);
4360 Process_Interface_Name (Def_Id, Arg3, Arg4);
4362 -- Note that we do not set Is_Public here. That's because we
4363 -- only want to set it if there is no address clause, and we
4364 -- don't know that yet, so we delay that processing till
4367 -- pragma Import completes deferred constants
4369 if Ekind (Def_Id) = E_Constant then
4370 Set_Has_Completion (Def_Id);
4373 -- It is not possible to import a constant of an unconstrained
4374 -- array type (e.g. string) because there is no simple way to
4375 -- write a meaningful subtype for it.
4377 if Is_Array_Type (Etype (Def_Id))
4378 and then not Is_Constrained (Etype (Def_Id))
4381 ("imported constant& must have a constrained subtype",
4386 elsif Is_Subprogram (Def_Id)
4387 or else Is_Generic_Subprogram (Def_Id)
4389 -- If the name is overloaded, pragma applies to all of the denoted
4390 -- entities in the same declarative part.
4393 while Present (Hom_Id) loop
4394 Def_Id := Get_Base_Subprogram (Hom_Id);
4396 -- Ignore inherited subprograms because the pragma will apply
4397 -- to the parent operation, which is the one called.
4399 if Is_Overloadable (Def_Id)
4400 and then Present (Alias (Def_Id))
4404 -- If it is not a subprogram, it must be in an outer scope and
4405 -- pragma does not apply.
4407 elsif not Is_Subprogram (Def_Id)
4408 and then not Is_Generic_Subprogram (Def_Id)
4412 -- The pragma does not apply to primitives of interfaces
4414 elsif Is_Dispatching_Operation (Def_Id)
4415 and then Present (Find_Dispatching_Type (Def_Id))
4416 and then Is_Interface (Find_Dispatching_Type (Def_Id))
4420 -- Verify that the homonym is in the same declarative part (not
4421 -- just the same scope).
4423 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
4424 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
4429 Set_Imported (Def_Id);
4431 -- Reject an Import applied to an abstract subprogram
4433 if Is_Subprogram (Def_Id)
4434 and then Is_Abstract_Subprogram (Def_Id)
4436 Error_Msg_Sloc := Sloc (Def_Id);
4438 ("cannot import abstract subprogram& declared#",
4442 -- Special processing for Convention_Intrinsic
4444 if C = Convention_Intrinsic then
4446 -- Link_Name argument not allowed for intrinsic
4450 Set_Is_Intrinsic_Subprogram (Def_Id);
4452 -- If no external name is present, then check that this
4453 -- is a valid intrinsic subprogram. If an external name
4454 -- is present, then this is handled by the back end.
4457 Check_Intrinsic_Subprogram
4458 (Def_Id, Get_Pragma_Arg (Arg2));
4462 -- All interfaced procedures need an external symbol created
4463 -- for them since they are always referenced from another
4466 Set_Is_Public (Def_Id);
4468 -- Verify that the subprogram does not have a completion
4469 -- through a renaming declaration. For other completions the
4470 -- pragma appears as a too late representation.
4473 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
4477 and then Nkind (Decl) = N_Subprogram_Declaration
4478 and then Present (Corresponding_Body (Decl))
4479 and then Nkind (Unit_Declaration_Node
4480 (Corresponding_Body (Decl))) =
4481 N_Subprogram_Renaming_Declaration
4483 Error_Msg_Sloc := Sloc (Def_Id);
4485 ("cannot import&, renaming already provided for " &
4486 "declaration #", N, Def_Id);
4490 Set_Has_Completion (Def_Id);
4491 Process_Interface_Name (Def_Id, Arg3, Arg4);
4494 if Is_Compilation_Unit (Hom_Id) then
4496 -- Its possible homonyms are not affected by the pragma.
4497 -- Such homonyms might be present in the context of other
4498 -- units being compiled.
4503 Hom_Id := Homonym (Hom_Id);
4507 -- When the convention is Java or CIL, we also allow Import to be
4508 -- given for packages, generic packages, exceptions, record
4509 -- components, and access to subprograms.
4511 elsif (C = Convention_Java or else C = Convention_CIL)
4513 (Is_Package_Or_Generic_Package (Def_Id)
4514 or else Ekind (Def_Id) = E_Exception
4515 or else Ekind (Def_Id) = E_Access_Subprogram_Type
4516 or else Nkind (Parent (Def_Id)) = N_Component_Declaration)
4518 Set_Imported (Def_Id);
4519 Set_Is_Public (Def_Id);
4520 Process_Interface_Name (Def_Id, Arg3, Arg4);
4522 -- Import a CPP class
4524 elsif Is_Record_Type (Def_Id)
4525 and then C = Convention_CPP
4527 -- Types treated as CPP classes must be declared limited (note:
4528 -- this used to be a warning but there is no real benefit to it
4529 -- since we did effectively intend to treat the type as limited
4532 if not Is_Limited_Type (Def_Id) then
4534 ("imported 'C'P'P type must be limited",
4535 Get_Pragma_Arg (Arg2));
4538 Set_Is_CPP_Class (Def_Id);
4540 -- Imported CPP types must not have discriminants (because C++
4541 -- classes do not have discriminants).
4543 if Has_Discriminants (Def_Id) then
4545 ("imported 'C'P'P type cannot have discriminants",
4546 First (Discriminant_Specifications
4547 (Declaration_Node (Def_Id))));
4550 -- Components of imported CPP types must not have default
4551 -- expressions because the constructor (if any) is on the
4555 Tdef : constant Node_Id :=
4556 Type_Definition (Declaration_Node (Def_Id));
4561 if Nkind (Tdef) = N_Record_Definition then
4562 Clist := Component_List (Tdef);
4565 pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition);
4566 Clist := Component_List (Record_Extension_Part (Tdef));
4569 if Present (Clist) then
4570 Comp := First (Component_Items (Clist));
4571 while Present (Comp) loop
4572 if Present (Expression (Comp)) then
4574 ("component of imported 'C'P'P type cannot have" &
4575 " default expression", Expression (Comp));
4583 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
4585 Check_Arg_Count (3);
4586 Check_Arg_Is_Static_Expression (Arg3, Standard_String);
4588 Process_Import_Predefined_Type;
4592 ("second argument of pragma% must be object, subprogram" &
4593 " or incomplete type",
4597 -- If this pragma applies to a compilation unit, then the unit, which
4598 -- is a subprogram, does not require (or allow) a body. We also do
4599 -- not need to elaborate imported procedures.
4601 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
4603 Cunit : constant Node_Id := Parent (Parent (N));
4605 Set_Body_Required (Cunit, False);
4608 end Process_Import_Or_Interface;
4610 --------------------
4611 -- Process_Inline --
4612 --------------------
4614 procedure Process_Inline (Active : Boolean) is
4621 Effective : Boolean := False;
4622 -- Set True if inline has some effect, i.e. if there is at least one
4623 -- subprogram set as inlined as a result of the use of the pragma.
4625 procedure Make_Inline (Subp : Entity_Id);
4626 -- Subp is the defining unit name of the subprogram declaration. Set
4627 -- the flag, as well as the flag in the corresponding body, if there
4630 procedure Set_Inline_Flags (Subp : Entity_Id);
4631 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
4632 -- Has_Pragma_Inline_Always for the Inline_Always case.
4634 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
4635 -- Returns True if it can be determined at this stage that inlining
4636 -- is not possible, for example if the body is available and contains
4637 -- exception handlers, we prevent inlining, since otherwise we can
4638 -- get undefined symbols at link time. This function also emits a
4639 -- warning if front-end inlining is enabled and the pragma appears
4642 -- ??? is business with link symbols still valid, or does it relate
4643 -- to front end ZCX which is being phased out ???
4645 ---------------------------
4646 -- Inlining_Not_Possible --
4647 ---------------------------
4649 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
4650 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
4654 if Nkind (Decl) = N_Subprogram_Body then
4655 Stats := Handled_Statement_Sequence (Decl);
4656 return Present (Exception_Handlers (Stats))
4657 or else Present (At_End_Proc (Stats));
4659 elsif Nkind (Decl) = N_Subprogram_Declaration
4660 and then Present (Corresponding_Body (Decl))
4662 if Front_End_Inlining
4663 and then Analyzed (Corresponding_Body (Decl))
4665 Error_Msg_N ("pragma appears too late, ignored?", N);
4668 -- If the subprogram is a renaming as body, the body is just a
4669 -- call to the renamed subprogram, and inlining is trivially
4673 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
4674 N_Subprogram_Renaming_Declaration
4680 Handled_Statement_Sequence
4681 (Unit_Declaration_Node (Corresponding_Body (Decl)));
4684 Present (Exception_Handlers (Stats))
4685 or else Present (At_End_Proc (Stats));
4689 -- If body is not available, assume the best, the check is
4690 -- performed again when compiling enclosing package bodies.
4694 end Inlining_Not_Possible;
4700 procedure Make_Inline (Subp : Entity_Id) is
4701 Kind : constant Entity_Kind := Ekind (Subp);
4702 Inner_Subp : Entity_Id := Subp;
4705 -- Ignore if bad type, avoid cascaded error
4707 if Etype (Subp) = Any_Type then
4711 -- Ignore if all inlining is suppressed
4713 elsif Suppress_All_Inlining then
4717 -- If inlining is not possible, for now do not treat as an error
4719 elsif Inlining_Not_Possible (Subp) then
4723 -- Here we have a candidate for inlining, but we must exclude
4724 -- derived operations. Otherwise we would end up trying to inline
4725 -- a phantom declaration, and the result would be to drag in a
4726 -- body which has no direct inlining associated with it. That
4727 -- would not only be inefficient but would also result in the
4728 -- backend doing cross-unit inlining in cases where it was
4729 -- definitely inappropriate to do so.
4731 -- However, a simple Comes_From_Source test is insufficient, since
4732 -- we do want to allow inlining of generic instances which also do
4733 -- not come from source. We also need to recognize specs generated
4734 -- by the front-end for bodies that carry the pragma. Finally,
4735 -- predefined operators do not come from source but are not
4736 -- inlineable either.
4738 elsif Is_Generic_Instance (Subp)
4739 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
4743 elsif not Comes_From_Source (Subp)
4744 and then Scope (Subp) /= Standard_Standard
4750 -- The referenced entity must either be the enclosing entity, or
4751 -- an entity declared within the current open scope.
4753 if Present (Scope (Subp))
4754 and then Scope (Subp) /= Current_Scope
4755 and then Subp /= Current_Scope
4758 ("argument of% must be entity in current scope", Assoc);
4762 -- Processing for procedure, operator or function. If subprogram
4763 -- is aliased (as for an instance) indicate that the renamed
4764 -- entity (if declared in the same unit) is inlined.
4766 if Is_Subprogram (Subp) then
4767 Inner_Subp := Ultimate_Alias (Inner_Subp);
4769 if In_Same_Source_Unit (Subp, Inner_Subp) then
4770 Set_Inline_Flags (Inner_Subp);
4772 Decl := Parent (Parent (Inner_Subp));
4774 if Nkind (Decl) = N_Subprogram_Declaration
4775 and then Present (Corresponding_Body (Decl))
4777 Set_Inline_Flags (Corresponding_Body (Decl));
4779 elsif Is_Generic_Instance (Subp) then
4781 -- Indicate that the body needs to be created for
4782 -- inlining subsequent calls. The instantiation node
4783 -- follows the declaration of the wrapper package
4786 if Scope (Subp) /= Standard_Standard
4788 Need_Subprogram_Instance_Body
4789 (Next (Unit_Declaration_Node (Scope (Alias (Subp)))),
4795 -- Inline is a program unit pragma (RM 10.1.5) and cannot
4796 -- appear in a formal part to apply to a formal subprogram.
4797 -- Do not apply check within an instance or a formal package
4798 -- the test will have been applied to the original generic.
4800 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
4801 and then List_Containing (Decl) = List_Containing (N)
4802 and then not In_Instance
4805 ("Inline cannot apply to a formal subprogram", N);
4811 -- For a generic subprogram set flag as well, for use at the point
4812 -- of instantiation, to determine whether the body should be
4815 elsif Is_Generic_Subprogram (Subp) then
4816 Set_Inline_Flags (Subp);
4819 -- Literals are by definition inlined
4821 elsif Kind = E_Enumeration_Literal then
4824 -- Anything else is an error
4828 ("expect subprogram name for pragma%", Assoc);
4832 ----------------------
4833 -- Set_Inline_Flags --
4834 ----------------------
4836 procedure Set_Inline_Flags (Subp : Entity_Id) is
4839 Set_Is_Inlined (Subp);
4842 if not Has_Pragma_Inline (Subp) then
4843 Set_Has_Pragma_Inline (Subp);
4847 if Prag_Id = Pragma_Inline_Always then
4848 Set_Has_Pragma_Inline_Always (Subp);
4850 end Set_Inline_Flags;
4852 -- Start of processing for Process_Inline
4855 Check_No_Identifiers;
4856 Check_At_Least_N_Arguments (1);
4859 Inline_Processing_Required := True;
4863 while Present (Assoc) loop
4864 Subp_Id := Get_Pragma_Arg (Assoc);
4868 if Is_Entity_Name (Subp_Id) then
4869 Subp := Entity (Subp_Id);
4871 if Subp = Any_Id then
4873 -- If previous error, avoid cascaded errors
4881 -- For the pragma case, climb homonym chain. This is
4882 -- what implements allowing the pragma in the renaming
4883 -- case, with the result applying to the ancestors.
4885 if not From_Aspect_Specification (N) then
4886 while Present (Homonym (Subp))
4887 and then Scope (Homonym (Subp)) = Current_Scope
4889 Make_Inline (Homonym (Subp));
4890 Subp := Homonym (Subp);
4898 ("inappropriate argument for pragma%", Assoc);
4901 and then Warn_On_Redundant_Constructs
4902 and then not Suppress_All_Inlining
4904 if Inlining_Not_Possible (Subp) then
4906 ("pragma Inline for& is ignored?", N, Entity (Subp_Id));
4909 ("pragma Inline for& is redundant?", N, Entity (Subp_Id));
4917 ----------------------------
4918 -- Process_Interface_Name --
4919 ----------------------------
4921 procedure Process_Interface_Name
4922 (Subprogram_Def : Entity_Id;
4928 String_Val : String_Id;
4930 procedure Check_Form_Of_Interface_Name
4932 Ext_Name_Case : Boolean);
4933 -- SN is a string literal node for an interface name. This routine
4934 -- performs some minimal checks that the name is reasonable. In
4935 -- particular that no spaces or other obviously incorrect characters
4936 -- appear. This is only a warning, since any characters are allowed.
4937 -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
4939 ----------------------------------
4940 -- Check_Form_Of_Interface_Name --
4941 ----------------------------------
4943 procedure Check_Form_Of_Interface_Name
4945 Ext_Name_Case : Boolean)
4947 S : constant String_Id := Strval (Expr_Value_S (SN));
4948 SL : constant Nat := String_Length (S);
4953 Error_Msg_N ("interface name cannot be null string", SN);
4956 for J in 1 .. SL loop
4957 C := Get_String_Char (S, J);
4959 -- Look for dubious character and issue unconditional warning.
4960 -- Definitely dubious if not in character range.
4962 if not In_Character_Range (C)
4964 -- For all cases except CLI target,
4965 -- commas, spaces and slashes are dubious (in CLI, we use
4966 -- commas and backslashes in external names to specify
4967 -- assembly version and public key, while slashes and spaces
4968 -- can be used in names to mark nested classes and
4971 or else ((not Ext_Name_Case or else VM_Target /= CLI_Target)
4972 and then (Get_Character (C) = ','
4974 Get_Character (C) = '\'))
4975 or else (VM_Target /= CLI_Target
4976 and then (Get_Character (C) = ' '
4978 Get_Character (C) = '/'))
4981 ("?interface name contains illegal character",
4982 Sloc (SN) + Source_Ptr (J));
4985 end Check_Form_Of_Interface_Name;
4987 -- Start of processing for Process_Interface_Name
4990 if No (Link_Arg) then
4991 if No (Ext_Arg) then
4992 if VM_Target = CLI_Target
4993 and then Ekind (Subprogram_Def) = E_Package
4994 and then Nkind (Parent (Subprogram_Def)) =
4995 N_Package_Specification
4996 and then Present (Generic_Parent (Parent (Subprogram_Def)))
5001 (Generic_Parent (Parent (Subprogram_Def))));
5006 elsif Chars (Ext_Arg) = Name_Link_Name then
5008 Link_Nam := Expression (Ext_Arg);
5011 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
5012 Ext_Nam := Expression (Ext_Arg);
5017 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
5018 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
5019 Ext_Nam := Expression (Ext_Arg);
5020 Link_Nam := Expression (Link_Arg);
5023 -- Check expressions for external name and link name are static
5025 if Present (Ext_Nam) then
5026 Check_Arg_Is_Static_Expression (Ext_Nam, Standard_String);
5027 Check_Form_Of_Interface_Name (Ext_Nam, Ext_Name_Case => True);
5029 -- Verify that external name is not the name of a local entity,
5030 -- which would hide the imported one and could lead to run-time
5031 -- surprises. The problem can only arise for entities declared in
5032 -- a package body (otherwise the external name is fully qualified
5033 -- and will not conflict).
5041 if Prag_Id = Pragma_Import then
5042 String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam)));
5044 E := Entity_Id (Get_Name_Table_Info (Nam));
5046 if Nam /= Chars (Subprogram_Def)
5047 and then Present (E)
5048 and then not Is_Overloadable (E)
5049 and then Is_Immediately_Visible (E)
5050 and then not Is_Imported (E)
5051 and then Ekind (Scope (E)) = E_Package
5054 while Present (Par) loop
5055 if Nkind (Par) = N_Package_Body then
5056 Error_Msg_Sloc := Sloc (E);
5058 ("imported entity is hidden by & declared#",
5063 Par := Parent (Par);
5070 if Present (Link_Nam) then
5071 Check_Arg_Is_Static_Expression (Link_Nam, Standard_String);
5072 Check_Form_Of_Interface_Name (Link_Nam, Ext_Name_Case => False);
5075 -- If there is no link name, just set the external name
5077 if No (Link_Nam) then
5078 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
5080 -- For the Link_Name case, the given literal is preceded by an
5081 -- asterisk, which indicates to GCC that the given name should be
5082 -- taken literally, and in particular that no prepending of
5083 -- underlines should occur, even in systems where this is the
5089 if VM_Target = No_VM then
5090 Store_String_Char (Get_Char_Code ('*'));
5093 String_Val := Strval (Expr_Value_S (Link_Nam));
5094 Store_String_Chars (String_Val);
5096 Make_String_Literal (Sloc (Link_Nam),
5097 Strval => End_String);
5100 -- Set the interface name. If the entity is a generic instance, use
5101 -- its alias, which is the callable entity.
5103 if Is_Generic_Instance (Subprogram_Def) then
5104 Set_Encoded_Interface_Name
5105 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
5107 Set_Encoded_Interface_Name
5108 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
5111 -- We allow duplicated export names in CIL/Java, as they are always
5112 -- enclosed in a namespace that differentiates them, and overloaded
5113 -- entities are supported by the VM.
5115 if Convention (Subprogram_Def) /= Convention_CIL
5117 Convention (Subprogram_Def) /= Convention_Java
5119 Check_Duplicated_Export_Name (Link_Nam);
5121 end Process_Interface_Name;
5123 -----------------------------------------
5124 -- Process_Interrupt_Or_Attach_Handler --
5125 -----------------------------------------
5127 procedure Process_Interrupt_Or_Attach_Handler is
5128 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
5129 Handler_Proc : constant Entity_Id := Entity (Arg1_X);
5130 Proc_Scope : constant Entity_Id := Scope (Handler_Proc);
5133 Set_Is_Interrupt_Handler (Handler_Proc);
5135 -- If the pragma is not associated with a handler procedure within a
5136 -- protected type, then it must be for a nonprotected procedure for
5137 -- the AAMP target, in which case we don't associate a representation
5138 -- item with the procedure's scope.
5140 if Ekind (Proc_Scope) = E_Protected_Type then
5141 if Prag_Id = Pragma_Interrupt_Handler
5143 Prag_Id = Pragma_Attach_Handler
5145 Record_Rep_Item (Proc_Scope, N);
5148 end Process_Interrupt_Or_Attach_Handler;
5150 --------------------------------------------------
5151 -- Process_Restrictions_Or_Restriction_Warnings --
5152 --------------------------------------------------
5154 -- Note: some of the simple identifier cases were handled in par-prag,
5155 -- but it is harmless (and more straightforward) to simply handle all
5156 -- cases here, even if it means we repeat a bit of work in some cases.
5158 procedure Process_Restrictions_Or_Restriction_Warnings
5162 R_Id : Restriction_Id;
5167 procedure Check_Unit_Name (N : Node_Id);
5168 -- Checks unit name parameter for No_Dependence. Returns if it has
5169 -- an appropriate form, otherwise raises pragma argument error.
5171 ---------------------
5172 -- Check_Unit_Name --
5173 ---------------------
5175 procedure Check_Unit_Name (N : Node_Id) is
5177 if Nkind (N) = N_Selected_Component then
5178 Check_Unit_Name (Prefix (N));
5179 Check_Unit_Name (Selector_Name (N));
5181 elsif Nkind (N) = N_Identifier then
5186 ("wrong form for unit name for No_Dependence", N);
5188 end Check_Unit_Name;
5190 -- Start of processing for Process_Restrictions_Or_Restriction_Warnings
5193 -- Ignore all Restrictions pragma in CodePeer mode
5195 if CodePeer_Mode then
5199 Check_Ada_83_Warning;
5200 Check_At_Least_N_Arguments (1);
5201 Check_Valid_Configuration_Pragma;
5204 while Present (Arg) loop
5206 Expr := Get_Pragma_Arg (Arg);
5208 -- Case of no restriction identifier present
5210 if Id = No_Name then
5211 if Nkind (Expr) /= N_Identifier then
5213 ("invalid form for restriction", Arg);
5218 (Process_Restriction_Synonyms (Expr));
5220 if R_Id not in All_Boolean_Restrictions then
5221 Error_Msg_Name_1 := Pname;
5223 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
5225 -- Check for possible misspelling
5227 for J in Restriction_Id loop
5229 Rnm : constant String := Restriction_Id'Image (J);
5232 Name_Buffer (1 .. Rnm'Length) := Rnm;
5233 Name_Len := Rnm'Length;
5234 Set_Casing (All_Lower_Case);
5236 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
5238 (Identifier_Casing (Current_Source_File));
5239 Error_Msg_String (1 .. Rnm'Length) :=
5240 Name_Buffer (1 .. Name_Len);
5241 Error_Msg_Strlen := Rnm'Length;
5242 Error_Msg_N -- CODEFIX
5243 ("\possible misspelling of ""~""",
5244 Get_Pragma_Arg (Arg));
5253 if Implementation_Restriction (R_Id) then
5254 Check_Restriction (No_Implementation_Restrictions, Arg);
5257 -- If this is a warning, then set the warning unless we already
5258 -- have a real restriction active (we never want a warning to
5259 -- override a real restriction).
5262 if not Restriction_Active (R_Id) then
5263 Set_Restriction (R_Id, N);
5264 Restriction_Warnings (R_Id) := True;
5267 -- If real restriction case, then set it and make sure that the
5268 -- restriction warning flag is off, since a real restriction
5269 -- always overrides a warning.
5272 Set_Restriction (R_Id, N);
5273 Restriction_Warnings (R_Id) := False;
5276 -- Check for obsolescent restrictions in Ada 2005 mode
5279 and then Ada_Version >= Ada_2005
5280 and then (R_Id = No_Asynchronous_Control
5282 R_Id = No_Unchecked_Deallocation
5284 R_Id = No_Unchecked_Conversion)
5286 Check_Restriction (No_Obsolescent_Features, N);
5289 -- A very special case that must be processed here: pragma
5290 -- Restrictions (No_Exceptions) turns off all run-time
5291 -- checking. This is a bit dubious in terms of the formal
5292 -- language definition, but it is what is intended by RM
5293 -- H.4(12). Restriction_Warnings never affects generated code
5294 -- so this is done only in the real restriction case.
5296 if R_Id = No_Exceptions and then not Warn then
5297 Scope_Suppress := (others => True);
5300 -- Case of No_Dependence => unit-name. Note that the parser
5301 -- already made the necessary entry in the No_Dependence table.
5303 elsif Id = Name_No_Dependence then
5304 Check_Unit_Name (Expr);
5306 -- All other cases of restriction identifier present
5309 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
5310 Analyze_And_Resolve (Expr, Any_Integer);
5312 if R_Id not in All_Parameter_Restrictions then
5314 ("invalid restriction parameter identifier", Arg);
5316 elsif not Is_OK_Static_Expression (Expr) then
5317 Flag_Non_Static_Expr
5318 ("value must be static expression!", Expr);
5321 elsif not Is_Integer_Type (Etype (Expr))
5322 or else Expr_Value (Expr) < 0
5325 ("value must be non-negative integer", Arg);
5328 -- Restriction pragma is active
5330 Val := Expr_Value (Expr);
5332 if not UI_Is_In_Int_Range (Val) then
5334 ("pragma ignored, value too large?", Arg);
5337 -- Warning case. If the real restriction is active, then we
5338 -- ignore the request, since warning never overrides a real
5339 -- restriction. Otherwise we set the proper warning. Note that
5340 -- this circuit sets the warning again if it is already set,
5341 -- which is what we want, since the constant may have changed.
5344 if not Restriction_Active (R_Id) then
5346 (R_Id, N, Integer (UI_To_Int (Val)));
5347 Restriction_Warnings (R_Id) := True;
5350 -- Real restriction case, set restriction and make sure warning
5351 -- flag is off since real restriction always overrides warning.
5354 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
5355 Restriction_Warnings (R_Id) := False;
5361 end Process_Restrictions_Or_Restriction_Warnings;
5363 ---------------------------------
5364 -- Process_Suppress_Unsuppress --
5365 ---------------------------------
5367 -- Note: this procedure makes entries in the check suppress data
5368 -- structures managed by Sem. See spec of package Sem for full
5369 -- details on how we handle recording of check suppression.
5371 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
5376 In_Package_Spec : constant Boolean :=
5377 Is_Package_Or_Generic_Package (Current_Scope)
5378 and then not In_Package_Body (Current_Scope);
5380 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
5381 -- Used to suppress a single check on the given entity
5383 --------------------------------
5384 -- Suppress_Unsuppress_Echeck --
5385 --------------------------------
5387 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
5389 Set_Checks_May_Be_Suppressed (E);
5391 if In_Package_Spec then
5392 Push_Global_Suppress_Stack_Entry
5395 Suppress => Suppress_Case);
5398 Push_Local_Suppress_Stack_Entry
5401 Suppress => Suppress_Case);
5404 -- If this is a first subtype, and the base type is distinct,
5405 -- then also set the suppress flags on the base type.
5407 if Is_First_Subtype (E)
5408 and then Etype (E) /= E
5410 Suppress_Unsuppress_Echeck (Etype (E), C);
5412 end Suppress_Unsuppress_Echeck;
5414 -- Start of processing for Process_Suppress_Unsuppress
5417 -- Ignore pragma Suppress/Unsuppress in CodePeer and Alfa modes on
5418 -- user code: we want to generate checks for analysis purposes, as
5419 -- set respectively by -gnatC and -gnatd.F
5421 if (CodePeer_Mode or Alfa_Mode)
5422 and then Comes_From_Source (N)
5427 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
5428 -- declarative part or a package spec (RM 11.5(5)).
5430 if not Is_Configuration_Pragma then
5431 Check_Is_In_Decl_Part_Or_Package_Spec;
5434 Check_At_Least_N_Arguments (1);
5435 Check_At_Most_N_Arguments (2);
5436 Check_No_Identifier (Arg1);
5437 Check_Arg_Is_Identifier (Arg1);
5439 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
5441 if C = No_Check_Id then
5443 ("argument of pragma% is not valid check name", Arg1);
5446 if not Suppress_Case
5447 and then (C = All_Checks or else C = Overflow_Check)
5449 Opt.Overflow_Checks_Unsuppressed := True;
5452 if Arg_Count = 1 then
5454 -- Make an entry in the local scope suppress table. This is the
5455 -- table that directly shows the current value of the scope
5456 -- suppress check for any check id value.
5458 if C = All_Checks then
5460 -- For All_Checks, we set all specific predefined checks with
5461 -- the exception of Elaboration_Check, which is handled
5462 -- specially because of not wanting All_Checks to have the
5463 -- effect of deactivating static elaboration order processing.
5465 for J in Scope_Suppress'Range loop
5466 if J /= Elaboration_Check then
5467 Scope_Suppress (J) := Suppress_Case;
5471 -- If not All_Checks, and predefined check, then set appropriate
5472 -- scope entry. Note that we will set Elaboration_Check if this
5473 -- is explicitly specified.
5475 elsif C in Predefined_Check_Id then
5476 Scope_Suppress (C) := Suppress_Case;
5479 -- Also make an entry in the Local_Entity_Suppress table
5481 Push_Local_Suppress_Stack_Entry
5484 Suppress => Suppress_Case);
5486 -- Case of two arguments present, where the check is suppressed for
5487 -- a specified entity (given as the second argument of the pragma)
5490 -- This is obsolescent in Ada 2005 mode
5492 if Ada_Version >= Ada_2005 then
5493 Check_Restriction (No_Obsolescent_Features, Arg2);
5496 Check_Optional_Identifier (Arg2, Name_On);
5497 E_Id := Get_Pragma_Arg (Arg2);
5500 if not Is_Entity_Name (E_Id) then
5502 ("second argument of pragma% must be entity name", Arg2);
5511 -- Enforce RM 11.5(7) which requires that for a pragma that
5512 -- appears within a package spec, the named entity must be
5513 -- within the package spec. We allow the package name itself
5514 -- to be mentioned since that makes sense, although it is not
5515 -- strictly allowed by 11.5(7).
5518 and then E /= Current_Scope
5519 and then Scope (E) /= Current_Scope
5522 ("entity in pragma% is not in package spec (RM 11.5(7))",
5526 -- Loop through homonyms. As noted below, in the case of a package
5527 -- spec, only homonyms within the package spec are considered.
5530 Suppress_Unsuppress_Echeck (E, C);
5532 if Is_Generic_Instance (E)
5533 and then Is_Subprogram (E)
5534 and then Present (Alias (E))
5536 Suppress_Unsuppress_Echeck (Alias (E), C);
5539 -- Move to next homonym if not aspect spec case
5541 exit when From_Aspect_Specification (N);
5545 -- If we are within a package specification, the pragma only
5546 -- applies to homonyms in the same scope.
5548 exit when In_Package_Spec
5549 and then Scope (E) /= Current_Scope;
5552 end Process_Suppress_Unsuppress;
5558 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
5560 if Is_Imported (E) then
5562 ("cannot export entity& that was previously imported", Arg);
5564 elsif Present (Address_Clause (E)) and then not CodePeer_Mode then
5566 ("cannot export entity& that has an address clause", Arg);
5569 Set_Is_Exported (E);
5571 -- Generate a reference for entity explicitly, because the
5572 -- identifier may be overloaded and name resolution will not
5575 Generate_Reference (E, Arg);
5577 -- Deal with exporting non-library level entity
5579 if not Is_Library_Level_Entity (E) then
5581 -- Not allowed at all for subprograms
5583 if Is_Subprogram (E) then
5584 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
5586 -- Otherwise set public and statically allocated
5590 Set_Is_Statically_Allocated (E);
5592 -- Warn if the corresponding W flag is set and the pragma comes
5593 -- from source. The latter may not be true e.g. on VMS where we
5594 -- expand export pragmas for exception codes associated with
5595 -- imported or exported exceptions. We do not want to generate
5596 -- a warning for something that the user did not write.
5598 if Warn_On_Export_Import
5599 and then Comes_From_Source (Arg)
5602 ("?& has been made static as a result of Export", Arg, E);
5604 ("\this usage is non-standard and non-portable", Arg);
5609 if Warn_On_Export_Import and then Is_Type (E) then
5610 Error_Msg_NE ("exporting a type has no effect?", Arg, E);
5613 if Warn_On_Export_Import and Inside_A_Generic then
5615 ("all instances of& will have the same external name?", Arg, E);
5619 ----------------------------------------------
5620 -- Set_Extended_Import_Export_External_Name --
5621 ----------------------------------------------
5623 procedure Set_Extended_Import_Export_External_Name
5624 (Internal_Ent : Entity_Id;
5625 Arg_External : Node_Id)
5627 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
5631 if No (Arg_External) then
5635 Check_Arg_Is_External_Name (Arg_External);
5637 if Nkind (Arg_External) = N_String_Literal then
5638 if String_Length (Strval (Arg_External)) = 0 then
5641 New_Name := Adjust_External_Name_Case (Arg_External);
5644 elsif Nkind (Arg_External) = N_Identifier then
5645 New_Name := Get_Default_External_Name (Arg_External);
5647 -- Check_Arg_Is_External_Name should let through only identifiers and
5648 -- string literals or static string expressions (which are folded to
5649 -- string literals).
5652 raise Program_Error;
5655 -- If we already have an external name set (by a prior normal Import
5656 -- or Export pragma), then the external names must match
5658 if Present (Interface_Name (Internal_Ent)) then
5659 Check_Matching_Internal_Names : declare
5660 S1 : constant String_Id := Strval (Old_Name);
5661 S2 : constant String_Id := Strval (New_Name);
5664 -- Called if names do not match
5670 procedure Mismatch is
5672 Error_Msg_Sloc := Sloc (Old_Name);
5674 ("external name does not match that given #",
5678 -- Start of processing for Check_Matching_Internal_Names
5681 if String_Length (S1) /= String_Length (S2) then
5685 for J in 1 .. String_Length (S1) loop
5686 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
5691 end Check_Matching_Internal_Names;
5693 -- Otherwise set the given name
5696 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
5697 Check_Duplicated_Export_Name (New_Name);
5699 end Set_Extended_Import_Export_External_Name;
5705 procedure Set_Imported (E : Entity_Id) is
5707 -- Error message if already imported or exported
5709 if Is_Exported (E) or else Is_Imported (E) then
5711 -- Error if being set Exported twice
5713 if Is_Exported (E) then
5714 Error_Msg_NE ("entity& was previously exported", N, E);
5716 -- OK if Import/Interface case
5718 elsif Import_Interface_Present (N) then
5721 -- Error if being set Imported twice
5724 Error_Msg_NE ("entity& was previously imported", N, E);
5727 Error_Msg_Name_1 := Pname;
5729 ("\(pragma% applies to all previous entities)", N);
5731 Error_Msg_Sloc := Sloc (E);
5732 Error_Msg_NE ("\import not allowed for& declared#", N, E);
5734 -- Here if not previously imported or exported, OK to import
5737 Set_Is_Imported (E);
5739 -- If the entity is an object that is not at the library level,
5740 -- then it is statically allocated. We do not worry about objects
5741 -- with address clauses in this context since they are not really
5742 -- imported in the linker sense.
5745 and then not Is_Library_Level_Entity (E)
5746 and then No (Address_Clause (E))
5748 Set_Is_Statically_Allocated (E);
5755 -------------------------
5756 -- Set_Mechanism_Value --
5757 -------------------------
5759 -- Note: the mechanism name has not been analyzed (and cannot indeed be
5760 -- analyzed, since it is semantic nonsense), so we get it in the exact
5761 -- form created by the parser.
5763 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
5766 Mech_Name_Id : Name_Id;
5768 procedure Bad_Class;
5769 -- Signal bad descriptor class name
5771 procedure Bad_Mechanism;
5772 -- Signal bad mechanism name
5778 procedure Bad_Class is
5780 Error_Pragma_Arg ("unrecognized descriptor class name", Class);
5783 -------------------------
5784 -- Bad_Mechanism_Value --
5785 -------------------------
5787 procedure Bad_Mechanism is
5789 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
5792 -- Start of processing for Set_Mechanism_Value
5795 if Mechanism (Ent) /= Default_Mechanism then
5797 ("mechanism for & has already been set", Mech_Name, Ent);
5800 -- MECHANISM_NAME ::= value | reference | descriptor |
5803 if Nkind (Mech_Name) = N_Identifier then
5804 if Chars (Mech_Name) = Name_Value then
5805 Set_Mechanism (Ent, By_Copy);
5808 elsif Chars (Mech_Name) = Name_Reference then
5809 Set_Mechanism (Ent, By_Reference);
5812 elsif Chars (Mech_Name) = Name_Descriptor then
5813 Check_VMS (Mech_Name);
5815 -- Descriptor => Short_Descriptor if pragma was given
5817 if Short_Descriptors then
5818 Set_Mechanism (Ent, By_Short_Descriptor);
5820 Set_Mechanism (Ent, By_Descriptor);
5825 elsif Chars (Mech_Name) = Name_Short_Descriptor then
5826 Check_VMS (Mech_Name);
5827 Set_Mechanism (Ent, By_Short_Descriptor);
5830 elsif Chars (Mech_Name) = Name_Copy then
5832 ("bad mechanism name, Value assumed", Mech_Name);
5838 -- MECHANISM_NAME ::= descriptor (CLASS_NAME) |
5839 -- short_descriptor (CLASS_NAME)
5840 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
5842 -- Note: this form is parsed as an indexed component
5844 elsif Nkind (Mech_Name) = N_Indexed_Component then
5845 Class := First (Expressions (Mech_Name));
5847 if Nkind (Prefix (Mech_Name)) /= N_Identifier
5848 or else not (Chars (Prefix (Mech_Name)) = Name_Descriptor or else
5849 Chars (Prefix (Mech_Name)) = Name_Short_Descriptor)
5850 or else Present (Next (Class))
5854 Mech_Name_Id := Chars (Prefix (Mech_Name));
5856 -- Change Descriptor => Short_Descriptor if pragma was given
5858 if Mech_Name_Id = Name_Descriptor
5859 and then Short_Descriptors
5861 Mech_Name_Id := Name_Short_Descriptor;
5865 -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) |
5866 -- short_descriptor (Class => CLASS_NAME)
5867 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
5869 -- Note: this form is parsed as a function call
5871 elsif Nkind (Mech_Name) = N_Function_Call then
5872 Param := First (Parameter_Associations (Mech_Name));
5874 if Nkind (Name (Mech_Name)) /= N_Identifier
5875 or else not (Chars (Name (Mech_Name)) = Name_Descriptor or else
5876 Chars (Name (Mech_Name)) = Name_Short_Descriptor)
5877 or else Present (Next (Param))
5878 or else No (Selector_Name (Param))
5879 or else Chars (Selector_Name (Param)) /= Name_Class
5883 Class := Explicit_Actual_Parameter (Param);
5884 Mech_Name_Id := Chars (Name (Mech_Name));
5891 -- Fall through here with Class set to descriptor class name
5893 Check_VMS (Mech_Name);
5895 if Nkind (Class) /= N_Identifier then
5898 elsif Mech_Name_Id = Name_Descriptor
5899 and then Chars (Class) = Name_UBS
5901 Set_Mechanism (Ent, By_Descriptor_UBS);
5903 elsif Mech_Name_Id = Name_Descriptor
5904 and then Chars (Class) = Name_UBSB
5906 Set_Mechanism (Ent, By_Descriptor_UBSB);
5908 elsif Mech_Name_Id = Name_Descriptor
5909 and then Chars (Class) = Name_UBA
5911 Set_Mechanism (Ent, By_Descriptor_UBA);
5913 elsif Mech_Name_Id = Name_Descriptor
5914 and then Chars (Class) = Name_S
5916 Set_Mechanism (Ent, By_Descriptor_S);
5918 elsif Mech_Name_Id = Name_Descriptor
5919 and then Chars (Class) = Name_SB
5921 Set_Mechanism (Ent, By_Descriptor_SB);
5923 elsif Mech_Name_Id = Name_Descriptor
5924 and then Chars (Class) = Name_A
5926 Set_Mechanism (Ent, By_Descriptor_A);
5928 elsif Mech_Name_Id = Name_Descriptor
5929 and then Chars (Class) = Name_NCA
5931 Set_Mechanism (Ent, By_Descriptor_NCA);
5933 elsif Mech_Name_Id = Name_Short_Descriptor
5934 and then Chars (Class) = Name_UBS
5936 Set_Mechanism (Ent, By_Short_Descriptor_UBS);
5938 elsif Mech_Name_Id = Name_Short_Descriptor
5939 and then Chars (Class) = Name_UBSB
5941 Set_Mechanism (Ent, By_Short_Descriptor_UBSB);
5943 elsif Mech_Name_Id = Name_Short_Descriptor
5944 and then Chars (Class) = Name_UBA
5946 Set_Mechanism (Ent, By_Short_Descriptor_UBA);
5948 elsif Mech_Name_Id = Name_Short_Descriptor
5949 and then Chars (Class) = Name_S
5951 Set_Mechanism (Ent, By_Short_Descriptor_S);
5953 elsif Mech_Name_Id = Name_Short_Descriptor
5954 and then Chars (Class) = Name_SB
5956 Set_Mechanism (Ent, By_Short_Descriptor_SB);
5958 elsif Mech_Name_Id = Name_Short_Descriptor
5959 and then Chars (Class) = Name_A
5961 Set_Mechanism (Ent, By_Short_Descriptor_A);
5963 elsif Mech_Name_Id = Name_Short_Descriptor
5964 and then Chars (Class) = Name_NCA
5966 Set_Mechanism (Ent, By_Short_Descriptor_NCA);
5971 end Set_Mechanism_Value;
5973 ---------------------------
5974 -- Set_Ravenscar_Profile --
5975 ---------------------------
5977 -- The tasks to be done here are
5979 -- Set required policies
5981 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
5982 -- pragma Locking_Policy (Ceiling_Locking)
5984 -- Set Detect_Blocking mode
5986 -- Set required restrictions (see System.Rident for detailed list)
5988 -- Set the No_Dependence rules
5989 -- No_Dependence => Ada.Asynchronous_Task_Control
5990 -- No_Dependence => Ada.Calendar
5991 -- No_Dependence => Ada.Execution_Time.Group_Budget
5992 -- No_Dependence => Ada.Execution_Time.Timers
5993 -- No_Dependence => Ada.Task_Attributes
5994 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
5996 procedure Set_Ravenscar_Profile (N : Node_Id) is
5997 Prefix_Entity : Entity_Id;
5998 Selector_Entity : Entity_Id;
5999 Prefix_Node : Node_Id;
6003 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
6005 if Task_Dispatching_Policy /= ' '
6006 and then Task_Dispatching_Policy /= 'F'
6008 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
6009 Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
6011 -- Set the FIFO_Within_Priorities policy, but always preserve
6012 -- System_Location since we like the error message with the run time
6016 Task_Dispatching_Policy := 'F';
6018 if Task_Dispatching_Policy_Sloc /= System_Location then
6019 Task_Dispatching_Policy_Sloc := Loc;
6023 -- pragma Locking_Policy (Ceiling_Locking)
6025 if Locking_Policy /= ' '
6026 and then Locking_Policy /= 'C'
6028 Error_Msg_Sloc := Locking_Policy_Sloc;
6029 Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
6031 -- Set the Ceiling_Locking policy, but preserve System_Location since
6032 -- we like the error message with the run time name.
6035 Locking_Policy := 'C';
6037 if Locking_Policy_Sloc /= System_Location then
6038 Locking_Policy_Sloc := Loc;
6042 -- pragma Detect_Blocking
6044 Detect_Blocking := True;
6046 -- Set the corresponding restrictions
6048 Set_Profile_Restrictions
6049 (Ravenscar, N, Warn => Treat_Restrictions_As_Warnings);
6051 -- Set the No_Dependence restrictions
6053 -- The following No_Dependence restrictions:
6054 -- No_Dependence => Ada.Asynchronous_Task_Control
6055 -- No_Dependence => Ada.Calendar
6056 -- No_Dependence => Ada.Task_Attributes
6057 -- are already set by previous call to Set_Profile_Restrictions.
6059 -- Set the following restrictions which were added to Ada 2005:
6060 -- No_Dependence => Ada.Execution_Time.Group_Budget
6061 -- No_Dependence => Ada.Execution_Time.Timers
6063 if Ada_Version >= Ada_2005 then
6064 Name_Buffer (1 .. 3) := "ada";
6067 Prefix_Entity := Make_Identifier (Loc, Name_Find);
6069 Name_Buffer (1 .. 14) := "execution_time";
6072 Selector_Entity := Make_Identifier (Loc, Name_Find);
6075 Make_Selected_Component
6077 Prefix => Prefix_Entity,
6078 Selector_Name => Selector_Entity);
6080 Name_Buffer (1 .. 13) := "group_budgets";
6083 Selector_Entity := Make_Identifier (Loc, Name_Find);
6086 Make_Selected_Component
6088 Prefix => Prefix_Node,
6089 Selector_Name => Selector_Entity);
6091 Set_Restriction_No_Dependence
6093 Warn => Treat_Restrictions_As_Warnings,
6094 Profile => Ravenscar);
6096 Name_Buffer (1 .. 6) := "timers";
6099 Selector_Entity := Make_Identifier (Loc, Name_Find);
6102 Make_Selected_Component
6104 Prefix => Prefix_Node,
6105 Selector_Name => Selector_Entity);
6107 Set_Restriction_No_Dependence
6109 Warn => Treat_Restrictions_As_Warnings,
6110 Profile => Ravenscar);
6113 -- Set the following restrictions which was added to Ada 2012 (see
6115 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
6117 if Ada_Version >= Ada_2012 then
6118 Name_Buffer (1 .. 6) := "system";
6121 Prefix_Entity := Make_Identifier (Loc, Name_Find);
6123 Name_Buffer (1 .. 15) := "multiprocessors";
6126 Selector_Entity := Make_Identifier (Loc, Name_Find);
6129 Make_Selected_Component
6131 Prefix => Prefix_Entity,
6132 Selector_Name => Selector_Entity);
6134 Name_Buffer (1 .. 19) := "dispatching_domains";
6137 Selector_Entity := Make_Identifier (Loc, Name_Find);
6140 Make_Selected_Component
6142 Prefix => Prefix_Node,
6143 Selector_Name => Selector_Entity);
6145 Set_Restriction_No_Dependence
6147 Warn => Treat_Restrictions_As_Warnings,
6148 Profile => Ravenscar);
6150 end Set_Ravenscar_Profile;
6152 -- Start of processing for Analyze_Pragma
6155 -- The following code is a defense against recursion. Not clear that
6156 -- this can happen legitimately, but perhaps some error situations
6157 -- can cause it, and we did see this recursion during testing.
6159 if Analyzed (N) then
6162 Set_Analyzed (N, True);
6165 -- Deal with unrecognized pragma
6167 if not Is_Pragma_Name (Pname) then
6168 if Warn_On_Unrecognized_Pragma then
6169 Error_Msg_Name_1 := Pname;
6170 Error_Msg_N ("?unrecognized pragma%!", Pragma_Identifier (N));
6172 for PN in First_Pragma_Name .. Last_Pragma_Name loop
6173 if Is_Bad_Spelling_Of (Pname, PN) then
6174 Error_Msg_Name_1 := PN;
6175 Error_Msg_N -- CODEFIX
6176 ("\?possible misspelling of %!", Pragma_Identifier (N));
6185 -- Here to start processing for recognized pragma
6187 Prag_Id := Get_Pragma_Id (Pname);
6197 if Present (Pragma_Argument_Associations (N)) then
6198 Arg_Count := List_Length (Pragma_Argument_Associations (N));
6199 Arg1 := First (Pragma_Argument_Associations (N));
6201 if Present (Arg1) then
6202 Arg2 := Next (Arg1);
6204 if Present (Arg2) then
6205 Arg3 := Next (Arg2);
6207 if Present (Arg3) then
6208 Arg4 := Next (Arg3);
6214 -- An enumeration type defines the pragmas that are supported by the
6215 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
6216 -- into the corresponding enumeration value for the following case.
6224 -- pragma Abort_Defer;
6226 when Pragma_Abort_Defer =>
6228 Check_Arg_Count (0);
6230 -- The only required semantic processing is to check the
6231 -- placement. This pragma must appear at the start of the
6232 -- statement sequence of a handled sequence of statements.
6234 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
6235 or else N /= First (Statements (Parent (N)))
6246 -- Note: this pragma also has some specific processing in Par.Prag
6247 -- because we want to set the Ada version mode during parsing.
6249 when Pragma_Ada_83 =>
6251 Check_Arg_Count (0);
6253 -- We really should check unconditionally for proper configuration
6254 -- pragma placement, since we really don't want mixed Ada modes
6255 -- within a single unit, and the GNAT reference manual has always
6256 -- said this was a configuration pragma, but we did not check and
6257 -- are hesitant to add the check now.
6259 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
6260 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
6261 -- or Ada 2012 mode.
6263 if Ada_Version >= Ada_2005 then
6264 Check_Valid_Configuration_Pragma;
6267 -- Now set Ada 83 mode
6269 Ada_Version := Ada_83;
6270 Ada_Version_Explicit := Ada_Version;
6278 -- Note: this pragma also has some specific processing in Par.Prag
6279 -- because we want to set the Ada 83 version mode during parsing.
6281 when Pragma_Ada_95 =>
6283 Check_Arg_Count (0);
6285 -- We really should check unconditionally for proper configuration
6286 -- pragma placement, since we really don't want mixed Ada modes
6287 -- within a single unit, and the GNAT reference manual has always
6288 -- said this was a configuration pragma, but we did not check and
6289 -- are hesitant to add the check now.
6291 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
6292 -- or Ada 95, so we must check if we are in Ada 2005 mode.
6294 if Ada_Version >= Ada_2005 then
6295 Check_Valid_Configuration_Pragma;
6298 -- Now set Ada 95 mode
6300 Ada_Version := Ada_95;
6301 Ada_Version_Explicit := Ada_Version;
6303 ---------------------
6304 -- Ada_05/Ada_2005 --
6305 ---------------------
6308 -- pragma Ada_05 (LOCAL_NAME);
6311 -- pragma Ada_2005 (LOCAL_NAME):
6313 -- Note: these pragmas also have some specific processing in Par.Prag
6314 -- because we want to set the Ada 2005 version mode during parsing.
6316 when Pragma_Ada_05 | Pragma_Ada_2005 => declare
6322 if Arg_Count = 1 then
6323 Check_Arg_Is_Local_Name (Arg1);
6324 E_Id := Get_Pragma_Arg (Arg1);
6326 if Etype (E_Id) = Any_Type then
6330 Set_Is_Ada_2005_Only (Entity (E_Id));
6333 Check_Arg_Count (0);
6335 -- For Ada_2005 we unconditionally enforce the documented
6336 -- configuration pragma placement, since we do not want to
6337 -- tolerate mixed modes in a unit involving Ada 2005. That
6338 -- would cause real difficulties for those cases where there
6339 -- are incompatibilities between Ada 95 and Ada 2005.
6341 Check_Valid_Configuration_Pragma;
6343 -- Now set appropriate Ada mode
6345 Ada_Version := Ada_2005;
6346 Ada_Version_Explicit := Ada_2005;
6350 ---------------------
6351 -- Ada_12/Ada_2012 --
6352 ---------------------
6355 -- pragma Ada_12 (LOCAL_NAME);
6358 -- pragma Ada_2012 (LOCAL_NAME):
6360 -- Note: these pragmas also have some specific processing in Par.Prag
6361 -- because we want to set the Ada 2012 version mode during parsing.
6363 when Pragma_Ada_12 | Pragma_Ada_2012 => declare
6369 if Arg_Count = 1 then
6370 Check_Arg_Is_Local_Name (Arg1);
6371 E_Id := Get_Pragma_Arg (Arg1);
6373 if Etype (E_Id) = Any_Type then
6377 Set_Is_Ada_2012_Only (Entity (E_Id));
6380 Check_Arg_Count (0);
6382 -- For Ada_2012 we unconditionally enforce the documented
6383 -- configuration pragma placement, since we do not want to
6384 -- tolerate mixed modes in a unit involving Ada 2012. That
6385 -- would cause real difficulties for those cases where there
6386 -- are incompatibilities between Ada 95 and Ada 2012. We could
6387 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
6389 Check_Valid_Configuration_Pragma;
6391 -- Now set appropriate Ada mode
6393 Ada_Version := Ada_2012;
6394 Ada_Version_Explicit := Ada_2012;
6398 ----------------------
6399 -- All_Calls_Remote --
6400 ----------------------
6402 -- pragma All_Calls_Remote [(library_package_NAME)];
6404 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
6405 Lib_Entity : Entity_Id;
6408 Check_Ada_83_Warning;
6409 Check_Valid_Library_Unit_Pragma;
6411 if Nkind (N) = N_Null_Statement then
6415 Lib_Entity := Find_Lib_Unit_Name;
6417 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
6419 if Present (Lib_Entity)
6420 and then not Debug_Flag_U
6422 if not Is_Remote_Call_Interface (Lib_Entity) then
6423 Error_Pragma ("pragma% only apply to rci unit");
6425 -- Set flag for entity of the library unit
6428 Set_Has_All_Calls_Remote (Lib_Entity);
6432 end All_Calls_Remote;
6438 -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]);
6439 -- ARG ::= NAME | EXPRESSION
6441 -- The first two arguments are by convention intended to refer to an
6442 -- external tool and a tool-specific function. These arguments are
6445 when Pragma_Annotate => Annotate : declare
6451 Check_At_Least_N_Arguments (1);
6452 Check_Arg_Is_Identifier (Arg1);
6453 Check_No_Identifiers;
6456 -- Second parameter is optional, it is never analyzed
6461 -- Here if we have a second parameter
6464 -- Second parameter must be identifier
6466 Check_Arg_Is_Identifier (Arg2);
6468 -- Process remaining parameters if any
6471 while Present (Arg) loop
6472 Exp := Get_Pragma_Arg (Arg);
6475 if Is_Entity_Name (Exp) then
6478 -- For string literals, we assume Standard_String as the
6479 -- type, unless the string contains wide or wide_wide
6482 elsif Nkind (Exp) = N_String_Literal then
6483 if Has_Wide_Wide_Character (Exp) then
6484 Resolve (Exp, Standard_Wide_Wide_String);
6485 elsif Has_Wide_Character (Exp) then
6486 Resolve (Exp, Standard_Wide_String);
6488 Resolve (Exp, Standard_String);
6491 elsif Is_Overloaded (Exp) then
6493 ("ambiguous argument for pragma%", Exp);
6508 -- pragma Assert ([Check =>] Boolean_EXPRESSION
6509 -- [, [Message =>] Static_String_EXPRESSION]);
6511 when Pragma_Assert => Assert : declare
6517 Check_At_Least_N_Arguments (1);
6518 Check_At_Most_N_Arguments (2);
6519 Check_Arg_Order ((Name_Check, Name_Message));
6520 Check_Optional_Identifier (Arg1, Name_Check);
6522 -- We treat pragma Assert as equivalent to:
6524 -- pragma Check (Assertion, condition [, msg]);
6526 -- So rewrite pragma in this manner, and analyze the result
6528 Expr := Get_Pragma_Arg (Arg1);
6530 Make_Pragma_Argument_Association (Loc,
6531 Expression => Make_Identifier (Loc, Name_Assertion)),
6533 Make_Pragma_Argument_Association (Sloc (Expr),
6534 Expression => Expr));
6536 if Arg_Count > 1 then
6537 Check_Optional_Identifier (Arg2, Name_Message);
6538 Analyze_And_Resolve (Get_Pragma_Arg (Arg2), Standard_String);
6539 Append_To (Newa, Relocate_Node (Arg2));
6544 Chars => Name_Check,
6545 Pragma_Argument_Associations => Newa));
6549 ----------------------
6550 -- Assertion_Policy --
6551 ----------------------
6553 -- pragma Assertion_Policy (Check | Disable |Ignore)
6555 when Pragma_Assertion_Policy => Assertion_Policy : declare
6560 Check_Valid_Configuration_Pragma;
6561 Check_Arg_Count (1);
6562 Check_No_Identifiers;
6563 Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Disable, Name_Ignore);
6565 -- We treat pragma Assertion_Policy as equivalent to:
6567 -- pragma Check_Policy (Assertion, policy)
6569 -- So rewrite the pragma in that manner and link on to the chain
6570 -- of Check_Policy pragmas, marking the pragma as analyzed.
6572 Policy := Get_Pragma_Arg (Arg1);
6576 Chars => Name_Check_Policy,
6578 Pragma_Argument_Associations => New_List (
6579 Make_Pragma_Argument_Association (Loc,
6580 Expression => Make_Identifier (Loc, Name_Assertion)),
6582 Make_Pragma_Argument_Association (Loc,
6584 Make_Identifier (Sloc (Policy), Chars (Policy))))));
6587 Set_Next_Pragma (N, Opt.Check_Policy_List);
6588 Opt.Check_Policy_List := N;
6589 end Assertion_Policy;
6591 ------------------------------
6592 -- Assume_No_Invalid_Values --
6593 ------------------------------
6595 -- pragma Assume_No_Invalid_Values (On | Off);
6597 when Pragma_Assume_No_Invalid_Values =>
6599 Check_Valid_Configuration_Pragma;
6600 Check_Arg_Count (1);
6601 Check_No_Identifiers;
6602 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
6604 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
6605 Assume_No_Invalid_Values := True;
6607 Assume_No_Invalid_Values := False;
6614 -- pragma AST_Entry (entry_IDENTIFIER);
6616 when Pragma_AST_Entry => AST_Entry : declare
6622 Check_Arg_Count (1);
6623 Check_No_Identifiers;
6624 Check_Arg_Is_Local_Name (Arg1);
6625 Ent := Entity (Get_Pragma_Arg (Arg1));
6627 -- Note: the implementation of the AST_Entry pragma could handle
6628 -- the entry family case fine, but for now we are consistent with
6629 -- the DEC rules, and do not allow the pragma, which of course
6630 -- has the effect of also forbidding the attribute.
6632 if Ekind (Ent) /= E_Entry then
6634 ("pragma% argument must be simple entry name", Arg1);
6636 elsif Is_AST_Entry (Ent) then
6638 ("duplicate % pragma for entry", Arg1);
6640 elsif Has_Homonym (Ent) then
6642 ("pragma% argument cannot specify overloaded entry", Arg1);
6646 FF : constant Entity_Id := First_Formal (Ent);
6649 if Present (FF) then
6650 if Present (Next_Formal (FF)) then
6652 ("entry for pragma% can have only one argument",
6655 elsif Parameter_Mode (FF) /= E_In_Parameter then
6657 ("entry parameter for pragma% must have mode IN",
6663 Set_Is_AST_Entry (Ent);
6671 -- pragma Asynchronous (LOCAL_NAME);
6673 when Pragma_Asynchronous => Asynchronous : declare
6681 procedure Process_Async_Pragma;
6682 -- Common processing for procedure and access-to-procedure case
6684 --------------------------
6685 -- Process_Async_Pragma --
6686 --------------------------
6688 procedure Process_Async_Pragma is
6691 Set_Is_Asynchronous (Nm);
6695 -- The formals should be of mode IN (RM E.4.1(6))
6698 while Present (S) loop
6699 Formal := Defining_Identifier (S);
6701 if Nkind (Formal) = N_Defining_Identifier
6702 and then Ekind (Formal) /= E_In_Parameter
6705 ("pragma% procedure can only have IN parameter",
6712 Set_Is_Asynchronous (Nm);
6713 end Process_Async_Pragma;
6715 -- Start of processing for pragma Asynchronous
6718 Check_Ada_83_Warning;
6719 Check_No_Identifiers;
6720 Check_Arg_Count (1);
6721 Check_Arg_Is_Local_Name (Arg1);
6723 if Debug_Flag_U then
6727 C_Ent := Cunit_Entity (Current_Sem_Unit);
6728 Analyze (Get_Pragma_Arg (Arg1));
6729 Nm := Entity (Get_Pragma_Arg (Arg1));
6731 if not Is_Remote_Call_Interface (C_Ent)
6732 and then not Is_Remote_Types (C_Ent)
6734 -- This pragma should only appear in an RCI or Remote Types
6735 -- unit (RM E.4.1(4)).
6738 ("pragma% not in Remote_Call_Interface or " &
6739 "Remote_Types unit");
6742 if Ekind (Nm) = E_Procedure
6743 and then Nkind (Parent (Nm)) = N_Procedure_Specification
6745 if not Is_Remote_Call_Interface (Nm) then
6747 ("pragma% cannot be applied on non-remote procedure",
6751 L := Parameter_Specifications (Parent (Nm));
6752 Process_Async_Pragma;
6755 elsif Ekind (Nm) = E_Function then
6757 ("pragma% cannot be applied to function", Arg1);
6759 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
6760 if Is_Record_Type (Nm) then
6762 -- A record type that is the Equivalent_Type for a remote
6763 -- access-to-subprogram type.
6765 N := Declaration_Node (Corresponding_Remote_Type (Nm));
6768 -- A non-expanded RAS type (distribution is not enabled)
6770 N := Declaration_Node (Nm);
6773 if Nkind (N) = N_Full_Type_Declaration
6774 and then Nkind (Type_Definition (N)) =
6775 N_Access_Procedure_Definition
6777 L := Parameter_Specifications (Type_Definition (N));
6778 Process_Async_Pragma;
6780 if Is_Asynchronous (Nm)
6781 and then Expander_Active
6782 and then Get_PCS_Name /= Name_No_DSA
6784 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
6789 ("pragma% cannot reference access-to-function type",
6793 -- Only other possibility is Access-to-class-wide type
6795 elsif Is_Access_Type (Nm)
6796 and then Is_Class_Wide_Type (Designated_Type (Nm))
6798 Check_First_Subtype (Arg1);
6799 Set_Is_Asynchronous (Nm);
6800 if Expander_Active then
6801 RACW_Type_Is_Asynchronous (Nm);
6805 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
6813 -- pragma Atomic (LOCAL_NAME);
6815 when Pragma_Atomic =>
6816 Process_Atomic_Shared_Volatile;
6818 -----------------------
6819 -- Atomic_Components --
6820 -----------------------
6822 -- pragma Atomic_Components (array_LOCAL_NAME);
6824 -- This processing is shared by Volatile_Components
6826 when Pragma_Atomic_Components |
6827 Pragma_Volatile_Components =>
6829 Atomic_Components : declare
6836 Check_Ada_83_Warning;
6837 Check_No_Identifiers;
6838 Check_Arg_Count (1);
6839 Check_Arg_Is_Local_Name (Arg1);
6840 E_Id := Get_Pragma_Arg (Arg1);
6842 if Etype (E_Id) = Any_Type then
6848 Check_Duplicate_Pragma (E);
6850 if Rep_Item_Too_Early (E, N)
6852 Rep_Item_Too_Late (E, N)
6857 D := Declaration_Node (E);
6860 if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
6862 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
6863 and then Nkind (D) = N_Object_Declaration
6864 and then Nkind (Object_Definition (D)) =
6865 N_Constrained_Array_Definition)
6867 -- The flag is set on the object, or on the base type
6869 if Nkind (D) /= N_Object_Declaration then
6873 Set_Has_Volatile_Components (E);
6875 if Prag_Id = Pragma_Atomic_Components then
6876 Set_Has_Atomic_Components (E);
6880 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
6882 end Atomic_Components;
6884 --------------------
6885 -- Attach_Handler --
6886 --------------------
6888 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
6890 when Pragma_Attach_Handler =>
6891 Check_Ada_83_Warning;
6892 Check_No_Identifiers;
6893 Check_Arg_Count (2);
6895 if No_Run_Time_Mode then
6896 Error_Msg_CRT ("Attach_Handler pragma", N);
6898 Check_Interrupt_Or_Attach_Handler;
6900 -- The expression that designates the attribute may depend on a
6901 -- discriminant, and is therefore a per- object expression, to
6902 -- be expanded in the init proc. If expansion is enabled, then
6903 -- perform semantic checks on a copy only.
6905 if Expander_Active then
6907 Temp : constant Node_Id :=
6908 New_Copy_Tree (Get_Pragma_Arg (Arg2));
6910 Set_Parent (Temp, N);
6911 Preanalyze_And_Resolve (Temp, RTE (RE_Interrupt_ID));
6915 Analyze (Get_Pragma_Arg (Arg2));
6916 Resolve (Get_Pragma_Arg (Arg2), RTE (RE_Interrupt_ID));
6919 Process_Interrupt_Or_Attach_Handler;
6922 --------------------
6923 -- C_Pass_By_Copy --
6924 --------------------
6926 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
6928 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
6934 Check_Valid_Configuration_Pragma;
6935 Check_Arg_Count (1);
6936 Check_Optional_Identifier (Arg1, "max_size");
6938 Arg := Get_Pragma_Arg (Arg1);
6939 Check_Arg_Is_Static_Expression (Arg, Any_Integer);
6941 Val := Expr_Value (Arg);
6945 ("maximum size for pragma% must be positive", Arg1);
6947 elsif UI_Is_In_Int_Range (Val) then
6948 Default_C_Record_Mechanism := UI_To_Int (Val);
6950 -- If a giant value is given, Int'Last will do well enough.
6951 -- If sometime someone complains that a record larger than
6952 -- two gigabytes is not copied, we will worry about it then!
6955 Default_C_Record_Mechanism := Mechanism_Type'Last;
6963 -- pragma Check ([Name =>] IDENTIFIER,
6964 -- [Check =>] Boolean_EXPRESSION
6965 -- [,[Message =>] String_EXPRESSION]);
6967 when Pragma_Check => Check : declare
6972 -- Set True if category of assertions referenced by Name enabled
6976 Check_At_Least_N_Arguments (2);
6977 Check_At_Most_N_Arguments (3);
6978 Check_Optional_Identifier (Arg1, Name_Name);
6979 Check_Optional_Identifier (Arg2, Name_Check);
6981 if Arg_Count = 3 then
6982 Check_Optional_Identifier (Arg3, Name_Message);
6983 Analyze_And_Resolve (Get_Pragma_Arg (Arg3), Standard_String);
6986 Check_Arg_Is_Identifier (Arg1);
6988 -- Completely ignore if disabled
6990 if Check_Disabled (Chars (Get_Pragma_Arg (Arg1))) then
6991 Rewrite (N, Make_Null_Statement (Loc));
6996 -- Indicate if pragma is enabled. The Original_Node reference here
6997 -- is to deal with pragma Assert rewritten as a Check pragma.
6999 Check_On := Check_Enabled (Chars (Get_Pragma_Arg (Arg1)));
7002 Set_SCO_Pragma_Enabled (Loc);
7005 -- If expansion is active and the check is not enabled then we
7006 -- rewrite the Check as:
7008 -- if False and then condition then
7012 -- The reason we do this rewriting during semantic analysis rather
7013 -- than as part of normal expansion is that we cannot analyze and
7014 -- expand the code for the boolean expression directly, or it may
7015 -- cause insertion of actions that would escape the attempt to
7016 -- suppress the check code.
7018 -- Note that the Sloc for the if statement corresponds to the
7019 -- argument condition, not the pragma itself. The reason for this
7020 -- is that we may generate a warning if the condition is False at
7021 -- compile time, and we do not want to delete this warning when we
7022 -- delete the if statement.
7024 Expr := Get_Pragma_Arg (Arg2);
7026 if Expander_Active and then not Check_On then
7027 Eloc := Sloc (Expr);
7030 Make_If_Statement (Eloc,
7032 Make_And_Then (Eloc,
7033 Left_Opnd => New_Occurrence_Of (Standard_False, Eloc),
7034 Right_Opnd => Expr),
7035 Then_Statements => New_List (
7036 Make_Null_Statement (Eloc))));
7043 Analyze_And_Resolve (Expr, Any_Boolean);
7051 -- pragma Check_Name (check_IDENTIFIER);
7053 when Pragma_Check_Name =>
7054 Check_No_Identifiers;
7056 Check_Valid_Configuration_Pragma;
7057 Check_Arg_Count (1);
7058 Check_Arg_Is_Identifier (Arg1);
7061 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
7064 for J in Check_Names.First .. Check_Names.Last loop
7065 if Check_Names.Table (J) = Nam then
7070 Check_Names.Append (Nam);
7077 -- pragma Check_Policy (
7078 -- [Name =>] IDENTIFIER,
7079 -- [Policy =>] POLICY_IDENTIFIER);
7081 -- POLICY_IDENTIFIER ::= ON | OFF | CHECK | DISABLE | IGNORE
7083 -- Note: this is a configuration pragma, but it is allowed to appear
7086 when Pragma_Check_Policy =>
7088 Check_Arg_Count (2);
7089 Check_Optional_Identifier (Arg1, Name_Name);
7090 Check_Optional_Identifier (Arg2, Name_Policy);
7092 (Arg2, Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
7094 -- A Check_Policy pragma can appear either as a configuration
7095 -- pragma, or in a declarative part or a package spec (see RM
7096 -- 11.5(5) for rules for Suppress/Unsuppress which are also
7097 -- followed for Check_Policy).
7099 if not Is_Configuration_Pragma then
7100 Check_Is_In_Decl_Part_Or_Package_Spec;
7103 Set_Next_Pragma (N, Opt.Check_Policy_List);
7104 Opt.Check_Policy_List := N;
7106 ---------------------
7107 -- CIL_Constructor --
7108 ---------------------
7110 -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
7112 -- Processing for this pragma is shared with Java_Constructor
7118 -- pragma Comment (static_string_EXPRESSION)
7120 -- Processing for pragma Comment shares the circuitry for pragma
7121 -- Ident. The only differences are that Ident enforces a limit of 31
7122 -- characters on its argument, and also enforces limitations on
7123 -- placement for DEC compatibility. Pragma Comment shares neither of
7124 -- these restrictions.
7130 -- pragma Common_Object (
7131 -- [Internal =>] LOCAL_NAME
7132 -- [, [External =>] EXTERNAL_SYMBOL]
7133 -- [, [Size =>] EXTERNAL_SYMBOL]);
7135 -- Processing for this pragma is shared with Psect_Object
7137 ------------------------
7138 -- Compile_Time_Error --
7139 ------------------------
7141 -- pragma Compile_Time_Error
7142 -- (boolean_EXPRESSION, static_string_EXPRESSION);
7144 when Pragma_Compile_Time_Error =>
7146 Process_Compile_Time_Warning_Or_Error;
7148 --------------------------
7149 -- Compile_Time_Warning --
7150 --------------------------
7152 -- pragma Compile_Time_Warning
7153 -- (boolean_EXPRESSION, static_string_EXPRESSION);
7155 when Pragma_Compile_Time_Warning =>
7157 Process_Compile_Time_Warning_Or_Error;
7163 when Pragma_Compiler_Unit =>
7165 Check_Arg_Count (0);
7166 Set_Is_Compiler_Unit (Get_Source_Unit (N));
7168 -----------------------------
7169 -- Complete_Representation --
7170 -----------------------------
7172 -- pragma Complete_Representation;
7174 when Pragma_Complete_Representation =>
7176 Check_Arg_Count (0);
7178 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
7180 ("pragma & must appear within record representation clause");
7183 ----------------------------
7184 -- Complex_Representation --
7185 ----------------------------
7187 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
7189 when Pragma_Complex_Representation => Complex_Representation : declare
7196 Check_Arg_Count (1);
7197 Check_Optional_Identifier (Arg1, Name_Entity);
7198 Check_Arg_Is_Local_Name (Arg1);
7199 E_Id := Get_Pragma_Arg (Arg1);
7201 if Etype (E_Id) = Any_Type then
7207 if not Is_Record_Type (E) then
7209 ("argument for pragma% must be record type", Arg1);
7212 Ent := First_Entity (E);
7215 or else No (Next_Entity (Ent))
7216 or else Present (Next_Entity (Next_Entity (Ent)))
7217 or else not Is_Floating_Point_Type (Etype (Ent))
7218 or else Etype (Ent) /= Etype (Next_Entity (Ent))
7221 ("record for pragma% must have two fields of the same "
7222 & "floating-point type", Arg1);
7225 Set_Has_Complex_Representation (Base_Type (E));
7227 -- We need to treat the type has having a non-standard
7228 -- representation, for back-end purposes, even though in
7229 -- general a complex will have the default representation
7230 -- of a record with two real components.
7232 Set_Has_Non_Standard_Rep (Base_Type (E));
7234 end Complex_Representation;
7236 -------------------------
7237 -- Component_Alignment --
7238 -------------------------
7240 -- pragma Component_Alignment (
7241 -- [Form =>] ALIGNMENT_CHOICE
7242 -- [, [Name =>] type_LOCAL_NAME]);
7244 -- ALIGNMENT_CHOICE ::=
7246 -- | Component_Size_4
7250 when Pragma_Component_Alignment => Component_AlignmentP : declare
7251 Args : Args_List (1 .. 2);
7252 Names : constant Name_List (1 .. 2) := (
7256 Form : Node_Id renames Args (1);
7257 Name : Node_Id renames Args (2);
7259 Atype : Component_Alignment_Kind;
7264 Gather_Associations (Names, Args);
7267 Error_Pragma ("missing Form argument for pragma%");
7270 Check_Arg_Is_Identifier (Form);
7272 -- Get proper alignment, note that Default = Component_Size on all
7273 -- machines we have so far, and we want to set this value rather
7274 -- than the default value to indicate that it has been explicitly
7275 -- set (and thus will not get overridden by the default component
7276 -- alignment for the current scope)
7278 if Chars (Form) = Name_Component_Size then
7279 Atype := Calign_Component_Size;
7281 elsif Chars (Form) = Name_Component_Size_4 then
7282 Atype := Calign_Component_Size_4;
7284 elsif Chars (Form) = Name_Default then
7285 Atype := Calign_Component_Size;
7287 elsif Chars (Form) = Name_Storage_Unit then
7288 Atype := Calign_Storage_Unit;
7292 ("invalid Form parameter for pragma%", Form);
7295 -- Case with no name, supplied, affects scope table entry
7299 (Scope_Stack.Last).Component_Alignment_Default := Atype;
7301 -- Case of name supplied
7304 Check_Arg_Is_Local_Name (Name);
7306 Typ := Entity (Name);
7309 or else Rep_Item_Too_Early (Typ, N)
7313 Typ := Underlying_Type (Typ);
7316 if not Is_Record_Type (Typ)
7317 and then not Is_Array_Type (Typ)
7320 ("Name parameter of pragma% must identify record or " &
7321 "array type", Name);
7324 -- An explicit Component_Alignment pragma overrides an
7325 -- implicit pragma Pack, but not an explicit one.
7327 if not Has_Pragma_Pack (Base_Type (Typ)) then
7328 Set_Is_Packed (Base_Type (Typ), False);
7329 Set_Component_Alignment (Base_Type (Typ), Atype);
7332 end Component_AlignmentP;
7338 -- pragma Controlled (first_subtype_LOCAL_NAME);
7340 when Pragma_Controlled => Controlled : declare
7344 Check_No_Identifiers;
7345 Check_Arg_Count (1);
7346 Check_Arg_Is_Local_Name (Arg1);
7347 Arg := Get_Pragma_Arg (Arg1);
7349 if not Is_Entity_Name (Arg)
7350 or else not Is_Access_Type (Entity (Arg))
7352 Error_Pragma_Arg ("pragma% requires access type", Arg1);
7354 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
7362 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
7363 -- [Entity =>] LOCAL_NAME);
7365 when Pragma_Convention => Convention : declare
7368 pragma Warnings (Off, C);
7369 pragma Warnings (Off, E);
7371 Check_Arg_Order ((Name_Convention, Name_Entity));
7372 Check_Ada_83_Warning;
7373 Check_Arg_Count (2);
7374 Process_Convention (C, E);
7377 ---------------------------
7378 -- Convention_Identifier --
7379 ---------------------------
7381 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
7382 -- [Convention =>] convention_IDENTIFIER);
7384 when Pragma_Convention_Identifier => Convention_Identifier : declare
7390 Check_Arg_Order ((Name_Name, Name_Convention));
7391 Check_Arg_Count (2);
7392 Check_Optional_Identifier (Arg1, Name_Name);
7393 Check_Optional_Identifier (Arg2, Name_Convention);
7394 Check_Arg_Is_Identifier (Arg1);
7395 Check_Arg_Is_Identifier (Arg2);
7396 Idnam := Chars (Get_Pragma_Arg (Arg1));
7397 Cname := Chars (Get_Pragma_Arg (Arg2));
7399 if Is_Convention_Name (Cname) then
7400 Record_Convention_Identifier
7401 (Idnam, Get_Convention_Id (Cname));
7404 ("second arg for % pragma must be convention", Arg2);
7406 end Convention_Identifier;
7412 -- pragma CPP_Class ([Entity =>] local_NAME)
7414 when Pragma_CPP_Class => CPP_Class : declare
7419 if Warn_On_Obsolescent_Feature then
7421 ("'G'N'A'T pragma cpp'_class is now obsolete; replace it" &
7422 " by pragma import?", N);
7426 Check_Arg_Count (1);
7427 Check_Optional_Identifier (Arg1, Name_Entity);
7428 Check_Arg_Is_Local_Name (Arg1);
7430 Arg := Get_Pragma_Arg (Arg1);
7433 if Etype (Arg) = Any_Type then
7437 if not Is_Entity_Name (Arg)
7438 or else not Is_Type (Entity (Arg))
7440 Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
7443 Typ := Entity (Arg);
7445 if not Is_Tagged_Type (Typ) then
7446 Error_Pragma_Arg ("pragma% applicable to tagged types ", Arg1);
7449 -- Types treated as CPP classes must be declared limited (note:
7450 -- this used to be a warning but there is no real benefit to it
7451 -- since we did effectively intend to treat the type as limited
7454 if not Is_Limited_Type (Typ) then
7456 ("imported 'C'P'P type must be limited",
7457 Get_Pragma_Arg (Arg1));
7460 Set_Is_CPP_Class (Typ);
7461 Set_Convention (Typ, Convention_CPP);
7463 -- Imported CPP types must not have discriminants (because C++
7464 -- classes do not have discriminants).
7466 if Has_Discriminants (Typ) then
7468 ("imported 'C'P'P type cannot have discriminants",
7469 First (Discriminant_Specifications
7470 (Declaration_Node (Typ))));
7473 -- Components of imported CPP types must not have default
7474 -- expressions because the constructor (if any) is in the
7477 if Is_Incomplete_Or_Private_Type (Typ)
7478 and then No (Underlying_Type (Typ))
7480 -- It should be an error to apply pragma CPP to a private
7481 -- type if the underlying type is not visible (as it is
7482 -- for any representation item). For now, for backward
7483 -- compatibility we do nothing but we cannot check components
7484 -- because they are not available at this stage. All this code
7485 -- will be removed when we cleanup this obsolete GNAT pragma???
7491 Tdef : constant Node_Id :=
7492 Type_Definition (Declaration_Node (Typ));
7497 if Nkind (Tdef) = N_Record_Definition then
7498 Clist := Component_List (Tdef);
7500 pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition);
7501 Clist := Component_List (Record_Extension_Part (Tdef));
7504 if Present (Clist) then
7505 Comp := First (Component_Items (Clist));
7506 while Present (Comp) loop
7507 if Present (Expression (Comp)) then
7509 ("component of imported 'C'P'P type cannot have" &
7510 " default expression", Expression (Comp));
7520 ---------------------
7521 -- CPP_Constructor --
7522 ---------------------
7524 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
7525 -- [, [External_Name =>] static_string_EXPRESSION ]
7526 -- [, [Link_Name =>] static_string_EXPRESSION ]);
7528 when Pragma_CPP_Constructor => CPP_Constructor : declare
7532 Tag_Typ : Entity_Id;
7536 Check_At_Least_N_Arguments (1);
7537 Check_At_Most_N_Arguments (3);
7538 Check_Optional_Identifier (Arg1, Name_Entity);
7539 Check_Arg_Is_Local_Name (Arg1);
7541 Id := Get_Pragma_Arg (Arg1);
7542 Find_Program_Unit_Name (Id);
7544 -- If we did not find the name, we are done
7546 if Etype (Id) = Any_Type then
7550 Def_Id := Entity (Id);
7552 -- Check if already defined as constructor
7554 if Is_Constructor (Def_Id) then
7556 ("?duplicate argument for pragma 'C'P'P_Constructor", Arg1);
7560 if Ekind (Def_Id) = E_Function
7561 and then (Is_CPP_Class (Etype (Def_Id))
7562 or else (Is_Class_Wide_Type (Etype (Def_Id))
7564 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
7566 if Arg_Count >= 2 then
7567 Set_Imported (Def_Id);
7568 Set_Is_Public (Def_Id);
7569 Process_Interface_Name (Def_Id, Arg2, Arg3);
7572 Set_Has_Completion (Def_Id);
7573 Set_Is_Constructor (Def_Id);
7575 -- Imported C++ constructors are not dispatching primitives
7576 -- because in C++ they don't have a dispatch table slot.
7577 -- However, in Ada the constructor has the profile of a
7578 -- function that returns a tagged type and therefore it has
7579 -- been treated as a primitive operation during semantic
7580 -- analysis. We now remove it from the list of primitive
7581 -- operations of the type.
7583 if Is_Tagged_Type (Etype (Def_Id))
7584 and then not Is_Class_Wide_Type (Etype (Def_Id))
7586 pragma Assert (Is_Dispatching_Operation (Def_Id));
7587 Tag_Typ := Etype (Def_Id);
7589 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
7590 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
7594 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
7595 Set_Is_Dispatching_Operation (Def_Id, False);
7598 -- For backward compatibility, if the constructor returns a
7599 -- class wide type, and we internally change the return type to
7600 -- the corresponding root type.
7602 if Is_Class_Wide_Type (Etype (Def_Id)) then
7603 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
7607 ("pragma% requires function returning a 'C'P'P_Class type",
7610 end CPP_Constructor;
7616 when Pragma_CPP_Virtual => CPP_Virtual : declare
7620 if Warn_On_Obsolescent_Feature then
7622 ("'G'N'A'T pragma cpp'_virtual is now obsolete and has " &
7631 when Pragma_CPP_Vtable => CPP_Vtable : declare
7635 if Warn_On_Obsolescent_Feature then
7637 ("'G'N'A'T pragma cpp'_vtable is now obsolete and has " &
7646 -- pragma CPU (EXPRESSION);
7648 when Pragma_CPU => CPU : declare
7649 P : constant Node_Id := Parent (N);
7654 Check_No_Identifiers;
7655 Check_Arg_Count (1);
7659 if Nkind (P) = N_Subprogram_Body then
7660 Check_In_Main_Program;
7662 Arg := Get_Pragma_Arg (Arg1);
7663 Analyze_And_Resolve (Arg, Any_Integer);
7667 if not Is_Static_Expression (Arg) then
7668 Flag_Non_Static_Expr
7669 ("main subprogram affinity is not static!", Arg);
7672 -- If constraint error, then we already signalled an error
7674 elsif Raises_Constraint_Error (Arg) then
7677 -- Otherwise check in range
7681 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
7682 -- This is the entity System.Multiprocessors.CPU_Range;
7684 Val : constant Uint := Expr_Value (Arg);
7687 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
7689 Val > Expr_Value (Type_High_Bound (CPU_Id))
7692 ("main subprogram CPU is out of range", Arg1);
7698 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
7702 elsif Nkind (P) = N_Task_Definition then
7703 Arg := Get_Pragma_Arg (Arg1);
7705 -- The expression must be analyzed in the special manner
7706 -- described in "Handling of Default and Per-Object
7707 -- Expressions" in sem.ads.
7709 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
7711 -- Anything else is incorrect
7717 if Has_Pragma_CPU (P) then
7718 Error_Pragma ("duplicate pragma% not allowed");
7720 Set_Has_Pragma_CPU (P, True);
7722 if Nkind (P) = N_Task_Definition then
7723 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
7732 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
7734 when Pragma_Debug => Debug : declare
7741 -- Skip analysis if disabled
7743 if Debug_Pragmas_Disabled then
7744 Rewrite (N, Make_Null_Statement (Loc));
7751 (Boolean_Literals (Debug_Pragmas_Enabled and Expander_Active),
7754 if Debug_Pragmas_Enabled then
7755 Set_SCO_Pragma_Enabled (Loc);
7758 if Arg_Count = 2 then
7761 Left_Opnd => Relocate_Node (Cond),
7762 Right_Opnd => Get_Pragma_Arg (Arg1));
7763 Call := Get_Pragma_Arg (Arg2);
7765 Call := Get_Pragma_Arg (Arg1);
7769 N_Indexed_Component,
7772 N_Selected_Component)
7774 -- If this pragma Debug comes from source, its argument was
7775 -- parsed as a name form (which is syntactically identical).
7776 -- Change it to a procedure call statement now.
7778 Change_Name_To_Procedure_Call_Statement (Call);
7780 elsif Nkind (Call) = N_Procedure_Call_Statement then
7782 -- Already in the form of a procedure call statement: nothing
7783 -- to do (could happen in case of an internally generated
7789 -- All other cases: diagnose error
7792 ("argument of pragma% is not procedure call", Sloc (Call));
7796 -- Rewrite into a conditional with an appropriate condition. We
7797 -- wrap the procedure call in a block so that overhead from e.g.
7798 -- use of the secondary stack does not generate execution overhead
7799 -- for suppressed conditions.
7801 Rewrite (N, Make_Implicit_If_Statement (N,
7803 Then_Statements => New_List (
7804 Make_Block_Statement (Loc,
7805 Handled_Statement_Sequence =>
7806 Make_Handled_Sequence_Of_Statements (Loc,
7807 Statements => New_List (Relocate_Node (Call)))))));
7815 -- pragma Debug_Policy (Check | Ignore)
7817 when Pragma_Debug_Policy =>
7819 Check_Arg_Count (1);
7820 Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Disable, Name_Ignore);
7821 Debug_Pragmas_Enabled :=
7822 Chars (Get_Pragma_Arg (Arg1)) = Name_Check;
7823 Debug_Pragmas_Disabled :=
7824 Chars (Get_Pragma_Arg (Arg1)) = Name_Disable;
7826 ---------------------
7827 -- Detect_Blocking --
7828 ---------------------
7830 -- pragma Detect_Blocking;
7832 when Pragma_Detect_Blocking =>
7834 Check_Arg_Count (0);
7835 Check_Valid_Configuration_Pragma;
7836 Detect_Blocking := True;
7838 --------------------------
7839 -- Default_Storage_Pool --
7840 --------------------------
7842 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
7844 when Pragma_Default_Storage_Pool =>
7846 Check_Arg_Count (1);
7848 -- Default_Storage_Pool can appear as a configuration pragma, or
7849 -- in a declarative part or a package spec.
7851 if not Is_Configuration_Pragma then
7852 Check_Is_In_Decl_Part_Or_Package_Spec;
7855 -- Case of Default_Storage_Pool (null);
7857 if Nkind (Expression (Arg1)) = N_Null then
7858 Analyze (Expression (Arg1));
7860 -- This is an odd case, this is not really an expression, so
7861 -- we don't have a type for it. So just set the type to Empty.
7863 Set_Etype (Expression (Arg1), Empty);
7865 -- Case of Default_Storage_Pool (storage_pool_NAME);
7868 -- If it's a configuration pragma, then the only allowed
7869 -- argument is "null".
7871 if Is_Configuration_Pragma then
7872 Error_Pragma_Arg ("NULL expected", Arg1);
7875 -- The expected type for a non-"null" argument is
7876 -- Root_Storage_Pool'Class.
7879 (Get_Pragma_Arg (Arg1),
7880 Typ => Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
7883 -- Finally, record the pool name (or null). Freeze.Freeze_Entity
7884 -- for an access type will use this information to set the
7885 -- appropriate attributes of the access type.
7887 Default_Pool := Expression (Arg1);
7893 when Pragma_Dimension =>
7895 Check_Arg_Count (4);
7896 Check_No_Identifiers;
7897 Check_Arg_Is_Local_Name (Arg1);
7899 if not Is_Type (Arg1) then
7900 Error_Pragma ("first argument for pragma% must be subtype");
7903 Check_Arg_Is_Static_Expression (Arg2, Standard_Integer);
7904 Check_Arg_Is_Static_Expression (Arg3, Standard_Integer);
7905 Check_Arg_Is_Static_Expression (Arg4, Standard_Integer);
7911 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
7913 when Pragma_Discard_Names => Discard_Names : declare
7918 Check_Ada_83_Warning;
7920 -- Deal with configuration pragma case
7922 if Arg_Count = 0 and then Is_Configuration_Pragma then
7923 Global_Discard_Names := True;
7926 -- Otherwise, check correct appropriate context
7929 Check_Is_In_Decl_Part_Or_Package_Spec;
7931 if Arg_Count = 0 then
7933 -- If there is no parameter, then from now on this pragma
7934 -- applies to any enumeration, exception or tagged type
7935 -- defined in the current declarative part, and recursively
7936 -- to any nested scope.
7938 Set_Discard_Names (Current_Scope);
7942 Check_Arg_Count (1);
7943 Check_Optional_Identifier (Arg1, Name_On);
7944 Check_Arg_Is_Local_Name (Arg1);
7946 E_Id := Get_Pragma_Arg (Arg1);
7948 if Etype (E_Id) = Any_Type then
7954 if (Is_First_Subtype (E)
7956 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
7957 or else Ekind (E) = E_Exception
7959 Set_Discard_Names (E);
7962 ("inappropriate entity for pragma%", Arg1);
7969 ------------------------
7970 -- Dispatching_Domain --
7971 ------------------------
7973 -- pragma Dispatching_Domain (EXPRESSION);
7975 when Pragma_Dispatching_Domain => Dispatching_Domain : declare
7976 P : constant Node_Id := Parent (N);
7981 Check_No_Identifiers;
7982 Check_Arg_Count (1);
7984 -- This pragma is born obsolete, but not the aspect
7986 if not From_Aspect_Specification (N) then
7988 (No_Obsolescent_Features, Pragma_Identifier (N));
7991 if Nkind (P) = N_Task_Definition then
7992 Arg := Get_Pragma_Arg (Arg1);
7994 -- The expression must be analyzed in the special manner
7995 -- described in "Handling of Default and Per-Object
7996 -- Expressions" in sem.ads.
7998 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
8000 -- Anything else is incorrect
8006 if Has_Pragma_Dispatching_Domain (P) then
8007 Error_Pragma ("duplicate pragma% not allowed");
8009 Set_Has_Pragma_Dispatching_Domain (P, True);
8011 if Nkind (P) = N_Task_Definition then
8012 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
8015 end Dispatching_Domain;
8021 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
8023 when Pragma_Elaborate => Elaborate : declare
8028 -- Pragma must be in context items list of a compilation unit
8030 if not Is_In_Context_Clause then
8034 -- Must be at least one argument
8036 if Arg_Count = 0 then
8037 Error_Pragma ("pragma% requires at least one argument");
8040 -- In Ada 83 mode, there can be no items following it in the
8041 -- context list except other pragmas and implicit with clauses
8042 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
8043 -- placement rule does not apply.
8045 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
8047 while Present (Citem) loop
8048 if Nkind (Citem) = N_Pragma
8049 or else (Nkind (Citem) = N_With_Clause
8050 and then Implicit_With (Citem))
8055 ("(Ada 83) pragma% must be at end of context clause");
8062 -- Finally, the arguments must all be units mentioned in a with
8063 -- clause in the same context clause. Note we already checked (in
8064 -- Par.Prag) that the arguments are all identifiers or selected
8068 Outer : while Present (Arg) loop
8069 Citem := First (List_Containing (N));
8070 Inner : while Citem /= N loop
8071 if Nkind (Citem) = N_With_Clause
8072 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
8074 Set_Elaborate_Present (Citem, True);
8075 Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
8076 Generate_Reference (Entity (Name (Citem)), Citem);
8078 -- With the pragma present, elaboration calls on
8079 -- subprograms from the named unit need no further
8080 -- checks, as long as the pragma appears in the current
8081 -- compilation unit. If the pragma appears in some unit
8082 -- in the context, there might still be a need for an
8083 -- Elaborate_All_Desirable from the current compilation
8084 -- to the named unit, so we keep the check enabled.
8086 if In_Extended_Main_Source_Unit (N) then
8087 Set_Suppress_Elaboration_Warnings
8088 (Entity (Name (Citem)));
8099 ("argument of pragma% is not with'ed unit", Arg);
8105 -- Give a warning if operating in static mode with -gnatwl
8106 -- (elaboration warnings enabled) switch set.
8108 if Elab_Warnings and not Dynamic_Elaboration_Checks then
8110 ("?use of pragma Elaborate may not be safe", N);
8112 ("?use pragma Elaborate_All instead if possible", N);
8120 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
8122 when Pragma_Elaborate_All => Elaborate_All : declare
8127 Check_Ada_83_Warning;
8129 -- Pragma must be in context items list of a compilation unit
8131 if not Is_In_Context_Clause then
8135 -- Must be at least one argument
8137 if Arg_Count = 0 then
8138 Error_Pragma ("pragma% requires at least one argument");
8141 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
8142 -- have to appear at the end of the context clause, but may
8143 -- appear mixed in with other items, even in Ada 83 mode.
8145 -- Final check: the arguments must all be units mentioned in
8146 -- a with clause in the same context clause. Note that we
8147 -- already checked (in Par.Prag) that all the arguments are
8148 -- either identifiers or selected components.
8151 Outr : while Present (Arg) loop
8152 Citem := First (List_Containing (N));
8153 Innr : while Citem /= N loop
8154 if Nkind (Citem) = N_With_Clause
8155 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
8157 Set_Elaborate_All_Present (Citem, True);
8158 Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
8160 -- Suppress warnings and elaboration checks on the named
8161 -- unit if the pragma is in the current compilation, as
8162 -- for pragma Elaborate.
8164 if In_Extended_Main_Source_Unit (N) then
8165 Set_Suppress_Elaboration_Warnings
8166 (Entity (Name (Citem)));
8175 Set_Error_Posted (N);
8177 ("argument of pragma% is not with'ed unit", Arg);
8184 --------------------
8185 -- Elaborate_Body --
8186 --------------------
8188 -- pragma Elaborate_Body [( library_unit_NAME )];
8190 when Pragma_Elaborate_Body => Elaborate_Body : declare
8191 Cunit_Node : Node_Id;
8192 Cunit_Ent : Entity_Id;
8195 Check_Ada_83_Warning;
8196 Check_Valid_Library_Unit_Pragma;
8198 if Nkind (N) = N_Null_Statement then
8202 Cunit_Node := Cunit (Current_Sem_Unit);
8203 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
8205 if Nkind_In (Unit (Cunit_Node), N_Package_Body,
8208 Error_Pragma ("pragma% must refer to a spec, not a body");
8210 Set_Body_Required (Cunit_Node, True);
8211 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
8213 -- If we are in dynamic elaboration mode, then we suppress
8214 -- elaboration warnings for the unit, since it is definitely
8215 -- fine NOT to do dynamic checks at the first level (and such
8216 -- checks will be suppressed because no elaboration boolean
8217 -- is created for Elaborate_Body packages).
8219 -- But in the static model of elaboration, Elaborate_Body is
8220 -- definitely NOT good enough to ensure elaboration safety on
8221 -- its own, since the body may WITH other units that are not
8222 -- safe from an elaboration point of view, so a client must
8223 -- still do an Elaborate_All on such units.
8225 -- Debug flag -gnatdD restores the old behavior of 3.13, where
8226 -- Elaborate_Body always suppressed elab warnings.
8228 if Dynamic_Elaboration_Checks or Debug_Flag_DD then
8229 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
8234 ------------------------
8235 -- Elaboration_Checks --
8236 ------------------------
8238 -- pragma Elaboration_Checks (Static | Dynamic);
8240 when Pragma_Elaboration_Checks =>
8242 Check_Arg_Count (1);
8243 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
8244 Dynamic_Elaboration_Checks :=
8245 (Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic);
8251 -- pragma Eliminate (
8252 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
8253 -- [,[Entity =>] IDENTIFIER |
8254 -- SELECTED_COMPONENT |
8256 -- [, OVERLOADING_RESOLUTION]);
8258 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
8261 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
8264 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
8266 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
8267 -- Result_Type => result_SUBTYPE_NAME]
8269 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
8270 -- SUBTYPE_NAME ::= STRING_LITERAL
8272 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
8273 -- SOURCE_TRACE ::= STRING_LITERAL
8275 when Pragma_Eliminate => Eliminate : declare
8276 Args : Args_List (1 .. 5);
8277 Names : constant Name_List (1 .. 5) := (
8280 Name_Parameter_Types,
8282 Name_Source_Location);
8284 Unit_Name : Node_Id renames Args (1);
8285 Entity : Node_Id renames Args (2);
8286 Parameter_Types : Node_Id renames Args (3);
8287 Result_Type : Node_Id renames Args (4);
8288 Source_Location : Node_Id renames Args (5);
8292 Check_Valid_Configuration_Pragma;
8293 Gather_Associations (Names, Args);
8295 if No (Unit_Name) then
8296 Error_Pragma ("missing Unit_Name argument for pragma%");
8300 and then (Present (Parameter_Types)
8302 Present (Result_Type)
8304 Present (Source_Location))
8306 Error_Pragma ("missing Entity argument for pragma%");
8309 if (Present (Parameter_Types)
8311 Present (Result_Type))
8313 Present (Source_Location)
8316 ("parameter profile and source location cannot " &
8317 "be used together in pragma%");
8320 Process_Eliminate_Pragma
8334 -- [ Convention =>] convention_IDENTIFIER,
8335 -- [ Entity =>] local_NAME
8336 -- [, [External_Name =>] static_string_EXPRESSION ]
8337 -- [, [Link_Name =>] static_string_EXPRESSION ]);
8339 when Pragma_Export => Export : declare
8343 pragma Warnings (Off, C);
8346 Check_Ada_83_Warning;
8352 Check_At_Least_N_Arguments (2);
8353 Check_At_Most_N_Arguments (4);
8354 Process_Convention (C, Def_Id);
8356 if Ekind (Def_Id) /= E_Constant then
8357 Note_Possible_Modification
8358 (Get_Pragma_Arg (Arg2), Sure => False);
8361 Process_Interface_Name (Def_Id, Arg3, Arg4);
8362 Set_Exported (Def_Id, Arg2);
8364 -- If the entity is a deferred constant, propagate the information
8365 -- to the full view, because gigi elaborates the full view only.
8367 if Ekind (Def_Id) = E_Constant
8368 and then Present (Full_View (Def_Id))
8371 Id2 : constant Entity_Id := Full_View (Def_Id);
8373 Set_Is_Exported (Id2, Is_Exported (Def_Id));
8374 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
8375 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
8380 ----------------------
8381 -- Export_Exception --
8382 ----------------------
8384 -- pragma Export_Exception (
8385 -- [Internal =>] LOCAL_NAME
8386 -- [, [External =>] EXTERNAL_SYMBOL]
8387 -- [, [Form =>] Ada | VMS]
8388 -- [, [Code =>] static_integer_EXPRESSION]);
8390 when Pragma_Export_Exception => Export_Exception : declare
8391 Args : Args_List (1 .. 4);
8392 Names : constant Name_List (1 .. 4) := (
8398 Internal : Node_Id renames Args (1);
8399 External : Node_Id renames Args (2);
8400 Form : Node_Id renames Args (3);
8401 Code : Node_Id renames Args (4);
8406 if Inside_A_Generic then
8407 Error_Pragma ("pragma% cannot be used for generic entities");
8410 Gather_Associations (Names, Args);
8411 Process_Extended_Import_Export_Exception_Pragma (
8412 Arg_Internal => Internal,
8413 Arg_External => External,
8417 if not Is_VMS_Exception (Entity (Internal)) then
8418 Set_Exported (Entity (Internal), Internal);
8420 end Export_Exception;
8422 ---------------------
8423 -- Export_Function --
8424 ---------------------
8426 -- pragma Export_Function (
8427 -- [Internal =>] LOCAL_NAME
8428 -- [, [External =>] EXTERNAL_SYMBOL]
8429 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
8430 -- [, [Result_Type =>] TYPE_DESIGNATOR]
8431 -- [, [Mechanism =>] MECHANISM]
8432 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
8434 -- EXTERNAL_SYMBOL ::=
8436 -- | static_string_EXPRESSION
8438 -- PARAMETER_TYPES ::=
8440 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
8442 -- TYPE_DESIGNATOR ::=
8444 -- | subtype_Name ' Access
8448 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
8450 -- MECHANISM_ASSOCIATION ::=
8451 -- [formal_parameter_NAME =>] MECHANISM_NAME
8453 -- MECHANISM_NAME ::=
8456 -- | Descriptor [([Class =>] CLASS_NAME)]
8458 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
8460 when Pragma_Export_Function => Export_Function : declare
8461 Args : Args_List (1 .. 6);
8462 Names : constant Name_List (1 .. 6) := (
8465 Name_Parameter_Types,
8468 Name_Result_Mechanism);
8470 Internal : Node_Id renames Args (1);
8471 External : Node_Id renames Args (2);
8472 Parameter_Types : Node_Id renames Args (3);
8473 Result_Type : Node_Id renames Args (4);
8474 Mechanism : Node_Id renames Args (5);
8475 Result_Mechanism : Node_Id renames Args (6);
8479 Gather_Associations (Names, Args);
8480 Process_Extended_Import_Export_Subprogram_Pragma (
8481 Arg_Internal => Internal,
8482 Arg_External => External,
8483 Arg_Parameter_Types => Parameter_Types,
8484 Arg_Result_Type => Result_Type,
8485 Arg_Mechanism => Mechanism,
8486 Arg_Result_Mechanism => Result_Mechanism);
8487 end Export_Function;
8493 -- pragma Export_Object (
8494 -- [Internal =>] LOCAL_NAME
8495 -- [, [External =>] EXTERNAL_SYMBOL]
8496 -- [, [Size =>] EXTERNAL_SYMBOL]);
8498 -- EXTERNAL_SYMBOL ::=
8500 -- | static_string_EXPRESSION
8502 -- PARAMETER_TYPES ::=
8504 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
8506 -- TYPE_DESIGNATOR ::=
8508 -- | subtype_Name ' Access
8512 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
8514 -- MECHANISM_ASSOCIATION ::=
8515 -- [formal_parameter_NAME =>] MECHANISM_NAME
8517 -- MECHANISM_NAME ::=
8520 -- | Descriptor [([Class =>] CLASS_NAME)]
8522 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
8524 when Pragma_Export_Object => Export_Object : declare
8525 Args : Args_List (1 .. 3);
8526 Names : constant Name_List (1 .. 3) := (
8531 Internal : Node_Id renames Args (1);
8532 External : Node_Id renames Args (2);
8533 Size : Node_Id renames Args (3);
8537 Gather_Associations (Names, Args);
8538 Process_Extended_Import_Export_Object_Pragma (
8539 Arg_Internal => Internal,
8540 Arg_External => External,
8544 ----------------------
8545 -- Export_Procedure --
8546 ----------------------
8548 -- pragma Export_Procedure (
8549 -- [Internal =>] LOCAL_NAME
8550 -- [, [External =>] EXTERNAL_SYMBOL]
8551 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
8552 -- [, [Mechanism =>] MECHANISM]);
8554 -- EXTERNAL_SYMBOL ::=
8556 -- | static_string_EXPRESSION
8558 -- PARAMETER_TYPES ::=
8560 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
8562 -- TYPE_DESIGNATOR ::=
8564 -- | subtype_Name ' Access
8568 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
8570 -- MECHANISM_ASSOCIATION ::=
8571 -- [formal_parameter_NAME =>] MECHANISM_NAME
8573 -- MECHANISM_NAME ::=
8576 -- | Descriptor [([Class =>] CLASS_NAME)]
8578 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
8580 when Pragma_Export_Procedure => Export_Procedure : declare
8581 Args : Args_List (1 .. 4);
8582 Names : constant Name_List (1 .. 4) := (
8585 Name_Parameter_Types,
8588 Internal : Node_Id renames Args (1);
8589 External : Node_Id renames Args (2);
8590 Parameter_Types : Node_Id renames Args (3);
8591 Mechanism : Node_Id renames Args (4);
8595 Gather_Associations (Names, Args);
8596 Process_Extended_Import_Export_Subprogram_Pragma (
8597 Arg_Internal => Internal,
8598 Arg_External => External,
8599 Arg_Parameter_Types => Parameter_Types,
8600 Arg_Mechanism => Mechanism);
8601 end Export_Procedure;
8607 -- pragma Export_Value (
8608 -- [Value =>] static_integer_EXPRESSION,
8609 -- [Link_Name =>] static_string_EXPRESSION);
8611 when Pragma_Export_Value =>
8613 Check_Arg_Order ((Name_Value, Name_Link_Name));
8614 Check_Arg_Count (2);
8616 Check_Optional_Identifier (Arg1, Name_Value);
8617 Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
8619 Check_Optional_Identifier (Arg2, Name_Link_Name);
8620 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
8622 -----------------------------
8623 -- Export_Valued_Procedure --
8624 -----------------------------
8626 -- pragma Export_Valued_Procedure (
8627 -- [Internal =>] LOCAL_NAME
8628 -- [, [External =>] EXTERNAL_SYMBOL,]
8629 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
8630 -- [, [Mechanism =>] MECHANISM]);
8632 -- EXTERNAL_SYMBOL ::=
8634 -- | static_string_EXPRESSION
8636 -- PARAMETER_TYPES ::=
8638 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
8640 -- TYPE_DESIGNATOR ::=
8642 -- | subtype_Name ' Access
8646 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
8648 -- MECHANISM_ASSOCIATION ::=
8649 -- [formal_parameter_NAME =>] MECHANISM_NAME
8651 -- MECHANISM_NAME ::=
8654 -- | Descriptor [([Class =>] CLASS_NAME)]
8656 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
8658 when Pragma_Export_Valued_Procedure =>
8659 Export_Valued_Procedure : declare
8660 Args : Args_List (1 .. 4);
8661 Names : constant Name_List (1 .. 4) := (
8664 Name_Parameter_Types,
8667 Internal : Node_Id renames Args (1);
8668 External : Node_Id renames Args (2);
8669 Parameter_Types : Node_Id renames Args (3);
8670 Mechanism : Node_Id renames Args (4);
8674 Gather_Associations (Names, Args);
8675 Process_Extended_Import_Export_Subprogram_Pragma (
8676 Arg_Internal => Internal,
8677 Arg_External => External,
8678 Arg_Parameter_Types => Parameter_Types,
8679 Arg_Mechanism => Mechanism);
8680 end Export_Valued_Procedure;
8686 -- pragma Extend_System ([Name =>] Identifier);
8688 when Pragma_Extend_System => Extend_System : declare
8691 Check_Valid_Configuration_Pragma;
8692 Check_Arg_Count (1);
8693 Check_Optional_Identifier (Arg1, Name_Name);
8694 Check_Arg_Is_Identifier (Arg1);
8696 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
8699 and then Name_Buffer (1 .. 4) = "aux_"
8701 if Present (System_Extend_Pragma_Arg) then
8702 if Chars (Get_Pragma_Arg (Arg1)) =
8703 Chars (Expression (System_Extend_Pragma_Arg))
8707 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
8708 Error_Pragma ("pragma% conflicts with that #");
8712 System_Extend_Pragma_Arg := Arg1;
8714 if not GNAT_Mode then
8715 System_Extend_Unit := Arg1;
8719 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
8723 ------------------------
8724 -- Extensions_Allowed --
8725 ------------------------
8727 -- pragma Extensions_Allowed (ON | OFF);
8729 when Pragma_Extensions_Allowed =>
8731 Check_Arg_Count (1);
8732 Check_No_Identifiers;
8733 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
8735 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
8736 Extensions_Allowed := True;
8737 Ada_Version := Ada_Version_Type'Last;
8740 Extensions_Allowed := False;
8741 Ada_Version := Ada_Version_Explicit;
8748 -- pragma External (
8749 -- [ Convention =>] convention_IDENTIFIER,
8750 -- [ Entity =>] local_NAME
8751 -- [, [External_Name =>] static_string_EXPRESSION ]
8752 -- [, [Link_Name =>] static_string_EXPRESSION ]);
8754 when Pragma_External => External : declare
8758 pragma Warnings (Off, C);
8767 Check_At_Least_N_Arguments (2);
8768 Check_At_Most_N_Arguments (4);
8769 Process_Convention (C, Def_Id);
8770 Note_Possible_Modification
8771 (Get_Pragma_Arg (Arg2), Sure => False);
8772 Process_Interface_Name (Def_Id, Arg3, Arg4);
8773 Set_Exported (Def_Id, Arg2);
8776 --------------------------
8777 -- External_Name_Casing --
8778 --------------------------
8780 -- pragma External_Name_Casing (
8781 -- UPPERCASE | LOWERCASE
8782 -- [, AS_IS | UPPERCASE | LOWERCASE]);
8784 when Pragma_External_Name_Casing => External_Name_Casing : declare
8787 Check_No_Identifiers;
8789 if Arg_Count = 2 then
8791 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
8793 case Chars (Get_Pragma_Arg (Arg2)) is
8795 Opt.External_Name_Exp_Casing := As_Is;
8797 when Name_Uppercase =>
8798 Opt.External_Name_Exp_Casing := Uppercase;
8800 when Name_Lowercase =>
8801 Opt.External_Name_Exp_Casing := Lowercase;
8808 Check_Arg_Count (1);
8811 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
8813 case Chars (Get_Pragma_Arg (Arg1)) is
8814 when Name_Uppercase =>
8815 Opt.External_Name_Imp_Casing := Uppercase;
8817 when Name_Lowercase =>
8818 Opt.External_Name_Imp_Casing := Lowercase;
8823 end External_Name_Casing;
8825 --------------------------
8826 -- Favor_Top_Level --
8827 --------------------------
8829 -- pragma Favor_Top_Level (type_NAME);
8831 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
8832 Named_Entity : Entity_Id;
8836 Check_No_Identifiers;
8837 Check_Arg_Count (1);
8838 Check_Arg_Is_Local_Name (Arg1);
8839 Named_Entity := Entity (Get_Pragma_Arg (Arg1));
8841 -- If it's an access-to-subprogram type (in particular, not a
8842 -- subtype), set the flag on that type.
8844 if Is_Access_Subprogram_Type (Named_Entity) then
8845 Set_Can_Use_Internal_Rep (Named_Entity, False);
8847 -- Otherwise it's an error (name denotes the wrong sort of entity)
8851 ("access-to-subprogram type expected",
8852 Get_Pragma_Arg (Arg1));
8854 end Favor_Top_Level;
8860 -- pragma Fast_Math;
8862 when Pragma_Fast_Math =>
8864 Check_No_Identifiers;
8865 Check_Valid_Configuration_Pragma;
8868 ---------------------------
8869 -- Finalize_Storage_Only --
8870 ---------------------------
8872 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
8874 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
8875 Assoc : constant Node_Id := Arg1;
8876 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
8881 Check_No_Identifiers;
8882 Check_Arg_Count (1);
8883 Check_Arg_Is_Local_Name (Arg1);
8885 Find_Type (Type_Id);
8886 Typ := Entity (Type_Id);
8889 or else Rep_Item_Too_Early (Typ, N)
8893 Typ := Underlying_Type (Typ);
8896 if not Is_Controlled (Typ) then
8897 Error_Pragma ("pragma% must specify controlled type");
8900 Check_First_Subtype (Arg1);
8902 if Finalize_Storage_Only (Typ) then
8903 Error_Pragma ("duplicate pragma%, only one allowed");
8905 elsif not Rep_Item_Too_Late (Typ, N) then
8906 Set_Finalize_Storage_Only (Base_Type (Typ), True);
8908 end Finalize_Storage;
8910 --------------------------
8911 -- Float_Representation --
8912 --------------------------
8914 -- pragma Float_Representation (FLOAT_REP[, float_type_LOCAL_NAME]);
8916 -- FLOAT_REP ::= VAX_Float | IEEE_Float
8918 when Pragma_Float_Representation => Float_Representation : declare
8926 if Arg_Count = 1 then
8927 Check_Valid_Configuration_Pragma;
8929 Check_Arg_Count (2);
8930 Check_Optional_Identifier (Arg2, Name_Entity);
8931 Check_Arg_Is_Local_Name (Arg2);
8934 Check_No_Identifier (Arg1);
8935 Check_Arg_Is_One_Of (Arg1, Name_VAX_Float, Name_IEEE_Float);
8937 if not OpenVMS_On_Target then
8938 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
8940 ("?pragma% ignored (applies only to Open'V'M'S)");
8946 -- One argument case
8948 if Arg_Count = 1 then
8949 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
8950 if Opt.Float_Format = 'I' then
8951 Error_Pragma ("'I'E'E'E format previously specified");
8954 Opt.Float_Format := 'V';
8957 if Opt.Float_Format = 'V' then
8958 Error_Pragma ("'V'A'X format previously specified");
8961 Opt.Float_Format := 'I';
8964 Set_Standard_Fpt_Formats;
8966 -- Two argument case
8969 Argx := Get_Pragma_Arg (Arg2);
8971 if not Is_Entity_Name (Argx)
8972 or else not Is_Floating_Point_Type (Entity (Argx))
8975 ("second argument of% pragma must be floating-point type",
8979 Ent := Entity (Argx);
8980 Digs := UI_To_Int (Digits_Value (Ent));
8982 -- Two arguments, VAX_Float case
8984 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
8986 when 6 => Set_F_Float (Ent);
8987 when 9 => Set_D_Float (Ent);
8988 when 15 => Set_G_Float (Ent);
8992 ("wrong digits value, must be 6,9 or 15", Arg2);
8995 -- Two arguments, IEEE_Float case
8999 when 6 => Set_IEEE_Short (Ent);
9000 when 15 => Set_IEEE_Long (Ent);
9004 ("wrong digits value, must be 6 or 15", Arg2);
9008 end Float_Representation;
9014 -- pragma Ident (static_string_EXPRESSION)
9016 -- Note: pragma Comment shares this processing. Pragma Comment is
9017 -- identical to Ident, except that the restriction of the argument to
9018 -- 31 characters and the placement restrictions are not enforced for
9021 when Pragma_Ident | Pragma_Comment => Ident : declare
9026 Check_Arg_Count (1);
9027 Check_No_Identifiers;
9028 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
9031 -- For pragma Ident, preserve DEC compatibility by requiring the
9032 -- pragma to appear in a declarative part or package spec.
9034 if Prag_Id = Pragma_Ident then
9035 Check_Is_In_Decl_Part_Or_Package_Spec;
9038 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
9045 GP := Parent (Parent (N));
9047 if Nkind_In (GP, N_Package_Declaration,
9048 N_Generic_Package_Declaration)
9053 -- If we have a compilation unit, then record the ident value,
9054 -- checking for improper duplication.
9056 if Nkind (GP) = N_Compilation_Unit then
9057 CS := Ident_String (Current_Sem_Unit);
9059 if Present (CS) then
9061 -- For Ident, we do not permit multiple instances
9063 if Prag_Id = Pragma_Ident then
9064 Error_Pragma ("duplicate% pragma not permitted");
9066 -- For Comment, we concatenate the string, unless we want
9067 -- to preserve the tree structure for ASIS.
9069 elsif not ASIS_Mode then
9070 Start_String (Strval (CS));
9071 Store_String_Char (' ');
9072 Store_String_Chars (Strval (Str));
9073 Set_Strval (CS, End_String);
9077 -- In VMS, the effect of IDENT is achieved by passing
9078 -- --identification=name as a --for-linker switch.
9080 if OpenVMS_On_Target then
9083 ("--for-linker=--identification=");
9084 String_To_Name_Buffer (Strval (Str));
9085 Store_String_Chars (Name_Buffer (1 .. Name_Len));
9087 -- Only the last processed IDENT is saved. The main
9088 -- purpose is so an IDENT associated with a main
9089 -- procedure will be used in preference to an IDENT
9090 -- associated with a with'd package.
9092 Replace_Linker_Option_String
9093 (End_String, "--for-linker=--identification=");
9096 Set_Ident_String (Current_Sem_Unit, Str);
9099 -- For subunits, we just ignore the Ident, since in GNAT these
9100 -- are not separate object files, and hence not separate units
9101 -- in the unit table.
9103 elsif Nkind (GP) = N_Subunit then
9106 -- Otherwise we have a misplaced pragma Ident, but we ignore
9107 -- this if we are in an instantiation, since it comes from
9108 -- a generic, and has no relevance to the instantiation.
9110 elsif Prag_Id = Pragma_Ident then
9111 if Instantiation_Location (Loc) = No_Location then
9112 Error_Pragma ("pragma% only allowed at outer level");
9122 -- pragma Implemented (procedure_LOCAL_NAME, implementation_kind);
9123 -- implementation_kind ::= By_Entry | By_Protected_Procedure | By_Any
9125 when Pragma_Implemented => Implemented : declare
9126 Proc_Id : Entity_Id;
9131 Check_Arg_Count (2);
9132 Check_No_Identifiers;
9133 Check_Arg_Is_Identifier (Arg1);
9134 Check_Arg_Is_Local_Name (Arg1);
9136 (Arg2, Name_By_Any, Name_By_Entry, Name_By_Protected_Procedure);
9138 -- Extract the name of the local procedure
9140 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
9142 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
9143 -- primitive procedure of a synchronized tagged type.
9145 if Ekind (Proc_Id) = E_Procedure
9146 and then Is_Primitive (Proc_Id)
9147 and then Present (First_Formal (Proc_Id))
9149 Typ := Etype (First_Formal (Proc_Id));
9151 if Is_Tagged_Type (Typ)
9154 -- Check for a protected, a synchronized or a task interface
9156 ((Is_Interface (Typ)
9157 and then Is_Synchronized_Interface (Typ))
9159 -- Check for a protected type or a task type that implements
9163 (Is_Concurrent_Record_Type (Typ)
9164 and then Present (Interfaces (Typ)))
9166 -- Check for a private record extension with keyword
9170 (Ekind_In (Typ, E_Record_Type_With_Private,
9171 E_Record_Subtype_With_Private)
9172 and then Synchronized_Present (Parent (Typ))))
9177 ("controlling formal must be of synchronized " &
9178 "tagged type", Arg1);
9182 -- Procedures declared inside a protected type must be accepted
9184 elsif Ekind (Proc_Id) = E_Procedure
9185 and then Is_Protected_Type (Scope (Proc_Id))
9189 -- The first argument is not a primitive procedure
9193 ("pragma % must be applied to a primitive procedure", Arg1);
9197 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
9198 -- By_Protected_Procedure to the primitive procedure of a task
9201 if Chars (Arg2) = Name_By_Protected_Procedure
9202 and then Is_Interface (Typ)
9203 and then Is_Task_Interface (Typ)
9206 ("implementation kind By_Protected_Procedure cannot be " &
9207 "applied to a task interface primitive", Arg2);
9211 Record_Rep_Item (Proc_Id, N);
9214 ----------------------
9215 -- Implicit_Packing --
9216 ----------------------
9218 -- pragma Implicit_Packing;
9220 when Pragma_Implicit_Packing =>
9222 Check_Arg_Count (0);
9223 Implicit_Packing := True;
9230 -- [Convention =>] convention_IDENTIFIER,
9231 -- [Entity =>] local_NAME
9232 -- [, [External_Name =>] static_string_EXPRESSION ]
9233 -- [, [Link_Name =>] static_string_EXPRESSION ]);
9235 when Pragma_Import =>
9236 Check_Ada_83_Warning;
9242 Check_At_Least_N_Arguments (2);
9243 Check_At_Most_N_Arguments (4);
9244 Process_Import_Or_Interface;
9246 ----------------------
9247 -- Import_Exception --
9248 ----------------------
9250 -- pragma Import_Exception (
9251 -- [Internal =>] LOCAL_NAME
9252 -- [, [External =>] EXTERNAL_SYMBOL]
9253 -- [, [Form =>] Ada | VMS]
9254 -- [, [Code =>] static_integer_EXPRESSION]);
9256 when Pragma_Import_Exception => Import_Exception : declare
9257 Args : Args_List (1 .. 4);
9258 Names : constant Name_List (1 .. 4) := (
9264 Internal : Node_Id renames Args (1);
9265 External : Node_Id renames Args (2);
9266 Form : Node_Id renames Args (3);
9267 Code : Node_Id renames Args (4);
9271 Gather_Associations (Names, Args);
9273 if Present (External) and then Present (Code) then
9275 ("cannot give both External and Code options for pragma%");
9278 Process_Extended_Import_Export_Exception_Pragma (
9279 Arg_Internal => Internal,
9280 Arg_External => External,
9284 if not Is_VMS_Exception (Entity (Internal)) then
9285 Set_Imported (Entity (Internal));
9287 end Import_Exception;
9289 ---------------------
9290 -- Import_Function --
9291 ---------------------
9293 -- pragma Import_Function (
9294 -- [Internal =>] LOCAL_NAME,
9295 -- [, [External =>] EXTERNAL_SYMBOL]
9296 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
9297 -- [, [Result_Type =>] SUBTYPE_MARK]
9298 -- [, [Mechanism =>] MECHANISM]
9299 -- [, [Result_Mechanism =>] MECHANISM_NAME]
9300 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
9302 -- EXTERNAL_SYMBOL ::=
9304 -- | static_string_EXPRESSION
9306 -- PARAMETER_TYPES ::=
9308 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
9310 -- TYPE_DESIGNATOR ::=
9312 -- | subtype_Name ' Access
9316 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
9318 -- MECHANISM_ASSOCIATION ::=
9319 -- [formal_parameter_NAME =>] MECHANISM_NAME
9321 -- MECHANISM_NAME ::=
9324 -- | Descriptor [([Class =>] CLASS_NAME)]
9326 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
9328 when Pragma_Import_Function => Import_Function : declare
9329 Args : Args_List (1 .. 7);
9330 Names : constant Name_List (1 .. 7) := (
9333 Name_Parameter_Types,
9336 Name_Result_Mechanism,
9337 Name_First_Optional_Parameter);
9339 Internal : Node_Id renames Args (1);
9340 External : Node_Id renames Args (2);
9341 Parameter_Types : Node_Id renames Args (3);
9342 Result_Type : Node_Id renames Args (4);
9343 Mechanism : Node_Id renames Args (5);
9344 Result_Mechanism : Node_Id renames Args (6);
9345 First_Optional_Parameter : Node_Id renames Args (7);
9349 Gather_Associations (Names, Args);
9350 Process_Extended_Import_Export_Subprogram_Pragma (
9351 Arg_Internal => Internal,
9352 Arg_External => External,
9353 Arg_Parameter_Types => Parameter_Types,
9354 Arg_Result_Type => Result_Type,
9355 Arg_Mechanism => Mechanism,
9356 Arg_Result_Mechanism => Result_Mechanism,
9357 Arg_First_Optional_Parameter => First_Optional_Parameter);
9358 end Import_Function;
9364 -- pragma Import_Object (
9365 -- [Internal =>] LOCAL_NAME
9366 -- [, [External =>] EXTERNAL_SYMBOL]
9367 -- [, [Size =>] EXTERNAL_SYMBOL]);
9369 -- EXTERNAL_SYMBOL ::=
9371 -- | static_string_EXPRESSION
9373 when Pragma_Import_Object => Import_Object : declare
9374 Args : Args_List (1 .. 3);
9375 Names : constant Name_List (1 .. 3) := (
9380 Internal : Node_Id renames Args (1);
9381 External : Node_Id renames Args (2);
9382 Size : Node_Id renames Args (3);
9386 Gather_Associations (Names, Args);
9387 Process_Extended_Import_Export_Object_Pragma (
9388 Arg_Internal => Internal,
9389 Arg_External => External,
9393 ----------------------
9394 -- Import_Procedure --
9395 ----------------------
9397 -- pragma Import_Procedure (
9398 -- [Internal =>] LOCAL_NAME
9399 -- [, [External =>] EXTERNAL_SYMBOL]
9400 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
9401 -- [, [Mechanism =>] MECHANISM]
9402 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
9404 -- EXTERNAL_SYMBOL ::=
9406 -- | static_string_EXPRESSION
9408 -- PARAMETER_TYPES ::=
9410 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
9412 -- TYPE_DESIGNATOR ::=
9414 -- | subtype_Name ' Access
9418 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
9420 -- MECHANISM_ASSOCIATION ::=
9421 -- [formal_parameter_NAME =>] MECHANISM_NAME
9423 -- MECHANISM_NAME ::=
9426 -- | Descriptor [([Class =>] CLASS_NAME)]
9428 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
9430 when Pragma_Import_Procedure => Import_Procedure : declare
9431 Args : Args_List (1 .. 5);
9432 Names : constant Name_List (1 .. 5) := (
9435 Name_Parameter_Types,
9437 Name_First_Optional_Parameter);
9439 Internal : Node_Id renames Args (1);
9440 External : Node_Id renames Args (2);
9441 Parameter_Types : Node_Id renames Args (3);
9442 Mechanism : Node_Id renames Args (4);
9443 First_Optional_Parameter : Node_Id renames Args (5);
9447 Gather_Associations (Names, Args);
9448 Process_Extended_Import_Export_Subprogram_Pragma (
9449 Arg_Internal => Internal,
9450 Arg_External => External,
9451 Arg_Parameter_Types => Parameter_Types,
9452 Arg_Mechanism => Mechanism,
9453 Arg_First_Optional_Parameter => First_Optional_Parameter);
9454 end Import_Procedure;
9456 -----------------------------
9457 -- Import_Valued_Procedure --
9458 -----------------------------
9460 -- pragma Import_Valued_Procedure (
9461 -- [Internal =>] LOCAL_NAME
9462 -- [, [External =>] EXTERNAL_SYMBOL]
9463 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
9464 -- [, [Mechanism =>] MECHANISM]
9465 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
9467 -- EXTERNAL_SYMBOL ::=
9469 -- | static_string_EXPRESSION
9471 -- PARAMETER_TYPES ::=
9473 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
9475 -- TYPE_DESIGNATOR ::=
9477 -- | subtype_Name ' Access
9481 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
9483 -- MECHANISM_ASSOCIATION ::=
9484 -- [formal_parameter_NAME =>] MECHANISM_NAME
9486 -- MECHANISM_NAME ::=
9489 -- | Descriptor [([Class =>] CLASS_NAME)]
9491 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
9493 when Pragma_Import_Valued_Procedure =>
9494 Import_Valued_Procedure : declare
9495 Args : Args_List (1 .. 5);
9496 Names : constant Name_List (1 .. 5) := (
9499 Name_Parameter_Types,
9501 Name_First_Optional_Parameter);
9503 Internal : Node_Id renames Args (1);
9504 External : Node_Id renames Args (2);
9505 Parameter_Types : Node_Id renames Args (3);
9506 Mechanism : Node_Id renames Args (4);
9507 First_Optional_Parameter : Node_Id renames Args (5);
9511 Gather_Associations (Names, Args);
9512 Process_Extended_Import_Export_Subprogram_Pragma (
9513 Arg_Internal => Internal,
9514 Arg_External => External,
9515 Arg_Parameter_Types => Parameter_Types,
9516 Arg_Mechanism => Mechanism,
9517 Arg_First_Optional_Parameter => First_Optional_Parameter);
9518 end Import_Valued_Procedure;
9524 -- pragma Independent (LOCAL_NAME);
9526 when Pragma_Independent => Independent : declare
9533 Check_Ada_83_Warning;
9535 Check_No_Identifiers;
9536 Check_Arg_Count (1);
9537 Check_Arg_Is_Local_Name (Arg1);
9538 E_Id := Get_Pragma_Arg (Arg1);
9540 if Etype (E_Id) = Any_Type then
9545 D := Declaration_Node (E);
9548 -- Check duplicate before we chain ourselves!
9550 Check_Duplicate_Pragma (E);
9552 -- Check appropriate entity
9555 if Rep_Item_Too_Early (E, N)
9557 Rep_Item_Too_Late (E, N)
9561 Check_First_Subtype (Arg1);
9564 elsif K = N_Object_Declaration
9565 or else (K = N_Component_Declaration
9566 and then Original_Record_Component (E) = E)
9568 if Rep_Item_Too_Late (E, N) then
9574 ("inappropriate entity for pragma%", Arg1);
9577 Independence_Checks.Append ((N, E));
9580 ----------------------------
9581 -- Independent_Components --
9582 ----------------------------
9584 -- pragma Atomic_Components (array_LOCAL_NAME);
9586 -- This processing is shared by Volatile_Components
9588 when Pragma_Independent_Components => Independent_Components : declare
9595 Check_Ada_83_Warning;
9597 Check_No_Identifiers;
9598 Check_Arg_Count (1);
9599 Check_Arg_Is_Local_Name (Arg1);
9600 E_Id := Get_Pragma_Arg (Arg1);
9602 if Etype (E_Id) = Any_Type then
9608 -- Check duplicate before we chain ourselves!
9610 Check_Duplicate_Pragma (E);
9612 -- Check appropriate entity
9614 if Rep_Item_Too_Early (E, N)
9616 Rep_Item_Too_Late (E, N)
9621 D := Declaration_Node (E);
9624 if (K = N_Full_Type_Declaration
9625 and then (Is_Array_Type (E) or else Is_Record_Type (E)))
9627 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
9628 and then Nkind (D) = N_Object_Declaration
9629 and then Nkind (Object_Definition (D)) =
9630 N_Constrained_Array_Definition)
9632 Independence_Checks.Append ((N, E));
9635 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
9637 end Independent_Components;
9639 ------------------------
9640 -- Initialize_Scalars --
9641 ------------------------
9643 -- pragma Initialize_Scalars;
9645 when Pragma_Initialize_Scalars =>
9647 Check_Arg_Count (0);
9648 Check_Valid_Configuration_Pragma;
9649 Check_Restriction (No_Initialize_Scalars, N);
9651 -- Initialize_Scalars creates false positives in CodePeer, and
9652 -- incorrect negative results in Alfa mode, so ignore this pragma
9655 if not Restriction_Active (No_Initialize_Scalars)
9656 and then not (CodePeer_Mode or Alfa_Mode)
9658 Init_Or_Norm_Scalars := True;
9659 Initialize_Scalars := True;
9666 -- pragma Inline ( NAME {, NAME} );
9668 when Pragma_Inline =>
9670 -- Pragma is active if inlining option is active
9672 Process_Inline (Inline_Active);
9678 -- pragma Inline_Always ( NAME {, NAME} );
9680 when Pragma_Inline_Always =>
9683 -- Pragma always active unless in CodePeer or Alfa mode, since
9684 -- this causes walk order issues.
9686 if not (CodePeer_Mode or Alfa_Mode) then
9687 Process_Inline (True);
9690 --------------------
9691 -- Inline_Generic --
9692 --------------------
9694 -- pragma Inline_Generic (NAME {, NAME});
9696 when Pragma_Inline_Generic =>
9698 Process_Generic_List;
9700 ----------------------
9701 -- Inspection_Point --
9702 ----------------------
9704 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
9706 when Pragma_Inspection_Point => Inspection_Point : declare
9711 if Arg_Count > 0 then
9714 Exp := Get_Pragma_Arg (Arg);
9717 if not Is_Entity_Name (Exp)
9718 or else not Is_Object (Entity (Exp))
9720 Error_Pragma_Arg ("object name required", Arg);
9727 end Inspection_Point;
9733 -- pragma Interface (
9734 -- [ Convention =>] convention_IDENTIFIER,
9735 -- [ Entity =>] local_NAME
9736 -- [, [External_Name =>] static_string_EXPRESSION ]
9737 -- [, [Link_Name =>] static_string_EXPRESSION ]);
9739 when Pragma_Interface =>
9746 Check_At_Least_N_Arguments (2);
9747 Check_At_Most_N_Arguments (4);
9748 Process_Import_Or_Interface;
9750 -- In Ada 2005, the permission to use Interface (a reserved word)
9751 -- as a pragma name is considered an obsolescent feature.
9753 if Ada_Version >= Ada_2005 then
9755 (No_Obsolescent_Features, Pragma_Identifier (N));
9758 --------------------
9759 -- Interface_Name --
9760 --------------------
9762 -- pragma Interface_Name (
9763 -- [ Entity =>] local_NAME
9764 -- [,[External_Name =>] static_string_EXPRESSION ]
9765 -- [,[Link_Name =>] static_string_EXPRESSION ]);
9767 when Pragma_Interface_Name => Interface_Name : declare
9776 ((Name_Entity, Name_External_Name, Name_Link_Name));
9777 Check_At_Least_N_Arguments (2);
9778 Check_At_Most_N_Arguments (3);
9779 Id := Get_Pragma_Arg (Arg1);
9782 if not Is_Entity_Name (Id) then
9784 ("first argument for pragma% must be entity name", Arg1);
9785 elsif Etype (Id) = Any_Type then
9788 Def_Id := Entity (Id);
9791 -- Special DEC-compatible processing for the object case, forces
9792 -- object to be imported.
9794 if Ekind (Def_Id) = E_Variable then
9795 Kill_Size_Check_Code (Def_Id);
9796 Note_Possible_Modification (Id, Sure => False);
9798 -- Initialization is not allowed for imported variable
9800 if Present (Expression (Parent (Def_Id)))
9801 and then Comes_From_Source (Expression (Parent (Def_Id)))
9803 Error_Msg_Sloc := Sloc (Def_Id);
9805 ("no initialization allowed for declaration of& #",
9809 -- For compatibility, support VADS usage of providing both
9810 -- pragmas Interface and Interface_Name to obtain the effect
9811 -- of a single Import pragma.
9813 if Is_Imported (Def_Id)
9814 and then Present (First_Rep_Item (Def_Id))
9815 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
9817 Pragma_Name (First_Rep_Item (Def_Id)) = Name_Interface
9821 Set_Imported (Def_Id);
9824 Set_Is_Public (Def_Id);
9825 Process_Interface_Name (Def_Id, Arg2, Arg3);
9828 -- Otherwise must be subprogram
9830 elsif not Is_Subprogram (Def_Id) then
9832 ("argument of pragma% is not subprogram", Arg1);
9835 Check_At_Most_N_Arguments (3);
9839 -- Loop through homonyms
9842 Def_Id := Get_Base_Subprogram (Hom_Id);
9844 if Is_Imported (Def_Id) then
9845 Process_Interface_Name (Def_Id, Arg2, Arg3);
9849 exit when From_Aspect_Specification (N);
9850 Hom_Id := Homonym (Hom_Id);
9852 exit when No (Hom_Id)
9853 or else Scope (Hom_Id) /= Current_Scope;
9858 ("argument of pragma% is not imported subprogram",
9864 -----------------------
9865 -- Interrupt_Handler --
9866 -----------------------
9868 -- pragma Interrupt_Handler (handler_NAME);
9870 when Pragma_Interrupt_Handler =>
9871 Check_Ada_83_Warning;
9872 Check_Arg_Count (1);
9873 Check_No_Identifiers;
9875 if No_Run_Time_Mode then
9876 Error_Msg_CRT ("Interrupt_Handler pragma", N);
9878 Check_Interrupt_Or_Attach_Handler;
9879 Process_Interrupt_Or_Attach_Handler;
9882 ------------------------
9883 -- Interrupt_Priority --
9884 ------------------------
9886 -- pragma Interrupt_Priority [(EXPRESSION)];
9888 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
9889 P : constant Node_Id := Parent (N);
9893 Check_Ada_83_Warning;
9895 if Arg_Count /= 0 then
9896 Arg := Get_Pragma_Arg (Arg1);
9897 Check_Arg_Count (1);
9898 Check_No_Identifiers;
9900 -- The expression must be analyzed in the special manner
9901 -- described in "Handling of Default and Per-Object
9902 -- Expressions" in sem.ads.
9904 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
9907 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
9911 elsif Has_Pragma_Priority (P) then
9912 Error_Pragma ("duplicate pragma% not allowed");
9915 Set_Has_Pragma_Priority (P, True);
9916 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
9918 end Interrupt_Priority;
9920 ---------------------
9921 -- Interrupt_State --
9922 ---------------------
9924 -- pragma Interrupt_State (
9925 -- [Name =>] INTERRUPT_ID,
9926 -- [State =>] INTERRUPT_STATE);
9928 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
9929 -- INTERRUPT_STATE => System | Runtime | User
9931 -- Note: if the interrupt id is given as an identifier, then it must
9932 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
9933 -- given as a static integer expression which must be in the range of
9934 -- Ada.Interrupts.Interrupt_ID.
9936 when Pragma_Interrupt_State => Interrupt_State : declare
9938 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
9939 -- This is the entity Ada.Interrupts.Interrupt_ID;
9941 State_Type : Character;
9942 -- Set to 's'/'r'/'u' for System/Runtime/User
9945 -- Index to entry in Interrupt_States table
9948 -- Value of interrupt
9950 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
9951 -- The first argument to the pragma
9953 Int_Ent : Entity_Id;
9954 -- Interrupt entity in Ada.Interrupts.Names
9958 Check_Arg_Order ((Name_Name, Name_State));
9959 Check_Arg_Count (2);
9961 Check_Optional_Identifier (Arg1, Name_Name);
9962 Check_Optional_Identifier (Arg2, Name_State);
9963 Check_Arg_Is_Identifier (Arg2);
9965 -- First argument is identifier
9967 if Nkind (Arg1X) = N_Identifier then
9969 -- Search list of names in Ada.Interrupts.Names
9971 Int_Ent := First_Entity (RTE (RE_Names));
9973 if No (Int_Ent) then
9974 Error_Pragma_Arg ("invalid interrupt name", Arg1);
9976 elsif Chars (Int_Ent) = Chars (Arg1X) then
9977 Int_Val := Expr_Value (Constant_Value (Int_Ent));
9981 Next_Entity (Int_Ent);
9984 -- First argument is not an identifier, so it must be a static
9985 -- expression of type Ada.Interrupts.Interrupt_ID.
9988 Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
9989 Int_Val := Expr_Value (Arg1X);
9991 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
9993 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
9996 ("value not in range of type " &
9997 """Ada.Interrupts.Interrupt_'I'D""", Arg1);
10003 case Chars (Get_Pragma_Arg (Arg2)) is
10004 when Name_Runtime => State_Type := 'r';
10005 when Name_System => State_Type := 's';
10006 when Name_User => State_Type := 'u';
10009 Error_Pragma_Arg ("invalid interrupt state", Arg2);
10012 -- Check if entry is already stored
10014 IST_Num := Interrupt_States.First;
10016 -- If entry not found, add it
10018 if IST_Num > Interrupt_States.Last then
10019 Interrupt_States.Append
10020 ((Interrupt_Number => UI_To_Int (Int_Val),
10021 Interrupt_State => State_Type,
10022 Pragma_Loc => Loc));
10025 -- Case of entry for the same entry
10027 elsif Int_Val = Interrupt_States.Table (IST_Num).
10030 -- If state matches, done, no need to make redundant entry
10033 State_Type = Interrupt_States.Table (IST_Num).
10036 -- Otherwise if state does not match, error
10039 Interrupt_States.Table (IST_Num).Pragma_Loc;
10041 ("state conflicts with that given #", Arg2);
10045 IST_Num := IST_Num + 1;
10047 end Interrupt_State;
10053 -- pragma Invariant
10054 -- ([Entity =>] type_LOCAL_NAME,
10055 -- [Check =>] EXPRESSION
10056 -- [,[Message =>] String_Expression]);
10058 when Pragma_Invariant => Invariant : declare
10063 pragma Unreferenced (Discard);
10067 Check_At_Least_N_Arguments (2);
10068 Check_At_Most_N_Arguments (3);
10069 Check_Optional_Identifier (Arg1, Name_Entity);
10070 Check_Optional_Identifier (Arg2, Name_Check);
10072 if Arg_Count = 3 then
10073 Check_Optional_Identifier (Arg3, Name_Message);
10074 Check_Arg_Is_Static_Expression (Arg3, Standard_String);
10077 Check_Arg_Is_Local_Name (Arg1);
10079 Type_Id := Get_Pragma_Arg (Arg1);
10080 Find_Type (Type_Id);
10081 Typ := Entity (Type_Id);
10083 if Typ = Any_Type then
10086 elsif not Ekind_In (Typ, E_Private_Type,
10087 E_Record_Type_With_Private,
10088 E_Limited_Private_Type)
10091 ("pragma% only allowed for private type", Arg1);
10094 -- Note that the type has at least one invariant, and also that
10095 -- it has inheritable invariants if we have Invariant'Class.
10097 Set_Has_Invariants (Typ);
10099 if Class_Present (N) then
10100 Set_Has_Inheritable_Invariants (Typ);
10103 -- The remaining processing is simply to link the pragma on to
10104 -- the rep item chain, for processing when the type is frozen.
10105 -- This is accomplished by a call to Rep_Item_Too_Late.
10107 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
10110 ----------------------
10111 -- Java_Constructor --
10112 ----------------------
10114 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
10116 -- Also handles pragma CIL_Constructor
10118 when Pragma_CIL_Constructor | Pragma_Java_Constructor =>
10119 Java_Constructor : declare
10120 Convention : Convention_Id;
10121 Def_Id : Entity_Id;
10122 Hom_Id : Entity_Id;
10124 This_Formal : Entity_Id;
10128 Check_Arg_Count (1);
10129 Check_Optional_Identifier (Arg1, Name_Entity);
10130 Check_Arg_Is_Local_Name (Arg1);
10132 Id := Get_Pragma_Arg (Arg1);
10133 Find_Program_Unit_Name (Id);
10135 -- If we did not find the name, we are done
10137 if Etype (Id) = Any_Type then
10141 -- Check wrong use of pragma in wrong VM target
10143 if VM_Target = No_VM then
10146 elsif VM_Target = CLI_Target
10147 and then Prag_Id = Pragma_Java_Constructor
10149 Error_Pragma ("must use pragma 'C'I'L_'Constructor");
10151 elsif VM_Target = JVM_Target
10152 and then Prag_Id = Pragma_CIL_Constructor
10154 Error_Pragma ("must use pragma 'Java_'Constructor");
10158 when Pragma_CIL_Constructor => Convention := Convention_CIL;
10159 when Pragma_Java_Constructor => Convention := Convention_Java;
10160 when others => null;
10163 Hom_Id := Entity (Id);
10165 -- Loop through homonyms
10168 Def_Id := Get_Base_Subprogram (Hom_Id);
10170 -- The constructor is required to be a function
10172 if Ekind (Def_Id) /= E_Function then
10173 if VM_Target = JVM_Target then
10175 ("pragma% requires function returning a " &
10176 "'Java access type", Def_Id);
10179 ("pragma% requires function returning a " &
10180 "'C'I'L access type", Def_Id);
10184 -- Check arguments: For tagged type the first formal must be
10185 -- named "this" and its type must be a named access type
10186 -- designating a class-wide tagged type that has convention
10187 -- CIL/Java. The first formal must also have a null default
10188 -- value. For example:
10190 -- type Typ is tagged ...
10191 -- type Ref is access all Typ;
10192 -- pragma Convention (CIL, Typ);
10194 -- function New_Typ (This : Ref) return Ref;
10195 -- function New_Typ (This : Ref; I : Integer) return Ref;
10196 -- pragma Cil_Constructor (New_Typ);
10198 -- Reason: The first formal must NOT be a primitive of the
10201 -- This rule also applies to constructors of delegates used
10202 -- to interface with standard target libraries. For example:
10204 -- type Delegate is access procedure ...
10205 -- pragma Import (CIL, Delegate, ...);
10207 -- function new_Delegate
10208 -- (This : Delegate := null; ... ) return Delegate;
10210 -- For value-types this rule does not apply.
10212 if not Is_Value_Type (Etype (Def_Id)) then
10213 if No (First_Formal (Def_Id)) then
10214 Error_Msg_Name_1 := Pname;
10215 Error_Msg_N ("% function must have parameters", Def_Id);
10219 -- In the JRE library we have several occurrences in which
10220 -- the "this" parameter is not the first formal.
10222 This_Formal := First_Formal (Def_Id);
10224 -- In the JRE library we have several occurrences in which
10225 -- the "this" parameter is not the first formal. Search for
10228 if VM_Target = JVM_Target then
10229 while Present (This_Formal)
10230 and then Get_Name_String (Chars (This_Formal)) /= "this"
10232 Next_Formal (This_Formal);
10235 if No (This_Formal) then
10236 This_Formal := First_Formal (Def_Id);
10240 -- Warning: The first parameter should be named "this".
10241 -- We temporarily allow it because we have the following
10242 -- case in the Java runtime (file s-osinte.ads) ???
10244 -- function new_Thread
10245 -- (Self_Id : System.Address) return Thread_Id;
10246 -- pragma Java_Constructor (new_Thread);
10248 if VM_Target = JVM_Target
10249 and then Get_Name_String (Chars (First_Formal (Def_Id)))
10251 and then Etype (First_Formal (Def_Id)) = RTE (RE_Address)
10255 elsif Get_Name_String (Chars (This_Formal)) /= "this" then
10256 Error_Msg_Name_1 := Pname;
10258 ("first formal of % function must be named `this`",
10259 Parent (This_Formal));
10261 elsif not Is_Access_Type (Etype (This_Formal)) then
10262 Error_Msg_Name_1 := Pname;
10264 ("first formal of % function must be an access type",
10265 Parameter_Type (Parent (This_Formal)));
10267 -- For delegates the type of the first formal must be a
10268 -- named access-to-subprogram type (see previous example)
10270 elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type
10271 and then Ekind (Etype (This_Formal))
10272 /= E_Access_Subprogram_Type
10274 Error_Msg_Name_1 := Pname;
10276 ("first formal of % function must be a named access" &
10277 " to subprogram type",
10278 Parameter_Type (Parent (This_Formal)));
10280 -- Warning: We should reject anonymous access types because
10281 -- the constructor must not be handled as a primitive of the
10282 -- tagged type. We temporarily allow it because this profile
10283 -- is currently generated by cil2ada???
10285 elsif Ekind (Etype (Def_Id)) /= E_Access_Subprogram_Type
10286 and then not Ekind_In (Etype (This_Formal),
10288 E_General_Access_Type,
10289 E_Anonymous_Access_Type)
10291 Error_Msg_Name_1 := Pname;
10293 ("first formal of % function must be a named access" &
10295 Parameter_Type (Parent (This_Formal)));
10297 elsif Atree.Convention
10298 (Designated_Type (Etype (This_Formal))) /= Convention
10300 Error_Msg_Name_1 := Pname;
10302 if Convention = Convention_Java then
10304 ("pragma% requires convention 'Cil in designated" &
10306 Parameter_Type (Parent (This_Formal)));
10309 ("pragma% requires convention 'Java in designated" &
10311 Parameter_Type (Parent (This_Formal)));
10314 elsif No (Expression (Parent (This_Formal)))
10315 or else Nkind (Expression (Parent (This_Formal))) /= N_Null
10317 Error_Msg_Name_1 := Pname;
10319 ("pragma% requires first formal with default `null`",
10320 Parameter_Type (Parent (This_Formal)));
10324 -- Check result type: the constructor must be a function
10326 -- * a value type (only allowed in the CIL compiler)
10327 -- * an access-to-subprogram type with convention Java/CIL
10328 -- * an access-type designating a type that has convention
10331 if Is_Value_Type (Etype (Def_Id)) then
10334 -- Access-to-subprogram type with convention Java/CIL
10336 elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type then
10337 if Atree.Convention (Etype (Def_Id)) /= Convention then
10338 if Convention = Convention_Java then
10340 ("pragma% requires function returning a " &
10341 "'Java access type", Arg1);
10343 pragma Assert (Convention = Convention_CIL);
10345 ("pragma% requires function returning a " &
10346 "'C'I'L access type", Arg1);
10350 elsif Ekind (Etype (Def_Id)) in Access_Kind then
10351 if not Ekind_In (Etype (Def_Id), E_Access_Type,
10352 E_General_Access_Type)
10355 (Designated_Type (Etype (Def_Id))) /= Convention
10357 Error_Msg_Name_1 := Pname;
10359 if Convention = Convention_Java then
10361 ("pragma% requires function returning a named" &
10362 "'Java access type", Arg1);
10365 ("pragma% requires function returning a named" &
10366 "'C'I'L access type", Arg1);
10371 Set_Is_Constructor (Def_Id);
10372 Set_Convention (Def_Id, Convention);
10373 Set_Is_Imported (Def_Id);
10375 exit when From_Aspect_Specification (N);
10376 Hom_Id := Homonym (Hom_Id);
10378 exit when No (Hom_Id) or else Scope (Hom_Id) /= Current_Scope;
10380 end Java_Constructor;
10382 ----------------------
10383 -- Java_Interface --
10384 ----------------------
10386 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
10388 when Pragma_Java_Interface => Java_Interface : declare
10394 Check_Arg_Count (1);
10395 Check_Optional_Identifier (Arg1, Name_Entity);
10396 Check_Arg_Is_Local_Name (Arg1);
10398 Arg := Get_Pragma_Arg (Arg1);
10401 if Etype (Arg) = Any_Type then
10405 if not Is_Entity_Name (Arg)
10406 or else not Is_Type (Entity (Arg))
10408 Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
10411 Typ := Underlying_Type (Entity (Arg));
10413 -- For now simply check some of the semantic constraints on the
10414 -- type. This currently leaves out some restrictions on interface
10415 -- types, namely that the parent type must be java.lang.Object.Typ
10416 -- and that all primitives of the type should be declared
10419 if not Is_Tagged_Type (Typ) or else not Is_Abstract_Type (Typ) then
10420 Error_Pragma_Arg ("pragma% requires an abstract "
10421 & "tagged type", Arg1);
10423 elsif not Has_Discriminants (Typ)
10424 or else Ekind (Etype (First_Discriminant (Typ)))
10425 /= E_Anonymous_Access_Type
10427 not Is_Class_Wide_Type
10428 (Designated_Type (Etype (First_Discriminant (Typ))))
10431 ("type must have a class-wide access discriminant", Arg1);
10433 end Java_Interface;
10439 -- pragma Keep_Names ([On => ] local_NAME);
10441 when Pragma_Keep_Names => Keep_Names : declare
10446 Check_Arg_Count (1);
10447 Check_Optional_Identifier (Arg1, Name_On);
10448 Check_Arg_Is_Local_Name (Arg1);
10450 Arg := Get_Pragma_Arg (Arg1);
10453 if Etype (Arg) = Any_Type then
10457 if not Is_Entity_Name (Arg)
10458 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
10461 ("pragma% requires a local enumeration type", Arg1);
10464 Set_Discard_Names (Entity (Arg), False);
10471 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
10473 when Pragma_License =>
10475 Check_Arg_Count (1);
10476 Check_No_Identifiers;
10477 Check_Valid_Configuration_Pragma;
10478 Check_Arg_Is_Identifier (Arg1);
10481 Sind : constant Source_File_Index :=
10482 Source_Index (Current_Sem_Unit);
10485 case Chars (Get_Pragma_Arg (Arg1)) is
10487 Set_License (Sind, GPL);
10489 when Name_Modified_GPL =>
10490 Set_License (Sind, Modified_GPL);
10492 when Name_Restricted =>
10493 Set_License (Sind, Restricted);
10495 when Name_Unrestricted =>
10496 Set_License (Sind, Unrestricted);
10499 Error_Pragma_Arg ("invalid license name", Arg1);
10507 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
10509 when Pragma_Link_With => Link_With : declare
10515 if Operating_Mode = Generate_Code
10516 and then In_Extended_Main_Source_Unit (N)
10518 Check_At_Least_N_Arguments (1);
10519 Check_No_Identifiers;
10520 Check_Is_In_Decl_Part_Or_Package_Spec;
10521 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
10525 while Present (Arg) loop
10526 Check_Arg_Is_Static_Expression (Arg, Standard_String);
10528 -- Store argument, converting sequences of spaces to a
10529 -- single null character (this is one of the differences
10530 -- in processing between Link_With and Linker_Options).
10532 Arg_Store : declare
10533 C : constant Char_Code := Get_Char_Code (' ');
10534 S : constant String_Id :=
10535 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
10536 L : constant Nat := String_Length (S);
10539 procedure Skip_Spaces;
10540 -- Advance F past any spaces
10546 procedure Skip_Spaces is
10548 while F <= L and then Get_String_Char (S, F) = C loop
10553 -- Start of processing for Arg_Store
10556 Skip_Spaces; -- skip leading spaces
10558 -- Loop through characters, changing any embedded
10559 -- sequence of spaces to a single null character (this
10560 -- is how Link_With/Linker_Options differ)
10563 if Get_String_Char (S, F) = C then
10566 Store_String_Char (ASCII.NUL);
10569 Store_String_Char (Get_String_Char (S, F));
10577 if Present (Arg) then
10578 Store_String_Char (ASCII.NUL);
10582 Store_Linker_Option_String (End_String);
10590 -- pragma Linker_Alias (
10591 -- [Entity =>] LOCAL_NAME
10592 -- [Target =>] static_string_EXPRESSION);
10594 when Pragma_Linker_Alias =>
10596 Check_Arg_Order ((Name_Entity, Name_Target));
10597 Check_Arg_Count (2);
10598 Check_Optional_Identifier (Arg1, Name_Entity);
10599 Check_Optional_Identifier (Arg2, Name_Target);
10600 Check_Arg_Is_Library_Level_Local_Name (Arg1);
10601 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
10603 -- The only processing required is to link this item on to the
10604 -- list of rep items for the given entity. This is accomplished
10605 -- by the call to Rep_Item_Too_Late (when no error is detected
10606 -- and False is returned).
10608 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
10611 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
10614 ------------------------
10615 -- Linker_Constructor --
10616 ------------------------
10618 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
10620 -- Code is shared with Linker_Destructor
10622 -----------------------
10623 -- Linker_Destructor --
10624 -----------------------
10626 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
10628 when Pragma_Linker_Constructor |
10629 Pragma_Linker_Destructor =>
10630 Linker_Constructor : declare
10636 Check_Arg_Count (1);
10637 Check_No_Identifiers;
10638 Check_Arg_Is_Local_Name (Arg1);
10639 Arg1_X := Get_Pragma_Arg (Arg1);
10641 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
10643 if not Is_Library_Level_Entity (Proc) then
10645 ("argument for pragma% must be library level entity", Arg1);
10648 -- The only processing required is to link this item on to the
10649 -- list of rep items for the given entity. This is accomplished
10650 -- by the call to Rep_Item_Too_Late (when no error is detected
10651 -- and False is returned).
10653 if Rep_Item_Too_Late (Proc, N) then
10656 Set_Has_Gigi_Rep_Item (Proc);
10658 end Linker_Constructor;
10660 --------------------
10661 -- Linker_Options --
10662 --------------------
10664 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
10666 when Pragma_Linker_Options => Linker_Options : declare
10670 Check_Ada_83_Warning;
10671 Check_No_Identifiers;
10672 Check_Arg_Count (1);
10673 Check_Is_In_Decl_Part_Or_Package_Spec;
10674 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
10675 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
10678 while Present (Arg) loop
10679 Check_Arg_Is_Static_Expression (Arg, Standard_String);
10680 Store_String_Char (ASCII.NUL);
10682 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
10686 if Operating_Mode = Generate_Code
10687 and then In_Extended_Main_Source_Unit (N)
10689 Store_Linker_Option_String (End_String);
10691 end Linker_Options;
10693 --------------------
10694 -- Linker_Section --
10695 --------------------
10697 -- pragma Linker_Section (
10698 -- [Entity =>] LOCAL_NAME
10699 -- [Section =>] static_string_EXPRESSION);
10701 when Pragma_Linker_Section =>
10703 Check_Arg_Order ((Name_Entity, Name_Section));
10704 Check_Arg_Count (2);
10705 Check_Optional_Identifier (Arg1, Name_Entity);
10706 Check_Optional_Identifier (Arg2, Name_Section);
10707 Check_Arg_Is_Library_Level_Local_Name (Arg1);
10708 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
10710 -- This pragma applies only to objects
10712 if not Is_Object (Entity (Get_Pragma_Arg (Arg1))) then
10713 Error_Pragma_Arg ("pragma% applies only to objects", Arg1);
10716 -- The only processing required is to link this item on to the
10717 -- list of rep items for the given entity. This is accomplished
10718 -- by the call to Rep_Item_Too_Late (when no error is detected
10719 -- and False is returned).
10721 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
10724 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
10731 -- pragma List (On | Off)
10733 -- There is nothing to do here, since we did all the processing for
10734 -- this pragma in Par.Prag (so that it works properly even in syntax
10737 when Pragma_List =>
10740 --------------------
10741 -- Locking_Policy --
10742 --------------------
10744 -- pragma Locking_Policy (policy_IDENTIFIER);
10746 when Pragma_Locking_Policy => declare
10750 Check_Ada_83_Warning;
10751 Check_Arg_Count (1);
10752 Check_No_Identifiers;
10753 Check_Arg_Is_Locking_Policy (Arg1);
10754 Check_Valid_Configuration_Pragma;
10755 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
10756 LP := Fold_Upper (Name_Buffer (1));
10758 if Locking_Policy /= ' '
10759 and then Locking_Policy /= LP
10761 Error_Msg_Sloc := Locking_Policy_Sloc;
10762 Error_Pragma ("locking policy incompatible with policy#");
10764 -- Set new policy, but always preserve System_Location since we
10765 -- like the error message with the run time name.
10768 Locking_Policy := LP;
10770 if Locking_Policy_Sloc /= System_Location then
10771 Locking_Policy_Sloc := Loc;
10780 -- pragma Long_Float (D_Float | G_Float);
10782 when Pragma_Long_Float =>
10784 Check_Valid_Configuration_Pragma;
10785 Check_Arg_Count (1);
10786 Check_No_Identifier (Arg1);
10787 Check_Arg_Is_One_Of (Arg1, Name_D_Float, Name_G_Float);
10789 if not OpenVMS_On_Target then
10790 Error_Pragma ("?pragma% ignored (applies only to Open'V'M'S)");
10795 if Chars (Get_Pragma_Arg (Arg1)) = Name_D_Float then
10796 if Opt.Float_Format_Long = 'G' then
10797 Error_Pragma ("G_Float previously specified");
10800 Opt.Float_Format_Long := 'D';
10802 -- G_Float case (this is the default, does not need overriding)
10805 if Opt.Float_Format_Long = 'D' then
10806 Error_Pragma ("D_Float previously specified");
10809 Opt.Float_Format_Long := 'G';
10812 Set_Standard_Fpt_Formats;
10814 -----------------------
10815 -- Machine_Attribute --
10816 -----------------------
10818 -- pragma Machine_Attribute (
10819 -- [Entity =>] LOCAL_NAME,
10820 -- [Attribute_Name =>] static_string_EXPRESSION
10821 -- [, [Info =>] static_EXPRESSION] );
10823 when Pragma_Machine_Attribute => Machine_Attribute : declare
10824 Def_Id : Entity_Id;
10828 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
10830 if Arg_Count = 3 then
10831 Check_Optional_Identifier (Arg3, Name_Info);
10832 Check_Arg_Is_Static_Expression (Arg3);
10834 Check_Arg_Count (2);
10837 Check_Optional_Identifier (Arg1, Name_Entity);
10838 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
10839 Check_Arg_Is_Local_Name (Arg1);
10840 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
10841 Def_Id := Entity (Get_Pragma_Arg (Arg1));
10843 if Is_Access_Type (Def_Id) then
10844 Def_Id := Designated_Type (Def_Id);
10847 if Rep_Item_Too_Early (Def_Id, N) then
10851 Def_Id := Underlying_Type (Def_Id);
10853 -- The only processing required is to link this item on to the
10854 -- list of rep items for the given entity. This is accomplished
10855 -- by the call to Rep_Item_Too_Late (when no error is detected
10856 -- and False is returned).
10858 if Rep_Item_Too_Late (Def_Id, N) then
10861 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
10863 end Machine_Attribute;
10870 -- (MAIN_OPTION [, MAIN_OPTION]);
10873 -- [STACK_SIZE =>] static_integer_EXPRESSION
10874 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
10875 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
10877 when Pragma_Main => Main : declare
10878 Args : Args_List (1 .. 3);
10879 Names : constant Name_List (1 .. 3) := (
10881 Name_Task_Stack_Size_Default,
10882 Name_Time_Slicing_Enabled);
10888 Gather_Associations (Names, Args);
10890 for J in 1 .. 2 loop
10891 if Present (Args (J)) then
10892 Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
10896 if Present (Args (3)) then
10897 Check_Arg_Is_Static_Expression (Args (3), Standard_Boolean);
10901 while Present (Nod) loop
10902 if Nkind (Nod) = N_Pragma
10903 and then Pragma_Name (Nod) = Name_Main
10905 Error_Msg_Name_1 := Pname;
10906 Error_Msg_N ("duplicate pragma% not permitted", Nod);
10917 -- pragma Main_Storage
10918 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
10920 -- MAIN_STORAGE_OPTION ::=
10921 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
10922 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
10924 when Pragma_Main_Storage => Main_Storage : declare
10925 Args : Args_List (1 .. 2);
10926 Names : constant Name_List (1 .. 2) := (
10927 Name_Working_Storage,
10934 Gather_Associations (Names, Args);
10936 for J in 1 .. 2 loop
10937 if Present (Args (J)) then
10938 Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
10942 Check_In_Main_Program;
10945 while Present (Nod) loop
10946 if Nkind (Nod) = N_Pragma
10947 and then Pragma_Name (Nod) = Name_Main_Storage
10949 Error_Msg_Name_1 := Pname;
10950 Error_Msg_N ("duplicate pragma% not permitted", Nod);
10961 -- pragma Memory_Size (NUMERIC_LITERAL)
10963 when Pragma_Memory_Size =>
10966 -- Memory size is simply ignored
10968 Check_No_Identifiers;
10969 Check_Arg_Count (1);
10970 Check_Arg_Is_Integer_Literal (Arg1);
10978 -- The only correct use of this pragma is on its own in a file, in
10979 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
10980 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
10981 -- check for a file containing nothing but a No_Body pragma). If we
10982 -- attempt to process it during normal semantics processing, it means
10983 -- it was misplaced.
10985 when Pragma_No_Body =>
10993 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
10995 when Pragma_No_Return => No_Return : declare
11003 Check_At_Least_N_Arguments (1);
11005 -- Loop through arguments of pragma
11008 while Present (Arg) loop
11009 Check_Arg_Is_Local_Name (Arg);
11010 Id := Get_Pragma_Arg (Arg);
11013 if not Is_Entity_Name (Id) then
11014 Error_Pragma_Arg ("entity name required", Arg);
11017 if Etype (Id) = Any_Type then
11021 -- Loop to find matching procedures
11026 and then Scope (E) = Current_Scope
11028 if Ekind_In (E, E_Procedure, E_Generic_Procedure) then
11031 -- Set flag on any alias as well
11033 if Is_Overloadable (E) and then Present (Alias (E)) then
11034 Set_No_Return (Alias (E));
11040 exit when From_Aspect_Specification (N);
11045 Error_Pragma_Arg ("no procedure & found for pragma%", Arg);
11056 -- pragma No_Run_Time;
11058 -- Note: this pragma is retained for backwards compatibility. See
11059 -- body of Rtsfind for full details on its handling.
11061 when Pragma_No_Run_Time =>
11063 Check_Valid_Configuration_Pragma;
11064 Check_Arg_Count (0);
11066 No_Run_Time_Mode := True;
11067 Configurable_Run_Time_Mode := True;
11069 -- Set Duration to 32 bits if word size is 32
11071 if Ttypes.System_Word_Size = 32 then
11072 Duration_32_Bits_On_Target := True;
11075 -- Set appropriate restrictions
11077 Set_Restriction (No_Finalization, N);
11078 Set_Restriction (No_Exception_Handlers, N);
11079 Set_Restriction (Max_Tasks, N, 0);
11080 Set_Restriction (No_Tasking, N);
11082 ------------------------
11083 -- No_Strict_Aliasing --
11084 ------------------------
11086 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
11088 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
11093 Check_At_Most_N_Arguments (1);
11095 if Arg_Count = 0 then
11096 Check_Valid_Configuration_Pragma;
11097 Opt.No_Strict_Aliasing := True;
11100 Check_Optional_Identifier (Arg2, Name_Entity);
11101 Check_Arg_Is_Local_Name (Arg1);
11102 E_Id := Entity (Get_Pragma_Arg (Arg1));
11104 if E_Id = Any_Type then
11106 elsif No (E_Id) or else not Is_Access_Type (E_Id) then
11107 Error_Pragma_Arg ("pragma% requires access type", Arg1);
11110 Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id));
11112 end No_Strict_Aliasing;
11114 -----------------------
11115 -- Normalize_Scalars --
11116 -----------------------
11118 -- pragma Normalize_Scalars;
11120 when Pragma_Normalize_Scalars =>
11121 Check_Ada_83_Warning;
11122 Check_Arg_Count (0);
11123 Check_Valid_Configuration_Pragma;
11125 -- Normalize_Scalars creates false positives in CodePeer, and
11126 -- incorrect negative results in Alfa mode, so ignore this pragma
11129 if not (CodePeer_Mode or Alfa_Mode) then
11130 Normalize_Scalars := True;
11131 Init_Or_Norm_Scalars := True;
11138 -- pragma Obsolescent;
11140 -- pragma Obsolescent (
11141 -- [Message =>] static_string_EXPRESSION
11142 -- [,[Version =>] Ada_05]]);
11144 -- pragma Obsolescent (
11145 -- [Entity =>] NAME
11146 -- [,[Message =>] static_string_EXPRESSION
11147 -- [,[Version =>] Ada_05]] );
11149 when Pragma_Obsolescent => Obsolescent : declare
11153 procedure Set_Obsolescent (E : Entity_Id);
11154 -- Given an entity Ent, mark it as obsolescent if appropriate
11156 ---------------------
11157 -- Set_Obsolescent --
11158 ---------------------
11160 procedure Set_Obsolescent (E : Entity_Id) is
11169 -- Entity name was given
11171 if Present (Ename) then
11173 -- If entity name matches, we are fine. Save entity in
11174 -- pragma argument, for ASIS use.
11176 if Chars (Ename) = Chars (Ent) then
11177 Set_Entity (Ename, Ent);
11178 Generate_Reference (Ent, Ename);
11180 -- If entity name does not match, only possibility is an
11181 -- enumeration literal from an enumeration type declaration.
11183 elsif Ekind (Ent) /= E_Enumeration_Type then
11185 ("pragma % entity name does not match declaration");
11188 Ent := First_Literal (E);
11192 ("pragma % entity name does not match any " &
11193 "enumeration literal");
11195 elsif Chars (Ent) = Chars (Ename) then
11196 Set_Entity (Ename, Ent);
11197 Generate_Reference (Ent, Ename);
11201 Ent := Next_Literal (Ent);
11207 -- Ent points to entity to be marked
11209 if Arg_Count >= 1 then
11211 -- Deal with static string argument
11213 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
11214 S := Strval (Get_Pragma_Arg (Arg1));
11216 for J in 1 .. String_Length (S) loop
11217 if not In_Character_Range (Get_String_Char (S, J)) then
11219 ("pragma% argument does not allow wide characters",
11224 Obsolescent_Warnings.Append
11225 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
11227 -- Check for Ada_05 parameter
11229 if Arg_Count /= 1 then
11230 Check_Arg_Count (2);
11233 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
11236 Check_Arg_Is_Identifier (Argx);
11238 if Chars (Argx) /= Name_Ada_05 then
11239 Error_Msg_Name_2 := Name_Ada_05;
11241 ("only allowed argument for pragma% is %", Argx);
11244 if Ada_Version_Explicit < Ada_2005
11245 or else not Warn_On_Ada_2005_Compatibility
11253 -- Set flag if pragma active
11256 Set_Is_Obsolescent (Ent);
11260 end Set_Obsolescent;
11262 -- Start of processing for pragma Obsolescent
11267 Check_At_Most_N_Arguments (3);
11269 -- See if first argument specifies an entity name
11273 (Chars (Arg1) = Name_Entity
11275 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
11277 N_Operator_Symbol))
11279 Ename := Get_Pragma_Arg (Arg1);
11281 -- Eliminate first argument, so we can share processing
11285 Arg_Count := Arg_Count - 1;
11287 -- No Entity name argument given
11293 if Arg_Count >= 1 then
11294 Check_Optional_Identifier (Arg1, Name_Message);
11296 if Arg_Count = 2 then
11297 Check_Optional_Identifier (Arg2, Name_Version);
11301 -- Get immediately preceding declaration
11304 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
11308 -- Cases where we do not follow anything other than another pragma
11312 -- First case: library level compilation unit declaration with
11313 -- the pragma immediately following the declaration.
11315 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
11317 (Defining_Entity (Unit (Parent (Parent (N)))));
11320 -- Case 2: library unit placement for package
11324 Ent : constant Entity_Id := Find_Lib_Unit_Name;
11326 if Is_Package_Or_Generic_Package (Ent) then
11327 Set_Obsolescent (Ent);
11333 -- Cases where we must follow a declaration
11336 if Nkind (Decl) not in N_Declaration
11337 and then Nkind (Decl) not in N_Later_Decl_Item
11338 and then Nkind (Decl) not in N_Generic_Declaration
11339 and then Nkind (Decl) not in N_Renaming_Declaration
11342 ("pragma% misplaced, "
11343 & "must immediately follow a declaration");
11346 Set_Obsolescent (Defining_Entity (Decl));
11356 -- pragma Optimize (Time | Space | Off);
11358 -- The actual check for optimize is done in Gigi. Note that this
11359 -- pragma does not actually change the optimization setting, it
11360 -- simply checks that it is consistent with the pragma.
11362 when Pragma_Optimize =>
11363 Check_No_Identifiers;
11364 Check_Arg_Count (1);
11365 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
11367 ------------------------
11368 -- Optimize_Alignment --
11369 ------------------------
11371 -- pragma Optimize_Alignment (Time | Space | Off);
11373 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
11375 Check_No_Identifiers;
11376 Check_Arg_Count (1);
11377 Check_Valid_Configuration_Pragma;
11380 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
11384 Opt.Optimize_Alignment := 'T';
11386 Opt.Optimize_Alignment := 'S';
11388 Opt.Optimize_Alignment := 'O';
11390 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
11394 -- Set indication that mode is set locally. If we are in fact in a
11395 -- configuration pragma file, this setting is harmless since the
11396 -- switch will get reset anyway at the start of each unit.
11398 Optimize_Alignment_Local := True;
11399 end Optimize_Alignment;
11405 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
11407 when Pragma_Ordered => Ordered : declare
11408 Assoc : constant Node_Id := Arg1;
11414 Check_No_Identifiers;
11415 Check_Arg_Count (1);
11416 Check_Arg_Is_Local_Name (Arg1);
11418 Type_Id := Get_Pragma_Arg (Assoc);
11419 Find_Type (Type_Id);
11420 Typ := Entity (Type_Id);
11422 if Typ = Any_Type then
11425 Typ := Underlying_Type (Typ);
11428 if not Is_Enumeration_Type (Typ) then
11429 Error_Pragma ("pragma% must specify enumeration type");
11432 Check_First_Subtype (Arg1);
11433 Set_Has_Pragma_Ordered (Base_Type (Typ));
11440 -- pragma Pack (first_subtype_LOCAL_NAME);
11442 when Pragma_Pack => Pack : declare
11443 Assoc : constant Node_Id := Arg1;
11447 Ignore : Boolean := False;
11450 Check_No_Identifiers;
11451 Check_Arg_Count (1);
11452 Check_Arg_Is_Local_Name (Arg1);
11454 Type_Id := Get_Pragma_Arg (Assoc);
11455 Find_Type (Type_Id);
11456 Typ := Entity (Type_Id);
11459 or else Rep_Item_Too_Early (Typ, N)
11463 Typ := Underlying_Type (Typ);
11466 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
11467 Error_Pragma ("pragma% must specify array or record type");
11470 Check_First_Subtype (Arg1);
11471 Check_Duplicate_Pragma (Typ);
11475 if Is_Array_Type (Typ) then
11476 Ctyp := Component_Type (Typ);
11478 -- Ignore pack that does nothing
11480 if Known_Static_Esize (Ctyp)
11481 and then Known_Static_RM_Size (Ctyp)
11482 and then Esize (Ctyp) = RM_Size (Ctyp)
11483 and then Addressable (Esize (Ctyp))
11488 -- Process OK pragma Pack. Note that if there is a separate
11489 -- component clause present, the Pack will be cancelled. This
11490 -- processing is in Freeze.
11492 if not Rep_Item_Too_Late (Typ, N) then
11494 -- In the context of static code analysis, we do not need
11495 -- complex front-end expansions related to pragma Pack,
11496 -- so disable handling of pragma Pack in these cases.
11498 if CodePeer_Mode or Alfa_Mode then
11501 -- Don't attempt any packing for VM targets. We possibly
11502 -- could deal with some cases of array bit-packing, but we
11503 -- don't bother, since this is not a typical kind of
11504 -- representation in the VM context anyway (and would not
11505 -- for example work nicely with the debugger).
11507 elsif VM_Target /= No_VM then
11508 if not GNAT_Mode then
11510 ("?pragma% ignored in this configuration");
11513 -- Normal case where we do the pack action
11517 Set_Is_Packed (Base_Type (Typ));
11518 Set_Has_Non_Standard_Rep (Base_Type (Typ));
11521 Set_Has_Pragma_Pack (Base_Type (Typ));
11525 -- For record types, the pack is always effective
11527 else pragma Assert (Is_Record_Type (Typ));
11528 if not Rep_Item_Too_Late (Typ, N) then
11530 -- Ignore pack request with warning in VM mode (skip warning
11531 -- if we are compiling GNAT run time library).
11533 if VM_Target /= No_VM then
11534 if not GNAT_Mode then
11536 ("?pragma% ignored in this configuration");
11539 -- Normal case of pack request active
11542 Set_Is_Packed (Base_Type (Typ));
11543 Set_Has_Pragma_Pack (Base_Type (Typ));
11544 Set_Has_Non_Standard_Rep (Base_Type (Typ));
11556 -- There is nothing to do here, since we did all the processing for
11557 -- this pragma in Par.Prag (so that it works properly even in syntax
11560 when Pragma_Page =>
11567 -- pragma Passive [(PASSIVE_FORM)];
11569 -- PASSIVE_FORM ::= Semaphore | No
11571 when Pragma_Passive =>
11574 if Nkind (Parent (N)) /= N_Task_Definition then
11575 Error_Pragma ("pragma% must be within task definition");
11578 if Arg_Count /= 0 then
11579 Check_Arg_Count (1);
11580 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
11583 ----------------------------------
11584 -- Preelaborable_Initialization --
11585 ----------------------------------
11587 -- pragma Preelaborable_Initialization (DIRECT_NAME);
11589 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
11594 Check_Arg_Count (1);
11595 Check_No_Identifiers;
11596 Check_Arg_Is_Identifier (Arg1);
11597 Check_Arg_Is_Local_Name (Arg1);
11598 Check_First_Subtype (Arg1);
11599 Ent := Entity (Get_Pragma_Arg (Arg1));
11601 if not (Is_Private_Type (Ent)
11603 Is_Protected_Type (Ent)
11605 (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent)))
11608 ("pragma % can only be applied to private, formal derived or "
11609 & "protected type",
11613 -- Give an error if the pragma is applied to a protected type that
11614 -- does not qualify (due to having entries, or due to components
11615 -- that do not qualify).
11617 if Is_Protected_Type (Ent)
11618 and then not Has_Preelaborable_Initialization (Ent)
11621 ("protected type & does not have preelaborable " &
11622 "initialization", Ent);
11624 -- Otherwise mark the type as definitely having preelaborable
11628 Set_Known_To_Have_Preelab_Init (Ent);
11631 if Has_Pragma_Preelab_Init (Ent)
11632 and then Warn_On_Redundant_Constructs
11634 Error_Pragma ("?duplicate pragma%!");
11636 Set_Has_Pragma_Preelab_Init (Ent);
11640 --------------------
11641 -- Persistent_BSS --
11642 --------------------
11644 -- pragma Persistent_BSS [(object_NAME)];
11646 when Pragma_Persistent_BSS => Persistent_BSS : declare
11653 Check_At_Most_N_Arguments (1);
11655 -- Case of application to specific object (one argument)
11657 if Arg_Count = 1 then
11658 Check_Arg_Is_Library_Level_Local_Name (Arg1);
11660 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
11662 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
11665 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
11668 Ent := Entity (Get_Pragma_Arg (Arg1));
11669 Decl := Parent (Ent);
11671 if Rep_Item_Too_Late (Ent, N) then
11675 if Present (Expression (Decl)) then
11677 ("object for pragma% cannot have initialization", Arg1);
11680 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
11682 ("object type for pragma% is not potentially persistent",
11686 Check_Duplicate_Pragma (Ent);
11689 Make_Linker_Section_Pragma
11690 (Ent, Sloc (N), ".persistent.bss");
11691 Insert_After (N, Prag);
11694 -- Case of use as configuration pragma with no arguments
11697 Check_Valid_Configuration_Pragma;
11698 Persistent_BSS_Mode := True;
11700 end Persistent_BSS;
11706 -- pragma Polling (ON | OFF);
11708 when Pragma_Polling =>
11710 Check_Arg_Count (1);
11711 Check_No_Identifiers;
11712 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
11713 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
11715 -------------------
11716 -- Postcondition --
11717 -------------------
11719 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
11720 -- [,[Message =>] String_EXPRESSION]);
11722 when Pragma_Postcondition => Postcondition : declare
11724 pragma Warnings (Off, In_Body);
11728 Check_At_Least_N_Arguments (1);
11729 Check_At_Most_N_Arguments (2);
11730 Check_Optional_Identifier (Arg1, Name_Check);
11732 -- All we need to do here is call the common check procedure,
11733 -- the remainder of the processing is found in Sem_Ch6/Sem_Ch7.
11735 Check_Precondition_Postcondition (In_Body);
11742 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
11743 -- [,[Message =>] String_EXPRESSION]);
11745 when Pragma_Precondition => Precondition : declare
11750 Check_At_Least_N_Arguments (1);
11751 Check_At_Most_N_Arguments (2);
11752 Check_Optional_Identifier (Arg1, Name_Check);
11753 Check_Precondition_Postcondition (In_Body);
11755 -- If in spec, nothing more to do. If in body, then we convert the
11756 -- pragma to pragma Check (Precondition, cond [, msg]). Note we do
11757 -- this whether or not precondition checks are enabled. That works
11758 -- fine since pragma Check will do this check, and will also
11759 -- analyze the condition itself in the proper context.
11764 Chars => Name_Check,
11765 Pragma_Argument_Associations => New_List (
11766 Make_Pragma_Argument_Association (Loc,
11767 Expression => Make_Identifier (Loc, Name_Precondition)),
11769 Make_Pragma_Argument_Association (Sloc (Arg1),
11770 Expression => Relocate_Node (Get_Pragma_Arg (Arg1))))));
11772 if Arg_Count = 2 then
11773 Append_To (Pragma_Argument_Associations (N),
11774 Make_Pragma_Argument_Association (Sloc (Arg2),
11775 Expression => Relocate_Node (Get_Pragma_Arg (Arg2))));
11786 -- pragma Predicate
11787 -- ([Entity =>] type_LOCAL_NAME,
11788 -- [Check =>] EXPRESSION);
11790 when Pragma_Predicate => Predicate : declare
11795 pragma Unreferenced (Discard);
11799 Check_Arg_Count (2);
11800 Check_Optional_Identifier (Arg1, Name_Entity);
11801 Check_Optional_Identifier (Arg2, Name_Check);
11803 Check_Arg_Is_Local_Name (Arg1);
11805 Type_Id := Get_Pragma_Arg (Arg1);
11806 Find_Type (Type_Id);
11807 Typ := Entity (Type_Id);
11809 if Typ = Any_Type then
11813 -- The remaining processing is simply to link the pragma on to
11814 -- the rep item chain, for processing when the type is frozen.
11815 -- This is accomplished by a call to Rep_Item_Too_Late. We also
11816 -- mark the type as having predicates.
11818 Set_Has_Predicates (Typ);
11819 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
11826 -- pragma Preelaborate [(library_unit_NAME)];
11828 -- Set the flag Is_Preelaborated of program unit name entity
11830 when Pragma_Preelaborate => Preelaborate : declare
11831 Pa : constant Node_Id := Parent (N);
11832 Pk : constant Node_Kind := Nkind (Pa);
11836 Check_Ada_83_Warning;
11837 Check_Valid_Library_Unit_Pragma;
11839 if Nkind (N) = N_Null_Statement then
11843 Ent := Find_Lib_Unit_Name;
11844 Check_Duplicate_Pragma (Ent);
11846 -- This filters out pragmas inside generic parent then
11847 -- show up inside instantiation
11850 and then not (Pk = N_Package_Specification
11851 and then Present (Generic_Parent (Pa)))
11853 if not Debug_Flag_U then
11854 Set_Is_Preelaborated (Ent);
11855 Set_Suppress_Elaboration_Warnings (Ent);
11860 ---------------------
11861 -- Preelaborate_05 --
11862 ---------------------
11864 -- pragma Preelaborate_05 [(library_unit_NAME)];
11866 -- This pragma is useable only in GNAT_Mode, where it is used like
11867 -- pragma Preelaborate but it is only effective in Ada 2005 mode
11868 -- (otherwise it is ignored). This is used to implement AI-362 which
11869 -- recategorizes some run-time packages in Ada 2005 mode.
11871 when Pragma_Preelaborate_05 => Preelaborate_05 : declare
11876 Check_Valid_Library_Unit_Pragma;
11878 if not GNAT_Mode then
11879 Error_Pragma ("pragma% only available in GNAT mode");
11882 if Nkind (N) = N_Null_Statement then
11886 -- This is one of the few cases where we need to test the value of
11887 -- Ada_Version_Explicit rather than Ada_Version (which is always
11888 -- set to Ada_2012 in a predefined unit), we need to know the
11889 -- explicit version set to know if this pragma is active.
11891 if Ada_Version_Explicit >= Ada_2005 then
11892 Ent := Find_Lib_Unit_Name;
11893 Set_Is_Preelaborated (Ent);
11894 Set_Suppress_Elaboration_Warnings (Ent);
11896 end Preelaborate_05;
11902 -- pragma Priority (EXPRESSION);
11904 when Pragma_Priority => Priority : declare
11905 P : constant Node_Id := Parent (N);
11909 Check_No_Identifiers;
11910 Check_Arg_Count (1);
11914 if Nkind (P) = N_Subprogram_Body then
11915 Check_In_Main_Program;
11917 Arg := Get_Pragma_Arg (Arg1);
11918 Analyze_And_Resolve (Arg, Standard_Integer);
11922 if not Is_Static_Expression (Arg) then
11923 Flag_Non_Static_Expr
11924 ("main subprogram priority is not static!", Arg);
11927 -- If constraint error, then we already signalled an error
11929 elsif Raises_Constraint_Error (Arg) then
11932 -- Otherwise check in range
11936 Val : constant Uint := Expr_Value (Arg);
11940 or else Val > Expr_Value (Expression
11941 (Parent (RTE (RE_Max_Priority))))
11944 ("main subprogram priority is out of range", Arg1);
11950 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
11952 -- Load an arbitrary entity from System.Tasking to make sure
11953 -- this package is implicitly with'ed, since we need to have
11954 -- the tasking run-time active for the pragma Priority to have
11958 Discard : Entity_Id;
11959 pragma Warnings (Off, Discard);
11961 Discard := RTE (RE_Task_List);
11964 -- Task or Protected, must be of type Integer
11966 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
11967 Arg := Get_Pragma_Arg (Arg1);
11969 -- The expression must be analyzed in the special manner
11970 -- described in "Handling of Default and Per-Object
11971 -- Expressions" in sem.ads.
11973 Preanalyze_Spec_Expression (Arg, Standard_Integer);
11975 if not Is_Static_Expression (Arg) then
11976 Check_Restriction (Static_Priorities, Arg);
11979 -- Anything else is incorrect
11985 if Has_Pragma_Priority (P) then
11986 Error_Pragma ("duplicate pragma% not allowed");
11988 Set_Has_Pragma_Priority (P, True);
11990 if Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
11991 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
11992 -- exp_ch9 should use this ???
11997 -----------------------------------
11998 -- Priority_Specific_Dispatching --
11999 -----------------------------------
12001 -- pragma Priority_Specific_Dispatching (
12002 -- policy_IDENTIFIER,
12003 -- first_priority_EXPRESSION,
12004 -- last_priority_EXPRESSION);
12006 when Pragma_Priority_Specific_Dispatching =>
12007 Priority_Specific_Dispatching : declare
12008 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
12009 -- This is the entity System.Any_Priority;
12012 Lower_Bound : Node_Id;
12013 Upper_Bound : Node_Id;
12019 Check_Arg_Count (3);
12020 Check_No_Identifiers;
12021 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
12022 Check_Valid_Configuration_Pragma;
12023 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
12024 DP := Fold_Upper (Name_Buffer (1));
12026 Lower_Bound := Get_Pragma_Arg (Arg2);
12027 Check_Arg_Is_Static_Expression (Lower_Bound, Standard_Integer);
12028 Lower_Val := Expr_Value (Lower_Bound);
12030 Upper_Bound := Get_Pragma_Arg (Arg3);
12031 Check_Arg_Is_Static_Expression (Upper_Bound, Standard_Integer);
12032 Upper_Val := Expr_Value (Upper_Bound);
12034 -- It is not allowed to use Task_Dispatching_Policy and
12035 -- Priority_Specific_Dispatching in the same partition.
12037 if Task_Dispatching_Policy /= ' ' then
12038 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
12040 ("pragma% incompatible with Task_Dispatching_Policy#");
12042 -- Check lower bound in range
12044 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
12046 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
12049 ("first_priority is out of range", Arg2);
12051 -- Check upper bound in range
12053 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
12055 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
12058 ("last_priority is out of range", Arg3);
12060 -- Check that the priority range is valid
12062 elsif Lower_Val > Upper_Val then
12064 ("last_priority_expression must be greater than" &
12065 " or equal to first_priority_expression");
12067 -- Store the new policy, but always preserve System_Location since
12068 -- we like the error message with the run-time name.
12071 -- Check overlapping in the priority ranges specified in other
12072 -- Priority_Specific_Dispatching pragmas within the same
12073 -- partition. We can only check those we know about!
12076 Specific_Dispatching.First .. Specific_Dispatching.Last
12078 if Specific_Dispatching.Table (J).First_Priority in
12079 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
12080 or else Specific_Dispatching.Table (J).Last_Priority in
12081 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
12084 Specific_Dispatching.Table (J).Pragma_Loc;
12086 ("priority range overlaps with "
12087 & "Priority_Specific_Dispatching#");
12091 -- The use of Priority_Specific_Dispatching is incompatible
12092 -- with Task_Dispatching_Policy.
12094 if Task_Dispatching_Policy /= ' ' then
12095 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
12097 ("Priority_Specific_Dispatching incompatible "
12098 & "with Task_Dispatching_Policy#");
12101 -- The use of Priority_Specific_Dispatching forces ceiling
12104 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
12105 Error_Msg_Sloc := Locking_Policy_Sloc;
12107 ("Priority_Specific_Dispatching incompatible "
12108 & "with Locking_Policy#");
12110 -- Set the Ceiling_Locking policy, but preserve System_Location
12111 -- since we like the error message with the run time name.
12114 Locking_Policy := 'C';
12116 if Locking_Policy_Sloc /= System_Location then
12117 Locking_Policy_Sloc := Loc;
12121 -- Add entry in the table
12123 Specific_Dispatching.Append
12124 ((Dispatching_Policy => DP,
12125 First_Priority => UI_To_Int (Lower_Val),
12126 Last_Priority => UI_To_Int (Upper_Val),
12127 Pragma_Loc => Loc));
12129 end Priority_Specific_Dispatching;
12135 -- pragma Profile (profile_IDENTIFIER);
12137 -- profile_IDENTIFIER => Restricted | Ravenscar
12139 when Pragma_Profile =>
12141 Check_Arg_Count (1);
12142 Check_Valid_Configuration_Pragma;
12143 Check_No_Identifiers;
12146 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
12148 if Chars (Argx) = Name_Ravenscar then
12149 Set_Ravenscar_Profile (N);
12150 elsif Chars (Argx) = Name_Restricted then
12151 Set_Profile_Restrictions
12152 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
12154 Error_Pragma_Arg ("& is not a valid profile", Argx);
12158 ----------------------
12159 -- Profile_Warnings --
12160 ----------------------
12162 -- pragma Profile_Warnings (profile_IDENTIFIER);
12164 -- profile_IDENTIFIER => Restricted | Ravenscar
12166 when Pragma_Profile_Warnings =>
12168 Check_Arg_Count (1);
12169 Check_Valid_Configuration_Pragma;
12170 Check_No_Identifiers;
12173 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
12175 if Chars (Argx) = Name_Ravenscar then
12176 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
12177 elsif Chars (Argx) = Name_Restricted then
12178 Set_Profile_Restrictions (Restricted, N, Warn => True);
12180 Error_Pragma_Arg ("& is not a valid profile", Argx);
12184 --------------------------
12185 -- Propagate_Exceptions --
12186 --------------------------
12188 -- pragma Propagate_Exceptions;
12190 -- Note: this pragma is obsolete and has no effect
12192 when Pragma_Propagate_Exceptions =>
12194 Check_Arg_Count (0);
12196 if In_Extended_Main_Source_Unit (N) then
12197 Propagate_Exceptions := True;
12204 -- pragma Psect_Object (
12205 -- [Internal =>] LOCAL_NAME,
12206 -- [, [External =>] EXTERNAL_SYMBOL]
12207 -- [, [Size =>] EXTERNAL_SYMBOL]);
12209 when Pragma_Psect_Object | Pragma_Common_Object =>
12210 Psect_Object : declare
12211 Args : Args_List (1 .. 3);
12212 Names : constant Name_List (1 .. 3) := (
12217 Internal : Node_Id renames Args (1);
12218 External : Node_Id renames Args (2);
12219 Size : Node_Id renames Args (3);
12221 Def_Id : Entity_Id;
12223 procedure Check_Too_Long (Arg : Node_Id);
12224 -- Posts message if the argument is an identifier with more
12225 -- than 31 characters, or a string literal with more than
12226 -- 31 characters, and we are operating under VMS
12228 --------------------
12229 -- Check_Too_Long --
12230 --------------------
12232 procedure Check_Too_Long (Arg : Node_Id) is
12233 X : constant Node_Id := Original_Node (Arg);
12236 if not Nkind_In (X, N_String_Literal, N_Identifier) then
12238 ("inappropriate argument for pragma %", Arg);
12241 if OpenVMS_On_Target then
12242 if (Nkind (X) = N_String_Literal
12243 and then String_Length (Strval (X)) > 31)
12245 (Nkind (X) = N_Identifier
12246 and then Length_Of_Name (Chars (X)) > 31)
12249 ("argument for pragma % is longer than 31 characters",
12253 end Check_Too_Long;
12255 -- Start of processing for Common_Object/Psect_Object
12259 Gather_Associations (Names, Args);
12260 Process_Extended_Import_Export_Internal_Arg (Internal);
12262 Def_Id := Entity (Internal);
12264 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
12266 ("pragma% must designate an object", Internal);
12269 Check_Too_Long (Internal);
12271 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
12273 ("cannot use pragma% for imported/exported object",
12277 if Is_Concurrent_Type (Etype (Internal)) then
12279 ("cannot specify pragma % for task/protected object",
12283 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
12285 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
12287 Error_Msg_N ("?duplicate Common/Psect_Object pragma", N);
12290 if Ekind (Def_Id) = E_Constant then
12292 ("cannot specify pragma % for a constant", Internal);
12295 if Is_Record_Type (Etype (Internal)) then
12301 Ent := First_Entity (Etype (Internal));
12302 while Present (Ent) loop
12303 Decl := Declaration_Node (Ent);
12305 if Ekind (Ent) = E_Component
12306 and then Nkind (Decl) = N_Component_Declaration
12307 and then Present (Expression (Decl))
12308 and then Warn_On_Export_Import
12311 ("?object for pragma % has defaults", Internal);
12321 if Present (Size) then
12322 Check_Too_Long (Size);
12325 if Present (External) then
12326 Check_Arg_Is_External_Name (External);
12327 Check_Too_Long (External);
12330 -- If all error tests pass, link pragma on to the rep item chain
12332 Record_Rep_Item (Def_Id, N);
12339 -- pragma Pure [(library_unit_NAME)];
12341 when Pragma_Pure => Pure : declare
12345 Check_Ada_83_Warning;
12346 Check_Valid_Library_Unit_Pragma;
12348 if Nkind (N) = N_Null_Statement then
12352 Ent := Find_Lib_Unit_Name;
12354 Set_Has_Pragma_Pure (Ent);
12355 Set_Suppress_Elaboration_Warnings (Ent);
12362 -- pragma Pure_05 [(library_unit_NAME)];
12364 -- This pragma is useable only in GNAT_Mode, where it is used like
12365 -- pragma Pure but it is only effective in Ada 2005 mode (otherwise
12366 -- it is ignored). It may be used after a pragma Preelaborate, in
12367 -- which case it overrides the effect of the pragma Preelaborate.
12368 -- This is used to implement AI-362 which recategorizes some run-time
12369 -- packages in Ada 2005 mode.
12371 when Pragma_Pure_05 => Pure_05 : declare
12376 Check_Valid_Library_Unit_Pragma;
12378 if not GNAT_Mode then
12379 Error_Pragma ("pragma% only available in GNAT mode");
12382 if Nkind (N) = N_Null_Statement then
12386 -- This is one of the few cases where we need to test the value of
12387 -- Ada_Version_Explicit rather than Ada_Version (which is always
12388 -- set to Ada_2012 in a predefined unit), we need to know the
12389 -- explicit version set to know if this pragma is active.
12391 if Ada_Version_Explicit >= Ada_2005 then
12392 Ent := Find_Lib_Unit_Name;
12393 Set_Is_Preelaborated (Ent, False);
12395 Set_Suppress_Elaboration_Warnings (Ent);
12399 -------------------
12400 -- Pure_Function --
12401 -------------------
12403 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
12405 when Pragma_Pure_Function => Pure_Function : declare
12408 Def_Id : Entity_Id;
12409 Effective : Boolean := False;
12413 Check_Arg_Count (1);
12414 Check_Optional_Identifier (Arg1, Name_Entity);
12415 Check_Arg_Is_Local_Name (Arg1);
12416 E_Id := Get_Pragma_Arg (Arg1);
12418 if Error_Posted (E_Id) then
12422 -- Loop through homonyms (overloadings) of referenced entity
12424 E := Entity (E_Id);
12426 if Present (E) then
12428 Def_Id := Get_Base_Subprogram (E);
12430 if not Ekind_In (Def_Id, E_Function,
12431 E_Generic_Function,
12435 ("pragma% requires a function name", Arg1);
12438 Set_Is_Pure (Def_Id);
12440 if not Has_Pragma_Pure_Function (Def_Id) then
12441 Set_Has_Pragma_Pure_Function (Def_Id);
12445 exit when From_Aspect_Specification (N);
12447 exit when No (E) or else Scope (E) /= Current_Scope;
12451 and then Warn_On_Redundant_Constructs
12454 ("pragma Pure_Function on& is redundant?",
12460 --------------------
12461 -- Queuing_Policy --
12462 --------------------
12464 -- pragma Queuing_Policy (policy_IDENTIFIER);
12466 when Pragma_Queuing_Policy => declare
12470 Check_Ada_83_Warning;
12471 Check_Arg_Count (1);
12472 Check_No_Identifiers;
12473 Check_Arg_Is_Queuing_Policy (Arg1);
12474 Check_Valid_Configuration_Pragma;
12475 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
12476 QP := Fold_Upper (Name_Buffer (1));
12478 if Queuing_Policy /= ' '
12479 and then Queuing_Policy /= QP
12481 Error_Msg_Sloc := Queuing_Policy_Sloc;
12482 Error_Pragma ("queuing policy incompatible with policy#");
12484 -- Set new policy, but always preserve System_Location since we
12485 -- like the error message with the run time name.
12488 Queuing_Policy := QP;
12490 if Queuing_Policy_Sloc /= System_Location then
12491 Queuing_Policy_Sloc := Loc;
12496 -----------------------
12497 -- Relative_Deadline --
12498 -----------------------
12500 -- pragma Relative_Deadline (time_span_EXPRESSION);
12502 when Pragma_Relative_Deadline => Relative_Deadline : declare
12503 P : constant Node_Id := Parent (N);
12508 Check_No_Identifiers;
12509 Check_Arg_Count (1);
12511 Arg := Get_Pragma_Arg (Arg1);
12513 -- The expression must be analyzed in the special manner described
12514 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
12516 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
12520 if Nkind (P) = N_Subprogram_Body then
12521 Check_In_Main_Program;
12525 elsif Nkind (P) = N_Task_Definition then
12528 -- Anything else is incorrect
12534 if Has_Relative_Deadline_Pragma (P) then
12535 Error_Pragma ("duplicate pragma% not allowed");
12537 Set_Has_Relative_Deadline_Pragma (P, True);
12539 if Nkind (P) = N_Task_Definition then
12540 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
12543 end Relative_Deadline;
12545 ---------------------------
12546 -- Remote_Call_Interface --
12547 ---------------------------
12549 -- pragma Remote_Call_Interface [(library_unit_NAME)];
12551 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
12552 Cunit_Node : Node_Id;
12553 Cunit_Ent : Entity_Id;
12557 Check_Ada_83_Warning;
12558 Check_Valid_Library_Unit_Pragma;
12560 if Nkind (N) = N_Null_Statement then
12564 Cunit_Node := Cunit (Current_Sem_Unit);
12565 K := Nkind (Unit (Cunit_Node));
12566 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
12568 if K = N_Package_Declaration
12569 or else K = N_Generic_Package_Declaration
12570 or else K = N_Subprogram_Declaration
12571 or else K = N_Generic_Subprogram_Declaration
12572 or else (K = N_Subprogram_Body
12573 and then Acts_As_Spec (Unit (Cunit_Node)))
12578 "pragma% must apply to package or subprogram declaration");
12581 Set_Is_Remote_Call_Interface (Cunit_Ent);
12582 end Remote_Call_Interface;
12588 -- pragma Remote_Types [(library_unit_NAME)];
12590 when Pragma_Remote_Types => Remote_Types : declare
12591 Cunit_Node : Node_Id;
12592 Cunit_Ent : Entity_Id;
12595 Check_Ada_83_Warning;
12596 Check_Valid_Library_Unit_Pragma;
12598 if Nkind (N) = N_Null_Statement then
12602 Cunit_Node := Cunit (Current_Sem_Unit);
12603 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
12605 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
12606 N_Generic_Package_Declaration)
12609 ("pragma% can only apply to a package declaration");
12612 Set_Is_Remote_Types (Cunit_Ent);
12619 -- pragma Ravenscar;
12621 when Pragma_Ravenscar =>
12623 Check_Arg_Count (0);
12624 Check_Valid_Configuration_Pragma;
12625 Set_Ravenscar_Profile (N);
12627 if Warn_On_Obsolescent_Feature then
12628 Error_Msg_N ("pragma Ravenscar is an obsolescent feature?", N);
12629 Error_Msg_N ("|use pragma Profile (Ravenscar) instead", N);
12632 -------------------------
12633 -- Restricted_Run_Time --
12634 -------------------------
12636 -- pragma Restricted_Run_Time;
12638 when Pragma_Restricted_Run_Time =>
12640 Check_Arg_Count (0);
12641 Check_Valid_Configuration_Pragma;
12642 Set_Profile_Restrictions
12643 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
12645 if Warn_On_Obsolescent_Feature then
12647 ("pragma Restricted_Run_Time is an obsolescent feature?", N);
12648 Error_Msg_N ("|use pragma Profile (Restricted) instead", N);
12655 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
12658 -- restriction_IDENTIFIER
12659 -- | restriction_parameter_IDENTIFIER => EXPRESSION
12661 when Pragma_Restrictions =>
12662 Process_Restrictions_Or_Restriction_Warnings
12663 (Warn => Treat_Restrictions_As_Warnings);
12665 --------------------------
12666 -- Restriction_Warnings --
12667 --------------------------
12669 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
12672 -- restriction_IDENTIFIER
12673 -- | restriction_parameter_IDENTIFIER => EXPRESSION
12675 when Pragma_Restriction_Warnings =>
12677 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
12683 -- pragma Reviewable;
12685 when Pragma_Reviewable =>
12686 Check_Ada_83_Warning;
12687 Check_Arg_Count (0);
12689 -- Call dummy debugging function rv. This is done to assist front
12690 -- end debugging. By placing a Reviewable pragma in the source
12691 -- program, a breakpoint on rv catches this place in the source,
12692 -- allowing convenient stepping to the point of interest.
12696 --------------------------
12697 -- Short_Circuit_And_Or --
12698 --------------------------
12700 when Pragma_Short_Circuit_And_Or =>
12702 Check_Arg_Count (0);
12703 Check_Valid_Configuration_Pragma;
12704 Short_Circuit_And_Or := True;
12706 -------------------
12707 -- Share_Generic --
12708 -------------------
12710 -- pragma Share_Generic (NAME {, NAME});
12712 when Pragma_Share_Generic =>
12714 Process_Generic_List;
12720 -- pragma Shared (LOCAL_NAME);
12722 when Pragma_Shared =>
12724 Process_Atomic_Shared_Volatile;
12726 --------------------
12727 -- Shared_Passive --
12728 --------------------
12730 -- pragma Shared_Passive [(library_unit_NAME)];
12732 -- Set the flag Is_Shared_Passive of program unit name entity
12734 when Pragma_Shared_Passive => Shared_Passive : declare
12735 Cunit_Node : Node_Id;
12736 Cunit_Ent : Entity_Id;
12739 Check_Ada_83_Warning;
12740 Check_Valid_Library_Unit_Pragma;
12742 if Nkind (N) = N_Null_Statement then
12746 Cunit_Node := Cunit (Current_Sem_Unit);
12747 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
12749 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
12750 N_Generic_Package_Declaration)
12753 ("pragma% can only apply to a package declaration");
12756 Set_Is_Shared_Passive (Cunit_Ent);
12757 end Shared_Passive;
12759 -----------------------
12760 -- Short_Descriptors --
12761 -----------------------
12763 -- pragma Short_Descriptors;
12765 when Pragma_Short_Descriptors =>
12767 Check_Arg_Count (0);
12768 Check_Valid_Configuration_Pragma;
12769 Short_Descriptors := True;
12771 ----------------------
12772 -- Source_File_Name --
12773 ----------------------
12775 -- There are five forms for this pragma:
12777 -- pragma Source_File_Name (
12778 -- [UNIT_NAME =>] unit_NAME,
12779 -- BODY_FILE_NAME => STRING_LITERAL
12780 -- [, [INDEX =>] INTEGER_LITERAL]);
12782 -- pragma Source_File_Name (
12783 -- [UNIT_NAME =>] unit_NAME,
12784 -- SPEC_FILE_NAME => STRING_LITERAL
12785 -- [, [INDEX =>] INTEGER_LITERAL]);
12787 -- pragma Source_File_Name (
12788 -- BODY_FILE_NAME => STRING_LITERAL
12789 -- [, DOT_REPLACEMENT => STRING_LITERAL]
12790 -- [, CASING => CASING_SPEC]);
12792 -- pragma Source_File_Name (
12793 -- SPEC_FILE_NAME => STRING_LITERAL
12794 -- [, DOT_REPLACEMENT => STRING_LITERAL]
12795 -- [, CASING => CASING_SPEC]);
12797 -- pragma Source_File_Name (
12798 -- SUBUNIT_FILE_NAME => STRING_LITERAL
12799 -- [, DOT_REPLACEMENT => STRING_LITERAL]
12800 -- [, CASING => CASING_SPEC]);
12802 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
12804 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
12805 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
12806 -- only be used when no project file is used, while SFNP can only be
12807 -- used when a project file is used.
12809 -- No processing here. Processing was completed during parsing, since
12810 -- we need to have file names set as early as possible. Units are
12811 -- loaded well before semantic processing starts.
12813 -- The only processing we defer to this point is the check for
12814 -- correct placement.
12816 when Pragma_Source_File_Name =>
12818 Check_Valid_Configuration_Pragma;
12820 ------------------------------
12821 -- Source_File_Name_Project --
12822 ------------------------------
12824 -- See Source_File_Name for syntax
12826 -- No processing here. Processing was completed during parsing, since
12827 -- we need to have file names set as early as possible. Units are
12828 -- loaded well before semantic processing starts.
12830 -- The only processing we defer to this point is the check for
12831 -- correct placement.
12833 when Pragma_Source_File_Name_Project =>
12835 Check_Valid_Configuration_Pragma;
12837 -- Check that a pragma Source_File_Name_Project is used only in a
12838 -- configuration pragmas file.
12840 -- Pragmas Source_File_Name_Project should only be generated by
12841 -- the Project Manager in configuration pragmas files.
12843 -- This is really an ugly test. It seems to depend on some
12844 -- accidental and undocumented property. At the very least it
12845 -- needs to be documented, but it would be better to have a
12846 -- clean way of testing if we are in a configuration file???
12848 if Present (Parent (N)) then
12850 ("pragma% can only appear in a configuration pragmas file");
12853 ----------------------
12854 -- Source_Reference --
12855 ----------------------
12857 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
12859 -- Nothing to do, all processing completed in Par.Prag, since we need
12860 -- the information for possible parser messages that are output.
12862 when Pragma_Source_Reference =>
12865 --------------------------------
12866 -- Static_Elaboration_Desired --
12867 --------------------------------
12869 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
12871 when Pragma_Static_Elaboration_Desired =>
12873 Check_At_Most_N_Arguments (1);
12875 if Is_Compilation_Unit (Current_Scope)
12876 and then Ekind (Current_Scope) = E_Package
12878 Set_Static_Elaboration_Desired (Current_Scope, True);
12880 Error_Pragma ("pragma% must apply to a library-level package");
12887 -- pragma Storage_Size (EXPRESSION);
12889 when Pragma_Storage_Size => Storage_Size : declare
12890 P : constant Node_Id := Parent (N);
12894 Check_No_Identifiers;
12895 Check_Arg_Count (1);
12897 -- The expression must be analyzed in the special manner described
12898 -- in "Handling of Default Expressions" in sem.ads.
12900 Arg := Get_Pragma_Arg (Arg1);
12901 Preanalyze_Spec_Expression (Arg, Any_Integer);
12903 if not Is_Static_Expression (Arg) then
12904 Check_Restriction (Static_Storage_Size, Arg);
12907 if Nkind (P) /= N_Task_Definition then
12912 if Has_Storage_Size_Pragma (P) then
12913 Error_Pragma ("duplicate pragma% not allowed");
12915 Set_Has_Storage_Size_Pragma (P, True);
12918 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
12919 -- ??? exp_ch9 should use this!
12927 -- pragma Storage_Unit (NUMERIC_LITERAL);
12929 -- Only permitted argument is System'Storage_Unit value
12931 when Pragma_Storage_Unit =>
12932 Check_No_Identifiers;
12933 Check_Arg_Count (1);
12934 Check_Arg_Is_Integer_Literal (Arg1);
12936 if Intval (Get_Pragma_Arg (Arg1)) /=
12937 UI_From_Int (Ttypes.System_Storage_Unit)
12939 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
12941 ("the only allowed argument for pragma% is ^", Arg1);
12944 --------------------
12945 -- Stream_Convert --
12946 --------------------
12948 -- pragma Stream_Convert (
12949 -- [Entity =>] type_LOCAL_NAME,
12950 -- [Read =>] function_NAME,
12951 -- [Write =>] function NAME);
12953 when Pragma_Stream_Convert => Stream_Convert : declare
12955 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
12956 -- Check that the given argument is the name of a local function
12957 -- of one argument that is not overloaded earlier in the current
12958 -- local scope. A check is also made that the argument is a
12959 -- function with one parameter.
12961 --------------------------------------
12962 -- Check_OK_Stream_Convert_Function --
12963 --------------------------------------
12965 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
12969 Check_Arg_Is_Local_Name (Arg);
12970 Ent := Entity (Get_Pragma_Arg (Arg));
12972 if Has_Homonym (Ent) then
12974 ("argument for pragma% may not be overloaded", Arg);
12977 if Ekind (Ent) /= E_Function
12978 or else No (First_Formal (Ent))
12979 or else Present (Next_Formal (First_Formal (Ent)))
12982 ("argument for pragma% must be" &
12983 " function of one argument", Arg);
12985 end Check_OK_Stream_Convert_Function;
12987 -- Start of processing for Stream_Convert
12991 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
12992 Check_Arg_Count (3);
12993 Check_Optional_Identifier (Arg1, Name_Entity);
12994 Check_Optional_Identifier (Arg2, Name_Read);
12995 Check_Optional_Identifier (Arg3, Name_Write);
12996 Check_Arg_Is_Local_Name (Arg1);
12997 Check_OK_Stream_Convert_Function (Arg2);
12998 Check_OK_Stream_Convert_Function (Arg3);
13001 Typ : constant Entity_Id :=
13002 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
13003 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
13004 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
13007 Check_First_Subtype (Arg1);
13009 -- Check for too early or too late. Note that we don't enforce
13010 -- the rule about primitive operations in this case, since, as
13011 -- is the case for explicit stream attributes themselves, these
13012 -- restrictions are not appropriate. Note that the chaining of
13013 -- the pragma by Rep_Item_Too_Late is actually the critical
13014 -- processing done for this pragma.
13016 if Rep_Item_Too_Early (Typ, N)
13018 Rep_Item_Too_Late (Typ, N, FOnly => True)
13023 -- Return if previous error
13025 if Etype (Typ) = Any_Type
13027 Etype (Read) = Any_Type
13029 Etype (Write) = Any_Type
13036 if Underlying_Type (Etype (Read)) /= Typ then
13038 ("incorrect return type for function&", Arg2);
13041 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
13043 ("incorrect parameter type for function&", Arg3);
13046 if Underlying_Type (Etype (First_Formal (Read))) /=
13047 Underlying_Type (Etype (Write))
13050 ("result type of & does not match Read parameter type",
13054 end Stream_Convert;
13056 -------------------------
13057 -- Style_Checks (GNAT) --
13058 -------------------------
13060 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
13062 -- This is processed by the parser since some of the style checks
13063 -- take place during source scanning and parsing. This means that
13064 -- we don't need to issue error messages here.
13066 when Pragma_Style_Checks => Style_Checks : declare
13067 A : constant Node_Id := Get_Pragma_Arg (Arg1);
13073 Check_No_Identifiers;
13075 -- Two argument form
13077 if Arg_Count = 2 then
13078 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
13085 E_Id := Get_Pragma_Arg (Arg2);
13088 if not Is_Entity_Name (E_Id) then
13090 ("second argument of pragma% must be entity name",
13094 E := Entity (E_Id);
13100 Set_Suppress_Style_Checks (E,
13101 (Chars (Get_Pragma_Arg (Arg1)) = Name_Off));
13102 exit when No (Homonym (E));
13108 -- One argument form
13111 Check_Arg_Count (1);
13113 if Nkind (A) = N_String_Literal then
13117 Slen : constant Natural := Natural (String_Length (S));
13118 Options : String (1 .. Slen);
13124 C := Get_String_Char (S, Int (J));
13125 exit when not In_Character_Range (C);
13126 Options (J) := Get_Character (C);
13128 -- If at end of string, set options. As per discussion
13129 -- above, no need to check for errors, since we issued
13130 -- them in the parser.
13133 Set_Style_Check_Options (Options);
13141 elsif Nkind (A) = N_Identifier then
13142 if Chars (A) = Name_All_Checks then
13144 Set_GNAT_Style_Check_Options;
13146 Set_Default_Style_Check_Options;
13149 elsif Chars (A) = Name_On then
13150 Style_Check := True;
13152 elsif Chars (A) = Name_Off then
13153 Style_Check := False;
13163 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
13165 when Pragma_Subtitle =>
13167 Check_Arg_Count (1);
13168 Check_Optional_Identifier (Arg1, Name_Subtitle);
13169 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
13176 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
13178 when Pragma_Suppress =>
13179 Process_Suppress_Unsuppress (True);
13185 -- pragma Suppress_All;
13187 -- The only check made here is that the pragma has no arguments.
13188 -- There are no placement rules, and the processing required (setting
13189 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
13190 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
13191 -- then creates and inserts a pragma Suppress (All_Checks).
13193 when Pragma_Suppress_All =>
13195 Check_Arg_Count (0);
13197 -------------------------
13198 -- Suppress_Debug_Info --
13199 -------------------------
13201 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
13203 when Pragma_Suppress_Debug_Info =>
13205 Check_Arg_Count (1);
13206 Check_Optional_Identifier (Arg1, Name_Entity);
13207 Check_Arg_Is_Local_Name (Arg1);
13208 Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1)));
13210 ----------------------------------
13211 -- Suppress_Exception_Locations --
13212 ----------------------------------
13214 -- pragma Suppress_Exception_Locations;
13216 when Pragma_Suppress_Exception_Locations =>
13218 Check_Arg_Count (0);
13219 Check_Valid_Configuration_Pragma;
13220 Exception_Locations_Suppressed := True;
13222 -----------------------------
13223 -- Suppress_Initialization --
13224 -----------------------------
13226 -- pragma Suppress_Initialization ([Entity =>] type_Name);
13228 when Pragma_Suppress_Initialization => Suppress_Init : declare
13234 Check_Arg_Count (1);
13235 Check_Optional_Identifier (Arg1, Name_Entity);
13236 Check_Arg_Is_Local_Name (Arg1);
13238 E_Id := Get_Pragma_Arg (Arg1);
13240 if Etype (E_Id) = Any_Type then
13244 E := Entity (E_Id);
13246 if not Is_Type (E) then
13247 Error_Pragma_Arg ("pragma% requires type or subtype", Arg1);
13250 if Rep_Item_Too_Early (E, N)
13252 Rep_Item_Too_Late (E, N, FOnly => True)
13257 -- For incomplete/private type, set flag on full view
13259 if Is_Incomplete_Or_Private_Type (E) then
13260 if No (Full_View (Base_Type (E))) then
13262 ("argument of pragma% cannot be an incomplete type", Arg1);
13264 Set_Suppress_Initialization (Full_View (Base_Type (E)));
13267 -- For first subtype, set flag on base type
13269 elsif Is_First_Subtype (E) then
13270 Set_Suppress_Initialization (Base_Type (E));
13272 -- For other than first subtype, set flag on subtype itself
13275 Set_Suppress_Initialization (E);
13283 -- pragma System_Name (DIRECT_NAME);
13285 -- Syntax check: one argument, which must be the identifier GNAT or
13286 -- the identifier GCC, no other identifiers are acceptable.
13288 when Pragma_System_Name =>
13290 Check_No_Identifiers;
13291 Check_Arg_Count (1);
13292 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
13294 -----------------------------
13295 -- Task_Dispatching_Policy --
13296 -----------------------------
13298 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
13300 when Pragma_Task_Dispatching_Policy => declare
13304 Check_Ada_83_Warning;
13305 Check_Arg_Count (1);
13306 Check_No_Identifiers;
13307 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
13308 Check_Valid_Configuration_Pragma;
13309 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
13310 DP := Fold_Upper (Name_Buffer (1));
13312 if Task_Dispatching_Policy /= ' '
13313 and then Task_Dispatching_Policy /= DP
13315 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
13317 ("task dispatching policy incompatible with policy#");
13319 -- Set new policy, but always preserve System_Location since we
13320 -- like the error message with the run time name.
13323 Task_Dispatching_Policy := DP;
13325 if Task_Dispatching_Policy_Sloc /= System_Location then
13326 Task_Dispatching_Policy_Sloc := Loc;
13335 -- pragma Task_Info (EXPRESSION);
13337 when Pragma_Task_Info => Task_Info : declare
13338 P : constant Node_Id := Parent (N);
13343 if Nkind (P) /= N_Task_Definition then
13344 Error_Pragma ("pragma% must appear in task definition");
13347 Check_No_Identifiers;
13348 Check_Arg_Count (1);
13350 Analyze_And_Resolve
13351 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
13353 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
13357 if Has_Task_Info_Pragma (P) then
13358 Error_Pragma ("duplicate pragma% not allowed");
13360 Set_Has_Task_Info_Pragma (P, True);
13368 -- pragma Task_Name (string_EXPRESSION);
13370 when Pragma_Task_Name => Task_Name : declare
13371 P : constant Node_Id := Parent (N);
13375 Check_No_Identifiers;
13376 Check_Arg_Count (1);
13378 Arg := Get_Pragma_Arg (Arg1);
13380 -- The expression is used in the call to Create_Task, and must be
13381 -- expanded there, not in the context of the current spec. It must
13382 -- however be analyzed to capture global references, in case it
13383 -- appears in a generic context.
13385 Preanalyze_And_Resolve (Arg, Standard_String);
13387 if Nkind (P) /= N_Task_Definition then
13391 if Has_Task_Name_Pragma (P) then
13392 Error_Pragma ("duplicate pragma% not allowed");
13394 Set_Has_Task_Name_Pragma (P, True);
13395 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
13403 -- pragma Task_Storage (
13404 -- [Task_Type =>] LOCAL_NAME,
13405 -- [Top_Guard =>] static_integer_EXPRESSION);
13407 when Pragma_Task_Storage => Task_Storage : declare
13408 Args : Args_List (1 .. 2);
13409 Names : constant Name_List (1 .. 2) := (
13413 Task_Type : Node_Id renames Args (1);
13414 Top_Guard : Node_Id renames Args (2);
13420 Gather_Associations (Names, Args);
13422 if No (Task_Type) then
13424 ("missing task_type argument for pragma%");
13427 Check_Arg_Is_Local_Name (Task_Type);
13429 Ent := Entity (Task_Type);
13431 if not Is_Task_Type (Ent) then
13433 ("argument for pragma% must be task type", Task_Type);
13436 if No (Top_Guard) then
13438 ("pragma% takes two arguments", Task_Type);
13440 Check_Arg_Is_Static_Expression (Top_Guard, Any_Integer);
13443 Check_First_Subtype (Task_Type);
13445 if Rep_Item_Too_Late (Ent, N) then
13454 -- pragma Test_Case ([Name =>] Static_String_EXPRESSION
13455 -- ,[Mode =>] MODE_TYPE
13456 -- [, Requires => Boolean_EXPRESSION]
13457 -- [, Ensures => Boolean_EXPRESSION]);
13459 -- MODE_TYPE ::= Nominal | Robustness
13461 when Pragma_Test_Case => Test_Case : declare
13464 Check_At_Least_N_Arguments (2);
13465 Check_At_Most_N_Arguments (4);
13467 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
13469 Check_Optional_Identifier (Arg1, Name_Name);
13470 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
13471 Check_Optional_Identifier (Arg2, Name_Mode);
13472 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
13474 if Arg_Count = 4 then
13475 Check_Identifier (Arg3, Name_Requires);
13476 Check_Identifier (Arg4, Name_Ensures);
13478 elsif Arg_Count = 3 then
13479 Check_Identifier_Is_One_Of (Arg3, Name_Requires, Name_Ensures);
13485 --------------------------
13486 -- Thread_Local_Storage --
13487 --------------------------
13489 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
13491 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
13497 Check_Arg_Count (1);
13498 Check_Optional_Identifier (Arg1, Name_Entity);
13499 Check_Arg_Is_Library_Level_Local_Name (Arg1);
13501 Id := Get_Pragma_Arg (Arg1);
13504 if not Is_Entity_Name (Id)
13505 or else Ekind (Entity (Id)) /= E_Variable
13507 Error_Pragma_Arg ("local variable name required", Arg1);
13512 if Rep_Item_Too_Early (E, N)
13513 or else Rep_Item_Too_Late (E, N)
13518 Set_Has_Pragma_Thread_Local_Storage (E);
13519 Set_Has_Gigi_Rep_Item (E);
13520 end Thread_Local_Storage;
13526 -- pragma Time_Slice (static_duration_EXPRESSION);
13528 when Pragma_Time_Slice => Time_Slice : declare
13534 Check_Arg_Count (1);
13535 Check_No_Identifiers;
13536 Check_In_Main_Program;
13537 Check_Arg_Is_Static_Expression (Arg1, Standard_Duration);
13539 if not Error_Posted (Arg1) then
13541 while Present (Nod) loop
13542 if Nkind (Nod) = N_Pragma
13543 and then Pragma_Name (Nod) = Name_Time_Slice
13545 Error_Msg_Name_1 := Pname;
13546 Error_Msg_N ("duplicate pragma% not permitted", Nod);
13553 -- Process only if in main unit
13555 if Get_Source_Unit (Loc) = Main_Unit then
13556 Opt.Time_Slice_Set := True;
13557 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
13559 if Val <= Ureal_0 then
13560 Opt.Time_Slice_Value := 0;
13562 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
13563 Opt.Time_Slice_Value := 1_000_000_000;
13566 Opt.Time_Slice_Value :=
13567 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
13576 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
13578 -- TITLING_OPTION ::=
13579 -- [Title =>] STRING_LITERAL
13580 -- | [Subtitle =>] STRING_LITERAL
13582 when Pragma_Title => Title : declare
13583 Args : Args_List (1 .. 2);
13584 Names : constant Name_List (1 .. 2) := (
13590 Gather_Associations (Names, Args);
13593 for J in 1 .. 2 loop
13594 if Present (Args (J)) then
13595 Check_Arg_Is_Static_Expression (Args (J), Standard_String);
13600 ---------------------
13601 -- Unchecked_Union --
13602 ---------------------
13604 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
13606 when Pragma_Unchecked_Union => Unchecked_Union : declare
13607 Assoc : constant Node_Id := Arg1;
13608 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
13619 Check_No_Identifiers;
13620 Check_Arg_Count (1);
13621 Check_Arg_Is_Local_Name (Arg1);
13623 Find_Type (Type_Id);
13624 Typ := Entity (Type_Id);
13627 or else Rep_Item_Too_Early (Typ, N)
13631 Typ := Underlying_Type (Typ);
13634 if Rep_Item_Too_Late (Typ, N) then
13638 Check_First_Subtype (Arg1);
13640 -- Note remaining cases are references to a type in the current
13641 -- declarative part. If we find an error, we post the error on
13642 -- the relevant type declaration at an appropriate point.
13644 if not Is_Record_Type (Typ) then
13645 Error_Msg_N ("Unchecked_Union must be record type", Typ);
13648 elsif Is_Tagged_Type (Typ) then
13649 Error_Msg_N ("Unchecked_Union must not be tagged", Typ);
13652 elsif Is_Limited_Type (Typ) then
13654 ("Unchecked_Union must not be limited record type", Typ);
13655 Explain_Limited_Type (Typ, Typ);
13659 if not Has_Discriminants (Typ) then
13661 ("Unchecked_Union must have one discriminant", Typ);
13665 Discr := First_Discriminant (Typ);
13666 while Present (Discr) loop
13667 if No (Discriminant_Default_Value (Discr)) then
13669 ("Unchecked_Union discriminant must have default value",
13673 Next_Discriminant (Discr);
13676 Tdef := Type_Definition (Declaration_Node (Typ));
13677 Clist := Component_List (Tdef);
13679 Comp := First (Component_Items (Clist));
13680 while Present (Comp) loop
13681 Check_Component (Comp, Typ);
13685 if No (Clist) or else No (Variant_Part (Clist)) then
13687 ("Unchecked_Union must have variant part",
13692 Vpart := Variant_Part (Clist);
13694 Variant := First (Variants (Vpart));
13695 while Present (Variant) loop
13696 Check_Variant (Variant, Typ);
13701 Set_Is_Unchecked_Union (Typ);
13702 Set_Convention (Typ, Convention_C);
13703 Set_Has_Unchecked_Union (Base_Type (Typ));
13704 Set_Is_Unchecked_Union (Base_Type (Typ));
13705 end Unchecked_Union;
13707 ------------------------
13708 -- Unimplemented_Unit --
13709 ------------------------
13711 -- pragma Unimplemented_Unit;
13713 -- Note: this only gives an error if we are generating code, or if
13714 -- we are in a generic library unit (where the pragma appears in the
13715 -- body, not in the spec).
13717 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
13718 Cunitent : constant Entity_Id :=
13719 Cunit_Entity (Get_Source_Unit (Loc));
13720 Ent_Kind : constant Entity_Kind :=
13725 Check_Arg_Count (0);
13727 if Operating_Mode = Generate_Code
13728 or else Ent_Kind = E_Generic_Function
13729 or else Ent_Kind = E_Generic_Procedure
13730 or else Ent_Kind = E_Generic_Package
13732 Get_Name_String (Chars (Cunitent));
13733 Set_Casing (Mixed_Case);
13734 Write_Str (Name_Buffer (1 .. Name_Len));
13735 Write_Str (" is not supported in this configuration");
13737 raise Unrecoverable_Error;
13739 end Unimplemented_Unit;
13741 ------------------------
13742 -- Universal_Aliasing --
13743 ------------------------
13745 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
13747 when Pragma_Universal_Aliasing => Universal_Alias : declare
13752 Check_Arg_Count (1);
13753 Check_Optional_Identifier (Arg2, Name_Entity);
13754 Check_Arg_Is_Local_Name (Arg1);
13755 E_Id := Entity (Get_Pragma_Arg (Arg1));
13757 if E_Id = Any_Type then
13759 elsif No (E_Id) or else not Is_Type (E_Id) then
13760 Error_Pragma_Arg ("pragma% requires type", Arg1);
13763 Set_Universal_Aliasing (Implementation_Base_Type (E_Id));
13764 end Universal_Alias;
13766 --------------------
13767 -- Universal_Data --
13768 --------------------
13770 -- pragma Universal_Data [(library_unit_NAME)];
13772 when Pragma_Universal_Data =>
13775 -- If this is a configuration pragma, then set the universal
13776 -- addressing option, otherwise confirm that the pragma satisfies
13777 -- the requirements of library unit pragma placement and leave it
13778 -- to the GNAAMP back end to detect the pragma (avoids transitive
13779 -- setting of the option due to withed units).
13781 if Is_Configuration_Pragma then
13782 Universal_Addressing_On_AAMP := True;
13784 Check_Valid_Library_Unit_Pragma;
13787 if not AAMP_On_Target then
13788 Error_Pragma ("?pragma% ignored (applies only to AAMP)");
13795 -- pragma Unmodified (local_Name {, local_Name});
13797 when Pragma_Unmodified => Unmodified : declare
13798 Arg_Node : Node_Id;
13799 Arg_Expr : Node_Id;
13800 Arg_Ent : Entity_Id;
13804 Check_At_Least_N_Arguments (1);
13806 -- Loop through arguments
13809 while Present (Arg_Node) loop
13810 Check_No_Identifier (Arg_Node);
13812 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
13813 -- in fact generate reference, so that the entity will have a
13814 -- reference, which will inhibit any warnings about it not
13815 -- being referenced, and also properly show up in the ali file
13816 -- as a reference. But this reference is recorded before the
13817 -- Has_Pragma_Unreferenced flag is set, so that no warning is
13818 -- generated for this reference.
13820 Check_Arg_Is_Local_Name (Arg_Node);
13821 Arg_Expr := Get_Pragma_Arg (Arg_Node);
13823 if Is_Entity_Name (Arg_Expr) then
13824 Arg_Ent := Entity (Arg_Expr);
13826 if not Is_Assignable (Arg_Ent) then
13828 ("pragma% can only be applied to a variable",
13831 Set_Has_Pragma_Unmodified (Arg_Ent);
13843 -- pragma Unreferenced (local_Name {, local_Name});
13845 -- or when used in a context clause:
13847 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
13849 when Pragma_Unreferenced => Unreferenced : declare
13850 Arg_Node : Node_Id;
13851 Arg_Expr : Node_Id;
13852 Arg_Ent : Entity_Id;
13857 Check_At_Least_N_Arguments (1);
13859 -- Check case of appearing within context clause
13861 if Is_In_Context_Clause then
13863 -- The arguments must all be units mentioned in a with clause
13864 -- in the same context clause. Note we already checked (in
13865 -- Par.Prag) that the arguments are either identifiers or
13866 -- selected components.
13869 while Present (Arg_Node) loop
13870 Citem := First (List_Containing (N));
13871 while Citem /= N loop
13872 if Nkind (Citem) = N_With_Clause
13874 Same_Name (Name (Citem), Get_Pragma_Arg (Arg_Node))
13876 Set_Has_Pragma_Unreferenced
13879 (Library_Unit (Citem))));
13881 (Get_Pragma_Arg (Arg_Node), Name (Citem));
13890 ("argument of pragma% is not with'ed unit", Arg_Node);
13896 -- Case of not in list of context items
13900 while Present (Arg_Node) loop
13901 Check_No_Identifier (Arg_Node);
13903 -- Note: the analyze call done by Check_Arg_Is_Local_Name
13904 -- will in fact generate reference, so that the entity will
13905 -- have a reference, which will inhibit any warnings about
13906 -- it not being referenced, and also properly show up in the
13907 -- ali file as a reference. But this reference is recorded
13908 -- before the Has_Pragma_Unreferenced flag is set, so that
13909 -- no warning is generated for this reference.
13911 Check_Arg_Is_Local_Name (Arg_Node);
13912 Arg_Expr := Get_Pragma_Arg (Arg_Node);
13914 if Is_Entity_Name (Arg_Expr) then
13915 Arg_Ent := Entity (Arg_Expr);
13917 -- If the entity is overloaded, the pragma applies to the
13918 -- most recent overloading, as documented. In this case,
13919 -- name resolution does not generate a reference, so it
13920 -- must be done here explicitly.
13922 if Is_Overloaded (Arg_Expr) then
13923 Generate_Reference (Arg_Ent, N);
13926 Set_Has_Pragma_Unreferenced (Arg_Ent);
13934 --------------------------
13935 -- Unreferenced_Objects --
13936 --------------------------
13938 -- pragma Unreferenced_Objects (local_Name {, local_Name});
13940 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
13941 Arg_Node : Node_Id;
13942 Arg_Expr : Node_Id;
13946 Check_At_Least_N_Arguments (1);
13949 while Present (Arg_Node) loop
13950 Check_No_Identifier (Arg_Node);
13951 Check_Arg_Is_Local_Name (Arg_Node);
13952 Arg_Expr := Get_Pragma_Arg (Arg_Node);
13954 if not Is_Entity_Name (Arg_Expr)
13955 or else not Is_Type (Entity (Arg_Expr))
13958 ("argument for pragma% must be type or subtype", Arg_Node);
13961 Set_Has_Pragma_Unreferenced_Objects (Entity (Arg_Expr));
13964 end Unreferenced_Objects;
13966 ------------------------------
13967 -- Unreserve_All_Interrupts --
13968 ------------------------------
13970 -- pragma Unreserve_All_Interrupts;
13972 when Pragma_Unreserve_All_Interrupts =>
13974 Check_Arg_Count (0);
13976 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
13977 Unreserve_All_Interrupts := True;
13984 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
13986 when Pragma_Unsuppress =>
13988 Process_Suppress_Unsuppress (False);
13990 -------------------
13991 -- Use_VADS_Size --
13992 -------------------
13994 -- pragma Use_VADS_Size;
13996 when Pragma_Use_VADS_Size =>
13998 Check_Arg_Count (0);
13999 Check_Valid_Configuration_Pragma;
14000 Use_VADS_Size := True;
14002 ---------------------
14003 -- Validity_Checks --
14004 ---------------------
14006 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
14008 when Pragma_Validity_Checks => Validity_Checks : declare
14009 A : constant Node_Id := Get_Pragma_Arg (Arg1);
14015 Check_Arg_Count (1);
14016 Check_No_Identifiers;
14018 if Nkind (A) = N_String_Literal then
14022 Slen : constant Natural := Natural (String_Length (S));
14023 Options : String (1 .. Slen);
14029 C := Get_String_Char (S, Int (J));
14030 exit when not In_Character_Range (C);
14031 Options (J) := Get_Character (C);
14034 Set_Validity_Check_Options (Options);
14042 elsif Nkind (A) = N_Identifier then
14044 if Chars (A) = Name_All_Checks then
14045 Set_Validity_Check_Options ("a");
14047 elsif Chars (A) = Name_On then
14048 Validity_Checks_On := True;
14050 elsif Chars (A) = Name_Off then
14051 Validity_Checks_On := False;
14055 end Validity_Checks;
14061 -- pragma Volatile (LOCAL_NAME);
14063 when Pragma_Volatile =>
14064 Process_Atomic_Shared_Volatile;
14066 -------------------------
14067 -- Volatile_Components --
14068 -------------------------
14070 -- pragma Volatile_Components (array_LOCAL_NAME);
14072 -- Volatile is handled by the same circuit as Atomic_Components
14078 -- pragma Warnings (On | Off);
14079 -- pragma Warnings (On | Off, LOCAL_NAME);
14080 -- pragma Warnings (static_string_EXPRESSION);
14081 -- pragma Warnings (On | Off, STRING_LITERAL);
14083 when Pragma_Warnings => Warnings : begin
14085 Check_At_Least_N_Arguments (1);
14086 Check_No_Identifiers;
14088 -- If debug flag -gnatd.i is set, pragma is ignored
14090 if Debug_Flag_Dot_I then
14094 -- Process various forms of the pragma
14097 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
14100 -- One argument case
14102 if Arg_Count = 1 then
14104 -- On/Off one argument case was processed by parser
14106 if Nkind (Argx) = N_Identifier
14108 (Chars (Argx) = Name_On
14110 Chars (Argx) = Name_Off)
14114 -- One argument case must be ON/OFF or static string expr
14116 elsif not Is_Static_String_Expression (Arg1) then
14118 ("argument of pragma% must be On/Off or " &
14119 "static string expression", Arg1);
14121 -- One argument string expression case
14125 Lit : constant Node_Id := Expr_Value_S (Argx);
14126 Str : constant String_Id := Strval (Lit);
14127 Len : constant Nat := String_Length (Str);
14135 while J <= Len loop
14136 C := Get_String_Char (Str, J);
14137 OK := In_Character_Range (C);
14140 Chr := Get_Character (C);
14144 if J < Len and then Chr = '.' then
14146 C := Get_String_Char (Str, J);
14147 Chr := Get_Character (C);
14149 if not Set_Dot_Warning_Switch (Chr) then
14151 ("invalid warning switch character " &
14158 OK := Set_Warning_Switch (Chr);
14164 ("invalid warning switch character " & Chr,
14173 -- Two or more arguments (must be two)
14176 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
14177 Check_At_Most_N_Arguments (2);
14185 E_Id := Get_Pragma_Arg (Arg2);
14188 -- In the expansion of an inlined body, a reference to
14189 -- the formal may be wrapped in a conversion if the
14190 -- actual is a conversion. Retrieve the real entity name.
14192 if (In_Instance_Body
14193 or else In_Inlined_Body)
14194 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
14196 E_Id := Expression (E_Id);
14199 -- Entity name case
14201 if Is_Entity_Name (E_Id) then
14202 E := Entity (E_Id);
14209 (E, (Chars (Get_Pragma_Arg (Arg1)) =
14212 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
14213 and then Warn_On_Warnings_Off
14215 Warnings_Off_Pragmas.Append ((N, E));
14218 if Is_Enumeration_Type (E) then
14222 Lit := First_Literal (E);
14223 while Present (Lit) loop
14224 Set_Warnings_Off (Lit);
14225 Next_Literal (Lit);
14230 exit when No (Homonym (E));
14235 -- Error if not entity or static string literal case
14237 elsif not Is_Static_String_Expression (Arg2) then
14239 ("second argument of pragma% must be entity " &
14240 "name or static string expression", Arg2);
14242 -- String literal case
14245 String_To_Name_Buffer
14246 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg2))));
14248 -- Note on configuration pragma case: If this is a
14249 -- configuration pragma, then for an OFF pragma, we
14250 -- just set Config True in the call, which is all
14251 -- that needs to be done. For the case of ON, this
14252 -- is normally an error, unless it is canceling the
14253 -- effect of a previous OFF pragma in the same file.
14254 -- In any other case, an error will be signalled (ON
14255 -- with no matching OFF).
14257 if Chars (Argx) = Name_Off then
14258 Set_Specific_Warning_Off
14259 (Loc, Name_Buffer (1 .. Name_Len),
14260 Config => Is_Configuration_Pragma);
14262 elsif Chars (Argx) = Name_On then
14263 Set_Specific_Warning_On
14264 (Loc, Name_Buffer (1 .. Name_Len), Err);
14268 ("?pragma Warnings On with no " &
14269 "matching Warnings Off",
14279 -------------------
14280 -- Weak_External --
14281 -------------------
14283 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
14285 when Pragma_Weak_External => Weak_External : declare
14290 Check_Arg_Count (1);
14291 Check_Optional_Identifier (Arg1, Name_Entity);
14292 Check_Arg_Is_Library_Level_Local_Name (Arg1);
14293 Ent := Entity (Get_Pragma_Arg (Arg1));
14295 if Rep_Item_Too_Early (Ent, N) then
14298 Ent := Underlying_Type (Ent);
14301 -- The only processing required is to link this item on to the
14302 -- list of rep items for the given entity. This is accomplished
14303 -- by the call to Rep_Item_Too_Late (when no error is detected
14304 -- and False is returned).
14306 if Rep_Item_Too_Late (Ent, N) then
14309 Set_Has_Gigi_Rep_Item (Ent);
14313 -----------------------------
14314 -- Wide_Character_Encoding --
14315 -----------------------------
14317 -- pragma Wide_Character_Encoding (IDENTIFIER);
14319 when Pragma_Wide_Character_Encoding =>
14322 -- Nothing to do, handled in parser. Note that we do not enforce
14323 -- configuration pragma placement, this pragma can appear at any
14324 -- place in the source, allowing mixed encodings within a single
14329 --------------------
14330 -- Unknown_Pragma --
14331 --------------------
14333 -- Should be impossible, since the case of an unknown pragma is
14334 -- separately processed before the case statement is entered.
14336 when Unknown_Pragma =>
14337 raise Program_Error;
14340 -- AI05-0144: detect dangerous order dependence. Disabled for now,
14341 -- until AI is formally approved.
14343 -- Check_Order_Dependence;
14346 when Pragma_Exit => null;
14347 end Analyze_Pragma;
14349 -----------------------------
14350 -- Analyze_TC_In_Decl_Part --
14351 -----------------------------
14353 procedure Analyze_TC_In_Decl_Part (N : Node_Id; S : Entity_Id) is
14355 -- Install formals and push subprogram spec onto scope stack so that we
14356 -- can see the formals from the pragma.
14358 Install_Formals (S);
14361 -- Preanalyze the boolean expressions, we treat these as spec
14362 -- expressions (i.e. similar to a default expression).
14364 Preanalyze_TC_Args (Get_Requires_From_Test_Case_Pragma (N),
14365 Get_Ensures_From_Test_Case_Pragma (N));
14367 -- Remove the subprogram from the scope stack now that the pre-analysis
14368 -- of the expressions in the test-case is done.
14371 end Analyze_TC_In_Decl_Part;
14373 --------------------
14374 -- Check_Disabled --
14375 --------------------
14377 function Check_Disabled (Nam : Name_Id) return Boolean is
14381 -- Loop through entries in check policy list
14383 PP := Opt.Check_Policy_List;
14385 -- If there are no specific entries that matched, then nothing is
14386 -- disabled, so return False.
14391 -- Here we have an entry see if it matches
14395 PPA : constant List_Id := Pragma_Argument_Associations (PP);
14397 if Nam = Chars (Get_Pragma_Arg (First (PPA))) then
14398 return Chars (Get_Pragma_Arg (Last (PPA))) = Name_Disable;
14400 PP := Next_Pragma (PP);
14405 end Check_Disabled;
14407 -------------------
14408 -- Check_Enabled --
14409 -------------------
14411 function Check_Enabled (Nam : Name_Id) return Boolean is
14415 -- Loop through entries in check policy list
14417 PP := Opt.Check_Policy_List;
14419 -- If there are no specific entries that matched, then we let the
14420 -- setting of assertions govern. Note that this provides the needed
14421 -- compatibility with the RM for the cases of assertion, invariant,
14422 -- precondition, predicate, and postcondition.
14425 return Assertions_Enabled;
14427 -- Here we have an entry see if it matches
14431 PPA : constant List_Id := Pragma_Argument_Associations (PP);
14434 if Nam = Chars (Get_Pragma_Arg (First (PPA))) then
14435 case (Chars (Get_Pragma_Arg (Last (PPA)))) is
14436 when Name_On | Name_Check =>
14438 when Name_Off | Name_Ignore =>
14441 raise Program_Error;
14445 PP := Next_Pragma (PP);
14452 ---------------------------------
14453 -- Delay_Config_Pragma_Analyze --
14454 ---------------------------------
14456 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
14458 return Pragma_Name (N) = Name_Interrupt_State
14460 Pragma_Name (N) = Name_Priority_Specific_Dispatching;
14461 end Delay_Config_Pragma_Analyze;
14463 -------------------------
14464 -- Get_Base_Subprogram --
14465 -------------------------
14467 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
14468 Result : Entity_Id;
14471 -- Follow subprogram renaming chain
14474 while Is_Subprogram (Result)
14476 Nkind (Parent (Declaration_Node (Result))) =
14477 N_Subprogram_Renaming_Declaration
14478 and then Present (Alias (Result))
14480 Result := Alias (Result);
14484 end Get_Base_Subprogram;
14490 procedure Initialize is
14495 -----------------------------
14496 -- Is_Config_Static_String --
14497 -----------------------------
14499 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
14501 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
14502 -- This is an internal recursive function that is just like the outer
14503 -- function except that it adds the string to the name buffer rather
14504 -- than placing the string in the name buffer.
14506 ------------------------------
14507 -- Add_Config_Static_String --
14508 ------------------------------
14510 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
14517 if Nkind (N) = N_Op_Concat then
14518 if Add_Config_Static_String (Left_Opnd (N)) then
14519 N := Right_Opnd (N);
14525 if Nkind (N) /= N_String_Literal then
14526 Error_Msg_N ("string literal expected for pragma argument", N);
14530 for J in 1 .. String_Length (Strval (N)) loop
14531 C := Get_String_Char (Strval (N), J);
14533 if not In_Character_Range (C) then
14535 ("string literal contains invalid wide character",
14536 Sloc (N) + 1 + Source_Ptr (J));
14540 Add_Char_To_Name_Buffer (Get_Character (C));
14545 end Add_Config_Static_String;
14547 -- Start of processing for Is_Config_Static_String
14552 return Add_Config_Static_String (Arg);
14553 end Is_Config_Static_String;
14555 -----------------------------------------
14556 -- Is_Non_Significant_Pragma_Reference --
14557 -----------------------------------------
14559 -- This function makes use of the following static table which indicates
14560 -- whether a given pragma is significant.
14562 -- -1 indicates that references in any argument position are significant
14563 -- 0 indicates that appearance in any argument is not significant
14564 -- +n indicates that appearance as argument n is significant, but all
14565 -- other arguments are not significant
14566 -- 99 special processing required (e.g. for pragma Check)
14568 Sig_Flags : constant array (Pragma_Id) of Int :=
14569 (Pragma_AST_Entry => -1,
14570 Pragma_Abort_Defer => -1,
14571 Pragma_Ada_83 => -1,
14572 Pragma_Ada_95 => -1,
14573 Pragma_Ada_05 => -1,
14574 Pragma_Ada_2005 => -1,
14575 Pragma_Ada_12 => -1,
14576 Pragma_Ada_2012 => -1,
14577 Pragma_All_Calls_Remote => -1,
14578 Pragma_Annotate => -1,
14579 Pragma_Assert => -1,
14580 Pragma_Assertion_Policy => 0,
14581 Pragma_Assume_No_Invalid_Values => 0,
14582 Pragma_Asynchronous => -1,
14583 Pragma_Atomic => 0,
14584 Pragma_Atomic_Components => 0,
14585 Pragma_Attach_Handler => -1,
14586 Pragma_Check => 99,
14587 Pragma_Check_Name => 0,
14588 Pragma_Check_Policy => 0,
14589 Pragma_CIL_Constructor => -1,
14590 Pragma_CPP_Class => 0,
14591 Pragma_CPP_Constructor => 0,
14592 Pragma_CPP_Virtual => 0,
14593 Pragma_CPP_Vtable => 0,
14595 Pragma_C_Pass_By_Copy => 0,
14596 Pragma_Comment => 0,
14597 Pragma_Common_Object => -1,
14598 Pragma_Compile_Time_Error => -1,
14599 Pragma_Compile_Time_Warning => -1,
14600 Pragma_Compiler_Unit => 0,
14601 Pragma_Complete_Representation => 0,
14602 Pragma_Complex_Representation => 0,
14603 Pragma_Component_Alignment => -1,
14604 Pragma_Controlled => 0,
14605 Pragma_Convention => 0,
14606 Pragma_Convention_Identifier => 0,
14607 Pragma_Debug => -1,
14608 Pragma_Debug_Policy => 0,
14609 Pragma_Detect_Blocking => -1,
14610 Pragma_Default_Storage_Pool => -1,
14611 Pragma_Dimension => -1,
14612 Pragma_Discard_Names => 0,
14613 Pragma_Dispatching_Domain => -1,
14614 Pragma_Elaborate => -1,
14615 Pragma_Elaborate_All => -1,
14616 Pragma_Elaborate_Body => -1,
14617 Pragma_Elaboration_Checks => -1,
14618 Pragma_Eliminate => -1,
14619 Pragma_Export => -1,
14620 Pragma_Export_Exception => -1,
14621 Pragma_Export_Function => -1,
14622 Pragma_Export_Object => -1,
14623 Pragma_Export_Procedure => -1,
14624 Pragma_Export_Value => -1,
14625 Pragma_Export_Valued_Procedure => -1,
14626 Pragma_Extend_System => -1,
14627 Pragma_Extensions_Allowed => -1,
14628 Pragma_External => -1,
14629 Pragma_Favor_Top_Level => -1,
14630 Pragma_External_Name_Casing => -1,
14631 Pragma_Fast_Math => -1,
14632 Pragma_Finalize_Storage_Only => 0,
14633 Pragma_Float_Representation => 0,
14634 Pragma_Ident => -1,
14635 Pragma_Implemented => -1,
14636 Pragma_Implicit_Packing => 0,
14637 Pragma_Import => +2,
14638 Pragma_Import_Exception => 0,
14639 Pragma_Import_Function => 0,
14640 Pragma_Import_Object => 0,
14641 Pragma_Import_Procedure => 0,
14642 Pragma_Import_Valued_Procedure => 0,
14643 Pragma_Independent => 0,
14644 Pragma_Independent_Components => 0,
14645 Pragma_Initialize_Scalars => -1,
14646 Pragma_Inline => 0,
14647 Pragma_Inline_Always => 0,
14648 Pragma_Inline_Generic => 0,
14649 Pragma_Inspection_Point => -1,
14650 Pragma_Interface => +2,
14651 Pragma_Interface_Name => +2,
14652 Pragma_Interrupt_Handler => -1,
14653 Pragma_Interrupt_Priority => -1,
14654 Pragma_Interrupt_State => -1,
14655 Pragma_Invariant => -1,
14656 Pragma_Java_Constructor => -1,
14657 Pragma_Java_Interface => -1,
14658 Pragma_Keep_Names => 0,
14659 Pragma_License => -1,
14660 Pragma_Link_With => -1,
14661 Pragma_Linker_Alias => -1,
14662 Pragma_Linker_Constructor => -1,
14663 Pragma_Linker_Destructor => -1,
14664 Pragma_Linker_Options => -1,
14665 Pragma_Linker_Section => -1,
14667 Pragma_Locking_Policy => -1,
14668 Pragma_Long_Float => -1,
14669 Pragma_Machine_Attribute => -1,
14671 Pragma_Main_Storage => -1,
14672 Pragma_Memory_Size => -1,
14673 Pragma_No_Return => 0,
14674 Pragma_No_Body => 0,
14675 Pragma_No_Run_Time => -1,
14676 Pragma_No_Strict_Aliasing => -1,
14677 Pragma_Normalize_Scalars => -1,
14678 Pragma_Obsolescent => 0,
14679 Pragma_Optimize => -1,
14680 Pragma_Optimize_Alignment => -1,
14681 Pragma_Ordered => 0,
14684 Pragma_Passive => -1,
14685 Pragma_Preelaborable_Initialization => -1,
14686 Pragma_Polling => -1,
14687 Pragma_Persistent_BSS => 0,
14688 Pragma_Postcondition => -1,
14689 Pragma_Precondition => -1,
14690 Pragma_Predicate => -1,
14691 Pragma_Preelaborate => -1,
14692 Pragma_Preelaborate_05 => -1,
14693 Pragma_Priority => -1,
14694 Pragma_Priority_Specific_Dispatching => -1,
14695 Pragma_Profile => 0,
14696 Pragma_Profile_Warnings => 0,
14697 Pragma_Propagate_Exceptions => -1,
14698 Pragma_Psect_Object => -1,
14700 Pragma_Pure_05 => -1,
14701 Pragma_Pure_Function => -1,
14702 Pragma_Queuing_Policy => -1,
14703 Pragma_Ravenscar => -1,
14704 Pragma_Relative_Deadline => -1,
14705 Pragma_Remote_Call_Interface => -1,
14706 Pragma_Remote_Types => -1,
14707 Pragma_Restricted_Run_Time => -1,
14708 Pragma_Restriction_Warnings => -1,
14709 Pragma_Restrictions => -1,
14710 Pragma_Reviewable => -1,
14711 Pragma_Short_Circuit_And_Or => -1,
14712 Pragma_Share_Generic => -1,
14713 Pragma_Shared => -1,
14714 Pragma_Shared_Passive => -1,
14715 Pragma_Short_Descriptors => 0,
14716 Pragma_Source_File_Name => -1,
14717 Pragma_Source_File_Name_Project => -1,
14718 Pragma_Source_Reference => -1,
14719 Pragma_Storage_Size => -1,
14720 Pragma_Storage_Unit => -1,
14721 Pragma_Static_Elaboration_Desired => -1,
14722 Pragma_Stream_Convert => -1,
14723 Pragma_Style_Checks => -1,
14724 Pragma_Subtitle => -1,
14725 Pragma_Suppress => 0,
14726 Pragma_Suppress_Exception_Locations => 0,
14727 Pragma_Suppress_All => -1,
14728 Pragma_Suppress_Debug_Info => 0,
14729 Pragma_Suppress_Initialization => 0,
14730 Pragma_System_Name => -1,
14731 Pragma_Task_Dispatching_Policy => -1,
14732 Pragma_Task_Info => -1,
14733 Pragma_Task_Name => -1,
14734 Pragma_Task_Storage => 0,
14735 Pragma_Test_Case => -1,
14736 Pragma_Thread_Local_Storage => 0,
14737 Pragma_Time_Slice => -1,
14738 Pragma_Title => -1,
14739 Pragma_Unchecked_Union => 0,
14740 Pragma_Unimplemented_Unit => -1,
14741 Pragma_Universal_Aliasing => -1,
14742 Pragma_Universal_Data => -1,
14743 Pragma_Unmodified => -1,
14744 Pragma_Unreferenced => -1,
14745 Pragma_Unreferenced_Objects => -1,
14746 Pragma_Unreserve_All_Interrupts => -1,
14747 Pragma_Unsuppress => 0,
14748 Pragma_Use_VADS_Size => -1,
14749 Pragma_Validity_Checks => -1,
14750 Pragma_Volatile => 0,
14751 Pragma_Volatile_Components => 0,
14752 Pragma_Warnings => -1,
14753 Pragma_Weak_External => -1,
14754 Pragma_Wide_Character_Encoding => 0,
14755 Unknown_Pragma => 0);
14757 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
14766 if Nkind (P) /= N_Pragma_Argument_Association then
14770 Id := Get_Pragma_Id (Parent (P));
14771 C := Sig_Flags (Id);
14783 -- For pragma Check, the first argument is not significant,
14784 -- the second and the third (if present) arguments are
14787 when Pragma_Check =>
14789 P = First (Pragma_Argument_Associations (Parent (P)));
14792 raise Program_Error;
14796 A := First (Pragma_Argument_Associations (Parent (P)));
14797 for J in 1 .. C - 1 loop
14805 return A = P; -- is this wrong way round ???
14808 end Is_Non_Significant_Pragma_Reference;
14810 ------------------------------
14811 -- Is_Pragma_String_Literal --
14812 ------------------------------
14814 -- This function returns true if the corresponding pragma argument is a
14815 -- static string expression. These are the only cases in which string
14816 -- literals can appear as pragma arguments. We also allow a string literal
14817 -- as the first argument to pragma Assert (although it will of course
14818 -- always generate a type error).
14820 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
14821 Pragn : constant Node_Id := Parent (Par);
14822 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
14823 Pname : constant Name_Id := Pragma_Name (Pragn);
14829 N := First (Assoc);
14836 if Pname = Name_Assert then
14839 elsif Pname = Name_Export then
14842 elsif Pname = Name_Ident then
14845 elsif Pname = Name_Import then
14848 elsif Pname = Name_Interface_Name then
14851 elsif Pname = Name_Linker_Alias then
14854 elsif Pname = Name_Linker_Section then
14857 elsif Pname = Name_Machine_Attribute then
14860 elsif Pname = Name_Source_File_Name then
14863 elsif Pname = Name_Source_Reference then
14866 elsif Pname = Name_Title then
14869 elsif Pname = Name_Subtitle then
14875 end Is_Pragma_String_Literal;
14877 ------------------------
14878 -- Preanalyze_TC_Args --
14879 ------------------------
14881 procedure Preanalyze_TC_Args (Arg_Req, Arg_Ens : Node_Id) is
14883 -- Preanalyze the boolean expressions, we treat these as spec
14884 -- expressions (i.e. similar to a default expression).
14886 if Present (Arg_Req) then
14887 Preanalyze_Spec_Expression
14888 (Get_Pragma_Arg (Arg_Req), Standard_Boolean);
14891 if Present (Arg_Ens) then
14892 Preanalyze_Spec_Expression
14893 (Get_Pragma_Arg (Arg_Ens), Standard_Boolean);
14895 end Preanalyze_TC_Args;
14897 --------------------------------------
14898 -- Process_Compilation_Unit_Pragmas --
14899 --------------------------------------
14901 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
14903 -- A special check for pragma Suppress_All, a very strange DEC pragma,
14904 -- strange because it comes at the end of the unit. Rational has the
14905 -- same name for a pragma, but treats it as a program unit pragma, In
14906 -- GNAT we just decide to allow it anywhere at all. If it appeared then
14907 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
14908 -- node, and we insert a pragma Suppress (All_Checks) at the start of
14909 -- the context clause to ensure the correct processing.
14911 if Has_Pragma_Suppress_All (N) then
14912 Prepend_To (Context_Items (N),
14913 Make_Pragma (Sloc (N),
14914 Chars => Name_Suppress,
14915 Pragma_Argument_Associations => New_List (
14916 Make_Pragma_Argument_Association (Sloc (N),
14917 Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
14920 -- Nothing else to do at the current time!
14922 end Process_Compilation_Unit_Pragmas;
14933 --------------------------------
14934 -- Set_Encoded_Interface_Name --
14935 --------------------------------
14937 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
14938 Str : constant String_Id := Strval (S);
14939 Len : constant Int := String_Length (Str);
14944 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
14947 -- Stores encoded value of character code CC. The encoding we use an
14948 -- underscore followed by four lower case hex digits.
14954 procedure Encode is
14956 Store_String_Char (Get_Char_Code ('_'));
14958 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
14960 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
14962 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
14964 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
14967 -- Start of processing for Set_Encoded_Interface_Name
14970 -- If first character is asterisk, this is a link name, and we leave it
14971 -- completely unmodified. We also ignore null strings (the latter case
14972 -- happens only in error cases) and no encoding should occur for Java or
14973 -- AAMP interface names.
14976 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
14977 or else VM_Target /= No_VM
14978 or else AAMP_On_Target
14980 Set_Interface_Name (E, S);
14985 CC := Get_String_Char (Str, J);
14987 exit when not In_Character_Range (CC);
14989 C := Get_Character (CC);
14991 exit when C /= '_' and then C /= '$'
14992 and then C not in '0' .. '9'
14993 and then C not in 'a' .. 'z'
14994 and then C not in 'A' .. 'Z';
14997 Set_Interface_Name (E, S);
15005 -- Here we need to encode. The encoding we use as follows:
15006 -- three underscores + four hex digits (lower case)
15010 for J in 1 .. String_Length (Str) loop
15011 CC := Get_String_Char (Str, J);
15013 if not In_Character_Range (CC) then
15016 C := Get_Character (CC);
15018 if C = '_' or else C = '$'
15019 or else C in '0' .. '9'
15020 or else C in 'a' .. 'z'
15021 or else C in 'A' .. 'Z'
15023 Store_String_Char (CC);
15030 Set_Interface_Name (E,
15031 Make_String_Literal (Sloc (S),
15032 Strval => End_String));
15034 end Set_Encoded_Interface_Name;
15036 -------------------
15037 -- Set_Unit_Name --
15038 -------------------
15040 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id) is
15045 if Nkind (N) = N_Identifier
15046 and then Nkind (With_Item) = N_Identifier
15048 Set_Entity (N, Entity (With_Item));
15050 elsif Nkind (N) = N_Selected_Component then
15051 Change_Selected_Component_To_Expanded_Name (N);
15052 Set_Entity (N, Entity (With_Item));
15053 Set_Entity (Selector_Name (N), Entity (N));
15055 Pref := Prefix (N);
15056 Scop := Scope (Entity (N));
15057 while Nkind (Pref) = N_Selected_Component loop
15058 Change_Selected_Component_To_Expanded_Name (Pref);
15059 Set_Entity (Selector_Name (Pref), Scop);
15060 Set_Entity (Pref, Scop);
15061 Pref := Prefix (Pref);
15062 Scop := Scope (Scop);
15065 Set_Entity (Pref, Scop);