1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2012, 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 Aspects; use Aspects;
33 with Atree; use Atree;
34 with Casing; use Casing;
35 with Checks; use Checks;
36 with Csets; use Csets;
37 with Debug; use Debug;
38 with Einfo; use Einfo;
39 with Elists; use Elists;
40 with Errout; use Errout;
41 with Exp_Dist; use Exp_Dist;
42 with Exp_Util; use Exp_Util;
43 with Freeze; use Freeze;
45 with Lib.Writ; use Lib.Writ;
46 with Lib.Xref; use Lib.Xref;
47 with Namet.Sp; use Namet.Sp;
48 with Nlists; use Nlists;
49 with Nmake; use Nmake;
51 with Output; use Output;
52 with Par_SCO; use Par_SCO;
53 with Restrict; use Restrict;
54 with Rident; use Rident;
55 with Rtsfind; use Rtsfind;
57 with Sem_Aux; use Sem_Aux;
58 with Sem_Ch3; use Sem_Ch3;
59 with Sem_Ch6; use Sem_Ch6;
60 with Sem_Ch8; use Sem_Ch8;
61 with Sem_Ch12; use Sem_Ch12;
62 with Sem_Ch13; use Sem_Ch13;
63 with Sem_Disp; use Sem_Disp;
64 with Sem_Dist; use Sem_Dist;
65 with Sem_Elim; use Sem_Elim;
66 with Sem_Eval; use Sem_Eval;
67 with Sem_Intr; use Sem_Intr;
68 with Sem_Mech; use Sem_Mech;
69 with Sem_Res; use Sem_Res;
70 with Sem_Type; use Sem_Type;
71 with Sem_Util; use Sem_Util;
72 with Sem_VFpt; use Sem_VFpt;
73 with Sem_Warn; use Sem_Warn;
74 with Stand; use Stand;
75 with Sinfo; use Sinfo;
76 with Sinfo.CN; use Sinfo.CN;
77 with Sinput; use Sinput;
78 with Snames; use Snames;
79 with Stringt; use Stringt;
80 with Stylesw; use Stylesw;
82 with Targparm; use Targparm;
83 with Tbuild; use Tbuild;
85 with Uintp; use Uintp;
86 with Uname; use Uname;
87 with Urealp; use Urealp;
88 with Validsw; use Validsw;
89 with Warnsw; use Warnsw;
91 package body Sem_Prag is
93 ----------------------------------------------
94 -- Common Handling of Import-Export Pragmas --
95 ----------------------------------------------
97 -- In the following section, a number of Import_xxx and Export_xxx pragmas
98 -- are defined by GNAT. These are compatible with the DEC pragmas of the
99 -- same name, and all have the following common form and processing:
102 -- [Internal =>] LOCAL_NAME
103 -- [, [External =>] EXTERNAL_SYMBOL]
104 -- [, other optional parameters ]);
107 -- [Internal =>] LOCAL_NAME
108 -- [, [External =>] EXTERNAL_SYMBOL]
109 -- [, other optional parameters ]);
111 -- EXTERNAL_SYMBOL ::=
113 -- | static_string_EXPRESSION
115 -- The internal LOCAL_NAME designates the entity that is imported or
116 -- exported, and must refer to an entity in the current declarative
117 -- part (as required by the rules for LOCAL_NAME).
119 -- The external linker name is designated by the External parameter if
120 -- given, or the Internal parameter if not (if there is no External
121 -- parameter, the External parameter is a copy of the Internal name).
123 -- If the External parameter is given as a string, then this string is
124 -- treated as an external name (exactly as though it had been given as an
125 -- External_Name parameter for a normal Import pragma).
127 -- If the External parameter is given as an identifier (or there is no
128 -- External parameter, so that the Internal identifier is used), then
129 -- the external name is the characters of the identifier, translated
130 -- to all upper case letters for OpenVMS versions of GNAT, and to all
131 -- lower case letters for all other versions
133 -- Note: the external name specified or implied by any of these special
134 -- Import_xxx or Export_xxx pragmas override an external or link name
135 -- specified in a previous Import or Export pragma.
137 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
138 -- named notation, following the standard rules for subprogram calls, i.e.
139 -- parameters can be given in any order if named notation is used, and
140 -- positional and named notation can be mixed, subject to the rule that all
141 -- positional parameters must appear first.
143 -- Note: All these pragmas are implemented exactly following the DEC design
144 -- and implementation and are intended to be fully compatible with the use
145 -- of these pragmas in the DEC Ada compiler.
147 --------------------------------------------
148 -- Checking for Duplicated External Names --
149 --------------------------------------------
151 -- It is suspicious if two separate Export pragmas use the same external
152 -- name. The following table is used to diagnose this situation so that
153 -- an appropriate warning can be issued.
155 -- The Node_Id stored is for the N_String_Literal node created to hold
156 -- the value of the external name. The Sloc of this node is used to
157 -- cross-reference the location of the duplication.
159 package Externals is new Table.Table (
160 Table_Component_Type => Node_Id,
161 Table_Index_Type => Int,
162 Table_Low_Bound => 0,
163 Table_Initial => 100,
164 Table_Increment => 100,
165 Table_Name => "Name_Externals");
167 -------------------------------------
168 -- Local Subprograms and Variables --
169 -------------------------------------
171 function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
172 -- This routine is used for possible casing adjustment of an explicit
173 -- external name supplied as a string literal (the node N), according to
174 -- the casing requirement of Opt.External_Name_Casing. If this is set to
175 -- As_Is, then the string literal is returned unchanged, but if it is set
176 -- to Uppercase or Lowercase, then a new string literal with appropriate
177 -- casing is constructed.
179 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
180 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
181 -- original one, following the renaming chain) is returned. Otherwise the
182 -- entity is returned unchanged. Should be in Einfo???
184 procedure Preanalyze_TC_Args (N, Arg_Req, Arg_Ens : Node_Id);
185 -- Preanalyze the boolean expressions in the Requires and Ensures arguments
186 -- of a Test_Case pragma if present (possibly Empty). We treat these as
187 -- spec expressions (i.e. similar to a default expression).
190 -- This is a dummy function called by the processing for pragma Reviewable.
191 -- It is there for assisting front end debugging. By placing a Reviewable
192 -- pragma in the source program, a breakpoint on rv catches this place in
193 -- the source, allowing convenient stepping to the point of interest.
195 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id);
196 -- Place semantic information on the argument of an Elaborate/Elaborate_All
197 -- pragma. Entity name for unit and its parents is taken from item in
198 -- previous with_clause that mentions the unit.
200 -------------------------------
201 -- Adjust_External_Name_Case --
202 -------------------------------
204 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
208 -- Adjust case of literal if required
210 if Opt.External_Name_Exp_Casing = As_Is then
214 -- Copy existing string
220 for J in 1 .. String_Length (Strval (N)) loop
221 CC := Get_String_Char (Strval (N), J);
223 if Opt.External_Name_Exp_Casing = Uppercase
224 and then CC >= Get_Char_Code ('a')
225 and then CC <= Get_Char_Code ('z')
227 Store_String_Char (CC - 32);
229 elsif Opt.External_Name_Exp_Casing = Lowercase
230 and then CC >= Get_Char_Code ('A')
231 and then CC <= Get_Char_Code ('Z')
233 Store_String_Char (CC + 32);
236 Store_String_Char (CC);
241 Make_String_Literal (Sloc (N),
242 Strval => End_String);
244 end Adjust_External_Name_Case;
246 ------------------------------
247 -- Analyze_PPC_In_Decl_Part --
248 ------------------------------
250 procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id) is
251 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
254 -- Install formals and push subprogram spec onto scope stack so that we
255 -- can see the formals from the pragma.
260 -- Preanalyze the boolean expression, we treat this as a spec expression
261 -- (i.e. similar to a default expression).
263 Preanalyze_Spec_Expression (Get_Pragma_Arg (Arg1), Standard_Boolean);
265 -- In ASIS mode, for a pragma generated from a source aspect, also
266 -- analyze the original aspect expression.
269 and then Present (Corresponding_Aspect (N))
271 Preanalyze_Spec_Expression
272 (Expression (Corresponding_Aspect (N)), Standard_Boolean);
275 -- For a class-wide condition, a reference to a controlling formal must
276 -- be interpreted as having the class-wide type (or an access to such)
277 -- so that the inherited condition can be properly applied to any
278 -- overriding operation (see ARM12 6.6.1 (7)).
280 if Class_Present (N) then
281 Class_Wide_Condition : declare
282 T : constant Entity_Id := Find_Dispatching_Type (S);
284 ACW : Entity_Id := Empty;
285 -- Access to T'class, created if there is a controlling formal
286 -- that is an access parameter.
288 function Get_ACW return Entity_Id;
289 -- If the expression has a reference to an controlling access
290 -- parameter, create an access to T'class for the necessary
291 -- conversions if one does not exist.
293 function Process (N : Node_Id) return Traverse_Result;
294 -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
295 -- aspect for a primitive subprogram of a tagged type T, a name
296 -- that denotes a formal parameter of type T is interpreted as
297 -- having type T'Class. Similarly, a name that denotes a formal
298 -- accessparameter of type access-to-T is interpreted as having
299 -- type access-to-T'Class. This ensures the expression is well-
300 -- defined for a primitive subprogram of a type descended from T.
306 function Get_ACW return Entity_Id is
307 Loc : constant Source_Ptr := Sloc (N);
312 Decl := Make_Full_Type_Declaration (Loc,
313 Defining_Identifier => Make_Temporary (Loc, 'T'),
315 Make_Access_To_Object_Definition (Loc,
316 Subtype_Indication =>
317 New_Occurrence_Of (Class_Wide_Type (T), Loc),
318 All_Present => True));
320 Insert_Before (Unit_Declaration_Node (S), Decl);
322 ACW := Defining_Identifier (Decl);
323 Freeze_Before (Unit_Declaration_Node (S), ACW);
333 function Process (N : Node_Id) return Traverse_Result is
334 Loc : constant Source_Ptr := Sloc (N);
338 if Is_Entity_Name (N)
339 and then Is_Formal (Entity (N))
340 and then Nkind (Parent (N)) /= N_Type_Conversion
342 if Etype (Entity (N)) = T then
343 Typ := Class_Wide_Type (T);
345 elsif Is_Access_Type (Etype (Entity (N)))
346 and then Designated_Type (Etype (Entity (N))) = T
353 if Present (Typ) then
355 Make_Type_Conversion (Loc,
357 New_Occurrence_Of (Typ, Loc),
358 Expression => New_Occurrence_Of (Entity (N), Loc)));
366 procedure Replace_Type is new Traverse_Proc (Process);
368 -- Start of processing for Class_Wide_Condition
371 if not Present (T) then
373 Chars (Identifier (Corresponding_Aspect (N)));
375 Error_Msg_Name_2 := Name_Class;
378 ("aspect `%''%` can only be specified for a primitive " &
379 "operation of a tagged type",
380 Corresponding_Aspect (N));
383 Replace_Type (Get_Pragma_Arg (Arg1));
384 end Class_Wide_Condition;
387 -- Remove the subprogram from the scope stack now that the pre-analysis
388 -- of the precondition/postcondition is done.
391 end Analyze_PPC_In_Decl_Part;
397 procedure Analyze_Pragma (N : Node_Id) is
398 Loc : constant Source_Ptr := Sloc (N);
402 -- Name of the source pragma, or name of the corresponding aspect for
403 -- pragmas which originate in a source aspect. In the latter case, the
404 -- name may be different from the pragma name.
406 Pragma_Exit : exception;
407 -- This exception is used to exit pragma processing completely. It is
408 -- used when an error is detected, and no further processing is
409 -- required. It is also used if an earlier error has left the tree in
410 -- a state where the pragma should not be processed.
413 -- Number of pragma argument associations
419 -- First four pragma arguments (pragma argument association nodes, or
420 -- Empty if the corresponding argument does not exist).
422 type Name_List is array (Natural range <>) of Name_Id;
423 type Args_List is array (Natural range <>) of Node_Id;
424 -- Types used for arguments to Check_Arg_Order and Gather_Associations
426 procedure Ada_2005_Pragma;
427 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
428 -- Ada 95 mode, these are implementation defined pragmas, so should be
429 -- caught by the No_Implementation_Pragmas restriction.
431 procedure Ada_2012_Pragma;
432 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
433 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
434 -- should be caught by the No_Implementation_Pragmas restriction.
436 procedure Check_Ada_83_Warning;
437 -- Issues a warning message for the current pragma if operating in Ada
438 -- 83 mode (used for language pragmas that are not a standard part of
439 -- Ada 83). This procedure does not raise Error_Pragma. Also notes use
442 procedure Check_Arg_Count (Required : Nat);
443 -- Check argument count for pragma is equal to given parameter. If not,
444 -- then issue an error message and raise Pragma_Exit.
446 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
447 -- Arg which can either be a pragma argument association, in which case
448 -- the check is applied to the expression of the association or an
449 -- expression directly.
451 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
452 -- Check that an argument has the right form for an EXTERNAL_NAME
453 -- parameter of an extended import/export pragma. The rule is that the
454 -- name must be an identifier or string literal (in Ada 83 mode) or a
455 -- static string expression (in Ada 95 mode).
457 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
458 -- Check the specified argument Arg to make sure that it is an
459 -- identifier. If not give error and raise Pragma_Exit.
461 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
462 -- Check the specified argument Arg to make sure that it is an integer
463 -- literal. If not give error and raise Pragma_Exit.
465 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
466 -- Check the specified argument Arg to make sure that it has the proper
467 -- syntactic form for a local name and meets the semantic requirements
468 -- for a local name. The local name is analyzed as part of the
469 -- processing for this call. In addition, the local name is required
470 -- to represent an entity at the library level.
472 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
473 -- Check the specified argument Arg to make sure that it has the proper
474 -- syntactic form for a local name and meets the semantic requirements
475 -- for a local name. The local name is analyzed as part of the
476 -- processing for this call.
478 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
479 -- Check the specified argument Arg to make sure that it is a valid
480 -- locking policy name. If not give error and raise Pragma_Exit.
482 procedure Check_Arg_Is_One_Of
485 procedure Check_Arg_Is_One_Of
487 N1, N2, N3 : Name_Id);
488 procedure Check_Arg_Is_One_Of
490 N1, N2, N3, N4 : Name_Id);
491 procedure Check_Arg_Is_One_Of
493 N1, N2, N3, N4, N5 : Name_Id);
494 -- Check the specified argument Arg to make sure that it is an
495 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
496 -- present). If not then give error and raise Pragma_Exit.
498 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
499 -- Check the specified argument Arg to make sure that it is a valid
500 -- queuing policy name. If not give error and raise Pragma_Exit.
502 procedure Check_Arg_Is_Static_Expression
504 Typ : Entity_Id := Empty);
505 -- Check the specified argument Arg to make sure that it is a static
506 -- expression of the given type (i.e. it will be analyzed and resolved
507 -- using this type, which can be any valid argument to Resolve, e.g.
508 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
509 -- Typ is left Empty, then any static expression is allowed.
511 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
512 -- Check the specified argument Arg to make sure that it is a valid task
513 -- dispatching policy name. If not give error and raise Pragma_Exit.
515 procedure Check_Arg_Order (Names : Name_List);
516 -- Checks for an instance of two arguments with identifiers for the
517 -- current pragma which are not in the sequence indicated by Names,
518 -- and if so, generates a fatal message about bad order of arguments.
520 procedure Check_At_Least_N_Arguments (N : Nat);
521 -- Check there are at least N arguments present
523 procedure Check_At_Most_N_Arguments (N : Nat);
524 -- Check there are no more than N arguments present
526 procedure Check_Component
529 In_Variant_Part : Boolean := False);
530 -- Examine an Unchecked_Union component for correct use of per-object
531 -- constrained subtypes, and for restrictions on finalizable components.
532 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
533 -- should be set when Comp comes from a record variant.
535 procedure Check_Duplicate_Pragma (E : Entity_Id);
536 -- Check if a pragma of the same name as the current pragma is already
537 -- chained as a rep pragma to the given entity. If so give a message
538 -- about the duplicate, and then raise Pragma_Exit so does not return.
539 -- Also checks for delayed aspect specification node in the chain.
541 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
542 -- Nam is an N_String_Literal node containing the external name set by
543 -- an Import or Export pragma (or extended Import or Export pragma).
544 -- This procedure checks for possible duplications if this is the export
545 -- case, and if found, issues an appropriate error message.
547 procedure Check_Expr_Is_Static_Expression
549 Typ : Entity_Id := Empty);
550 -- Check the specified expression Expr to make sure that it is a static
551 -- expression of the given type (i.e. it will be analyzed and resolved
552 -- using this type, which can be any valid argument to Resolve, e.g.
553 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
554 -- Typ is left Empty, then any static expression is allowed.
556 procedure Check_First_Subtype (Arg : Node_Id);
557 -- Checks that Arg, whose expression is an entity name, references a
560 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
561 -- Checks that the given argument has an identifier, and if so, requires
562 -- it to match the given identifier name. If there is no identifier, or
563 -- a non-matching identifier, then an error message is given and
564 -- Pragma_Exit is raised.
566 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
567 -- Checks that the given argument has an identifier, and if so, requires
568 -- it to match one of the given identifier names. If there is no
569 -- identifier, or a non-matching identifier, then an error message is
570 -- given and Pragma_Exit is raised.
572 procedure Check_In_Main_Program;
573 -- Common checks for pragmas that appear within a main program
574 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
576 procedure Check_Interrupt_Or_Attach_Handler;
577 -- Common processing for first argument of pragma Interrupt_Handler or
578 -- pragma Attach_Handler.
580 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
581 -- Check that pragma appears in a declarative part, or in a package
582 -- specification, i.e. that it does not occur in a statement sequence
585 procedure Check_No_Identifier (Arg : Node_Id);
586 -- Checks that the given argument does not have an identifier. If
587 -- an identifier is present, then an error message is issued, and
588 -- Pragma_Exit is raised.
590 procedure Check_No_Identifiers;
591 -- Checks that none of the arguments to the pragma has an identifier.
592 -- If any argument has an identifier, then an error message is issued,
593 -- and Pragma_Exit is raised.
595 procedure Check_No_Link_Name;
596 -- Checks that no link name is specified
598 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
599 -- Checks if the given argument has an identifier, and if so, requires
600 -- it to match the given identifier name. If there is a non-matching
601 -- identifier, then an error message is given and Pragma_Exit is raised.
603 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
604 -- Checks if the given argument has an identifier, and if so, requires
605 -- it to match the given identifier name. If there is a non-matching
606 -- identifier, then an error message is given and Pragma_Exit is raised.
607 -- In this version of the procedure, the identifier name is given as
608 -- a string with lower case letters.
610 procedure Check_Precondition_Postcondition (In_Body : out Boolean);
611 -- Called to process a precondition or postcondition pragma. There are
614 -- The pragma appears after a subprogram spec
616 -- If the corresponding check is not enabled, the pragma is analyzed
617 -- but otherwise ignored and control returns with In_Body set False.
619 -- If the check is enabled, then the first step is to analyze the
620 -- pragma, but this is skipped if the subprogram spec appears within
621 -- a package specification (because this is the case where we delay
622 -- analysis till the end of the spec). Then (whether or not it was
623 -- analyzed), the pragma is chained to the subprogram in question
624 -- (using Spec_PPC_List and Next_Pragma) and control returns to the
625 -- caller with In_Body set False.
627 -- The pragma appears at the start of subprogram body declarations
629 -- In this case an immediate return to the caller is made with
630 -- In_Body set True, and the pragma is NOT analyzed.
632 -- In all other cases, an error message for bad placement is given
634 procedure Check_Static_Constraint (Constr : Node_Id);
635 -- Constr is a constraint from an N_Subtype_Indication node from a
636 -- component constraint in an Unchecked_Union type. This routine checks
637 -- that the constraint is static as required by the restrictions for
640 procedure Check_Test_Case;
641 -- Called to process a test-case pragma. The treatment is similar to the
642 -- one for pre- and postcondition in Check_Precondition_Postcondition,
643 -- except the placement rules for the test-case pragma are stricter.
644 -- This pragma may only occur after a subprogram spec declared directly
645 -- in a package spec unit. In this case, the pragma is chained to the
646 -- subprogram in question (using Spec_TC_List and Next_Pragma) and
647 -- analysis of the pragma is delayed till the end of the spec. In
648 -- all other cases, an error message for bad placement is given.
650 procedure Check_Valid_Configuration_Pragma;
651 -- Legality checks for placement of a configuration pragma
653 procedure Check_Valid_Library_Unit_Pragma;
654 -- Legality checks for library unit pragmas. A special case arises for
655 -- pragmas in generic instances that come from copies of the original
656 -- library unit pragmas in the generic templates. In the case of other
657 -- than library level instantiations these can appear in contexts which
658 -- would normally be invalid (they only apply to the original template
659 -- and to library level instantiations), and they are simply ignored,
660 -- which is implemented by rewriting them as null statements.
662 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
663 -- Check an Unchecked_Union variant for lack of nested variants and
664 -- presence of at least one component. UU_Typ is the related Unchecked_
667 procedure Error_Pragma (Msg : String);
668 pragma No_Return (Error_Pragma);
669 -- Outputs error message for current pragma. The message contains a %
670 -- that will be replaced with the pragma name, and the flag is placed
671 -- on the pragma itself. Pragma_Exit is then raised.
673 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
674 pragma No_Return (Error_Pragma_Arg);
675 -- Outputs error message for current pragma. The message may contain
676 -- a % that will be replaced with the pragma name. The parameter Arg
677 -- may either be a pragma argument association, in which case the flag
678 -- is placed on the expression of this association, or an expression,
679 -- in which case the flag is placed directly on the expression. The
680 -- message is placed using Error_Msg_N, so the message may also contain
681 -- an & insertion character which will reference the given Arg value.
682 -- After placing the message, Pragma_Exit is raised.
684 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
685 pragma No_Return (Error_Pragma_Arg);
686 -- Similar to above form of Error_Pragma_Arg except that two messages
687 -- are provided, the second is a continuation comment starting with \.
689 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
690 pragma No_Return (Error_Pragma_Arg_Ident);
691 -- Outputs error message for current pragma. The message may contain
692 -- a % that will be replaced with the pragma name. The parameter Arg
693 -- must be a pragma argument association with a non-empty identifier
694 -- (i.e. its Chars field must be set), and the error message is placed
695 -- on the identifier. The message is placed using Error_Msg_N so
696 -- the message may also contain an & insertion character which will
697 -- reference the identifier. After placing the message, Pragma_Exit
700 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
701 pragma No_Return (Error_Pragma_Ref);
702 -- Outputs error message for current pragma. The message may contain
703 -- a % that will be replaced with the pragma name. The parameter Ref
704 -- must be an entity whose name can be referenced by & and sloc by #.
705 -- After placing the message, Pragma_Exit is raised.
707 function Find_Lib_Unit_Name return Entity_Id;
708 -- Used for a library unit pragma to find the entity to which the
709 -- library unit pragma applies, returns the entity found.
711 procedure Find_Program_Unit_Name (Id : Node_Id);
712 -- If the pragma is a compilation unit pragma, the id must denote the
713 -- compilation unit in the same compilation, and the pragma must appear
714 -- in the list of preceding or trailing pragmas. If it is a program
715 -- unit pragma that is not a compilation unit pragma, then the
716 -- identifier must be visible.
718 function Find_Unique_Parameterless_Procedure
720 Arg : Node_Id) return Entity_Id;
721 -- Used for a procedure pragma to find the unique parameterless
722 -- procedure identified by Name, returns it if it exists, otherwise
723 -- errors out and uses Arg as the pragma argument for the message.
725 procedure Fix_Error (Msg : in out String);
726 -- This is called prior to issuing an error message. Msg is a string
727 -- that typically contains the substring "pragma". If the current pragma
728 -- comes from an aspect, each such "pragma" substring is replaced with
729 -- the characters "aspect", and if Error_Msg_Name_1 is Name_Precondition
730 -- (resp Name_Postcondition) it is changed to Name_Pre (resp Name_Post).
732 procedure Gather_Associations
734 Args : out Args_List);
735 -- This procedure is used to gather the arguments for a pragma that
736 -- permits arbitrary ordering of parameters using the normal rules
737 -- for named and positional parameters. The Names argument is a list
738 -- of Name_Id values that corresponds to the allowed pragma argument
739 -- association identifiers in order. The result returned in Args is
740 -- a list of corresponding expressions that are the pragma arguments.
741 -- Note that this is a list of expressions, not of pragma argument
742 -- associations (Gather_Associations has completely checked all the
743 -- optional identifiers when it returns). An entry in Args is Empty
744 -- on return if the corresponding argument is not present.
746 procedure GNAT_Pragma;
747 -- Called for all GNAT defined pragmas to check the relevant restriction
748 -- (No_Implementation_Pragmas).
750 function Is_Before_First_Decl
751 (Pragma_Node : Node_Id;
752 Decls : List_Id) return Boolean;
753 -- Return True if Pragma_Node is before the first declarative item in
754 -- Decls where Decls is the list of declarative items.
756 function Is_Configuration_Pragma return Boolean;
757 -- Determines if the placement of the current pragma is appropriate
758 -- for a configuration pragma.
760 function Is_In_Context_Clause return Boolean;
761 -- Returns True if pragma appears within the context clause of a unit,
762 -- and False for any other placement (does not generate any messages).
764 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
765 -- Analyzes the argument, and determines if it is a static string
766 -- expression, returns True if so, False if non-static or not String.
768 procedure Pragma_Misplaced;
769 pragma No_Return (Pragma_Misplaced);
770 -- Issue fatal error message for misplaced pragma
772 procedure Process_Atomic_Shared_Volatile;
773 -- Common processing for pragmas Atomic, Shared, Volatile. Note that
774 -- Shared is an obsolete Ada 83 pragma, treated as being identical
775 -- in effect to pragma Atomic.
777 procedure Process_Compile_Time_Warning_Or_Error;
778 -- Common processing for Compile_Time_Error and Compile_Time_Warning
780 procedure Process_Convention
781 (C : out Convention_Id;
782 Ent : out Entity_Id);
783 -- Common processing for Convention, Interface, Import and Export.
784 -- Checks first two arguments of pragma, and sets the appropriate
785 -- convention value in the specified entity or entities. On return
786 -- C is the convention, Ent is the referenced entity.
788 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
789 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
790 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
792 procedure Process_Extended_Import_Export_Exception_Pragma
793 (Arg_Internal : Node_Id;
794 Arg_External : Node_Id;
797 -- Common processing for the pragmas Import/Export_Exception. The three
798 -- arguments correspond to the three named parameters of the pragma. An
799 -- argument is empty if the corresponding parameter is not present in
802 procedure Process_Extended_Import_Export_Object_Pragma
803 (Arg_Internal : Node_Id;
804 Arg_External : Node_Id;
806 -- Common processing for the pragmas Import/Export_Object. The three
807 -- arguments correspond to the three named parameters of the pragmas. An
808 -- argument is empty if the corresponding parameter is not present in
811 procedure Process_Extended_Import_Export_Internal_Arg
812 (Arg_Internal : Node_Id := Empty);
813 -- Common processing for all extended Import and Export pragmas. The
814 -- argument is the pragma parameter for the Internal argument. If
815 -- Arg_Internal is empty or inappropriate, an error message is posted.
816 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
817 -- set to identify the referenced entity.
819 procedure Process_Extended_Import_Export_Subprogram_Pragma
820 (Arg_Internal : Node_Id;
821 Arg_External : Node_Id;
822 Arg_Parameter_Types : Node_Id;
823 Arg_Result_Type : Node_Id := Empty;
824 Arg_Mechanism : Node_Id;
825 Arg_Result_Mechanism : Node_Id := Empty;
826 Arg_First_Optional_Parameter : Node_Id := Empty);
827 -- Common processing for all extended Import and Export pragmas applying
828 -- to subprograms. The caller omits any arguments that do not apply to
829 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
830 -- only in the Import_Function and Export_Function cases). The argument
831 -- names correspond to the allowed pragma association identifiers.
833 procedure Process_Generic_List;
834 -- Common processing for Share_Generic and Inline_Generic
836 procedure Process_Import_Or_Interface;
837 -- Common processing for Import of Interface
839 procedure Process_Import_Predefined_Type;
840 -- Processing for completing a type with pragma Import. This is used
841 -- to declare types that match predefined C types, especially for cases
842 -- without corresponding Ada predefined type.
844 procedure Process_Inline (Active : Boolean);
845 -- Common processing for Inline and Inline_Always. The parameter
846 -- indicates if the inline pragma is active, i.e. if it should actually
847 -- cause inlining to occur.
849 procedure Process_Interface_Name
850 (Subprogram_Def : Entity_Id;
853 -- Given the last two arguments of pragma Import, pragma Export, or
854 -- pragma Interface_Name, performs validity checks and sets the
855 -- Interface_Name field of the given subprogram entity to the
856 -- appropriate external or link name, depending on the arguments given.
857 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
858 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
859 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
860 -- nor Link_Arg is present, the interface name is set to the default
861 -- from the subprogram name.
863 procedure Process_Interrupt_Or_Attach_Handler;
864 -- Common processing for Interrupt and Attach_Handler pragmas
866 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
867 -- Common processing for Restrictions and Restriction_Warnings pragmas.
868 -- Warn is True for Restriction_Warnings, or for Restrictions if the
869 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
870 -- is not set in the Restrictions case.
872 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
873 -- Common processing for Suppress and Unsuppress. The boolean parameter
874 -- Suppress_Case is True for the Suppress case, and False for the
877 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
878 -- This procedure sets the Is_Exported flag for the given entity,
879 -- checking that the entity was not previously imported. Arg is
880 -- the argument that specified the entity. A check is also made
881 -- for exporting inappropriate entities.
883 procedure Set_Extended_Import_Export_External_Name
884 (Internal_Ent : Entity_Id;
885 Arg_External : Node_Id);
886 -- Common processing for all extended import export pragmas. The first
887 -- argument, Internal_Ent, is the internal entity, which has already
888 -- been checked for validity by the caller. Arg_External is from the
889 -- Import or Export pragma, and may be null if no External parameter
890 -- was present. If Arg_External is present and is a non-null string
891 -- (a null string is treated as the default), then the Interface_Name
892 -- field of Internal_Ent is set appropriately.
894 procedure Set_Imported (E : Entity_Id);
895 -- This procedure sets the Is_Imported flag for the given entity,
896 -- checking that it is not previously exported or imported.
898 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
899 -- Mech is a parameter passing mechanism (see Import_Function syntax
900 -- for MECHANISM_NAME). This routine checks that the mechanism argument
901 -- has the right form, and if not issues an error message. If the
902 -- argument has the right form then the Mechanism field of Ent is
903 -- set appropriately.
905 procedure Set_Ravenscar_Profile (N : Node_Id);
906 -- Activate the set of configuration pragmas and restrictions that make
907 -- up the Ravenscar Profile. N is the corresponding pragma node, which
908 -- is used for error messages on any constructs that violate the
911 ---------------------
912 -- Ada_2005_Pragma --
913 ---------------------
915 procedure Ada_2005_Pragma is
917 if Ada_Version <= Ada_95 then
918 Check_Restriction (No_Implementation_Pragmas, N);
922 ---------------------
923 -- Ada_2012_Pragma --
924 ---------------------
926 procedure Ada_2012_Pragma is
928 if Ada_Version <= Ada_2005 then
929 Check_Restriction (No_Implementation_Pragmas, N);
933 --------------------------
934 -- Check_Ada_83_Warning --
935 --------------------------
937 procedure Check_Ada_83_Warning is
939 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
940 Error_Msg_N ("(Ada 83) pragma& is non-standard?", N);
942 end Check_Ada_83_Warning;
944 ---------------------
945 -- Check_Arg_Count --
946 ---------------------
948 procedure Check_Arg_Count (Required : Nat) is
950 if Arg_Count /= Required then
951 Error_Pragma ("wrong number of arguments for pragma%");
955 --------------------------------
956 -- Check_Arg_Is_External_Name --
957 --------------------------------
959 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
960 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
963 if Nkind (Argx) = N_Identifier then
967 Analyze_And_Resolve (Argx, Standard_String);
969 if Is_OK_Static_Expression (Argx) then
972 elsif Etype (Argx) = Any_Type then
975 -- An interesting special case, if we have a string literal and
976 -- we are in Ada 83 mode, then we allow it even though it will
977 -- not be flagged as static. This allows expected Ada 83 mode
978 -- use of external names which are string literals, even though
979 -- technically these are not static in Ada 83.
981 elsif Ada_Version = Ada_83
982 and then Nkind (Argx) = N_String_Literal
986 -- Static expression that raises Constraint_Error. This has
987 -- already been flagged, so just exit from pragma processing.
989 elsif Is_Static_Expression (Argx) then
992 -- Here we have a real error (non-static expression)
995 Error_Msg_Name_1 := Pname;
999 "argument for pragma% must be a identifier or "
1000 & "static string expression!";
1003 Flag_Non_Static_Expr (Msg, Argx);
1008 end Check_Arg_Is_External_Name;
1010 -----------------------------
1011 -- Check_Arg_Is_Identifier --
1012 -----------------------------
1014 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
1015 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1017 if Nkind (Argx) /= N_Identifier then
1019 ("argument for pragma% must be identifier", Argx);
1021 end Check_Arg_Is_Identifier;
1023 ----------------------------------
1024 -- Check_Arg_Is_Integer_Literal --
1025 ----------------------------------
1027 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
1028 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1030 if Nkind (Argx) /= N_Integer_Literal then
1032 ("argument for pragma% must be integer literal", Argx);
1034 end Check_Arg_Is_Integer_Literal;
1036 -------------------------------------------
1037 -- Check_Arg_Is_Library_Level_Local_Name --
1038 -------------------------------------------
1042 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
1043 -- | library_unit_NAME
1045 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
1047 Check_Arg_Is_Local_Name (Arg);
1049 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
1050 and then Comes_From_Source (N)
1053 ("argument for pragma% must be library level entity", Arg);
1055 end Check_Arg_Is_Library_Level_Local_Name;
1057 -----------------------------
1058 -- Check_Arg_Is_Local_Name --
1059 -----------------------------
1063 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
1064 -- | library_unit_NAME
1066 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
1067 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1072 if Nkind (Argx) not in N_Direct_Name
1073 and then (Nkind (Argx) /= N_Attribute_Reference
1074 or else Present (Expressions (Argx))
1075 or else Nkind (Prefix (Argx)) /= N_Identifier)
1076 and then (not Is_Entity_Name (Argx)
1077 or else not Is_Compilation_Unit (Entity (Argx)))
1079 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
1082 -- No further check required if not an entity name
1084 if not Is_Entity_Name (Argx) then
1090 Ent : constant Entity_Id := Entity (Argx);
1091 Scop : constant Entity_Id := Scope (Ent);
1093 -- Case of a pragma applied to a compilation unit: pragma must
1094 -- occur immediately after the program unit in the compilation.
1096 if Is_Compilation_Unit (Ent) then
1098 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
1101 -- Case of pragma placed immediately after spec
1103 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
1106 -- Case of pragma placed immediately after body
1108 elsif Nkind (Decl) = N_Subprogram_Declaration
1109 and then Present (Corresponding_Body (Decl))
1113 (Parent (Unit_Declaration_Node
1114 (Corresponding_Body (Decl))));
1116 -- All other cases are illegal
1123 -- Special restricted placement rule from 10.2.1(11.8/2)
1125 elsif Is_Generic_Formal (Ent)
1126 and then Prag_Id = Pragma_Preelaborable_Initialization
1128 OK := List_Containing (N) =
1129 Generic_Formal_Declarations
1130 (Unit_Declaration_Node (Scop));
1132 -- Default case, just check that the pragma occurs in the scope
1133 -- of the entity denoted by the name.
1136 OK := Current_Scope = Scop;
1141 ("pragma% argument must be in same declarative part", Arg);
1145 end Check_Arg_Is_Local_Name;
1147 ---------------------------------
1148 -- Check_Arg_Is_Locking_Policy --
1149 ---------------------------------
1151 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
1152 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1155 Check_Arg_Is_Identifier (Argx);
1157 if not Is_Locking_Policy_Name (Chars (Argx)) then
1158 Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
1160 end Check_Arg_Is_Locking_Policy;
1162 -------------------------
1163 -- Check_Arg_Is_One_Of --
1164 -------------------------
1166 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
1167 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1170 Check_Arg_Is_Identifier (Argx);
1172 if Chars (Argx) /= N1 and then Chars (Argx) /= N2 then
1173 Error_Msg_Name_2 := N1;
1174 Error_Msg_Name_3 := N2;
1175 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
1177 end Check_Arg_Is_One_Of;
1179 procedure Check_Arg_Is_One_Of
1181 N1, N2, N3 : Name_Id)
1183 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1186 Check_Arg_Is_Identifier (Argx);
1188 if Chars (Argx) /= N1
1189 and then Chars (Argx) /= N2
1190 and then Chars (Argx) /= N3
1192 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
1194 end Check_Arg_Is_One_Of;
1196 procedure Check_Arg_Is_One_Of
1198 N1, N2, N3, N4 : Name_Id)
1200 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1203 Check_Arg_Is_Identifier (Argx);
1205 if Chars (Argx) /= N1
1206 and then Chars (Argx) /= N2
1207 and then Chars (Argx) /= N3
1208 and then Chars (Argx) /= N4
1210 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
1212 end Check_Arg_Is_One_Of;
1214 procedure Check_Arg_Is_One_Of
1216 N1, N2, N3, N4, N5 : Name_Id)
1218 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1221 Check_Arg_Is_Identifier (Argx);
1223 if Chars (Argx) /= N1
1224 and then Chars (Argx) /= N2
1225 and then Chars (Argx) /= N3
1226 and then Chars (Argx) /= N4
1227 and then Chars (Argx) /= N5
1229 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
1231 end Check_Arg_Is_One_Of;
1232 ---------------------------------
1233 -- Check_Arg_Is_Queuing_Policy --
1234 ---------------------------------
1236 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
1237 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1240 Check_Arg_Is_Identifier (Argx);
1242 if not Is_Queuing_Policy_Name (Chars (Argx)) then
1243 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
1245 end Check_Arg_Is_Queuing_Policy;
1247 ------------------------------------
1248 -- Check_Arg_Is_Static_Expression --
1249 ------------------------------------
1251 procedure Check_Arg_Is_Static_Expression
1253 Typ : Entity_Id := Empty)
1256 Check_Expr_Is_Static_Expression (Get_Pragma_Arg (Arg), Typ);
1257 end Check_Arg_Is_Static_Expression;
1259 ------------------------------------------
1260 -- Check_Arg_Is_Task_Dispatching_Policy --
1261 ------------------------------------------
1263 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
1264 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1267 Check_Arg_Is_Identifier (Argx);
1269 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
1271 ("& is not a valid task dispatching policy name", Argx);
1273 end Check_Arg_Is_Task_Dispatching_Policy;
1275 ---------------------
1276 -- Check_Arg_Order --
1277 ---------------------
1279 procedure Check_Arg_Order (Names : Name_List) is
1282 Highest_So_Far : Natural := 0;
1283 -- Highest index in Names seen do far
1287 for J in 1 .. Arg_Count loop
1288 if Chars (Arg) /= No_Name then
1289 for K in Names'Range loop
1290 if Chars (Arg) = Names (K) then
1291 if K < Highest_So_Far then
1292 Error_Msg_Name_1 := Pname;
1294 ("parameters out of order for pragma%", Arg);
1295 Error_Msg_Name_1 := Names (K);
1296 Error_Msg_Name_2 := Names (Highest_So_Far);
1297 Error_Msg_N ("\% must appear before %", Arg);
1301 Highest_So_Far := K;
1309 end Check_Arg_Order;
1311 --------------------------------
1312 -- Check_At_Least_N_Arguments --
1313 --------------------------------
1315 procedure Check_At_Least_N_Arguments (N : Nat) is
1317 if Arg_Count < N then
1318 Error_Pragma ("too few arguments for pragma%");
1320 end Check_At_Least_N_Arguments;
1322 -------------------------------
1323 -- Check_At_Most_N_Arguments --
1324 -------------------------------
1326 procedure Check_At_Most_N_Arguments (N : Nat) is
1329 if Arg_Count > N then
1331 for J in 1 .. N loop
1333 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
1336 end Check_At_Most_N_Arguments;
1338 ---------------------
1339 -- Check_Component --
1340 ---------------------
1342 procedure Check_Component
1345 In_Variant_Part : Boolean := False)
1347 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
1348 Sindic : constant Node_Id :=
1349 Subtype_Indication (Component_Definition (Comp));
1350 Typ : constant Entity_Id := Etype (Comp_Id);
1353 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
1354 -- object constraint, then the component type shall be an Unchecked_
1357 if Nkind (Sindic) = N_Subtype_Indication
1358 and then Has_Per_Object_Constraint (Comp_Id)
1359 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
1362 ("component subtype subject to per-object constraint " &
1363 "must be an Unchecked_Union", Comp);
1365 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
1366 -- the body of a generic unit, or within the body of any of its
1367 -- descendant library units, no part of the type of a component
1368 -- declared in a variant_part of the unchecked union type shall be of
1369 -- a formal private type or formal private extension declared within
1370 -- the formal part of the generic unit.
1372 elsif Ada_Version >= Ada_2012
1373 and then In_Generic_Body (UU_Typ)
1374 and then In_Variant_Part
1375 and then Is_Private_Type (Typ)
1376 and then Is_Generic_Type (Typ)
1379 ("component of Unchecked_Union cannot be of generic type", Comp);
1381 elsif Needs_Finalization (Typ) then
1383 ("component of Unchecked_Union cannot be controlled", Comp);
1385 elsif Has_Task (Typ) then
1387 ("component of Unchecked_Union cannot have tasks", Comp);
1389 end Check_Component;
1391 ----------------------------
1392 -- Check_Duplicate_Pragma --
1393 ----------------------------
1395 procedure Check_Duplicate_Pragma (E : Entity_Id) is
1399 -- Nothing to do if this pragma comes from an aspect specification,
1400 -- since we could not be duplicating a pragma, and we dealt with the
1401 -- case of duplicated aspects in Analyze_Aspect_Specifications.
1403 if From_Aspect_Specification (N) then
1407 -- Otherwise current pragma may duplicate previous pragma or a
1408 -- previously given aspect specification for the same pragma.
1410 P := Get_Rep_Item_For_Entity (E, Pragma_Name (N));
1413 Error_Msg_Name_1 := Pragma_Name (N);
1414 Error_Msg_Sloc := Sloc (P);
1416 if Nkind (P) = N_Aspect_Specification
1417 or else From_Aspect_Specification (P)
1419 Error_Msg_NE ("aspect% for & previously given#", N, E);
1421 Error_Msg_NE ("pragma% for & duplicates pragma#", N, E);
1426 end Check_Duplicate_Pragma;
1428 ----------------------------------
1429 -- Check_Duplicated_Export_Name --
1430 ----------------------------------
1432 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
1433 String_Val : constant String_Id := Strval (Nam);
1436 -- We are only interested in the export case, and in the case of
1437 -- generics, it is the instance, not the template, that is the
1438 -- problem (the template will generate a warning in any case).
1440 if not Inside_A_Generic
1441 and then (Prag_Id = Pragma_Export
1443 Prag_Id = Pragma_Export_Procedure
1445 Prag_Id = Pragma_Export_Valued_Procedure
1447 Prag_Id = Pragma_Export_Function)
1449 for J in Externals.First .. Externals.Last loop
1450 if String_Equal (String_Val, Strval (Externals.Table (J))) then
1451 Error_Msg_Sloc := Sloc (Externals.Table (J));
1452 Error_Msg_N ("external name duplicates name given#", Nam);
1457 Externals.Append (Nam);
1459 end Check_Duplicated_Export_Name;
1461 -------------------------------------
1462 -- Check_Expr_Is_Static_Expression --
1463 -------------------------------------
1465 procedure Check_Expr_Is_Static_Expression
1467 Typ : Entity_Id := Empty)
1470 if Present (Typ) then
1471 Analyze_And_Resolve (Expr, Typ);
1473 Analyze_And_Resolve (Expr);
1476 if Is_OK_Static_Expression (Expr) then
1479 elsif Etype (Expr) = Any_Type then
1482 -- An interesting special case, if we have a string literal and we
1483 -- are in Ada 83 mode, then we allow it even though it will not be
1484 -- flagged as static. This allows the use of Ada 95 pragmas like
1485 -- Import in Ada 83 mode. They will of course be flagged with
1486 -- warnings as usual, but will not cause errors.
1488 elsif Ada_Version = Ada_83
1489 and then Nkind (Expr) = N_String_Literal
1493 -- Static expression that raises Constraint_Error. This has already
1494 -- been flagged, so just exit from pragma processing.
1496 elsif Is_Static_Expression (Expr) then
1499 -- Finally, we have a real error
1502 Error_Msg_Name_1 := Pname;
1506 "argument for pragma% must be a static expression!";
1509 Flag_Non_Static_Expr (Msg, Expr);
1514 end Check_Expr_Is_Static_Expression;
1516 -------------------------
1517 -- Check_First_Subtype --
1518 -------------------------
1520 procedure Check_First_Subtype (Arg : Node_Id) is
1521 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1522 Ent : constant Entity_Id := Entity (Argx);
1525 if Is_First_Subtype (Ent) then
1528 elsif Is_Type (Ent) then
1530 ("pragma% cannot apply to subtype", Argx);
1532 elsif Is_Object (Ent) then
1534 ("pragma% cannot apply to object, requires a type", Argx);
1538 ("pragma% cannot apply to&, requires a type", Argx);
1540 end Check_First_Subtype;
1542 ----------------------
1543 -- Check_Identifier --
1544 ----------------------
1546 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
1549 and then Nkind (Arg) = N_Pragma_Argument_Association
1551 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
1552 Error_Msg_Name_1 := Pname;
1553 Error_Msg_Name_2 := Id;
1554 Error_Msg_N ("pragma% argument expects identifier%", Arg);
1558 end Check_Identifier;
1560 --------------------------------
1561 -- Check_Identifier_Is_One_Of --
1562 --------------------------------
1564 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
1567 and then Nkind (Arg) = N_Pragma_Argument_Association
1569 if Chars (Arg) = No_Name then
1570 Error_Msg_Name_1 := Pname;
1571 Error_Msg_N ("pragma% argument expects an identifier", Arg);
1574 elsif Chars (Arg) /= N1
1575 and then Chars (Arg) /= N2
1577 Error_Msg_Name_1 := Pname;
1578 Error_Msg_N ("invalid identifier for pragma% argument", Arg);
1582 end Check_Identifier_Is_One_Of;
1584 ---------------------------
1585 -- Check_In_Main_Program --
1586 ---------------------------
1588 procedure Check_In_Main_Program is
1589 P : constant Node_Id := Parent (N);
1592 -- Must be at in subprogram body
1594 if Nkind (P) /= N_Subprogram_Body then
1595 Error_Pragma ("% pragma allowed only in subprogram");
1597 -- Otherwise warn if obviously not main program
1599 elsif Present (Parameter_Specifications (Specification (P)))
1600 or else not Is_Compilation_Unit (Defining_Entity (P))
1602 Error_Msg_Name_1 := Pname;
1604 ("?pragma% is only effective in main program", N);
1606 end Check_In_Main_Program;
1608 ---------------------------------------
1609 -- Check_Interrupt_Or_Attach_Handler --
1610 ---------------------------------------
1612 procedure Check_Interrupt_Or_Attach_Handler is
1613 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
1614 Handler_Proc, Proc_Scope : Entity_Id;
1619 if Prag_Id = Pragma_Interrupt_Handler then
1620 Check_Restriction (No_Dynamic_Attachment, N);
1623 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
1624 Proc_Scope := Scope (Handler_Proc);
1626 -- On AAMP only, a pragma Interrupt_Handler is supported for
1627 -- nonprotected parameterless procedures.
1629 if not AAMP_On_Target
1630 or else Prag_Id = Pragma_Attach_Handler
1632 if Ekind (Proc_Scope) /= E_Protected_Type then
1634 ("argument of pragma% must be protected procedure", Arg1);
1637 if Parent (N) /= Protected_Definition (Parent (Proc_Scope)) then
1638 Error_Pragma ("pragma% must be in protected definition");
1642 if not Is_Library_Level_Entity (Proc_Scope)
1643 or else (AAMP_On_Target
1644 and then not Is_Library_Level_Entity (Handler_Proc))
1647 ("argument for pragma% must be library level entity", Arg1);
1650 -- AI05-0033: A pragma cannot appear within a generic body, because
1651 -- instance can be in a nested scope. The check that protected type
1652 -- is itself a library-level declaration is done elsewhere.
1654 -- Note: we omit this check in Codepeer mode to properly handle code
1655 -- prior to AI-0033 (pragmas don't matter to codepeer in any case).
1657 if Inside_A_Generic then
1658 if Ekind (Scope (Current_Scope)) = E_Generic_Package
1659 and then In_Package_Body (Scope (Current_Scope))
1660 and then not CodePeer_Mode
1662 Error_Pragma ("pragma% cannot be used inside a generic");
1665 end Check_Interrupt_Or_Attach_Handler;
1667 -------------------------------------------
1668 -- Check_Is_In_Decl_Part_Or_Package_Spec --
1669 -------------------------------------------
1671 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
1680 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
1683 elsif Nkind_In (P, N_Package_Specification,
1688 -- Note: the following tests seem a little peculiar, because
1689 -- they test for bodies, but if we were in the statement part
1690 -- of the body, we would already have hit the handled statement
1691 -- sequence, so the only way we get here is by being in the
1692 -- declarative part of the body.
1694 elsif Nkind_In (P, N_Subprogram_Body,
1705 Error_Pragma ("pragma% is not in declarative part or package spec");
1706 end Check_Is_In_Decl_Part_Or_Package_Spec;
1708 -------------------------
1709 -- Check_No_Identifier --
1710 -------------------------
1712 procedure Check_No_Identifier (Arg : Node_Id) is
1714 if Nkind (Arg) = N_Pragma_Argument_Association
1715 and then Chars (Arg) /= No_Name
1717 Error_Pragma_Arg_Ident
1718 ("pragma% does not permit identifier& here", Arg);
1720 end Check_No_Identifier;
1722 --------------------------
1723 -- Check_No_Identifiers --
1724 --------------------------
1726 procedure Check_No_Identifiers is
1729 if Arg_Count > 0 then
1731 while Present (Arg_Node) loop
1732 Check_No_Identifier (Arg_Node);
1736 end Check_No_Identifiers;
1738 ------------------------
1739 -- Check_No_Link_Name --
1740 ------------------------
1742 procedure Check_No_Link_Name is
1745 and then Chars (Arg3) = Name_Link_Name
1750 if Present (Arg4) then
1752 ("Link_Name argument not allowed for Import Intrinsic", Arg4);
1754 end Check_No_Link_Name;
1756 -------------------------------
1757 -- Check_Optional_Identifier --
1758 -------------------------------
1760 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
1763 and then Nkind (Arg) = N_Pragma_Argument_Association
1764 and then Chars (Arg) /= No_Name
1766 if Chars (Arg) /= Id then
1767 Error_Msg_Name_1 := Pname;
1768 Error_Msg_Name_2 := Id;
1769 Error_Msg_N ("pragma% argument expects identifier%", Arg);
1773 end Check_Optional_Identifier;
1775 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
1777 Name_Buffer (1 .. Id'Length) := Id;
1778 Name_Len := Id'Length;
1779 Check_Optional_Identifier (Arg, Name_Find);
1780 end Check_Optional_Identifier;
1782 --------------------------------------
1783 -- Check_Precondition_Postcondition --
1784 --------------------------------------
1786 procedure Check_Precondition_Postcondition (In_Body : out Boolean) is
1790 procedure Chain_PPC (PO : Node_Id);
1791 -- If PO is an entry or a [generic] subprogram declaration node, then
1792 -- the precondition/postcondition applies to this subprogram and the
1793 -- processing for the pragma is completed. Otherwise the pragma is
1800 procedure Chain_PPC (PO : Node_Id) is
1805 if Nkind (PO) = N_Abstract_Subprogram_Declaration then
1806 if not From_Aspect_Specification (N) then
1808 ("pragma% cannot be applied to abstract subprogram");
1810 elsif Class_Present (N) then
1815 ("aspect % requires ''Class for abstract subprogram");
1818 -- AI05-0230: The same restriction applies to null procedures. For
1819 -- compatibility with earlier uses of the Ada pragma, apply this
1820 -- rule only to aspect specifications.
1822 -- The above discrpency needs documentation. Robert is dubious
1823 -- about whether it is a good idea ???
1825 elsif Nkind (PO) = N_Subprogram_Declaration
1826 and then Nkind (Specification (PO)) = N_Procedure_Specification
1827 and then Null_Present (Specification (PO))
1828 and then From_Aspect_Specification (N)
1829 and then not Class_Present (N)
1832 ("aspect % requires ''Class for null procedure");
1834 elsif not Nkind_In (PO, N_Subprogram_Declaration,
1835 N_Expression_Function,
1836 N_Generic_Subprogram_Declaration,
1837 N_Entry_Declaration)
1842 -- Here if we have [generic] subprogram or entry declaration
1844 if Nkind (PO) = N_Entry_Declaration then
1845 S := Defining_Entity (PO);
1847 S := Defining_Unit_Name (Specification (PO));
1850 -- Make sure we do not have the case of a precondition pragma when
1851 -- the Pre'Class aspect is present.
1853 -- We do this by looking at pragmas already chained to the entity
1854 -- since the aspect derived pragma will be put on this list first.
1856 if Pragma_Name (N) = Name_Precondition then
1857 if not From_Aspect_Specification (N) then
1858 P := Spec_PPC_List (Contract (S));
1859 while Present (P) loop
1860 if Pragma_Name (P) = Name_Precondition
1861 and then From_Aspect_Specification (P)
1862 and then Class_Present (P)
1864 Error_Msg_Sloc := Sloc (P);
1866 ("pragma% not allowed, `Pre''Class` aspect given#");
1869 P := Next_Pragma (P);
1874 -- Similarly check for Pre with inherited Pre'Class. Note that
1875 -- we cover the aspect case as well here.
1877 if Pragma_Name (N) = Name_Precondition
1878 and then not Class_Present (N)
1881 Inherited : constant Subprogram_List :=
1882 Inherited_Subprograms (S);
1886 for J in Inherited'Range loop
1887 P := Spec_PPC_List (Contract (Inherited (J)));
1888 while Present (P) loop
1889 if Pragma_Name (P) = Name_Precondition
1890 and then Class_Present (P)
1892 Error_Msg_Sloc := Sloc (P);
1894 ("pragma% not allowed, `Pre''Class` "
1895 & "aspect inherited from#");
1898 P := Next_Pragma (P);
1904 -- Note: we do not analyze the pragma at this point. Instead we
1905 -- delay this analysis until the end of the declarative part in
1906 -- which the pragma appears. This implements the required delay
1907 -- in this analysis, allowing forward references. The analysis
1908 -- happens at the end of Analyze_Declarations.
1910 -- Chain spec PPC pragma to list for subprogram
1912 Set_Next_Pragma (N, Spec_PPC_List (Contract (S)));
1913 Set_Spec_PPC_List (Contract (S), N);
1915 -- Return indicating spec case
1921 -- Start of processing for Check_Precondition_Postcondition
1924 if not Is_List_Member (N) then
1928 -- Preanalyze message argument if present. Visibility in this
1929 -- argument is established at the point of pragma occurrence.
1931 if Arg_Count = 2 then
1932 Check_Optional_Identifier (Arg2, Name_Message);
1933 Preanalyze_Spec_Expression
1934 (Get_Pragma_Arg (Arg2), Standard_String);
1937 -- Record if pragma is disabled
1939 if Check_Enabled (Pname) then
1940 Set_SCO_Pragma_Enabled (Loc);
1943 -- If we are within an inlined body, the legality of the pragma
1944 -- has been checked already.
1946 if In_Inlined_Body then
1951 -- Search prior declarations
1954 while Present (Prev (P)) loop
1957 -- If the previous node is a generic subprogram, do not go to to
1958 -- the original node, which is the unanalyzed tree: we need to
1959 -- attach the pre/postconditions to the analyzed version at this
1960 -- point. They get propagated to the original tree when analyzing
1961 -- the corresponding body.
1963 if Nkind (P) not in N_Generic_Declaration then
1964 PO := Original_Node (P);
1969 -- Skip past prior pragma
1971 if Nkind (PO) = N_Pragma then
1974 -- Skip stuff not coming from source
1976 elsif not Comes_From_Source (PO) then
1978 -- The condition may apply to a subprogram instantiation
1980 if Nkind (PO) = N_Subprogram_Declaration
1981 and then Present (Generic_Parent (Specification (PO)))
1986 elsif Nkind (PO) = N_Subprogram_Declaration
1987 and then In_Instance
1992 -- For all other cases of non source code, do nothing
1998 -- Only remaining possibility is subprogram declaration
2006 -- If we fall through loop, pragma is at start of list, so see if it
2007 -- is at the start of declarations of a subprogram body.
2009 if Nkind (Parent (N)) = N_Subprogram_Body
2010 and then List_Containing (N) = Declarations (Parent (N))
2012 if Operating_Mode /= Generate_Code
2013 or else Inside_A_Generic
2015 -- Analyze pragma expression for correctness and for ASIS use
2017 Preanalyze_Spec_Expression
2018 (Get_Pragma_Arg (Arg1), Standard_Boolean);
2020 -- In ASIS mode, for a pragma generated from a source aspect,
2021 -- also analyze the original aspect expression.
2024 and then Present (Corresponding_Aspect (N))
2026 Preanalyze_Spec_Expression
2027 (Expression (Corresponding_Aspect (N)), Standard_Boolean);
2034 -- See if it is in the pragmas after a library level subprogram
2036 elsif Nkind (Parent (N)) = N_Compilation_Unit_Aux then
2038 -- In formal verification mode, analyze pragma expression for
2039 -- correctness, as it is not expanded later.
2042 Analyze_PPC_In_Decl_Part
2043 (N, Defining_Entity (Unit (Parent (Parent (N)))));
2046 Chain_PPC (Unit (Parent (Parent (N))));
2050 -- If we fall through, pragma was misplaced
2053 end Check_Precondition_Postcondition;
2055 -----------------------------
2056 -- Check_Static_Constraint --
2057 -----------------------------
2059 -- Note: for convenience in writing this procedure, in addition to
2060 -- the officially (i.e. by spec) allowed argument which is always a
2061 -- constraint, it also allows ranges and discriminant associations.
2062 -- Above is not clear ???
2064 procedure Check_Static_Constraint (Constr : Node_Id) is
2066 procedure Require_Static (E : Node_Id);
2067 -- Require given expression to be static expression
2069 --------------------
2070 -- Require_Static --
2071 --------------------
2073 procedure Require_Static (E : Node_Id) is
2075 if not Is_OK_Static_Expression (E) then
2076 Flag_Non_Static_Expr
2077 ("non-static constraint not allowed in Unchecked_Union!", E);
2082 -- Start of processing for Check_Static_Constraint
2085 case Nkind (Constr) is
2086 when N_Discriminant_Association =>
2087 Require_Static (Expression (Constr));
2090 Require_Static (Low_Bound (Constr));
2091 Require_Static (High_Bound (Constr));
2093 when N_Attribute_Reference =>
2094 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
2095 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
2097 when N_Range_Constraint =>
2098 Check_Static_Constraint (Range_Expression (Constr));
2100 when N_Index_Or_Discriminant_Constraint =>
2104 IDC := First (Constraints (Constr));
2105 while Present (IDC) loop
2106 Check_Static_Constraint (IDC);
2114 end Check_Static_Constraint;
2116 ---------------------
2117 -- Check_Test_Case --
2118 ---------------------
2120 procedure Check_Test_Case is
2124 procedure Chain_TC (PO : Node_Id);
2125 -- If PO is a [generic] subprogram declaration node, then the
2126 -- test-case applies to this subprogram and the processing for the
2127 -- pragma is completed. Otherwise the pragma is misplaced.
2133 procedure Chain_TC (PO : Node_Id) is
2137 if Nkind (PO) = N_Abstract_Subprogram_Declaration then
2138 if From_Aspect_Specification (N) then
2140 ("aspect% cannot be applied to abstract subprogram");
2143 ("pragma% cannot be applied to abstract subprogram");
2146 elsif Nkind (PO) = N_Entry_Declaration then
2147 if From_Aspect_Specification (N) then
2148 Error_Pragma ("aspect% cannot be applied to entry");
2150 Error_Pragma ("pragma% cannot be applied to entry");
2153 elsif not Nkind_In (PO, N_Subprogram_Declaration,
2154 N_Generic_Subprogram_Declaration)
2159 -- Here if we have [generic] subprogram declaration
2161 S := Defining_Unit_Name (Specification (PO));
2163 -- Note: we do not analyze the pragma at this point. Instead we
2164 -- delay this analysis until the end of the declarative part in
2165 -- which the pragma appears. This implements the required delay
2166 -- in this analysis, allowing forward references. The analysis
2167 -- happens at the end of Analyze_Declarations.
2169 -- There should not be another test case with the same name
2170 -- associated to this subprogram.
2173 Name : constant String_Id := Get_Name_From_Test_Case_Pragma (N);
2177 TC := Spec_TC_List (Contract (S));
2178 while Present (TC) loop
2181 (Name, Get_Name_From_Test_Case_Pragma (TC))
2183 Error_Msg_Sloc := Sloc (TC);
2185 if From_Aspect_Specification (N) then
2186 Error_Pragma ("name for aspect% is already used#");
2188 Error_Pragma ("name for pragma% is already used#");
2192 TC := Next_Pragma (TC);
2196 -- Chain spec TC pragma to list for subprogram
2198 Set_Next_Pragma (N, Spec_TC_List (Contract (S)));
2199 Set_Spec_TC_List (Contract (S), N);
2202 -- Start of processing for Check_Test_Case
2205 if not Is_List_Member (N) then
2209 -- Test cases should only appear in package spec unit
2211 if Get_Source_Unit (N) = No_Unit
2212 or else not Nkind_In (Sinfo.Unit (Cunit (Get_Source_Unit (N))),
2213 N_Package_Declaration,
2214 N_Generic_Package_Declaration)
2219 -- Search prior declarations
2222 while Present (Prev (P)) loop
2225 -- If the previous node is a generic subprogram, do not go to to
2226 -- the original node, which is the unanalyzed tree: we need to
2227 -- attach the test-case to the analyzed version at this point.
2228 -- They get propagated to the original tree when analyzing the
2229 -- corresponding body.
2231 if Nkind (P) not in N_Generic_Declaration then
2232 PO := Original_Node (P);
2237 -- Skip past prior pragma
2239 if Nkind (PO) = N_Pragma then
2242 -- Skip stuff not coming from source
2244 elsif not Comes_From_Source (PO) then
2247 -- Only remaining possibility is subprogram declaration. First
2248 -- check that it is declared directly in a package declaration.
2249 -- This may be either the package declaration for the current unit
2250 -- being defined or a local package declaration.
2252 elsif not Present (Parent (Parent (PO)))
2253 or else not Present (Parent (Parent (Parent (PO))))
2254 or else not Nkind_In (Parent (Parent (PO)),
2255 N_Package_Declaration,
2256 N_Generic_Package_Declaration)
2266 -- If we fall through, pragma was misplaced
2269 end Check_Test_Case;
2271 --------------------------------------
2272 -- Check_Valid_Configuration_Pragma --
2273 --------------------------------------
2275 -- A configuration pragma must appear in the context clause of a
2276 -- compilation unit, and only other pragmas may precede it. Note that
2277 -- the test also allows use in a configuration pragma file.
2279 procedure Check_Valid_Configuration_Pragma is
2281 if not Is_Configuration_Pragma then
2282 Error_Pragma ("incorrect placement for configuration pragma%");
2284 end Check_Valid_Configuration_Pragma;
2286 -------------------------------------
2287 -- Check_Valid_Library_Unit_Pragma --
2288 -------------------------------------
2290 procedure Check_Valid_Library_Unit_Pragma is
2292 Parent_Node : Node_Id;
2293 Unit_Name : Entity_Id;
2294 Unit_Kind : Node_Kind;
2295 Unit_Node : Node_Id;
2296 Sindex : Source_File_Index;
2299 if not Is_List_Member (N) then
2303 Plist := List_Containing (N);
2304 Parent_Node := Parent (Plist);
2306 if Parent_Node = Empty then
2309 -- Case of pragma appearing after a compilation unit. In this case
2310 -- it must have an argument with the corresponding name and must
2311 -- be part of the following pragmas of its parent.
2313 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
2314 if Plist /= Pragmas_After (Parent_Node) then
2317 elsif Arg_Count = 0 then
2319 ("argument required if outside compilation unit");
2322 Check_No_Identifiers;
2323 Check_Arg_Count (1);
2324 Unit_Node := Unit (Parent (Parent_Node));
2325 Unit_Kind := Nkind (Unit_Node);
2327 Analyze (Get_Pragma_Arg (Arg1));
2329 if Unit_Kind = N_Generic_Subprogram_Declaration
2330 or else Unit_Kind = N_Subprogram_Declaration
2332 Unit_Name := Defining_Entity (Unit_Node);
2334 elsif Unit_Kind in N_Generic_Instantiation then
2335 Unit_Name := Defining_Entity (Unit_Node);
2338 Unit_Name := Cunit_Entity (Current_Sem_Unit);
2341 if Chars (Unit_Name) /=
2342 Chars (Entity (Get_Pragma_Arg (Arg1)))
2345 ("pragma% argument is not current unit name", Arg1);
2348 if Ekind (Unit_Name) = E_Package
2349 and then Present (Renamed_Entity (Unit_Name))
2351 Error_Pragma ("pragma% not allowed for renamed package");
2355 -- Pragma appears other than after a compilation unit
2358 -- Here we check for the generic instantiation case and also
2359 -- for the case of processing a generic formal package. We
2360 -- detect these cases by noting that the Sloc on the node
2361 -- does not belong to the current compilation unit.
2363 Sindex := Source_Index (Current_Sem_Unit);
2365 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
2366 Rewrite (N, Make_Null_Statement (Loc));
2369 -- If before first declaration, the pragma applies to the
2370 -- enclosing unit, and the name if present must be this name.
2372 elsif Is_Before_First_Decl (N, Plist) then
2373 Unit_Node := Unit_Declaration_Node (Current_Scope);
2374 Unit_Kind := Nkind (Unit_Node);
2376 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
2379 elsif Unit_Kind = N_Subprogram_Body
2380 and then not Acts_As_Spec (Unit_Node)
2384 elsif Nkind (Parent_Node) = N_Package_Body then
2387 elsif Nkind (Parent_Node) = N_Package_Specification
2388 and then Plist = Private_Declarations (Parent_Node)
2392 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
2393 or else Nkind (Parent_Node) =
2394 N_Generic_Subprogram_Declaration)
2395 and then Plist = Generic_Formal_Declarations (Parent_Node)
2399 elsif Arg_Count > 0 then
2400 Analyze (Get_Pragma_Arg (Arg1));
2402 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
2404 ("name in pragma% must be enclosing unit", Arg1);
2407 -- It is legal to have no argument in this context
2413 -- Error if not before first declaration. This is because a
2414 -- library unit pragma argument must be the name of a library
2415 -- unit (RM 10.1.5(7)), but the only names permitted in this
2416 -- context are (RM 10.1.5(6)) names of subprogram declarations,
2417 -- generic subprogram declarations or generic instantiations.
2421 ("pragma% misplaced, must be before first declaration");
2425 end Check_Valid_Library_Unit_Pragma;
2431 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
2432 Clist : constant Node_Id := Component_List (Variant);
2436 if not Is_Non_Empty_List (Component_Items (Clist)) then
2438 ("Unchecked_Union may not have empty component list",
2443 Comp := First (Component_Items (Clist));
2444 while Present (Comp) loop
2445 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
2454 procedure Error_Pragma (Msg : String) is
2455 MsgF : String := Msg;
2457 Error_Msg_Name_1 := Pname;
2459 Error_Msg_N (MsgF, N);
2463 ----------------------
2464 -- Error_Pragma_Arg --
2465 ----------------------
2467 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
2468 MsgF : String := Msg;
2470 Error_Msg_Name_1 := Pname;
2472 Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
2474 end Error_Pragma_Arg;
2476 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
2477 MsgF : String := Msg1;
2479 Error_Msg_Name_1 := Pname;
2481 Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
2482 Error_Pragma_Arg (Msg2, Arg);
2483 end Error_Pragma_Arg;
2485 ----------------------------
2486 -- Error_Pragma_Arg_Ident --
2487 ----------------------------
2489 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
2490 MsgF : String := Msg;
2492 Error_Msg_Name_1 := Pname;
2494 Error_Msg_N (MsgF, Arg);
2496 end Error_Pragma_Arg_Ident;
2498 ----------------------
2499 -- Error_Pragma_Ref --
2500 ----------------------
2502 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
2503 MsgF : String := Msg;
2505 Error_Msg_Name_1 := Pname;
2507 Error_Msg_Sloc := Sloc (Ref);
2508 Error_Msg_NE (MsgF, N, Ref);
2510 end Error_Pragma_Ref;
2512 ------------------------
2513 -- Find_Lib_Unit_Name --
2514 ------------------------
2516 function Find_Lib_Unit_Name return Entity_Id is
2518 -- Return inner compilation unit entity, for case of nested
2519 -- categorization pragmas. This happens in generic unit.
2521 if Nkind (Parent (N)) = N_Package_Specification
2522 and then Defining_Entity (Parent (N)) /= Current_Scope
2524 return Defining_Entity (Parent (N));
2526 return Current_Scope;
2528 end Find_Lib_Unit_Name;
2530 ----------------------------
2531 -- Find_Program_Unit_Name --
2532 ----------------------------
2534 procedure Find_Program_Unit_Name (Id : Node_Id) is
2535 Unit_Name : Entity_Id;
2536 Unit_Kind : Node_Kind;
2537 P : constant Node_Id := Parent (N);
2540 if Nkind (P) = N_Compilation_Unit then
2541 Unit_Kind := Nkind (Unit (P));
2543 if Unit_Kind = N_Subprogram_Declaration
2544 or else Unit_Kind = N_Package_Declaration
2545 or else Unit_Kind in N_Generic_Declaration
2547 Unit_Name := Defining_Entity (Unit (P));
2549 if Chars (Id) = Chars (Unit_Name) then
2550 Set_Entity (Id, Unit_Name);
2551 Set_Etype (Id, Etype (Unit_Name));
2553 Set_Etype (Id, Any_Type);
2555 ("cannot find program unit referenced by pragma%");
2559 Set_Etype (Id, Any_Type);
2560 Error_Pragma ("pragma% inapplicable to this unit");
2566 end Find_Program_Unit_Name;
2568 -----------------------------------------
2569 -- Find_Unique_Parameterless_Procedure --
2570 -----------------------------------------
2572 function Find_Unique_Parameterless_Procedure
2574 Arg : Node_Id) return Entity_Id
2576 Proc : Entity_Id := Empty;
2579 -- The body of this procedure needs some comments ???
2581 if not Is_Entity_Name (Name) then
2583 ("argument of pragma% must be entity name", Arg);
2585 elsif not Is_Overloaded (Name) then
2586 Proc := Entity (Name);
2588 if Ekind (Proc) /= E_Procedure
2589 or else Present (First_Formal (Proc))
2592 ("argument of pragma% must be parameterless procedure", Arg);
2597 Found : Boolean := False;
2599 Index : Interp_Index;
2602 Get_First_Interp (Name, Index, It);
2603 while Present (It.Nam) loop
2606 if Ekind (Proc) = E_Procedure
2607 and then No (First_Formal (Proc))
2611 Set_Entity (Name, Proc);
2612 Set_Is_Overloaded (Name, False);
2615 ("ambiguous handler name for pragma% ", Arg);
2619 Get_Next_Interp (Index, It);
2624 ("argument of pragma% must be parameterless procedure",
2627 Proc := Entity (Name);
2633 end Find_Unique_Parameterless_Procedure;
2639 procedure Fix_Error (Msg : in out String) is
2641 if From_Aspect_Specification (N) then
2642 for J in Msg'First .. Msg'Last - 5 loop
2643 if Msg (J .. J + 5) = "pragma" then
2644 Msg (J .. J + 5) := "aspect";
2648 if Error_Msg_Name_1 = Name_Precondition then
2649 Error_Msg_Name_1 := Name_Pre;
2650 elsif Error_Msg_Name_1 = Name_Postcondition then
2651 Error_Msg_Name_1 := Name_Post;
2656 -------------------------
2657 -- Gather_Associations --
2658 -------------------------
2660 procedure Gather_Associations
2662 Args : out Args_List)
2667 -- Initialize all parameters to Empty
2669 for J in Args'Range loop
2673 -- That's all we have to do if there are no argument associations
2675 if No (Pragma_Argument_Associations (N)) then
2679 -- Otherwise first deal with any positional parameters present
2681 Arg := First (Pragma_Argument_Associations (N));
2682 for Index in Args'Range loop
2683 exit when No (Arg) or else Chars (Arg) /= No_Name;
2684 Args (Index) := Get_Pragma_Arg (Arg);
2688 -- Positional parameters all processed, if any left, then we
2689 -- have too many positional parameters.
2691 if Present (Arg) and then Chars (Arg) = No_Name then
2693 ("too many positional associations for pragma%", Arg);
2696 -- Process named parameters if any are present
2698 while Present (Arg) loop
2699 if Chars (Arg) = No_Name then
2701 ("positional association cannot follow named association",
2705 for Index in Names'Range loop
2706 if Names (Index) = Chars (Arg) then
2707 if Present (Args (Index)) then
2709 ("duplicate argument association for pragma%", Arg);
2711 Args (Index) := Get_Pragma_Arg (Arg);
2716 if Index = Names'Last then
2717 Error_Msg_Name_1 := Pname;
2718 Error_Msg_N ("pragma% does not allow & argument", Arg);
2720 -- Check for possible misspelling
2722 for Index1 in Names'Range loop
2723 if Is_Bad_Spelling_Of
2724 (Chars (Arg), Names (Index1))
2726 Error_Msg_Name_1 := Names (Index1);
2727 Error_Msg_N -- CODEFIX
2728 ("\possible misspelling of%", Arg);
2740 end Gather_Associations;
2746 procedure GNAT_Pragma is
2748 -- We need to check the No_Implementation_Pragmas restriction for
2749 -- the case of a pragma from source. Note that the case of aspects
2750 -- generating corresponding pragmas marks these pragmas as not being
2751 -- from source, so this test also catches that case.
2753 if Comes_From_Source (N) then
2754 Check_Restriction (No_Implementation_Pragmas, N);
2758 --------------------------
2759 -- Is_Before_First_Decl --
2760 --------------------------
2762 function Is_Before_First_Decl
2763 (Pragma_Node : Node_Id;
2764 Decls : List_Id) return Boolean
2766 Item : Node_Id := First (Decls);
2769 -- Only other pragmas can come before this pragma
2772 if No (Item) or else Nkind (Item) /= N_Pragma then
2775 elsif Item = Pragma_Node then
2781 end Is_Before_First_Decl;
2783 -----------------------------
2784 -- Is_Configuration_Pragma --
2785 -----------------------------
2787 -- A configuration pragma must appear in the context clause of a
2788 -- compilation unit, and only other pragmas may precede it. Note that
2789 -- the test below also permits use in a configuration pragma file.
2791 function Is_Configuration_Pragma return Boolean is
2792 Lis : constant List_Id := List_Containing (N);
2793 Par : constant Node_Id := Parent (N);
2797 -- If no parent, then we are in the configuration pragma file,
2798 -- so the placement is definitely appropriate.
2803 -- Otherwise we must be in the context clause of a compilation unit
2804 -- and the only thing allowed before us in the context list is more
2805 -- configuration pragmas.
2807 elsif Nkind (Par) = N_Compilation_Unit
2808 and then Context_Items (Par) = Lis
2815 elsif Nkind (Prg) /= N_Pragma then
2825 end Is_Configuration_Pragma;
2827 --------------------------
2828 -- Is_In_Context_Clause --
2829 --------------------------
2831 function Is_In_Context_Clause return Boolean is
2833 Parent_Node : Node_Id;
2836 if not Is_List_Member (N) then
2840 Plist := List_Containing (N);
2841 Parent_Node := Parent (Plist);
2843 if Parent_Node = Empty
2844 or else Nkind (Parent_Node) /= N_Compilation_Unit
2845 or else Context_Items (Parent_Node) /= Plist
2852 end Is_In_Context_Clause;
2854 ---------------------------------
2855 -- Is_Static_String_Expression --
2856 ---------------------------------
2858 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
2859 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
2862 Analyze_And_Resolve (Argx);
2863 return Is_OK_Static_Expression (Argx)
2864 and then Nkind (Argx) = N_String_Literal;
2865 end Is_Static_String_Expression;
2867 ----------------------
2868 -- Pragma_Misplaced --
2869 ----------------------
2871 procedure Pragma_Misplaced is
2873 Error_Pragma ("incorrect placement of pragma%");
2874 end Pragma_Misplaced;
2876 ------------------------------------
2877 -- Process Atomic_Shared_Volatile --
2878 ------------------------------------
2880 procedure Process_Atomic_Shared_Volatile is
2887 procedure Set_Atomic (E : Entity_Id);
2888 -- Set given type as atomic, and if no explicit alignment was given,
2889 -- set alignment to unknown, since back end knows what the alignment
2890 -- requirements are for atomic arrays. Note: this step is necessary
2891 -- for derived types.
2897 procedure Set_Atomic (E : Entity_Id) is
2901 if not Has_Alignment_Clause (E) then
2902 Set_Alignment (E, Uint_0);
2906 -- Start of processing for Process_Atomic_Shared_Volatile
2909 Check_Ada_83_Warning;
2910 Check_No_Identifiers;
2911 Check_Arg_Count (1);
2912 Check_Arg_Is_Local_Name (Arg1);
2913 E_Id := Get_Pragma_Arg (Arg1);
2915 if Etype (E_Id) = Any_Type then
2920 D := Declaration_Node (E);
2923 -- Check duplicate before we chain ourselves!
2925 Check_Duplicate_Pragma (E);
2927 -- Now check appropriateness of the entity
2930 if Rep_Item_Too_Early (E, N)
2932 Rep_Item_Too_Late (E, N)
2936 Check_First_Subtype (Arg1);
2939 if Prag_Id /= Pragma_Volatile then
2941 Set_Atomic (Underlying_Type (E));
2942 Set_Atomic (Base_Type (E));
2945 -- Attribute belongs on the base type. If the view of the type is
2946 -- currently private, it also belongs on the underlying type.
2948 Set_Is_Volatile (Base_Type (E));
2949 Set_Is_Volatile (Underlying_Type (E));
2951 Set_Treat_As_Volatile (E);
2952 Set_Treat_As_Volatile (Underlying_Type (E));
2954 elsif K = N_Object_Declaration
2955 or else (K = N_Component_Declaration
2956 and then Original_Record_Component (E) = E)
2958 if Rep_Item_Too_Late (E, N) then
2962 if Prag_Id /= Pragma_Volatile then
2965 -- If the object declaration has an explicit initialization, a
2966 -- temporary may have to be created to hold the expression, to
2967 -- ensure that access to the object remain atomic.
2969 if Nkind (Parent (E)) = N_Object_Declaration
2970 and then Present (Expression (Parent (E)))
2972 Set_Has_Delayed_Freeze (E);
2975 -- An interesting improvement here. If an object of composite
2976 -- type X is declared atomic, and the type X isn't, that's a
2977 -- pity, since it may not have appropriate alignment etc. We
2978 -- can rescue this in the special case where the object and
2979 -- type are in the same unit by just setting the type as
2980 -- atomic, so that the back end will process it as atomic.
2982 -- Note: we used to do this for elementary types as well,
2983 -- but that turns out to be a bad idea and can have unwanted
2984 -- effects, most notably if the type is elementary, the object
2985 -- a simple component within a record, and both are in a spec:
2986 -- every object of this type in the entire program will be
2987 -- treated as atomic, thus incurring a potentially costly
2988 -- synchronization operation for every access.
2990 -- Of course it would be best if the back end could just adjust
2991 -- the alignment etc for the specific object, but that's not
2992 -- something we are capable of doing at this point.
2994 Utyp := Underlying_Type (Etype (E));
2997 and then Is_Composite_Type (Utyp)
2998 and then Sloc (E) > No_Location
2999 and then Sloc (Utyp) > No_Location
3001 Get_Source_File_Index (Sloc (E)) =
3002 Get_Source_File_Index (Sloc (Underlying_Type (Etype (E))))
3004 Set_Is_Atomic (Underlying_Type (Etype (E)));
3008 Set_Is_Volatile (E);
3009 Set_Treat_As_Volatile (E);
3013 ("inappropriate entity for pragma%", Arg1);
3015 end Process_Atomic_Shared_Volatile;
3017 -------------------------------------------
3018 -- Process_Compile_Time_Warning_Or_Error --
3019 -------------------------------------------
3021 procedure Process_Compile_Time_Warning_Or_Error is
3022 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
3025 Check_Arg_Count (2);
3026 Check_No_Identifiers;
3027 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
3028 Analyze_And_Resolve (Arg1x, Standard_Boolean);
3030 if Compile_Time_Known_Value (Arg1x) then
3031 if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
3033 Str : constant String_Id :=
3034 Strval (Get_Pragma_Arg (Arg2));
3035 Len : constant Int := String_Length (Str);
3040 Cent : constant Entity_Id :=
3041 Cunit_Entity (Current_Sem_Unit);
3043 Force : constant Boolean :=
3044 Prag_Id = Pragma_Compile_Time_Warning
3046 Is_Spec_Name (Unit_Name (Current_Sem_Unit))
3047 and then (Ekind (Cent) /= E_Package
3048 or else not In_Private_Part (Cent));
3049 -- Set True if this is the warning case, and we are in the
3050 -- visible part of a package spec, or in a subprogram spec,
3051 -- in which case we want to force the client to see the
3052 -- warning, even though it is not in the main unit.
3055 -- Loop through segments of message separated by line feeds.
3056 -- We output these segments as separate messages with
3057 -- continuation marks for all but the first.
3062 Error_Msg_Strlen := 0;
3064 -- Loop to copy characters from argument to error message
3068 exit when Ptr > Len;
3069 CC := Get_String_Char (Str, Ptr);
3072 -- Ignore wide chars ??? else store character
3074 if In_Character_Range (CC) then
3075 C := Get_Character (CC);
3076 exit when C = ASCII.LF;
3077 Error_Msg_Strlen := Error_Msg_Strlen + 1;
3078 Error_Msg_String (Error_Msg_Strlen) := C;
3082 -- Here with one line ready to go
3084 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
3086 -- If this is a warning in a spec, then we want clients
3087 -- to see the warning, so mark the message with the
3088 -- special sequence !! to force the warning. In the case
3089 -- of a package spec, we do not force this if we are in
3090 -- the private part of the spec.
3093 if Cont = False then
3094 Error_Msg_N ("<~!!", Arg1);
3097 Error_Msg_N ("\<~!!", Arg1);
3100 -- Error, rather than warning, or in a body, so we do not
3101 -- need to force visibility for client (error will be
3102 -- output in any case, and this is the situation in which
3103 -- we do not want a client to get a warning, since the
3104 -- warning is in the body or the spec private part).
3107 if Cont = False then
3108 Error_Msg_N ("<~", Arg1);
3111 Error_Msg_N ("\<~", Arg1);
3115 exit when Ptr > Len;
3120 end Process_Compile_Time_Warning_Or_Error;
3122 ------------------------
3123 -- Process_Convention --
3124 ------------------------
3126 procedure Process_Convention
3127 (C : out Convention_Id;
3128 Ent : out Entity_Id)
3134 Comp_Unit : Unit_Number_Type;
3136 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
3137 -- Called if we have more than one Export/Import/Convention pragma.
3138 -- This is generally illegal, but we have a special case of allowing
3139 -- Import and Interface to coexist if they specify the convention in
3140 -- a consistent manner. We are allowed to do this, since Interface is
3141 -- an implementation defined pragma, and we choose to do it since we
3142 -- know Rational allows this combination. S is the entity id of the
3143 -- subprogram in question. This procedure also sets the special flag
3144 -- Import_Interface_Present in both pragmas in the case where we do
3145 -- have matching Import and Interface pragmas.
3147 procedure Set_Convention_From_Pragma (E : Entity_Id);
3148 -- Set convention in entity E, and also flag that the entity has a
3149 -- convention pragma. If entity is for a private or incomplete type,
3150 -- also set convention and flag on underlying type. This procedure
3151 -- also deals with the special case of C_Pass_By_Copy convention.
3153 -------------------------------
3154 -- Diagnose_Multiple_Pragmas --
3155 -------------------------------
3157 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
3158 Pdec : constant Node_Id := Declaration_Node (S);
3162 function Same_Convention (Decl : Node_Id) return Boolean;
3163 -- Decl is a pragma node. This function returns True if this
3164 -- pragma has a first argument that is an identifier with a
3165 -- Chars field corresponding to the Convention_Id C.
3167 function Same_Name (Decl : Node_Id) return Boolean;
3168 -- Decl is a pragma node. This function returns True if this
3169 -- pragma has a second argument that is an identifier with a
3170 -- Chars field that matches the Chars of the current subprogram.
3172 ---------------------
3173 -- Same_Convention --
3174 ---------------------
3176 function Same_Convention (Decl : Node_Id) return Boolean is
3177 Arg1 : constant Node_Id :=
3178 First (Pragma_Argument_Associations (Decl));
3181 if Present (Arg1) then
3183 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
3185 if Nkind (Arg) = N_Identifier
3186 and then Is_Convention_Name (Chars (Arg))
3187 and then Get_Convention_Id (Chars (Arg)) = C
3195 end Same_Convention;
3201 function Same_Name (Decl : Node_Id) return Boolean is
3202 Arg1 : constant Node_Id :=
3203 First (Pragma_Argument_Associations (Decl));
3211 Arg2 := Next (Arg1);
3218 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
3220 if Nkind (Arg) = N_Identifier
3221 and then Chars (Arg) = Chars (S)
3230 -- Start of processing for Diagnose_Multiple_Pragmas
3235 -- Definitely give message if we have Convention/Export here
3237 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
3240 -- If we have an Import or Export, scan back from pragma to
3241 -- find any previous pragma applying to the same procedure.
3242 -- The scan will be terminated by the start of the list, or
3243 -- hitting the subprogram declaration. This won't allow one
3244 -- pragma to appear in the public part and one in the private
3245 -- part, but that seems very unlikely in practice.
3249 while Present (Decl) and then Decl /= Pdec loop
3251 -- Look for pragma with same name as us
3253 if Nkind (Decl) = N_Pragma
3254 and then Same_Name (Decl)
3256 -- Give error if same as our pragma or Export/Convention
3258 if Pragma_Name (Decl) = Name_Export
3260 Pragma_Name (Decl) = Name_Convention
3262 Pragma_Name (Decl) = Pragma_Name (N)
3266 -- Case of Import/Interface or the other way round
3268 elsif Pragma_Name (Decl) = Name_Interface
3270 Pragma_Name (Decl) = Name_Import
3272 -- Here we know that we have Import and Interface. It
3273 -- doesn't matter which way round they are. See if
3274 -- they specify the same convention. If so, all OK,
3275 -- and set special flags to stop other messages
3277 if Same_Convention (Decl) then
3278 Set_Import_Interface_Present (N);
3279 Set_Import_Interface_Present (Decl);
3282 -- If different conventions, special message
3285 Error_Msg_Sloc := Sloc (Decl);
3287 ("convention differs from that given#", Arg1);
3297 -- Give message if needed if we fall through those tests
3301 ("at most one Convention/Export/Import pragma is allowed",
3304 end Diagnose_Multiple_Pragmas;
3306 --------------------------------
3307 -- Set_Convention_From_Pragma --
3308 --------------------------------
3310 procedure Set_Convention_From_Pragma (E : Entity_Id) is
3312 -- Ada 2005 (AI-430): Check invalid attempt to change convention
3313 -- for an overridden dispatching operation. Technically this is
3314 -- an amendment and should only be done in Ada 2005 mode. However,
3315 -- this is clearly a mistake, since the problem that is addressed
3316 -- by this AI is that there is a clear gap in the RM!
3318 if Is_Dispatching_Operation (E)
3319 and then Present (Overridden_Operation (E))
3320 and then C /= Convention (Overridden_Operation (E))
3323 ("cannot change convention for " &
3324 "overridden dispatching operation",
3328 -- Set the convention
3330 Set_Convention (E, C);
3331 Set_Has_Convention_Pragma (E);
3333 if Is_Incomplete_Or_Private_Type (E)
3334 and then Present (Underlying_Type (E))
3336 Set_Convention (Underlying_Type (E), C);
3337 Set_Has_Convention_Pragma (Underlying_Type (E), True);
3340 -- A class-wide type should inherit the convention of the specific
3341 -- root type (although this isn't specified clearly by the RM).
3343 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
3344 Set_Convention (Class_Wide_Type (E), C);
3347 -- If the entity is a record type, then check for special case of
3348 -- C_Pass_By_Copy, which is treated the same as C except that the
3349 -- special record flag is set. This convention is only permitted
3350 -- on record types (see AI95-00131).
3352 if Cname = Name_C_Pass_By_Copy then
3353 if Is_Record_Type (E) then
3354 Set_C_Pass_By_Copy (Base_Type (E));
3355 elsif Is_Incomplete_Or_Private_Type (E)
3356 and then Is_Record_Type (Underlying_Type (E))
3358 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
3361 ("C_Pass_By_Copy convention allowed only for record type",
3366 -- If the entity is a derived boolean type, check for the special
3367 -- case of convention C, C++, or Fortran, where we consider any
3368 -- nonzero value to represent true.
3370 if Is_Discrete_Type (E)
3371 and then Root_Type (Etype (E)) = Standard_Boolean
3377 C = Convention_Fortran)
3379 Set_Nonzero_Is_True (Base_Type (E));
3381 end Set_Convention_From_Pragma;
3383 -- Start of processing for Process_Convention
3386 Check_At_Least_N_Arguments (2);
3387 Check_Optional_Identifier (Arg1, Name_Convention);
3388 Check_Arg_Is_Identifier (Arg1);
3389 Cname := Chars (Get_Pragma_Arg (Arg1));
3391 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
3392 -- tested again below to set the critical flag).
3394 if Cname = Name_C_Pass_By_Copy then
3397 -- Otherwise we must have something in the standard convention list
3399 elsif Is_Convention_Name (Cname) then
3400 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
3402 -- In DEC VMS, it seems that there is an undocumented feature that
3403 -- any unrecognized convention is treated as the default, which for
3404 -- us is convention C. It does not seem so terrible to do this
3405 -- unconditionally, silently in the VMS case, and with a warning
3406 -- in the non-VMS case.
3409 if Warn_On_Export_Import and not OpenVMS_On_Target then
3411 ("?unrecognized convention name, C assumed",
3412 Get_Pragma_Arg (Arg1));
3418 Check_Optional_Identifier (Arg2, Name_Entity);
3419 Check_Arg_Is_Local_Name (Arg2);
3421 Id := Get_Pragma_Arg (Arg2);
3424 if not Is_Entity_Name (Id) then
3425 Error_Pragma_Arg ("entity name required", Arg2);
3430 -- Set entity to return
3434 -- Ada_Pass_By_Copy special checking
3436 if C = Convention_Ada_Pass_By_Copy then
3437 if not Is_First_Subtype (E) then
3439 ("convention `Ada_Pass_By_Copy` only "
3440 & "allowed for types", Arg2);
3443 if Is_By_Reference_Type (E) then
3445 ("convention `Ada_Pass_By_Copy` not allowed for "
3446 & "by-reference type", Arg1);
3450 -- Ada_Pass_By_Reference special checking
3452 if C = Convention_Ada_Pass_By_Reference then
3453 if not Is_First_Subtype (E) then
3455 ("convention `Ada_Pass_By_Reference` only "
3456 & "allowed for types", Arg2);
3459 if Is_By_Copy_Type (E) then
3461 ("convention `Ada_Pass_By_Reference` not allowed for "
3462 & "by-copy type", Arg1);
3466 -- Go to renamed subprogram if present, since convention applies to
3467 -- the actual renamed entity, not to the renaming entity. If the
3468 -- subprogram is inherited, go to parent subprogram.
3470 if Is_Subprogram (E)
3471 and then Present (Alias (E))
3473 if Nkind (Parent (Declaration_Node (E))) =
3474 N_Subprogram_Renaming_Declaration
3476 if Scope (E) /= Scope (Alias (E)) then
3478 ("cannot apply pragma% to non-local entity&#", E);
3483 elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
3484 N_Private_Extension_Declaration)
3485 and then Scope (E) = Scope (Alias (E))
3489 -- Return the parent subprogram the entity was inherited from
3495 -- Check that we are not applying this to a specless body
3497 if Is_Subprogram (E)
3498 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
3501 ("pragma% requires separate spec and must come before body");
3504 -- Check that we are not applying this to a named constant
3506 if Ekind_In (E, E_Named_Integer, E_Named_Real) then
3507 Error_Msg_Name_1 := Pname;
3509 ("cannot apply pragma% to named constant!",
3510 Get_Pragma_Arg (Arg2));
3512 ("\supply appropriate type for&!", Arg2);
3515 if Ekind (E) = E_Enumeration_Literal then
3516 Error_Pragma ("enumeration literal not allowed for pragma%");
3519 -- Check for rep item appearing too early or too late
3521 if Etype (E) = Any_Type
3522 or else Rep_Item_Too_Early (E, N)
3526 elsif Present (Underlying_Type (E)) then
3527 E := Underlying_Type (E);
3530 if Rep_Item_Too_Late (E, N) then
3534 if Has_Convention_Pragma (E) then
3535 Diagnose_Multiple_Pragmas (E);
3537 elsif Convention (E) = Convention_Protected
3538 or else Ekind (Scope (E)) = E_Protected_Type
3541 ("a protected operation cannot be given a different convention",
3545 -- For Intrinsic, a subprogram is required
3547 if C = Convention_Intrinsic
3548 and then not Is_Subprogram (E)
3549 and then not Is_Generic_Subprogram (E)
3552 ("second argument of pragma% must be a subprogram", Arg2);
3557 if C = Convention_Stdcall then
3559 -- A dispatching call is not allowed. A dispatching subprogram
3560 -- cannot be used to interface to the Win32 API, so in fact this
3561 -- check does not impose any effective restriction.
3563 if Is_Dispatching_Operation (E) then
3566 ("dispatching subprograms cannot use Stdcall convention");
3568 -- Subprogram is allowed, but not a generic subprogram, and not a
3569 -- dispatching operation.
3571 elsif not Is_Subprogram (E)
3572 and then not Is_Generic_Subprogram (E)
3576 and then Ekind (E) /= E_Variable
3578 -- An access to subprogram is also allowed
3582 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
3585 ("second argument of pragma% must be subprogram (type)",
3590 if not Is_Subprogram (E)
3591 and then not Is_Generic_Subprogram (E)
3593 Set_Convention_From_Pragma (E);
3596 Check_First_Subtype (Arg2);
3597 Set_Convention_From_Pragma (Base_Type (E));
3599 -- For subprograms, we must set the convention on the
3600 -- internally generated directly designated type as well.
3602 if Ekind (E) = E_Access_Subprogram_Type then
3603 Set_Convention_From_Pragma (Directly_Designated_Type (E));
3607 -- For the subprogram case, set proper convention for all homonyms
3608 -- in same scope and the same declarative part, i.e. the same
3609 -- compilation unit.
3612 Comp_Unit := Get_Source_Unit (E);
3613 Set_Convention_From_Pragma (E);
3615 -- Treat a pragma Import as an implicit body, for GPS use
3617 if Prag_Id = Pragma_Import then
3618 Generate_Reference (E, Id, 'b');
3621 -- Loop through the homonyms of the pragma argument's entity
3626 exit when No (E1) or else Scope (E1) /= Current_Scope;
3628 -- Do not set the pragma on inherited operations or on formal
3631 if Comes_From_Source (E1)
3632 and then Comp_Unit = Get_Source_Unit (E1)
3633 and then not Is_Formal_Subprogram (E1)
3634 and then Nkind (Original_Node (Parent (E1))) /=
3635 N_Full_Type_Declaration
3637 if Present (Alias (E1))
3638 and then Scope (E1) /= Scope (Alias (E1))
3641 ("cannot apply pragma% to non-local entity& declared#",
3645 Set_Convention_From_Pragma (E1);
3647 if Prag_Id = Pragma_Import then
3648 Generate_Reference (E1, Id, 'b');
3652 -- For aspect case, do NOT apply to homonyms
3654 exit when From_Aspect_Specification (N);
3657 end Process_Convention;
3659 ----------------------------------------
3660 -- Process_Disable_Enable_Atomic_Sync --
3661 ----------------------------------------
3663 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
3666 Check_No_Identifiers;
3667 Check_At_Most_N_Arguments (1);
3669 -- Modeled internally as
3670 -- pragma Unsuppress (Atomic_Synchronization [,Entity])
3674 Pragma_Identifier =>
3675 Make_Identifier (Loc, Nam),
3676 Pragma_Argument_Associations => New_List (
3677 Make_Pragma_Argument_Association (Loc,
3679 Make_Identifier (Loc, Name_Atomic_Synchronization)))));
3681 if Present (Arg1) then
3682 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
3686 end Process_Disable_Enable_Atomic_Sync;
3688 -----------------------------------------------------
3689 -- Process_Extended_Import_Export_Exception_Pragma --
3690 -----------------------------------------------------
3692 procedure Process_Extended_Import_Export_Exception_Pragma
3693 (Arg_Internal : Node_Id;
3694 Arg_External : Node_Id;
3702 if not OpenVMS_On_Target then
3704 ("?pragma% ignored (applies only to Open'V'M'S)");
3707 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
3708 Def_Id := Entity (Arg_Internal);
3710 if Ekind (Def_Id) /= E_Exception then
3712 ("pragma% must refer to declared exception", Arg_Internal);
3715 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
3717 if Present (Arg_Form) then
3718 Check_Arg_Is_One_Of (Arg_Form, Name_Ada, Name_VMS);
3721 if Present (Arg_Form)