1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, 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 Stringt; use Stringt;
79 with Stylesw; use Stylesw;
81 with Targparm; use Targparm;
82 with Tbuild; use Tbuild;
84 with Uintp; use Uintp;
85 with Uname; use Uname;
86 with Urealp; use Urealp;
87 with Validsw; use Validsw;
88 with Warnsw; use Warnsw;
90 package body Sem_Prag is
92 ----------------------------------------------
93 -- Common Handling of Import-Export Pragmas --
94 ----------------------------------------------
96 -- In the following section, a number of Import_xxx and Export_xxx pragmas
97 -- are defined by GNAT. These are compatible with the DEC pragmas of the
98 -- same name, and all have the following common form and processing:
101 -- [Internal =>] LOCAL_NAME
102 -- [, [External =>] EXTERNAL_SYMBOL]
103 -- [, other optional parameters ]);
106 -- [Internal =>] LOCAL_NAME
107 -- [, [External =>] EXTERNAL_SYMBOL]
108 -- [, other optional parameters ]);
110 -- EXTERNAL_SYMBOL ::=
112 -- | static_string_EXPRESSION
114 -- The internal LOCAL_NAME designates the entity that is imported or
115 -- exported, and must refer to an entity in the current declarative
116 -- part (as required by the rules for LOCAL_NAME).
118 -- The external linker name is designated by the External parameter if
119 -- given, or the Internal parameter if not (if there is no External
120 -- parameter, the External parameter is a copy of the Internal name).
122 -- If the External parameter is given as a string, then this string is
123 -- treated as an external name (exactly as though it had been given as an
124 -- External_Name parameter for a normal Import pragma).
126 -- If the External parameter is given as an identifier (or there is no
127 -- External parameter, so that the Internal identifier is used), then
128 -- the external name is the characters of the identifier, translated
129 -- to all upper case letters for OpenVMS versions of GNAT, and to all
130 -- lower case letters for all other versions
132 -- Note: the external name specified or implied by any of these special
133 -- Import_xxx or Export_xxx pragmas override an external or link name
134 -- specified in a previous Import or Export pragma.
136 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
137 -- named notation, following the standard rules for subprogram calls, i.e.
138 -- parameters can be given in any order if named notation is used, and
139 -- positional and named notation can be mixed, subject to the rule that all
140 -- positional parameters must appear first.
142 -- Note: All these pragmas are implemented exactly following the DEC design
143 -- and implementation and are intended to be fully compatible with the use
144 -- of these pragmas in the DEC Ada compiler.
146 --------------------------------------------
147 -- Checking for Duplicated External Names --
148 --------------------------------------------
150 -- It is suspicious if two separate Export pragmas use the same external
151 -- name. The following table is used to diagnose this situation so that
152 -- an appropriate warning can be issued.
154 -- The Node_Id stored is for the N_String_Literal node created to hold
155 -- the value of the external name. The Sloc of this node is used to
156 -- cross-reference the location of the duplication.
158 package Externals is new Table.Table (
159 Table_Component_Type => Node_Id,
160 Table_Index_Type => Int,
161 Table_Low_Bound => 0,
162 Table_Initial => 100,
163 Table_Increment => 100,
164 Table_Name => "Name_Externals");
166 -------------------------------------
167 -- Local Subprograms and Variables --
168 -------------------------------------
170 procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id);
171 -- Subsidiary routine to the analysis of pragmas Depends, Global and
172 -- Refined_State. Append an entity to a list. If the list is empty, create
175 function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
176 -- This routine is used for possible casing adjustment of an explicit
177 -- external name supplied as a string literal (the node N), according to
178 -- the casing requirement of Opt.External_Name_Casing. If this is set to
179 -- As_Is, then the string literal is returned unchanged, but if it is set
180 -- to Uppercase or Lowercase, then a new string literal with appropriate
181 -- casing is constructed.
183 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean;
184 -- Subsidiary to the analysis of pragma Global and pragma Depends. Query
185 -- whether a particular item appears in a mixed list of nodes and entities.
186 -- It is assumed that all nodes in the list have entities.
188 function Check_Kind (Nam : Name_Id) return Name_Id;
189 -- This function is used in connection with pragmas Assert, Check,
190 -- and assertion aspects and pragmas, to determine if Check pragmas
191 -- (or corresponding assertion aspects or pragmas) are currently active
192 -- as determined by the presence of -gnata on the command line (which
193 -- sets the default), and the appearance of pragmas Check_Policy and
194 -- Assertion_Policy as configuration pragmas either in a configuration
195 -- pragma file, or at the start of the current unit, or locally given
196 -- Check_Policy and Assertion_Policy pragmas that are currently active.
198 -- The value returned is one of the names Check, Ignore, Disable (On
199 -- returns Check, and Off returns Ignore).
201 -- Note: for assertion kinds Pre'Class, Post'Class, Invariant'Class,
202 -- and Type_Invariant'Class, the name passed is Name_uPre, Name_uPost,
203 -- Name_uInvariant, or Name_uType_Invariant, which corresponds to _Pre,
204 -- _Post, _Invariant, or _Type_Invariant, which are special names used
205 -- in identifiers to represent these attribute references.
207 procedure Collect_Subprogram_Inputs_Outputs
208 (Subp_Id : Entity_Id;
209 Subp_Inputs : in out Elist_Id;
210 Subp_Outputs : in out Elist_Id;
211 Global_Seen : out Boolean);
212 -- Subsidiary to the analysis of pragma Global and pragma Depends. Gather
213 -- all inputs and outputs of subprogram Subp_Id in lists Subp_Inputs and
214 -- Subp_Outputs. If the case where the subprogram has no inputs and/or
215 -- outputs, the corresponding returned list is No_Elist. Flag Global_Seen
216 -- is set when the related subprogram has aspect/pragma Global.
218 function Find_Related_Subprogram
220 Check_Duplicates : Boolean := False) return Node_Id;
221 -- Find the declaration of the related subprogram subject to pragma Prag.
222 -- If flag Check_Duplicates is set, the routine emits errors concerning
223 -- duplicate pragmas. If a related subprogram is found, then either the
224 -- corresponding N_Subprogram_Declaration node is returned, or, if the
225 -- pragma applies to a subprogram body, then the N_Subprogram_Body node
226 -- is returned. Note that in the latter case, no check is made to ensure
227 -- that there is no separate declaration of the subprogram.
229 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
230 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
231 -- original one, following the renaming chain) is returned. Otherwise the
232 -- entity is returned unchanged. Should be in Einfo???
234 function Get_SPARK_Mode_Id (N : Name_Id) return SPARK_Mode_Id;
235 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
236 -- Get_SPARK_Mode_Id. Convert a name into a corresponding value of type
239 function Original_Name (N : Node_Id) return Name_Id;
240 -- N is a pragma node or aspect specification node. This function returns
241 -- the name of the pragma or aspect in original source form, taking into
242 -- account possible rewrites, and also cases where a pragma comes from an
243 -- aspect (in such cases, the name can be different from the pragma name,
244 -- e.g. a Pre aspect generates a Precondition pragma). This also deals with
245 -- the presence of 'Class, which results in one of the special names
246 -- Name_uPre, Name_uPost, Name_uInvariant, or Name_uType_Invariant being
247 -- returned to represent the corresponding aspects with x'Class names.
249 procedure Preanalyze_CTC_Args (N, Arg_Req, Arg_Ens : Node_Id);
250 -- Preanalyze the boolean expressions in the Requires and Ensures arguments
251 -- of a Test_Case pragma if present (possibly Empty). We treat these as
252 -- spec expressions (i.e. similar to a default expression).
254 procedure Rewrite_Assertion_Kind (N : Node_Id);
255 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
256 -- then it is rewritten as an identifier with the corresponding special
257 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas
258 -- Check, Check_Policy.
261 -- This is a dummy function called by the processing for pragma Reviewable.
262 -- It is there for assisting front end debugging. By placing a Reviewable
263 -- pragma in the source program, a breakpoint on rv catches this place in
264 -- the source, allowing convenient stepping to the point of interest.
266 function Requires_Profile_Installation
268 Subp : Node_Id) return Boolean;
269 -- Subsidiary routine to the analysis of pragma Depends and pragma Global.
270 -- Determine whether the profile of subprogram Subp must be installed into
271 -- visibility to access its formals from pragma Prag.
273 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id);
274 -- Place semantic information on the argument of an Elaborate/Elaborate_All
275 -- pragma. Entity name for unit and its parents is taken from item in
276 -- previous with_clause that mentions the unit.
282 procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id) is
285 To_List := New_Elmt_List;
288 Append_Elmt (Item, To_List);
291 -------------------------------
292 -- Adjust_External_Name_Case --
293 -------------------------------
295 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
299 -- Adjust case of literal if required
301 if Opt.External_Name_Exp_Casing = As_Is then
305 -- Copy existing string
311 for J in 1 .. String_Length (Strval (N)) loop
312 CC := Get_String_Char (Strval (N), J);
314 if Opt.External_Name_Exp_Casing = Uppercase
315 and then CC >= Get_Char_Code ('a')
316 and then CC <= Get_Char_Code ('z')
318 Store_String_Char (CC - 32);
320 elsif Opt.External_Name_Exp_Casing = Lowercase
321 and then CC >= Get_Char_Code ('A')
322 and then CC <= Get_Char_Code ('Z')
324 Store_String_Char (CC + 32);
327 Store_String_Char (CC);
332 Make_String_Literal (Sloc (N),
333 Strval => End_String);
335 end Adjust_External_Name_Case;
337 -----------------------------------------
338 -- Analyze_Contract_Cases_In_Decl_Part --
339 -----------------------------------------
341 procedure Analyze_Contract_Cases_In_Decl_Part (N : Node_Id) is
342 Others_Seen : Boolean := False;
344 procedure Analyze_Contract_Case (CCase : Node_Id);
345 -- Verify the legality of a single contract case
347 ---------------------------
348 -- Analyze_Contract_Case --
349 ---------------------------
351 procedure Analyze_Contract_Case (CCase : Node_Id) is
352 Case_Guard : Node_Id;
354 Extra_Guard : Node_Id;
357 if Nkind (CCase) = N_Component_Association then
358 Case_Guard := First (Choices (CCase));
359 Conseq := Expression (CCase);
361 -- Each contract case must have exactly one case guard
363 Extra_Guard := Next (Case_Guard);
365 if Present (Extra_Guard) then
367 ("contract case may have only one case guard", Extra_Guard);
370 -- Check the placement of "others" (if available)
372 if Nkind (Case_Guard) = N_Others_Choice then
375 ("only one others choice allowed in aspect Contract_Cases",
381 elsif Others_Seen then
383 ("others must be the last choice in aspect Contract_Cases",
387 -- Preanalyze the case guard and consequence
389 if Nkind (Case_Guard) /= N_Others_Choice then
390 Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean);
393 Preanalyze_Assert_Expression (Conseq, Standard_Boolean);
395 -- The contract case is malformed
398 Error_Msg_N ("wrong syntax in contract case", CCase);
400 end Analyze_Contract_Case;
404 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
410 Restore_Scope : Boolean := False;
411 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
413 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
418 Subp_Decl := Find_Related_Subprogram (N);
419 Subp_Id := Defining_Unit_Name (Specification (Subp_Decl));
420 All_Cases := Expression (Arg1);
422 -- Multiple contract cases appear in aggregate form
424 if Nkind (All_Cases) = N_Aggregate then
425 if No (Component_Associations (All_Cases)) then
426 Error_Msg_N ("wrong syntax for aspect Contract_Cases", N);
428 -- Individual contract cases appear as component associations
431 -- Ensure that the formal parameters are visible when analyzing
432 -- all clauses. This falls out of the general rule of aspects
433 -- pertaining to subprogram declarations. Skip the installation
434 -- for subprogram bodies because the formals are already visible.
436 if Requires_Profile_Installation (N, Subp_Decl) then
437 Restore_Scope := True;
438 Push_Scope (Subp_Id);
439 Install_Formals (Subp_Id);
442 CCase := First (Component_Associations (All_Cases));
443 while Present (CCase) loop
444 Analyze_Contract_Case (CCase);
448 if Restore_Scope then
454 Error_Msg_N ("wrong syntax for aspect Contract_Cases", N);
456 end Analyze_Contract_Cases_In_Decl_Part;
458 ----------------------------------
459 -- Analyze_Depends_In_Decl_Part --
460 ----------------------------------
462 procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is
463 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
464 Loc : constant Source_Ptr := Sloc (N);
466 All_Inputs_Seen : Elist_Id := No_Elist;
467 -- A list containing the entities of all the inputs processed so far.
468 -- This Elist is populated with unique entities because the same input
469 -- may appear in multiple input lists.
471 Global_Seen : Boolean := False;
472 -- A flag set when pragma Global has been processed
474 Outputs_Seen : Elist_Id := No_Elist;
475 -- A list containing the entities of all the outputs processed so far.
476 -- The elements of this list may come from different output lists.
478 Null_Output_Seen : Boolean := False;
479 -- A flag used to track the legality of a null output
481 Result_Seen : Boolean := False;
482 -- A flag set when Subp_Id'Result is processed
485 -- The entity of the subprogram subject to pragma Depends
487 Subp_Inputs : Elist_Id := No_Elist;
488 Subp_Outputs : Elist_Id := No_Elist;
489 -- Two lists containing the full set of inputs and output of the related
490 -- subprograms. Note that these lists contain both nodes and entities.
492 procedure Analyze_Dependency_Clause
495 -- Verify the legality of a single dependency clause. Flag Is_Last
496 -- denotes whether Clause is the last clause in the relation.
498 procedure Check_Function_Return;
499 -- Verify that Funtion'Result appears as one of the outputs
506 -- Ensure that an item has a proper "in", "in out" or "out" mode
507 -- depending on its function. If this is not the case, emit an error.
508 -- Item and Item_Id denote the attributes of an item. Flag Is_Input
509 -- should be set when item comes from an input list. Flag Self_Ref
510 -- should be set when the item is an output and the dependency clause
513 procedure Check_Usage
514 (Subp_Items : Elist_Id;
515 Used_Items : Elist_Id;
517 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
518 -- error if this is not the case.
520 procedure Normalize_Clause (Clause : Node_Id);
521 -- Remove a self-dependency "+" from the input list of a clause.
522 -- Depending on the contents of the relation, either split the the
523 -- clause into multiple smaller clauses or perform the normalization in
526 -------------------------------
527 -- Analyze_Dependency_Clause --
528 -------------------------------
530 procedure Analyze_Dependency_Clause
534 procedure Analyze_Input_List (Inputs : Node_Id);
535 -- Verify the legality of a single input list
537 procedure Analyze_Input_Output
542 Seen : in out Elist_Id;
543 Null_Seen : in out Boolean);
544 -- Verify the legality of a single input or output item. Flag
545 -- Is_Input should be set whenever Item is an input, False when it
546 -- denotes an output. Flag Self_Ref should be set when the item is an
547 -- output and the dependency clause has a "+". Flag Top_Level should
548 -- be set whenever Item appears immediately within an input or output
549 -- list. Seen is a collection of all abstract states, variables and
550 -- formals processed so far. Flag Null_Seen denotes whether a null
551 -- input or output has been encountered.
553 ------------------------
554 -- Analyze_Input_List --
555 ------------------------
557 procedure Analyze_Input_List (Inputs : Node_Id) is
558 Inputs_Seen : Elist_Id := No_Elist;
559 -- A list containing the entities of all inputs that appear in the
560 -- current input list.
562 Null_Input_Seen : Boolean := False;
563 -- A flag used to track the legality of a null input
568 -- Multiple inputs appear as an aggregate
570 if Nkind (Inputs) = N_Aggregate then
571 if Present (Component_Associations (Inputs)) then
573 ("nested dependency relations not allowed", Inputs);
575 elsif Present (Expressions (Inputs)) then
576 Input := First (Expressions (Inputs));
577 while Present (Input) loop
584 Null_Seen => Null_Input_Seen);
590 Error_Msg_N ("malformed input dependency list", Inputs);
593 -- Process a solitary input
602 Null_Seen => Null_Input_Seen);
605 -- Detect an illegal dependency clause of the form
609 if Null_Output_Seen and then Null_Input_Seen then
611 ("null dependency clause cannot have a null input list",
614 end Analyze_Input_List;
616 --------------------------
617 -- Analyze_Input_Output --
618 --------------------------
620 procedure Analyze_Input_Output
625 Seen : in out Elist_Id;
626 Null_Seen : in out Boolean)
628 Is_Output : constant Boolean := not Is_Input;
633 -- Multiple input or output items appear as an aggregate
635 if Nkind (Item) = N_Aggregate then
636 if not Top_Level then
637 Error_Msg_N ("nested grouping of items not allowed", Item);
639 elsif Present (Component_Associations (Item)) then
641 ("nested dependency relations not allowed", Item);
643 -- Recursively analyze the grouped items
645 elsif Present (Expressions (Item)) then
646 Grouped := First (Expressions (Item));
647 while Present (Grouped) loop
650 Is_Input => Is_Input,
651 Self_Ref => Self_Ref,
654 Null_Seen => Null_Seen);
660 Error_Msg_N ("malformed dependency list", Item);
663 -- Process Function'Result in the context of a dependency clause
665 elsif Nkind (Item) = N_Attribute_Reference
666 and then Attribute_Name (Item) = Name_Result
668 -- It is sufficent to analyze the prefix of 'Result in order to
669 -- establish legality of the attribute.
671 Analyze (Prefix (Item));
673 -- The prefix of 'Result must denote the function for which
674 -- aspect/pragma Depends applies.
676 if not Is_Entity_Name (Prefix (Item))
677 or else Ekind (Subp_Id) /= E_Function
678 or else Entity (Prefix (Item)) /= Subp_Id
680 Error_Msg_Name_1 := Name_Result;
682 ("prefix of attribute % must denote the enclosing "
685 -- Function'Result is allowed to appear on the output side of a
686 -- dependency clause.
689 Error_Msg_N ("function result cannot act as input", Item);
695 -- Detect multiple uses of null in a single dependency list or
696 -- throughout the whole relation. Verify the placement of a null
697 -- output list relative to the other clauses.
699 elsif Nkind (Item) = N_Null then
702 ("multiple null dependency relations not allowed", Item);
706 if Is_Output and then not Is_Last then
708 ("null output list must be the last clause in a "
709 & "dependency relation", Item);
718 -- Find the entity of the item. If this is a renaming, climb
719 -- the renaming chain to reach the root object. Renamings of
720 -- non-entire objects do not yield an entity (Empty).
722 Item_Id := Entity_Of (Item);
724 if Present (Item_Id) then
725 if Ekind_In (Item_Id, E_Abstract_State,
731 -- Ensure that the item is of the correct mode depending
734 Check_Mode (Item, Item_Id, Is_Input, Self_Ref);
736 -- Detect multiple uses of the same state, variable or
737 -- formal parameter. If this is not the case, add the
738 -- item to the list of processed relations.
740 if Contains (Seen, Item_Id) then
741 Error_Msg_N ("duplicate use of item", Item);
743 Add_Item (Item_Id, Seen);
746 -- Detect an illegal use of an input related to a null
747 -- output. Such input items cannot appear in other input
751 and then Contains (All_Inputs_Seen, Item_Id)
754 ("input of a null output list appears in multiple "
755 & "input lists", Item);
757 Add_Item (Item_Id, All_Inputs_Seen);
760 -- When the item renames an entire object, replace the
761 -- item with a reference to the object.
763 if Present (Renamed_Object (Entity (Item))) then
765 New_Reference_To (Item_Id, Sloc (Item)));
769 -- All other input/output items are illegal
773 ("item must denote variable, state or formal "
774 & "parameter", Item);
777 -- All other input/output items are illegal
781 ("item must denote variable, state or formal parameter",
785 end Analyze_Input_Output;
793 -- Start of processing for Analyze_Dependency_Clause
796 Inputs := Expression (Clause);
799 -- An input list with a self-dependency appears as operator "+" where
800 -- the actuals inputs are the right operand.
802 if Nkind (Inputs) = N_Op_Plus then
803 Inputs := Right_Opnd (Inputs);
807 -- Process the output_list of a dependency_clause
809 Output := First (Choices (Clause));
810 while Present (Output) loop
814 Self_Ref => Self_Ref,
816 Seen => Outputs_Seen,
817 Null_Seen => Null_Output_Seen);
822 -- Process the input_list of a dependency_clause
824 Analyze_Input_List (Inputs);
825 end Analyze_Dependency_Clause;
827 ----------------------------
828 -- Check_Function_Return --
829 ----------------------------
831 procedure Check_Function_Return is
833 if Ekind (Subp_Id) = E_Function and then not Result_Seen then
835 ("result of & must appear in exactly one output list",
838 end Check_Function_Return;
854 if Ekind (Item_Id) = E_Out_Parameter
856 and then not Appears_In (Subp_Inputs, Item_Id))
859 ("item & must have mode in or in out", Item, Item_Id);
862 -- Self-referential output
866 -- A self-referential state or variable must appear in both input
867 -- and output lists of a subprogram.
869 if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
872 (Appears_In (Subp_Inputs, Item_Id)
874 Appears_In (Subp_Outputs, Item_Id))
876 Error_Msg_NE ("item & must have mode in out", Item, Item_Id);
879 -- Self-referential parameter
881 elsif Ekind (Item_Id) /= E_In_Out_Parameter then
882 Error_Msg_NE ("item & must have mode in out", Item, Item_Id);
887 elsif Ekind (Item_Id) = E_In_Parameter
889 (Global_Seen and then not Appears_In (Subp_Outputs, Item_Id))
892 ("item & must have mode out or in out", Item, Item_Id);
900 procedure Check_Usage
901 (Subp_Items : Elist_Id;
902 Used_Items : Elist_Id;
905 procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id);
906 -- Emit an error concerning the erroneous usage of an item
912 procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id) is
916 ("item & must appear in at least one input list of aspect "
917 & "Depends", Item, Item_Id);
920 ("item & must appear in exactly one output list of aspect "
921 & "Depends", Item, Item_Id);
931 -- Start of processing for Check_Usage
934 if No (Subp_Items) then
938 -- Each input or output of the subprogram must appear in a dependency
941 Elmt := First_Elmt (Subp_Items);
942 while Present (Elmt) loop
945 if Nkind (Item) = N_Defining_Identifier then
948 Item_Id := Entity (Item);
951 -- The item does not appear in a dependency
953 if not Contains (Used_Items, Item_Id) then
954 if Is_Formal (Item_Id) then
955 Usage_Error (Item, Item_Id);
957 -- States and global variables are not used properly only when
958 -- the subprogram is subject to pragma Global.
960 elsif Global_Seen then
961 Usage_Error (Item, Item_Id);
969 ----------------------
970 -- Normalize_Clause --
971 ----------------------
973 procedure Normalize_Clause (Clause : Node_Id) is
974 procedure Create_Or_Modify_Clause
981 -- Create a brand new clause to represent the self-reference or
982 -- modify the input and/or output lists of an existing clause. Output
983 -- denotes a self-referencial output. Outputs is the output list of a
984 -- clause. Inputs is the input list of a clause. After denotes the
985 -- clause after which the new clause is to be inserted. Flag In_Place
986 -- should be set when normalizing the last output of an output list.
987 -- Flag Multiple should be set when Output comes from a list with
990 -----------------------------
991 -- Create_Or_Modify_Clause --
992 -----------------------------
994 procedure Create_Or_Modify_Clause
1002 procedure Propagate_Output
1005 -- Handle the various cases of output propagation to the input
1006 -- list. Output denotes a self-referencial output item. Inputs is
1007 -- the input list of a clause.
1009 ----------------------
1010 -- Propagate_Output --
1011 ----------------------
1013 procedure Propagate_Output
1017 function In_Input_List
1019 Inputs : List_Id) return Boolean;
1020 -- Determine whether a particulat item appears in the input
1021 -- list of a clause.
1027 function In_Input_List
1029 Inputs : List_Id) return Boolean
1034 Elmt := First (Inputs);
1035 while Present (Elmt) loop
1036 if Entity_Of (Elmt) = Item then
1048 Output_Id : constant Entity_Id := Entity_Of (Output);
1051 -- Start of processing for Propagate_Output
1054 -- The clause is of the form:
1056 -- (Output =>+ null)
1058 -- Remove the null input and replace it with a copy of the
1061 -- (Output => Output)
1063 if Nkind (Inputs) = N_Null then
1064 Rewrite (Inputs, New_Copy_Tree (Output));
1066 -- The clause is of the form:
1068 -- (Output =>+ (Input1, ..., InputN))
1070 -- Determine whether the output is not already mentioned in the
1071 -- input list and if not, add it to the list of inputs:
1073 -- (Output => (Output, Input1, ..., InputN))
1075 elsif Nkind (Inputs) = N_Aggregate then
1076 Grouped := Expressions (Inputs);
1078 if not In_Input_List
1082 Prepend_To (Grouped, New_Copy_Tree (Output));
1085 -- The clause is of the form:
1087 -- (Output =>+ Input)
1089 -- If the input does not mention the output, group the two
1092 -- (Output => (Output, Input))
1094 elsif Entity_Of (Inputs) /= Output_Id then
1096 Make_Aggregate (Loc,
1097 Expressions => New_List (
1098 New_Copy_Tree (Output),
1099 New_Copy_Tree (Inputs))));
1101 end Propagate_Output;
1105 Loc : constant Source_Ptr := Sloc (Output);
1108 -- Start of processing for Create_Or_Modify_Clause
1111 -- A function result cannot depend on itself because it cannot
1112 -- appear in the input list of a relation.
1114 if Nkind (Output) = N_Attribute_Reference
1115 and then Attribute_Name (Output) = Name_Result
1117 Error_Msg_N ("function result cannot depend on itself", Output);
1120 -- A null output depending on itself does not require any
1123 elsif Nkind (Output) = N_Null then
1127 -- When performing the transformation in place, simply add the
1128 -- output to the list of inputs (if not already there). This case
1129 -- arises when dealing with the last output of an output list -
1130 -- we perform the normalization in place to avoid generating a
1134 Propagate_Output (Output, Inputs);
1136 -- A list with multiple outputs is slowly trimmed until only
1137 -- one element remains. When this happens, replace the
1138 -- aggregate with the element itself.
1142 Rewrite (Outputs, Output);
1148 -- Unchain the output from its output list as it will appear in
1149 -- a new clause. Note that we cannot simply rewrite the output
1150 -- as null because this will violate the semantics of aspect or
1155 -- Create a new clause of the form:
1157 -- (Output => Inputs)
1160 Make_Component_Association (Loc,
1161 Choices => New_List (Output),
1162 Expression => New_Copy_Tree (Inputs));
1164 -- The new clause contains replicated content that has already
1165 -- been analyzed. There is not need to reanalyze it or
1166 -- renormalize it again.
1168 Set_Analyzed (Clause);
1171 (Output => First (Choices (Clause)),
1172 Inputs => Expression (Clause));
1174 Insert_After (After, Clause);
1176 end Create_Or_Modify_Clause;
1180 Outputs : constant Node_Id := First (Choices (Clause));
1182 Last_Output : Node_Id;
1183 Next_Output : Node_Id;
1186 -- Start of processing for Normalize_Clause
1189 -- A self-dependency appears as operator "+". Remove the "+" from the
1190 -- tree by moving the real inputs to their proper place.
1192 if Nkind (Expression (Clause)) = N_Op_Plus then
1193 Rewrite (Expression (Clause), Right_Opnd (Expression (Clause)));
1194 Inputs := Expression (Clause);
1196 -- Multiple outputs appear as an aggregate
1198 if Nkind (Outputs) = N_Aggregate then
1199 Last_Output := Last (Expressions (Outputs));
1201 Output := First (Expressions (Outputs));
1202 while Present (Output) loop
1204 -- Normalization may remove an output from its list,
1205 -- preserve the subsequent output now.
1207 Next_Output := Next (Output);
1209 Create_Or_Modify_Clause
1214 In_Place => Output = Last_Output,
1217 Output := Next_Output;
1223 Create_Or_Modify_Clause
1232 end Normalize_Clause;
1238 Last_Clause : Node_Id;
1239 Subp_Decl : Node_Id;
1241 Restore_Scope : Boolean := False;
1242 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
1244 -- Start of processing for Analyze_Depends_In_Decl_Part
1249 Subp_Decl := Find_Related_Subprogram (N);
1250 Subp_Id := Defining_Unit_Name (Specification (Subp_Decl));
1251 Clause := Expression (Arg1);
1253 -- Empty dependency list
1255 if Nkind (Clause) = N_Null then
1257 -- Gather all states, variables and formal parameters that the
1258 -- subprogram may depend on. These items are obtained from the
1259 -- parameter profile or pragma Global (if available).
1261 Collect_Subprogram_Inputs_Outputs
1262 (Subp_Id => Subp_Id,
1263 Subp_Inputs => Subp_Inputs,
1264 Subp_Outputs => Subp_Outputs,
1265 Global_Seen => Global_Seen);
1267 -- Verify that every input or output of the subprogram appear in a
1270 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1271 Check_Usage (Subp_Outputs, Outputs_Seen, False);
1272 Check_Function_Return;
1274 -- Dependency clauses appear as component associations of an aggregate
1276 elsif Nkind (Clause) = N_Aggregate
1277 and then Present (Component_Associations (Clause))
1279 Last_Clause := Last (Component_Associations (Clause));
1281 -- Gather all states, variables and formal parameters that the
1282 -- subprogram may depend on. These items are obtained from the
1283 -- parameter profile or pragma Global (if available).
1285 Collect_Subprogram_Inputs_Outputs
1286 (Subp_Id => Subp_Id,
1287 Subp_Inputs => Subp_Inputs,
1288 Subp_Outputs => Subp_Outputs,
1289 Global_Seen => Global_Seen);
1291 -- Ensure that the formal parameters are visible when analyzing all
1292 -- clauses. This falls out of the general rule of aspects pertaining
1293 -- to subprogram declarations. Skip the installation for subprogram
1294 -- bodies because the formals are already visible.
1296 if Requires_Profile_Installation (N, Subp_Decl) then
1297 Restore_Scope := True;
1298 Push_Scope (Subp_Id);
1299 Install_Formals (Subp_Id);
1302 Clause := First (Component_Associations (Clause));
1303 while Present (Clause) loop
1304 Errors := Serious_Errors_Detected;
1306 -- Normalization may create extra clauses that contain replicated
1307 -- input and output names. There is no need to reanalyze or
1308 -- renormalize these extra clauses.
1310 if not Analyzed (Clause) then
1311 Set_Analyzed (Clause);
1313 Analyze_Dependency_Clause
1315 Is_Last => Clause = Last_Clause);
1317 -- Do not normalize an erroneous clause because the inputs or
1318 -- outputs may denote illegal items.
1320 if Errors = Serious_Errors_Detected then
1321 Normalize_Clause (Clause);
1328 if Restore_Scope then
1332 -- Verify that every input or output of the subprogram appear in a
1335 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1336 Check_Usage (Subp_Outputs, Outputs_Seen, False);
1337 Check_Function_Return;
1339 -- The top level dependency relation is malformed
1342 Error_Msg_N ("malformed dependency relation", Clause);
1344 end Analyze_Depends_In_Decl_Part;
1346 ---------------------------------
1347 -- Analyze_Global_In_Decl_Part --
1348 ---------------------------------
1350 procedure Analyze_Global_In_Decl_Part (N : Node_Id) is
1351 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
1353 Seen : Elist_Id := No_Elist;
1354 -- A list containing the entities of all the items processed so far. It
1355 -- plays a role in detecting distinct entities.
1357 Subp_Id : Entity_Id;
1358 -- The entity of the subprogram subject to pragma Global
1360 Contract_Seen : Boolean := False;
1361 In_Out_Seen : Boolean := False;
1362 Input_Seen : Boolean := False;
1363 Output_Seen : Boolean := False;
1364 -- Flags used to verify the consistency of modes
1366 procedure Analyze_Global_List
1368 Global_Mode : Name_Id := Name_Input);
1369 -- Verify the legality of a single global list declaration. Global_Mode
1370 -- denotes the current mode in effect.
1372 -------------------------
1373 -- Analyze_Global_List --
1374 -------------------------
1376 procedure Analyze_Global_List
1378 Global_Mode : Name_Id := Name_Input)
1380 procedure Analyze_Global_Item
1382 Global_Mode : Name_Id);
1383 -- Verify the legality of a single global item declaration.
1384 -- Global_Mode denotes the current mode in effect.
1386 procedure Check_Duplicate_Mode
1388 Status : in out Boolean);
1389 -- Flag Status denotes whether a particular mode has been seen while
1390 -- processing a global list. This routine verifies that Mode is not a
1391 -- duplicate mode and sets the flag Status.
1393 procedure Check_Mode_Restriction_In_Enclosing_Context
1395 Item_Id : Entity_Id);
1396 -- Verify that an item of mode In_Out or Output does not appear as an
1397 -- input in the Global aspect of an enclosing subprogram. If this is
1398 -- the case, emit an error. Item and Item_Id are respectively the
1399 -- item and its entity.
1401 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id);
1402 -- Mode denotes either In_Out or Output. Depending on the kind of the
1403 -- related subprogram, emit an error if those two modes apply to a
1406 -------------------------
1407 -- Analyze_Global_Item --
1408 -------------------------
1410 procedure Analyze_Global_Item
1412 Global_Mode : Name_Id)
1414 Item_Id : Entity_Id;
1417 -- Detect one of the following cases
1419 -- with Global => (null, Name)
1420 -- with Global => (Name_1, null, Name_2)
1421 -- with Global => (Name, null)
1423 if Nkind (Item) = N_Null then
1424 Error_Msg_N ("cannot mix null and non-null global items", Item);
1430 -- Find the entity of the item. If this is a renaming, climb the
1431 -- renaming chain to reach the root object. Renamings of non-
1432 -- entire objects do not yield an entity (Empty).
1434 Item_Id := Entity_Of (Item);
1436 if Present (Item_Id) then
1438 -- A global item cannot reference a formal parameter. Do this
1439 -- check first to provide a better error diagnostic.
1441 if Is_Formal (Item_Id) then
1443 ("global item cannot reference formal parameter", Item);
1446 -- The only legal references are those to abstract states and
1449 elsif not Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
1451 ("global item must denote variable or state", Item);
1455 -- When the item renames an entire object, replace the item
1456 -- with a reference to the object.
1458 if Present (Renamed_Object (Entity (Item))) then
1459 Rewrite (Item, New_Reference_To (Item_Id, Sloc (Item)));
1463 -- Some form of illegal construct masquerading as a name
1466 Error_Msg_N ("global item must denote variable or state", Item);
1470 -- At this point we know that the global item is one of the two
1471 -- valid choices. Perform mode- and usage-specific checks.
1473 if Ekind (Item_Id) = E_Abstract_State
1474 and then Is_External_State (Item_Id)
1476 -- A global item of mode In_Out or Output cannot denote an
1477 -- external Input_Only state.
1479 if Is_Input_Only_State (Item_Id)
1480 and then Nam_In (Global_Mode, Name_In_Out, Name_Output)
1483 ("global item of mode In_Out or Output cannot reference "
1484 & "External Input_Only state", Item);
1486 -- A global item of mode In_Out or Input cannot reference an
1487 -- external Output_Only state.
1489 elsif Is_Output_Only_State (Item_Id)
1490 and then Nam_In (Global_Mode, Name_In_Out, Name_Input)
1493 ("global item of mode In_Out or Input cannot reference "
1494 & "External Output_Only state", Item);
1498 -- Verify that an output does not appear as an input in an
1499 -- enclosing subprogram.
1501 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
1502 Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id);
1505 -- The same entity might be referenced through various way. Check
1506 -- the entity of the item rather than the item itself.
1508 if Contains (Seen, Item_Id) then
1509 Error_Msg_N ("duplicate global item", Item);
1511 -- Add the entity of the current item to the list of processed
1515 Add_Item (Item_Id, Seen);
1517 end Analyze_Global_Item;
1519 --------------------------
1520 -- Check_Duplicate_Mode --
1521 --------------------------
1523 procedure Check_Duplicate_Mode
1525 Status : in out Boolean)
1529 Error_Msg_N ("duplicate global mode", Mode);
1533 end Check_Duplicate_Mode;
1535 -------------------------------------------------
1536 -- Check_Mode_Restriction_In_Enclosing_Context --
1537 -------------------------------------------------
1539 procedure Check_Mode_Restriction_In_Enclosing_Context
1541 Item_Id : Entity_Id)
1543 Context : Entity_Id;
1545 Inputs : Elist_Id := No_Elist;
1546 Outputs : Elist_Id := No_Elist;
1549 -- Traverse the scope stack looking for enclosing subprograms
1550 -- subject to aspect/pragma Global.
1552 Context := Scope (Subp_Id);
1553 while Present (Context) and then Context /= Standard_Standard loop
1554 if Is_Subprogram (Context)
1555 and then Has_Aspect (Context, Aspect_Global)
1557 Collect_Subprogram_Inputs_Outputs
1558 (Subp_Id => Context,
1559 Subp_Inputs => Inputs,
1560 Subp_Outputs => Outputs,
1561 Global_Seen => Dummy);
1563 -- The item is classified as In_Out or Output but appears as
1564 -- an Input in an enclosing subprogram.
1566 if Appears_In (Inputs, Item_Id)
1567 and then not Appears_In (Outputs, Item_Id)
1570 ("global item & cannot have mode In_Out or Output",
1573 ("\item already appears as input of subprogram &",
1576 -- Stop the traversal once an error has been detected
1582 Context := Scope (Context);
1584 end Check_Mode_Restriction_In_Enclosing_Context;
1586 ----------------------------------------
1587 -- Check_Mode_Restriction_In_Function --
1588 ----------------------------------------
1590 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
1592 if Ekind (Subp_Id) = E_Function then
1594 ("global mode & not applicable to functions", Mode);
1596 end Check_Mode_Restriction_In_Function;
1604 -- Start of processing for Analyze_Global_List
1607 -- Single global item declaration
1609 if Nkind_In (List, N_Expanded_Name,
1611 N_Selected_Component)
1613 Analyze_Global_Item (List, Global_Mode);
1615 -- Simple global list or moded global list declaration
1617 elsif Nkind (List) = N_Aggregate then
1619 -- The declaration of a simple global list appear as a collection
1622 if Present (Expressions (List)) then
1623 if Present (Component_Associations (List)) then
1625 ("cannot mix moded and non-moded global lists", List);
1628 Item := First (Expressions (List));
1629 while Present (Item) loop
1630 Analyze_Global_Item (Item, Global_Mode);
1635 -- The declaration of a moded global list appears as a collection
1636 -- of component associations where individual choices denote
1639 elsif Present (Component_Associations (List)) then
1640 if Present (Expressions (List)) then
1642 ("cannot mix moded and non-moded global lists", List);
1645 Assoc := First (Component_Associations (List));
1646 while Present (Assoc) loop
1647 Mode := First (Choices (Assoc));
1649 if Nkind (Mode) = N_Identifier then
1650 if Chars (Mode) = Name_Contract_In then
1651 Check_Duplicate_Mode (Mode, Contract_Seen);
1653 elsif Chars (Mode) = Name_In_Out then
1654 Check_Duplicate_Mode (Mode, In_Out_Seen);
1655 Check_Mode_Restriction_In_Function (Mode);
1657 elsif Chars (Mode) = Name_Input then
1658 Check_Duplicate_Mode (Mode, Input_Seen);
1660 elsif Chars (Mode) = Name_Output then
1661 Check_Duplicate_Mode (Mode, Output_Seen);
1662 Check_Mode_Restriction_In_Function (Mode);
1665 Error_Msg_N ("invalid mode selector", Mode);
1669 Error_Msg_N ("invalid mode selector", Mode);
1672 -- Items in a moded list appear as a collection of
1673 -- expressions. Reuse the existing machinery to analyze
1677 (List => Expression (Assoc),
1678 Global_Mode => Chars (Mode));
1683 -- Something went horribly wrong, we have a malformed tree
1686 raise Program_Error;
1689 -- Any other attempt to declare a global item is erroneous
1692 Error_Msg_N ("malformed global list declaration", List);
1694 end Analyze_Global_List;
1699 Subp_Decl : Node_Id;
1701 Restore_Scope : Boolean := False;
1702 -- Set True if we do a Push_Scope requiring a Pop_Scope on exit
1704 -- Start of processing for Analyze_Global_In_Decl_List
1709 Subp_Decl := Find_Related_Subprogram (N);
1710 Subp_Id := Defining_Unit_Name (Specification (Subp_Decl));
1711 List := Expression (Arg1);
1713 -- There is nothing to be done for a null global list
1715 if Nkind (List) = N_Null then
1718 -- Analyze the various forms of global lists and items. Note that some
1719 -- of these may be malformed in which case the analysis emits error
1723 -- Ensure that the formal parameters are visible when processing an
1724 -- item. This falls out of the general rule of aspects pertaining to
1725 -- subprogram declarations.
1727 if Requires_Profile_Installation (N, Subp_Decl) then
1728 Restore_Scope := True;
1729 Push_Scope (Subp_Id);
1730 Install_Formals (Subp_Id);
1733 Analyze_Global_List (List);
1735 if Restore_Scope then
1739 end Analyze_Global_In_Decl_Part;
1741 --------------------
1742 -- Analyze_Pragma --
1743 --------------------
1745 procedure Analyze_Pragma (N : Node_Id) is
1746 Loc : constant Source_Ptr := Sloc (N);
1747 Prag_Id : Pragma_Id;
1750 -- Name of the source pragma, or name of the corresponding aspect for
1751 -- pragmas which originate in a source aspect. In the latter case, the
1752 -- name may be different from the pragma name.
1754 Pragma_Exit : exception;
1755 -- This exception is used to exit pragma processing completely. It is
1756 -- used when an error is detected, and no further processing is
1757 -- required. It is also used if an earlier error has left the tree in
1758 -- a state where the pragma should not be processed.
1761 -- Number of pragma argument associations
1767 -- First four pragma arguments (pragma argument association nodes, or
1768 -- Empty if the corresponding argument does not exist).
1770 type Name_List is array (Natural range <>) of Name_Id;
1771 type Args_List is array (Natural range <>) of Node_Id;
1772 -- Types used for arguments to Check_Arg_Order and Gather_Associations
1774 procedure Ada_2005_Pragma;
1775 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
1776 -- Ada 95 mode, these are implementation defined pragmas, so should be
1777 -- caught by the No_Implementation_Pragmas restriction.
1779 procedure Ada_2012_Pragma;
1780 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
1781 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
1782 -- should be caught by the No_Implementation_Pragmas restriction.
1784 procedure Analyze_Refined_Pre_Post_Condition;
1785 -- Subsidiary routine to the analysis of pragmas Refined_Pre and
1788 procedure Check_Ada_83_Warning;
1789 -- Issues a warning message for the current pragma if operating in Ada
1790 -- 83 mode (used for language pragmas that are not a standard part of
1791 -- Ada 83). This procedure does not raise Error_Pragma. Also notes use
1794 procedure Check_Arg_Count (Required : Nat);
1795 -- Check argument count for pragma is equal to given parameter. If not,
1796 -- then issue an error message and raise Pragma_Exit.
1798 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
1799 -- Arg which can either be a pragma argument association, in which case
1800 -- the check is applied to the expression of the association or an
1801 -- expression directly.
1803 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
1804 -- Check that an argument has the right form for an EXTERNAL_NAME
1805 -- parameter of an extended import/export pragma. The rule is that the
1806 -- name must be an identifier or string literal (in Ada 83 mode) or a
1807 -- static string expression (in Ada 95 mode).
1809 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
1810 -- Check the specified argument Arg to make sure that it is an
1811 -- identifier. If not give error and raise Pragma_Exit.
1813 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
1814 -- Check the specified argument Arg to make sure that it is an integer
1815 -- literal. If not give error and raise Pragma_Exit.
1817 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
1818 -- Check the specified argument Arg to make sure that it has the proper
1819 -- syntactic form for a local name and meets the semantic requirements
1820 -- for a local name. The local name is analyzed as part of the
1821 -- processing for this call. In addition, the local name is required
1822 -- to represent an entity at the library level.
1824 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
1825 -- Check the specified argument Arg to make sure that it has the proper
1826 -- syntactic form for a local name and meets the semantic requirements
1827 -- for a local name. The local name is analyzed as part of the
1828 -- processing for this call.
1830 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
1831 -- Check the specified argument Arg to make sure that it is a valid
1832 -- locking policy name. If not give error and raise Pragma_Exit.
1834 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
1835 -- Check the specified argument Arg to make sure that it is a valid
1836 -- elaboration policy name. If not give error and raise Pragma_Exit.
1838 procedure Check_Arg_Is_One_Of
1841 procedure Check_Arg_Is_One_Of
1843 N1, N2, N3 : Name_Id);
1844 procedure Check_Arg_Is_One_Of
1846 N1, N2, N3, N4 : Name_Id);
1847 procedure Check_Arg_Is_One_Of
1849 N1, N2, N3, N4, N5 : Name_Id);
1850 -- Check the specified argument Arg to make sure that it is an
1851 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
1852 -- present). If not then give error and raise Pragma_Exit.
1854 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
1855 -- Check the specified argument Arg to make sure that it is a valid
1856 -- queuing policy name. If not give error and raise Pragma_Exit.
1858 procedure Check_Arg_Is_Static_Expression
1860 Typ : Entity_Id := Empty);
1861 -- Check the specified argument Arg to make sure that it is a static
1862 -- expression of the given type (i.e. it will be analyzed and resolved
1863 -- using this type, which can be any valid argument to Resolve, e.g.
1864 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
1865 -- Typ is left Empty, then any static expression is allowed.
1867 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
1868 -- Check the specified argument Arg to make sure that it is a valid task
1869 -- dispatching policy name. If not give error and raise Pragma_Exit.
1871 procedure Check_Arg_Order (Names : Name_List);
1872 -- Checks for an instance of two arguments with identifiers for the
1873 -- current pragma which are not in the sequence indicated by Names,
1874 -- and if so, generates a fatal message about bad order of arguments.
1876 procedure Check_At_Least_N_Arguments (N : Nat);
1877 -- Check there are at least N arguments present
1879 procedure Check_At_Most_N_Arguments (N : Nat);
1880 -- Check there are no more than N arguments present
1882 procedure Check_Component
1885 In_Variant_Part : Boolean := False);
1886 -- Examine an Unchecked_Union component for correct use of per-object
1887 -- constrained subtypes, and for restrictions on finalizable components.
1888 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
1889 -- should be set when Comp comes from a record variant.
1891 procedure Check_Test_Case;
1892 -- Called to process a test-case pragma. It starts with checking pragma
1893 -- arguments, and the rest of the treatment is similar to the one for
1894 -- pre- and postcondition in Check_Precondition_Postcondition, except
1895 -- the placement rules for the test-case pragma are stricter. These
1896 -- pragmas may only occur after a subprogram spec declared directly
1897 -- in a package spec unit. In this case, the pragma is chained to the
1898 -- subprogram in question (using Contract_Test_Cases and Next_Pragma)
1899 -- and analysis of the pragma is delayed till the end of the spec. In
1900 -- all other cases, an error message for bad placement is given.
1902 procedure Check_Duplicate_Pragma (E : Entity_Id);
1903 -- Check if a rep item of the same name as the current pragma is already
1904 -- chained as a rep pragma to the given entity. If so give a message
1905 -- about the duplicate, and then raise Pragma_Exit so does not return.
1907 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
1908 -- Nam is an N_String_Literal node containing the external name set by
1909 -- an Import or Export pragma (or extended Import or Export pragma).
1910 -- This procedure checks for possible duplications if this is the export
1911 -- case, and if found, issues an appropriate error message.
1913 procedure Check_Expr_Is_Static_Expression
1915 Typ : Entity_Id := Empty);
1916 -- Check the specified expression Expr to make sure that it is a static
1917 -- expression of the given type (i.e. it will be analyzed and resolved
1918 -- using this type, which can be any valid argument to Resolve, e.g.
1919 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
1920 -- Typ is left Empty, then any static expression is allowed.
1922 procedure Check_First_Subtype (Arg : Node_Id);
1923 -- Checks that Arg, whose expression is an entity name, references a
1926 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
1927 -- Checks that the given argument has an identifier, and if so, requires
1928 -- it to match the given identifier name. If there is no identifier, or
1929 -- a non-matching identifier, then an error message is given and
1930 -- Pragma_Exit is raised.
1932 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
1933 -- Checks that the given argument has an identifier, and if so, requires
1934 -- it to match one of the given identifier names. If there is no
1935 -- identifier, or a non-matching identifier, then an error message is
1936 -- given and Pragma_Exit is raised.
1938 procedure Check_In_Main_Program;
1939 -- Common checks for pragmas that appear within a main program
1940 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
1942 procedure Check_Interrupt_Or_Attach_Handler;
1943 -- Common processing for first argument of pragma Interrupt_Handler or
1944 -- pragma Attach_Handler.
1946 procedure Check_Loop_Pragma_Placement;
1947 -- Verify whether pragma Loop_Invariant or Loop_Optimize or Loop_Variant
1948 -- appear immediately within a construct restricted to loops.
1950 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
1951 -- Check that pragma appears in a declarative part, or in a package
1952 -- specification, i.e. that it does not occur in a statement sequence
1955 procedure Check_No_Identifier (Arg : Node_Id);
1956 -- Checks that the given argument does not have an identifier. If
1957 -- an identifier is present, then an error message is issued, and
1958 -- Pragma_Exit is raised.
1960 procedure Check_No_Identifiers;
1961 -- Checks that none of the arguments to the pragma has an identifier.
1962 -- If any argument has an identifier, then an error message is issued,
1963 -- and Pragma_Exit is raised.
1965 procedure Check_No_Link_Name;
1966 -- Checks that no link name is specified
1968 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
1969 -- Checks if the given argument has an identifier, and if so, requires
1970 -- it to match the given identifier name. If there is a non-matching
1971 -- identifier, then an error message is given and Pragma_Exit is raised.
1973 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
1974 -- Checks if the given argument has an identifier, and if so, requires
1975 -- it to match the given identifier name. If there is a non-matching
1976 -- identifier, then an error message is given and Pragma_Exit is raised.
1977 -- In this version of the procedure, the identifier name is given as
1978 -- a string with lower case letters.
1980 procedure Check_Precondition_Postcondition (In_Body : out Boolean);
1981 -- Called to process a precondition or postcondition pragma. There are
1984 -- The pragma appears after a subprogram spec
1986 -- If the corresponding check is not enabled, the pragma is analyzed
1987 -- but otherwise ignored and control returns with In_Body set False.
1989 -- If the check is enabled, then the first step is to analyze the
1990 -- pragma, but this is skipped if the subprogram spec appears within
1991 -- a package specification (because this is the case where we delay
1992 -- analysis till the end of the spec). Then (whether or not it was
1993 -- analyzed), the pragma is chained to the subprogram in question
1994 -- (using Pre_Post_Conditions and Next_Pragma) and control returns
1995 -- to the caller with In_Body set False.
1997 -- The pragma appears at the start of subprogram body declarations
1999 -- In this case an immediate return to the caller is made with
2000 -- In_Body set True, and the pragma is NOT analyzed.
2002 -- In all other cases, an error message for bad placement is given
2004 procedure Check_Static_Constraint (Constr : Node_Id);
2005 -- Constr is a constraint from an N_Subtype_Indication node from a
2006 -- component constraint in an Unchecked_Union type. This routine checks
2007 -- that the constraint is static as required by the restrictions for
2010 procedure Check_Valid_Configuration_Pragma;
2011 -- Legality checks for placement of a configuration pragma
2013 procedure Check_Valid_Library_Unit_Pragma;
2014 -- Legality checks for library unit pragmas. A special case arises for
2015 -- pragmas in generic instances that come from copies of the original
2016 -- library unit pragmas in the generic templates. In the case of other
2017 -- than library level instantiations these can appear in contexts which
2018 -- would normally be invalid (they only apply to the original template
2019 -- and to library level instantiations), and they are simply ignored,
2020 -- which is implemented by rewriting them as null statements.
2022 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
2023 -- Check an Unchecked_Union variant for lack of nested variants and
2024 -- presence of at least one component. UU_Typ is the related Unchecked_
2027 procedure Error_Pragma (Msg : String);
2028 pragma No_Return (Error_Pragma);
2029 -- Outputs error message for current pragma. The message contains a %
2030 -- that will be replaced with the pragma name, and the flag is placed
2031 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
2032 -- calls Fix_Error (see spec of that procedure for details).
2034 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
2035 pragma No_Return (Error_Pragma_Arg);
2036 -- Outputs error message for current pragma. The message may contain
2037 -- a % that will be replaced with the pragma name. The parameter Arg
2038 -- may either be a pragma argument association, in which case the flag
2039 -- is placed on the expression of this association, or an expression,
2040 -- in which case the flag is placed directly on the expression. The
2041 -- message is placed using Error_Msg_N, so the message may also contain
2042 -- an & insertion character which will reference the given Arg value.
2043 -- After placing the message, Pragma_Exit is raised. Note: this routine
2044 -- calls Fix_Error (see spec of that procedure for details).
2046 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
2047 pragma No_Return (Error_Pragma_Arg);
2048 -- Similar to above form of Error_Pragma_Arg except that two messages
2049 -- are provided, the second is a continuation comment starting with \.
2051 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
2052 pragma No_Return (Error_Pragma_Arg_Ident);
2053 -- Outputs error message for current pragma. The message may contain
2054 -- a % that will be replaced with the pragma name. The parameter Arg
2055 -- must be a pragma argument association with a non-empty identifier
2056 -- (i.e. its Chars field must be set), and the error message is placed
2057 -- on the identifier. The message is placed using Error_Msg_N so
2058 -- the message may also contain an & insertion character which will
2059 -- reference the identifier. After placing the message, Pragma_Exit
2060 -- is raised. Note: this routine calls Fix_Error (see spec of that
2061 -- procedure for details).
2063 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
2064 pragma No_Return (Error_Pragma_Ref);
2065 -- Outputs error message for current pragma. The message may contain
2066 -- a % that will be replaced with the pragma name. The parameter Ref
2067 -- must be an entity whose name can be referenced by & and sloc by #.
2068 -- After placing the message, Pragma_Exit is raised. Note: this routine
2069 -- calls Fix_Error (see spec of that procedure for details).
2071 function Find_Lib_Unit_Name return Entity_Id;
2072 -- Used for a library unit pragma to find the entity to which the
2073 -- library unit pragma applies, returns the entity found.
2075 procedure Find_Program_Unit_Name (Id : Node_Id);
2076 -- If the pragma is a compilation unit pragma, the id must denote the
2077 -- compilation unit in the same compilation, and the pragma must appear
2078 -- in the list of preceding or trailing pragmas. If it is a program
2079 -- unit pragma that is not a compilation unit pragma, then the
2080 -- identifier must be visible.
2082 function Find_Unique_Parameterless_Procedure
2084 Arg : Node_Id) return Entity_Id;
2085 -- Used for a procedure pragma to find the unique parameterless
2086 -- procedure identified by Name, returns it if it exists, otherwise
2087 -- errors out and uses Arg as the pragma argument for the message.
2089 procedure Fix_Error (Msg : in out String);
2090 -- This is called prior to issuing an error message. Msg is a string
2091 -- that typically contains the substring "pragma". If the pragma comes
2092 -- from an aspect, each such "pragma" substring is replaced with the
2093 -- characters "aspect", and Error_Msg_Name_1 is set to the name of the
2094 -- aspect (which may be different from the pragma name). If the current
2095 -- pragma results from rewriting another pragma, then Error_Msg_Name_1
2096 -- is set to the original pragma name.
2098 procedure Gather_Associations
2100 Args : out Args_List);
2101 -- This procedure is used to gather the arguments for a pragma that
2102 -- permits arbitrary ordering of parameters using the normal rules
2103 -- for named and positional parameters. The Names argument is a list
2104 -- of Name_Id values that corresponds to the allowed pragma argument
2105 -- association identifiers in order. The result returned in Args is
2106 -- a list of corresponding expressions that are the pragma arguments.
2107 -- Note that this is a list of expressions, not of pragma argument
2108 -- associations (Gather_Associations has completely checked all the
2109 -- optional identifiers when it returns). An entry in Args is Empty
2110 -- on return if the corresponding argument is not present.
2112 procedure GNAT_Pragma;
2113 -- Called for all GNAT defined pragmas to check the relevant restriction
2114 -- (No_Implementation_Pragmas).
2116 procedure S14_Pragma;
2117 -- Called for all pragmas defined for formal verification to check that
2118 -- the S14_Extensions flag is set.
2119 -- This name needs fixing ??? There is no such thing as an
2120 -- "S14_Extensions" flag ???
2122 function Is_Before_First_Decl
2123 (Pragma_Node : Node_Id;
2124 Decls : List_Id) return Boolean;
2125 -- Return True if Pragma_Node is before the first declarative item in
2126 -- Decls where Decls is the list of declarative items.
2128 function Is_Configuration_Pragma return Boolean;
2129 -- Determines if the placement of the current pragma is appropriate
2130 -- for a configuration pragma.
2132 function Is_In_Context_Clause return Boolean;
2133 -- Returns True if pragma appears within the context clause of a unit,
2134 -- and False for any other placement (does not generate any messages).
2136 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
2137 -- Analyzes the argument, and determines if it is a static string
2138 -- expression, returns True if so, False if non-static or not String.
2140 procedure Pragma_Misplaced;
2141 pragma No_Return (Pragma_Misplaced);
2142 -- Issue fatal error message for misplaced pragma
2144 procedure Process_Atomic_Shared_Volatile;
2145 -- Common processing for pragmas Atomic, Shared, Volatile. Note that
2146 -- Shared is an obsolete Ada 83 pragma, treated as being identical
2147 -- in effect to pragma Atomic.
2149 procedure Process_Compile_Time_Warning_Or_Error;
2150 -- Common processing for Compile_Time_Error and Compile_Time_Warning
2152 procedure Process_Convention
2153 (C : out Convention_Id;
2154 Ent : out Entity_Id);
2155 -- Common processing for Convention, Interface, Import and Export.
2156 -- Checks first two arguments of pragma, and sets the appropriate
2157 -- convention value in the specified entity or entities. On return
2158 -- C is the convention, Ent is the referenced entity.
2160 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
2161 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
2162 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
2164 procedure Process_Extended_Import_Export_Exception_Pragma
2165 (Arg_Internal : Node_Id;
2166 Arg_External : Node_Id;
2168 Arg_Code : Node_Id);
2169 -- Common processing for the pragmas Import/Export_Exception. The three
2170 -- arguments correspond to the three named parameters of the pragma. An
2171 -- argument is empty if the corresponding parameter is not present in
2174 procedure Process_Extended_Import_Export_Object_Pragma
2175 (Arg_Internal : Node_Id;
2176 Arg_External : Node_Id;
2177 Arg_Size : Node_Id);
2178 -- Common processing for the pragmas Import/Export_Object. The three
2179 -- arguments correspond to the three named parameters of the pragmas. An
2180 -- argument is empty if the corresponding parameter is not present in
2183 procedure Process_Extended_Import_Export_Internal_Arg
2184 (Arg_Internal : Node_Id := Empty);
2185 -- Common processing for all extended Import and Export pragmas. The
2186 -- argument is the pragma parameter for the Internal argument. If
2187 -- Arg_Internal is empty or inappropriate, an error message is posted.
2188 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
2189 -- set to identify the referenced entity.
2191 procedure Process_Extended_Import_Export_Subprogram_Pragma
2192 (Arg_Internal : Node_Id;
2193 Arg_External : Node_Id;
2194 Arg_Parameter_Types : Node_Id;
2195 Arg_Result_Type : Node_Id := Empty;
2196 Arg_Mechanism : Node_Id;
2197 Arg_Result_Mechanism : Node_Id := Empty;
2198 Arg_First_Optional_Parameter : Node_Id := Empty);
2199 -- Common processing for all extended Import and Export pragmas applying
2200 -- to subprograms. The caller omits any arguments that do not apply to
2201 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
2202 -- only in the Import_Function and Export_Function cases). The argument
2203 -- names correspond to the allowed pragma association identifiers.
2205 procedure Process_Generic_List;
2206 -- Common processing for Share_Generic and Inline_Generic
2208 procedure Process_Import_Or_Interface;
2209 -- Common processing for Import of Interface
2211 procedure Process_Import_Predefined_Type;
2212 -- Processing for completing a type with pragma Import. This is used
2213 -- to declare types that match predefined C types, especially for cases
2214 -- without corresponding Ada predefined type.
2216 type Inline_Status is (Suppressed, Disabled, Enabled);
2217 -- Inline status of a subprogram, indicated as follows:
2218 -- Suppressed: inlining is suppressed for the subprogram
2219 -- Disabled: no inlining is requested for the subprogram
2220 -- Enabled: inlining is requested/required for the subprogram
2222 procedure Process_Inline (Status : Inline_Status);
2223 -- Common processing for Inline, Inline_Always and No_Inline. Parameter
2224 -- indicates the inline status specified by the pragma.
2226 procedure Process_Interface_Name
2227 (Subprogram_Def : Entity_Id;
2229 Link_Arg : Node_Id);
2230 -- Given the last two arguments of pragma Import, pragma Export, or
2231 -- pragma Interface_Name, performs validity checks and sets the
2232 -- Interface_Name field of the given subprogram entity to the
2233 -- appropriate external or link name, depending on the arguments given.
2234 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
2235 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
2236 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
2237 -- nor Link_Arg is present, the interface name is set to the default
2238 -- from the subprogram name.
2240 procedure Process_Interrupt_Or_Attach_Handler;
2241 -- Common processing for Interrupt and Attach_Handler pragmas
2243 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
2244 -- Common processing for Restrictions and Restriction_Warnings pragmas.
2245 -- Warn is True for Restriction_Warnings, or for Restrictions if the
2246 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
2247 -- is not set in the Restrictions case.
2249 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
2250 -- Common processing for Suppress and Unsuppress. The boolean parameter
2251 -- Suppress_Case is True for the Suppress case, and False for the
2254 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
2255 -- This procedure sets the Is_Exported flag for the given entity,
2256 -- checking that the entity was not previously imported. Arg is
2257 -- the argument that specified the entity. A check is also made
2258 -- for exporting inappropriate entities.
2260 procedure Set_Extended_Import_Export_External_Name
2261 (Internal_Ent : Entity_Id;
2262 Arg_External : Node_Id);
2263 -- Common processing for all extended import export pragmas. The first
2264 -- argument, Internal_Ent, is the internal entity, which has already
2265 -- been checked for validity by the caller. Arg_External is from the
2266 -- Import or Export pragma, and may be null if no External parameter
2267 -- was present. If Arg_External is present and is a non-null string
2268 -- (a null string is treated as the default), then the Interface_Name
2269 -- field of Internal_Ent is set appropriately.
2271 procedure Set_Imported (E : Entity_Id);
2272 -- This procedure sets the Is_Imported flag for the given entity,
2273 -- checking that it is not previously exported or imported.
2275 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
2276 -- Mech is a parameter passing mechanism (see Import_Function syntax
2277 -- for MECHANISM_NAME). This routine checks that the mechanism argument
2278 -- has the right form, and if not issues an error message. If the
2279 -- argument has the right form then the Mechanism field of Ent is
2280 -- set appropriately.
2282 procedure Set_Rational_Profile;
2283 -- Activate the set of configuration pragmas and permissions that make
2284 -- up the Rational profile.
2286 procedure Set_Ravenscar_Profile (N : Node_Id);
2287 -- Activate the set of configuration pragmas and restrictions that make
2288 -- up the Ravenscar Profile. N is the corresponding pragma node, which
2289 -- is used for error messages on any constructs that violate the
2292 ---------------------
2293 -- Ada_2005_Pragma --
2294 ---------------------
2296 procedure Ada_2005_Pragma is
2298 if Ada_Version <= Ada_95 then
2299 Check_Restriction (No_Implementation_Pragmas, N);
2301 end Ada_2005_Pragma;
2303 ---------------------
2304 -- Ada_2012_Pragma --
2305 ---------------------
2307 procedure Ada_2012_Pragma is
2309 if Ada_Version <= Ada_2005 then
2310 Check_Restriction (No_Implementation_Pragmas, N);
2312 end Ada_2012_Pragma;
2314 ----------------------------------------
2315 -- Analyze_Refined_Pre_Post_Condition --
2316 ----------------------------------------
2318 procedure Analyze_Refined_Pre_Post_Condition is
2319 Body_Decl : Node_Id := Parent (N);
2320 Pack_Spec : Node_Id;
2321 Spec_Decl : Node_Id;
2322 Spec_Id : Entity_Id;
2327 Check_Arg_Count (1);
2328 Check_No_Identifiers;
2330 -- Verify the placement of the pragma and check for duplicates
2333 while Present (Stmt) loop
2335 -- Skip prior pragmas, but check for duplicates
2337 if Nkind (Stmt) = N_Pragma then
2338 if Pragma_Name (Stmt) = Pname then
2339 Error_Msg_Name_1 := Pname;
2340 Error_Msg_Sloc := Sloc (Stmt);
2341 Error_Msg_N ("pragma % duplicates pragma declared #", N);
2344 -- Emit an error when the pragma applies to an expression function
2345 -- that does not act as a completion.
2347 elsif Nkind (Stmt) = N_Subprogram_Declaration
2348 and then Nkind (Original_Node (Stmt)) = N_Expression_Function
2350 Has_Completion (Defining_Unit_Name (Specification (Stmt)))
2353 ("pragma % cannot apply to a stand alone expression "
2357 -- The pragma applies to a subprogram body stub
2359 elsif Nkind (Stmt) = N_Subprogram_Body_Stub then
2363 -- Skip internally generated code
2365 elsif not Comes_From_Source (Stmt) then
2368 -- The pragma does not apply to a legal construct, issue an error
2369 -- and stop the analysis.
2376 Stmt := Prev (Stmt);
2379 -- Pragma Refined_Pre/Post must apply to a subprogram body [stub]
2381 if not Nkind_In (Body_Decl, N_Subprogram_Body,
2382 N_Subprogram_Body_Stub)
2388 -- The body [stub] must not act as a spec, in other words it has to
2389 -- be paired with a corresponding spec.
2391 if Nkind (Body_Decl) = N_Subprogram_Body then
2392 Spec_Id := Corresponding_Spec (Body_Decl);
2394 Spec_Id := Corresponding_Spec_Of_Stub (Body_Decl);
2397 if No (Spec_Id) then
2398 Error_Pragma ("pragma % cannot apply to a stand alone body");
2402 -- Refined_Pre/Post may only apply to the body [stub] of a subprogram
2403 -- declared in the visible part of a package. Retrieve the context of
2404 -- the subprogram declaration.
2406 Spec_Decl := Parent (Parent (Spec_Id));
2409 (Nkind_In (Spec_Decl, N_Abstract_Subprogram_Declaration,
2410 N_Generic_Subprogram_Declaration,
2411 N_Subprogram_Declaration));
2413 Pack_Spec := Parent (Spec_Decl);
2415 if Nkind (Pack_Spec) /= N_Package_Specification
2416 or else List_Containing (Spec_Decl) /=
2417 Visible_Declarations (Pack_Spec)
2420 ("pragma % must apply to the body of a visible subprogram");
2424 -- Analyze the boolean expression as a "spec expression"
2426 Analyze_Pre_Post_Condition_In_Decl_Part (N, Spec_Id);
2427 end Analyze_Refined_Pre_Post_Condition;
2429 --------------------------
2430 -- Check_Ada_83_Warning --
2431 --------------------------
2433 procedure Check_Ada_83_Warning is
2435 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
2436 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
2438 end Check_Ada_83_Warning;
2440 ---------------------
2441 -- Check_Arg_Count --
2442 ---------------------
2444 procedure Check_Arg_Count (Required : Nat) is
2446 if Arg_Count /= Required then
2447 Error_Pragma ("wrong number of arguments for pragma%");
2449 end Check_Arg_Count;
2451 --------------------------------
2452 -- Check_Arg_Is_External_Name --
2453 --------------------------------
2455 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
2456 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
2459 if Nkind (Argx) = N_Identifier then
2463 Analyze_And_Resolve (Argx, Standard_String);
2465 if Is_OK_Static_Expression (Argx) then
2468 elsif Etype (Argx) = Any_Type then
2471 -- An interesting special case, if we have a string literal and
2472 -- we are in Ada 83 mode, then we allow it even though it will
2473 -- not be flagged as static. This allows expected Ada 83 mode
2474 -- use of external names which are string literals, even though
2475 -- technically these are not static in Ada 83.
2477 elsif Ada_Version = Ada_83
2478 and then Nkind (Argx) = N_String_Literal
2482 -- Static expression that raises Constraint_Error. This has
2483 -- already been flagged, so just exit from pragma processing.
2485 elsif Is_Static_Expression (Argx) then
2488 -- Here we have a real error (non-static expression)
2491 Error_Msg_Name_1 := Pname;
2495 "argument for pragma% must be a identifier or "
2496 & "static string expression!";
2499 Flag_Non_Static_Expr (Msg, Argx);
2504 end Check_Arg_Is_External_Name;
2506 -----------------------------
2507 -- Check_Arg_Is_Identifier --
2508 -----------------------------
2510 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
2511 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
2513 if Nkind (Argx) /= N_Identifier then
2515 ("argument for pragma% must be identifier", Argx);
2517 end Check_Arg_Is_Identifier;
2519 ----------------------------------
2520 -- Check_Arg_Is_Integer_Literal --
2521 ----------------------------------
2523 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
2524 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
2526 if Nkind (Argx) /= N_Integer_Literal then
2528 ("argument for pragma% must be integer literal", Argx);
2530 end Check_Arg_Is_Integer_Literal;
2532 -------------------------------------------
2533 -- Check_Arg_Is_Library_Level_Local_Name --
2534 -------------------------------------------
2538 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
2539 -- | library_unit_NAME
2541 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
2543 Check_Arg_Is_Local_Name (Arg);
2545 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
2546 and then Comes_From_Source (N)
2549 ("argument for pragma% must be library level entity", Arg);
2551 end Check_Arg_Is_Library_Level_Local_Name;
2553 -----------------------------
2554 -- Check_Arg_Is_Local_Name --
2555 -----------------------------
2559 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
2560 -- | library_unit_NAME
2562 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
2563 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
2568 if Nkind (Argx) not in N_Direct_Name
2569 and then (Nkind (Argx) /= N_Attribute_Reference
2570 or else Present (Expressions (Argx))
2571 or else Nkind (Prefix (Argx)) /= N_Identifier)
2572 and then (not Is_Entity_Name (Argx)
2573 or else not Is_Compilation_Unit (Entity (Argx)))
2575 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
2578 -- No further check required if not an entity name
2580 if not Is_Entity_Name (Argx) then
2586 Ent : constant Entity_Id := Entity (Argx);
2587 Scop : constant Entity_Id := Scope (Ent);
2590 -- Case of a pragma applied to a compilation unit: pragma must
2591 -- occur immediately after the program unit in the compilation.
2593 if Is_Compilation_Unit (Ent) then
2595 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
2598 -- Case of pragma placed immediately after spec
2600 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
2603 -- Case of pragma placed immediately after body
2605 elsif Nkind (Decl) = N_Subprogram_Declaration
2606 and then Present (Corresponding_Body (Decl))
2610 (Parent (Unit_Declaration_Node
2611 (Corresponding_Body (Decl))));
2613 -- All other cases are illegal
2620 -- Special restricted placement rule from 10.2.1(11.8/2)
2622 elsif Is_Generic_Formal (Ent)
2623 and then Prag_Id = Pragma_Preelaborable_Initialization
2625 OK := List_Containing (N) =
2626 Generic_Formal_Declarations
2627 (Unit_Declaration_Node (Scop));
2629 -- Default case, just check that the pragma occurs in the scope
2630 -- of the entity denoted by the name.
2633 OK := Current_Scope = Scop;
2638 ("pragma% argument must be in same declarative part", Arg);
2642 end Check_Arg_Is_Local_Name;
2644 ---------------------------------
2645 -- Check_Arg_Is_Locking_Policy --
2646 ---------------------------------
2648 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
2649 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
2652 Check_Arg_Is_Identifier (Argx);
2654 if not Is_Locking_Policy_Name (Chars (Argx)) then
2655 Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
2657 end Check_Arg_Is_Locking_Policy;
2659 -----------------------------------------------
2660 -- Check_Arg_Is_Partition_Elaboration_Policy --
2661 -----------------------------------------------
2663 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
2664 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
2667 Check_Arg_Is_Identifier (Argx);
2669 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
2671 ("& is not a valid partition elaboration policy name", Argx);
2673 end Check_Arg_Is_Partition_Elaboration_Policy;
2675 -------------------------
2676 -- Check_Arg_Is_One_Of --
2677 -------------------------
2679 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
2680 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
2683 Check_Arg_Is_Identifier (Argx);
2685 if not Nam_In (Chars (Argx), N1, N2) then
2686 Error_Msg_Name_2 := N1;
2687 Error_Msg_Name_3 := N2;
2688 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
2690 end Check_Arg_Is_One_Of;
2692 procedure Check_Arg_Is_One_Of
2694 N1, N2, N3 : Name_Id)
2696 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
2699 Check_Arg_Is_Identifier (Argx);
2701 if not Nam_In (Chars (Argx), N1, N2, N3) then
2702 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
2704 end Check_Arg_Is_One_Of;
2706 procedure Check_Arg_Is_One_Of
2708 N1, N2, N3, N4 : Name_Id)
2710 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
2713 Check_Arg_Is_Identifier (Argx);
2715 if not Nam_In (Chars (Argx), N1, N2, N3, N4) then
2716 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
2718 end Check_Arg_Is_One_Of;
2720 procedure Check_Arg_Is_One_Of
2722 N1, N2, N3, N4, N5 : Name_Id)
2724 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
2727 Check_Arg_Is_Identifier (Argx);
2729 if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then
2730 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
2732 end Check_Arg_Is_One_Of;
2734 ---------------------------------
2735 -- Check_Arg_Is_Queuing_Policy --
2736 ---------------------------------
2738 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
2739 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
2742 Check_Arg_Is_Identifier (Argx);
2744 if not Is_Queuing_Policy_Name (Chars (Argx)) then
2745 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
2747 end Check_Arg_Is_Queuing_Policy;
2749 ------------------------------------
2750 -- Check_Arg_Is_Static_Expression --
2751 ------------------------------------
2753 procedure Check_Arg_Is_Static_Expression
2755 Typ : Entity_Id := Empty)
2758 Check_Expr_Is_Static_Expression (Get_Pragma_Arg (Arg), Typ);
2759 end Check_Arg_Is_Static_Expression;
2761 ------------------------------------------
2762 -- Check_Arg_Is_Task_Dispatching_Policy --
2763 ------------------------------------------
2765 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
2766 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
2769 Check_Arg_Is_Identifier (Argx);
2771 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
2773 ("& is not a valid task dispatching policy name", Argx);
2775 end Check_Arg_Is_Task_Dispatching_Policy;
2777 ---------------------
2778 -- Check_Arg_Order --
2779 ---------------------
2781 procedure Check_Arg_Order (Names : Name_List) is
2784 Highest_So_Far : Natural := 0;
2785 -- Highest index in Names seen do far
2789 for J in 1 .. Arg_Count loop
2790 if Chars (Arg) /= No_Name then
2791 for K in Names'Range loop
2792 if Chars (Arg) = Names (K) then
2793 if K < Highest_So_Far then
2794 Error_Msg_Name_1 := Pname;
2796 ("parameters out of order for pragma%", Arg);
2797 Error_Msg_Name_1 := Names (K);
2798 Error_Msg_Name_2 := Names (Highest_So_Far);
2799 Error_Msg_N ("\% must appear before %", Arg);
2803 Highest_So_Far := K;
2811 end Check_Arg_Order;
2813 --------------------------------
2814 -- Check_At_Least_N_Arguments --
2815 --------------------------------
2817 procedure Check_At_Least_N_Arguments (N : Nat) is
2819 if Arg_Count < N then
2820 Error_Pragma ("too few arguments for pragma%");
2822 end Check_At_Least_N_Arguments;
2824 -------------------------------
2825 -- Check_At_Most_N_Arguments --
2826 -------------------------------
2828 procedure Check_At_Most_N_Arguments (N : Nat) is
2831 if Arg_Count > N then
2833 for J in 1 .. N loop
2835 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
2838 end Check_At_Most_N_Arguments;
2840 ---------------------
2841 -- Check_Component --
2842 ---------------------
2844 procedure Check_Component
2847 In_Variant_Part : Boolean := False)
2849 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
2850 Sindic : constant Node_Id :=
2851 Subtype_Indication (Component_Definition (Comp));
2852 Typ : constant Entity_Id := Etype (Comp_Id);
2855 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
2856 -- object constraint, then the component type shall be an Unchecked_
2859 if Nkind (Sindic) = N_Subtype_Indication
2860 and then Has_Per_Object_Constraint (Comp_Id)
2861 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
2864 ("component subtype subject to per-object constraint "
2865 & "must be an Unchecked_Union", Comp);
2867 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
2868 -- the body of a generic unit, or within the body of any of its
2869 -- descendant library units, no part of the type of a component
2870 -- declared in a variant_part of the unchecked union type shall be of
2871 -- a formal private type or formal private extension declared within
2872 -- the formal part of the generic unit.
2874 elsif Ada_Version >= Ada_2012
2875 and then In_Generic_Body (UU_Typ)
2876 and then In_Variant_Part
2877 and then Is_Private_Type (Typ)
2878 and then Is_Generic_Type (Typ)
2881 ("component of unchecked union cannot be of generic type", Comp);
2883 elsif Needs_Finalization (Typ) then
2885 ("component of unchecked union cannot be controlled", Comp);
2887 elsif Has_Task (Typ) then
2889 ("component of unchecked union cannot have tasks", Comp);
2891 end Check_Component;
2893 ----------------------------
2894 -- Check_Duplicate_Pragma --
2895 ----------------------------
2897 procedure Check_Duplicate_Pragma (E : Entity_Id) is
2898 Id : Entity_Id := E;
2902 -- Nothing to do if this pragma comes from an aspect specification,
2903 -- since we could not be duplicating a pragma, and we dealt with the
2904 -- case of duplicated aspects in Analyze_Aspect_Specifications.
2906 if From_Aspect_Specification (N) then
2910 -- Otherwise current pragma may duplicate previous pragma or a
2911 -- previously given aspect specification or attribute definition
2912 -- clause for the same pragma.
2914 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
2917 Error_Msg_Name_1 := Pragma_Name (N);
2918 Error_Msg_Sloc := Sloc (P);
2920 -- For a single protected or a single task object, the error is
2921 -- issued on the original entity.
2923 if Ekind_In (Id, E_Task_Type, E_Protected_Type) then
2924 Id := Defining_Identifier (Original_Node (Parent (Id)));
2927 if Nkind (P) = N_Aspect_Specification
2928 or else From_Aspect_Specification (P)
2930 Error_Msg_NE ("aspect% for & previously given#", N, Id);
2932 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
2937 end Check_Duplicate_Pragma;
2939 ----------------------------------
2940 -- Check_Duplicated_Export_Name --
2941 ----------------------------------
2943 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
2944 String_Val : constant String_Id := Strval (Nam);
2947 -- We are only interested in the export case, and in the case of
2948 -- generics, it is the instance, not the template, that is the
2949 -- problem (the template will generate a warning in any case).
2951 if not Inside_A_Generic
2952 and then (Prag_Id = Pragma_Export
2954 Prag_Id = Pragma_Export_Procedure
2956 Prag_Id = Pragma_Export_Valued_Procedure
2958 Prag_Id = Pragma_Export_Function)
2960 for J in Externals.First .. Externals.Last loop
2961 if String_Equal (String_Val, Strval (Externals.Table (J))) then
2962 Error_Msg_Sloc := Sloc (Externals.Table (J));
2963 Error_Msg_N ("external name duplicates name given#", Nam);
2968 Externals.Append (Nam);
2970 end Check_Duplicated_Export_Name;
2972 -------------------------------------
2973 -- Check_Expr_Is_Static_Expression --
2974 -------------------------------------
2976 procedure Check_Expr_Is_Static_Expression
2978 Typ : Entity_Id := Empty)
2981 if Present (Typ) then
2982 Analyze_And_Resolve (Expr, Typ);
2984 Analyze_And_Resolve (Expr);
2987 if Is_OK_Static_Expression (Expr) then
2990 elsif Etype (Expr) = Any_Type then
2993 -- An interesting special case, if we have a string literal and we
2994 -- are in Ada 83 mode, then we allow it even though it will not be
2995 -- flagged as static. This allows the use of Ada 95 pragmas like
2996 -- Import in Ada 83 mode. They will of course be flagged with
2997 -- warnings as usual, but will not cause errors.
2999 elsif Ada_Version = Ada_83
3000 and then Nkind (Expr) = N_String_Literal
3004 -- Static expression that raises Constraint_Error. This has already
3005 -- been flagged, so just exit from pragma processing.
3007 elsif Is_Static_Expression (Expr) then
3010 -- Finally, we have a real error
3013 Error_Msg_Name_1 := Pname;
3017 "argument for pragma% must be a static expression!";
3020 Flag_Non_Static_Expr (Msg, Expr);
3025 end Check_Expr_Is_Static_Expression;
3027 -------------------------
3028 -- Check_First_Subtype --
3029 -------------------------
3031 procedure Check_First_Subtype (Arg : Node_Id) is
3032 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3033 Ent : constant Entity_Id := Entity (Argx);
3036 if Is_First_Subtype (Ent) then
3039 elsif Is_Type (Ent) then
3041 ("pragma% cannot apply to subtype", Argx);
3043 elsif Is_Object (Ent) then
3045 ("pragma% cannot apply to object, requires a type", Argx);
3049 ("pragma% cannot apply to&, requires a type", Argx);
3051 end Check_First_Subtype;
3053 ----------------------
3054 -- Check_Identifier --
3055 ----------------------
3057 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
3060 and then Nkind (Arg) = N_Pragma_Argument_Association
3062 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
3063 Error_Msg_Name_1 := Pname;
3064 Error_Msg_Name_2 := Id;
3065 Error_Msg_N ("pragma% argument expects identifier%", Arg);
3069 end Check_Identifier;
3071 --------------------------------
3072 -- Check_Identifier_Is_One_Of --
3073 --------------------------------
3075 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
3078 and then Nkind (Arg) = N_Pragma_Argument_Association
3080 if Chars (Arg) = No_Name then
3081 Error_Msg_Name_1 := Pname;
3082 Error_Msg_N ("pragma% argument expects an identifier", Arg);
3085 elsif Chars (Arg) /= N1
3086 and then Chars (Arg) /= N2
3088 Error_Msg_Name_1 := Pname;
3089 Error_Msg_N ("invalid identifier for pragma% argument", Arg);
3093 end Check_Identifier_Is_One_Of;
3095 ---------------------------
3096 -- Check_In_Main_Program --
3097 ---------------------------
3099 procedure Check_In_Main_Program is
3100 P : constant Node_Id := Parent (N);
3103 -- Must be at in subprogram body
3105 if Nkind (P) /= N_Subprogram_Body then
3106 Error_Pragma ("% pragma allowed only in subprogram");
3108 -- Otherwise warn if obviously not main program
3110 elsif Present (Parameter_Specifications (Specification (P)))
3111 or else not Is_Compilation_Unit (Defining_Entity (P))
3113 Error_Msg_Name_1 := Pname;
3115 ("??pragma% is only effective in main program", N);
3117 end Check_In_Main_Program;
3119 ---------------------------------------
3120 -- Check_Interrupt_Or_Attach_Handler --
3121 ---------------------------------------
3123 procedure Check_Interrupt_Or_Attach_Handler is
3124 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
3125 Handler_Proc, Proc_Scope : Entity_Id;
3130 if Prag_Id = Pragma_Interrupt_Handler then
3131 Check_Restriction (No_Dynamic_Attachment, N);
3134 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
3135 Proc_Scope := Scope (Handler_Proc);
3137 -- On AAMP only, a pragma Interrupt_Handler is supported for
3138 -- nonprotected parameterless procedures.
3140 if not AAMP_On_Target
3141 or else Prag_Id = Pragma_Attach_Handler
3143 if Ekind (Proc_Scope) /= E_Protected_Type then
3145 ("argument of pragma% must be protected procedure", Arg1);
3148 if Parent (N) /= Protected_Definition (Parent (Proc_Scope)) then
3149 Error_Pragma ("pragma% must be in protected definition");
3153 if not Is_Library_Level_Entity (Proc_Scope)
3154 or else (AAMP_On_Target
3155 and then not Is_Library_Level_Entity (Handler_Proc))
3158 ("argument for pragma% must be library level entity", Arg1);
3161 -- AI05-0033: A pragma cannot appear within a generic body, because
3162 -- instance can be in a nested scope. The check that protected type
3163 -- is itself a library-level declaration is done elsewhere.
3165 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
3166 -- handle code prior to AI-0033. Analysis tools typically are not
3167 -- interested in this pragma in any case, so no need to worry too
3168 -- much about its placement.
3170 if Inside_A_Generic then
3171 if Ekind (Scope (Current_Scope)) = E_Generic_Package
3172 and then In_Package_Body (Scope (Current_Scope))
3173 and then not Relaxed_RM_Semantics
3175 Error_Pragma ("pragma% cannot be used inside a generic");
3178 end Check_Interrupt_Or_Attach_Handler;
3180 ---------------------------------
3181 -- Check_Loop_Pragma_Placement --
3182 ---------------------------------
3184 procedure Check_Loop_Pragma_Placement is
3185 procedure Placement_Error (Constr : Node_Id);
3186 pragma No_Return (Placement_Error);
3187 -- Node Constr denotes the last loop restricted construct before we
3188 -- encountered an illegal relation between enclosing constructs. Emit
3189 -- an error depending on what Constr was.
3191 ---------------------
3192 -- Placement_Error --
3193 ---------------------
3195 procedure Placement_Error (Constr : Node_Id) is
3197 if Nkind (Constr) = N_Pragma then
3199 ("pragma % must appear immediately within the statements "
3203 ("block containing pragma % must appear immediately within "
3204 & "the statements of a loop", Constr);
3206 end Placement_Error;
3208 -- Local declarations
3213 -- Start of processing for Check_Loop_Pragma_Placement
3218 while Present (Stmt) loop
3220 -- The pragma or previous block must appear immediately within the
3221 -- current block's declarative or statement part.
3223 if Nkind (Stmt) = N_Block_Statement then
3224 if (No (Declarations (Stmt))
3225 or else List_Containing (Prev) /= Declarations (Stmt))
3227 List_Containing (Prev) /=
3228 Statements (Handled_Statement_Sequence (Stmt))
3230 Placement_Error (Prev);
3233 -- Keep inspecting the parents because we are now within a
3234 -- chain of nested blocks.
3238 Stmt := Parent (Stmt);
3241 -- The pragma or previous block must appear immediately within the
3242 -- statements of the loop.
3244 elsif Nkind (Stmt) = N_Loop_Statement then
3245 if List_Containing (Prev) /= Statements (Stmt) then
3246 Placement_Error (Prev);
3249 -- Stop the traversal because we reached the innermost loop
3250 -- regardless of whether we encountered an error or not.
3254 -- Ignore a handled statement sequence. Note that this node may
3255 -- be related to a subprogram body in which case we will emit an
3256 -- error on the next iteration of the search.
3258 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then
3259 Stmt := Parent (Stmt);
3261 -- Any other statement breaks the chain from the pragma to the
3265 Placement_Error (Prev);
3269 end Check_Loop_Pragma_Placement;
3271 -------------------------------------------
3272 -- Check_Is_In_Decl_Part_Or_Package_Spec --
3273 -------------------------------------------
3275 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
3284 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
3287 elsif Nkind_In (P, N_Package_Specification,
3292 -- Note: the following tests seem a little peculiar, because
3293 -- they test for bodies, but if we were in the statement part
3294 -- of the body, we would already have hit the handled statement
3295 -- sequence, so the only way we get here is by being in the
3296 -- declarative part of the body.
3298 elsif Nkind_In (P, N_Subprogram_Body,
3309 Error_Pragma ("pragma% is not in declarative part or package spec");
3310 end Check_Is_In_Decl_Part_Or_Package_Spec;
3312 -------------------------
3313 -- Check_No_Identifier --
3314 -------------------------
3316 procedure Check_No_Identifier (Arg : Node_Id) is
3318 if Nkind (Arg) = N_Pragma_Argument_Association
3319 and then Chars (Arg) /= No_Name
3321 Error_Pragma_Arg_Ident
3322 ("pragma% does not permit identifier& here", Arg);
3324 end Check_No_Identifier;
3326 --------------------------
3327 -- Check_No_Identifiers --
3328 --------------------------
3330 procedure Check_No_Identifiers is
3334 for J in 1 .. Arg_Count loop
3335 Check_No_Identifier (Arg_Node);
3338 end Check_No_Identifiers;
3340 ------------------------
3341 -- Check_No_Link_Name --
3342 ------------------------
3344 procedure Check_No_Link_Name is
3346 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then
3350 if Present (Arg4) then
3352 ("Link_Name argument not allowed for Import Intrinsic", Arg4);
3354 end Check_No_Link_Name;
3356 -------------------------------
3357 -- Check_Optional_Identifier --
3358 -------------------------------
3360 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
3363 and then Nkind (Arg) = N_Pragma_Argument_Association
3364 and then Chars (Arg) /= No_Name
3366 if Chars (Arg) /= Id then
3367 Error_Msg_Name_1 := Pname;
3368 Error_Msg_Name_2 := Id;
3369 Error_Msg_N ("pragma% argument expects identifier%", Arg);
3373 end Check_Optional_Identifier;
3375 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
3377 Name_Buffer (1 .. Id'Length) := Id;
3378 Name_Len := Id'Length;
3379 Check_Optional_Identifier (Arg, Name_Find);
3380 end Check_Optional_Identifier;
3382 --------------------------------------
3383 -- Check_Precondition_Postcondition --
3384 --------------------------------------
3386 procedure Check_Precondition_Postcondition (In_Body : out Boolean) is
3390 procedure Chain_PPC (PO : Node_Id);
3391 -- If PO is an entry or a [generic] subprogram declaration node, then
3392 -- the precondition/postcondition applies to this subprogram and the
3393 -- processing for the pragma is completed. Otherwise the pragma is
3400 procedure Chain_PPC (PO : Node_Id) is
3404 if Nkind (PO) = N_Abstract_Subprogram_Declaration then
3405 if not From_Aspect_Specification (N) then
3407 ("pragma% cannot be applied to abstract subprogram");
3409 elsif Class_Present (N) then
3414 ("aspect % requires ''Class for abstract subprogram");
3417 -- AI05-0230: The same restriction applies to null procedures. For
3418 -- compatibility with earlier uses of the Ada pragma, apply this
3419 -- rule only to aspect specifications.
3421 -- The above discrpency needs documentation. Robert is dubious
3422 -- about whether it is a good idea ???
3424 elsif Nkind (PO) = N_Subprogram_Declaration
3425 and then Nkind (Specification (PO)) = N_Procedure_Specification
3426 and then Null_Present (Specification (PO))
3427 and then From_Aspect_Specification (N)
3428 and then not Class_Present (N)
3431 ("aspect % requires ''Class for null procedure");
3433 -- Pre/postconditions are legal on a subprogram body if it is not
3434 -- a completion of a declaration. They are also legal on a stub
3435 -- with no previous declarations (this is checked when processing
3436 -- the corresponding aspects).
3438 elsif Nkind (PO) = N_Subprogram_Body
3439 and then Acts_As_Spec (PO)
3443 elsif Nkind (PO) = N_Subprogram_Body_Stub then
3446 elsif not Nkind_In (PO, N_Subprogram_Declaration,
3447 N_Expression_Function,
3448 N_Generic_Subprogram_Declaration,
3449 N_Entry_Declaration)
3454 -- Here if we have [generic] subprogram or entry declaration
3456 if Nkind (PO) = N_Entry_Declaration then
3457 S := Defining_Entity (PO);
3459 S := Defining_Unit_Name (Specification (PO));
3461 if Nkind (S) = N_Defining_Program_Unit_Name then
3462 S := Defining_Identifier (S);
3466 -- Note: we do not analyze the pragma at this point. Instead we
3467 -- delay this analysis until the end of the declarative part in
3468 -- which the pragma appears. This implements the required delay
3469 -- in this analysis, allowing forward references. The analysis
3470 -- happens at the end of Analyze_Declarations.
3472 -- Chain spec PPC pragma to list for subprogram
3474 Add_Contract_Item (N, S);
3476 -- Return indicating spec case
3482 -- Start of processing for Check_Precondition_Postcondition
3485 if not Is_List_Member (N) then
3489 -- Preanalyze message argument if present. Visibility in this
3490 -- argument is established at the point of pragma occurrence.
3492 if Arg_Count = 2 then
3493 Check_Optional_Identifier (Arg2, Name_Message);
3494 Preanalyze_Spec_Expression
3495 (Get_Pragma_Arg (Arg2), Standard_String);
3498 -- For a pragma PPC in the extended main source unit, record enabled
3501 if Is_Checked (N) and then not Split_PPC (N) then
3502 Set_SCO_Pragma_Enabled (Loc);
3505 -- If we are within an inlined body, the legality of the pragma
3506 -- has been checked already.
3508 if In_Inlined_Body then
3513 -- Search prior declarations
3516 while Present (Prev (P)) loop
3519 -- If the previous node is a generic subprogram, do not go to to
3520 -- the original node, which is the unanalyzed tree: we need to
3521 -- attach the pre/postconditions to the analyzed version at this
3522 -- point. They get propagated to the original tree when analyzing
3523 -- the corresponding body.
3525 if Nkind (P) not in N_Generic_Declaration then
3526 PO := Original_Node (P);
3531 -- Skip past prior pragma
3533 if Nkind (PO) = N_Pragma then
3536 -- Skip stuff not coming from source
3538 elsif not Comes_From_Source (PO) then
3540 -- The condition may apply to a subprogram instantiation
3542 if Nkind (PO) = N_Subprogram_Declaration
3543 and then Present (Generic_Parent (Specification (PO)))
3548 elsif Nkind (PO) = N_Subprogram_Declaration
3549 and then In_Instance
3554 -- For all other cases of non source code, do nothing
3560 -- Only remaining possibility is subprogram declaration
3568 -- If we fall through loop, pragma is at start of list, so see if it
3569 -- is at the start of declarations of a subprogram body.
3573 if Nkind (PO) = N_Subprogram_Body
3574 and then List_Containing (N) = Declarations (PO)
3576 if Operating_Mode /= Generate_Code or else Inside_A_Generic then
3578 -- Analyze pragma expression for correctness and for ASIS use
3580 Preanalyze_Assert_Expression
3581 (Get_Pragma_Arg (Arg1), Standard_Boolean);
3583 -- In ASIS mode, for a pragma generated from a source aspect,
3584 -- also analyze the original aspect expression.
3586 if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
3587 Preanalyze_Assert_Expression
3588 (Expression (Corresponding_Aspect (N)), Standard_Boolean);
3592 -- Retain a copy of the pre- or postcondition pragma for formal
3593 -- verification purposes. The copy is needed because the pragma is
3594 -- expanded into other constructs which are not acceptable in the
3597 if Acts_As_Spec (PO)
3598 and then (SPARK_Mode or Formal_Extensions)
3601 Prag : constant Node_Id := New_Copy_Tree (N);
3604 -- Preanalyze the pragma
3606 Preanalyze_Assert_Expression
3608 (First (Pragma_Argument_Associations (Prag))),
3611 -- Preanalyze the corresponding aspect (if any)
3613 if Present (Corresponding_Aspect (Prag)) then
3614 Preanalyze_Assert_Expression
3615 (Expression (Corresponding_Aspect (Prag)),
3619 -- Chain the copy on the contract of the body
3622 (Prag, Defining_Unit_Name (Specification (PO)));
3629 -- See if it is in the pragmas after a library level subprogram
3631 elsif Nkind (PO) = N_Compilation_Unit_Aux then
3633 -- In formal verification mode, analyze pragma expression for
3634 -- correctness, as it is not expanded later. Ditto in ASIS_Mode
3635 -- where there is no later point at which the aspect will be
3638 if SPARK_Mode or else ASIS_Mode then
3639 Analyze_Pre_Post_Condition_In_Decl_Part
3640 (N, Defining_Entity (Unit (Parent (PO))));
3643 Chain_PPC (Unit (Parent (PO)));
3647 -- If we fall through, pragma was misplaced
3650 end Check_Precondition_Postcondition;
3652 -----------------------------
3653 -- Check_Static_Constraint --
3654 -----------------------------
3656 -- Note: for convenience in writing this procedure, in addition to
3657 -- the officially (i.e. by spec) allowed argument which is always a
3658 -- constraint, it also allows ranges and discriminant associations.
3659 -- Above is not clear ???
3661 procedure Check_Static_Constraint (Constr : Node_Id) is
3663 procedure Require_Static (E : Node_Id);
3664 -- Require given expression to be static expression
3666 --------------------
3667 -- Require_Static --
3668 --------------------
3670 procedure Require_Static (E : Node_Id) is
3672 if not Is_OK_Static_Expression (E) then
3673 Flag_Non_Static_Expr
3674 ("non-static constraint not allowed in Unchecked_Union!", E);
3679 -- Start of processing for Check_Static_Constraint
3682 case Nkind (Constr) is
3683 when N_Discriminant_Association =>
3684 Require_Static (Expression (Constr));
3687 Require_Static (Low_Bound (Constr));
3688 Require_Static (High_Bound (Constr));
3690 when N_Attribute_Reference =>
3691 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
3692 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
3694 when N_Range_Constraint =>
3695 Check_Static_Constraint (Range_Expression (Constr));
3697 when N_Index_Or_Discriminant_Constraint =>
3701 IDC := First (Constraints (Constr));
3702 while Present (IDC) loop
3703 Check_Static_Constraint (IDC);
3711 end Check_Static_Constraint;
3713 ---------------------
3714 -- Check_Test_Case --
3715 ---------------------
3717 procedure Check_Test_Case is
3721 procedure Chain_CTC (PO : Node_Id);
3722 -- If PO is a [generic] subprogram declaration node, then the
3723 -- test-case applies to this subprogram and the processing for
3724 -- the pragma is completed. Otherwise the pragma is misplaced.
3730 procedure Chain_CTC (PO : Node_Id) is
3734 if Nkind (PO) = N_Abstract_Subprogram_Declaration then
3736 ("pragma% cannot be applied to abstract subprogram");
3738 elsif Nkind (PO) = N_Entry_Declaration then
3739 Error_Pragma ("pragma% cannot be applied to entry");
3741 elsif not Nkind_In (PO, N_Subprogram_Declaration,
3742 N_Generic_Subprogram_Declaration)
3747 -- Here if we have [generic] subprogram declaration
3749 S := Defining_Unit_Name (Specification (PO));
3751 -- Note: we do not analyze the pragma at this point. Instead we
3752 -- delay this analysis until the end of the declarative part in
3753 -- which the pragma appears. This implements the required delay
3754 -- in this analysis, allowing forward references. The analysis
3755 -- happens at the end of Analyze_Declarations.
3757 -- There should not be another test-case with the same name
3758 -- associated to this subprogram.
3761 Name : constant String_Id := Get_Name_From_CTC_Pragma (N);
3765 CTC := Contract_Test_Cases (Contract (S));
3766 while Present (CTC) loop
3768 -- Omit pragma Contract_Cases because it does not introduce
3769 -- a unique case name and it does not follow the syntax of
3772 if Pragma_Name (CTC) = Name_Contract_Cases then
3776 (Name, Get_Name_From_CTC_Pragma (CTC))
3778 Error_Msg_Sloc := Sloc (CTC);
3779 Error_Pragma ("name for pragma% is already used#");
3782 CTC := Next_Pragma (CTC);
3786 -- Chain spec CTC pragma to list for subprogram
3788 Add_Contract_Item (N, S);
3791 -- Start of processing for Check_Test_Case
3794 -- First check pragma arguments
3796 Check_At_Least_N_Arguments (2);
3797 Check_At_Most_N_Arguments (4);
3799 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
3801 Check_Optional_Identifier (Arg1, Name_Name);
3802 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
3804 -- In ASIS mode, for a pragma generated from a source aspect, also
3805 -- analyze the original aspect expression.
3807 if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
3808 Check_Expr_Is_Static_Expression
3809 (Original_Node (Get_Pragma_Arg (Arg1)), Standard_String);
3812 Check_Optional_Identifier (Arg2, Name_Mode);
3813 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
3815 if Arg_Count = 4 then
3816 Check_Identifier (Arg3, Name_Requires);
3817 Check_Identifier (Arg4, Name_Ensures);
3819 elsif Arg_Count = 3 then
3820 Check_Identifier_Is_One_Of (Arg3, Name_Requires, Name_Ensures);
3823 -- Check pragma placement
3825 if not Is_List_Member (N) then
3829 -- Test-case should only appear in package spec unit
3831 if Get_Source_Unit (N) = No_Unit
3832 or else not Nkind_In (Sinfo.Unit (Cunit (Get_Source_Unit (N))),
3833 N_Package_Declaration,
3834 N_Generic_Package_Declaration)
3839 -- Search prior declarations
3842 while Present (Prev (P)) loop
3845 -- If the previous node is a generic subprogram, do not go to to
3846 -- the original node, which is the unanalyzed tree: we need to
3847 -- attach the test-case to the analyzed version at this point.
3848 -- They get propagated to the original tree when analyzing the
3849 -- corresponding body.
3851 if Nkind (P) not in N_Generic_Declaration then
3852 PO := Original_Node (P);
3857 -- Skip past prior pragma
3859 if Nkind (PO) = N_Pragma then
3862 -- Skip stuff not coming from source
3864 elsif not Comes_From_Source (PO) then
3867 -- Only remaining possibility is subprogram declaration. First
3868 -- check that it is declared directly in a package declaration.
3869 -- This may be either the package declaration for the current unit
3870 -- being defined or a local package declaration.
3872 elsif not Present (Parent (Parent (PO)))
3873 or else not Present (Parent (Parent (Parent (PO))))
3874 or else not Nkind_In (Parent (Parent (PO)),
3875 N_Package_Declaration,
3876 N_Generic_Package_Declaration)
3886 -- If we fall through, pragma was misplaced
3889 end Check_Test_Case;
3891 --------------------------------------
3892 -- Check_Valid_Configuration_Pragma --
3893 --------------------------------------
3895 -- A configuration pragma must appear in the context clause of a
3896 -- compilation unit, and only other pragmas may precede it. Note that
3897 -- the test also allows use in a configuration pragma file.
3899 procedure Check_Valid_Configuration_Pragma is
3901 if not Is_Configuration_Pragma then
3902 Error_Pragma ("incorrect placement for configuration pragma%");
3904 end Check_Valid_Configuration_Pragma;
3906 -------------------------------------
3907 -- Check_Valid_Library_Unit_Pragma --
3908 -------------------------------------
3910 procedure Check_Valid_Library_Unit_Pragma is
3912 Parent_Node : Node_Id;
3913 Unit_Name : Entity_Id;
3914 Unit_Kind : Node_Kind;
3915 Unit_Node : Node_Id;
3916 Sindex : Source_File_Index;
3919 if not Is_List_Member (N) then
3923 Plist := List_Containing (N);
3924 Parent_Node := Parent (Plist);
3926 if Parent_Node = Empty then
3929 -- Case of pragma appearing after a compilation unit. In this case
3930 -- it must have an argument with the corresponding name and must
3931 -- be part of the following pragmas of its parent.
3933 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
3934 if Plist /= Pragmas_After (Parent_Node) then
3937 elsif Arg_Count = 0 then
3939 ("argument required if outside compilation unit");
3942 Check_No_Identifiers;
3943 Check_Arg_Count (1);
3944 Unit_Node := Unit (Parent (Parent_Node));
3945 Unit_Kind := Nkind (Unit_Node);
3947 Analyze (Get_Pragma_Arg (Arg1));
3949 if Unit_Kind = N_Generic_Subprogram_Declaration
3950 or else Unit_Kind = N_Subprogram_Declaration
3952 Unit_Name := Defining_Entity (Unit_Node);
3954 elsif Unit_Kind in N_Generic_Instantiation then
3955 Unit_Name := Defining_Entity (Unit_Node);
3958 Unit_Name := Cunit_Entity (Current_Sem_Unit);
3961 if Chars (Unit_Name) /=
3962 Chars (Entity (Get_Pragma_Arg (Arg1)))
3965 ("pragma% argument is not current unit name", Arg1);
3968 if Ekind (Unit_Name) = E_Package
3969 and then Present (Renamed_Entity (Unit_Name))
3971 Error_Pragma ("pragma% not allowed for renamed package");
3975 -- Pragma appears other than after a compilation unit
3978 -- Here we check for the generic instantiation case and also
3979 -- for the case of processing a generic formal package. We
3980 -- detect these cases by noting that the Sloc on the node
3981 -- does not belong to the current compilation unit.
3983 Sindex := Source_Index (Current_Sem_Unit);
3985 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
3986 Rewrite (N, Make_Null_Statement (Loc));
3989 -- If before first declaration, the pragma applies to the
3990 -- enclosing unit, and the name if present must be this name.
3992 elsif Is_Before_First_Decl (N, Plist) then
3993 Unit_Node := Unit_Declaration_Node (Current_Scope);
3994 Unit_Kind := Nkind (Unit_Node);
3996 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
3999 elsif Unit_Kind = N_Subprogram_Body
4000 and then not Acts_As_Spec (Unit_Node)
4004 elsif Nkind (Parent_Node) = N_Package_Body then
4007 elsif Nkind (Parent_Node) = N_Package_Specification
4008 and then Plist = Private_Declarations (Parent_Node)
4012 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
4013 or else Nkind (Parent_Node) =
4014 N_Generic_Subprogram_Declaration)
4015 and then Plist = Generic_Formal_Declarations (Parent_Node)
4019 elsif Arg_Count > 0 then
4020 Analyze (Get_Pragma_Arg (Arg1));
4022 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
4024 ("name in pragma% must be enclosing unit", Arg1);
4027 -- It is legal to have no argument in this context
4033 -- Error if not before first declaration. This is because a
4034 -- library unit pragma argument must be the name of a library
4035 -- unit (RM 10.1.5(7)), but the only names permitted in this
4036 -- context are (RM 10.1.5(6)) names of subprogram declarations,
4037 -- generic subprogram declarations or generic instantiations.
4041 ("pragma% misplaced, must be before first declaration");
4045 end Check_Valid_Library_Unit_Pragma;
4051 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
4052 Clist : constant Node_Id := Component_List (Variant);
4056 Comp := First (Component_Items (Clist));
4057 while Present (Comp) loop
4058 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
4067 procedure Error_Pragma (Msg : String) is
4068 MsgF : String := Msg;
4070 Error_Msg_Name_1 := Pname;
4072 Error_Msg_N (MsgF, N);
4076 ----------------------
4077 -- Error_Pragma_Arg --
4078 ----------------------
4080 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
4081 MsgF : String := Msg;
4083 Error_Msg_Name_1 := Pname;
4085 Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
4087 end Error_Pragma_Arg;
4089 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
4090 MsgF : String := Msg1;
4092 Error_Msg_Name_1 := Pname;
4094 Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
4095 Error_Pragma_Arg (Msg2, Arg);
4096 end Error_Pragma_Arg;
4098 ----------------------------
4099 -- Error_Pragma_Arg_Ident --
4100 ----------------------------
4102 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
4103 MsgF : String := Msg;
4105 Error_Msg_Name_1 := Pname;
4107 Error_Msg_N (MsgF, Arg);
4109 end Error_Pragma_Arg_Ident;
4111 ----------------------
4112 -- Error_Pragma_Ref --
4113 ----------------------
4115 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
4116 MsgF : String := Msg;
4118 Error_Msg_Name_1 := Pname;
4120 Error_Msg_Sloc := Sloc (Ref);
4121 Error_Msg_NE (MsgF, N, Ref);
4123 end Error_Pragma_Ref;
4125 ------------------------
4126 -- Find_Lib_Unit_Name --
4127 ------------------------
4129 function Find_Lib_Unit_Name return Entity_Id is
4131 -- Return inner compilation unit entity, for case of nested
4132 -- categorization pragmas. This happens in generic unit.
4134 if Nkind (Parent (N)) = N_Package_Specification
4135 and then Defining_Entity (Parent (N)) /= Current_Scope
4137 return Defining_Entity (Parent (N));
4139 return Current_Scope;
4141 end Find_Lib_Unit_Name;
4143 ----------------------------
4144 -- Find_Program_Unit_Name --
4145 ----------------------------
4147 procedure Find_Program_Unit_Name (Id : Node_Id) is
4148 Unit_Name : Entity_Id;
4149 Unit_Kind : Node_Kind;
4150 P : constant Node_Id := Parent (N);
4153 if Nkind (P) = N_Compilation_Unit then
4154 Unit_Kind := Nkind (Unit (P));
4156 if Unit_Kind = N_Subprogram_Declaration
4157 or else Unit_Kind = N_Package_Declaration
4158 or else Unit_Kind in N_Generic_Declaration
4160 Unit_Name := Defining_Entity (Unit (P));
4162 if Chars (Id) = Chars (Unit_Name) then
4163 Set_Entity (Id, Unit_Name);
4164 Set_Etype (Id, Etype (Unit_Name));
4166 Set_Etype (Id, Any_Type);
4168 ("cannot find program unit referenced by pragma%");
4172 Set_Etype (Id, Any_Type);
4173 Error_Pragma ("pragma% inapplicable to this unit");
4179 end Find_Program_Unit_Name;
4181 -----------------------------------------
4182 -- Find_Unique_Parameterless_Procedure --
4183 -----------------------------------------
4185 function Find_Unique_Parameterless_Procedure
4187 Arg : Node_Id) return Entity_Id
4189 Proc : Entity_Id := Empty;
4192 -- The body of this procedure needs some comments ???
4194 if not Is_Entity_Name (Name) then
4196 ("argument of pragma% must be entity name", Arg);
4198 elsif not Is_Overloaded (Name) then
4199 Proc := Entity (Name);
4201 if Ekind (Proc) /= E_Procedure
4202 or else Present (First_Formal (Proc))
4205 ("argument of pragma% must be parameterless procedure", Arg);
4210 Found : Boolean := False;
4212 Index : Interp_Index;
4215 Get_First_Interp (Name, Index, It);
4216 while Present (It.Nam) loop
4219 if Ekind (Proc) = E_Procedure
4220 and then No (First_Formal (Proc))
4224 Set_Entity (Name, Proc);
4225 Set_Is_Overloaded (Name, False);
4228 ("ambiguous handler name for pragma% ", Arg);
4232 Get_Next_Interp (Index, It);
4237 ("argument of pragma% must be parameterless procedure",
4240 Proc := Entity (Name);
4246 end Find_Unique_Parameterless_Procedure;
4252 procedure Fix_Error (Msg : in out String) is
4254 -- If we have a rewriting of another pragma, go to that pragma
4256 if Is_Rewrite_Substitution (N)
4257 and then Nkind (Original_Node (N)) = N_Pragma
4259 Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
4262 -- Case where pragma comes from an aspect specification
4264 if From_Aspect_Specification (N) then
4266 -- Change appearence of "pragma" in message to "aspect"
4268 for J in Msg'First .. Msg'Last - 5 loop
4269 if Msg (J .. J + 5) = "pragma" then
4270 Msg (J .. J + 5) := "aspect";
4274 -- Get name from corresponding aspect
4276 Error_Msg_Name_1 := Original_Name (N);
4280 -------------------------
4281 -- Gather_Associations --
4282 -------------------------
4284 procedure Gather_Associations
4286 Args : out Args_List)
4291 -- Initialize all parameters to Empty
4293 for J in Args'Range loop
4297 -- That's all we have to do if there are no argument associations
4299 if No (Pragma_Argument_Associations (N)) then
4303 -- Otherwise first deal with any positional parameters present
4305 Arg := First (Pragma_Argument_Associations (N));
4306 for Index in Args'Range loop
4307 exit when No (Arg) or else Chars (Arg) /= No_Name;
4308 Args (Index) := Get_Pragma_Arg (Arg);
4312 -- Positional parameters all processed, if any left, then we
4313 -- have too many positional parameters.
4315 if Present (Arg) and then Chars (Arg) = No_Name then
4317 ("too many positional associations for pragma%", Arg);
4320 -- Process named parameters if any are present
4322 while Present (Arg) loop
4323 if Chars (Arg) = No_Name then
4325 ("positional association cannot follow named association",
4329 for Index in Names'Range loop
4330 if Names (Index) = Chars (Arg) then
4331 if Present (Args (Index)) then
4333 ("duplicate argument association for pragma%", Arg);
4335 Args (Index) := Get_Pragma_Arg (Arg);
4340 if Index = Names'Last then
4341 Error_Msg_Name_1 := Pname;
4342 Error_Msg_N ("pragma% does not allow & argument", Arg);
4344 -- Check for possible misspelling
4346 for Index1 in Names'Range loop
4347 if Is_Bad_Spelling_Of
4348 (Chars (Arg), Names (Index1))
4350 Error_Msg_Name_1 := Names (Index1);
4351 Error_Msg_N -- CODEFIX
4352 ("\possible misspelling of%", Arg);
4364 end Gather_Associations;
4370 procedure GNAT_Pragma is
4372 -- We need to check the No_Implementation_Pragmas restriction for
4373 -- the case of a pragma from source. Note that the case of aspects
4374 -- generating corresponding pragmas marks these pragmas as not being
4375 -- from source, so this test also catches that case.
4377 if Comes_From_Source (N) then
4378 Check_Restriction (No_Implementation_Pragmas, N);
4382 --------------------------
4383 -- Is_Before_First_Decl --
4384 --------------------------
4386 function Is_Before_First_Decl
4387 (Pragma_Node : Node_Id;
4388 Decls : List_Id) return Boolean
4390 Item : Node_Id := First (Decls);
4393 -- Only other pragmas can come before this pragma
4396 if No (Item) or else Nkind (Item) /= N_Pragma then
4399 elsif Item = Pragma_Node then
4405 end Is_Before_First_Decl;
4407 -----------------------------
4408 -- Is_Configuration_Pragma --
4409 -----------------------------
4411 -- A configuration pragma must appear in the context clause of a
4412 -- compilation unit, and only other pragmas may precede it. Note that
4413 -- the test below also permits use in a configuration pragma file.
4415 function Is_Configuration_Pragma return Boolean is
4416 Lis : constant List_Id := List_Containing (N);
4417 Par : constant Node_Id := Parent (N);
4421 -- If no parent, then we are in the configuration pragma file,
4422 -- so the placement is definitely appropriate.
4427 -- Otherwise we must be in the context clause of a compilation unit
4428 -- and the only thing allowed before us in the context list is more
4429 -- configuration pragmas.
4431 elsif Nkind (Par) = N_Compilation_Unit
4432 and then Context_Items (Par) = Lis
4439 elsif Nkind (Prg) /= N_Pragma then
4449 end Is_Configuration_Pragma;
4451 --------------------------
4452 -- Is_In_Context_Clause --
4453 --------------------------
4455 function Is_In_Context_Clause return Boolean is
4457 Parent_Node : Node_Id;
4460 if not Is_List_Member (N) then
4464 Plist := List_Containing (N);
4465 Parent_Node := Parent (Plist);
4467 if Parent_Node = Empty
4468 or else Nkind (Parent_Node) /= N_Compilation_Unit
4469 or else Context_Items (Parent_Node) /= Plist
4476 end Is_In_Context_Clause;
4478 ---------------------------------
4479 -- Is_Static_String_Expression --
4480 ---------------------------------
4482 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
4483 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4486 Analyze_And_Resolve (Argx);
4487 return Is_OK_Static_Expression (Argx)
4488 and then Nkind (Argx) = N_String_Literal;
4489 end Is_Static_String_Expression;
4491 ----------------------
4492 -- Pragma_Misplaced --
4493 ----------------------
4495 procedure Pragma_Misplaced is
4497 Error_Pragma ("incorrect placement of pragma%");
4498 end Pragma_Misplaced;
4500 ------------------------------------
4501 -- Process_Atomic_Shared_Volatile --
4502 ------------------------------------
4504 procedure Process_Atomic_Shared_Volatile is
4511 procedure Set_Atomic (E : Entity_Id);
4512 -- Set given type as atomic, and if no explicit alignment was given,
4513 -- set alignment to unknown, since back end knows what the alignment
4514 -- requirements are for atomic arrays. Note: this step is necessary
4515 -- for derived types.
4521 procedure Set_Atomic (E : Entity_Id) is
4525 if not Has_Alignment_Clause (E) then
4526 Set_Alignment (E, Uint_0);
4530 -- Start of processing for Process_Atomic_Shared_Volatile
4533 Check_Ada_83_Warning;
4534 Check_No_Identifiers;
4535 Check_Arg_Count (1);
4536 Check_Arg_Is_Local_Name (Arg1);
4537 E_Id := Get_Pragma_Arg (Arg1);
4539 if Etype (E_Id) = Any_Type then
4544 D := Declaration_Node (E);
4547 -- Check duplicate before we chain ourselves!
4549 Check_Duplicate_Pragma (E);
4551 -- Now check appropriateness of the entity
4554 if Rep_Item_Too_Early (E, N)
4556 Rep_Item_Too_Late (E, N)
4560 Check_First_Subtype (Arg1);
4563 if Prag_Id /= Pragma_Volatile then
4565 Set_Atomic (Underlying_Type (E));
4566 Set_Atomic (Base_Type (E));
4569 -- Attribute belongs on the base type. If the view of the type is
4570 -- currently private, it also belongs on the underlying type.
4572 Set_Is_Volatile (Base_Type (E));
4573 Set_Is_Volatile (Underlying_Type (E));
4575 Set_Treat_As_Volatile (E);
4576 Set_Treat_As_Volatile (Underlying_Type (E));
4578 elsif K = N_Object_Declaration
4579 or else (K = N_Component_Declaration
4580 and then Original_Record_Component (E) = E)
4582 if Rep_Item_Too_Late (E, N) then
4586 if Prag_Id /= Pragma_Volatile then
4589 -- If the object declaration has an explicit initialization, a
4590 -- temporary may have to be created to hold the expression, to
4591 -- ensure that access to the object remain atomic.
4593 if Nkind (Parent (E)) = N_Object_Declaration
4594 and then Present (Expression (Parent (E)))
4596 Set_Has_Delayed_Freeze (E);
4599 -- An interesting improvement here. If an object of composite
4600 -- type X is declared atomic, and the type X isn't, that's a
4601 -- pity, since it may not have appropriate alignment etc. We
4602 -- can rescue this in the special case where the object and
4603 -- type are in the same unit by just setting the type as
4604 -- atomic, so that the back end will process it as atomic.
4606 -- Note: we used to do this for elementary types as well,
4607 -- but that turns out to be a bad idea and can have unwanted
4608 -- effects, most notably if the type is elementary, the object
4609 -- a simple component within a record, and both are in a spec:
4610 -- every object of this type in the entire program will be
4611 -- treated as atomic, thus incurring a potentially costly
4612 -- synchronization operation for every access.
4614 -- Of course it would be best if the back end could just adjust
4615 -- the alignment etc for the specific object, but that's not
4616 -- something we are capable of doing at this point.
4618 Utyp := Underlying_Type (Etype (E));
4621 and then Is_Composite_Type (Utyp)
4622 and then Sloc (E) > No_Location
4623 and then Sloc (Utyp) > No_Location
4625 Get_Source_File_Index (Sloc (E)) =
4626 Get_Source_File_Index (Sloc (Underlying_Type (Etype (E))))
4628 Set_Is_Atomic (Underlying_Type (Etype (E)));
4632 Set_Is_Volatile (E);
4633 Set_Treat_As_Volatile (E);
4637 ("inappropriate entity for pragma%", Arg1);
4639 end Process_Atomic_Shared_Volatile;
4641 -------------------------------------------
4642 -- Process_Compile_Time_Warning_Or_Error --
4643 -------------------------------------------
4645 procedure Process_Compile_Time_Warning_Or_Error is
4646 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
4649 Check_Arg_Count (2);
4650 Check_No_Identifiers;
4651 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
4652 Analyze_And_Resolve (Arg1x, Standard_Boolean);
4654 if Compile_Time_Known_Value (Arg1x) then
4655 if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
4657 Str : constant String_Id :=
4658 Strval (Get_Pragma_Arg (Arg2));
4659 Len : constant Int := String_Length (Str);
4664 Cent : constant Entity_Id :=
4665 Cunit_Entity (Current_Sem_Unit);
4667 Force : constant Boolean :=
4668 Prag_Id = Pragma_Compile_Time_Warning
4670 Is_Spec_Name (Unit_Name (Current_Sem_Unit))
4671 and then (Ekind (Cent) /= E_Package
4672 or else not In_Private_Part (Cent));
4673 -- Set True if this is the warning case, and we are in the
4674 -- visible part of a package spec, or in a subprogram spec,
4675 -- in which case we want to force the client to see the
4676 -- warning, even though it is not in the main unit.
4679 -- Loop through segments of message separated by line feeds.
4680 -- We output these segments as separate messages with
4681 -- continuation marks for all but the first.
4686 Error_Msg_Strlen := 0;
4688 -- Loop to copy characters from argument to error message
4692 exit when Ptr > Len;
4693 CC := Get_String_Char (Str, Ptr);
4696 -- Ignore wide chars ??? else store character
4698 if In_Character_Range (CC) then
4699 C := Get_Character (CC);
4700 exit when C = ASCII.LF;
4701 Error_Msg_Strlen := Error_Msg_Strlen + 1;
4702 Error_Msg_String (Error_Msg_Strlen) := C;
4706 -- Here with one line ready to go
4708 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
4710 -- If this is a warning in a spec, then we want clients
4711 -- to see the warning, so mark the message with the
4712 -- special sequence !! to force the warning. In the case
4713 -- of a package spec, we do not force this if we are in
4714 -- the private part of the spec.
4717 if Cont = False then
4718 Error_Msg_N ("<~!!", Arg1);
4721 Error_Msg_N ("\<~!!", Arg1);
4724 -- Error, rather than warning, or in a body, so we do not
4725 -- need to force visibility for client (error will be
4726 -- output in any case, and this is the situation in which
4727 -- we do not want a client to get a warning, since the
4728 -- warning is in the body or the spec private part).
4731 if Cont = False then
4732 Error_Msg_N ("<~", Arg1);
4735 Error_Msg_N ("\<~", Arg1);
4739 exit when Ptr > Len;
4744 end Process_Compile_Time_Warning_Or_Error;
4746 ------------------------
4747 -- Process_Convention --
4748 ------------------------
4750 procedure Process_Convention
4751 (C : out Convention_Id;
4752 Ent : out Entity_Id)
4758 Comp_Unit : Unit_Number_Type;
4760 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
4761 -- Called if we have more than one Export/Import/Convention pragma.
4762 -- This is generally illegal, but we have a special case of allowing
4763 -- Import and Interface to coexist if they specify the convention in
4764 -- a consistent manner. We are allowed to do this, since Interface is
4765 -- an implementation defined pragma, and we choose to do it since we
4766 -- know Rational allows this combination. S is the entity id of the
4767 -- subprogram in question. This procedure also sets the special flag
4768 -- Import_Interface_Present in both pragmas in the case where we do
4769 -- have matching Import and Interface pragmas.
4771 procedure Set_Convention_From_Pragma (E : Entity_Id);
4772 -- Set convention in entity E, and also flag that the entity has a
4773 -- convention pragma. If entity is for a private or incomplete type,
4774 -- also set convention and flag on underlying type. This procedure
4775 -- also deals with the special case of C_Pass_By_Copy convention.
4777 -------------------------------
4778 -- Diagnose_Multiple_Pragmas --
4779 -------------------------------
4781 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
4782 Pdec : constant Node_Id := Declaration_Node (S);
4786 function Same_Convention (Decl : Node_Id) return Boolean;
4787 -- Decl is a pragma node. This function returns True if this
4788 -- pragma has a first argument that is an identifier with a
4789 -- Chars field corresponding to the Convention_Id C.
4791 function Same_Name (Decl : Node_Id) return Boolean;
4792 -- Decl is a pragma node. This function returns True if this
4793 -- pragma has a second argument that is an identifier with a
4794 -- Chars field that matches the Chars of the current subprogram.
4796 ---------------------
4797 -- Same_Convention --
4798 ---------------------
4800 function Same_Convention (Decl : Node_Id) return Boolean is
4801 Arg1 : constant Node_Id :=
4802 First (Pragma_Argument_Associations (Decl));
4805 if Present (Arg1) then
4807 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
4809 if Nkind (Arg) = N_Identifier
4810 and then Is_Convention_Name (Chars (Arg))
4811 and then Get_Convention_Id (Chars (Arg)) = C
4819 end Same_Convention;
4825 function Same_Name (Decl : Node_Id) return Boolean is
4826 Arg1 : constant Node_Id :=
4827 First (Pragma_Argument_Associations (Decl));
4835 Arg2 := Next (Arg1);
4842 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
4844 if Nkind (Arg) = N_Identifier
4845 and then Chars (Arg) = Chars (S)
4854 -- Start of processing for Diagnose_Multiple_Pragmas
4859 -- Definitely give message if we have Convention/Export here
4861 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
4864 -- If we have an Import or Export, scan back from pragma to
4865 -- find any previous pragma applying to the same procedure.
4866 -- The scan will be terminated by the start of the list, or
4867 -- hitting the subprogram declaration. This won't allow one
4868 -- pragma to appear in the public part and one in the private
4869 -- part, but that seems very unlikely in practice.
4873 while Present (Decl) and then Decl /= Pdec loop
4875 -- Look for pragma with same name as us
4877 if Nkind (Decl) = N_Pragma
4878 and then Same_Name (Decl)
4880 -- Give error if same as our pragma or Export/Convention
4882 if Nam_In (Pragma_Name (Decl), Name_Export,
4888 -- Case of Import/Interface or the other way round
4890 elsif Nam_In (Pragma_Name (Decl), Name_Interface,
4893 -- Here we know that we have Import and Interface. It
4894 -- doesn't matter which way round they are. See if
4895 -- they specify the same convention. If so, all OK,
4896 -- and set special flags to stop other messages
4898 if Same_Convention (Decl) then
4899 Set_Import_Interface_Present (N);
4900 Set_Import_Interface_Present (Decl);
4903 -- If different conventions, special message
4906 Error_Msg_Sloc := Sloc (Decl);
4908 ("convention differs from that given#", Arg1);
4918 -- Give message if needed if we fall through those tests
4919 -- except on Relaxed_RM_Semantics where we let go: either this
4920 -- is a case accepted/ignored by other Ada compilers (e.g.
4921 -- a mix of Convention and Import), or another error will be
4922 -- generated later (e.g. using both Import and Export).
4924 if Err and not Relaxed_RM_Semantics then
4926 ("at most one Convention/Export/Import pragma is allowed",
4929 end Diagnose_Multiple_Pragmas;
4931 --------------------------------
4932 -- Set_Convention_From_Pragma --
4933 --------------------------------
4935 procedure Set_Convention_From_Pragma (E : Entity_Id) is
4937 -- Ada 2005 (AI-430): Check invalid attempt to change convention
4938 -- for an overridden dispatching operation. Technically this is
4939 -- an amendment and should only be done in Ada 2005 mode. However,
4940 -- this is clearly a mistake, since the problem that is addressed
4941 -- by this AI is that there is a clear gap in the RM!
4943 if Is_Dispatching_Operation (E)
4944 and then Present (Overridden_Operation (E))
4945 and then C /= Convention (Overridden_Operation (E))
4947 -- An attempt to override a subprogram with a ghost subprogram
4948 -- appears as a mismatch in conventions.
4950 if C = Convention_Ghost then
4951 Error_Msg_N ("ghost subprogram & cannot be overriding", E);
4954 ("cannot change convention for overridden dispatching "
4955 & "operation", Arg1);
4959 -- Special checks for Convention_Stdcall
4961 if C = Convention_Stdcall then
4963 -- A dispatching call is not allowed. A dispatching subprogram
4964 -- cannot be used to interface to the Win32 API, so in fact
4965 -- this check does not impose any effective restriction.
4967 if Is_Dispatching_Operation (E) then
4968 Error_Msg_Sloc := Sloc (E);
4970 -- Note: make this unconditional so that if there is more
4971 -- than one call to which the pragma applies, we get a
4972 -- message for each call. Also don't use Error_Pragma,
4973 -- so that we get multiple messages!
4976 ("dispatching subprogram# cannot use Stdcall convention!",
4979 -- Subprogram is allowed, but not a generic subprogram
4981 elsif not Is_Subprogram (E)
4982 and then not Is_Generic_Subprogram (E)
4986 and then Ekind (E) /= E_Variable
4988 -- An access to subprogram is also allowed
4992 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
4994 -- Allow internal call to set convention of subprogram type
4996 and then not (Ekind (E) = E_Subprogram_Type)
4999 ("second argument of pragma% must be subprogram (type)",
5004 -- Set the convention
5006 Set_Convention (E, C);
5007 Set_Has_Convention_Pragma (E);
5009 if Is_Incomplete_Or_Private_Type (E)
5010 and then Present (Underlying_Type (E))
5012 Set_Convention (Underlying_Type (E), C);
5013 Set_Has_Convention_Pragma (Underlying_Type (E), True);
5016 -- A class-wide type should inherit the convention of the specific
5017 -- root type (although this isn't specified clearly by the RM).
5019 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
5020 Set_Convention (Class_Wide_Type (E), C);
5023 -- If the entity is a record type, then check for special case of
5024 -- C_Pass_By_Copy, which is treated the same as C except that the
5025 -- special record flag is set. This convention is only permitted
5026 -- on record types (see AI95-00131).
5028 if Cname = Name_C_Pass_By_Copy then
5029 if Is_Record_Type (E) then
5030 Set_C_Pass_By_Copy (Base_Type (E));
5031 elsif Is_Incomplete_Or_Private_Type (E)
5032 and then Is_Record_Type (Underlying_Type (E))
5034 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
5037 ("C_Pass_By_Copy convention allowed only for record type",
5042 -- If the entity is a derived boolean type, check for the special
5043 -- case of convention C, C++, or Fortran, where we consider any
5044 -- nonzero value to represent true.
5046 if Is_Discrete_Type (E)
5047 and then Root_Type (Etype (E)) = Standard_Boolean
5053 C = Convention_Fortran)
5055 Set_Nonzero_Is_True (Base_Type (E));
5057 end Set_Convention_From_Pragma;
5059 -- Start of processing for Process_Convention
5062 Check_At_Least_N_Arguments (2);
5063 Check_Optional_Identifier (Arg1, Name_Convention);
5064 Check_Arg_Is_Identifier (Arg1);
5065 Cname := Chars (Get_Pragma_Arg (Arg1));
5067 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
5068 -- tested again below to set the critical flag).
5070 if Cname = Name_C_Pass_By_Copy then
5073 -- Otherwise we must have something in the standard convention list
5075 elsif Is_Convention_Name (Cname) then
5076 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
5078 -- In DEC VMS, it seems that there is an undocumented feature that
5079 -- any unrecognized convention is treated as the default, which for
5080 -- us is convention C. It does not seem so terrible to do this
5081 -- unconditionally, silently in the VMS case, and with a warning
5082 -- in the non-VMS case.
5085 if Warn_On_Export_Import and not OpenVMS_On_Target then
5087 ("??unrecognized convention name, C assumed",
5088 Get_Pragma_Arg (Arg1));
5094 Check_Optional_Identifier (Arg2, Name_Entity);
5095 Check_Arg_Is_Local_Name (Arg2);
5097 Id := Get_Pragma_Arg (Arg2);
5100 if not Is_Entity_Name (Id) then
5101 Error_Pragma_Arg ("entity name required", Arg2);
5106 -- Set entity to return
5110 -- Ada_Pass_By_Copy special checking
5112 if C = Convention_Ada_Pass_By_Copy then
5113 if not Is_First_Subtype (E) then
5115 ("convention `Ada_Pass_By_Copy` only allowed for types",
5119 if Is_By_Reference_Type (E) then
5121 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
5126 -- Ada_Pass_By_Reference special checking
5128 if C = Convention_Ada_Pass_By_Reference then
5129 if not Is_First_Subtype (E) then
5131 ("convention `Ada_Pass_By_Reference` only allowed for types",
5135 if Is_By_Copy_Type (E) then
5137 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
5142 -- Ghost special checking
5144 if Is_Ghost_Subprogram (E)
5145 and then Present (Overridden_Operation (E))
5147 Error_Msg_N ("ghost subprogram & cannot be overriding", E);
5150 -- Go to renamed subprogram if present, since convention applies to
5151 -- the actual renamed entity, not to the renaming entity. If the
5152 -- subprogram is inherited, go to parent subprogram.
5154 if Is_Subprogram (E)
5155 and then Present (Alias (E))
5157 if Nkind (Parent (Declaration_Node (E))) =
5158 N_Subprogram_Renaming_Declaration
5160 if Scope (E) /= Scope (Alias (E)) then
5162 ("cannot apply pragma% to non-local entity&#", E);
5167 elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
5168 N_Private_Extension_Declaration)
5169 and then Scope (E) = Scope (Alias (E))
5173 -- Return the parent subprogram the entity was inherited from
5179 -- Check that we are not applying this to a specless body
5180 -- Relax this check if Relaxed_RM_Semantics to accomodate other Ada
5183 if Is_Subprogram (E)
5184 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
5185 and then not Relaxed_RM_Semantics
5188 ("pragma% requires separate spec and must come before body");
5191 -- Check that we are not applying this to a named constant
5193 if Ekind_In (E, E_Named_Integer, E_Named_Real) then
5194 Error_Msg_Name_1 := Pname;
5196 ("cannot apply pragma% to named constant!",
5197 Get_Pragma_Arg (Arg2));
5199 ("\supply appropriate type for&!", Arg2);
5202 if Ekind (E) = E_Enumeration_Literal then
5203 Error_Pragma ("enumeration literal not allowed for pragma%");
5206 -- Check for rep item appearing too early or too late
5208 if Etype (E) = Any_Type
5209 or else Rep_Item_Too_Early (E, N)
5213 elsif Present (Underlying_Type (E)) then
5214 E := Underlying_Type (E);
5217 if Rep_Item_Too_Late (E, N) then
5221 if Has_Convention_Pragma (E) then
5222 Diagnose_Multiple_Pragmas (E);
5224 elsif Convention (E) = Convention_Protected
5225 or else Ekind (Scope (E)) = E_Protected_Type
5228 ("a protected operation cannot be given a different convention",
5232 -- For Intrinsic, a subprogram is required
5234 if C = Convention_Intrinsic
5235 and then not Is_Subprogram (E)
5236 and then not Is_Generic_Subprogram (E)
5239 ("second argument of pragma% must be a subprogram", Arg2);
5242 -- Deal with non-subprogram cases
5244 if not Is_Subprogram (E)
5245 and then not Is_Generic_Subprogram (E)
5247 Set_Convention_From_Pragma (E);
5250 Check_First_Subtype (Arg2);
5251 Set_Convention_From_Pragma (Base_Type (E));
5253 -- For access subprograms, we must set the convention on the
5254 -- internally generated directly designated type as well.
5256 if Ekind (E) = E_Access_Subprogram_Type then
5257 Set_Convention_From_Pragma (Directly_Designated_Type (E));
5261 -- For the subprogram case, set proper convention for all homonyms
5262 -- in same scope and the same declarative part, i.e. the same
5263 -- compilation unit.
5266 Comp_Unit := Get_Source_Unit (E);
5267 Set_Convention_From_Pragma (E);
5269 -- Treat a pragma Import as an implicit body, and pragma import
5270 -- as implicit reference (for navigation in GPS).
5272 if Prag_Id = Pragma_Import then
5273 Generate_Reference (E, Id, 'b');
5275 -- For exported entities we restrict the generation of references
5276 -- to entities exported to foreign languages since entities
5277 -- exported to Ada do not provide further information to GPS and
5278 -- add undesired references to the output of the gnatxref tool.
5280 elsif Prag_Id = Pragma_Export
5281 and then Convention (E) /= Convention_Ada
5283 Generate_Reference (E, Id, 'i');
5286 -- If the pragma comes from from an aspect, it only applies to the
5287 -- given entity, not its homonyms.
5289 if From_Aspect_Specification (N) then
5293 -- Otherwise Loop through the homonyms of the pragma argument's
5294 -- entity, an apply convention to those in the current scope.
5300 exit when No (E1) or else Scope (E1) /= Current_Scope;
5302 -- Ignore entry for which convention is already set
5304 if Has_Convention_Pragma (E1) then
5308 -- Do not set the pragma on inherited operations or on formal
5311 if Comes_From_Source (E1)
5312 and then Comp_Unit = Get_Source_Unit (E1)
5313 and then not Is_Formal_Subprogram (E1)
5314 and then Nkind (Original_Node (Parent (E1))) /=
5315 N_Full_Type_Declaration
5317 if Present (Alias (E1))
5318 and then Scope (E1) /= Scope (Alias (E1))
5321 ("cannot apply pragma% to non-local entity& declared#",
5325 Set_Convention_From_Pragma (E1);
5327 if Prag_Id = Pragma_Import then
5328 Generate_Reference (E1, Id, 'b');
5336 end Process_Convention;
5338 ----------------------------------------
5339 -- Process_Disable_Enable_Atomic_Sync --
5340 ----------------------------------------
5342 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
5344 Check_No_Identifiers;
5345 Check_At_Most_N_Arguments (1);
5347 -- Modeled internally as
5348 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
5352 Pragma_Identifier =>
5353 Make_Identifier (Loc, Nam),
5354 Pragma_Argument_Associations => New_List (
5355 Make_Pragma_Argument_Association (Loc,
5357 Make_Identifier (Loc, Name_Atomic_Synchronization)))));
5359 if Present (Arg1) then
5360 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
5364 end Process_Disable_Enable_Atomic_Sync;
5366 -----------------------------------------------------
5367 -- Process_Extended_Import_Export_Exception_Pragma --
5368 -----------------------------------------------------
5370 procedure Process_Extended_Import_Export_Exception_Pragma
5371 (Arg_Internal : Node_Id;
5372 Arg_External : Node_Id;
5380 if not OpenVMS_On_Target then
5382 ("??pragma% ignored (applies only to Open'V'M'S)");
5385 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
5386 Def_Id := Entity (Arg_Internal);
5388 if Ekind (Def_Id) /= E_Exception then
5390 ("pragma% must refer to declared exception", Arg_Internal);
5393 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
5395 if Present (Arg_Form) then
5396 Check_Arg_Is_One_Of (Arg_Form, Name_Ada, Name_VMS);
5399 if Present (Arg_Form)
5400 and then Chars (Arg_Form) = Name_Ada
5404 Set_Is_VMS_Exception (Def_Id);
5405 Set_Exception_Code (Def_Id, No_Uint);
5408 if Present (Arg_Code) then
5409 if not Is_VMS_Exception (Def_Id) then
5411 ("Code option for pragma% not allowed for Ada case",
5415 Check_Arg_Is_Static_Expression (Arg_Code, Any_Integer);
5416 Code_Val := Expr_Value (Arg_Code);
5418 if not UI_Is_In_Int_Range (Code_Val) then
5420 ("Code option for pragma% must be in 32-bit range",
5424 Set_Exception_Code (Def_Id, Code_Val);
5427 end Process_Extended_Import_Export_Exception_Pragma;
5429 -------------------------------------------------
5430 -- Process_Extended_Import_Export_Internal_Arg --
5431 -------------------------------------------------
5433 procedure Process_Extended_Import_Export_Internal_Arg
5434 (Arg_Internal : Node_Id := Empty)
5437 if No (Arg_Internal) then
5438 Error_Pragma ("Internal parameter required for pragma%");
5441 if Nkind (Arg_Internal) = N_Identifier then
5444 elsif Nkind (Arg_Internal) = N_Operator_Symbol
5445 and then (Prag_Id = Pragma_Import_Function
5447 Prag_Id = Pragma_Export_Function)
5453 ("wrong form for Internal parameter for pragma%", Arg_Internal);
5456 Check_Arg_Is_Local_Name (Arg_Internal);
5457 end Process_Extended_Import_Export_Internal_Arg;
5459 --------------------------------------------------
5460 -- Process_Extended_Import_Export_Object_Pragma --
5461 --------------------------------------------------
5463 procedure Process_Extended_Import_Export_Object_Pragma
5464 (Arg_Internal : Node_Id;
5465 Arg_External : Node_Id;
5471 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
5472 Def_Id := Entity (Arg_Internal);
5474 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
5476 ("pragma% must designate an object", Arg_Internal);
5479 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
5481 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
5484 ("previous Common/Psect_Object applies, pragma % not permitted",
5488 if Rep_Item_Too_Late (Def_Id, N) then
5492 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
5494 if Present (Arg_Size) then
5495 Check_Arg_Is_External_Name (Arg_Size);
5498 -- Export_Object case
5500 if Prag_Id = Pragma_Export_Object then
5501 if not Is_Library_Level_Entity (Def_Id) then
5503 ("argument for pragma% must be library level entity",
5507 if Ekind (Current_Scope) = E_Generic_Package then
5508 Error_Pragma ("pragma& cannot appear in a generic unit");
5511 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
5513 ("exported object must have compile time known size",
5517 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
5518 Error_Msg_N ("??duplicate Export_Object pragma", N);
5520 Set_Exported (Def_Id, Arg_Internal);
5523 -- Import_Object case
5526 if Is_Concurrent_Type (Etype (Def_Id)) then
5528 ("cannot use pragma% for task/protected object",
5532 if Ekind (Def_Id) = E_Constant then
5534 ("cannot import a constant", Arg_Internal);
5537 if Warn_On_Export_Import
5538 and then Has_Discriminants (Etype (Def_Id))
5541 ("imported value must be initialized??", Arg_Internal);
5544 if Warn_On_Export_Import
5545 and then Is_Access_Type (Etype (Def_Id))
5548 ("cannot import object of an access type??", Arg_Internal);
5551 if Warn_On_Export_Import
5552 and then Is_Imported (Def_Id)
5554 Error_Msg_N ("??duplicate Import_Object pragma", N);
5556 -- Check for explicit initialization present. Note that an
5557 -- initialization generated by the code generator, e.g. for an
5558 -- access type, does not count here.
5560 elsif Present (Expression (Parent (Def_Id)))
5563 (Original_Node (Expression (Parent (Def_Id))))
5565 Error_Msg_Sloc := Sloc (Def_Id);
5567 ("imported entities cannot be initialized (RM B.1(24))",
5568 "\no initialization allowed for & declared#", Arg1);
5570 Set_Imported (Def_Id);
5571 Note_Possible_Modification (Arg_Internal, Sure => False);
5574 end Process_Extended_Import_Export_Object_Pragma;
5576 ------------------------------------------------------
5577 -- Process_Extended_Import_Export_Subprogram_Pragma --
5578 ------------------------------------------------------
5580 procedure Process_Extended_Import_Export_Subprogram_Pragma
5581 (Arg_Internal : Node_Id;
5582 Arg_External : Node_Id;
5583 Arg_Parameter_Types : Node_Id;
5584 Arg_Result_Type : Node_Id := Empty;
5585 Arg_Mechanism : Node_Id;
5586 Arg_Result_Mechanism : Node_Id := Empty;
5587 Arg_First_Optional_Parameter : Node_Id := Empty)
5593 Ambiguous : Boolean;
5597 function Same_Base_Type
5599 Formal : Entity_Id) return Boolean;
5600 -- Determines if Ptype references the type of Formal. Note that only
5601 -- the base types need to match according to the spec. Ptype here is
5602 -- the argument from the pragma, which is either a type name, or an
5603 -- access attribute.
5605 --------------------
5606 -- Same_Base_Type --
5607 --------------------
5609 function Same_Base_Type
5611 Formal : Entity_Id) return Boolean
5613 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
5617 -- Case where pragma argument is typ'Access
5619 if Nkind (Ptype) = N_Attribute_Reference
5620 and then Attribute_Name (Ptype) = Name_Access
5622 Pref := Prefix (Ptype);
5625 if not Is_Entity_Name (Pref)
5626 or else Entity (Pref) = Any_Type
5631 -- We have a match if the corresponding argument is of an
5632 -- anonymous access type, and its designated type matches the
5633 -- type of the prefix of the access attribute
5635 return Ekind (Ftyp) = E_Anonymous_Access_Type
5636 and then Base_Type (Entity (Pref)) =
5637 Base_Type (Etype (Designated_Type (Ftyp)));
5639 -- Case where pragma argument is a type name
5644 if not Is_Entity_Name (Ptype)
5645 or else Entity (Ptype) = Any_Type
5650 -- We have a match if the corresponding argument is of the type
5651 -- given in the pragma (comparing base types)
5653 return Base_Type (Entity (Ptype)) = Ftyp;
5657 -- Start of processing for
5658 -- Process_Extended_Import_Export_Subprogram_Pragma
5661 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
5665 -- Loop through homonyms (overloadings) of the entity
5667 Hom_Id := Entity (Arg_Internal);
5668 while Present (Hom_Id) loop
5669 Def_Id := Get_Base_Subprogram (Hom_Id);
5671 -- We need a subprogram in the current scope
5673 if not Is_Subprogram (Def_Id)
5674 or else Scope (Def_Id) /= Current_Scope
5681 -- Pragma cannot apply to subprogram body
5683 if Is_Subprogram (Def_Id)
5684 and then Nkind (Parent (Declaration_Node (Def_Id))) =
5688 ("pragma% requires separate spec"
5689 & " and must come before body");
5692 -- Test result type if given, note that the result type
5693 -- parameter can only be present for the function cases.
5695 if Present (Arg_Result_Type)
5696 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
5700 elsif Etype (Def_Id) /= Standard_Void_Type
5702 Nam_In (Pname, Name_Export_Procedure, Name_Import_Procedure)
5706 -- Test parameter types if given. Note that this parameter
5707 -- has not been analyzed (and must not be, since it is
5708 -- semantic nonsense), so we get it as the parser left it.
5710 elsif Present (Arg_Parameter_Types) then
5711 Check_Matching_Types : declare
5716 Formal := First_Formal (Def_Id);
5718 if Nkind (Arg_Parameter_Types) = N_Null then
5719 if Present (Formal) then
5723 -- A list of one type, e.g. (List) is parsed as
5724 -- a parenthesized expression.
5726 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
5727 and then Paren_Count (Arg_Parameter_Types) = 1
5730 or else Present (Next_Formal (Formal))
5735 Same_Base_Type (Arg_Parameter_Types, Formal);
5738 -- A list of more than one type is parsed as a aggregate
5740 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
5741 and then Paren_Count (Arg_Parameter_Types) = 0
5743 Ptype := First (Expressions (Arg_Parameter_Types));
5744 while Present (Ptype) or else Present (Formal) loop
5747 or else not Same_Base_Type (Ptype, Formal)
5752 Next_Formal (Formal);
5757 -- Anything else is of the wrong form
5761 ("wrong form for Parameter_Types parameter",
5762 Arg_Parameter_Types);
5764 end Check_Matching_Types;
5767 -- Match is now False if the entry we found did not match
5768 -- either a supplied Parameter_Types or Result_Types argument
5774 -- Ambiguous case, the flag Ambiguous shows if we already
5775 -- detected this and output the initial messages.
5778 if not Ambiguous then
5780 Error_Msg_Name_1 := Pname;
5782 ("pragma% does not uniquely identify subprogram!",
5784 Error_Msg_Sloc := Sloc (Ent);
5785 Error_Msg_N ("matching subprogram #!", N);
5789 Error_Msg_Sloc := Sloc (Def_Id);
5790 Error_Msg_N ("matching subprogram #!", N);
5795 Hom_Id := Homonym (Hom_Id);
5798 -- See if we found an entry
5801 if not Ambiguous then
5802 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
5804 ("pragma% cannot be given for generic subprogram");
5807 ("pragma% does not identify local subprogram");
5814 -- Import pragmas must be for imported entities
5816 if Prag_Id = Pragma_Import_Function
5818 Prag_Id = Pragma_Import_Procedure
5820 Prag_Id = Pragma_Import_Valued_Procedure
5822 if not Is_Imported (Ent) then
5824 ("pragma Import or Interface must precede pragma%");
5827 -- Here we have the Export case which can set the entity as exported
5829 -- But does not do so if the specified external name is null, since
5830 -- that is taken as a signal in DEC Ada 83 (with which we want to be
5831 -- compatible) to request no external name.
5833 elsif Nkind (Arg_External) = N_String_Literal
5834 and then String_Length (Strval (Arg_External)) = 0
5838 -- In all other cases, set entity as exported
5841 Set_Exported (Ent, Arg_Internal);
5844 -- Special processing for Valued_Procedure cases
5846 if Prag_Id = Pragma_Import_Valued_Procedure
5848 Prag_Id = Pragma_Export_Valued_Procedure
5850 Formal := First_Formal (Ent);
5853 Error_Pragma ("at least one parameter required for pragma%");
5855 elsif Ekind (Formal) /= E_Out_Parameter then
5856 Error_Pragma ("first parameter must have mode out for pragma%");
5859 Set_Is_Valued_Procedure (Ent);
5863 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
5865 -- Process Result_Mechanism argument if present. We have already
5866 -- checked that this is only allowed for the function case.
5868 if Present (Arg_Result_Mechanism) then
5869 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
5872 -- Process Mechanism parameter if present. Note that this parameter
5873 -- is not analyzed, and must not be analyzed since it is semantic
5874 -- nonsense, so we get it in exactly as the parser left it.
5876 if Present (Arg_Mechanism) then
5884 -- A single mechanism association without a formal parameter
5885 -- name is parsed as a parenthesized expression. All other
5886 -- cases are parsed as aggregates, so we rewrite the single
5887 -- parameter case as an aggregate for consistency.
5889 if Nkind (Arg_Mechanism) /= N_Aggregate
5890 and then Paren_Count (Arg_Mechanism) = 1
5892 Rewrite (Arg_Mechanism,
5893 Make_Aggregate (Sloc (Arg_Mechanism),
5894 Expressions => New_List (
5895 Relocate_Node (Arg_Mechanism))));
5898 -- Case of only mechanism name given, applies to all formals
5900 if Nkind (Arg_Mechanism) /= N_Aggregate then
5901 Formal := First_Formal (Ent);
5902 while Present (Formal) loop
5903 Set_Mechanism_Value (Formal, Arg_Mechanism);
5904 Next_Formal (Formal);
5907 -- Case of list of mechanism associations given
5910 if Null_Record_Present (Arg_Mechanism) then
5912 ("inappropriate form for Mechanism parameter",
5916 -- Deal with positional ones first
5918 Formal := First_Formal (Ent);
5920 if Present (Expressions (Arg_Mechanism)) then
5921 Mname := First (Expressions (Arg_Mechanism));
5922 while Present (Mname) loop
5925 ("too many mechanism associations", Mname);
5928 Set_Mechanism_Value (Formal, Mname);
5929 Next_Formal (Formal);
5934 -- Deal with named entries
5936 if Present (Component_Associations (Arg_Mechanism)) then
5937 Massoc := First (Component_Associations (Arg_Mechanism));
5938 while Present (Massoc) loop
5939 Choice := First (Choices (Massoc));
5941 if Nkind (Choice) /= N_Identifier
5942 or else Present (Next (Choice))
5945 ("incorrect form for mechanism association",
5949 Formal := First_Formal (Ent);
5953 ("parameter name & not present", Choice);
5956 if Chars (Choice) = Chars (Formal) then
5958 (Formal, Expression (Massoc));
5960 -- Set entity on identifier (needed by ASIS)
5962 Set_Entity (Choice, Formal);
5967 Next_Formal (Formal);
5977 -- Process First_Optional_Parameter argument if present. We have
5978 -- already checked that this is only allowed for the Import case.
5980 if Present (Arg_First_Optional_Parameter) then
5981 if Nkind (Arg_First_Optional_Parameter) /= N_Identifier then
5983 ("first optional parameter must be formal parameter name",
5984 Arg_First_Optional_Parameter);
5987 Formal := First_Formal (Ent);
5991 ("specified formal parameter& not found",
5992 Arg_First_Optional_Parameter);
5995 exit when Chars (Formal) =
5996 Chars (Arg_First_Optional_Parameter);
5998 Next_Formal (Formal);
6001 Set_First_Optional_Parameter (Ent, Formal);
6003 -- Check specified and all remaining formals have right form
6005 while Present (Formal) loop
6006 if Ekind (Formal) /= E_In_Parameter then
6008 ("optional formal& is not of mode in!",
6009 Arg_First_Optional_Parameter, Formal);
6012 Dval := Default_Value (Formal);
6016 ("optional formal& does not have default value!",
6017 Arg_First_Optional_Parameter, Formal);
6019 elsif Compile_Time_Known_Value_Or_Aggr (Dval) then
6024 ("default value for optional formal& is non-static!",
6025 Arg_First_Optional_Parameter, Formal);
6029 Set_Is_Optional_Parameter (Formal);
6030 Next_Formal (Formal);
6033 end Process_Extended_Import_Export_Subprogram_Pragma;
6035 --------------------------
6036 -- Process_Generic_List --
6037 --------------------------
6039 procedure Process_Generic_List is
6044 Check_No_Identifiers;
6045 Check_At_Least_N_Arguments (1);
6047 -- Check all arguments are names of generic units or instances
6050 while Present (Arg) loop
6051 Exp := Get_Pragma_Arg (Arg);
6054 if not Is_Entity_Name (Exp)
6056 (not Is_Generic_Instance (Entity (Exp))
6058 not Is_Generic_Unit (Entity (Exp)))
6061 ("pragma% argument must be name of generic unit/instance",
6067 end Process_Generic_List;
6069 ------------------------------------
6070 -- Process_Import_Predefined_Type --
6071 ------------------------------------
6073 procedure Process_Import_Predefined_Type is
6074 Loc : constant Source_Ptr := Sloc (N);
6076 Ftyp : Node_Id := Empty;
6082 String_To_Name_Buffer (Strval (Expression (Arg3)));
6085 Elmt := First_Elmt (Predefined_Float_Types);
6086 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
6090 Ftyp := Node (Elmt);
6092 if Present (Ftyp) then
6094 -- Don't build a derived type declaration, because predefined C
6095 -- types have no declaration anywhere, so cannot really be named.
6096 -- Instead build a full type declaration, starting with an
6097 -- appropriate type definition is built
6099 if Is_Floating_Point_Type (Ftyp) then
6100 Def := Make_Floating_Point_Definition (Loc,
6101 Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
6102 Make_Real_Range_Specification (Loc,
6103 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
6104 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
6106 -- Should never have a predefined type we cannot handle
6109 raise Program_Error;
6112 -- Build and insert a Full_Type_Declaration, which will be
6113 -- analyzed as soon as this list entry has been analyzed.
6115 Decl := Make_Full_Type_Declaration (Loc,
6116 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
6117 Type_Definition => Def);
6119 Insert_After (N, Decl);
6120 Mark_Rewrite_Insertion (Decl);
6123 Error_Pragma_Arg ("no matching type found for pragma%",
6126 end Process_Import_Predefined_Type;
6128 ---------------------------------
6129 -- Process_Import_Or_Interface --
6130 ---------------------------------
6132 procedure Process_Import_Or_Interface is
6138 Process_Convention (C, Def_Id);
6139 Kill_Size_Check_Code (Def_Id);
6140 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
6142 if Ekind_In (Def_Id, E_Variable, E_Constant) then
6144 -- We do not permit Import to apply to a renaming declaration
6146 if Present (Renamed_Object (Def_Id)) then
6148 ("pragma% not allowed for object renaming", Arg2);
6150 -- User initialization is not allowed for imported object, but
6151 -- the object declaration may contain a default initialization,
6152 -- that will be discarded. Note that an explicit initialization
6153 -- only counts if it comes from source, otherwise it is simply
6154 -- the code generator making an implicit initialization explicit.
6156 elsif Present (Expression (Parent (Def_Id)))
6157 and then Comes_From_Source (Expression (Parent (Def_Id)))
6159 Error_Msg_Sloc := Sloc (Def_Id);
6161 ("no initialization allowed for declaration of& #",
6162 "\imported entities cannot be initialized (RM B.1(24))",
6166 Set_Imported (Def_Id);
6167 Process_Interface_Name (Def_Id, Arg3, Arg4);
6169 -- Note that we do not set Is_Public here. That's because we
6170 -- only want to set it if there is no address clause, and we
6171 -- don't know that yet, so we delay that processing till
6174 -- pragma Import completes deferred constants
6176 if Ekind (Def_Id) = E_Constant then
6177 Set_Has_Completion (Def_Id);
6180 -- It is not possible to import a constant of an unconstrained
6181 -- array type (e.g. string) because there is no simple way to
6182 -- write a meaningful subtype for it.
6184 if Is_Array_Type (Etype (Def_Id))
6185 and then not Is_Constrained (Etype (Def_Id))
6188 ("imported constant& must have a constrained subtype",
6193 elsif Is_Subprogram (Def_Id)
6194 or else Is_Generic_Subprogram (Def_Id)
6196 -- If the name is overloaded, pragma applies to all of the denoted
6197 -- entities in the same declarative part, unless the pragma comes
6198 -- from an aspect specification.
6201 while Present (Hom_Id) loop
6203 Def_Id := Get_Base_Subprogram (Hom_Id);
6205 -- Ignore inherited subprograms because the pragma will apply
6206 -- to the parent operation, which is the one called.
6208 if Is_Overloadable (Def_Id)
6209 and then Present (Alias (Def_Id))
6213 -- If it is not a subprogram, it must be in an outer scope and
6214 -- pragma does not apply.
6216 elsif not Is_Subprogram (Def_Id)
6217 and then not Is_Generic_Subprogram (Def_Id)
6221 -- The pragma does not apply to primitives of interfaces
6223 elsif Is_Dispatching_Operation (Def_Id)
6224 and then Present (Find_Dispatching_Type (Def_Id))
6225 and then Is_Interface (Find_Dispatching_Type (Def_Id))
6229 -- Verify that the homonym is in the same declarative part (not
6230 -- just the same scope). If the pragma comes from an aspect
6231 -- specification we know that it is part of the declaration.
6233 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
6234 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
6235 and then not From_Aspect_Specification (N)
6240 Set_Imported (Def_Id);
6242 -- Reject an Import applied to an abstract subprogram
6244 if Is_Subprogram (Def_Id)
6245 and then Is_Abstract_Subprogram (Def_Id)
6247 Error_Msg_Sloc := Sloc (Def_Id);
6249 ("cannot import abstract subprogram& declared#",
6253 -- Special processing for Convention_Intrinsic
6255 if C = Convention_Intrinsic then
6257 -- Link_Name argument not allowed for intrinsic
6261 Set_Is_Intrinsic_Subprogram (Def_Id);
6263 -- If no external name is present, then check that this
6264 -- is a valid intrinsic subprogram. If an external name
6265 -- is present, then this is handled by the back end.
6268 Check_Intrinsic_Subprogram
6269 (Def_Id, Get_Pragma_Arg (Arg2));
6273 -- All interfaced procedures need an external symbol created
6274 -- for them since they are always referenced from another
6277 Set_Is_Public (Def_Id);
6279 -- Verify that the subprogram does not have a completion
6280 -- through a renaming declaration. For other completions the
6281 -- pragma appears as a too late representation.
6284 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
6288 and then Nkind (Decl) = N_Subprogram_Declaration
6289 and then Present (Corresponding_Body (Decl))
6290 and then Nkind (Unit_Declaration_Node
6291 (Corresponding_Body (Decl))) =
6292 N_Subprogram_Renaming_Declaration
6294 Error_Msg_Sloc := Sloc (Def_Id);
6296 ("cannot import&, renaming already provided for "
6297 & "declaration #", N, Def_Id);
6301 Set_Has_Completion (Def_Id);
6302 Process_Interface_Name (Def_Id, Arg3, Arg4);
6305 if Is_Compilation_Unit (Hom_Id) then
6307 -- Its possible homonyms are not affected by the pragma.
6308 -- Such homonyms might be present in the context of other
6309 -- units being compiled.
6313 elsif From_Aspect_Specification (N) then
6317 Hom_Id := Homonym (Hom_Id);
6321 -- When the convention is Java or CIL, we also allow Import to
6322 -- be given for packages, generic packages, exceptions, record
6323 -- components, and access to subprograms.
6325 elsif (C = Convention_Java or else C = Convention_CIL)
6327 (Is_Package_Or_Generic_Package (Def_Id)
6328 or else Ekind (Def_Id) = E_Exception
6329 or else Ekind (Def_Id) = E_Access_Subprogram_Type
6330 or else Nkind (Parent (Def_Id)) = N_Component_Declaration)
6332 Set_Imported (Def_Id);
6333 Set_Is_Public (Def_Id);
6334 Process_Interface_Name (Def_Id, Arg3, Arg4);
6336 -- Import a CPP class
6338 elsif C = Convention_CPP
6339 and then (Is_Record_Type (Def_Id)
6340 or else Ekind (Def_Id) = E_Incomplete_Type)
6342 if Ekind (Def_Id) = E_Incomplete_Type then
6343 if Present (Full_View (Def_Id)) then
6344 Def_Id := Full_View (Def_Id);
6348 ("cannot import 'C'P'P type before full declaration seen",
6349 Get_Pragma_Arg (Arg2));
6351 -- Although we have reported the error we decorate it as
6352 -- CPP_Class to avoid reporting spurious errors
6354 Set_Is_CPP_Class (Def_Id);
6359 -- Types treated as CPP classes must be declared limited (note:
6360 -- this used to be a warning but there is no real benefit to it
6361 -- since we did effectively intend to treat the type as limited
6364 if not Is_Limited_Type (Def_Id) then
6366 ("imported 'C'P'P type must be limited",
6367 Get_Pragma_Arg (Arg2));
6370 if Etype (Def_Id) /= Def_Id
6371 and then not Is_CPP_Class (Root_Type (Def_Id))
6373 Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
6376 Set_Is_CPP_Class (Def_Id);
6378 -- Imported CPP types must not have discriminants (because C++
6379 -- classes do not have discriminants).
6381 if Has_Discriminants (Def_Id) then
6383 ("imported 'C'P'P type cannot have discriminants",
6384 First (Discriminant_Specifications
6385 (Declaration_Node (Def_Id))));
6388 -- Check that components of imported CPP types do not have default
6389 -- expressions. For private types this check is performed when the
6390 -- full view is analyzed (see Process_Full_View).
6392 if not Is_Private_Type (Def_Id) then
6393 Check_CPP_Type_Has_No_Defaults (Def_Id);
6396 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
6398 Check_Arg_Count (3);
6399 Check_Arg_Is_Static_Expression (Arg3, Standard_String);
6401 Process_Import_Predefined_Type;
6405 ("second argument of pragma% must be object, subprogram "
6406 & "or incomplete type",
6410 -- If this pragma applies to a compilation unit, then the unit, which
6411 -- is a subprogram, does not require (or allow) a body. We also do
6412 -- not need to elaborate imported procedures.
6414 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
6416 Cunit : constant Node_Id := Parent (Parent (N));
6418 Set_Body_Required (Cunit, False);
6421 end Process_Import_Or_Interface;
6423 --------------------
6424 -- Process_Inline --
6425 --------------------
6427 procedure Process_Inline (Status : Inline_Status) is
6434 Effective : Boolean := False;
6435 -- Set True if inline has some effect, i.e. if there is at least one
6436 -- subprogram set as inlined as a result of the use of the pragma.
6438 procedure Make_Inline (Subp : Entity_Id);
6439 -- Subp is the defining unit name of the subprogram declaration. Set
6440 -- the flag, as well as the flag in the corresponding body, if there
6443 procedure Set_Inline_Flags (Subp : Entity_Id);
6444 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
6445 -- Has_Pragma_Inline_Always for the Inline_Always case.
6447 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
6448 -- Returns True if it can be determined at this stage that inlining
6449 -- is not possible, for example if the body is available and contains
6450 -- exception handlers, we prevent inlining, since otherwise we can
6451 -- get undefined symbols at link time. This function also emits a
6452 -- warning if front-end inlining is enabled and the pragma appears
6455 -- ??? is business with link symbols still valid, or does it relate
6456 -- to front end ZCX which is being phased out ???
6458 ---------------------------
6459 -- Inlining_Not_Possible --
6460 ---------------------------
6462 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
6463 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
6467 if Nkind (Decl) = N_Subprogram_Body then
6468 Stats := Handled_Statement_Sequence (Decl);
6469 return Present (Exception_Handlers (Stats))
6470 or else Present (At_End_Proc (Stats));
6472 elsif Nkind (Decl) = N_Subprogram_Declaration
6473 and then Present (Corresponding_Body (Decl))
6475 if Front_End_Inlining
6476 and then Analyzed (Corresponding_Body (Decl))
6478 Error_Msg_N ("pragma appears too late, ignored??", N);
6481 -- If the subprogram is a renaming as body, the body is just a
6482 -- call to the renamed subprogram, and inlining is trivially
6486 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
6487 N_Subprogram_Renaming_Declaration
6493 Handled_Statement_Sequence
6494 (Unit_Declaration_Node (Corresponding_Body (Decl)));
6497 Present (Exception_Handlers (Stats))
6498 or else Present (At_End_Proc (Stats));
6502 -- If body is not available, assume the best, the check is
6503 -- performed again when compiling enclosing package bodies.
6507 end Inlining_Not_Possible;
6513 procedure Make_Inline (Subp : Entity_Id) is
6514 Kind : constant Entity_Kind := Ekind (Subp);
6515 Inner_Subp : Entity_Id := Subp;
6518 -- Ignore if bad type, avoid cascaded error
6520 if Etype (Subp) = Any_Type then
6524 -- Ignore if all inlining is suppressed
6526 elsif Suppress_All_Inlining then
6530 -- If inlining is not possible, for now do not treat as an error
6532 elsif Status /= Suppressed
6533 and then Inlining_Not_Possible (Subp)
6538 -- Here we have a candidate for inlining, but we must exclude
6539 -- derived operations. Otherwise we would end up trying to inline
6540 -- a phantom declaration, and the result would be to drag in a
6541 -- body which has no direct inlining associated with it. That
6542 -- would not only be inefficient but would also result in the
6543 -- backend doing cross-unit inlining in cases where it was
6544 -- definitely inappropriate to do so.
6546 -- However, a simple Comes_From_Source test is insufficient, since
6547 -- we do want to allow inlining of generic instances which also do
6548 -- not come from source. We also need to recognize specs generated
6549 -- by the front-end for bodies that carry the pragma. Finally,
6550 -- predefined operators do not come from source but are not
6551 -- inlineable either.
6553 elsif Is_Generic_Instance (Subp)
6554 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
6558 elsif not Comes_From_Source (Subp)
6559 and then Scope (Subp) /= Standard_Standard
6565 -- The referenced entity must either be the enclosing entity, or
6566 -- an entity declared within the current open scope.
6568 if Present (Scope (Subp))
6569 and then Scope (Subp) /= Current_Scope
6570 and then Subp /= Current_Scope
6573 ("argument of% must be entity in current scope", Assoc);
6577 -- Processing for procedure, operator or function. If subprogram
6578 -- is aliased (as for an instance) indicate that the renamed
6579 -- entity (if declared in the same unit) is inlined.
6581 if Is_Subprogram (Subp) then
6582 Inner_Subp := Ultimate_Alias (Inner_Subp);
6584 if In_Same_Source_Unit (Subp, Inner_Subp) then
6585 Set_Inline_Flags (Inner_Subp);
6587 Decl := Parent (Parent (Inner_Subp));
6589 if Nkind (Decl) = N_Subprogram_Declaration
6590 and then Present (Corresponding_Body (Decl))
6592 Set_Inline_Flags (Corresponding_Body (Decl));
6594 elsif Is_Generic_Instance (Subp) then
6596 -- Indicate that the body needs to be created for
6597 -- inlining subsequent calls. The instantiation node
6598 -- follows the declaration of the wrapper package
6601 if Scope (Subp) /= Standard_Standard
6603 Need_Subprogram_Instance_Body
6604 (Next (Unit_Declaration_Node (Scope (Alias (Subp)))),
6610 -- Inline is a program unit pragma (RM 10.1.5) and cannot
6611 -- appear in a formal part to apply to a formal subprogram.
6612 -- Do not apply check within an instance or a formal package
6613 -- the test will have been applied to the original generic.
6615 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
6616 and then List_Containing (Decl) = List_Containing (N)
6617 and then not In_Instance
6620 ("Inline cannot apply to a formal subprogram", N);
6622 -- If Subp is a renaming, it is the renamed entity that
6623 -- will appear in any call, and be inlined. However, for
6624 -- ASIS uses it is convenient to indicate that the renaming
6625 -- itself is an inlined subprogram, so that some gnatcheck
6626 -- rules can be applied in the absence of expansion.
6628 elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then
6629 Set_Inline_Flags (Subp);
6635 -- For a generic subprogram set flag as well, for use at the point
6636 -- of instantiation, to determine whether the body should be
6639 elsif Is_Generic_Subprogram (Subp) then
6640 Set_Inline_Flags (Subp);
6643 -- Literals are by definition inlined
6645 elsif Kind = E_Enumeration_Literal then
6648 -- Anything else is an error
6652 ("expect subprogram name for pragma%", Assoc);
6656 ----------------------
6657 -- Set_Inline_Flags --
6658 ----------------------
6660 procedure Set_Inline_Flags (Subp : Entity_Id) is
6662 -- First set the Has_Pragma_XXX flags and issue the appropriate
6663 -- errors and warnings for suspicious combinations.
6665 if Prag_Id = Pragma_No_Inline then
6666 if Has_Pragma_Inline_Always (Subp) then
6668 ("Inline_Always and No_Inline are mutually exclusive", N);
6669 elsif Has_Pragma_Inline (Subp) then
6671 ("Inline and No_Inline both specified for& ??",
6672 N, Entity (Subp_Id));
6675 Set_Has_Pragma_No_Inline (Subp);
6677 if Prag_Id = Pragma_Inline_Always then
6678 if Has_Pragma_No_Inline (Subp) then
6680 ("Inline_Always and No_Inline are mutually exclusive",
6684 Set_Has_Pragma_Inline_Always (Subp);
6686 if Has_Pragma_No_Inline (Subp) then
6688 ("Inline and No_Inline both specified for& ??",
6689 N, Entity (Subp_Id));
6693 if not Has_Pragma_Inline (Subp) then
6694 Set_Has_Pragma_Inline (Subp);
6699 -- Then adjust the Is_Inlined flag. It can never be set if the
6700 -- subprogram is subject to pragma No_Inline.
6704 Set_Is_Inlined (Subp, False);
6708 if not Has_Pragma_No_Inline (Subp) then
6709 Set_Is_Inlined (Subp, True);
6712 end Set_Inline_Flags;
6714 -- Start of processing for Process_Inline
6717 Check_No_Identifiers;
6718 Check_At_Least_N_Arguments (1);
6720 if Status = Enabled then
6721 Inline_Processing_Required := True;
6725 while Present (Assoc) loop
6726 Subp_Id := Get_Pragma_Arg (Assoc);
6730 if Is_Entity_Name (Subp_Id) then
6731 Subp := Entity (Subp_Id);
6733 if Subp = Any_Id then
6735 -- If previous error, avoid cascaded errors
6737 Check_Error_Detected;
6744 -- For the pragma case, climb homonym chain. This is
6745 -- what implements allowing the pragma in the renaming
6746 -- case, with the result applying to the ancestors, and
6747 -- also allows Inline to apply to all previous homonyms.
6749 if not From_Aspect_Specification (N) then
6750 while Present (Homonym (Subp))
6751 and then Scope (Homonym (Subp)) = Current_Scope
6753 Make_Inline (Homonym (Subp));
6754 Subp := Homonym (Subp);
6762 ("inappropriate argument for pragma%", Assoc);
6765 and then Warn_On_Redundant_Constructs
6766 and then not (Status = Suppressed or else Suppress_All_Inlining)
6768 if Inlining_Not_Possible (Subp) then
6770 ("pragma Inline for& is ignored?r?",
6771 N, Entity (Subp_Id));
6774 ("pragma Inline for& is redundant?r?",
6775 N, Entity (Subp_Id));
6783 ----------------------------
6784 -- Process_Interface_Name --
6785 ----------------------------
6787 procedure Process_Interface_Name
6788 (Subprogram_Def : Entity_Id;
6794 String_Val : String_Id;
6796 procedure Check_Form_Of_Interface_Name
6798 Ext_Name_Case : Boolean);
6799 -- SN is a string literal node for an interface name. This routine
6800 -- performs some minimal checks that the name is reasonable. In
6801 -- particular that no spaces or other obviously incorrect characters
6802 -- appear. This is only a warning, since any characters are allowed.
6803 -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
6805 ----------------------------------
6806 -- Check_Form_Of_Interface_Name --
6807 ----------------------------------
6809 procedure Check_Form_Of_Interface_Name
6811 Ext_Name_Case : Boolean)
6813 S : constant String_Id := Strval (Expr_Value_S (SN));
6814 SL : constant Nat := String_Length (S);
6819 Error_Msg_N ("interface name cannot be null string", SN);
6822 for J in 1 .. SL loop
6823 C := Get_String_Char (S, J);
6825 -- Look for dubious character and issue unconditional warning.
6826 -- Definitely dubious if not in character range.
6828 if not In_Character_Range (C)
6830 -- For all cases except CLI target,
6831 -- commas, spaces and slashes are dubious (in CLI, we use
6832 -- commas and backslashes in external names to specify
6833 -- assembly version and public key, while slashes and spaces
6834 -- can be used in names to mark nested classes and
6837 or else ((not Ext_Name_Case or else VM_Target /= CLI_Target)
6838 and then (Get_Character (C) = ','
6840 Get_Character (C) = '\'))
6841 or else (VM_Target /= CLI_Target
6842 and then (Get_Character (C) = ' '
6844 Get_Character (C) = '/'))
6847 ("??interface name contains illegal character",
6848 Sloc (SN) + Source_Ptr (J));
6851 end Check_Form_Of_Interface_Name;
6853 -- Start of processing for Process_Interface_Name
6856 if No (Link_Arg) then
6857 if No (Ext_Arg) then
6858 if VM_Target = CLI_Target
6859 and then Ekind (Subprogram_Def) = E_Package
6860 and then Nkind (Parent (Subprogram_Def)) =
6861 N_Package_Specification
6862 and then Present (Generic_Parent (Parent (Subprogram_Def)))
6867 (Generic_Parent (Parent (Subprogram_Def))));
6872 elsif Chars (Ext_Arg) = Name_Link_Name then
6874 Link_Nam := Expression (Ext_Arg);
6877 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
6878 Ext_Nam := Expression (Ext_Arg);
6883 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
6884 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
6885 Ext_Nam := Expression (Ext_Arg);
6886 Link_Nam := Expression (Link_Arg);
6889 -- Check expressions for external name and link name are static
6891 if Present (Ext_Nam) then
6892 Check_Arg_Is_Static_Expression (Ext_Nam, Standard_String);
6893 Check_Form_Of_Interface_Name (Ext_Nam, Ext_Name_Case => True);
6895 -- Verify that external name is not the name of a local entity,
6896 -- which would hide the imported one and could lead to run-time
6897 -- surprises. The problem can only arise for entities declared in
6898 -- a package body (otherwise the external name is fully qualified
6899 -- and will not conflict).
6907 if Prag_Id = Pragma_Import then
6908 String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam)));
6910 E := Entity_Id (Get_Name_Table_Info (Nam));
6912 if Nam /= Chars (Subprogram_Def)
6913 and then Present (E)
6914 and then not Is_Overloadable (E)
6915 and then Is_Immediately_Visible (E)
6916 and then not Is_Imported (E)
6917 and then Ekind (Scope (E)) = E_Package
6920 while Present (Par) loop
6921 if Nkind (Par) = N_Package_Body then
6922 Error_Msg_Sloc := Sloc (E);
6924 ("imported entity is hidden by & declared#",
6929 Par := Parent (Par);
6936 if Present (Link_Nam) then
6937 Check_Arg_Is_Static_Expression (Link_Nam, Standard_String);
6938 Check_Form_Of_Interface_Name (Link_Nam, Ext_Name_Case => False);
6941 -- If there is no link name, just set the external name
6943 if No (Link_Nam) then
6944 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
6946 -- For the Link_Name case, the given literal is preceded by an
6947 -- asterisk, which indicates to GCC that the given name should be
6948 -- taken literally, and in particular that no prepending of
6949 -- underlines should occur, even in systems where this is the
6955 if VM_Target = No_VM then
6956 Store_String_Char (Get_Char_Code ('*'));
6959 String_Val := Strval (Expr_Value_S (Link_Nam));
6960 Store_String_Chars (String_Val);
6962 Make_String_Literal (Sloc (Link_Nam),
6963 Strval => End_String);
6966 -- Set the interface name. If the entity is a generic instance, use
6967 -- its alias, which is the callable entity.
6969 if Is_Generic_Instance (Subprogram_Def) then
6970 Set_Encoded_Interface_Name
6971 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
6973 Set_Encoded_Interface_Name
6974 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
6977 -- We allow duplicated export names in CIL/Java, as they are always
6978 -- enclosed in a namespace that differentiates them, and overloaded
6979 -- entities are supported by the VM.
6981 if Convention (Subprogram_Def) /= Convention_CIL
6983 Convention (Subprogram_Def) /= Convention_Java
6985 Check_Duplicated_Export_Name (Link_Nam);
6987 end Process_Interface_Name;
6989 -----------------------------------------
6990 -- Process_Interrupt_Or_Attach_Handler --
6991 -----------------------------------------
6993 procedure Process_Interrupt_Or_Attach_Handler is
6994 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
6995 Handler_Proc : constant Entity_Id := Entity (Arg1_X);
6996 Proc_Scope : constant Entity_Id := Scope (Handler_Proc);
6999 Set_Is_Interrupt_Handler (Handler_Proc);
7001 -- If the pragma is not associated with a handler procedure within a
7002 -- protected type, then it must be for a nonprotected procedure for
7003 -- the AAMP target, in which case we don't associate a representation
7004 -- item with the procedure's scope.
7006 if Ekind (Proc_Scope) = E_Protected_Type then
7007 if Prag_Id = Pragma_Interrupt_Handler
7009 Prag_Id = Pragma_Attach_Handler
7011 Record_Rep_Item (Proc_Scope, N);
7014 end Process_Interrupt_Or_Attach_Handler;
7016 --------------------------------------------------
7017 -- Process_Restrictions_Or_Restriction_Warnings --
7018 --------------------------------------------------
7020 -- Note: some of the simple identifier cases were handled in par-prag,
7021 -- but it is harmless (and more straightforward) to simply handle all
7022 -- cases here, even if it means we repeat a bit of work in some cases.
7024 procedure Process_Restrictions_Or_Restriction_Warnings
7028 R_Id : Restriction_Id;
7034 -- Ignore all Restrictions pragmas in CodePeer mode
7036 if CodePeer_Mode then
7040 Check_Ada_83_Warning;
7041 Check_At_Least_N_Arguments (1);
7042 Check_Valid_Configuration_Pragma;
7045 while Present (Arg) loop
7047 Expr := Get_Pragma_Arg (Arg);
7049 -- Case of no restriction identifier present
7051 if Id = No_Name then
7052 if Nkind (Expr) /= N_Identifier then
7054 ("invalid form for restriction", Arg);
7059 (Process_Restriction_Synonyms (Expr));
7061 if R_Id not in All_Boolean_Restrictions then
7062 Error_Msg_Name_1 := Pname;
7064 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
7066 -- Check for possible misspelling
7068 for J in Restriction_Id loop
7070 Rnm : constant String := Restriction_Id'Image (J);
7073 Name_Buffer (1 .. Rnm'Length) := Rnm;
7074 Name_Len := Rnm'Length;
7075 Set_Casing (All_Lower_Case);
7077 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
7079 (Identifier_Casing (Current_Source_File));
7080 Error_Msg_String (1 .. Rnm'Length) :=
7081 Name_Buffer (1 .. Name_Len);
7082 Error_Msg_Strlen := Rnm'Length;
7083 Error_Msg_N -- CODEFIX
7084 ("\possible misspelling of ""~""",
7085 Get_Pragma_Arg (Arg));
7094 if Implementation_Restriction (R_Id) then
7095 Check_Restriction (No_Implementation_Restrictions, Arg);
7098 -- Special processing for No_Elaboration_Code restriction
7100 if R_Id = No_Elaboration_Code then
7102 -- Restriction is only recognized within a configuration
7103 -- pragma file, or within a unit of the main extended
7104 -- program. Note: the test for Main_Unit is needed to
7105 -- properly include the case of configuration pragma files.
7107 if not (Current_Sem_Unit = Main_Unit
7108 or else In_Extended_Main_Source_Unit (N))
7112 -- Don't allow in a subunit unless already specified in
7115 elsif Nkind (Parent (N)) = N_Compilation_Unit
7116 and then Nkind (Unit (Parent (N))) = N_Subunit
7117 and then not Restriction_Active (No_Elaboration_Code)
7120 ("invalid specification of ""No_Elaboration_Code""",
7123 ("\restriction cannot be specified in a subunit", N);
7125 ("\unless also specified in body or spec", N);
7128 -- If we have a No_Elaboration_Code pragma that we
7129 -- accept, then it needs to be added to the configuration
7130 -- restrcition set so that we get proper application to
7131 -- other units in the main extended source as required.
7134 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
7138 -- If this is a warning, then set the warning unless we already
7139 -- have a real restriction active (we never want a warning to
7140 -- override a real restriction).
7143 if not Restriction_Active (R_Id) then
7144 Set_Restriction (R_Id, N);
7145 Restriction_Warnings (R_Id) := True;
7148 -- If real restriction case, then set it and make sure that the
7149 -- restriction warning flag is off, since a real restriction
7150 -- always overrides a warning.
7153 Set_Restriction (R_Id, N);
7154 Restriction_Warnings (R_Id) := False;
7157 -- Check for obsolescent restrictions in Ada 2005 mode
7160 and then Ada_Version >= Ada_2005
7161 and then (R_Id = No_Asynchronous_Control
7163 R_Id = No_Unchecked_Deallocation
7165 R_Id = No_Unchecked_Conversion)
7167 Check_Restriction (No_Obsolescent_Features, N);
7170 -- A very special case that must be processed here: pragma
7171 -- Restrictions (No_Exceptions) turns off all run-time
7172 -- checking. This is a bit dubious in terms of the formal
7173 -- language definition, but it is what is intended by RM
7174 -- H.4(12). Restriction_Warnings never affects generated code
7175 -- so this is done only in the real restriction case.
7177 -- Atomic_Synchronization is not a real check, so it is not
7178 -- affected by this processing).
7180 if R_Id = No_Exceptions and then not Warn then
7181 for J in Scope_Suppress.Suppress'Range loop
7182 if J /= Atomic_Synchronization then
7183 Scope_Suppress.Suppress (J) := True;
7188 -- Case of No_Dependence => unit-name. Note that the parser
7189 -- already made the necessary entry in the No_Dependence table.
7191 elsif Id = Name_No_Dependence then
7192 if not OK_No_Dependence_Unit_Name (Expr) then
7196 -- Case of No_Specification_Of_Aspect => Identifier.
7198 elsif Id = Name_No_Specification_Of_Aspect then
7203 if Nkind (Expr) /= N_Identifier then
7206 A_Id := Get_Aspect_Id (Chars (Expr));
7209 if A_Id = No_Aspect then
7210 Error_Pragma_Arg ("invalid restriction name", Arg);
7212 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
7216 elsif Id = Name_No_Use_Of_Attribute then
7217 if Nkind (Expr) /= N_Identifier
7218 or else not Is_Attribute_Name (Chars (Expr))
7220 Error_Msg_N ("unknown attribute name?", Expr);
7223 Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
7226 elsif Id = Name_No_Use_Of_Pragma then
7227 if Nkind (Expr) /= N_Identifier
7228 or else not Is_Pragma_Name (Chars (Expr))
7230 Error_Msg_N ("unknown pragma name?", Expr);
7233 Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
7236 -- All other cases of restriction identifier present
7239 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
7240 Analyze_And_Resolve (Expr, Any_Integer);
7242 if R_Id not in All_Parameter_Restrictions then
7244 ("invalid restriction parameter identifier", Arg);
7246 elsif not Is_OK_Static_Expression (Expr) then
7247 Flag_Non_Static_Expr
7248 ("value must be static expression!", Expr);
7251 elsif not Is_Integer_Type (Etype (Expr))
7252 or else Expr_Value (Expr) < 0
7255 ("value must be non-negative integer", Arg);
7258 -- Restriction pragma is active
7260 Val := Expr_Value (Expr);
7262 if not UI_Is_In_Int_Range (Val) then
7264 ("pragma ignored, value too large??", Arg);
7267 -- Warning case. If the real restriction is active, then we
7268 -- ignore the request, since warning never overrides a real
7269 -- restriction. Otherwise we set the proper warning. Note that
7270 -- this circuit sets the warning again if it is already set,
7271 -- which is what we want, since the constant may have changed.
7274 if not Restriction_Active (R_Id) then
7276 (R_Id, N, Integer (UI_To_Int (Val)));
7277 Restriction_Warnings (R_Id) := True;
7280 -- Real restriction case, set restriction and make sure warning
7281 -- flag is off since real restriction always overrides warning.
7284 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
7285 Restriction_Warnings (R_Id) := False;
7291 end Process_Restrictions_Or_Restriction_Warnings;
7293 ---------------------------------
7294 -- Process_Suppress_Unsuppress --
7295 ---------------------------------
7297 -- Note: this procedure makes entries in the check suppress data
7298 -- structures managed by Sem. See spec of package Sem for full
7299 -- details on how we handle recording of check suppression.
7301 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
7306 In_Package_Spec : constant Boolean :=
7307 Is_Package_Or_Generic_Package (Current_Scope)
7308 and then not In_Package_Body (Current_Scope);
7310 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
7311 -- Used to suppress a single check on the given entity
7313 --------------------------------
7314 -- Suppress_Unsuppress_Echeck --
7315 --------------------------------
7317 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
7319 -- Check for error of trying to set atomic synchronization for
7320 -- a non-atomic variable.
7322 if C = Atomic_Synchronization
7323 and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
7326 ("pragma & requires atomic type or variable",
7327 Pragma_Identifier (Original_Node (N)));
7330 Set_Checks_May_Be_Suppressed (E);
7332 if In_Package_Spec then
7333 Push_Global_Suppress_Stack_Entry
7336 Suppress => Suppress_Case);
7338 Push_Local_Suppress_Stack_Entry
7341 Suppress => Suppress_Case);
7344 -- If this is a first subtype, and the base type is distinct,
7345 -- then also set the suppress flags on the base type.
7347 if Is_First_Subtype (E) and then Etype (E) /= E then
7348 Suppress_Unsuppress_Echeck (Etype (E), C);
7350 end Suppress_Unsuppress_Echeck;
7352 -- Start of processing for Process_Suppress_Unsuppress
7355 -- Ignore pragma Suppress/Unsuppress in CodePeer and SPARK modes on
7356 -- user code: we want to generate checks for analysis purposes, as
7357 -- set respectively by -gnatC and -gnatd.F
7359 if (CodePeer_Mode or SPARK_Mode) and then Comes_From_Source (N) then
7363 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
7364 -- declarative part or a package spec (RM 11.5(5)).
7366 if not Is_Configuration_Pragma then
7367 Check_Is_In_Decl_Part_Or_Package_Spec;
7370 Check_At_Least_N_Arguments (1);
7371 Check_At_Most_N_Arguments (2);
7372 Check_No_Identifier (Arg1);
7373 Check_Arg_Is_Identifier (Arg1);
7375 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
7377 if C = No_Check_Id then
7379 ("argument of pragma% is not valid check name", Arg1);
7382 if Arg_Count = 1 then
7384 -- Make an entry in the local scope suppress table. This is the
7385 -- table that directly shows the current value of the scope
7386 -- suppress check for any check id value.
7388 if C = All_Checks then
7390 -- For All_Checks, we set all specific predefined checks with
7391 -- the exception of Elaboration_Check, which is handled
7392 -- specially because of not wanting All_Checks to have the
7393 -- effect of deactivating static elaboration order processing.
7394 -- Atomic_Synchronization is also not affected, since this is
7395 -- not a real check.
7397 for J in Scope_Suppress.Suppress'Range loop
7398 if J /= Elaboration_Check
7400 J /= Atomic_Synchronization
7402 Scope_Suppress.Suppress (J) := Suppress_Case;
7406 -- If not All_Checks, and predefined check, then set appropriate
7407 -- scope entry. Note that we will set Elaboration_Check if this
7408 -- is explicitly specified. Atomic_Synchronization is allowed
7409 -- only if internally generated and entity is atomic.
7411 elsif C in Predefined_Check_Id
7412 and then (not Comes_From_Source (N)
7413 or else C /= Atomic_Synchronization)
7415 Scope_Suppress.Suppress (C) := Suppress_Case;
7418 -- Also make an entry in the Local_Entity_Suppress table
7420 Push_Local_Suppress_Stack_Entry
7423 Suppress => Suppress_Case);
7425 -- Case of two arguments present, where the check is suppressed for
7426 -- a specified entity (given as the second argument of the pragma)
7429 -- This is obsolescent in Ada 2005 mode
7431 if Ada_Version >= Ada_2005 then
7432 Check_Restriction (No_Obsolescent_Features, Arg2);
7435 Check_Optional_Identifier (Arg2, Name_On);
7436 E_Id := Get_Pragma_Arg (Arg2);
7439 if not Is_Entity_Name (E_Id) then
7441 ("second argument of pragma% must be entity name", Arg2);
7450 -- Enforce RM 11.5(7) which requires that for a pragma that
7451 -- appears within a package spec, the named entity must be
7452 -- within the package spec. We allow the package name itself
7453 -- to be mentioned since that makes sense, although it is not
7454 -- strictly allowed by 11.5(7).
7457 and then E /= Current_Scope
7458 and then Scope (E) /= Current_Scope
7461 ("entity in pragma% is not in package spec (RM 11.5(7))",
7465 -- Loop through homonyms. As noted below, in the case of a package
7466 -- spec, only homonyms within the package spec are considered.
7469 Suppress_Unsuppress_Echeck (E, C);
7471 if Is_Generic_Instance (E)
7472 and then Is_Subprogram (E)
7473 and then Present (Alias (E))
7475 Suppress_Unsuppress_Echeck (Alias (E), C);
7478 -- Move to next homonym if not aspect spec case
7480 exit when From_Aspect_Specification (N);
7484 -- If we are within a package specification, the pragma only
7485 -- applies to homonyms in the same scope.
7487 exit when In_Package_Spec
7488 and then Scope (E) /= Current_Scope;
7491 end Process_Suppress_Unsuppress;
7497 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
7499 if Is_Imported (E) then
7501 ("cannot export entity& that was previously imported", Arg);
7503 elsif Present (Address_Clause (E))
7504 and then not Relaxed_RM_Semantics
7507 ("cannot export entity& that has an address clause", Arg);
7510 Set_Is_Exported (E);
7512 -- Generate a reference for entity explicitly, because the
7513 -- identifier may be overloaded and name resolution will not
7516 Generate_Reference (E, Arg);
7518 -- Deal with exporting non-library level entity
7520 if not Is_Library_Level_Entity (E) then
7522 -- Not allowed at all for subprograms
7524 if Is_Subprogram (E) then
7525 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
7527 -- Otherwise set public and statically allocated
7531 Set_Is_Statically_Allocated (E);
7533 -- Warn if the corresponding W flag is set and the pragma comes
7534 -- from source. The latter may not be true e.g. on VMS where we
7535 -- expand export pragmas for exception codes associated with
7536 -- imported or exported exceptions. We do not want to generate
7537 -- a warning for something that the user did not write.
7539 if Warn_On_Export_Import
7540 and then Comes_From_Source (Arg)
7543 ("?x?& has been made static as a result of Export",
7546 ("\?x?this usage is non-standard and non-portable",
7552 if Warn_On_Export_Import and then Is_Type (E) then
7553 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
7556 if Warn_On_Export_Import and Inside_A_Generic then
7558 ("all instances of& will have the same external name?x?",
7563 ----------------------------------------------
7564 -- Set_Extended_Import_Export_External_Name --
7565 ----------------------------------------------
7567 procedure Set_Extended_Import_Export_External_Name
7568 (Internal_Ent : Entity_Id;
7569 Arg_External : Node_Id)
7571 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
7575 if No (Arg_External) then
7579 Check_Arg_Is_External_Name (Arg_External);
7581 if Nkind (Arg_External) = N_String_Literal then
7582 if String_Length (Strval (Arg_External)) = 0 then
7585 New_Name := Adjust_External_Name_Case (Arg_External);
7588 elsif Nkind (Arg_External) = N_Identifier then
7589 New_Name := Get_Default_External_Name (Arg_External);
7591 -- Check_Arg_Is_External_Name should let through only identifiers and
7592 -- string literals or static string expressions (which are folded to
7593 -- string literals).
7596 raise Program_Error;
7599 -- If we already have an external name set (by a prior normal Import
7600 -- or Export pragma), then the external names must match
7602 if Present (Interface_Name (Internal_Ent)) then
7603 Check_Matching_Internal_Names : declare
7604 S1 : constant String_Id := Strval (Old_Name);
7605 S2 : constant String_Id := Strval (New_Name);
7608 pragma No_Return (Mismatch);
7609 -- Called if names do not match
7615 procedure Mismatch is
7617 Error_Msg_Sloc := Sloc (Old_Name);
7619 ("external name does not match that given #",
7623 -- Start of processing for Check_Matching_Internal_Names
7626 if String_Length (S1) /= String_Length (S2) then
7630 for J in 1 .. String_Length (S1) loop
7631 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
7636 end Check_Matching_Internal_Names;
7638 -- Otherwise set the given name
7641 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
7642 Check_Duplicated_Export_Name (New_Name);
7644 end Set_Extended_Import_Export_External_Name;
7650 procedure Set_Imported (E : Entity_Id) is
7652 -- Error message if already imported or exported
7654 if Is_Exported (E) or else Is_Imported (E) then
7656 -- Error if being set Exported twice
7658 if Is_Exported (E) then
7659 Error_Msg_NE ("entity& was previously exported", N, E);
7661 -- Ignore error in CodePeer mode where we treat all imported
7662 -- subprograms as unknown.
7664 elsif CodePeer_Mode then
7667 -- OK if Import/Interface case
7669 elsif Import_Interface_Present (N) then
7672 -- Error if being set Imported twice
7675 Error_Msg_NE ("entity& was previously imported", N, E);
7678 Error_Msg_Name_1 := Pname;
7680 ("\(pragma% applies to all previous entities)", N);
7682 Error_Msg_Sloc := Sloc (E);
7683 Error_Msg_NE ("\import not allowed for& declared#", N, E);
7685 -- Here if not previously imported or exported, OK to import
7688 Set_Is_Imported (E);
7690 -- If the entity is an object that is not at the library level,
7691 -- then it is statically allocated. We do not worry about objects
7692 -- with address clauses in this context since they are not really
7693 -- imported in the linker sense.
7696 and then not Is_Library_Level_Entity (E)
7697 and then No (Address_Clause (E))
7699 Set_Is_Statically_Allocated (E);
7706 -------------------------
7707 -- Set_Mechanism_Value --
7708 -------------------------
7710 -- Note: the mechanism name has not been analyzed (and cannot indeed be
7711 -- analyzed, since it is semantic nonsense), so we get it in the exact
7712 -- form created by the parser.
7714 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
7717 Mech_Name_Id : Name_Id;
7719 procedure Bad_Class;
7720 pragma No_Return (Bad_Class);
7721 -- Signal bad descriptor class name
7723 procedure Bad_Mechanism;
7724 pragma No_Return (Bad_Mechanism);
7725 -- Signal bad mechanism name
7731 procedure Bad_Class is
7733 Error_Pragma_Arg ("unrecognized descriptor class name", Class);
7736 -------------------------
7737 -- Bad_Mechanism_Value --
7738 -------------------------
7740 procedure Bad_Mechanism is
7742 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
7745 -- Start of processing for Set_Mechanism_Value
7748 if Mechanism (Ent) /= Default_Mechanism then
7750 ("mechanism for & has already been set", Mech_Name, Ent);
7753 -- MECHANISM_NAME ::= value | reference | descriptor |
7756 if Nkind (Mech_Name) = N_Identifier then
7757 if Chars (Mech_Name) = Name_Value then
7758 Set_Mechanism (Ent, By_Copy);
7761 elsif Chars (Mech_Name) = Name_Reference then
7762 Set_Mechanism (Ent, By_Reference);
7765 elsif Chars (Mech_Name) = Name_Descriptor then
7766 Check_VMS (Mech_Name);
7768 -- Descriptor => Short_Descriptor if pragma was given
7770 if Short_Descriptors then
7771 Set_Mechanism (Ent, By_Short_Descriptor);
7773 Set_Mechanism (Ent, By_Descriptor);
7778 elsif Chars (Mech_Name) = Name_Short_Descriptor then
7779 Check_VMS (Mech_Name);
7780 Set_Mechanism (Ent, By_Short_Descriptor);
7783 elsif Chars (Mech_Name) = Name_Copy then
7785 ("bad mechanism name, Value assumed", Mech_Name);
7791 -- MECHANISM_NAME ::= descriptor (CLASS_NAME) |
7792 -- short_descriptor (CLASS_NAME)
7793 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7795 -- Note: this form is parsed as an indexed component
7797 elsif Nkind (Mech_Name) = N_Indexed_Component then
7798 Class := First (Expressions (Mech_Name));
7800 if Nkind (Prefix (Mech_Name)) /= N_Identifier
7802 not Nam_In (Chars (Prefix (Mech_Name)), Name_Descriptor,
7803 Name_Short_Descriptor)
7804 or else Present (Next (Class))
7808 Mech_Name_Id := Chars (Prefix (Mech_Name));
7810 -- Change Descriptor => Short_Descriptor if pragma was given
7812 if Mech_Name_Id = Name_Descriptor
7813 and then Short_Descriptors
7815 Mech_Name_Id := Name_Short_Descriptor;
7819 -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) |
7820 -- short_descriptor (Class => CLASS_NAME)
7821 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7823 -- Note: this form is parsed as a function call
7825 elsif Nkind (Mech_Name) = N_Function_Call then
7826 Param := First (Parameter_Associations (Mech_Name));
7828 if Nkind (Name (Mech_Name)) /= N_Identifier
7830 not Nam_In (Chars (Name (Mech_Name)), Name_Descriptor,
7831 Name_Short_Descriptor)
7832 or else Present (Next (Param))
7833 or else No (Selector_Name (Param))
7834 or else Chars (Selector_Name (Param)) /= Name_Class
7838 Class := Explicit_Actual_Parameter (Param);
7839 Mech_Name_Id := Chars (Name (Mech_Name));
7846 -- Fall through here with Class set to descriptor class name
7848 Check_VMS (Mech_Name);
7850 if Nkind (Class) /= N_Identifier then
7853 elsif Mech_Name_Id = Name_Descriptor
7854 and then Chars (Class) = Name_UBS
7856 Set_Mechanism (Ent, By_Descriptor_UBS);
7858 elsif Mech_Name_Id = Name_Descriptor
7859 and then Chars (Class) = Name_UBSB
7861 Set_Mechanism (Ent, By_Descriptor_UBSB);
7863 elsif Mech_Name_Id = Name_Descriptor
7864 and then Chars (Class) = Name_UBA
7866 Set_Mechanism (Ent, By_Descriptor_UBA);
7868 elsif Mech_Name_Id = Name_Descriptor
7869 and then Chars (Class) = Name_S
7871 Set_Mechanism (Ent, By_Descriptor_S);
7873 elsif Mech_Name_Id = Name_Descriptor
7874 and then Chars (Class) = Name_SB
7876 Set_Mechanism (Ent, By_Descriptor_SB);
7878 elsif Mech_Name_Id = Name_Descriptor
7879 and then Chars (Class) = Name_A
7881 Set_Mechanism (Ent, By_Descriptor_A);
7883 elsif Mech_Name_Id = Name_Descriptor
7884 and then Chars (Class) = Name_NCA
7886 Set_Mechanism (Ent, By_Descriptor_NCA);
7888 elsif Mech_Name_Id = Name_Short_Descriptor
7889 and then Chars (Class) = Name_UBS
7891 Set_Mechanism (Ent, By_Short_Descriptor_UBS);
7893 elsif Mech_Name_Id = Name_Short_Descriptor
7894 and then Chars (Class) = Name_UBSB
7896 Set_Mechanism (Ent, By_Short_Descriptor_UBSB);
7898 elsif Mech_Name_Id = Name_Short_Descriptor
7899 and then Chars (Class) = Name_UBA
7901 Set_Mechanism (Ent, By_Short_Descriptor_UBA);
7903 elsif Mech_Name_Id = Name_Short_Descriptor
7904 and then Chars (Class) = Name_S
7906 Set_Mechanism (Ent, By_Short_Descriptor_S);
7908 elsif Mech_Name_Id = Name_Short_Descriptor
7909 and then Chars (Class) = Name_SB
7911 Set_Mechanism (Ent, By_Short_Descriptor_SB);
7913 elsif Mech_Name_Id = Name_Short_Descriptor
7914 and then Chars (Class) = Name_A
7916 Set_Mechanism (Ent, By_Short_Descriptor_A);
7918 elsif Mech_Name_Id = Name_Short_Descriptor
7919 and then Chars (Class) = Name_NCA
7921 Set_Mechanism (Ent, By_Short_Descriptor_NCA);
7926 end Set_Mechanism_Value;
7928 --------------------------
7929 -- Set_Rational_Profile --
7930 --------------------------
7932 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
7933 -- and extension to the semantics of renaming declarations.
7935 procedure Set_Rational_Profile is
7937 Implicit_Packing := True;
7938 Overriding_Renamings := True;
7939 Use_VADS_Size := True;
7940 end Set_Rational_Profile;
7942 ---------------------------
7943 -- Set_Ravenscar_Profile --
7944 ---------------------------
7946 -- The tasks to be done here are
7948 -- Set required policies
7950 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
7951 -- pragma Locking_Policy (Ceiling_Locking)
7953 -- Set Detect_Blocking mode
7955 -- Set required restrictions (see System.Rident for detailed list)
7957 -- Set the No_Dependence rules
7958 -- No_Dependence => Ada.Asynchronous_Task_Control
7959 -- No_Dependence => Ada.Calendar
7960 -- No_Dependence => Ada.Execution_Time.Group_Budget
7961 -- No_Dependence => Ada.Execution_Time.Timers
7962 -- No_Dependence => Ada.Task_Attributes
7963 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
7965 procedure Set_Ravenscar_Profile (N : Node_Id) is
7966 Prefix_Entity : Entity_Id;
7967 Selector_Entity : Entity_Id;
7968 Prefix_Node : Node_Id;
7972 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
7974 if Task_Dispatching_Policy /= ' '
7975 and then Task_Dispatching_Policy /= 'F'
7977 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
7978 Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
7980 -- Set the FIFO_Within_Priorities policy, but always preserve
7981 -- System_Location since we like the error message with the run time
7985 Task_Dispatching_Policy := 'F';
7987 if Task_Dispatching_Policy_Sloc /= System_Location then
7988 Task_Dispatching_Policy_Sloc := Loc;
7992 -- pragma Locking_Policy (Ceiling_Locking)
7994 if Locking_Policy /= ' '
7995 and then Locking_Policy /= 'C'
7997 Error_Msg_Sloc := Locking_Policy_Sloc;
7998 Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
8000 -- Set the Ceiling_Locking policy, but preserve System_Location since
8001 -- we like the error message with the run time name.
8004 Locking_Policy := 'C';
8006 if Locking_Policy_Sloc /= System_Location then
8007 Locking_Policy_Sloc := Loc;
8011 -- pragma Detect_Blocking
8013 Detect_Blocking := True;
8015 -- Set the corresponding restrictions
8017 Set_Profile_Restrictions
8018 (Ravenscar, N, Warn => Treat_Restrictions_As_Warnings);
8020 -- Set the No_Dependence restrictions
8022 -- The following No_Dependence restrictions:
8023 -- No_Dependence => Ada.Asynchronous_Task_Control
8024 -- No_Dependence => Ada.Calendar
8025 -- No_Dependence => Ada.Task_Attributes
8026 -- are already set by previous call to Set_Profile_Restrictions.
8028 -- Set the following restrictions which were added to Ada 2005:
8029 -- No_Dependence => Ada.Execution_Time.Group_Budget
8030 -- No_Dependence => Ada.Execution_Time.Timers
8032 if Ada_Version >= Ada_2005 then
8033 Name_Buffer (1 .. 3) := "ada";
8036 Prefix_Entity := Make_Identifier (Loc, Name_Find);
8038 Name_Buffer (1 .. 14) := "execution_time";
8041 Selector_Entity := Make_Identifier (Loc, Name_Find);
8044 Make_Selected_Component
8046 Prefix => Prefix_Entity,
8047 Selector_Name => Selector_Entity);
8049 Name_Buffer (1 .. 13) := "group_budgets";
8052 Selector_Entity := Make_Identifier (Loc, Name_Find);
8055 Make_Selected_Component
8057 Prefix => Prefix_Node,
8058 Selector_Name => Selector_Entity);
8060 Set_Restriction_No_Dependence
8062 Warn => Treat_Restrictions_As_Warnings,
8063 Profile => Ravenscar);
8065 Name_Buffer (1 .. 6) := "timers";
8068 Selector_Entity := Make_Identifier (Loc, Name_Find);
8071 Make_Selected_Component
8073 Prefix => Prefix_Node,
8074 Selector_Name => Selector_Entity);
8076 Set_Restriction_No_Dependence
8078 Warn => Treat_Restrictions_As_Warnings,
8079 Profile => Ravenscar);
8082 -- Set the following restrictions which was added to Ada 2012 (see
8084 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
8086 if Ada_Version >= Ada_2012 then
8087 Name_Buffer (1 .. 6) := "system";
8090 Prefix_Entity := Make_Identifier (Loc, Name_Find);
8092 Name_Buffer (1 .. 15) := "multiprocessors";
8095 Selector_Entity := Make_Identifier (Loc, Name_Find);
8098 Make_Selected_Component
8100 Prefix => Prefix_Entity,
8101 Selector_Name => Selector_Entity);
8103 Name_Buffer (1 .. 19) := "dispatching_domains";
8106 Selector_Entity := Make_Identifier (Loc, Name_Find);
8109 Make_Selected_Component
8111 Prefix => Prefix_Node,
8112 Selector_Name => Selector_Entity);
8114 Set_Restriction_No_Dependence
8116 Warn => Treat_Restrictions_As_Warnings,
8117 Profile => Ravenscar);
8119 end Set_Ravenscar_Profile;
8125 procedure S14_Pragma is
8127 if not Formal_Extensions then
8128 Error_Pragma ("pragma% requires the use of debug switch -gnatd.V");
8132 -- Start of processing for Analyze_Pragma
8135 -- The following code is a defense against recursion. Not clear that
8136 -- this can happen legitimately, but perhaps some error situations
8137 -- can cause it, and we did see this recursion during testing.
8139 if Analyzed (N) then
8142 Set_Analyzed (N, True);
8145 -- Deal with unrecognized pragma
8147 Pname := Pragma_Name (N);
8149 if not Is_Pragma_Name (Pname) then
8150 if Warn_On_Unrecognized_Pragma then
8151 Error_Msg_Name_1 := Pname;
8152 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
8154 for PN in First_Pragma_Name .. Last_Pragma_Name loop
8155 if Is_Bad_Spelling_Of (Pname, PN) then
8156 Error_Msg_Name_1 := PN;
8157 Error_Msg_N -- CODEFIX
8158 ("\?g?possible misspelling of %!", Pragma_Identifier (N));
8167 -- Here to start processing for recognized pragma
8169 Prag_Id := Get_Pragma_Id (Pname);
8170 Pname := Original_Name (N);
8172 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
8173 -- is already set, indicating that we have already checked the policy
8174 -- at the right point. This happens for example in the case of a pragma
8175 -- that is derived from an Aspect.
8177 if Is_Ignored (N) or else Is_Checked (N) then
8180 -- For a pragma that is a rewriting of another pragma, copy the
8181 -- Is_Checked/Is_Ignored status from the rewritten pragma.
8183 elsif Is_Rewrite_Substitution (N)
8184 and then Nkind (Original_Node (N)) = N_Pragma
8185 and then Original_Node (N) /= N
8187 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
8188 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
8190 -- Otherwise query the applicable policy at this point
8193 Check_Applicable_Policy (N);
8195 -- If pragma is disabled, rewrite as NULL and skip analysis
8197 if Is_Disabled (N) then
8198 Rewrite (N, Make_Null_Statement (Loc));
8212 if Present (Pragma_Argument_Associations (N)) then
8213 Arg_Count := List_Length (Pragma_Argument_Associations (N));
8214 Arg1 := First (Pragma_Argument_Associations (N));
8216 if Present (Arg1) then
8217 Arg2 := Next (Arg1);
8219 if Present (Arg2) then
8220 Arg3 := Next (Arg2);
8222 if Present (Arg3) then
8223 Arg4 := Next (Arg3);
8229 Check_Restriction_No_Use_Of_Pragma (N);
8231 -- An enumeration type defines the pragmas that are supported by the
8232 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
8233 -- into the corresponding enumeration value for the following case.
8241 -- pragma Abort_Defer;
8243 when Pragma_Abort_Defer =>
8245 Check_Arg_Count (0);
8247 -- The only required semantic processing is to check the
8248 -- placement. This pragma must appear at the start of the
8249 -- statement sequence of a handled sequence of statements.
8251 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
8252 or else N /= First (Statements (Parent (N)))
8257 --------------------
8258 -- Abstract_State --
8259 --------------------
8261 -- pragma Abstract_State (ABSTRACT_STATE_LIST)
8263 -- ABSTRACT_STATE_LIST ::=
8265 -- | STATE_NAME_WITH_OPTIONS
8266 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
8268 -- STATE_NAME_WITH_OPTIONS ::=
8270 -- | (state_NAME with OPTION_LIST)
8272 -- OPTION_LIST ::= OPTION {, OPTION}
8274 -- OPTION ::= SIMPLE_OPTION | NAME_VALUE_OPTION
8276 -- SIMPLE_OPTION ::=
8277 -- External | Non_Volatile | Input_Only | Output_Only
8279 -- NAME_VALUE_OPTION ::= Part_Of => abstract_state_NAME
8281 when Pragma_Abstract_State => Abstract_State : declare
8282 Pack_Id : Entity_Id;
8284 -- Flags used to verify the consistency of states
8286 Non_Null_Seen : Boolean := False;
8287 Null_Seen : Boolean := False;
8289 procedure Analyze_Abstract_State (State : Node_Id);
8290 -- Verify the legality of a single state declaration. Create and
8291 -- decorate a state abstraction entity and introduce it into the
8292 -- visibility chain.
8294 ----------------------------
8295 -- Analyze_Abstract_State --
8296 ----------------------------
8298 procedure Analyze_Abstract_State (State : Node_Id) is
8299 procedure Check_Duplicate_Option
8301 Status : in out Boolean);
8302 -- Flag Status denotes whether a particular option has been
8303 -- seen while processing a state. This routine verifies that
8304 -- Opt is not a duplicate property and sets the flag Status.
8306 ----------------------------
8307 -- Check_Duplicate_Option --
8308 ----------------------------
8310 procedure Check_Duplicate_Option
8312 Status : in out Boolean)
8316 Error_Msg_N ("duplicate state option", Opt);
8320 end Check_Duplicate_Option;
8324 Errors : constant Nat := Serious_Errors_Detected;
8325 Loc : constant Source_Ptr := Sloc (State);
8328 Is_Null : Boolean := False;
8331 Par_State : Node_Id;
8333 -- Flags used to verify the consistency of options
8335 External_Seen : Boolean := False;
8336 Input_Seen : Boolean := False;
8337 Non_Volatile_Seen : Boolean := False;
8338 Output_Seen : Boolean := False;
8339 Part_Of_Seen : Boolean := False;
8341 -- Start of processing for Analyze_Abstract_State
8344 -- A package with a null abstract state is not allowed to
8345 -- declare additional states.
8349 ("package & has null abstract state", State, Pack_Id);
8351 -- Null states appear as internally generated entities
8353 elsif Nkind (State) = N_Null then
8354 Name := New_Internal_Name ('S');
8358 -- Catch a case where a null state appears in a list of
8361 if Non_Null_Seen then
8363 ("package & has non-null abstract state",
8367 -- Simple state declaration
8369 elsif Nkind (State) = N_Identifier then
8370 Name := Chars (State);
8371 Non_Null_Seen := True;
8373 -- State declaration with various options. This construct
8374 -- appears as an extension aggregate in the tree.
8376 elsif Nkind (State) = N_Extension_Aggregate then
8377 if Nkind (Ancestor_Part (State)) = N_Identifier then
8378 Name := Chars (Ancestor_Part (State));
8379 Non_Null_Seen := True;
8382 ("state name must be an identifier",
8383 Ancestor_Part (State));
8386 -- Process options External, Input_Only, Output_Only and
8387 -- Volatile. Ensure that none of them appear more than once.
8389 Opt := First (Expressions (State));
8390 while Present (Opt) loop
8391 if Nkind (Opt) = N_Identifier then
8392 if Chars (Opt) = Name_External then
8393 Check_Duplicate_Option (Opt, External_Seen);
8394 elsif Chars (Opt) = Name_Input_Only then
8395 Check_Duplicate_Option (Opt, Input_Seen);
8396 elsif Chars (Opt) = Name_Output_Only then
8397 Check_Duplicate_Option (Opt, Output_Seen);
8398 elsif Chars (Opt) = Name_Non_Volatile then
8399 Check_Duplicate_Option (Opt, Non_Volatile_Seen);
8401 -- Ensure that the abstract state component of option
8402 -- Part_Of has not been omitted.
8404 elsif Chars (Opt) = Name_Part_Of then
8406 ("option Part_Of requires an abstract state",
8409 Error_Msg_N ("invalid state option", Opt);
8412 Error_Msg_N ("invalid state option", Opt);
8418 -- External requires exactly one Input_Only or Output_Only
8420 if External_Seen and then Input_Seen = Output_Seen then
8422 ("option External requires exactly one option "
8423 & "Input_Only or Output_Only", State);
8426 -- Either Input_Only or Output_Only require External
8428 if (Input_Seen or Output_Seen)
8429 and then not External_Seen
8432 ("options Input_Only and Output_Only require option "
8433 & "External", State);
8436 -- Option Part_Of appears as a component association
8438 Assoc := First (Component_Associations (State));
8439 while Present (Assoc) loop
8440 Opt := First (Choices (Assoc));
8441 while Present (Opt) loop
8442 if Nkind (Opt) = N_Identifier
8443 and then Chars (Opt) = Name_Part_Of
8445 Check_Duplicate_Option (Opt, Part_Of_Seen);
8447 Error_Msg_N ("invalid state option", Opt);
8453 -- Part_Of must denote a parent state. Ensure that the
8454 -- tree is not malformed by checking the expression of
8455 -- the component association.
8457 Par_State := Expression (Assoc);
8458 pragma Assert (Present (Par_State));
8460 Analyze (Par_State);
8462 -- Part_Of specified a legal state
8464 if Is_Entity_Name (Par_State)
8465 and then Present (Entity (Par_State))
8466 and then Ekind (Entity (Par_State)) = E_Abstract_State
8471 ("option Part_Of must denote an abstract state",
8478 -- Any other attempt to declare a state is erroneous
8481 Error_Msg_N ("malformed abstract state declaration", State);
8484 -- Do not generate a state abstraction entity if it was not
8485 -- properly declared.
8487 if Serious_Errors_Detected > Errors then
8491 -- The generated state abstraction reuses the same characters
8492 -- from the original state declaration. Decorate the entity.
8494 Id := Make_Defining_Identifier (Loc, New_External_Name (Name));
8495 Set_Comes_From_Source (Id, not Is_Null);
8496 Set_Parent (Id, State);
8497 Set_Ekind (Id, E_Abstract_State);
8498 Set_Etype (Id, Standard_Void_Type);
8500 -- Every non-null state must be nameable and resolvable the
8501 -- same way a constant is.
8504 Push_Scope (Pack_Id);
8509 -- Verify whether the state introduces an illegal hidden state
8510 -- within a package subject to a null abstract state.
8512 if Formal_Extensions then
8513 Check_No_Hidden_State (Id);
8516 -- Associate the state with its related package
8518 if No (Abstract_States (Pack_Id)) then
8519 Set_Abstract_States (Pack_Id, New_Elmt_List);
8522 Append_Elmt (Id, Abstract_States (Pack_Id));
8523 end Analyze_Abstract_State;
8527 Context : constant Node_Id := Parent (Parent (N));
8530 -- Start of processing for Abstract_State
8535 Check_Arg_Count (1);
8537 -- Ensure the proper placement of the pragma. Abstract states must
8538 -- be associated with a package declaration.
8540 if not Nkind_In (Context, N_Generic_Package_Declaration,
8541 N_Package_Declaration)
8547 Pack_Id := Defining_Entity (Context);
8548 State := Expression (Arg1);
8550 -- Multiple abstract states appear as an aggregate
8552 if Nkind (State) = N_Aggregate then
8553 State := First (Expressions (State));
8554 while Present (State) loop
8555 Analyze_Abstract_State (State);
8560 -- Various forms of a single abstract state. Note that these may
8561 -- include malformed state declarations.
8564 Analyze_Abstract_State (State);
8574 -- Note: this pragma also has some specific processing in Par.Prag
8575 -- because we want to set the Ada version mode during parsing.
8577 when Pragma_Ada_83 =>
8579 Check_Arg_Count (0);
8581 -- We really should check unconditionally for proper configuration
8582 -- pragma placement, since we really don't want mixed Ada modes
8583 -- within a single unit, and the GNAT reference manual has always
8584 -- said this was a configuration pragma, but we did not check and
8585 -- are hesitant to add the check now.
8587 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
8588 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
8589 -- or Ada 2012 mode.
8591 if Ada_Version >= Ada_2005 then
8592 Check_Valid_Configuration_Pragma;
8595 -- Now set Ada 83 mode
8597 Ada_Version := Ada_83;
8598 Ada_Version_Explicit := Ada_83;
8599 Ada_Version_Pragma := N;
8607 -- Note: this pragma also has some specific processing in Par.Prag
8608 -- because we want to set the Ada 83 version mode during parsing.
8610 when Pragma_Ada_95 =>
8612 Check_Arg_Count (0);
8614 -- We really should check unconditionally for proper configuration
8615 -- pragma placement, since we really don't want mixed Ada modes
8616 -- within a single unit, and the GNAT reference manual has always
8617 -- said this was a configuration pragma, but we did not check and
8618 -- are hesitant to add the check now.
8620 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
8621 -- or Ada 95, so we must check if we are in Ada 2005 mode.
8623 if Ada_Version >= Ada_2005 then
8624 Check_Valid_Configuration_Pragma;
8627 -- Now set Ada 95 mode
8629 Ada_Version := Ada_95;
8630 Ada_Version_Explicit := Ada_95;
8631 Ada_Version_Pragma := N;
8633 ---------------------
8634 -- Ada_05/Ada_2005 --
8635 ---------------------
8638 -- pragma Ada_05 (LOCAL_NAME);
8641 -- pragma Ada_2005 (LOCAL_NAME):
8643 -- Note: these pragmas also have some specific processing in Par.Prag
8644 -- because we want to set the Ada 2005 version mode during parsing.
8646 when Pragma_Ada_05 | Pragma_Ada_2005 => declare
8652 if Arg_Count = 1 then
8653 Check_Arg_Is_Local_Name (Arg1);
8654 E_Id := Get_Pragma_Arg (Arg1);
8656 if Etype (E_Id) = Any_Type then
8660 Set_Is_Ada_2005_Only (Entity (E_Id));
8661 Record_Rep_Item (Entity (E_Id), N);
8664 Check_Arg_Count (0);
8666 -- For Ada_2005 we unconditionally enforce the documented
8667 -- configuration pragma placement, since we do not want to
8668 -- tolerate mixed modes in a unit involving Ada 2005. That
8669 -- would cause real difficulties for those cases where there
8670 -- are incompatibilities between Ada 95 and Ada 2005.
8672 Check_Valid_Configuration_Pragma;
8674 -- Now set appropriate Ada mode
8676 Ada_Version := Ada_2005;
8677 Ada_Version_Explicit := Ada_2005;
8678 Ada_Version_Pragma := N;
8682 ---------------------
8683 -- Ada_12/Ada_2012 --
8684 ---------------------
8687 -- pragma Ada_12 (LOCAL_NAME);
8690 -- pragma Ada_2012 (LOCAL_NAME):
8692 -- Note: these pragmas also have some specific processing in Par.Prag
8693 -- because we want to set the Ada 2012 version mode during parsing.
8695 when Pragma_Ada_12 | Pragma_Ada_2012 => declare
8701 if Arg_Count = 1 then
8702 Check_Arg_Is_Local_Name (Arg1);
8703 E_Id := Get_Pragma_Arg (Arg1);
8705 if Etype (E_Id) = Any_Type then
8709 Set_Is_Ada_2012_Only (Entity (E_Id));
8710 Record_Rep_Item (Entity (E_Id), N);
8713 Check_Arg_Count (0);
8715 -- For Ada_2012 we unconditionally enforce the documented
8716 -- configuration pragma placement, since we do not want to
8717 -- tolerate mixed modes in a unit involving Ada 2012. That
8718 -- would cause real difficulties for those cases where there
8719 -- are incompatibilities between Ada 95 and Ada 2012. We could
8720 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
8722 Check_Valid_Configuration_Pragma;
8724 -- Now set appropriate Ada mode
8726 Ada_Version := Ada_2012;
8727 Ada_Version_Explicit := Ada_2012;
8728 Ada_Version_Pragma := N;
8732 ----------------------
8733 -- All_Calls_Remote --
8734 ----------------------
8736 -- pragma All_Calls_Remote [(library_package_NAME)];
8738 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
8739 Lib_Entity : Entity_Id;
8742 Check_Ada_83_Warning;
8743 Check_Valid_Library_Unit_Pragma;
8745 if Nkind (N) = N_Null_Statement then
8749 Lib_Entity := Find_Lib_Unit_Name;
8751 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
8753 if Present (Lib_Entity)
8754 and then not Debug_Flag_U
8756 if not Is_Remote_Call_Interface (Lib_Entity) then
8757 Error_Pragma ("pragma% only apply to rci unit");
8759 -- Set flag for entity of the library unit
8762 Set_Has_All_Calls_Remote (Lib_Entity);
8766 end All_Calls_Remote;
8772 -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]);
8773 -- ARG ::= NAME | EXPRESSION
8775 -- The first two arguments are by convention intended to refer to an
8776 -- external tool and a tool-specific function. These arguments are
8779 when Pragma_Annotate => Annotate : declare
8785 Check_At_Least_N_Arguments (1);
8786 Check_Arg_Is_Identifier (Arg1);
8787 Check_No_Identifiers;
8790 -- Second parameter is optional, it is never analyzed
8795 -- Here if we have a second parameter
8798 -- Second parameter must be identifier
8800 Check_Arg_Is_Identifier (Arg2);
8802 -- Process remaining parameters if any
8805 while Present (Arg) loop
8806 Exp := Get_Pragma_Arg (Arg);
8809 if Is_Entity_Name (Exp) then
8812 -- For string literals, we assume Standard_String as the
8813 -- type, unless the string contains wide or wide_wide
8816 elsif Nkind (Exp) = N_String_Literal then
8817 if Has_Wide_Wide_Character (Exp) then
8818 Resolve (Exp, Standard_Wide_Wide_String);
8819 elsif Has_Wide_Character (Exp) then
8820 Resolve (Exp, Standard_Wide_String);
8822 Resolve (Exp, Standard_String);
8825 elsif Is_Overloaded (Exp) then
8827 ("ambiguous argument for pragma%", Exp);
8838 -------------------------------------------------
8839 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
8840 -------------------------------------------------
8843 -- ( [Check => ] Boolean_EXPRESSION
8844 -- [, [Message =>] Static_String_EXPRESSION]);
8846 -- pragma Assert_And_Cut
8847 -- ( [Check => ] Boolean_EXPRESSION
8848 -- [, [Message =>] Static_String_EXPRESSION]);
8851 -- ( [Check => ] Boolean_EXPRESSION
8852 -- [, [Message =>] Static_String_EXPRESSION]);
8854 -- pragma Loop_Invariant
8855 -- ( [Check => ] Boolean_EXPRESSION
8856 -- [, [Message =>] Static_String_EXPRESSION]);
8858 when Pragma_Assert |
8859 Pragma_Assert_And_Cut |
8861 Pragma_Loop_Invariant =>
8867 -- Assert is an Ada 2005 RM-defined pragma
8869 if Prag_Id = Pragma_Assert then
8872 -- The remaining ones are GNAT pragmas
8878 Check_At_Least_N_Arguments (1);
8879 Check_At_Most_N_Arguments (2);
8880 Check_Arg_Order ((Name_Check, Name_Message));
8881 Check_Optional_Identifier (Arg1, Name_Check);
8883 -- Special processing for Loop_Invariant
8885 if Prag_Id = Pragma_Loop_Invariant then
8887 -- Check restricted placement, must be within a loop
8889 Check_Loop_Pragma_Placement;
8891 -- Do preanalyze to deal with embedded Loop_Entry attribute
8893 Preanalyze_Assert_Expression (Expression (Arg1), Any_Boolean);
8896 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
8897 -- a corresponding Check pragma:
8899 -- pragma Check (name, condition [, msg]);
8901 -- Where name is the identifier matching the pragma name. So
8902 -- rewrite pragma in this manner, transfer the message argument
8903 -- if present, and analyze the result
8905 -- Note: When dealing with a semantically analyzed tree, the
8906 -- information that a Check node N corresponds to a source Assert,
8907 -- Assume, or Assert_And_Cut pragma can be retrieved from the
8908 -- pragma kind of Original_Node(N).
8910 Expr := Get_Pragma_Arg (Arg1);
8912 Make_Pragma_Argument_Association (Loc,
8913 Expression => Make_Identifier (Loc, Pname)),
8914 Make_Pragma_Argument_Association (Sloc (Expr),
8915 Expression => Expr));
8917 if Arg_Count > 1 then
8918 Check_Optional_Identifier (Arg2, Name_Message);
8919 Append_To (Newa, New_Copy_Tree (Arg2));
8922 -- Rewrite as Check pragma
8926 Chars => Name_Check,
8927 Pragma_Argument_Associations => Newa));
8931 ----------------------
8932 -- Assertion_Policy --
8933 ----------------------
8935 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
8937 -- The following form is Ada 2012 only, but we allow it in all modes
8939 -- Pragma Assertion_Policy (
8940 -- ASSERTION_KIND => POLICY_IDENTIFIER
8941 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
8943 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
8945 -- RM_ASSERTION_KIND ::= Assert |
8946 -- Static_Predicate |
8947 -- Dynamic_Predicate |
8953 -- Type_Invariant'Class
8955 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
8966 -- Statement_Assertions
8968 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
8969 -- ID_ASSERTION_KIND list contains implementation-defined additions
8970 -- recognized by GNAT. The effect is to control the behavior of
8971 -- identically named aspects and pragmas, depending on the specified
8972 -- policy identifier:
8974 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
8976 -- Note: Check and Ignore are language-defined. Disable is a GNAT
8977 -- implementation defined addition that results in totally ignoring
8978 -- the corresponding assertion. If Disable is specified, then the
8979 -- argument of the assertion is not even analyzed. This is useful
8980 -- when the aspect/pragma argument references entities in a with'ed
8981 -- package that is replaced by a dummy package in the final build.
8983 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
8984 -- and Type_Invariant'Class were recognized by the parser and
8985 -- transformed into references to the special internal identifiers
8986 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
8987 -- processing is required here.
8989 when Pragma_Assertion_Policy => Assertion_Policy : declare
8998 -- This can always appear as a configuration pragma
9000 if Is_Configuration_Pragma then
9003 -- It can also appear in a declarative part or package spec in Ada
9004 -- 2012 mode. We allow this in other modes, but in that case we
9005 -- consider that we have an Ada 2012 pragma on our hands.
9008 Check_Is_In_Decl_Part_Or_Package_Spec;
9012 -- One argument case with no identifier (first form above)
9015 and then (Nkind (Arg1) /= N_Pragma_Argument_Association
9016 or else Chars (Arg1) = No_Name)
9019 (Arg1, Name_Check, Name_Disable, Name_Ignore);
9021 -- Treat one argument Assertion_Policy as equivalent to:
9023 -- pragma Check_Policy (Assertion, policy)
9025 -- So rewrite pragma in that manner and link on to the chain
9026 -- of Check_Policy pragmas, marking the pragma as analyzed.
9028 Policy := Get_Pragma_Arg (Arg1);
9032 Chars => Name_Check_Policy,
9033 Pragma_Argument_Associations => New_List (
9034 Make_Pragma_Argument_Association (Loc,
9035 Expression => Make_Identifier (Loc, Name_Assertion)),
9037 Make_Pragma_Argument_Association (Loc,
9039 Make_Identifier (Sloc (Policy), Chars (Policy))))));
9042 -- Here if we have two or more arguments
9045 Check_At_Least_N_Arguments (1);
9048 -- Loop through arguments
9051 while Present (Arg) loop
9054 -- Kind must be specified
9056 if Nkind (Arg) /= N_Pragma_Argument_Association
9057 or else Chars (Arg) = No_Name
9060 ("missing assertion kind for pragma%", Arg);
9063 -- Check Kind and Policy have allowed forms
9065 Kind := Chars (Arg);
9067 if not Is_Valid_Assertion_Kind (Kind) then
9069 ("invalid assertion kind for pragma%", Arg);
9073 (Arg, Name_Check, Name_Disable, Name_Ignore);
9075 -- We rewrite the Assertion_Policy pragma as a series of
9076 -- Check_Policy pragmas:
9078 -- Check_Policy (Kind, Policy);
9082 Chars => Name_Check_Policy,
9083 Pragma_Argument_Associations => New_List (
9084 Make_Pragma_Argument_Association (LocP,
9085 Expression => Make_Identifier (LocP, Kind)),
9086 Make_Pragma_Argument_Association (LocP,
9087 Expression => Get_Pragma_Arg (Arg)))));
9092 -- Rewrite the Assertion_Policy pragma as null since we have
9093 -- now inserted all the equivalent Check pragmas.
9095 Rewrite (N, Make_Null_Statement (Loc));
9098 end Assertion_Policy;
9100 ------------------------------
9101 -- Assume_No_Invalid_Values --
9102 ------------------------------
9104 -- pragma Assume_No_Invalid_Values (On | Off);
9106 when Pragma_Assume_No_Invalid_Values =>
9108 Check_Valid_Configuration_Pragma;
9109 Check_Arg_Count (1);
9110 Check_No_Identifiers;
9111 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
9113 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
9114 Assume_No_Invalid_Values := True;
9116 Assume_No_Invalid_Values := False;
9119 --------------------------
9120 -- Attribute_Definition --
9121 --------------------------
9123 -- pragma Attribute_Definition
9124 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
9125 -- [Entity =>] LOCAL_NAME,
9126 -- [Expression =>] EXPRESSION | NAME);
9128 when Pragma_Attribute_Definition => Attribute_Definition : declare
9129 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
9134 Check_Arg_Count (3);
9135 Check_Optional_Identifier (Arg1, "attribute");
9136 Check_Optional_Identifier (Arg2, "entity");
9137 Check_Optional_Identifier (Arg3, "expression");
9139 if Nkind (Attribute_Designator) /= N_Identifier then
9140 Error_Msg_N ("attribute name expected", Attribute_Designator);
9144 Check_Arg_Is_Local_Name (Arg2);
9146 -- If the attribute is not recognized, then issue a warning (not
9147 -- an error), and ignore the pragma.
9149 Aname := Chars (Attribute_Designator);
9151 if not Is_Attribute_Name (Aname) then
9152 Bad_Attribute (Attribute_Designator, Aname, Warn => True);
9156 -- Otherwise, rewrite the pragma as an attribute definition clause
9159 Make_Attribute_Definition_Clause (Loc,
9160 Name => Get_Pragma_Arg (Arg2),
9162 Expression => Get_Pragma_Arg (Arg3)));
9164 end Attribute_Definition;
9170 -- pragma AST_Entry (entry_IDENTIFIER);
9172 when Pragma_AST_Entry => AST_Entry : declare
9178 Check_Arg_Count (1);
9179 Check_No_Identifiers;
9180 Check_Arg_Is_Local_Name (Arg1);
9181 Ent := Entity (Get_Pragma_Arg (Arg1));
9183 -- Note: the implementation of the AST_Entry pragma could handle
9184 -- the entry family case fine, but for now we are consistent with
9185 -- the DEC rules, and do not allow the pragma, which of course
9186 -- has the effect of also forbidding the attribute.
9188 if Ekind (Ent) /= E_Entry then
9190 ("pragma% argument must be simple entry name", Arg1);
9192 elsif Is_AST_Entry (Ent) then
9194 ("duplicate % pragma for entry", Arg1);
9196 elsif Has_Homonym (Ent) then
9198 ("pragma% argument cannot specify overloaded entry", Arg1);
9202 FF : constant Entity_Id := First_Formal (Ent);
9205 if Present (FF) then
9206 if Present (Next_Formal (FF)) then
9208 ("entry for pragma% can have only one argument",
9211 elsif Parameter_Mode (FF) /= E_In_Parameter then
9213 ("entry parameter for pragma% must have mode IN",
9219 Set_Is_AST_Entry (Ent);
9227 -- pragma Asynchronous (LOCAL_NAME);
9229 when Pragma_Asynchronous => Asynchronous : declare
9237 procedure Process_Async_Pragma;
9238 -- Common processing for procedure and access-to-procedure case
9240 --------------------------
9241 -- Process_Async_Pragma --
9242 --------------------------
9244 procedure Process_Async_Pragma is
9247 Set_Is_Asynchronous (Nm);
9251 -- The formals should be of mode IN (RM E.4.1(6))
9254 while Present (S) loop
9255 Formal := Defining_Identifier (S);
9257 if Nkind (Formal) = N_Defining_Identifier
9258 and then Ekind (Formal) /= E_In_Parameter
9261 ("pragma% procedure can only have IN parameter",
9268 Set_Is_Asynchronous (Nm);
9269 end Process_Async_Pragma;
9271 -- Start of processing for pragma Asynchronous
9274 Check_Ada_83_Warning;
9275 Check_No_Identifiers;
9276 Check_Arg_Count (1);
9277 Check_Arg_Is_Local_Name (Arg1);
9279 if Debug_Flag_U then
9283 C_Ent := Cunit_Entity (Current_Sem_Unit);
9284 Analyze (Get_Pragma_Arg (Arg1));
9285 Nm := Entity (Get_Pragma_Arg (Arg1));
9287 if not Is_Remote_Call_Interface (C_Ent)
9288 and then not Is_Remote_Types (C_Ent)
9290 -- This pragma should only appear in an RCI or Remote Types
9291 -- unit (RM E.4.1(4)).
9294 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
9297 if Ekind (Nm) = E_Procedure
9298 and then Nkind (Parent (Nm)) = N_Procedure_Specification
9300 if not Is_Remote_Call_Interface (Nm) then
9302 ("pragma% cannot be applied on non-remote procedure",
9306 L := Parameter_Specifications (Parent (Nm));
9307 Process_Async_Pragma;
9310 elsif Ekind (Nm) = E_Function then
9312 ("pragma% cannot be applied to function", Arg1);
9314 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
9315 if Is_Record_Type (Nm) then
9317 -- A record type that is the Equivalent_Type for a remote
9318 -- access-to-subprogram type.
9320 N := Declaration_Node (Corresponding_Remote_Type (Nm));
9323 -- A non-expanded RAS type (distribution is not enabled)
9325 N := Declaration_Node (Nm);
9328 if Nkind (N) = N_Full_Type_Declaration
9329 and then Nkind (Type_Definition (N)) =
9330 N_Access_Procedure_Definition
9332 L := Parameter_Specifications (Type_Definition (N));
9333 Process_Async_Pragma;
9335 if Is_Asynchronous (Nm)
9336 and then Expander_Active
9337 and then Get_PCS_Name /= Name_No_DSA
9339 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
9344 ("pragma% cannot reference access-to-function type",
9348 -- Only other possibility is Access-to-class-wide type
9350 elsif Is_Access_Type (Nm)
9351 and then Is_Class_Wide_Type (Designated_Type (Nm))
9353 Check_First_Subtype (Arg1);
9354 Set_Is_Asynchronous (Nm);
9355 if Expander_Active then
9356 RACW_Type_Is_Asynchronous (Nm);
9360 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
9368 -- pragma Atomic (LOCAL_NAME);
9370 when Pragma_Atomic =>
9371 Process_Atomic_Shared_Volatile;
9373 -----------------------
9374 -- Atomic_Components --
9375 -----------------------
9377 -- pragma Atomic_Components (array_LOCAL_NAME);
9379 -- This processing is shared by Volatile_Components
9381 when Pragma_Atomic_Components |
9382 Pragma_Volatile_Components =>
9384 Atomic_Components : declare
9391 Check_Ada_83_Warning;
9392 Check_No_Identifiers;
9393 Check_Arg_Count (1);
9394 Check_Arg_Is_Local_Name (Arg1);
9395 E_Id := Get_Pragma_Arg (Arg1);
9397 if Etype (E_Id) = Any_Type then
9403 Check_Duplicate_Pragma (E);
9405 if Rep_Item_Too_Early (E, N)
9407 Rep_Item_Too_Late (E, N)
9412 D := Declaration_Node (E);
9415 if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
9417 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
9418 and then Nkind (D) = N_Object_Declaration
9419 and then Nkind (Object_Definition (D)) =
9420 N_Constrained_Array_Definition)
9422 -- The flag is set on the object, or on the base type
9424 if Nkind (D) /= N_Object_Declaration then
9428 Set_Has_Volatile_Components (E);
9430 if Prag_Id = Pragma_Atomic_Components then
9431 Set_Has_Atomic_Components (E);
9435 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
9437 end Atomic_Components;
9439 --------------------
9440 -- Attach_Handler --
9441 --------------------
9443 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
9445 when Pragma_Attach_Handler =>
9446 Check_Ada_83_Warning;
9447 Check_No_Identifiers;
9448 Check_Arg_Count (2);
9450 if No_Run_Time_Mode then
9451 Error_Msg_CRT ("Attach_Handler pragma", N);
9453 Check_Interrupt_Or_Attach_Handler;
9455 -- The expression that designates the attribute may depend on a
9456 -- discriminant, and is therefore a per-object expression, to
9457 -- be expanded in the init proc. If expansion is enabled, then
9458 -- perform semantic checks on a copy only.
9460 if Expander_Active then
9462 Temp : constant Node_Id :=
9463 New_Copy_Tree (Get_Pragma_Arg (Arg2));
9465 Set_Parent (Temp, N);
9466 Preanalyze_And_Resolve (Temp, RTE (RE_Interrupt_ID));
9470 Analyze (Get_Pragma_Arg (Arg2));
9471 Resolve (Get_Pragma_Arg (Arg2), RTE (RE_Interrupt_ID));
9474 Process_Interrupt_Or_Attach_Handler;
9477 --------------------
9478 -- C_Pass_By_Copy --
9479 --------------------
9481 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
9483 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
9489 Check_Valid_Configuration_Pragma;
9490 Check_Arg_Count (1);
9491 Check_Optional_Identifier (Arg1, "max_size");
9493 Arg := Get_Pragma_Arg (Arg1);
9494 Check_Arg_Is_Static_Expression (Arg, Any_Integer);
9496 Val := Expr_Value (Arg);
9500 ("maximum size for pragma% must be positive", Arg1);
9502 elsif UI_Is_In_Int_Range (Val) then
9503 Default_C_Record_Mechanism := UI_To_Int (Val);
9505 -- If a giant value is given, Int'Last will do well enough.
9506 -- If sometime someone complains that a record larger than
9507 -- two gigabytes is not copied, we will worry about it then!
9510 Default_C_Record_Mechanism := Mechanism_Type'Last;
9518 -- pragma Check ([Name =>] CHECK_KIND,
9519 -- [Check =>] Boolean_EXPRESSION
9520 -- [,[Message =>] String_EXPRESSION]);
9522 -- CHECK_KIND ::= IDENTIFIER |
9525 -- Invariant'Class |
9526 -- Type_Invariant'Class
9528 -- The identifiers Assertions and Statement_Assertions are not
9529 -- allowed, since they have special meaning for Check_Policy.
9531 when Pragma_Check => Check : declare
9539 Check_At_Least_N_Arguments (2);
9540 Check_At_Most_N_Arguments (3);
9541 Check_Optional_Identifier (Arg1, Name_Name);
9542 Check_Optional_Identifier (Arg2, Name_Check);
9544 if Arg_Count = 3 then
9545 Check_Optional_Identifier (Arg3, Name_Message);
9546 Str := Get_Pragma_Arg (Arg3);
9549 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
9550 Check_Arg_Is_Identifier (Arg1);
9551 Cname := Chars (Get_Pragma_Arg (Arg1));
9553 -- Check forbidden name Assertions or Statement_Assertions
9556 when Name_Assertions =>
9558 ("""Assertions"" is not allowed as a check kind "
9559 & "for pragma%", Arg1);
9561 when Name_Statement_Assertions =>
9563 ("""Statement_Assertions"" is not allowed as a check kind "
9564 & "for pragma%", Arg1);
9570 -- Check applicable policy. We skip this if Checked/Ignored status
9571 -- is already set (e.g. in the casse of a pragma from an aspect).
9573 if Is_Checked (N) or else Is_Ignored (N) then
9576 -- For a non-source pragma that is a rewriting of another pragma,
9577 -- copy the Is_Checked/Ignored status from the rewritten pragma.
9579 elsif Is_Rewrite_Substitution (N)
9580 and then Nkind (Original_Node (N)) = N_Pragma
9581 and then Original_Node (N) /= N
9583 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
9584 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
9586 -- Otherwise query the applicable policy at this point
9589 case Check_Kind (Cname) is
9591 Set_Is_Ignored (N, True);
9592 Set_Is_Checked (N, False);
9595 Set_Is_Ignored (N, False);
9596 Set_Is_Checked (N, True);
9598 -- For disable, rewrite pragma as null statement and skip
9599 -- rest of the analysis of the pragma.
9601 when Name_Disable =>
9602 Rewrite (N, Make_Null_Statement (Loc));
9606 -- No other possibilities
9609 raise Program_Error;
9613 -- If check kind was not Disable, then continue pragma analysis
9615 Expr := Get_Pragma_Arg (Arg2);
9617 -- Deal with SCO generation
9620 when Name_Predicate |
9623 -- Nothing to do: since checks occur in client units,
9624 -- the SCO for the aspect in the declaration unit is
9625 -- conservatively always enabled.
9631 if Is_Checked (N) and then not Split_PPC (N) then
9633 -- Mark pragma/aspect SCO as enabled
9635 Set_SCO_Pragma_Enabled (Loc);
9639 -- Deal with analyzing the string argument.
9641 if Arg_Count = 3 then
9643 -- If checks are not on we don't want any expansion (since
9644 -- such expansion would not get properly deleted) but
9645 -- we do want to analyze (to get proper references).
9646 -- The Preanalyze_And_Resolve routine does just what we want
9648 if Is_Ignored (N) then
9649 Preanalyze_And_Resolve (Str, Standard_String);
9651 -- Otherwise we need a proper analysis and expansion
9654 Analyze_And_Resolve (Str, Standard_String);
9658 -- Now you might think we could just do the same with the Boolean
9659 -- expression if checks are off (and expansion is on) and then
9660 -- rewrite the check as a null statement. This would work but we
9661 -- would lose the useful warnings about an assertion being bound
9662 -- to fail even if assertions are turned off.
9664 -- So instead we wrap the boolean expression in an if statement
9667 -- if False and then condition then
9671 -- The reason we do this rewriting during semantic analysis rather
9672 -- than as part of normal expansion is that we cannot analyze and
9673 -- expand the code for the boolean expression directly, or it may
9674 -- cause insertion of actions that would escape the attempt to
9675 -- suppress the check code.
9677 -- Note that the Sloc for the if statement corresponds to the
9678 -- argument condition, not the pragma itself. The reason for
9679 -- this is that we may generate a warning if the condition is
9680 -- False at compile time, and we do not want to delete this
9681 -- warning when we delete the if statement.
9683 if Expander_Active and Is_Ignored (N) then
9684 Eloc := Sloc (Expr);
9687 Make_If_Statement (Eloc,
9689 Make_And_Then (Eloc,
9690 Left_Opnd => New_Occurrence_Of (Standard_False, Eloc),
9691 Right_Opnd => Expr),
9692 Then_Statements => New_List (
9693 Make_Null_Statement (Eloc))));
9695 In_Assertion_Expr := In_Assertion_Expr + 1;
9697 In_Assertion_Expr := In_Assertion_Expr - 1;
9699 -- Check is active or expansion not active. In these cases we can
9700 -- just go ahead and analyze the boolean with no worries.
9703 In_Assertion_Expr := In_Assertion_Expr + 1;
9704 Analyze_And_Resolve (Expr, Any_Boolean);
9705 In_Assertion_Expr := In_Assertion_Expr - 1;
9709 --------------------------
9710 -- Check_Float_Overflow --
9711 --------------------------
9713 -- pragma Check_Float_Overflow;
9715 when Pragma_Check_Float_Overflow =>
9717 Check_Valid_Configuration_Pragma;
9718 Check_Arg_Count (0);
9719 Check_Float_Overflow := True;
9725 -- pragma Check_Name (check_IDENTIFIER);
9727 when Pragma_Check_Name =>
9729 Check_No_Identifiers;
9730 Check_Valid_Configuration_Pragma;
9731 Check_Arg_Count (1);
9732 Check_Arg_Is_Identifier (Arg1);
9735 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
9738 for J in Check_Names.First .. Check_Names.Last loop
9739 if Check_Names.Table (J) = Nam then
9744 Check_Names.Append (Nam);
9751 -- This is the old style syntax, which is still allowed in all modes:
9753 -- pragma Check_Policy ([Name =>] CHECK_KIND
9754 -- [Policy =>] POLICY_IDENTIFIER);
9756 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
9758 -- CHECK_KIND ::= IDENTIFIER |
9761 -- Type_Invariant'Class |
9764 -- This is the new style syntax, compatible with Assertion_Policy
9765 -- and also allowed in all modes.
9767 -- Pragma Check_Policy (
9768 -- CHECK_KIND => POLICY_IDENTIFIER
9769 -- {, CHECK_KIND => POLICY_IDENTIFIER});
9771 -- Note: the identifiers Name and Policy are not allowed as
9772 -- Check_Kind values. This avoids ambiguities between the old and
9775 when Pragma_Check_Policy => Check_Policy : declare
9780 Check_At_Least_N_Arguments (1);
9782 -- A Check_Policy pragma can appear either as a configuration
9783 -- pragma, or in a declarative part or a package spec (see RM
9784 -- 11.5(5) for rules for Suppress/Unsuppress which are also
9785 -- followed for Check_Policy).
9787 if not Is_Configuration_Pragma then
9788 Check_Is_In_Decl_Part_Or_Package_Spec;
9791 -- Figure out if we have the old or new syntax. We have the
9792 -- old syntax if the first argument has no identifier, or the
9793 -- identifier is Name.
9795 if Nkind (Arg1) /= N_Pragma_Argument_Association
9796 or else Nam_In (Chars (Arg1), No_Name, Name_Name)
9800 Check_Arg_Count (2);
9801 Check_Optional_Identifier (Arg1, Name_Name);
9802 Kind := Get_Pragma_Arg (Arg1);
9803 Rewrite_Assertion_Kind (Kind);
9804 Check_Arg_Is_Identifier (Arg1);
9806 -- Check forbidden check kind
9808 if Nam_In (Chars (Kind), Name_Name, Name_Policy) then
9809 Error_Msg_Name_2 := Chars (Kind);
9811 ("pragma% does not allow% as check name", Arg1);
9816 Check_Optional_Identifier (Arg2, Name_Policy);
9819 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
9821 -- And chain pragma on the Check_Policy_List for search
9823 Set_Next_Pragma (N, Opt.Check_Policy_List);
9824 Opt.Check_Policy_List := N;
9826 -- For the new syntax, what we do is to convert each argument to
9827 -- an old syntax equivalent. We do that because we want to chain
9828 -- old style Check_Policy pragmas for the search (we don't want
9829 -- to have to deal with multiple arguments in the search).
9839 while Present (Arg) loop
9841 Argx := Get_Pragma_Arg (Arg);
9843 -- Kind must be specified
9845 if Nkind (Arg) /= N_Pragma_Argument_Association
9846 or else Chars (Arg) = No_Name
9849 ("missing assertion kind for pragma%", Arg);
9852 -- Construct equivalent old form syntax Check_Policy
9853 -- pragma and insert it to get remaining checks.
9857 Chars => Name_Check_Policy,
9858 Pragma_Argument_Associations => New_List (
9859 Make_Pragma_Argument_Association (LocP,
9861 Make_Identifier (LocP, Chars (Arg))),
9862 Make_Pragma_Argument_Association (Sloc (Argx),
9863 Expression => Argx))));
9868 -- Rewrite original Check_Policy pragma to null, since we
9869 -- have converted it into a series of old syntax pragmas.
9871 Rewrite (N, Make_Null_Statement (Loc));
9877 ---------------------
9878 -- CIL_Constructor --
9879 ---------------------
9881 -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
9883 -- Processing for this pragma is shared with Java_Constructor
9889 -- pragma Comment (static_string_EXPRESSION)
9891 -- Processing for pragma Comment shares the circuitry for pragma
9892 -- Ident. The only differences are that Ident enforces a limit of 31
9893 -- characters on its argument, and also enforces limitations on
9894 -- placement for DEC compatibility. Pragma Comment shares neither of
9895 -- these restrictions.
9901 -- pragma Common_Object (
9902 -- [Internal =>] LOCAL_NAME
9903 -- [, [External =>] EXTERNAL_SYMBOL]
9904 -- [, [Size =>] EXTERNAL_SYMBOL]);
9906 -- Processing for this pragma is shared with Psect_Object
9908 ------------------------
9909 -- Compile_Time_Error --
9910 ------------------------
9912 -- pragma Compile_Time_Error
9913 -- (boolean_EXPRESSION, static_string_EXPRESSION);
9915 when Pragma_Compile_Time_Error =>
9917 Process_Compile_Time_Warning_Or_Error;
9919 --------------------------
9920 -- Compile_Time_Warning --
9921 --------------------------
9923 -- pragma Compile_Time_Warning
9924 -- (boolean_EXPRESSION, static_string_EXPRESSION);
9926 when Pragma_Compile_Time_Warning =>
9928 Process_Compile_Time_Warning_Or_Error;
9934 when Pragma_Compiler_Unit =>
9936 Check_Arg_Count (0);
9937 Set_Is_Compiler_Unit (Get_Source_Unit (N));
9939 -----------------------------
9940 -- Complete_Representation --
9941 -----------------------------
9943 -- pragma Complete_Representation;
9945 when Pragma_Complete_Representation =>
9947 Check_Arg_Count (0);
9949 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
9951 ("pragma & must appear within record representation clause");
9954 ----------------------------
9955 -- Complex_Representation --
9956 ----------------------------
9958 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
9960 when Pragma_Complex_Representation => Complex_Representation : declare
9967 Check_Arg_Count (1);
9968 Check_Optional_Identifier (Arg1, Name_Entity);
9969 Check_Arg_Is_Local_Name (Arg1);
9970 E_Id := Get_Pragma_Arg (Arg1);
9972 if Etype (E_Id) = Any_Type then
9978 if not Is_Record_Type (E) then
9980 ("argument for pragma% must be record type", Arg1);
9983 Ent := First_Entity (E);
9986 or else No (Next_Entity (Ent))
9987 or else Present (Next_Entity (Next_Entity (Ent)))
9988 or else not Is_Floating_Point_Type (Etype (Ent))
9989 or else Etype (Ent) /= Etype (Next_Entity (Ent))
9992 ("record for pragma% must have two fields of the same "
9993 & "floating-point type", Arg1);
9996 Set_Has_Complex_Representation (Base_Type (E));
9998 -- We need to treat the type has having a non-standard
9999 -- representation, for back-end purposes, even though in
10000 -- general a complex will have the default representation
10001 -- of a record with two real components.
10003 Set_Has_Non_Standard_Rep (Base_Type (E));
10005 end Complex_Representation;
10007 -------------------------
10008 -- Component_Alignment --
10009 -------------------------
10011 -- pragma Component_Alignment (
10012 -- [Form =>] ALIGNMENT_CHOICE
10013 -- [, [Name =>] type_LOCAL_NAME]);
10015 -- ALIGNMENT_CHOICE ::=
10017 -- | Component_Size_4
10021 when Pragma_Component_Alignment => Component_AlignmentP : declare
10022 Args : Args_List (1 .. 2);
10023 Names : constant Name_List (1 .. 2) := (
10027 Form : Node_Id renames Args (1);
10028 Name : Node_Id renames Args (2);
10030 Atype : Component_Alignment_Kind;
10035 Gather_Associations (Names, Args);
10038 Error_Pragma ("missing Form argument for pragma%");
10041 Check_Arg_Is_Identifier (Form);
10043 -- Get proper alignment, note that Default = Component_Size on all
10044 -- machines we have so far, and we want to set this value rather
10045 -- than the default value to indicate that it has been explicitly
10046 -- set (and thus will not get overridden by the default component
10047 -- alignment for the current scope)
10049 if Chars (Form) = Name_Component_Size then
10050 Atype := Calign_Component_Size;
10052 elsif Chars (Form) = Name_Component_Size_4 then
10053 Atype := Calign_Component_Size_4;
10055 elsif Chars (Form) = Name_Default then
10056 Atype := Calign_Component_Size;
10058 elsif Chars (Form) = Name_Storage_Unit then
10059 Atype := Calign_Storage_Unit;
10063 ("invalid Form parameter for pragma%", Form);
10066 -- Case with no name, supplied, affects scope table entry
10070 (Scope_Stack.Last).Component_Alignment_Default := Atype;
10072 -- Case of name supplied
10075 Check_Arg_Is_Local_Name (Name);
10077 Typ := Entity (Name);
10080 or else Rep_Item_Too_Early (Typ, N)
10084 Typ := Underlying_Type (Typ);
10087 if not Is_Record_Type (Typ)
10088 and then not Is_Array_Type (Typ)
10091 ("Name parameter of pragma% must identify record or "
10092 & "array type", Name);
10095 -- An explicit Component_Alignment pragma overrides an
10096 -- implicit pragma Pack, but not an explicit one.
10098 if not Has_Pragma_Pack (Base_Type (Typ)) then
10099 Set_Is_Packed (Base_Type (Typ), False);
10100 Set_Component_Alignment (Base_Type (Typ), Atype);
10103 end Component_AlignmentP;
10105 --------------------
10106 -- Contract_Cases --
10107 --------------------
10109 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
10111 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
10113 -- CASE_GUARD ::= boolean_EXPRESSION | others
10115 -- CONSEQUENCE ::= boolean_EXPRESSION
10117 when Pragma_Contract_Cases => Contract_Cases : declare
10118 Subp_Decl : Node_Id;
10119 Subp_Id : Entity_Id;
10123 Check_Arg_Count (1);
10125 -- Ensure the proper placement of the pragma. Contract_Cases must
10126 -- be associated with a subprogram declaration or a body that acts
10129 Subp_Decl := Find_Related_Subprogram (N, Check_Duplicates => True);
10131 if Nkind (Subp_Decl) /= N_Subprogram_Declaration
10132 and then (Nkind (Subp_Decl) /= N_Subprogram_Body
10133 or else not Acts_As_Spec (Subp_Decl))
10139 Subp_Id := Defining_Unit_Name (Specification (Subp_Decl));
10141 -- The pragma is analyzed at the end of the declarative part which
10142 -- contains the related subprogram. Reset the analyzed flag.
10144 Set_Analyzed (N, False);
10146 -- When the aspect/pragma appears on a subprogram body, perform
10147 -- the full analysis now.
10149 if Nkind (Subp_Decl) = N_Subprogram_Body then
10150 Analyze_Contract_Cases_In_Decl_Part (N);
10152 -- When Contract_Cases applies to a subprogram compilation unit,
10153 -- the corresponding pragma is placed after the unit's declaration
10154 -- node and needs to be analyzed immediately.
10156 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration
10157 and then Nkind (Parent (Subp_Decl)) = N_Compilation_Unit
10159 Analyze_Contract_Cases_In_Decl_Part (N);
10162 -- Chain the pragma on the contract for further processing
10164 Add_Contract_Item (N, Subp_Id);
10165 end Contract_Cases;
10171 -- pragma Controlled (first_subtype_LOCAL_NAME);
10173 when Pragma_Controlled => Controlled : declare
10177 Check_No_Identifiers;
10178 Check_Arg_Count (1);
10179 Check_Arg_Is_Local_Name (Arg1);
10180 Arg := Get_Pragma_Arg (Arg1);
10182 if not Is_Entity_Name (Arg)
10183 or else not Is_Access_Type (Entity (Arg))
10185 Error_Pragma_Arg ("pragma% requires access type", Arg1);
10187 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
10195 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
10196 -- [Entity =>] LOCAL_NAME);
10198 when Pragma_Convention => Convention : declare
10201 pragma Warnings (Off, C);
10202 pragma Warnings (Off, E);
10204 Check_Arg_Order ((Name_Convention, Name_Entity));
10205 Check_Ada_83_Warning;
10206 Check_Arg_Count (2);
10207 Process_Convention (C, E);
10210 ---------------------------
10211 -- Convention_Identifier --
10212 ---------------------------
10214 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
10215 -- [Convention =>] convention_IDENTIFIER);
10217 when Pragma_Convention_Identifier => Convention_Identifier : declare
10223 Check_Arg_Order ((Name_Name, Name_Convention));
10224 Check_Arg_Count (2);
10225 Check_Optional_Identifier (Arg1, Name_Name);
10226 Check_Optional_Identifier (Arg2, Name_Convention);
10227 Check_Arg_Is_Identifier (Arg1);
10228 Check_Arg_Is_Identifier (Arg2);
10229 Idnam := Chars (Get_Pragma_Arg (Arg1));
10230 Cname := Chars (Get_Pragma_Arg (Arg2));
10232 if Is_Convention_Name (Cname) then
10233 Record_Convention_Identifier
10234 (Idnam, Get_Convention_Id (Cname));
10237 ("second arg for % pragma must be convention", Arg2);
10239 end Convention_Identifier;
10245 -- pragma CPP_Class ([Entity =>] local_NAME)
10247 when Pragma_CPP_Class => CPP_Class : declare
10251 if Warn_On_Obsolescent_Feature then
10253 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
10254 & "effect; replace it by pragma import?j?", N);
10257 Check_Arg_Count (1);
10261 Chars => Name_Import,
10262 Pragma_Argument_Associations => New_List (
10263 Make_Pragma_Argument_Association (Loc,
10264 Expression => Make_Identifier (Loc, Name_CPP)),
10265 New_Copy (First (Pragma_Argument_Associations (N))))));
10269 ---------------------
10270 -- CPP_Constructor --
10271 ---------------------
10273 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
10274 -- [, [External_Name =>] static_string_EXPRESSION ]
10275 -- [, [Link_Name =>] static_string_EXPRESSION ]);
10277 when Pragma_CPP_Constructor => CPP_Constructor : declare
10280 Def_Id : Entity_Id;
10281 Tag_Typ : Entity_Id;
10285 Check_At_Least_N_Arguments (1);
10286 Check_At_Most_N_Arguments (3);
10287 Check_Optional_Identifier (Arg1, Name_Entity);
10288 Check_Arg_Is_Local_Name (Arg1);
10290 Id := Get_Pragma_Arg (Arg1);
10291 Find_Program_Unit_Name (Id);
10293 -- If we did not find the name, we are done
10295 if Etype (Id) = Any_Type then
10299 Def_Id := Entity (Id);
10301 -- Check if already defined as constructor
10303 if Is_Constructor (Def_Id) then
10305 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
10309 if Ekind (Def_Id) = E_Function
10310 and then (Is_CPP_Class (Etype (Def_Id))
10311 or else (Is_Class_Wide_Type (Etype (Def_Id))
10313 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
10315 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
10317 ("'C'P'P constructor must be defined in the scope of "
10318 & "its returned type", Arg1);
10321 if Arg_Count >= 2 then
10322 Set_Imported (Def_Id);
10323 Set_Is_Public (Def_Id);
10324 Process_Interface_Name (Def_Id, Arg2, Arg3);
10327 Set_Has_Completion (Def_Id);
10328 Set_Is_Constructor (Def_Id);
10329 Set_Convention (Def_Id, Convention_CPP);
10331 -- Imported C++ constructors are not dispatching primitives
10332 -- because in C++ they don't have a dispatch table slot.
10333 -- However, in Ada the constructor has the profile of a
10334 -- function that returns a tagged type and therefore it has
10335 -- been treated as a primitive operation during semantic
10336 -- analysis. We now remove it from the list of primitive
10337 -- operations of the type.
10339 if Is_Tagged_Type (Etype (Def_Id))
10340 and then not Is_Class_Wide_Type (Etype (Def_Id))
10341 and then Is_Dispatching_Operation (Def_Id)
10343 Tag_Typ := Etype (Def_Id);
10345 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
10346 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
10350 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
10351 Set_Is_Dispatching_Operation (Def_Id, False);
10354 -- For backward compatibility, if the constructor returns a
10355 -- class wide type, and we internally change the return type to
10356 -- the corresponding root type.
10358 if Is_Class_Wide_Type (Etype (Def_Id)) then
10359 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
10363 ("pragma% requires function returning a 'C'P'P_Class type",
10366 end CPP_Constructor;
10372 when Pragma_CPP_Virtual => CPP_Virtual : declare
10376 if Warn_On_Obsolescent_Feature then
10378 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
10387 when Pragma_CPP_Vtable => CPP_Vtable : declare
10391 if Warn_On_Obsolescent_Feature then
10393 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
10402 -- pragma CPU (EXPRESSION);
10404 when Pragma_CPU => CPU : declare
10405 P : constant Node_Id := Parent (N);
10411 Check_No_Identifiers;
10412 Check_Arg_Count (1);
10416 if Nkind (P) = N_Subprogram_Body then
10417 Check_In_Main_Program;
10419 Arg := Get_Pragma_Arg (Arg1);
10420 Analyze_And_Resolve (Arg, Any_Integer);
10422 Ent := Defining_Unit_Name (Specification (P));
10424 if Nkind (Ent) = N_Defining_Program_Unit_Name then
10425 Ent := Defining_Identifier (Ent);
10430 if not Is_Static_Expression (Arg) then
10431 Flag_Non_Static_Expr
10432 ("main subprogram affinity is not static!", Arg);
10435 -- If constraint error, then we already signalled an error
10437 elsif Raises_Constraint_Error (Arg) then
10440 -- Otherwise check in range
10444 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
10445 -- This is the entity System.Multiprocessors.CPU_Range;
10447 Val : constant Uint := Expr_Value (Arg);
10450 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
10452 Val > Expr_Value (Type_High_Bound (CPU_Id))
10455 ("main subprogram CPU is out of range", Arg1);
10461 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
10465 elsif Nkind (P) = N_Task_Definition then
10466 Arg := Get_Pragma_Arg (Arg1);
10467 Ent := Defining_Identifier (Parent (P));
10469 -- The expression must be analyzed in the special manner
10470 -- described in "Handling of Default and Per-Object
10471 -- Expressions" in sem.ads.
10473 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
10475 -- Anything else is incorrect
10481 -- Check duplicate pragma before we chain the pragma in the Rep
10482 -- Item chain of Ent.
10484 Check_Duplicate_Pragma (Ent);
10485 Record_Rep_Item (Ent, N);
10492 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
10494 when Pragma_Debug => Debug : declare
10501 -- The condition for executing the call is that the expander
10502 -- is active and that we are not ignoring this debug pragma.
10507 (Expander_Active and then not Is_Ignored (N)),
10510 if not Is_Ignored (N) then
10511 Set_SCO_Pragma_Enabled (Loc);
10514 if Arg_Count = 2 then
10516 Make_And_Then (Loc,
10517 Left_Opnd => Relocate_Node (Cond),
10518 Right_Opnd => Get_Pragma_Arg (Arg1));
10519 Call := Get_Pragma_Arg (Arg2);
10521 Call := Get_Pragma_Arg (Arg1);
10525 N_Indexed_Component,
10529 N_Selected_Component)
10531 -- If this pragma Debug comes from source, its argument was
10532 -- parsed as a name form (which is syntactically identical).
10533 -- In a generic context a parameterless call will be left as
10534 -- an expanded name (if global) or selected_component if local.
10535 -- Change it to a procedure call statement now.
10537 Change_Name_To_Procedure_Call_Statement (Call);
10539 elsif Nkind (Call) = N_Procedure_Call_Statement then
10541 -- Already in the form of a procedure call statement: nothing
10542 -- to do (could happen in case of an internally generated
10548 -- All other cases: diagnose error
10551 ("argument of pragma ""Debug"" is not procedure call",
10556 -- Rewrite into a conditional with an appropriate condition. We
10557 -- wrap the procedure call in a block so that overhead from e.g.
10558 -- use of the secondary stack does not generate execution overhead
10559 -- for suppressed conditions.
10561 -- Normally the analysis that follows will freeze the subprogram
10562 -- being called. However, if the call is to a null procedure,
10563 -- we want to freeze it before creating the block, because the
10564 -- analysis that follows may be done with expansion disabled, in
10565 -- which case the body will not be generated, leading to spurious
10568 if Nkind (Call) = N_Procedure_Call_Statement
10569 and then Is_Entity_Name (Name (Call))
10571 Analyze (Name (Call));
10572 Freeze_Before (N, Entity (Name (Call)));
10575 Rewrite (N, Make_Implicit_If_Statement (N,
10577 Then_Statements => New_List (
10578 Make_Block_Statement (Loc,
10579 Handled_Statement_Sequence =>
10580 Make_Handled_Sequence_Of_Statements (Loc,
10581 Statements => New_List (Relocate_Node (Call)))))));
10589 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
10591 when Pragma_Debug_Policy =>
10593 Check_Arg_Count (1);
10594 Check_No_Identifiers;
10595 Check_Arg_Is_Identifier (Arg1);
10597 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
10598 -- rewrite it that way, and let the rest of the checking come
10599 -- from analyzing the rewritten pragma.
10603 Chars => Name_Check_Policy,
10604 Pragma_Argument_Associations => New_List (
10605 Make_Pragma_Argument_Association (Loc,
10606 Expression => Make_Identifier (Loc, Name_Debug)),
10608 Make_Pragma_Argument_Association (Loc,
10609 Expression => Get_Pragma_Arg (Arg1)))));
10616 -- pragma Depends (DEPENDENCY_RELATION);
10618 -- DEPENDENCY_RELATION ::=
10620 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
10622 -- DEPENDENCY_CLAUSE ::=
10623 -- OUTPUT_LIST =>[+] INPUT_LIST
10624 -- | NULL_DEPENDENCY_CLAUSE
10626 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
10628 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
10630 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
10632 -- OUTPUT ::= NAME | FUNCTION_RESULT
10635 -- where FUNCTION_RESULT is a function Result attribute_reference
10637 when Pragma_Depends => Depends : declare
10638 Subp_Decl : Node_Id;
10639 Subp_Id : Entity_Id;
10644 Check_Arg_Count (1);
10646 -- Ensure the proper placement of the pragma. Depends must be
10647 -- associated with a subprogram declaration or a body that acts
10650 Subp_Decl := Find_Related_Subprogram (N, Check_Duplicates => True);
10652 if Nkind (Subp_Decl) /= N_Subprogram_Declaration
10653 and then (Nkind (Subp_Decl) /= N_Subprogram_Body
10654 or else not Acts_As_Spec (Subp_Decl))
10660 Subp_Id := Defining_Unit_Name (Specification (Subp_Decl));
10662 -- When the aspect/pragma appears on a subprogram body, perform
10663 -- the full analysis now.
10665 if Nkind (Subp_Decl) = N_Subprogram_Body then
10666 Analyze_Depends_In_Decl_Part (N);
10668 -- When Depends applies to a subprogram compilation unit, the
10669 -- corresponding pragma is placed after the unit's declaration
10670 -- node and needs to be analyzed immediately.
10672 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration
10673 and then Nkind (Parent (Subp_Decl)) = N_Compilation_Unit
10675 Analyze_Depends_In_Decl_Part (N);
10678 -- Chain the pragma on the contract for further processing
10680 Add_Contract_Item (N, Subp_Id);
10683 ---------------------
10684 -- Detect_Blocking --
10685 ---------------------
10687 -- pragma Detect_Blocking;
10689 when Pragma_Detect_Blocking =>
10691 Check_Arg_Count (0);
10692 Check_Valid_Configuration_Pragma;
10693 Detect_Blocking := True;
10695 --------------------------
10696 -- Default_Storage_Pool --
10697 --------------------------
10699 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
10701 when Pragma_Default_Storage_Pool =>
10703 Check_Arg_Count (1);
10705 -- Default_Storage_Pool can appear as a configuration pragma, or
10706 -- in a declarative part or a package spec.
10708 if not Is_Configuration_Pragma then
10709 Check_Is_In_Decl_Part_Or_Package_Spec;
10712 -- Case of Default_Storage_Pool (null);
10714 if Nkind (Expression (Arg1)) = N_Null then
10715 Analyze (Expression (Arg1));
10717 -- This is an odd case, this is not really an expression, so
10718 -- we don't have a type for it. So just set the type to Empty.
10720 Set_Etype (Expression (Arg1), Empty);
10722 -- Case of Default_Storage_Pool (storage_pool_NAME);
10725 -- If it's a configuration pragma, then the only allowed
10726 -- argument is "null".
10728 if Is_Configuration_Pragma then
10729 Error_Pragma_Arg ("NULL expected", Arg1);
10732 -- The expected type for a non-"null" argument is
10733 -- Root_Storage_Pool'Class.
10735 Analyze_And_Resolve
10736 (Get_Pragma_Arg (Arg1),
10737 Typ => Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
10740 -- Finally, record the pool name (or null). Freeze.Freeze_Entity
10741 -- for an access type will use this information to set the
10742 -- appropriate attributes of the access type.
10744 Default_Pool := Expression (Arg1);
10746 ------------------------------------
10747 -- Disable_Atomic_Synchronization --
10748 ------------------------------------
10750 -- pragma Disable_Atomic_Synchronization [(Entity)];
10752 when Pragma_Disable_Atomic_Synchronization =>
10754 Process_Disable_Enable_Atomic_Sync (Name_Suppress);
10756 -------------------
10757 -- Discard_Names --
10758 -------------------
10760 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
10762 when Pragma_Discard_Names => Discard_Names : declare
10767 Check_Ada_83_Warning;
10769 -- Deal with configuration pragma case
10771 if Arg_Count = 0 and then Is_Configuration_Pragma then
10772 Global_Discard_Names := True;
10775 -- Otherwise, check correct appropriate context
10778 Check_Is_In_Decl_Part_Or_Package_Spec;
10780 if Arg_Count = 0 then
10782 -- If there is no parameter, then from now on this pragma
10783 -- applies to any enumeration, exception or tagged type
10784 -- defined in the current declarative part, and recursively
10785 -- to any nested scope.
10787 Set_Discard_Names (Current_Scope);
10791 Check_Arg_Count (1);
10792 Check_Optional_Identifier (Arg1, Name_On);
10793 Check_Arg_Is_Local_Name (Arg1);
10795 E_Id := Get_Pragma_Arg (Arg1);
10797 if Etype (E_Id) = Any_Type then
10800 E := Entity (E_Id);
10803 if (Is_First_Subtype (E)
10805 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
10806 or else Ekind (E) = E_Exception
10808 Set_Discard_Names (E);
10809 Record_Rep_Item (E, N);
10813 ("inappropriate entity for pragma%", Arg1);
10820 ------------------------
10821 -- Dispatching_Domain --
10822 ------------------------
10824 -- pragma Dispatching_Domain (EXPRESSION);
10826 when Pragma_Dispatching_Domain => Dispatching_Domain : declare
10827 P : constant Node_Id := Parent (N);
10833 Check_No_Identifiers;
10834 Check_Arg_Count (1);
10836 -- This pragma is born obsolete, but not the aspect
10838 if not From_Aspect_Specification (N) then
10840 (No_Obsolescent_Features, Pragma_Identifier (N));
10843 if Nkind (P) = N_Task_Definition then
10844 Arg := Get_Pragma_Arg (Arg1);
10845 Ent := Defining_Identifier (Parent (P));
10847 -- The expression must be analyzed in the special manner
10848 -- described in "Handling of Default and Per-Object
10849 -- Expressions" in sem.ads.
10851 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
10853 -- Check duplicate pragma before we chain the pragma in the Rep
10854 -- Item chain of Ent.
10856 Check_Duplicate_Pragma (Ent);
10857 Record_Rep_Item (Ent, N);
10859 -- Anything else is incorrect
10864 end Dispatching_Domain;
10870 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
10872 when Pragma_Elaborate => Elaborate : declare
10877 -- Pragma must be in context items list of a compilation unit
10879 if not Is_In_Context_Clause then
10883 -- Must be at least one argument
10885 if Arg_Count = 0 then
10886 Error_Pragma ("pragma% requires at least one argument");
10889 -- In Ada 83 mode, there can be no items following it in the
10890 -- context list except other pragmas and implicit with clauses
10891 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
10892 -- placement rule does not apply.
10894 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
10896 while Present (Citem) loop
10897 if Nkind (Citem) = N_Pragma
10898 or else (Nkind (Citem) = N_With_Clause
10899 and then Implicit_With (Citem))
10904 ("(Ada 83) pragma% must be at end of context clause");
10911 -- Finally, the arguments must all be units mentioned in a with
10912 -- clause in the same context clause. Note we already checked (in
10913 -- Par.Prag) that the arguments are all identifiers or selected
10917 Outer : while Present (Arg) loop
10918 Citem := First (List_Containing (N));
10919 Inner : while Citem /= N loop
10920 if Nkind (Citem) = N_With_Clause
10921 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
10923 Set_Elaborate_Present (Citem, True);
10924 Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
10925 Generate_Reference (Entity (Name (Citem)), Citem);
10927 -- With the pragma present, elaboration calls on
10928 -- subprograms from the named unit need no further
10929 -- checks, as long as the pragma appears in the current
10930 -- compilation unit. If the pragma appears in some unit
10931 -- in the context, there might still be a need for an
10932 -- Elaborate_All_Desirable from the current compilation
10933 -- to the named unit, so we keep the check enabled.
10935 if In_Extended_Main_Source_Unit (N) then
10936 Set_Suppress_Elaboration_Warnings
10937 (Entity (Name (Citem)));
10948 ("argument of pragma% is not withed unit", Arg);
10954 -- Give a warning if operating in static mode with -gnatwl
10955 -- (elaboration warnings enabled) switch set.
10957 if Elab_Warnings and not Dynamic_Elaboration_Checks then
10959 ("?l?use of pragma Elaborate may not be safe", N);
10961 ("?l?use pragma Elaborate_All instead if possible", N);
10965 -------------------
10966 -- Elaborate_All --
10967 -------------------
10969 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
10971 when Pragma_Elaborate_All => Elaborate_All : declare
10976 Check_Ada_83_Warning;
10978 -- Pragma must be in context items list of a compilation unit
10980 if not Is_In_Context_Clause then
10984 -- Must be at least one argument
10986 if Arg_Count = 0 then
10987 Error_Pragma ("pragma% requires at least one argument");
10990 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
10991 -- have to appear at the end of the context clause, but may
10992 -- appear mixed in with other items, even in Ada 83 mode.
10994 -- Final check: the arguments must all be units mentioned in
10995 -- a with clause in the same context clause. Note that we
10996 -- already checked (in Par.Prag) that all the arguments are
10997 -- either identifiers or selected components.
11000 Outr : while Present (Arg) loop
11001 Citem := First (List_Containing (N));
11002 Innr : while Citem /= N loop
11003 if Nkind (Citem) = N_With_Clause
11004 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
11006 Set_Elaborate_All_Present (Citem, True);
11007 Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
11009 -- Suppress warnings and elaboration checks on the named
11010 -- unit if the pragma is in the current compilation, as
11011 -- for pragma Elaborate.
11013 if In_Extended_Main_Source_Unit (N) then
11014 Set_Suppress_Elaboration_Warnings
11015 (Entity (Name (Citem)));
11024 Set_Error_Posted (N);
11026 ("argument of pragma% is not withed unit", Arg);
11033 --------------------
11034 -- Elaborate_Body --
11035 --------------------
11037 -- pragma Elaborate_Body [( library_unit_NAME )];
11039 when Pragma_Elaborate_Body => Elaborate_Body : declare
11040 Cunit_Node : Node_Id;
11041 Cunit_Ent : Entity_Id;
11044 Check_Ada_83_Warning;
11045 Check_Valid_Library_Unit_Pragma;
11047 if Nkind (N) = N_Null_Statement then
11051 Cunit_Node := Cunit (Current_Sem_Unit);
11052 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
11054 if Nkind_In (Unit (Cunit_Node), N_Package_Body,
11057 Error_Pragma ("pragma% must refer to a spec, not a body");
11059 Set_Body_Required (Cunit_Node, True);
11060 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
11062 -- If we are in dynamic elaboration mode, then we suppress
11063 -- elaboration warnings for the unit, since it is definitely
11064 -- fine NOT to do dynamic checks at the first level (and such
11065 -- checks will be suppressed because no elaboration boolean
11066 -- is created for Elaborate_Body packages).
11068 -- But in the static model of elaboration, Elaborate_Body is
11069 -- definitely NOT good enough to ensure elaboration safety on
11070 -- its own, since the body may WITH other units that are not
11071 -- safe from an elaboration point of view, so a client must
11072 -- still do an Elaborate_All on such units.
11074 -- Debug flag -gnatdD restores the old behavior of 3.13, where
11075 -- Elaborate_Body always suppressed elab warnings.
11077 if Dynamic_Elaboration_Checks or Debug_Flag_DD then
11078 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
11081 end Elaborate_Body;
11083 ------------------------
11084 -- Elaboration_Checks --
11085 ------------------------
11087 -- pragma Elaboration_Checks (Static | Dynamic);
11089 when Pragma_Elaboration_Checks =>
11091 Check_Arg_Count (1);
11092 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
11093 Dynamic_Elaboration_Checks :=
11094 (Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic);
11100 -- pragma Eliminate (
11101 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
11102 -- [,[Entity =>] IDENTIFIER |
11103 -- SELECTED_COMPONENT |
11105 -- [, OVERLOADING_RESOLUTION]);
11107 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
11110 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
11111 -- FUNCTION_PROFILE
11113 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
11115 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
11116 -- Result_Type => result_SUBTYPE_NAME]
11118 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
11119 -- SUBTYPE_NAME ::= STRING_LITERAL
11121 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
11122 -- SOURCE_TRACE ::= STRING_LITERAL
11124 when Pragma_Eliminate => Eliminate : declare
11125 Args : Args_List (1 .. 5);
11126 Names : constant Name_List (1 .. 5) := (
11129 Name_Parameter_Types,
11131 Name_Source_Location);
11133 Unit_Name : Node_Id renames Args (1);
11134 Entity : Node_Id renames Args (2);
11135 Parameter_Types : Node_Id renames Args (3);
11136 Result_Type : Node_Id renames Args (4);
11137 Source_Location : Node_Id renames Args (5);
11141 Check_Valid_Configuration_Pragma;
11142 Gather_Associations (Names, Args);
11144 if No (Unit_Name) then
11145 Error_Pragma ("missing Unit_Name argument for pragma%");
11149 and then (Present (Parameter_Types)
11151 Present (Result_Type)
11153 Present (Source_Location))
11155 Error_Pragma ("missing Entity argument for pragma%");
11158 if (Present (Parameter_Types)
11160 Present (Result_Type))
11162 Present (Source_Location)
11165 ("parameter profile and source location cannot be used "
11166 & "together in pragma%");
11169 Process_Eliminate_Pragma
11178 -----------------------------------
11179 -- Enable_Atomic_Synchronization --
11180 -----------------------------------
11182 -- pragma Enable_Atomic_Synchronization [(Entity)];
11184 when Pragma_Enable_Atomic_Synchronization =>
11186 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
11193 -- [ Convention =>] convention_IDENTIFIER,
11194 -- [ Entity =>] local_NAME
11195 -- [, [External_Name =>] static_string_EXPRESSION ]
11196 -- [, [Link_Name =>] static_string_EXPRESSION ]);
11198 when Pragma_Export => Export : declare
11200 Def_Id : Entity_Id;
11202 pragma Warnings (Off, C);
11205 Check_Ada_83_Warning;
11209 Name_External_Name,
11212 Check_At_Least_N_Arguments (2);
11214 Check_At_Most_N_Arguments (4);
11215 Process_Convention (C, Def_Id);
11217 if Ekind (Def_Id) /= E_Constant then
11218 Note_Possible_Modification
11219 (Get_Pragma_Arg (Arg2), Sure => False);
11222 Process_Interface_Name (Def_Id, Arg3, Arg4);
11223 Set_Exported (Def_Id, Arg2);
11225 -- If the entity is a deferred constant, propagate the information
11226 -- to the full view, because gigi elaborates the full view only.
11228 if Ekind (Def_Id) = E_Constant
11229 and then Present (Full_View (Def_Id))
11232 Id2 : constant Entity_Id := Full_View (Def_Id);
11234 Set_Is_Exported (Id2, Is_Exported (Def_Id));
11235 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
11236 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
11241 ----------------------
11242 -- Export_Exception --
11243 ----------------------
11245 -- pragma Export_Exception (
11246 -- [Internal =>] LOCAL_NAME
11247 -- [, [External =>] EXTERNAL_SYMBOL]
11248 -- [, [Form =>] Ada | VMS]
11249 -- [, [Code =>] static_integer_EXPRESSION]);
11251 when Pragma_Export_Exception => Export_Exception : declare
11252 Args : Args_List (1 .. 4);
11253 Names : constant Name_List (1 .. 4) := (
11259 Internal : Node_Id renames Args (1);
11260 External : Node_Id renames Args (2);
11261 Form : Node_Id renames Args (3);
11262 Code : Node_Id renames Args (4);
11267 if Inside_A_Generic then
11268 Error_Pragma ("pragma% cannot be used for generic entities");
11271 Gather_Associations (Names, Args);
11272 Process_Extended_Import_Export_Exception_Pragma (
11273 Arg_Internal => Internal,
11274 Arg_External => External,
11278 if not Is_VMS_Exception (Entity (Internal)) then
11279 Set_Exported (Entity (Internal), Internal);
11281 end Export_Exception;
11283 ---------------------
11284 -- Export_Function --
11285 ---------------------
11287 -- pragma Export_Function (
11288 -- [Internal =>] LOCAL_NAME
11289 -- [, [External =>] EXTERNAL_SYMBOL]
11290 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
11291 -- [, [Result_Type =>] TYPE_DESIGNATOR]
11292 -- [, [Mechanism =>] MECHANISM]
11293 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
11295 -- EXTERNAL_SYMBOL ::=
11297 -- | static_string_EXPRESSION
11299 -- PARAMETER_TYPES ::=
11301 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
11303 -- TYPE_DESIGNATOR ::=
11305 -- | subtype_Name ' Access
11309 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
11311 -- MECHANISM_ASSOCIATION ::=
11312 -- [formal_parameter_NAME =>] MECHANISM_NAME
11314 -- MECHANISM_NAME ::=
11317 -- | Descriptor [([Class =>] CLASS_NAME)]
11319 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
11321 when Pragma_Export_Function => Export_Function : declare
11322 Args : Args_List (1 .. 6);
11323 Names : constant Name_List (1 .. 6) := (
11326 Name_Parameter_Types,
11329 Name_Result_Mechanism);
11331 Internal : Node_Id renames Args (1);
11332 External : Node_Id renames Args (2);
11333 Parameter_Types : Node_Id renames Args (3);
11334 Result_Type : Node_Id renames Args (4);
11335 Mechanism : Node_Id renames Args (5);
11336 Result_Mechanism : Node_Id renames Args (6);
11340 Gather_Associations (Names, Args);
11341 Process_Extended_Import_Export_Subprogram_Pragma (
11342 Arg_Internal => Internal,
11343 Arg_External => External,
11344 Arg_Parameter_Types => Parameter_Types,
11345 Arg_Result_Type => Result_Type,
11346 Arg_Mechanism => Mechanism,
11347 Arg_Result_Mechanism => Result_Mechanism);
11348 end Export_Function;
11350 -------------------
11351 -- Export_Object --
11352 -------------------
11354 -- pragma Export_Object (
11355 -- [Internal =>] LOCAL_NAME
11356 -- [, [External =>] EXTERNAL_SYMBOL]
11357 -- [, [Size =>] EXTERNAL_SYMBOL]);
11359 -- EXTERNAL_SYMBOL ::=
11361 -- | static_string_EXPRESSION
11363 -- PARAMETER_TYPES ::=
11365 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
11367 -- TYPE_DESIGNATOR ::=
11369 -- | subtype_Name ' Access
11373 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
11375 -- MECHANISM_ASSOCIATION ::=
11376 -- [formal_parameter_NAME =>] MECHANISM_NAME
11378 -- MECHANISM_NAME ::=
11381 -- | Descriptor [([Class =>] CLASS_NAME)]
11383 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
11385 when Pragma_Export_Object => Export_Object : declare
11386 Args : Args_List (1 .. 3);
11387 Names : constant Name_List (1 .. 3) := (
11392 Internal : Node_Id renames Args (1);
11393 External : Node_Id renames Args (2);
11394 Size : Node_Id renames Args (3);
11398 Gather_Associations (Names, Args);
11399 Process_Extended_Import_Export_Object_Pragma (
11400 Arg_Internal => Internal,
11401 Arg_External => External,
11405 ----------------------
11406 -- Export_Procedure --
11407 ----------------------
11409 -- pragma Export_Procedure (
11410 -- [Internal =>] LOCAL_NAME
11411 -- [, [External =>] EXTERNAL_SYMBOL]
11412 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
11413 -- [, [Mechanism =>] MECHANISM]);
11415 -- EXTERNAL_SYMBOL ::=
11417 -- | static_string_EXPRESSION
11419 -- PARAMETER_TYPES ::=
11421 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
11423 -- TYPE_DESIGNATOR ::=
11425 -- | subtype_Name ' Access
11429 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
11431 -- MECHANISM_ASSOCIATION ::=
11432 -- [formal_parameter_NAME =>] MECHANISM_NAME
11434 -- MECHANISM_NAME ::=
11437 -- | Descriptor [([Class =>] CLASS_NAME)]
11439 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
11441 when Pragma_Export_Procedure => Export_Procedure : declare
11442 Args : Args_List (1 .. 4);
11443 Names : constant Name_List (1 .. 4) := (
11446 Name_Parameter_Types,
11449 Internal : Node_Id renames Args (1);
11450 External : Node_Id renames Args (2);
11451 Parameter_Types : Node_Id renames Args (3);
11452 Mechanism : Node_Id renames Args (4);
11456 Gather_Associations (Names, Args);
11457 Process_Extended_Import_Export_Subprogram_Pragma (
11458 Arg_Internal => Internal,
11459 Arg_External => External,
11460 Arg_Parameter_Types => Parameter_Types,
11461 Arg_Mechanism => Mechanism);
11462 end Export_Procedure;
11468 -- pragma Export_Value (
11469 -- [Value =>] static_integer_EXPRESSION,
11470 -- [Link_Name =>] static_string_EXPRESSION);
11472 when Pragma_Export_Value =>
11474 Check_Arg_Order ((Name_Value, Name_Link_Name));
11475 Check_Arg_Count (2);
11477 Check_Optional_Identifier (Arg1, Name_Value);
11478 Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
11480 Check_Optional_Identifier (Arg2, Name_Link_Name);
11481 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
11483 -----------------------------
11484 -- Export_Valued_Procedure --
11485 -----------------------------
11487 -- pragma Export_Valued_Procedure (
11488 -- [Internal =>] LOCAL_NAME
11489 -- [, [External =>] EXTERNAL_SYMBOL,]
11490 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
11491 -- [, [Mechanism =>] MECHANISM]);
11493 -- EXTERNAL_SYMBOL ::=
11495 -- | static_string_EXPRESSION
11497 -- PARAMETER_TYPES ::=
11499 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
11501 -- TYPE_DESIGNATOR ::=
11503 -- | subtype_Name ' Access
11507 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
11509 -- MECHANISM_ASSOCIATION ::=
11510 -- [formal_parameter_NAME =>] MECHANISM_NAME
11512 -- MECHANISM_NAME ::=
11515 -- | Descriptor [([Class =>] CLASS_NAME)]
11517 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
11519 when Pragma_Export_Valued_Procedure =>
11520 Export_Valued_Procedure : declare
11521 Args : Args_List (1 .. 4);
11522 Names : constant Name_List (1 .. 4) := (
11525 Name_Parameter_Types,
11528 Internal : Node_Id renames Args (1);
11529 External : Node_Id renames Args (2);
11530 Parameter_Types : Node_Id renames Args (3);
11531 Mechanism : Node_Id renames Args (4);
11535 Gather_Associations (Names, Args);
11536 Process_Extended_Import_Export_Subprogram_Pragma (
11537 Arg_Internal => Internal,
11538 Arg_External => External,
11539 Arg_Parameter_Types => Parameter_Types,
11540 Arg_Mechanism => Mechanism);
11541 end Export_Valued_Procedure;
11543 -------------------
11544 -- Extend_System --
11545 -------------------
11547 -- pragma Extend_System ([Name =>] Identifier);
11549 when Pragma_Extend_System => Extend_System : declare
11552 Check_Valid_Configuration_Pragma;
11553 Check_Arg_Count (1);
11554 Check_Optional_Identifier (Arg1, Name_Name);
11555 Check_Arg_Is_Identifier (Arg1);
11557 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
11560 and then Name_Buffer (1 .. 4) = "aux_"
11562 if Present (System_Extend_Pragma_Arg) then
11563 if Chars (Get_Pragma_Arg (Arg1)) =
11564 Chars (Expression (System_Extend_Pragma_Arg))
11568 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
11569 Error_Pragma ("pragma% conflicts with that #");
11573 System_Extend_Pragma_Arg := Arg1;
11575 if not GNAT_Mode then
11576 System_Extend_Unit := Arg1;
11580 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
11584 ------------------------
11585 -- Extensions_Allowed --
11586 ------------------------
11588 -- pragma Extensions_Allowed (ON | OFF);
11590 when Pragma_Extensions_Allowed =>
11592 Check_Arg_Count (1);
11593 Check_No_Identifiers;
11594 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
11596 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
11597 Extensions_Allowed := True;
11598 Ada_Version := Ada_Version_Type'Last;
11601 Extensions_Allowed := False;
11602 Ada_Version := Ada_Version_Explicit;
11603 Ada_Version_Pragma := Empty;
11610 -- pragma External (
11611 -- [ Convention =>] convention_IDENTIFIER,
11612 -- [ Entity =>] local_NAME
11613 -- [, [External_Name =>] static_string_EXPRESSION ]
11614 -- [, [Link_Name =>] static_string_EXPRESSION ]);
11616 when Pragma_External => External : declare
11617 Def_Id : Entity_Id;
11620 pragma Warnings (Off, C);
11627 Name_External_Name,
11629 Check_At_Least_N_Arguments (2);
11630 Check_At_Most_N_Arguments (4);
11631 Process_Convention (C, Def_Id);
11632 Note_Possible_Modification
11633 (Get_Pragma_Arg (Arg2), Sure => False);
11634 Process_Interface_Name (Def_Id, Arg3, Arg4);
11635 Set_Exported (Def_Id, Arg2);
11638 --------------------------
11639 -- External_Name_Casing --
11640 --------------------------
11642 -- pragma External_Name_Casing (
11643 -- UPPERCASE | LOWERCASE
11644 -- [, AS_IS | UPPERCASE | LOWERCASE]);
11646 when Pragma_External_Name_Casing => External_Name_Casing : declare
11649 Check_No_Identifiers;
11651 if Arg_Count = 2 then
11652 Check_Arg_Is_One_Of
11653 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
11655 case Chars (Get_Pragma_Arg (Arg2)) is
11657 Opt.External_Name_Exp_Casing := As_Is;
11659 when Name_Uppercase =>
11660 Opt.External_Name_Exp_Casing := Uppercase;
11662 when Name_Lowercase =>
11663 Opt.External_Name_Exp_Casing := Lowercase;
11670 Check_Arg_Count (1);
11673 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
11675 case Chars (Get_Pragma_Arg (Arg1)) is
11676 when Name_Uppercase =>
11677 Opt.External_Name_Imp_Casing := Uppercase;
11679 when Name_Lowercase =>
11680 Opt.External_Name_Imp_Casing := Lowercase;
11685 end External_Name_Casing;
11691 -- pragma Fast_Math;
11693 when Pragma_Fast_Math =>
11695 Check_No_Identifiers;
11696 Check_Valid_Configuration_Pragma;
11699 --------------------------
11700 -- Favor_Top_Level --
11701 --------------------------
11703 -- pragma Favor_Top_Level (type_NAME);
11705 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
11706 Named_Entity : Entity_Id;
11710 Check_No_Identifiers;
11711 Check_Arg_Count (1);
11712 Check_Arg_Is_Local_Name (Arg1);
11713 Named_Entity := Entity (Get_Pragma_Arg (Arg1));
11715 -- If it's an access-to-subprogram type (in particular, not a
11716 -- subtype), set the flag on that type.
11718 if Is_Access_Subprogram_Type (Named_Entity) then
11719 Set_Can_Use_Internal_Rep (Named_Entity, False);
11721 -- Otherwise it's an error (name denotes the wrong sort of entity)
11725 ("access-to-subprogram type expected",
11726 Get_Pragma_Arg (Arg1));
11728 end Favor_Top_Level;
11730 ---------------------------
11731 -- Finalize_Storage_Only --
11732 ---------------------------
11734 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
11736 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
11737 Assoc : constant Node_Id := Arg1;
11738 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
11743 Check_No_Identifiers;
11744 Check_Arg_Count (1);
11745 Check_Arg_Is_Local_Name (Arg1);
11747 Find_Type (Type_Id);
11748 Typ := Entity (Type_Id);
11751 or else Rep_Item_Too_Early (Typ, N)
11755 Typ := Underlying_Type (Typ);
11758 if not Is_Controlled (Typ) then
11759 Error_Pragma ("pragma% must specify controlled type");
11762 Check_First_Subtype (Arg1);
11764 if Finalize_Storage_Only (Typ) then
11765 Error_Pragma ("duplicate pragma%, only one allowed");
11767 elsif not Rep_Item_Too_Late (Typ, N) then
11768 Set_Finalize_Storage_Only (Base_Type (Typ), True);
11770 end Finalize_Storage;
11772 --------------------------
11773 -- Float_Representation --
11774 --------------------------
11776 -- pragma Float_Representation (FLOAT_REP[, float_type_LOCAL_NAME]);
11778 -- FLOAT_REP ::= VAX_Float | IEEE_Float
11780 when Pragma_Float_Representation => Float_Representation : declare
11788 if Arg_Count = 1 then
11789 Check_Valid_Configuration_Pragma;
11791 Check_Arg_Count (2);
11792 Check_Optional_Identifier (Arg2, Name_Entity);
11793 Check_Arg_Is_Local_Name (Arg2);
11796 Check_No_Identifier (Arg1);
11797 Check_Arg_Is_One_Of (Arg1, Name_VAX_Float, Name_IEEE_Float);
11799 if not OpenVMS_On_Target then
11800 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
11802 ("??pragma% ignored (applies only to Open'V'M'S)");
11808 -- One argument case
11810 if Arg_Count = 1 then
11811 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
11812 if Opt.Float_Format = 'I' then
11813 Error_Pragma ("'I'E'E'E format previously specified");
11816 Opt.Float_Format := 'V';
11819 if Opt.Float_Format = 'V' then
11820 Error_Pragma ("'V'A'X format previously specified");
11823 Opt.Float_Format := 'I';
11826 Set_Standard_Fpt_Formats;
11828 -- Two argument case
11831 Argx := Get_Pragma_Arg (Arg2);
11833 if not Is_Entity_Name (Argx)
11834 or else not Is_Floating_Point_Type (Entity (Argx))
11837 ("second argument of% pragma must be floating-point type",
11841 Ent := Entity (Argx);
11842 Digs := UI_To_Int (Digits_Value (Ent));
11844 -- Two arguments, VAX_Float case
11846 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
11848 when 6 => Set_F_Float (Ent);
11849 when 9 => Set_D_Float (Ent);
11850 when 15 => Set_G_Float (Ent);
11854 ("wrong digits value, must be 6,9 or 15", Arg2);
11857 -- Two arguments, IEEE_Float case
11861 when 6 => Set_IEEE_Short (Ent);
11862 when 15 => Set_IEEE_Long (Ent);
11866 ("wrong digits value, must be 6 or 15", Arg2);
11870 end Float_Representation;
11876 -- pragma Global (GLOBAL_SPECIFICATION)
11878 -- GLOBAL_SPECIFICATION ::=
11881 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
11883 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
11885 -- MODE_SELECTOR ::= Input | Output | In_Out | Contract_In
11886 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
11887 -- GLOBAL_ITEM ::= NAME
11889 when Pragma_Global => Global : declare
11890 Subp_Decl : Node_Id;
11891 Subp_Id : Entity_Id;
11896 Check_Arg_Count (1);
11898 -- Ensure the proper placement of the pragma. Global must be
11899 -- associated with a subprogram declaration or a body that acts
11902 Subp_Decl := Find_Related_Subprogram (N, Check_Duplicates => True);
11904 if Nkind (Subp_Decl) /= N_Subprogram_Declaration
11905 and then (Nkind (Subp_Decl) /= N_Subprogram_Body
11906 or else not Acts_As_Spec (Subp_Decl))
11912 Subp_Id := Defining_Unit_Name (Specification (Subp_Decl));
11914 -- When the aspect/pragma appears on a subprogram body, perform
11915 -- the full analysis now.
11917 if Nkind (Subp_Decl) = N_Subprogram_Body then
11918 Analyze_Global_In_Decl_Part (N);
11920 -- When Global applies to a subprogram compilation unit, the
11921 -- corresponding pragma is placed after the unit's declaration
11922 -- node and needs to be analyzed immediately.
11924 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration
11925 and then Nkind (Parent (Subp_Decl)) = N_Compilation_Unit
11927 Analyze_Global_In_Decl_Part (N);
11930 -- Chain the pragma on the contract for further processing
11932 Add_Contract_Item (N, Subp_Id);
11939 -- pragma Ident (static_string_EXPRESSION)
11941 -- Note: pragma Comment shares this processing. Pragma Comment is
11942 -- identical to Ident, except that the restriction of the argument to
11943 -- 31 characters and the placement restrictions are not enforced for
11946 when Pragma_Ident | Pragma_Comment => Ident : declare
11951 Check_Arg_Count (1);
11952 Check_No_Identifiers;
11953 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
11956 -- For pragma Ident, preserve DEC compatibility by requiring the
11957 -- pragma to appear in a declarative part or package spec.
11959 if Prag_Id = Pragma_Ident then
11960 Check_Is_In_Decl_Part_Or_Package_Spec;
11963 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
11970 GP := Parent (Parent (N));
11972 if Nkind_In (GP, N_Package_Declaration,
11973 N_Generic_Package_Declaration)
11978 -- If we have a compilation unit, then record the ident value,
11979 -- checking for improper duplication.
11981 if Nkind (GP) = N_Compilation_Unit then
11982 CS := Ident_String (Current_Sem_Unit);
11984 if Present (CS) then
11986 -- For Ident, we do not permit multiple instances
11988 if Prag_Id = Pragma_Ident then
11989 Error_Pragma ("duplicate% pragma not permitted");
11991 -- For Comment, we concatenate the string, unless we want
11992 -- to preserve the tree structure for ASIS.
11994 elsif not ASIS_Mode then
11995 Start_String (Strval (CS));
11996 Store_String_Char (' ');
11997 Store_String_Chars (Strval (Str));
11998 Set_Strval (CS, End_String);
12002 -- In VMS, the effect of IDENT is achieved by passing
12003 -- --identification=name as a --for-linker switch.
12005 if OpenVMS_On_Target then
12008 ("--for-linker=--identification=");
12009 String_To_Name_Buffer (Strval (Str));
12010 Store_String_Chars (Name_Buffer (1 .. Name_Len));
12012 -- Only the last processed IDENT is saved. The main
12013 -- purpose is so an IDENT associated with a main
12014 -- procedure will be used in preference to an IDENT
12015 -- associated with a with'd package.
12017 Replace_Linker_Option_String
12018 (End_String, "--for-linker=--identification=");
12021 Set_Ident_String (Current_Sem_Unit, Str);
12024 -- For subunits, we just ignore the Ident, since in GNAT these
12025 -- are not separate object files, and hence not separate units
12026 -- in the unit table.
12028 elsif Nkind (GP) = N_Subunit then
12031 -- Otherwise we have a misplaced pragma Ident, but we ignore
12032 -- this if we are in an instantiation, since it comes from
12033 -- a generic, and has no relevance to the instantiation.
12035 elsif Prag_Id = Pragma_Ident then
12036 if Instantiation_Location (Loc) = No_Location then
12037 Error_Pragma ("pragma% only allowed at outer level");
12043 ----------------------------
12044 -- Implementation_Defined --
12045 ----------------------------
12047 -- pragma Implementation_Defined (local_NAME);
12049 -- Marks previously declared entity as implementation defined. For
12050 -- an overloaded entity, applies to the most recent homonym.
12052 -- pragma Implementation_Defined;
12054 -- The form with no arguments appears anywhere within a scope, most
12055 -- typically a package spec, and indicates that all entities that are
12056 -- defined within the package spec are Implementation_Defined.
12058 when Pragma_Implementation_Defined => Implementation_Defined : declare
12063 Check_No_Identifiers;
12065 -- Form with no arguments
12067 if Arg_Count = 0 then
12068 Set_Is_Implementation_Defined (Current_Scope);
12070 -- Form with one argument
12073 Check_Arg_Count (1);
12074 Check_Arg_Is_Local_Name (Arg1);
12075 Ent := Entity (Get_Pragma_Arg (Arg1));
12076 Set_Is_Implementation_Defined (Ent);
12078 end Implementation_Defined;
12084 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
12086 -- IMPLEMENTATION_KIND ::=
12087 -- By_Entry | By_Protected_Procedure | By_Any | Optional
12089 -- "By_Any" and "Optional" are treated as synonyms in order to
12090 -- support Ada 2012 aspect Synchronization.
12092 when Pragma_Implemented => Implemented : declare
12093 Proc_Id : Entity_Id;
12098 Check_Arg_Count (2);
12099 Check_No_Identifiers;
12100 Check_Arg_Is_Identifier (Arg1);
12101 Check_Arg_Is_Local_Name (Arg1);
12102 Check_Arg_Is_One_Of (Arg2,
12105 Name_By_Protected_Procedure,
12108 -- Extract the name of the local procedure
12110 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
12112 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
12113 -- primitive procedure of a synchronized tagged type.
12115 if Ekind (Proc_Id) = E_Procedure
12116 and then Is_Primitive (Proc_Id)
12117 and then Present (First_Formal (Proc_Id))
12119 Typ := Etype (First_Formal (Proc_Id));
12121 if Is_Tagged_Type (Typ)
12124 -- Check for a protected, a synchronized or a task interface
12126 ((Is_Interface (Typ)
12127 and then Is_Synchronized_Interface (Typ))
12129 -- Check for a protected type or a task type that implements
12133 (Is_Concurrent_Record_Type (Typ)
12134 and then Present (Interfaces (Typ)))
12136 -- Check for a private record extension with keyword
12140 (Ekind_In (Typ, E_Record_Type_With_Private,
12141 E_Record_Subtype_With_Private)
12142 and then Synchronized_Present (Parent (Typ))))
12147 ("controlling formal must be of synchronized tagged type",
12152 -- Procedures declared inside a protected type must be accepted
12154 elsif Ekind (Proc_Id) = E_Procedure
12155 and then Is_Protected_Type (Scope (Proc_Id))
12159 -- The first argument is not a primitive procedure
12163 ("pragma % must be applied to a primitive procedure", Arg1);
12167 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
12168 -- By_Protected_Procedure to the primitive procedure of a task
12171 if Chars (Arg2) = Name_By_Protected_Procedure
12172 and then Is_Interface (Typ)
12173 and then Is_Task_Interface (Typ)
12176 ("implementation kind By_Protected_Procedure cannot be "
12177 & "applied to a task interface primitive", Arg2);
12181 Record_Rep_Item (Proc_Id, N);
12184 ----------------------
12185 -- Implicit_Packing --
12186 ----------------------
12188 -- pragma Implicit_Packing;
12190 when Pragma_Implicit_Packing =>
12192 Check_Arg_Count (0);
12193 Implicit_Packing := True;
12200 -- [Convention =>] convention_IDENTIFIER,
12201 -- [Entity =>] local_NAME
12202 -- [, [External_Name =>] static_string_EXPRESSION ]
12203 -- [, [Link_Name =>] static_string_EXPRESSION ]);
12205 when Pragma_Import =>
12206 Check_Ada_83_Warning;
12210 Name_External_Name,
12213 Check_At_Least_N_Arguments (2);
12214 Check_At_Most_N_Arguments (4);
12215 Process_Import_Or_Interface;
12217 ----------------------
12218 -- Import_Exception --
12219 ----------------------
12221 -- pragma Import_Exception (
12222 -- [Internal =>] LOCAL_NAME
12223 -- [, [External =>] EXTERNAL_SYMBOL]
12224 -- [, [Form =>] Ada | VMS]
12225 -- [, [Code =>] static_integer_EXPRESSION]);
12227 when Pragma_Import_Exception => Import_Exception : declare
12228 Args : Args_List (1 .. 4);
12229 Names : constant Name_List (1 .. 4) := (
12235 Internal : Node_Id renames Args (1);
12236 External : Node_Id renames Args (2);
12237 Form : Node_Id renames Args (3);
12238 Code : Node_Id renames Args (4);
12242 Gather_Associations (Names, Args);
12244 if Present (External) and then Present (Code) then
12246 ("cannot give both External and Code options for pragma%");
12249 Process_Extended_Import_Export_Exception_Pragma (
12250 Arg_Internal => Internal,
12251 Arg_External => External,
12255 if not Is_VMS_Exception (Entity (Internal)) then
12256 Set_Imported (Entity (Internal));
12258 end Import_Exception;
12260 ---------------------
12261 -- Import_Function --
12262 ---------------------
12264 -- pragma Import_Function (
12265 -- [Internal =>] LOCAL_NAME,
12266 -- [, [External =>] EXTERNAL_SYMBOL]
12267 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
12268 -- [, [Result_Type =>] SUBTYPE_MARK]
12269 -- [, [Mechanism =>] MECHANISM]
12270 -- [, [Result_Mechanism =>] MECHANISM_NAME]
12271 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
12273 -- EXTERNAL_SYMBOL ::=
12275 -- | static_string_EXPRESSION
12277 -- PARAMETER_TYPES ::=
12279 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
12281 -- TYPE_DESIGNATOR ::=
12283 -- | subtype_Name ' Access
12287 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
12289 -- MECHANISM_ASSOCIATION ::=
12290 -- [formal_parameter_NAME =>] MECHANISM_NAME
12292 -- MECHANISM_NAME ::=
12295 -- | Descriptor [([Class =>] CLASS_NAME)]
12297 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
12299 when Pragma_Import_Function => Import_Function : declare
12300 Args : Args_List (1 .. 7);
12301 Names : constant Name_List (1 .. 7) := (
12304 Name_Parameter_Types,
12307 Name_Result_Mechanism,
12308 Name_First_Optional_Parameter);
12310 Internal : Node_Id renames Args (1);
12311 External : Node_Id renames Args (2);
12312 Parameter_Types : Node_Id renames Args (3);
12313 Result_Type : Node_Id renames Args (4);
12314 Mechanism : Node_Id renames Args (5);
12315 Result_Mechanism : Node_Id renames Args (6);
12316 First_Optional_Parameter : Node_Id renames Args (7);
12320 Gather_Associations (Names, Args);
12321 Process_Extended_Import_Export_Subprogram_Pragma (
12322 Arg_Internal => Internal,
12323 Arg_External => External,
12324 Arg_Parameter_Types => Parameter_Types,
12325 Arg_Result_Type => Result_Type,
12326 Arg_Mechanism => Mechanism,
12327 Arg_Result_Mechanism => Result_Mechanism,
12328 Arg_First_Optional_Parameter => First_Optional_Parameter);
12329 end Import_Function;
12331 -------------------
12332 -- Import_Object --
12333 -------------------
12335 -- pragma Import_Object (
12336 -- [Internal =>] LOCAL_NAME
12337 -- [, [External =>] EXTERNAL_SYMBOL]
12338 -- [, [Size =>] EXTERNAL_SYMBOL]);
12340 -- EXTERNAL_SYMBOL ::=
12342 -- | static_string_EXPRESSION
12344 when Pragma_Import_Object => Import_Object : declare
12345 Args : Args_List (1 .. 3);
12346 Names : constant Name_List (1 .. 3) := (
12351 Internal : Node_Id renames Args (1);
12352 External : Node_Id renames Args (2);
12353 Size : Node_Id renames Args (3);
12357 Gather_Associations (Names, Args);
12358 Process_Extended_Import_Export_Object_Pragma (
12359 Arg_Internal => Internal,
12360 Arg_External => External,
12364 ----------------------
12365 -- Import_Procedure --
12366 ----------------------
12368 -- pragma Import_Procedure (
12369 -- [Internal =>] LOCAL_NAME
12370 -- [, [External =>] EXTERNAL_SYMBOL]
12371 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
12372 -- [, [Mechanism =>] MECHANISM]
12373 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
12375 -- EXTERNAL_SYMBOL ::=
12377 -- | static_string_EXPRESSION
12379 -- PARAMETER_TYPES ::=
12381 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
12383 -- TYPE_DESIGNATOR ::=
12385 -- | subtype_Name ' Access
12389 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
12391 -- MECHANISM_ASSOCIATION ::=
12392 -- [formal_parameter_NAME =>] MECHANISM_NAME
12394 -- MECHANISM_NAME ::=
12397 -- | Descriptor [([Class =>] CLASS_NAME)]
12399 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
12401 when Pragma_Import_Procedure => Import_Procedure : declare
12402 Args : Args_List (1 .. 5);
12403 Names : constant Name_List (1 .. 5) := (
12406 Name_Parameter_Types,
12408 Name_First_Optional_Parameter);
12410 Internal : Node_Id renames Args (1);
12411 External : Node_Id renames Args (2);
12412 Parameter_Types : Node_Id renames Args (3);
12413 Mechanism : Node_Id renames Args (4);
12414 First_Optional_Parameter : Node_Id renames Args (5);
12418 Gather_Associations (Names, Args);
12419 Process_Extended_Import_Export_Subprogram_Pragma (
12420 Arg_Internal => Internal,
12421 Arg_External => External,
12422 Arg_Parameter_Types => Parameter_Types,
12423 Arg_Mechanism => Mechanism,
12424 Arg_First_Optional_Parameter => First_Optional_Parameter);
12425 end Import_Procedure;
12427 -----------------------------
12428 -- Import_Valued_Procedure --
12429 -----------------------------
12431 -- pragma Import_Valued_Procedure (
12432 -- [Internal =>] LOCAL_NAME
12433 -- [, [External =>] EXTERNAL_SYMBOL]
12434 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
12435 -- [, [Mechanism =>] MECHANISM]
12436 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
12438 -- EXTERNAL_SYMBOL ::=
12440 -- | static_string_EXPRESSION
12442 -- PARAMETER_TYPES ::=
12444 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
12446 -- TYPE_DESIGNATOR ::=
12448 -- | subtype_Name ' Access
12452 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
12454 -- MECHANISM_ASSOCIATION ::=
12455 -- [formal_parameter_NAME =>] MECHANISM_NAME
12457 -- MECHANISM_NAME ::=
12460 -- | Descriptor [([Class =>] CLASS_NAME)]
12462 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
12464 when Pragma_Import_Valued_Procedure =>
12465 Import_Valued_Procedure : declare
12466 Args : Args_List (1 .. 5);
12467 Names : constant Name_List (1 .. 5) := (
12470 Name_Parameter_Types,
12472 Name_First_Optional_Parameter);
12474 Internal : Node_Id renames Args (1);
12475 External : Node_Id renames Args (2);
12476 Parameter_Types : Node_Id renames Args (3);
12477 Mechanism : Node_Id renames Args (4);
12478 First_Optional_Parameter : Node_Id renames Args (5);
12482 Gather_Associations (Names, Args);
12483 Process_Extended_Import_Export_Subprogram_Pragma (
12484 Arg_Internal => Internal,
12485 Arg_External => External,
12486 Arg_Parameter_Types => Parameter_Types,
12487 Arg_Mechanism => Mechanism,
12488 Arg_First_Optional_Parameter => First_Optional_Parameter);
12489 end Import_Valued_Procedure;
12495 -- pragma Independent (LOCAL_NAME);
12497 when Pragma_Independent => Independent : declare
12504 Check_Ada_83_Warning;
12506 Check_No_Identifiers;
12507 Check_Arg_Count (1);
12508 Check_Arg_Is_Local_Name (Arg1);
12509 E_Id := Get_Pragma_Arg (Arg1);
12511 if Etype (E_Id) = Any_Type then
12515 E := Entity (E_Id);
12516 D := Declaration_Node (E);
12519 -- Check duplicate before we chain ourselves!
12521 Check_Duplicate_Pragma (E);
12523 -- Check appropriate entity
12525 if Is_Type (E) then
12526 if Rep_Item_Too_Early (E, N)
12528 Rep_Item_Too_Late (E, N)
12532 Check_First_Subtype (Arg1);
12535 elsif K = N_Object_Declaration
12536 or else (K = N_Component_Declaration
12537 and then Original_Record_Component (E) = E)
12539 if Rep_Item_Too_Late (E, N) then
12545 ("inappropriate entity for pragma%", Arg1);
12548 Independence_Checks.Append ((N, E));
12551 ----------------------------
12552 -- Independent_Components --
12553 ----------------------------
12555 -- pragma Atomic_Components (array_LOCAL_NAME);
12557 -- This processing is shared by Volatile_Components
12559 when Pragma_Independent_Components => Independent_Components : declare
12566 Check_Ada_83_Warning;
12568 Check_No_Identifiers;
12569 Check_Arg_Count (1);
12570 Check_Arg_Is_Local_Name (Arg1);
12571 E_Id := Get_Pragma_Arg (Arg1);
12573 if Etype (E_Id) = Any_Type then
12577 E := Entity (E_Id);
12579 -- Check duplicate before we chain ourselves!
12581 Check_Duplicate_Pragma (E);
12583 -- Check appropriate entity
12585 if Rep_Item_Too_Early (E, N)
12587 Rep_Item_Too_Late (E, N)
12592 D := Declaration_Node (E);
12595 if K = N_Full_Type_Declaration
12596 and then (Is_Array_Type (E) or else Is_Record_Type (E))
12598 Independence_Checks.Append ((N, E));
12599 Set_Has_Independent_Components (Base_Type (E));
12601 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
12602 and then Nkind (D) = N_Object_Declaration
12603 and then Nkind (Object_Definition (D)) =
12604 N_Constrained_Array_Definition
12606 Independence_Checks.Append ((N, E));
12607 Set_Has_Independent_Components (E);
12610 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
12612 end Independent_Components;
12614 ------------------------
12615 -- Initialize_Scalars --
12616 ------------------------
12618 -- pragma Initialize_Scalars;
12620 when Pragma_Initialize_Scalars =>
12622 Check_Arg_Count (0);
12623 Check_Valid_Configuration_Pragma;
12624 Check_Restriction (No_Initialize_Scalars, N);
12626 -- Initialize_Scalars creates false positives in CodePeer, and
12627 -- incorrect negative results in SPARK mode, so ignore this pragma
12630 if not Restriction_Active (No_Initialize_Scalars)
12631 and then not (CodePeer_Mode or SPARK_Mode)
12633 Init_Or_Norm_Scalars := True;
12634 Initialize_Scalars := True;
12641 -- pragma Inline ( NAME {, NAME} );
12643 when Pragma_Inline =>
12645 -- Inline status is Enabled if inlining option is active
12647 if Inline_Active then
12648 Process_Inline (Enabled);
12650 Process_Inline (Disabled);
12653 -------------------
12654 -- Inline_Always --
12655 -------------------
12657 -- pragma Inline_Always ( NAME {, NAME} );
12659 when Pragma_Inline_Always =>
12662 -- Pragma always active unless in CodePeer or SPARK mode, since
12663 -- this causes walk order issues.
12665 if not (CodePeer_Mode or SPARK_Mode) then
12666 Process_Inline (Enabled);
12669 --------------------
12670 -- Inline_Generic --
12671 --------------------
12673 -- pragma Inline_Generic (NAME {, NAME});
12675 when Pragma_Inline_Generic =>
12677 Process_Generic_List;
12679 ----------------------
12680 -- Inspection_Point --
12681 ----------------------
12683 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
12685 when Pragma_Inspection_Point => Inspection_Point : declare
12690 if Arg_Count > 0 then
12693 Exp := Get_Pragma_Arg (Arg);
12696 if not Is_Entity_Name (Exp)
12697 or else not Is_Object (Entity (Exp))
12699 Error_Pragma_Arg ("object name required", Arg);
12703 exit when No (Arg);
12706 end Inspection_Point;
12712 -- pragma Interface (
12713 -- [ Convention =>] convention_IDENTIFIER,
12714 -- [ Entity =>] local_NAME
12715 -- [, [External_Name =>] static_string_EXPRESSION ]
12716 -- [, [Link_Name =>] static_string_EXPRESSION ]);
12718 when Pragma_Interface =>
12723 Name_External_Name,
12725 Check_At_Least_N_Arguments (2);
12726 Check_At_Most_N_Arguments (4);
12727 Process_Import_Or_Interface;
12729 -- In Ada 2005, the permission to use Interface (a reserved word)
12730 -- as a pragma name is considered an obsolescent feature, and this
12731 -- pragma was already obsolescent in Ada 95.
12733 if Ada_Version >= Ada_95 then
12735 (No_Obsolescent_Features, Pragma_Identifier (N));
12737 if Warn_On_Obsolescent_Feature then
12739 ("pragma Interface is an obsolescent feature?j?", N);
12741 ("|use pragma Import instead?j?", N);
12745 --------------------
12746 -- Interface_Name --
12747 --------------------
12749 -- pragma Interface_Name (
12750 -- [ Entity =>] local_NAME
12751 -- [,[External_Name =>] static_string_EXPRESSION ]
12752 -- [,[Link_Name =>] static_string_EXPRESSION ]);
12754 when Pragma_Interface_Name => Interface_Name : declare
12756 Def_Id : Entity_Id;
12757 Hom_Id : Entity_Id;
12763 ((Name_Entity, Name_External_Name, Name_Link_Name));
12764 Check_At_Least_N_Arguments (2);
12765 Check_At_Most_N_Arguments (3);
12766 Id := Get_Pragma_Arg (Arg1);
12769 -- This is obsolete from Ada 95 on, but it is an implementation
12770 -- defined pragma, so we do not consider that it violates the
12771 -- restriction (No_Obsolescent_Features).
12773 if Ada_Version >= Ada_95 then
12774 if Warn_On_Obsolescent_Feature then
12776 ("pragma Interface_Name is an obsolescent feature?j?", N);
12778 ("|use pragma Import instead?j?", N);
12782 if not Is_Entity_Name (Id) then
12784 ("first argument for pragma% must be entity name", Arg1);
12785 elsif Etype (Id) = Any_Type then
12788 Def_Id := Entity (Id);
12791 -- Special DEC-compatible processing for the object case, forces
12792 -- object to be imported.
12794 if Ekind (Def_Id) = E_Variable then
12795 Kill_Size_Check_Code (Def_Id);
12796 Note_Possible_Modification (Id, Sure => False);
12798 -- Initialization is not allowed for imported variable
12800 if Present (Expression (Parent (Def_Id)))
12801 and then Comes_From_Source (Expression (Parent (Def_Id)))
12803 Error_Msg_Sloc := Sloc (Def_Id);
12805 ("no initialization allowed for declaration of& #",
12809 -- For compatibility, support VADS usage of providing both
12810 -- pragmas Interface and Interface_Name to obtain the effect
12811 -- of a single Import pragma.
12813 if Is_Imported (Def_Id)
12814 and then Present (First_Rep_Item (Def_Id))
12815 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
12817 Pragma_Name (First_Rep_Item (Def_Id)) = Name_Interface
12821 Set_Imported (Def_Id);
12824 Set_Is_Public (Def_Id);
12825 Process_Interface_Name (Def_Id, Arg2, Arg3);
12828 -- Otherwise must be subprogram
12830 elsif not Is_Subprogram (Def_Id) then
12832 ("argument of pragma% is not subprogram", Arg1);
12835 Check_At_Most_N_Arguments (3);
12839 -- Loop through homonyms
12842 Def_Id := Get_Base_Subprogram (Hom_Id);
12844 if Is_Imported (Def_Id) then
12845 Process_Interface_Name (Def_Id, Arg2, Arg3);
12849 exit when From_Aspect_Specification (N);
12850 Hom_Id := Homonym (Hom_Id);
12852 exit when No (Hom_Id)
12853 or else Scope (Hom_Id) /= Current_Scope;
12858 ("argument of pragma% is not imported subprogram",
12862 end Interface_Name;
12864 -----------------------
12865 -- Interrupt_Handler --
12866 -----------------------
12868 -- pragma Interrupt_Handler (handler_NAME);
12870 when Pragma_Interrupt_Handler =>
12871 Check_Ada_83_Warning;
12872 Check_Arg_Count (1);
12873 Check_No_Identifiers;
12875 if No_Run_Time_Mode then
12876 Error_Msg_CRT ("Interrupt_Handler pragma", N);
12878 Check_Interrupt_Or_Attach_Handler;
12879 Process_Interrupt_Or_Attach_Handler;
12882 ------------------------
12883 -- Interrupt_Priority --
12884 ------------------------
12886 -- pragma Interrupt_Priority [(EXPRESSION)];
12888 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
12889 P : constant Node_Id := Parent (N);
12894 Check_Ada_83_Warning;
12896 if Arg_Count /= 0 then
12897 Arg := Get_Pragma_Arg (Arg1);
12898 Check_Arg_Count (1);
12899 Check_No_Identifiers;
12901 -- The expression must be analyzed in the special manner
12902 -- described in "Handling of Default and Per-Object
12903 -- Expressions" in sem.ads.
12905 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
12908 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
12913 Ent := Defining_Identifier (Parent (P));
12915 -- Check duplicate pragma before we chain the pragma in the Rep
12916 -- Item chain of Ent.
12918 Check_Duplicate_Pragma (Ent);
12919 Record_Rep_Item (Ent, N);
12921 end Interrupt_Priority;
12923 ---------------------
12924 -- Interrupt_State --
12925 ---------------------
12927 -- pragma Interrupt_State (
12928 -- [Name =>] INTERRUPT_ID,
12929 -- [State =>] INTERRUPT_STATE);
12931 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
12932 -- INTERRUPT_STATE => System | Runtime | User
12934 -- Note: if the interrupt id is given as an identifier, then it must
12935 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
12936 -- given as a static integer expression which must be in the range of
12937 -- Ada.Interrupts.Interrupt_ID.
12939 when Pragma_Interrupt_State => Interrupt_State : declare
12941 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
12942 -- This is the entity Ada.Interrupts.Interrupt_ID;
12944 State_Type : Character;
12945 -- Set to 's'/'r'/'u' for System/Runtime/User
12948 -- Index to entry in Interrupt_States table
12951 -- Value of interrupt
12953 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
12954 -- The first argument to the pragma
12956 Int_Ent : Entity_Id;
12957 -- Interrupt entity in Ada.Interrupts.Names
12961 Check_Arg_Order ((Name_Name, Name_State));
12962 Check_Arg_Count (2);
12964 Check_Optional_Identifier (Arg1, Name_Name);
12965 Check_Optional_Identifier (Arg2, Name_State);
12966 Check_Arg_Is_Identifier (Arg2);
12968 -- First argument is identifier
12970 if Nkind (Arg1X) = N_Identifier then
12972 -- Search list of names in Ada.Interrupts.Names
12974 Int_Ent := First_Entity (RTE (RE_Names));
12976 if No (Int_Ent) then
12977 Error_Pragma_Arg ("invalid interrupt name", Arg1);
12979 elsif Chars (Int_Ent) = Chars (Arg1X) then
12980 Int_Val := Expr_Value (Constant_Value (Int_Ent));
12984 Next_Entity (Int_Ent);
12987 -- First argument is not an identifier, so it must be a static
12988 -- expression of type Ada.Interrupts.Interrupt_ID.
12991 Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
12992 Int_Val := Expr_Value (Arg1X);
12994 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
12996 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
12999 ("value not in range of type "
13000 & """Ada.Interrupts.Interrupt_'I'D""", Arg1);
13006 case Chars (Get_Pragma_Arg (Arg2)) is
13007 when Name_Runtime => State_Type := 'r';
13008 when Name_System => State_Type := 's';
13009 when Name_User => State_Type := 'u';
13012 Error_Pragma_Arg ("invalid interrupt state", Arg2);
13015 -- Check if entry is already stored
13017 IST_Num := Interrupt_States.First;
13019 -- If entry not found, add it
13021 if IST_Num > Interrupt_States.Last then
13022 Interrupt_States.Append
13023 ((Interrupt_Number => UI_To_Int (Int_Val),
13024 Interrupt_State => State_Type,
13025 Pragma_Loc => Loc));
13028 -- Case of entry for the same entry
13030 elsif Int_Val = Interrupt_States.Table (IST_Num).
13033 -- If state matches, done, no need to make redundant entry
13036 State_Type = Interrupt_States.Table (IST_Num).
13039 -- Otherwise if state does not match, error
13042 Interrupt_States.Table (IST_Num).Pragma_Loc;
13044 ("state conflicts with that given #", Arg2);
13048 IST_Num := IST_Num + 1;
13050 end Interrupt_State;
13056 -- pragma Invariant
13057 -- ([Entity =>] type_LOCAL_NAME,
13058 -- [Check =>] EXPRESSION
13059 -- [,[Message =>] String_Expression]);
13061 when Pragma_Invariant => Invariant : declare
13067 pragma Unreferenced (Discard);
13071 Check_At_Least_N_Arguments (2);
13072 Check_At_Most_N_Arguments (3);
13073 Check_Optional_Identifier (Arg1, Name_Entity);
13074 Check_Optional_Identifier (Arg2, Name_Check);
13076 if Arg_Count = 3 then
13077 Check_Optional_Identifier (Arg3, Name_Message);
13078 Check_Arg_Is_Static_Expression (Arg3, Standard_String);
13081 Check_Arg_Is_Local_Name (Arg1);
13083 Type_Id := Get_Pragma_Arg (Arg1);
13084 Find_Type (Type_Id);
13085 Typ := Entity (Type_Id);
13087 if Typ = Any_Type then
13090 -- An invariant must apply to a private type, or appear in the
13091 -- private part of a package spec and apply to a completion.
13093 elsif Ekind_In (Typ, E_Private_Type,
13094 E_Record_Type_With_Private,
13095 E_Limited_Private_Type)
13099 elsif In_Private_Part (Current_Scope)
13100 and then Has_Private_Declaration (Typ)
13104 elsif In_Private_Part (Current_Scope) then
13106 ("pragma% only allowed for private type declared in "
13107 & "visible part", Arg1);
13111 ("pragma% only allowed for private type", Arg1);
13114 -- Note that the type has at least one invariant, and also that
13115 -- it has inheritable invariants if we have Invariant'Class
13116 -- or Type_Invariant'Class. Build the corresponding invariant
13117 -- procedure declaration, so that calls to it can be generated
13118 -- before the body is built (e.g. within an expression function).
13120 PDecl := Build_Invariant_Procedure_Declaration (Typ);
13122 Insert_After (N, PDecl);
13125 if Class_Present (N) then
13126 Set_Has_Inheritable_Invariants (Typ);
13129 -- The remaining processing is simply to link the pragma on to
13130 -- the rep item chain, for processing when the type is frozen.
13131 -- This is accomplished by a call to Rep_Item_Too_Late.
13133 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
13136 ----------------------
13137 -- Java_Constructor --
13138 ----------------------
13140 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
13142 -- Also handles pragma CIL_Constructor
13144 when Pragma_CIL_Constructor | Pragma_Java_Constructor =>
13145 Java_Constructor : declare
13146 Convention : Convention_Id;
13147 Def_Id : Entity_Id;
13148 Hom_Id : Entity_Id;
13150 This_Formal : Entity_Id;
13154 Check_Arg_Count (1);
13155 Check_Optional_Identifier (Arg1, Name_Entity);
13156 Check_Arg_Is_Local_Name (Arg1);
13158 Id := Get_Pragma_Arg (Arg1);
13159 Find_Program_Unit_Name (Id);
13161 -- If we did not find the name, we are done
13163 if Etype (Id) = Any_Type then
13167 -- Check wrong use of pragma in wrong VM target
13169 if VM_Target = No_VM then
13172 elsif VM_Target = CLI_Target
13173 and then Prag_Id = Pragma_Java_Constructor
13175 Error_Pragma ("must use pragma 'C'I'L_'Constructor");
13177 elsif VM_Target = JVM_Target
13178 and then Prag_Id = Pragma_CIL_Constructor
13180 Error_Pragma ("must use pragma 'Java_'Constructor");
13184 when Pragma_CIL_Constructor => Convention := Convention_CIL;
13185 when Pragma_Java_Constructor => Convention := Convention_Java;
13186 when others => null;
13189 Hom_Id := Entity (Id);
13191 -- Loop through homonyms
13194 Def_Id := Get_Base_Subprogram (Hom_Id);
13196 -- The constructor is required to be a function
13198 if Ekind (Def_Id) /= E_Function then
13199 if VM_Target = JVM_Target then
13201 ("pragma% requires function returning a 'Java access "
13205 ("pragma% requires function returning a 'C'I'L access "
13210 -- Check arguments: For tagged type the first formal must be
13211 -- named "this" and its type must be a named access type
13212 -- designating a class-wide tagged type that has convention
13213 -- CIL/Java. The first formal must also have a null default
13214 -- value. For example:
13216 -- type Typ is tagged ...
13217 -- type Ref is access all Typ;
13218 -- pragma Convention (CIL, Typ);
13220 -- function New_Typ (This : Ref) return Ref;
13221 -- function New_Typ (This : Ref; I : Integer) return Ref;
13222 -- pragma Cil_Constructor (New_Typ);
13224 -- Reason: The first formal must NOT be a primitive of the
13227 -- This rule also applies to constructors of delegates used
13228 -- to interface with standard target libraries. For example:
13230 -- type Delegate is access procedure ...
13231 -- pragma Import (CIL, Delegate, ...);
13233 -- function new_Delegate
13234 -- (This : Delegate := null; ... ) return Delegate;
13236 -- For value-types this rule does not apply.
13238 if not Is_Value_Type (Etype (Def_Id)) then
13239 if No (First_Formal (Def_Id)) then
13240 Error_Msg_Name_1 := Pname;
13241 Error_Msg_N ("% function must have parameters", Def_Id);
13245 -- In the JRE library we have several occurrences in which
13246 -- the "this" parameter is not the first formal.
13248 This_Formal := First_Formal (Def_Id);
13250 -- In the JRE library we have several occurrences in which
13251 -- the "this" parameter is not the first formal. Search for
13254 if VM_Target = JVM_Target then
13255 while Present (This_Formal)
13256 and then Get_Name_String (Chars (This_Formal)) /= "this"
13258 Next_Formal (This_Formal);
13261 if No (This_Formal) then
13262 This_Formal := First_Formal (Def_Id);
13266 -- Warning: The first parameter should be named "this".
13267 -- We temporarily allow it because we have the following
13268 -- case in the Java runtime (file s-osinte.ads) ???
13270 -- function new_Thread
13271 -- (Self_Id : System.Address) return Thread_Id;
13272 -- pragma Java_Constructor (new_Thread);
13274 if VM_Target = JVM_Target
13275 and then Get_Name_String (Chars (First_Formal (Def_Id)))
13277 and then Etype (First_Formal (Def_Id)) = RTE (RE_Address)
13281 elsif Get_Name_String (Chars (This_Formal)) /= "this" then
13282 Error_Msg_Name_1 := Pname;
13284 ("first formal of % function must be named `this`",
13285 Parent (This_Formal));
13287 elsif not Is_Access_Type (Etype (This_Formal)) then
13288 Error_Msg_Name_1 := Pname;
13290 ("first formal of % function must be an access type",
13291 Parameter_Type (Parent (This_Formal)));
13293 -- For delegates the type of the first formal must be a
13294 -- named access-to-subprogram type (see previous example)
13296 elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type
13297 and then Ekind (Etype (This_Formal))
13298 /= E_Access_Subprogram_Type
13300 Error_Msg_Name_1 := Pname;
13302 ("first formal of % function must be a named access "
13303 & "to subprogram type",
13304 Parameter_Type (Parent (This_Formal)));
13306 -- Warning: We should reject anonymous access types because
13307 -- the constructor must not be handled as a primitive of the
13308 -- tagged type. We temporarily allow it because this profile
13309 -- is currently generated by cil2ada???
13311 elsif Ekind (Etype (Def_Id)) /= E_Access_Subprogram_Type
13312 and then not Ekind_In (Etype (This_Formal),
13314 E_General_Access_Type,
13315 E_Anonymous_Access_Type)
13317 Error_Msg_Name_1 := Pname;
13319 ("first formal of % function must be a named access "
13320 & "type", Parameter_Type (Parent (This_Formal)));
13322 elsif Atree.Convention
13323 (Designated_Type (Etype (This_Formal))) /= Convention
13325 Error_Msg_Name_1 := Pname;
13327 if Convention = Convention_Java then
13329 ("pragma% requires convention 'Cil in designated "
13330 & "type", Parameter_Type (Parent (This_Formal)));
13333 ("pragma% requires convention 'Java in designated "
13334 & "type", Parameter_Type (Parent (This_Formal)));
13337 elsif No (Expression (Parent (This_Formal)))
13338 or else Nkind (Expression (Parent (This_Formal))) /= N_Null
13340 Error_Msg_Name_1 := Pname;
13342 ("pragma% requires first formal with default `null`",
13343 Parameter_Type (Parent (This_Formal)));
13347 -- Check result type: the constructor must be a function
13349 -- * a value type (only allowed in the CIL compiler)
13350 -- * an access-to-subprogram type with convention Java/CIL
13351 -- * an access-type designating a type that has convention
13354 if Is_Value_Type (Etype (Def_Id)) then
13357 -- Access-to-subprogram type with convention Java/CIL
13359 elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type then
13360 if Atree.Convention (Etype (Def_Id)) /= Convention then
13361 if Convention = Convention_Java then
13363 ("pragma% requires function returning a 'Java "
13364 & "access type", Arg1);
13366 pragma Assert (Convention = Convention_CIL);
13368 ("pragma% requires function returning a 'C'I'L "
13369 & "access type", Arg1);
13373 elsif Ekind (Etype (Def_Id)) in Access_Kind then
13374 if not Ekind_In (Etype (Def_Id), E_Access_Type,
13375 E_General_Access_Type)
13378 (Designated_Type (Etype (Def_Id))) /= Convention
13380 Error_Msg_Name_1 := Pname;
13382 if Convention = Convention_Java then
13384 ("pragma% requires function returning a named "
13385 & "'Java access type", Arg1);
13388 ("pragma% requires function returning a named "
13389 & "'C'I'L access type", Arg1);
13394 Set_Is_Constructor (Def_Id);
13395 Set_Convention (Def_Id, Convention);
13396 Set_Is_Imported (Def_Id);
13398 exit when From_Aspect_Specification (N);
13399 Hom_Id := Homonym (Hom_Id);
13401 exit when No (Hom_Id) or else Scope (Hom_Id) /= Current_Scope;
13403 end Java_Constructor;
13405 ----------------------
13406 -- Java_Interface --
13407 ----------------------
13409 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
13411 when Pragma_Java_Interface => Java_Interface : declare
13417 Check_Arg_Count (1);
13418 Check_Optional_Identifier (Arg1, Name_Entity);
13419 Check_Arg_Is_Local_Name (Arg1);
13421 Arg := Get_Pragma_Arg (Arg1);
13424 if Etype (Arg) = Any_Type then
13428 if not Is_Entity_Name (Arg)
13429 or else not Is_Type (Entity (Arg))
13431 Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
13434 Typ := Underlying_Type (Entity (Arg));
13436 -- For now simply check some of the semantic constraints on the
13437 -- type. This currently leaves out some restrictions on interface
13438 -- types, namely that the parent type must be java.lang.Object.Typ
13439 -- and that all primitives of the type should be declared
13442 if not Is_Tagged_Type (Typ) or else not Is_Abstract_Type (Typ) then
13444 ("pragma% requires an abstract tagged type", Arg1);
13446 elsif not Has_Discriminants (Typ)
13447 or else Ekind (Etype (First_Discriminant (Typ)))
13448 /= E_Anonymous_Access_Type
13450 not Is_Class_Wide_Type
13451 (Designated_Type (Etype (First_Discriminant (Typ))))
13454 ("type must have a class-wide access discriminant", Arg1);
13456 end Java_Interface;
13462 -- pragma Keep_Names ([On => ] local_NAME);
13464 when Pragma_Keep_Names => Keep_Names : declare
13469 Check_Arg_Count (1);
13470 Check_Optional_Identifier (Arg1, Name_On);
13471 Check_Arg_Is_Local_Name (Arg1);
13473 Arg := Get_Pragma_Arg (Arg1);
13476 if Etype (Arg) = Any_Type then
13480 if not Is_Entity_Name (Arg)
13481 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
13484 ("pragma% requires a local enumeration type", Arg1);
13487 Set_Discard_Names (Entity (Arg), False);
13494 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
13496 when Pragma_License =>
13498 Check_Arg_Count (1);
13499 Check_No_Identifiers;
13500 Check_Valid_Configuration_Pragma;
13501 Check_Arg_Is_Identifier (Arg1);
13504 Sind : constant Source_File_Index :=
13505 Source_Index (Current_Sem_Unit);
13508 case Chars (Get_Pragma_Arg (Arg1)) is
13510 Set_License (Sind, GPL);
13512 when Name_Modified_GPL =>
13513 Set_License (Sind, Modified_GPL);
13515 when Name_Restricted =>
13516 Set_License (Sind, Restricted);
13518 when Name_Unrestricted =>
13519 Set_License (Sind, Unrestricted);
13522 Error_Pragma_Arg ("invalid license name", Arg1);
13530 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
13532 when Pragma_Link_With => Link_With : declare
13538 if Operating_Mode = Generate_Code
13539 and then In_Extended_Main_Source_Unit (N)
13541 Check_At_Least_N_Arguments (1);
13542 Check_No_Identifiers;
13543 Check_Is_In_Decl_Part_Or_Package_Spec;
13544 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
13548 while Present (Arg) loop
13549 Check_Arg_Is_Static_Expression (Arg, Standard_String);
13551 -- Store argument, converting sequences of spaces to a
13552 -- single null character (this is one of the differences
13553 -- in processing between Link_With and Linker_Options).
13555 Arg_Store : declare
13556 C : constant Char_Code := Get_Char_Code (' ');
13557 S : constant String_Id :=
13558 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
13559 L : constant Nat := String_Length (S);
13562 procedure Skip_Spaces;
13563 -- Advance F past any spaces
13569 procedure Skip_Spaces is
13571 while F <= L and then Get_String_Char (S, F) = C loop
13576 -- Start of processing for Arg_Store
13579 Skip_Spaces; -- skip leading spaces
13581 -- Loop through characters, changing any embedded
13582 -- sequence of spaces to a single null character (this
13583 -- is how Link_With/Linker_Options differ)
13586 if Get_String_Char (S, F) = C then
13589 Store_String_Char (ASCII.NUL);
13592 Store_String_Char (Get_String_Char (S, F));
13600 if Present (Arg) then
13601 Store_String_Char (ASCII.NUL);
13605 Store_Linker_Option_String (End_String);
13613 -- pragma Linker_Alias (
13614 -- [Entity =>] LOCAL_NAME
13615 -- [Target =>] static_string_EXPRESSION);
13617 when Pragma_Linker_Alias =>
13619 Check_Arg_Order ((Name_Entity, Name_Target));
13620 Check_Arg_Count (2);
13621 Check_Optional_Identifier (Arg1, Name_Entity);
13622 Check_Optional_Identifier (Arg2, Name_Target);
13623 Check_Arg_Is_Library_Level_Local_Name (Arg1);
13624 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
13626 -- The only processing required is to link this item on to the
13627 -- list of rep items for the given entity. This is accomplished
13628 -- by the call to Rep_Item_Too_Late (when no error is detected
13629 -- and False is returned).
13631 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
13634 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
13637 ------------------------
13638 -- Linker_Constructor --
13639 ------------------------
13641 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
13643 -- Code is shared with Linker_Destructor
13645 -----------------------
13646 -- Linker_Destructor --
13647 -----------------------
13649 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
13651 when Pragma_Linker_Constructor |
13652 Pragma_Linker_Destructor =>
13653 Linker_Constructor : declare
13659 Check_Arg_Count (1);
13660 Check_No_Identifiers;
13661 Check_Arg_Is_Local_Name (Arg1);
13662 Arg1_X := Get_Pragma_Arg (Arg1);
13664 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
13666 if not Is_Library_Level_Entity (Proc) then
13668 ("argument for pragma% must be library level entity", Arg1);
13671 -- The only processing required is to link this item on to the
13672 -- list of rep items for the given entity. This is accomplished
13673 -- by the call to Rep_Item_Too_Late (when no error is detected
13674 -- and False is returned).
13676 if Rep_Item_Too_Late (Proc, N) then
13679 Set_Has_Gigi_Rep_Item (Proc);
13681 end Linker_Constructor;
13683 --------------------
13684 -- Linker_Options --
13685 --------------------
13687 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
13689 when Pragma_Linker_Options => Linker_Options : declare
13693 Check_Ada_83_Warning;
13694 Check_No_Identifiers;
13695 Check_Arg_Count (1);
13696 Check_Is_In_Decl_Part_Or_Package_Spec;
13697 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
13698 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
13701 while Present (Arg) loop
13702 Check_Arg_Is_Static_Expression (Arg, Standard_String);
13703 Store_String_Char (ASCII.NUL);
13705 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
13709 if Operating_Mode = Generate_Code
13710 and then In_Extended_Main_Source_Unit (N)
13712 Store_Linker_Option_String (End_String);
13714 end Linker_Options;
13716 --------------------
13717 -- Linker_Section --
13718 --------------------
13720 -- pragma Linker_Section (
13721 -- [Entity =>] LOCAL_NAME
13722 -- [Section =>] static_string_EXPRESSION);
13724 when Pragma_Linker_Section =>
13726 Check_Arg_Order ((Name_Entity, Name_Section));
13727 Check_Arg_Count (2);
13728 Check_Optional_Identifier (Arg1, Name_Entity);
13729 Check_Optional_Identifier (Arg2, Name_Section);
13730 Check_Arg_Is_Library_Level_Local_Name (Arg1);
13731 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
13733 -- This pragma applies to objects and types
13735 if not Is_Object (Entity (Get_Pragma_Arg (Arg1)))
13736 and then not Is_Type (Entity (Get_Pragma_Arg (Arg1)))
13739 ("pragma% applies only to objects and types", Arg1);
13742 -- The only processing required is to link this item on to the
13743 -- list of rep items for the given entity. This is accomplished
13744 -- by the call to Rep_Item_Too_Late (when no error is detected
13745 -- and False is returned).
13747 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
13750 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
13757 -- pragma List (On | Off)
13759 -- There is nothing to do here, since we did all the processing for
13760 -- this pragma in Par.Prag (so that it works properly even in syntax
13763 when Pragma_List =>
13770 -- pragma Lock_Free [(Boolean_EXPRESSION)];
13772 when Pragma_Lock_Free => Lock_Free : declare
13773 P : constant Node_Id := Parent (N);
13779 Check_No_Identifiers;
13780 Check_At_Most_N_Arguments (1);
13782 -- Protected definition case
13784 if Nkind (P) = N_Protected_Definition then
13785 Ent := Defining_Identifier (Parent (P));
13789 if Arg_Count = 1 then
13790 Arg := Get_Pragma_Arg (Arg1);
13791 Val := Is_True (Static_Boolean (Arg));
13793 -- No arguments (expression is considered to be True)
13799 -- Check duplicate pragma before we chain the pragma in the Rep
13800 -- Item chain of Ent.
13802 Check_Duplicate_Pragma (Ent);
13803 Record_Rep_Item (Ent, N);
13804 Set_Uses_Lock_Free (Ent, Val);
13806 -- Anything else is incorrect placement
13813 --------------------
13814 -- Locking_Policy --
13815 --------------------
13817 -- pragma Locking_Policy (policy_IDENTIFIER);
13819 when Pragma_Locking_Policy => declare
13820 subtype LP_Range is Name_Id
13821 range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
13826 Check_Ada_83_Warning;
13827 Check_Arg_Count (1);
13828 Check_No_Identifiers;
13829 Check_Arg_Is_Locking_Policy (Arg1);
13830 Check_Valid_Configuration_Pragma;
13831 LP_Val := Chars (Get_Pragma_Arg (Arg1));
13834 when Name_Ceiling_Locking =>
13836 when Name_Inheritance_Locking =>
13838 when Name_Concurrent_Readers_Locking =>
13842 if Locking_Policy /= ' '
13843 and then Locking_Policy /= LP
13845 Error_Msg_Sloc := Locking_Policy_Sloc;
13846 Error_Pragma ("locking policy incompatible with policy#");
13848 -- Set new policy, but always preserve System_Location since we
13849 -- like the error message with the run time name.
13852 Locking_Policy := LP;
13854 if Locking_Policy_Sloc /= System_Location then
13855 Locking_Policy_Sloc := Loc;
13864 -- pragma Long_Float (D_Float | G_Float);
13866 when Pragma_Long_Float => Long_Float : declare
13869 Check_Valid_Configuration_Pragma;
13870 Check_Arg_Count (1);
13871 Check_No_Identifier (Arg1);
13872 Check_Arg_Is_One_Of (Arg1, Name_D_Float, Name_G_Float);
13874 if not OpenVMS_On_Target then
13875 Error_Pragma ("??pragma% ignored (applies only to Open'V'M'S)");
13880 if Chars (Get_Pragma_Arg (Arg1)) = Name_D_Float then
13881 if Opt.Float_Format_Long = 'G' then
13883 ("G_Float previously specified", Arg1);
13885 elsif Current_Sem_Unit /= Main_Unit
13886 and then Opt.Float_Format_Long /= 'D'
13889 ("main unit not compiled with pragma Long_Float (D_Float)",
13890 "\pragma% must be used consistently for whole partition",
13894 Opt.Float_Format_Long := 'D';
13897 -- G_Float case (this is the default, does not need overriding)
13900 if Opt.Float_Format_Long = 'D' then
13901 Error_Pragma ("D_Float previously specified");
13903 elsif Current_Sem_Unit /= Main_Unit
13904 and then Opt.Float_Format_Long /= 'G'
13907 ("main unit not compiled with pragma Long_Float (G_Float)",
13908 "\pragma% must be used consistently for whole partition",
13912 Opt.Float_Format_Long := 'G';
13916 Set_Standard_Fpt_Formats;
13919 -------------------
13920 -- Loop_Optimize --
13921 -------------------
13923 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
13925 -- OPTIMIZATION_HINT ::= No_Unroll | Unroll | No_Vector | Vector
13927 when Pragma_Loop_Optimize => Loop_Optimize : declare
13932 Check_At_Least_N_Arguments (1);
13933 Check_No_Identifiers;
13935 Hint := First (Pragma_Argument_Associations (N));
13936 while Present (Hint) loop
13937 Check_Arg_Is_One_Of (Hint,
13938 Name_No_Unroll, Name_Unroll, Name_No_Vector, Name_Vector);
13942 Check_Loop_Pragma_Placement;
13949 -- pragma Loop_Variant
13950 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
13952 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
13954 -- CHANGE_DIRECTION ::= Increases | Decreases
13956 when Pragma_Loop_Variant => Loop_Variant : declare
13961 Check_At_Least_N_Arguments (1);
13962 Check_Loop_Pragma_Placement;
13964 -- Process all increasing / decreasing expressions
13966 Variant := First (Pragma_Argument_Associations (N));
13967 while Present (Variant) loop
13968 if not Nam_In (Chars (Variant), Name_Decreases,
13971 Error_Pragma_Arg ("wrong change modifier", Variant);
13974 Preanalyze_Assert_Expression
13975 (Expression (Variant), Any_Discrete);
13981 -----------------------
13982 -- Machine_Attribute --
13983 -----------------------
13985 -- pragma Machine_Attribute (
13986 -- [Entity =>] LOCAL_NAME,
13987 -- [Attribute_Name =>] static_string_EXPRESSION
13988 -- [, [Info =>] static_EXPRESSION] );
13990 when Pragma_Machine_Attribute => Machine_Attribute : declare
13991 Def_Id : Entity_Id;
13995 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
13997 if Arg_Count = 3 then
13998 Check_Optional_Identifier (Arg3, Name_Info);
13999 Check_Arg_Is_Static_Expression (Arg3);
14001 Check_Arg_Count (2);
14004 Check_Optional_Identifier (Arg1, Name_Entity);
14005 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
14006 Check_Arg_Is_Local_Name (Arg1);
14007 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
14008 Def_Id := Entity (Get_Pragma_Arg (Arg1));
14010 if Is_Access_Type (Def_Id) then
14011 Def_Id := Designated_Type (Def_Id);
14014 if Rep_Item_Too_Early (Def_Id, N) then
14018 Def_Id := Underlying_Type (Def_Id);
14020 -- The only processing required is to link this item on to the
14021 -- list of rep items for the given entity. This is accomplished
14022 -- by the call to Rep_Item_Too_Late (when no error is detected
14023 -- and False is returned).
14025 if Rep_Item_Too_Late (Def_Id, N) then
14028 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
14030 end Machine_Attribute;
14037 -- (MAIN_OPTION [, MAIN_OPTION]);
14040 -- [STACK_SIZE =>] static_integer_EXPRESSION
14041 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
14042 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
14044 when Pragma_Main => Main : declare
14045 Args : Args_List (1 .. 3);
14046 Names : constant Name_List (1 .. 3) := (
14048 Name_Task_Stack_Size_Default,
14049 Name_Time_Slicing_Enabled);
14055 Gather_Associations (Names, Args);
14057 for J in 1 .. 2 loop
14058 if Present (Args (J)) then
14059 Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
14063 if Present (Args (3)) then
14064 Check_Arg_Is_Static_Expression (Args (3), Standard_Boolean);
14068 while Present (Nod) loop
14069 if Nkind (Nod) = N_Pragma
14070 and then Pragma_Name (Nod) = Name_Main
14072 Error_Msg_Name_1 := Pname;
14073 Error_Msg_N ("duplicate pragma% not permitted", Nod);
14084 -- pragma Main_Storage
14085 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
14087 -- MAIN_STORAGE_OPTION ::=
14088 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
14089 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
14091 when Pragma_Main_Storage => Main_Storage : declare
14092 Args : Args_List (1 .. 2);
14093 Names : constant Name_List (1 .. 2) := (
14094 Name_Working_Storage,
14101 Gather_Associations (Names, Args);
14103 for J in 1 .. 2 loop
14104 if Present (Args (J)) then
14105 Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
14109 Check_In_Main_Program;
14112 while Present (Nod) loop
14113 if Nkind (Nod) = N_Pragma
14114 and then Pragma_Name (Nod) = Name_Main_Storage
14116 Error_Msg_Name_1 := Pname;
14117 Error_Msg_N ("duplicate pragma% not permitted", Nod);
14128 -- pragma Memory_Size (NUMERIC_LITERAL)
14130 when Pragma_Memory_Size =>
14133 -- Memory size is simply ignored
14135 Check_No_Identifiers;
14136 Check_Arg_Count (1);
14137 Check_Arg_Is_Integer_Literal (Arg1);
14145 -- The only correct use of this pragma is on its own in a file, in
14146 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
14147 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
14148 -- check for a file containing nothing but a No_Body pragma). If we
14149 -- attempt to process it during normal semantics processing, it means
14150 -- it was misplaced.
14152 when Pragma_No_Body =>
14160 -- pragma No_Inline ( NAME {, NAME} );
14162 when Pragma_No_Inline =>
14164 Process_Inline (Suppressed);
14170 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
14172 when Pragma_No_Return => No_Return : declare
14180 Check_At_Least_N_Arguments (1);
14182 -- Loop through arguments of pragma
14185 while Present (Arg) loop
14186 Check_Arg_Is_Local_Name (Arg);
14187 Id := Get_Pragma_Arg (Arg);
14190 if not Is_Entity_Name (Id) then
14191 Error_Pragma_Arg ("entity name required", Arg);
14194 if Etype (Id) = Any_Type then
14198 -- Loop to find matching procedures
14203 and then Scope (E) = Current_Scope
14205 if Ekind_In (E, E_Procedure, E_Generic_Procedure) then
14208 -- Set flag on any alias as well
14210 if Is_Overloadable (E) and then Present (Alias (E)) then
14211 Set_No_Return (Alias (E));
14217 exit when From_Aspect_Specification (N);
14222 Error_Pragma_Arg ("no procedure & found for pragma%", Arg);
14233 -- pragma No_Run_Time;
14235 -- Note: this pragma is retained for backwards compatibility. See
14236 -- body of Rtsfind for full details on its handling.
14238 when Pragma_No_Run_Time =>
14240 Check_Valid_Configuration_Pragma;
14241 Check_Arg_Count (0);
14243 No_Run_Time_Mode := True;
14244 Configurable_Run_Time_Mode := True;
14246 -- Set Duration to 32 bits if word size is 32
14248 if Ttypes.System_Word_Size = 32 then
14249 Duration_32_Bits_On_Target := True;
14252 -- Set appropriate restrictions
14254 Set_Restriction (No_Finalization, N);
14255 Set_Restriction (No_Exception_Handlers, N);
14256 Set_Restriction (Max_Tasks, N, 0);
14257 Set_Restriction (No_Tasking, N);
14259 ------------------------
14260 -- No_Strict_Aliasing --
14261 ------------------------
14263 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
14265 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
14270 Check_At_Most_N_Arguments (1);
14272 if Arg_Count = 0 then
14273 Check_Valid_Configuration_Pragma;
14274 Opt.No_Strict_Aliasing := True;
14277 Check_Optional_Identifier (Arg2, Name_Entity);
14278 Check_Arg_Is_Local_Name (Arg1);
14279 E_Id := Entity (Get_Pragma_Arg (Arg1));
14281 if E_Id = Any_Type then
14283 elsif No (E_Id) or else not Is_Access_Type (E_Id) then
14284 Error_Pragma_Arg ("pragma% requires access type", Arg1);
14287 Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id));
14289 end No_Strict_Aliasing;
14291 -----------------------
14292 -- Normalize_Scalars --
14293 -----------------------
14295 -- pragma Normalize_Scalars;
14297 when Pragma_Normalize_Scalars =>
14298 Check_Ada_83_Warning;
14299 Check_Arg_Count (0);
14300 Check_Valid_Configuration_Pragma;
14302 -- Normalize_Scalars creates false positives in CodePeer, and
14303 -- incorrect negative results in SPARK mode, so ignore this pragma
14306 if not (CodePeer_Mode or SPARK_Mode) then
14307 Normalize_Scalars := True;
14308 Init_Or_Norm_Scalars := True;
14315 -- pragma Obsolescent;
14317 -- pragma Obsolescent (
14318 -- [Message =>] static_string_EXPRESSION
14319 -- [,[Version =>] Ada_05]]);
14321 -- pragma Obsolescent (
14322 -- [Entity =>] NAME
14323 -- [,[Message =>] static_string_EXPRESSION
14324 -- [,[Version =>] Ada_05]] );
14326 when Pragma_Obsolescent => Obsolescent : declare
14330 procedure Set_Obsolescent (E : Entity_Id);
14331 -- Given an entity Ent, mark it as obsolescent if appropriate
14333 ---------------------
14334 -- Set_Obsolescent --
14335 ---------------------
14337 procedure Set_Obsolescent (E : Entity_Id) is
14346 -- Entity name was given
14348 if Present (Ename) then
14350 -- If entity name matches, we are fine. Save entity in
14351 -- pragma argument, for ASIS use.
14353 if Chars (Ename) = Chars (Ent) then
14354 Set_Entity (Ename, Ent);
14355 Generate_Reference (Ent, Ename);
14357 -- If entity name does not match, only possibility is an
14358 -- enumeration literal from an enumeration type declaration.
14360 elsif Ekind (Ent) /= E_Enumeration_Type then
14362 ("pragma % entity name does not match declaration");
14365 Ent := First_Literal (E);
14369 ("pragma % entity name does not match any "
14370 & "enumeration literal");
14372 elsif Chars (Ent) = Chars (Ename) then
14373 Set_Entity (Ename, Ent);
14374 Generate_Reference (Ent, Ename);
14378 Ent := Next_Literal (Ent);
14384 -- Ent points to entity to be marked
14386 if Arg_Count >= 1 then
14388 -- Deal with static string argument
14390 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
14391 S := Strval (Get_Pragma_Arg (Arg1));
14393 for J in 1 .. String_Length (S) loop
14394 if not In_Character_Range (Get_String_Char (S, J)) then
14396 ("pragma% argument does not allow wide characters",
14401 Obsolescent_Warnings.Append
14402 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
14404 -- Check for Ada_05 parameter
14406 if Arg_Count /= 1 then
14407 Check_Arg_Count (2);
14410 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
14413 Check_Arg_Is_Identifier (Argx);
14415 if Chars (Argx) /= Name_Ada_05 then
14416 Error_Msg_Name_2 := Name_Ada_05;
14418 ("only allowed argument for pragma% is %", Argx);
14421 if Ada_Version_Explicit < Ada_2005
14422 or else not Warn_On_Ada_2005_Compatibility
14430 -- Set flag if pragma active
14433 Set_Is_Obsolescent (Ent);
14437 end Set_Obsolescent;
14439 -- Start of processing for pragma Obsolescent
14444 Check_At_Most_N_Arguments (3);
14446 -- See if first argument specifies an entity name
14450 (Chars (Arg1) = Name_Entity
14452 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
14454 N_Operator_Symbol))
14456 Ename := Get_Pragma_Arg (Arg1);
14458 -- Eliminate first argument, so we can share processing
14462 Arg_Count := Arg_Count - 1;
14464 -- No Entity name argument given
14470 if Arg_Count >= 1 then
14471 Check_Optional_Identifier (Arg1, Name_Message);
14473 if Arg_Count = 2 then
14474 Check_Optional_Identifier (Arg2, Name_Version);
14478 -- Get immediately preceding declaration
14481 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
14485 -- Cases where we do not follow anything other than another pragma
14489 -- First case: library level compilation unit declaration with
14490 -- the pragma immediately following the declaration.
14492 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
14494 (Defining_Entity (Unit (Parent (Parent (N)))));
14497 -- Case 2: library unit placement for package
14501 Ent : constant Entity_Id := Find_Lib_Unit_Name;
14503 if Is_Package_Or_Generic_Package (Ent) then
14504 Set_Obsolescent (Ent);
14510 -- Cases where we must follow a declaration
14513 if Nkind (Decl) not in N_Declaration
14514 and then Nkind (Decl) not in N_Later_Decl_Item
14515 and then Nkind (Decl) not in N_Generic_Declaration
14516 and then Nkind (Decl) not in N_Renaming_Declaration
14519 ("pragma% misplaced, "
14520 & "must immediately follow a declaration");
14523 Set_Obsolescent (Defining_Entity (Decl));
14533 -- pragma Optimize (Time | Space | Off);
14535 -- The actual check for optimize is done in Gigi. Note that this
14536 -- pragma does not actually change the optimization setting, it
14537 -- simply checks that it is consistent with the pragma.
14539 when Pragma_Optimize =>
14540 Check_No_Identifiers;
14541 Check_Arg_Count (1);
14542 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
14544 ------------------------
14545 -- Optimize_Alignment --
14546 ------------------------
14548 -- pragma Optimize_Alignment (Time | Space | Off);
14550 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
14552 Check_No_Identifiers;
14553 Check_Arg_Count (1);
14554 Check_Valid_Configuration_Pragma;
14557 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
14561 Opt.Optimize_Alignment := 'T';
14563 Opt.Optimize_Alignment := 'S';
14565 Opt.Optimize_Alignment := 'O';
14567 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
14571 -- Set indication that mode is set locally. If we are in fact in a
14572 -- configuration pragma file, this setting is harmless since the
14573 -- switch will get reset anyway at the start of each unit.
14575 Optimize_Alignment_Local := True;
14576 end Optimize_Alignment;
14582 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
14584 when Pragma_Ordered => Ordered : declare
14585 Assoc : constant Node_Id := Arg1;
14591 Check_No_Identifiers;
14592 Check_Arg_Count (1);
14593 Check_Arg_Is_Local_Name (Arg1);
14595 Type_Id := Get_Pragma_Arg (Assoc);
14596 Find_Type (Type_Id);
14597 Typ := Entity (Type_Id);
14599 if Typ = Any_Type then
14602 Typ := Underlying_Type (Typ);
14605 if not Is_Enumeration_Type (Typ) then
14606 Error_Pragma ("pragma% must specify enumeration type");
14609 Check_First_Subtype (Arg1);
14610 Set_Has_Pragma_Ordered (Base_Type (Typ));
14613 -------------------
14614 -- Overflow_Mode --
14615 -------------------
14617 -- pragma Overflow_Mode
14618 -- ([General => ] MODE [, [Assertions => ] MODE]);
14620 -- MODE := STRICT | MINIMIZED | ELIMINATED
14622 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
14623 -- since System.Bignums makes this assumption. This is true of nearly
14624 -- all (all?) targets.
14626 when Pragma_Overflow_Mode => Overflow_Mode : declare
14627 function Get_Overflow_Mode
14629 Arg : Node_Id) return Overflow_Mode_Type;
14630 -- Function to process one pragma argument, Arg. If an identifier
14631 -- is present, it must be Name. Mode type is returned if a valid
14632 -- argument exists, otherwise an error is signalled.
14634 -----------------------
14635 -- Get_Overflow_Mode --
14636 -----------------------
14638 function Get_Overflow_Mode
14640 Arg : Node_Id) return Overflow_Mode_Type
14642 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
14645 Check_Optional_Identifier (Arg, Name);
14646 Check_Arg_Is_Identifier (Argx);
14648 if Chars (Argx) = Name_Strict then
14651 elsif Chars (Argx) = Name_Minimized then
14654 elsif Chars (Argx) = Name_Eliminated then
14655 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then
14657 ("Eliminated not implemented on this target", Argx);
14663 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
14665 end Get_Overflow_Mode;
14667 -- Start of processing for Overflow_Mode
14671 Check_At_Least_N_Arguments (1);
14672 Check_At_Most_N_Arguments (2);
14674 -- Process first argument
14676 Scope_Suppress.Overflow_Mode_General :=
14677 Get_Overflow_Mode (Name_General, Arg1);
14679 -- Case of only one argument
14681 if Arg_Count = 1 then
14682 Scope_Suppress.Overflow_Mode_Assertions :=
14683 Scope_Suppress.Overflow_Mode_General;
14685 -- Case of two arguments present
14688 Scope_Suppress.Overflow_Mode_Assertions :=
14689 Get_Overflow_Mode (Name_Assertions, Arg2);
14693 --------------------------
14694 -- Overriding Renamings --
14695 --------------------------
14697 -- pragma Overriding_Renamings;
14699 when Pragma_Overriding_Renamings =>
14701 Check_Arg_Count (0);
14702 Check_Valid_Configuration_Pragma;
14703 Overriding_Renamings := True;
14709 -- pragma Pack (first_subtype_LOCAL_NAME);
14711 when Pragma_Pack => Pack : declare
14712 Assoc : constant Node_Id := Arg1;
14716 Ignore : Boolean := False;
14719 Check_No_Identifiers;
14720 Check_Arg_Count (1);
14721 Check_Arg_Is_Local_Name (Arg1);
14723 Type_Id := Get_Pragma_Arg (Assoc);
14724 Find_Type (Type_Id);
14725 Typ := Entity (Type_Id);
14728 or else Rep_Item_Too_Early (Typ, N)
14732 Typ := Underlying_Type (Typ);
14735 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
14736 Error_Pragma ("pragma% must specify array or record type");
14739 Check_First_Subtype (Arg1);
14740 Check_Duplicate_Pragma (Typ);
14744 if Is_Array_Type (Typ) then
14745 Ctyp := Component_Type (Typ);
14747 -- Ignore pack that does nothing
14749 if Known_Static_Esize (Ctyp)
14750 and then Known_Static_RM_Size (Ctyp)
14751 and then Esize (Ctyp) = RM_Size (Ctyp)
14752 and then Addressable (Esize (Ctyp))
14757 -- Process OK pragma Pack. Note that if there is a separate
14758 -- component clause present, the Pack will be cancelled. This
14759 -- processing is in Freeze.
14761 if not Rep_Item_Too_Late (Typ, N) then
14763 -- In the context of static code analysis, we do not need
14764 -- complex front-end expansions related to pragma Pack,
14765 -- so disable handling of pragma Pack in these cases.
14767 if CodePeer_Mode or SPARK_Mode then
14770 -- Don't attempt any packing for VM targets. We possibly
14771 -- could deal with some cases of array bit-packing, but we
14772 -- don't bother, since this is not a typical kind of
14773 -- representation in the VM context anyway (and would not
14774 -- for example work nicely with the debugger).
14776 elsif VM_Target /= No_VM then
14777 if not GNAT_Mode then
14779 ("??pragma% ignored in this configuration");
14782 -- Normal case where we do the pack action
14786 Set_Is_Packed (Base_Type (Typ));
14787 Set_Has_Non_Standard_Rep (Base_Type (Typ));
14790 Set_Has_Pragma_Pack (Base_Type (Typ));
14794 -- For record types, the pack is always effective
14796 else pragma Assert (Is_Record_Type (Typ));
14797 if not Rep_Item_Too_Late (Typ, N) then
14799 -- Ignore pack request with warning in VM mode (skip warning
14800 -- if we are compiling GNAT run time library).
14802 if VM_Target /= No_VM then
14803 if not GNAT_Mode then
14805 ("??pragma% ignored in this configuration");
14808 -- Normal case of pack request active
14811 Set_Is_Packed (Base_Type (Typ));
14812 Set_Has_Pragma_Pack (Base_Type (Typ));
14813 Set_Has_Non_Standard_Rep (Base_Type (Typ));
14825 -- There is nothing to do here, since we did all the processing for
14826 -- this pragma in Par.Prag (so that it works properly even in syntax
14829 when Pragma_Page =>
14832 ----------------------------------
14833 -- Partition_Elaboration_Policy --
14834 ----------------------------------
14836 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
14838 when Pragma_Partition_Elaboration_Policy => declare
14839 subtype PEP_Range is Name_Id
14840 range First_Partition_Elaboration_Policy_Name
14841 .. Last_Partition_Elaboration_Policy_Name;
14842 PEP_Val : PEP_Range;
14847 Check_Arg_Count (1);
14848 Check_No_Identifiers;
14849 Check_Arg_Is_Partition_Elaboration_Policy (Arg1);
14850 Check_Valid_Configuration_Pragma;
14851 PEP_Val := Chars (Get_Pragma_Arg (Arg1));
14854 when Name_Concurrent =>
14856 when Name_Sequential =>
14860 if Partition_Elaboration_Policy /= ' '
14861 and then Partition_Elaboration_Policy /= PEP
14863 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc;
14865 ("partition elaboration policy incompatible with policy#");
14867 -- Set new policy, but always preserve System_Location since we
14868 -- like the error message with the run time name.
14871 Partition_Elaboration_Policy := PEP;
14873 if Partition_Elaboration_Policy_Sloc /= System_Location then
14874 Partition_Elaboration_Policy_Sloc := Loc;
14883 -- pragma Passive [(PASSIVE_FORM)];
14885 -- PASSIVE_FORM ::= Semaphore | No
14887 when Pragma_Passive =>
14890 if Nkind (Parent (N)) /= N_Task_Definition then
14891 Error_Pragma ("pragma% must be within task definition");
14894 if Arg_Count /= 0 then
14895 Check_Arg_Count (1);
14896 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
14899 ----------------------------------
14900 -- Preelaborable_Initialization --
14901 ----------------------------------
14903 -- pragma Preelaborable_Initialization (DIRECT_NAME);
14905 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
14910 Check_Arg_Count (1);
14911 Check_No_Identifiers;
14912 Check_Arg_Is_Identifier (Arg1);
14913 Check_Arg_Is_Local_Name (Arg1);
14914 Check_First_Subtype (Arg1);
14915 Ent := Entity (Get_Pragma_Arg (Arg1));
14917 -- The pragma may come from an aspect on a private declaration,
14918 -- even if the freeze point at which this is analyzed in the
14919 -- private part after the full view.
14921 if Has_Private_Declaration (Ent)
14922 and then From_Aspect_Specification (N)
14926 elsif Is_Private_Type (Ent)
14927 or else Is_Protected_Type (Ent)
14928 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))
14934 ("pragma % can only be applied to private, formal derived or "
14935 & "protected type",
14939 -- Give an error if the pragma is applied to a protected type that
14940 -- does not qualify (due to having entries, or due to components
14941 -- that do not qualify).
14943 if Is_Protected_Type (Ent)
14944 and then not Has_Preelaborable_Initialization (Ent)
14947 ("protected type & does not have preelaborable "
14948 & "initialization", Ent);
14950 -- Otherwise mark the type as definitely having preelaborable
14954 Set_Known_To_Have_Preelab_Init (Ent);
14957 if Has_Pragma_Preelab_Init (Ent)
14958 and then Warn_On_Redundant_Constructs
14960 Error_Pragma ("?r?duplicate pragma%!");
14962 Set_Has_Pragma_Preelab_Init (Ent);
14966 --------------------
14967 -- Persistent_BSS --
14968 --------------------
14970 -- pragma Persistent_BSS [(object_NAME)];
14972 when Pragma_Persistent_BSS => Persistent_BSS : declare
14979 Check_At_Most_N_Arguments (1);
14981 -- Case of application to specific object (one argument)
14983 if Arg_Count = 1 then
14984 Check_Arg_Is_Library_Level_Local_Name (Arg1);
14986 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
14988 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
14991 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
14994 Ent := Entity (Get_Pragma_Arg (Arg1));
14995 Decl := Parent (Ent);
14997 -- Check for duplication before inserting in list of
14998 -- representation items.
15000 Check_Duplicate_Pragma (Ent);
15002 if Rep_Item_Too_Late (Ent, N) then
15006 if Present (Expression (Decl)) then
15008 ("object for pragma% cannot have initialization", Arg1);
15011 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
15013 ("object type for pragma% is not potentially persistent",
15018 Make_Linker_Section_Pragma
15019 (Ent, Sloc (N), ".persistent.bss");
15020 Insert_After (N, Prag);
15023 -- Case of use as configuration pragma with no arguments
15026 Check_Valid_Configuration_Pragma;
15027 Persistent_BSS_Mode := True;
15029 end Persistent_BSS;
15035 -- pragma Polling (ON | OFF);
15037 when Pragma_Polling =>
15039 Check_Arg_Count (1);
15040 Check_No_Identifiers;
15041 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
15042 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
15044 -------------------
15045 -- Postcondition --
15046 -------------------
15048 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
15049 -- [,[Message =>] String_EXPRESSION]);
15051 when Pragma_Postcondition => Postcondition : declare
15056 Check_At_Least_N_Arguments (1);
15057 Check_At_Most_N_Arguments (2);
15058 Check_Optional_Identifier (Arg1, Name_Check);
15060 -- Verify the proper placement of the pragma. The remainder of the
15061 -- processing is found in Sem_Ch6/Sem_Ch7.
15063 Check_Precondition_Postcondition (In_Body);
15065 -- When the pragma is a source construct appearing inside a body,
15066 -- preanalyze the boolean_expression to detect illegal forward
15070 -- pragma Postcondition (X'Old ...);
15073 if Comes_From_Source (N) and then In_Body then
15074 Preanalyze_Spec_Expression (Expression (Arg1), Any_Boolean);
15082 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
15083 -- [,[Message =>] String_EXPRESSION]);
15085 when Pragma_Precondition => Precondition : declare
15090 Check_At_Least_N_Arguments (1);
15091 Check_At_Most_N_Arguments (2);
15092 Check_Optional_Identifier (Arg1, Name_Check);
15093 Check_Precondition_Postcondition (In_Body);
15095 -- If in spec, nothing more to do. If in body, then we convert
15096 -- the pragma to an equivalent pragma Check. That works fine since
15097 -- pragma Check will analyze the condition in the proper context.
15099 -- The form of the pragma Check is either:
15101 -- pragma Check (Precondition, cond [, msg])
15103 -- pragma Check (Pre, cond [, msg])
15105 -- We use the Pre form if this pragma derived from a Pre aspect.
15106 -- This is needed to make sure that the right set of Policy
15107 -- pragmas are checked.
15111 -- Rewrite as Check pragma
15115 Chars => Name_Check,
15116 Pragma_Argument_Associations => New_List (
15117 Make_Pragma_Argument_Association (Loc,
15118 Expression => Make_Identifier (Loc, Pname)),
15120 Make_Pragma_Argument_Association (Sloc (Arg1),
15122 Relocate_Node (Get_Pragma_Arg (Arg1))))));
15124 if Arg_Count = 2 then
15125 Append_To (Pragma_Argument_Associations (N),
15126 Make_Pragma_Argument_Association (Sloc (Arg2),
15128 Relocate_Node (Get_Pragma_Arg (Arg2))));
15139 -- pragma Predicate
15140 -- ([Entity =>] type_LOCAL_NAME,
15141 -- [Check =>] boolean_EXPRESSION);
15143 when Pragma_Predicate => Predicate : declare
15148 pragma Unreferenced (Discard);
15152 Check_Arg_Count (2);
15153 Check_Optional_Identifier (Arg1, Name_Entity);
15154 Check_Optional_Identifier (Arg2, Name_Check);
15156 Check_Arg_Is_Local_Name (Arg1);
15158 Type_Id := Get_Pragma_Arg (Arg1);
15159 Find_Type (Type_Id);
15160 Typ := Entity (Type_Id);
15162 if Typ = Any_Type then
15166 -- The remaining processing is simply to link the pragma on to
15167 -- the rep item chain, for processing when the type is frozen.
15168 -- This is accomplished by a call to Rep_Item_Too_Late. We also
15169 -- mark the type as having predicates.
15171 Set_Has_Predicates (Typ);
15172 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
15179 -- pragma Preelaborate [(library_unit_NAME)];
15181 -- Set the flag Is_Preelaborated of program unit name entity
15183 when Pragma_Preelaborate => Preelaborate : declare
15184 Pa : constant Node_Id := Parent (N);
15185 Pk : constant Node_Kind := Nkind (Pa);
15189 Check_Ada_83_Warning;
15190 Check_Valid_Library_Unit_Pragma;
15192 if Nkind (N) = N_Null_Statement then
15196 Ent := Find_Lib_Unit_Name;
15197 Check_Duplicate_Pragma (Ent);
15199 -- This filters out pragmas inside generic parents that show up
15200 -- inside instantiations. Pragmas that come from aspects in the
15201 -- unit are not ignored.
15203 if Present (Ent) then
15204 if Pk = N_Package_Specification
15205 and then Present (Generic_Parent (Pa))
15206 and then not From_Aspect_Specification (N)
15211 if not Debug_Flag_U then
15212 Set_Is_Preelaborated (Ent);
15213 Set_Suppress_Elaboration_Warnings (Ent);
15219 ---------------------
15220 -- Preelaborate_05 --
15221 ---------------------
15223 -- pragma Preelaborate_05 [(library_unit_NAME)];
15225 -- This pragma is useable only in GNAT_Mode, where it is used like
15226 -- pragma Preelaborate but it is only effective in Ada 2005 mode
15227 -- (otherwise it is ignored). This is used to implement AI-362 which
15228 -- recategorizes some run-time packages in Ada 2005 mode.
15230 when Pragma_Preelaborate_05 => Preelaborate_05 : declare
15235 Check_Valid_Library_Unit_Pragma;
15237 if not GNAT_Mode then
15238 Error_Pragma ("pragma% only available in GNAT mode");
15241 if Nkind (N) = N_Null_Statement then
15245 -- This is one of the few cases where we need to test the value of
15246 -- Ada_Version_Explicit rather than Ada_Version (which is always
15247 -- set to Ada_2012 in a predefined unit), we need to know the
15248 -- explicit version set to know if this pragma is active.
15250 if Ada_Version_Explicit >= Ada_2005 then
15251 Ent := Find_Lib_Unit_Name;
15252 Set_Is_Preelaborated (Ent);
15253 Set_Suppress_Elaboration_Warnings (Ent);
15255 end Preelaborate_05;
15261 -- pragma Priority (EXPRESSION);
15263 when Pragma_Priority => Priority : declare
15264 P : constant Node_Id := Parent (N);
15269 Check_No_Identifiers;
15270 Check_Arg_Count (1);
15274 if Nkind (P) = N_Subprogram_Body then
15275 Check_In_Main_Program;
15277 Ent := Defining_Unit_Name (Specification (P));
15279 if Nkind (Ent) = N_Defining_Program_Unit_Name then
15280 Ent := Defining_Identifier (Ent);
15283 Arg := Get_Pragma_Arg (Arg1);
15284 Analyze_And_Resolve (Arg, Standard_Integer);
15288 if not Is_Static_Expression (Arg) then
15289 Flag_Non_Static_Expr
15290 ("main subprogram priority is not static!", Arg);
15293 -- If constraint error, then we already signalled an error
15295 elsif Raises_Constraint_Error (Arg) then
15298 -- Otherwise check in range
15302 Val : constant Uint := Expr_Value (Arg);
15306 or else Val > Expr_Value (Expression
15307 (Parent (RTE (RE_Max_Priority))))
15310 ("main subprogram priority is out of range", Arg1);
15316 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
15318 -- Load an arbitrary entity from System.Tasking to make sure
15319 -- this package is implicitly with'ed, since we need to have
15320 -- the tasking run-time active for the pragma Priority to have
15324 Discard : Entity_Id;
15325 pragma Warnings (Off, Discard);
15327 Discard := RTE (RE_Task_List);
15330 -- Task or Protected, must be of type Integer
15332 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
15333 Arg := Get_Pragma_Arg (Arg1);
15334 Ent := Defining_Identifier (Parent (P));
15336 -- The expression must be analyzed in the special manner
15337 -- described in "Handling of Default and Per-Object
15338 -- Expressions" in sem.ads.
15340 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority));
15342 if not Is_Static_Expression (Arg) then
15343 Check_Restriction (Static_Priorities, Arg);
15346 -- Anything else is incorrect
15352 -- Check duplicate pragma before we chain the pragma in the Rep
15353 -- Item chain of Ent.
15355 Check_Duplicate_Pragma (Ent);
15356 Record_Rep_Item (Ent, N);
15359 -----------------------------------
15360 -- Priority_Specific_Dispatching --
15361 -----------------------------------
15363 -- pragma Priority_Specific_Dispatching (
15364 -- policy_IDENTIFIER,
15365 -- first_priority_EXPRESSION,
15366 -- last_priority_EXPRESSION);
15368 when Pragma_Priority_Specific_Dispatching =>
15369 Priority_Specific_Dispatching : declare
15370 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
15371 -- This is the entity System.Any_Priority;
15374 Lower_Bound : Node_Id;
15375 Upper_Bound : Node_Id;
15381 Check_Arg_Count (3);
15382 Check_No_Identifiers;
15383 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
15384 Check_Valid_Configuration_Pragma;
15385 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
15386 DP := Fold_Upper (Name_Buffer (1));
15388 Lower_Bound := Get_Pragma_Arg (Arg2);
15389 Check_Arg_Is_Static_Expression (Lower_Bound, Standard_Integer);
15390 Lower_Val := Expr_Value (Lower_Bound);
15392 Upper_Bound := Get_Pragma_Arg (Arg3);
15393 Check_Arg_Is_Static_Expression (Upper_Bound, Standard_Integer);
15394 Upper_Val := Expr_Value (Upper_Bound);
15396 -- It is not allowed to use Task_Dispatching_Policy and
15397 -- Priority_Specific_Dispatching in the same partition.
15399 if Task_Dispatching_Policy /= ' ' then
15400 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
15402 ("pragma% incompatible with Task_Dispatching_Policy#");
15404 -- Check lower bound in range
15406 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
15408 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
15411 ("first_priority is out of range", Arg2);
15413 -- Check upper bound in range
15415 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
15417 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
15420 ("last_priority is out of range", Arg3);
15422 -- Check that the priority range is valid
15424 elsif Lower_Val > Upper_Val then
15426 ("last_priority_expression must be greater than or equal to "
15427 & "first_priority_expression");
15429 -- Store the new policy, but always preserve System_Location since
15430 -- we like the error message with the run-time name.
15433 -- Check overlapping in the priority ranges specified in other
15434 -- Priority_Specific_Dispatching pragmas within the same
15435 -- partition. We can only check those we know about!
15438 Specific_Dispatching.First .. Specific_Dispatching.Last
15440 if Specific_Dispatching.Table (J).First_Priority in
15441 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
15442 or else Specific_Dispatching.Table (J).Last_Priority in
15443 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
15446 Specific_Dispatching.Table (J).Pragma_Loc;
15448 ("priority range overlaps with "
15449 & "Priority_Specific_Dispatching#");
15453 -- The use of Priority_Specific_Dispatching is incompatible
15454 -- with Task_Dispatching_Policy.
15456 if Task_Dispatching_Policy /= ' ' then
15457 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
15459 ("Priority_Specific_Dispatching incompatible "
15460 & "with Task_Dispatching_Policy#");
15463 -- The use of Priority_Specific_Dispatching forces ceiling
15466 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
15467 Error_Msg_Sloc := Locking_Policy_Sloc;
15469 ("Priority_Specific_Dispatching incompatible "
15470 & "with Locking_Policy#");
15472 -- Set the Ceiling_Locking policy, but preserve System_Location
15473 -- since we like the error message with the run time name.
15476 Locking_Policy := 'C';
15478 if Locking_Policy_Sloc /= System_Location then
15479 Locking_Policy_Sloc := Loc;
15483 -- Add entry in the table
15485 Specific_Dispatching.Append
15486 ((Dispatching_Policy => DP,
15487 First_Priority => UI_To_Int (Lower_Val),
15488 Last_Priority => UI_To_Int (Upper_Val),
15489 Pragma_Loc => Loc));
15491 end Priority_Specific_Dispatching;
15497 -- pragma Profile (profile_IDENTIFIER);
15499 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
15501 when Pragma_Profile =>
15503 Check_Arg_Count (1);
15504 Check_Valid_Configuration_Pragma;
15505 Check_No_Identifiers;
15508 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
15511 if Chars (Argx) = Name_Ravenscar then
15512 Set_Ravenscar_Profile (N);
15514 elsif Chars (Argx) = Name_Restricted then
15515 Set_Profile_Restrictions
15517 N, Warn => Treat_Restrictions_As_Warnings);
15519 elsif Chars (Argx) = Name_Rational then
15520 Set_Rational_Profile;
15522 elsif Chars (Argx) = Name_No_Implementation_Extensions then
15523 Set_Profile_Restrictions
15524 (No_Implementation_Extensions,
15525 N, Warn => Treat_Restrictions_As_Warnings);
15528 Error_Pragma_Arg ("& is not a valid profile", Argx);
15532 ----------------------
15533 -- Profile_Warnings --
15534 ----------------------
15536 -- pragma Profile_Warnings (profile_IDENTIFIER);
15538 -- profile_IDENTIFIER => Restricted | Ravenscar
15540 when Pragma_Profile_Warnings =>
15542 Check_Arg_Count (1);
15543 Check_Valid_Configuration_Pragma;
15544 Check_No_Identifiers;
15547 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
15550 if Chars (Argx) = Name_Ravenscar then
15551 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
15553 elsif Chars (Argx) = Name_Restricted then
15554 Set_Profile_Restrictions (Restricted, N, Warn => True);
15556 elsif Chars (Argx) = Name_No_Implementation_Extensions then
15557 Set_Profile_Restrictions
15558 (No_Implementation_Extensions, N, Warn => True);
15561 Error_Pragma_Arg ("& is not a valid profile", Argx);
15565 --------------------------
15566 -- Propagate_Exceptions --
15567 --------------------------
15569 -- pragma Propagate_Exceptions;
15571 -- Note: this pragma is obsolete and has no effect
15573 when Pragma_Propagate_Exceptions =>
15575 Check_Arg_Count (0);
15577 if Warn_On_Obsolescent_Feature then
15579 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
15580 "and has no effect?j?", N);
15587 -- pragma Psect_Object (
15588 -- [Internal =>] LOCAL_NAME,
15589 -- [, [External =>] EXTERNAL_SYMBOL]
15590 -- [, [Size =>] EXTERNAL_SYMBOL]);
15592 when Pragma_Psect_Object | Pragma_Common_Object =>
15593 Psect_Object : declare
15594 Args : Args_List (1 .. 3);
15595 Names : constant Name_List (1 .. 3) := (
15600 Internal : Node_Id renames Args (1);
15601 External : Node_Id renames Args (2);
15602 Size : Node_Id renames Args (3);
15604 Def_Id : Entity_Id;
15606 procedure Check_Too_Long (Arg : Node_Id);
15607 -- Posts message if the argument is an identifier with more
15608 -- than 31 characters, or a string literal with more than
15609 -- 31 characters, and we are operating under VMS
15611 --------------------
15612 -- Check_Too_Long --
15613 --------------------
15615 procedure Check_Too_Long (Arg : Node_Id) is
15616 X : constant Node_Id := Original_Node (Arg);
15619 if not Nkind_In (X, N_String_Literal, N_Identifier) then
15621 ("inappropriate argument for pragma %", Arg);
15624 if OpenVMS_On_Target then
15625 if (Nkind (X) = N_String_Literal
15626 and then String_Length (Strval (X)) > 31)
15628 (Nkind (X) = N_Identifier
15629 and then Length_Of_Name (Chars (X)) > 31)
15632 ("argument for pragma % is longer than 31 characters",
15636 end Check_Too_Long;
15638 -- Start of processing for Common_Object/Psect_Object
15642 Gather_Associations (Names, Args);
15643 Process_Extended_Import_Export_Internal_Arg (Internal);
15645 Def_Id := Entity (Internal);
15647 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
15649 ("pragma% must designate an object", Internal);
15652 Check_Too_Long (Internal);
15654 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
15656 ("cannot use pragma% for imported/exported object",
15660 if Is_Concurrent_Type (Etype (Internal)) then
15662 ("cannot specify pragma % for task/protected object",
15666 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
15668 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
15670 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N);
15673 if Ekind (Def_Id) = E_Constant then
15675 ("cannot specify pragma % for a constant", Internal);
15678 if Is_Record_Type (Etype (Internal)) then
15684 Ent := First_Entity (Etype (Internal));
15685 while Present (Ent) loop
15686 Decl := Declaration_Node (Ent);
15688 if Ekind (Ent) = E_Component
15689 and then Nkind (Decl) = N_Component_Declaration
15690 and then Present (Expression (Decl))
15691 and then Warn_On_Export_Import
15694 ("?x?object for pragma % has defaults", Internal);
15704 if Present (Size) then
15705 Check_Too_Long (Size);
15708 if Present (External) then
15709 Check_Arg_Is_External_Name (External);
15710 Check_Too_Long (External);
15713 -- If all error tests pass, link pragma on to the rep item chain
15715 Record_Rep_Item (Def_Id, N);
15722 -- pragma Pure [(library_unit_NAME)];
15724 when Pragma_Pure => Pure : declare
15728 Check_Ada_83_Warning;
15729 Check_Valid_Library_Unit_Pragma;
15731 if Nkind (N) = N_Null_Statement then
15735 Ent := Find_Lib_Unit_Name;
15737 Set_Has_Pragma_Pure (Ent);
15738 Set_Suppress_Elaboration_Warnings (Ent);
15745 -- pragma Pure_05 [(library_unit_NAME)];
15747 -- This pragma is useable only in GNAT_Mode, where it is used like
15748 -- pragma Pure but it is only effective in Ada 2005 mode (otherwise
15749 -- it is ignored). It may be used after a pragma Preelaborate, in
15750 -- which case it overrides the effect of the pragma Preelaborate.
15751 -- This is used to implement AI-362 which recategorizes some run-time
15752 -- packages in Ada 2005 mode.
15754 when Pragma_Pure_05 => Pure_05 : declare
15759 Check_Valid_Library_Unit_Pragma;
15761 if not GNAT_Mode then
15762 Error_Pragma ("pragma% only available in GNAT mode");
15765 if Nkind (N) = N_Null_Statement then
15769 -- This is one of the few cases where we need to test the value of
15770 -- Ada_Version_Explicit rather than Ada_Version (which is always
15771 -- set to Ada_2012 in a predefined unit), we need to know the
15772 -- explicit version set to know if this pragma is active.
15774 if Ada_Version_Explicit >= Ada_2005 then
15775 Ent := Find_Lib_Unit_Name;
15776 Set_Is_Preelaborated (Ent, False);
15778 Set_Suppress_Elaboration_Warnings (Ent);
15786 -- pragma Pure_12 [(library_unit_NAME)];
15788 -- This pragma is useable only in GNAT_Mode, where it is used like
15789 -- pragma Pure but it is only effective in Ada 2012 mode (otherwise
15790 -- it is ignored). It may be used after a pragma Preelaborate, in
15791 -- which case it overrides the effect of the pragma Preelaborate.
15792 -- This is used to implement AI05-0212 which recategorizes some
15793 -- run-time packages in Ada 2012 mode.
15795 when Pragma_Pure_12 => Pure_12 : declare
15800 Check_Valid_Library_Unit_Pragma;
15802 if not GNAT_Mode then
15803 Error_Pragma ("pragma% only available in GNAT mode");
15806 if Nkind (N) = N_Null_Statement then
15810 -- This is one of the few cases where we need to test the value of
15811 -- Ada_Version_Explicit rather than Ada_Version (which is always
15812 -- set to Ada_2012 in a predefined unit), we need to know the
15813 -- explicit version set to know if this pragma is active.
15815 if Ada_Version_Explicit >= Ada_2012 then
15816 Ent := Find_Lib_Unit_Name;
15817 Set_Is_Preelaborated (Ent, False);
15819 Set_Suppress_Elaboration_Warnings (Ent);
15823 -------------------
15824 -- Pure_Function --
15825 -------------------
15827 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
15829 when Pragma_Pure_Function => Pure_Function : declare
15832 Def_Id : Entity_Id;
15833 Effective : Boolean := False;
15837 Check_Arg_Count (1);
15838 Check_Optional_Identifier (Arg1, Name_Entity);
15839 Check_Arg_Is_Local_Name (Arg1);
15840 E_Id := Get_Pragma_Arg (Arg1);
15842 if Error_Posted (E_Id) then
15846 -- Loop through homonyms (overloadings) of referenced entity
15848 E := Entity (E_Id);
15850 if Present (E) then
15852 Def_Id := Get_Base_Subprogram (E);
15854 if not Ekind_In (Def_Id, E_Function,
15855 E_Generic_Function,
15859 ("pragma% requires a function name", Arg1);
15862 Set_Is_Pure (Def_Id);
15864 if not Has_Pragma_Pure_Function (Def_Id) then
15865 Set_Has_Pragma_Pure_Function (Def_Id);
15869 exit when From_Aspect_Specification (N);
15871 exit when No (E) or else Scope (E) /= Current_Scope;
15875 and then Warn_On_Redundant_Constructs
15878 ("pragma Pure_Function on& is redundant?r?",
15884 --------------------
15885 -- Queuing_Policy --
15886 --------------------
15888 -- pragma Queuing_Policy (policy_IDENTIFIER);
15890 when Pragma_Queuing_Policy => declare
15894 Check_Ada_83_Warning;
15895 Check_Arg_Count (1);
15896 Check_No_Identifiers;
15897 Check_Arg_Is_Queuing_Policy (Arg1);
15898 Check_Valid_Configuration_Pragma;
15899 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
15900 QP := Fold_Upper (Name_Buffer (1));
15902 if Queuing_Policy /= ' '
15903 and then Queuing_Policy /= QP
15905 Error_Msg_Sloc := Queuing_Policy_Sloc;
15906 Error_Pragma ("queuing policy incompatible with policy#");
15908 -- Set new policy, but always preserve System_Location since we
15909 -- like the error message with the run time name.
15912 Queuing_Policy := QP;
15914 if Queuing_Policy_Sloc /= System_Location then
15915 Queuing_Policy_Sloc := Loc;
15924 -- pragma Rational, for compatibility with foreign compiler
15926 when Pragma_Rational =>
15927 Set_Rational_Profile;
15929 ---------------------
15930 -- Refined_Depends --
15931 ---------------------
15933 -- ??? To be implemented
15935 when Pragma_Refined_Depends =>
15938 --------------------
15939 -- Refined_Global --
15940 --------------------
15942 -- ??? To be implemented
15944 -- Would be better if these generated an error message saying that
15945 -- the feature was not yet implemented ???
15947 when Pragma_Refined_Global =>
15954 -- pragma Refined_Post (boolean_EXPRESSION);
15956 when Pragma_Refined_Post =>
15957 Analyze_Refined_Pre_Post_Condition;
15963 -- pragma Refined_Pre (boolean_EXPRESSION);
15965 when Pragma_Refined_Pre =>
15966 Analyze_Refined_Pre_Post_Condition;
15968 -------------------
15969 -- Refined_State --
15970 -------------------
15972 -- pragma Refined_State (REFINEMENT_LIST);
15974 -- REFINEMENT_LIST ::=
15975 -- REFINEMENT_CLAUSE
15976 -- | (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
15978 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
15980 -- CONSTITUENT_LIST ::=
15983 -- | (CONSTITUENT {, CONSTITUENT})
15985 -- CONSTITUENT ::= object_NAME | state_NAME
15987 when Pragma_Refined_State => Refined_State : declare
15988 Context : constant Node_Id := Parent (N);
15989 Spec_Id : Entity_Id;
15994 Check_Arg_Count (1);
15996 -- Ensure the proper placement of the pragma. Refined states must
15997 -- be associated with a package body.
15999 if Nkind (Context) /= N_Package_Body then
16004 -- State refinement is allowed only when the corresponding package
16005 -- declaration has a non-null aspect/pragma Abstract_State.
16007 Spec_Id := Corresponding_Spec (Context);
16009 if No (Abstract_States (Spec_Id))
16010 or else Has_Null_Abstract_State (Spec_Id)
16013 ("useless pragma %, package does not define abstract states");
16017 -- The pragma must be analyzed at the end of the declarations as
16018 -- it has visibility over the whole declarative region. Save the
16019 -- pragma for later (see Analyze_Refined_Depends_In_Decl_Part).
16021 Set_Refined_State_Pragma (Defining_Entity (Context), N);
16024 -----------------------
16025 -- Relative_Deadline --
16026 -----------------------
16028 -- pragma Relative_Deadline (time_span_EXPRESSION);
16030 when Pragma_Relative_Deadline => Relative_Deadline : declare
16031 P : constant Node_Id := Parent (N);
16036 Check_No_Identifiers;
16037 Check_Arg_Count (1);
16039 Arg := Get_Pragma_Arg (Arg1);
16041 -- The expression must be analyzed in the special manner described
16042 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
16044 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
16048 if Nkind (P) = N_Subprogram_Body then
16049 Check_In_Main_Program;
16051 -- Only Task and subprogram cases allowed
16053 elsif Nkind (P) /= N_Task_Definition then
16057 -- Check duplicate pragma before we set the corresponding flag
16059 if Has_Relative_Deadline_Pragma (P) then
16060 Error_Pragma ("duplicate pragma% not allowed");
16063 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
16064 -- Relative_Deadline pragma node cannot be inserted in the Rep
16065 -- Item chain of Ent since it is rewritten by the expander as a
16066 -- procedure call statement that will break the chain.
16068 Set_Has_Relative_Deadline_Pragma (P, True);
16069 end Relative_Deadline;
16071 ------------------------
16072 -- Remote_Access_Type --
16073 ------------------------
16075 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
16077 when Pragma_Remote_Access_Type => Remote_Access_Type : declare
16082 Check_Arg_Count (1);
16083 Check_Optional_Identifier (Arg1, Name_Entity);
16084 Check_Arg_Is_Local_Name (Arg1);
16086 E := Entity (Get_Pragma_Arg (Arg1));
16088 if Nkind (Parent (E)) = N_Formal_Type_Declaration
16089 and then Ekind (E) = E_General_Access_Type
16090 and then Is_Class_Wide_Type (Directly_Designated_Type (E))
16091 and then Scope (Root_Type (Directly_Designated_Type (E)))
16093 and then Is_Valid_Remote_Object_Type
16094 (Root_Type (Directly_Designated_Type (E)))
16096 Set_Is_Remote_Types (E);
16100 ("pragma% applies only to formal access to classwide types",
16103 end Remote_Access_Type;
16105 ---------------------------
16106 -- Remote_Call_Interface --
16107 ---------------------------
16109 -- pragma Remote_Call_Interface [(library_unit_NAME)];
16111 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
16112 Cunit_Node : Node_Id;
16113 Cunit_Ent : Entity_Id;
16117 Check_Ada_83_Warning;
16118 Check_Valid_Library_Unit_Pragma;
16120 if Nkind (N) = N_Null_Statement then
16124 Cunit_Node := Cunit (Current_Sem_Unit);
16125 K := Nkind (Unit (Cunit_Node));
16126 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
16128 if K = N_Package_Declaration
16129 or else K = N_Generic_Package_Declaration
16130 or else K = N_Subprogram_Declaration
16131 or else K = N_Generic_Subprogram_Declaration
16132 or else (K = N_Subprogram_Body
16133 and then Acts_As_Spec (Unit (Cunit_Node)))
16138 "pragma% must apply to package or subprogram declaration");
16141 Set_Is_Remote_Call_Interface (Cunit_Ent);
16142 end Remote_Call_Interface;
16148 -- pragma Remote_Types [(library_unit_NAME)];
16150 when Pragma_Remote_Types => Remote_Types : declare
16151 Cunit_Node : Node_Id;
16152 Cunit_Ent : Entity_Id;
16155 Check_Ada_83_Warning;
16156 Check_Valid_Library_Unit_Pragma;
16158 if Nkind (N) = N_Null_Statement then
16162 Cunit_Node := Cunit (Current_Sem_Unit);
16163 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
16165 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
16166 N_Generic_Package_Declaration)
16169 ("pragma% can only apply to a package declaration");
16172 Set_Is_Remote_Types (Cunit_Ent);
16179 -- pragma Ravenscar;
16181 when Pragma_Ravenscar =>
16183 Check_Arg_Count (0);
16184 Check_Valid_Configuration_Pragma;
16185 Set_Ravenscar_Profile (N);
16187 if Warn_On_Obsolescent_Feature then
16189 ("pragma Ravenscar is an obsolescent feature?j?", N);
16191 ("|use pragma Profile (Ravenscar) instead?j?", N);
16194 -------------------------
16195 -- Restricted_Run_Time --
16196 -------------------------
16198 -- pragma Restricted_Run_Time;
16200 when Pragma_Restricted_Run_Time =>
16202 Check_Arg_Count (0);
16203 Check_Valid_Configuration_Pragma;
16204 Set_Profile_Restrictions
16205 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
16207 if Warn_On_Obsolescent_Feature then
16209 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
16212 ("|use pragma Profile (Restricted) instead?j?", N);
16219 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
16222 -- restriction_IDENTIFIER
16223 -- | restriction_parameter_IDENTIFIER => EXPRESSION
16225 when Pragma_Restrictions =>
16226 Process_Restrictions_Or_Restriction_Warnings
16227 (Warn => Treat_Restrictions_As_Warnings);
16229 --------------------------
16230 -- Restriction_Warnings --
16231 --------------------------
16233 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
16236 -- restriction_IDENTIFIER
16237 -- | restriction_parameter_IDENTIFIER => EXPRESSION
16239 when Pragma_Restriction_Warnings =>
16241 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
16247 -- pragma Reviewable;
16249 when Pragma_Reviewable =>
16250 Check_Ada_83_Warning;
16251 Check_Arg_Count (0);
16253 -- Call dummy debugging function rv. This is done to assist front
16254 -- end debugging. By placing a Reviewable pragma in the source
16255 -- program, a breakpoint on rv catches this place in the source,
16256 -- allowing convenient stepping to the point of interest.
16260 --------------------------
16261 -- Short_Circuit_And_Or --
16262 --------------------------
16264 -- pragma Short_Circuit_And_Or;
16266 when Pragma_Short_Circuit_And_Or =>
16268 Check_Arg_Count (0);
16269 Check_Valid_Configuration_Pragma;
16270 Short_Circuit_And_Or := True;
16272 -------------------
16273 -- Share_Generic --
16274 -------------------
16276 -- pragma Share_Generic (GNAME {, GNAME});
16278 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
16280 when Pragma_Share_Generic =>
16282 Process_Generic_List;
16288 -- pragma Shared (LOCAL_NAME);
16290 when Pragma_Shared =>
16292 Process_Atomic_Shared_Volatile;
16294 --------------------
16295 -- Shared_Passive --
16296 --------------------
16298 -- pragma Shared_Passive [(library_unit_NAME)];
16300 -- Set the flag Is_Shared_Passive of program unit name entity
16302 when Pragma_Shared_Passive => Shared_Passive : declare
16303 Cunit_Node : Node_Id;
16304 Cunit_Ent : Entity_Id;
16307 Check_Ada_83_Warning;
16308 Check_Valid_Library_Unit_Pragma;
16310 if Nkind (N) = N_Null_Statement then
16314 Cunit_Node := Cunit (Current_Sem_Unit);
16315 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
16317 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
16318 N_Generic_Package_Declaration)
16321 ("pragma% can only apply to a package declaration");
16324 Set_Is_Shared_Passive (Cunit_Ent);
16325 end Shared_Passive;
16327 -----------------------
16328 -- Short_Descriptors --
16329 -----------------------
16331 -- pragma Short_Descriptors;
16333 when Pragma_Short_Descriptors =>
16335 Check_Arg_Count (0);
16336 Check_Valid_Configuration_Pragma;
16337 Short_Descriptors := True;
16339 ------------------------------
16340 -- Simple_Storage_Pool_Type --
16341 ------------------------------
16343 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
16345 when Pragma_Simple_Storage_Pool_Type =>
16346 Simple_Storage_Pool_Type : declare
16352 Check_Arg_Count (1);
16353 Check_Arg_Is_Library_Level_Local_Name (Arg1);
16355 Type_Id := Get_Pragma_Arg (Arg1);
16356 Find_Type (Type_Id);
16357 Typ := Entity (Type_Id);
16359 if Typ = Any_Type then
16363 -- We require the pragma to apply to a type declared in a package
16364 -- declaration, but not (immediately) within a package body.
16366 if Ekind (Current_Scope) /= E_Package
16367 or else In_Package_Body (Current_Scope)
16370 ("pragma% can only apply to type declared immediately "
16371 & "within a package declaration");
16374 -- A simple storage pool type must be an immutably limited record
16375 -- or private type. If the pragma is given for a private type,
16376 -- the full type is similarly restricted (which is checked later
16377 -- in Freeze_Entity).
16379 if Is_Record_Type (Typ)
16380 and then not Is_Immutably_Limited_Type (Typ)
16383 ("pragma% can only apply to explicitly limited record type");
16385 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
16387 ("pragma% can only apply to a private type that is limited");
16389 elsif not Is_Record_Type (Typ)
16390 and then not Is_Private_Type (Typ)
16393 ("pragma% can only apply to limited record or private type");
16396 Record_Rep_Item (Typ, N);
16397 end Simple_Storage_Pool_Type;
16399 ----------------------
16400 -- Source_File_Name --
16401 ----------------------
16403 -- There are five forms for this pragma:
16405 -- pragma Source_File_Name (
16406 -- [UNIT_NAME =>] unit_NAME,
16407 -- BODY_FILE_NAME => STRING_LITERAL
16408 -- [, [INDEX =>] INTEGER_LITERAL]);
16410 -- pragma Source_File_Name (
16411 -- [UNIT_NAME =>] unit_NAME,
16412 -- SPEC_FILE_NAME => STRING_LITERAL
16413 -- [, [INDEX =>] INTEGER_LITERAL]);
16415 -- pragma Source_File_Name (
16416 -- BODY_FILE_NAME => STRING_LITERAL
16417 -- [, DOT_REPLACEMENT => STRING_LITERAL]
16418 -- [, CASING => CASING_SPEC]);
16420 -- pragma Source_File_Name (
16421 -- SPEC_FILE_NAME => STRING_LITERAL
16422 -- [, DOT_REPLACEMENT => STRING_LITERAL]
16423 -- [, CASING => CASING_SPEC]);
16425 -- pragma Source_File_Name (
16426 -- SUBUNIT_FILE_NAME => STRING_LITERAL
16427 -- [, DOT_REPLACEMENT => STRING_LITERAL]
16428 -- [, CASING => CASING_SPEC]);
16430 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
16432 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
16433 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
16434 -- only be used when no project file is used, while SFNP can only be
16435 -- used when a project file is used.
16437 -- No processing here. Processing was completed during parsing, since
16438 -- we need to have file names set as early as possible. Units are
16439 -- loaded well before semantic processing starts.
16441 -- The only processing we defer to this point is the check for
16442 -- correct placement.
16444 when Pragma_Source_File_Name =>
16446 Check_Valid_Configuration_Pragma;
16448 ------------------------------
16449 -- Source_File_Name_Project --
16450 ------------------------------
16452 -- See Source_File_Name for syntax
16454 -- No processing here. Processing was completed during parsing, since
16455 -- we need to have file names set as early as possible. Units are
16456 -- loaded well before semantic processing starts.
16458 -- The only processing we defer to this point is the check for
16459 -- correct placement.
16461 when Pragma_Source_File_Name_Project =>
16463 Check_Valid_Configuration_Pragma;
16465 -- Check that a pragma Source_File_Name_Project is used only in a
16466 -- configuration pragmas file.
16468 -- Pragmas Source_File_Name_Project should only be generated by
16469 -- the Project Manager in configuration pragmas files.
16471 -- This is really an ugly test. It seems to depend on some
16472 -- accidental and undocumented property. At the very least it
16473 -- needs to be documented, but it would be better to have a
16474 -- clean way of testing if we are in a configuration file???
16476 if Present (Parent (N)) then
16478 ("pragma% can only appear in a configuration pragmas file");
16481 ----------------------
16482 -- Source_Reference --
16483 ----------------------
16485 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
16487 -- Nothing to do, all processing completed in Par.Prag, since we need
16488 -- the information for possible parser messages that are output.
16490 when Pragma_Source_Reference =>
16497 -- pragma SPARK_Mode [(On | Off | Auto)];
16499 when Pragma_SPARK_Mode => SPARK_Mod : declare
16500 procedure Chain_Pragma (Context : Entity_Id; Prag : Node_Id);
16501 -- Associate a SPARK_Mode pragma with the context where it lives.
16502 -- If the context is a package spec or a body, the routine checks
16503 -- the consistency between modes of visible/private declarations
16504 -- and body declarations/statements.
16506 procedure Check_Spark_Mode_Conformance
16507 (Governing_Id : Entity_Id;
16508 New_Id : Entity_Id);
16509 -- Verify the "monotonicity" of SPARK modes between two entities.
16510 -- The order of modes is Off < Auto < On. Governing_Id establishes
16511 -- the mode of the context. New_Id attempts to redefine the known
16514 procedure Check_Pragma_Conformance
16515 (Governing_Mode : Node_Id;
16516 New_Mode : Node_Id);
16517 -- Verify the "monotonicity" of two SPARK_Mode pragmas. The order
16518 -- of modes is Off < Auto < On. Governing_Mode is the established
16519 -- mode dictated by the context. New_Mode attempts to redefine the
16522 function Get_SPARK_Mode_Name (Id : SPARK_Mode_Id) return Name_Id;
16523 -- Convert a value of type SPARK_Mode_Id into a corresponding name
16529 procedure Chain_Pragma (Context : Entity_Id; Prag : Node_Id) is
16530 Existing_Prag : constant Node_Id :=
16531 SPARK_Mode_Pragmas (Context);
16533 -- The context does not have a prior mode defined
16535 if No (Existing_Prag) then
16536 Set_SPARK_Mode_Pragmas (Context, Prag);
16538 -- Chain the new mode on the list of SPARK_Mode pragmas. Verify
16539 -- the consistency between the existing mode and the new one.
16542 Set_Next_Pragma (Existing_Prag, Prag);
16544 Check_Pragma_Conformance
16545 (Governing_Mode => Existing_Prag,
16550 ----------------------------------
16551 -- Check_Spark_Mode_Conformance --
16552 ----------------------------------
16554 procedure Check_Spark_Mode_Conformance
16555 (Governing_Id : Entity_Id;
16556 New_Id : Entity_Id)
16558 Gov_Prag : constant Node_Id :=
16559 SPARK_Mode_Pragmas (Governing_Id);
16560 New_Prag : constant Node_Id := SPARK_Mode_Pragmas (New_Id);
16563 -- Nothing to do when one or both entities lack a mode
16565 if No (Gov_Prag) or else No (New_Prag) then
16569 -- Do not compare the modes of a package spec and body when the
16570 -- spec mode appears in the private part. In this case the spec
16571 -- mode does not affect the body.
16573 if Ekind_In (Governing_Id, E_Generic_Package, E_Package)
16574 and then Ekind (New_Id) = E_Package_Body
16575 and then Is_Private_SPARK_Mode (Gov_Prag)
16579 -- Test the pragmas
16582 Check_Pragma_Conformance
16583 (Governing_Mode => Gov_Prag,
16584 New_Mode => New_Prag);
16586 end Check_Spark_Mode_Conformance;
16588 ------------------------------
16589 -- Check_Pragma_Conformance --
16590 ------------------------------
16592 procedure Check_Pragma_Conformance
16593 (Governing_Mode : Node_Id;
16594 New_Mode : Node_Id)
16596 Gov_M : constant SPARK_Mode_Id :=
16597 Get_SPARK_Mode_Id (Governing_Mode);
16598 New_M : constant SPARK_Mode_Id := Get_SPARK_Mode_Id (New_Mode);
16601 -- The new mode is less restrictive than the established mode
16603 if Gov_M < New_M then
16604 Error_Msg_Name_1 := Get_SPARK_Mode_Name (New_M);
16605 Error_Msg_N ("cannot define 'S'P'A'R'K mode %", New_Mode);
16607 Error_Msg_Name_1 := Get_SPARK_Mode_Name (Gov_M);
16608 Error_Msg_Sloc := Sloc (Governing_Mode);
16610 ("\mode is less restrictive than mode % defined #",
16613 end Check_Pragma_Conformance;
16615 -------------------------
16616 -- Get_SPARK_Mode_Name --
16617 -------------------------
16619 function Get_SPARK_Mode_Name (Id : SPARK_Mode_Id) return Name_Id is
16621 if Id = SPARK_On then
16623 elsif Id = SPARK_Off then
16625 elsif Id = SPARK_Auto then
16628 -- Mode "None" should never be used in error message generation
16631 raise Program_Error;
16633 end Get_SPARK_Mode_Name;
16637 Body_Id : Entity_Id;
16640 Mode_Id : SPARK_Mode_Id;
16641 Spec_Id : Entity_Id;
16644 -- Start of processing for SPARK_Mode
16648 Check_No_Identifiers;
16649 Check_At_Most_N_Arguments (1);
16651 -- Check the legality of the mode
16653 if Arg_Count = 1 then
16654 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off, Name_Auto);
16655 Mode := Chars (Get_Pragma_Arg (Arg1));
16657 -- A SPARK_Mode without an argument defaults to "On"
16663 Mode_Id := Get_SPARK_Mode_Id (Mode);
16664 Context := Parent (N);
16666 -- The pragma appears in a configuration file
16668 if No (Context) then
16669 Check_Valid_Configuration_Pragma;
16670 Global_SPARK_Mode := Mode_Id;
16672 -- When the pragma is placed before the declaration of a unit, it
16673 -- configures the whole unit.
16675 elsif Nkind (Context) = N_Compilation_Unit then
16676 Check_Valid_Configuration_Pragma;
16677 Set_SPARK_Mode_Pragma (Current_Sem_Unit, N);
16679 -- The pragma applies to a [library unit] subprogram or package
16682 -- Mode "Auto" cannot be used in nested subprograms or packages
16684 if Mode_Id = SPARK_Auto then
16686 ("mode `Auto` can only apply to the configuration variant "
16687 & "of pragma %", Arg1);
16690 -- Verify the placement of the pragma with respect to package
16691 -- or subprogram declarations and detect duplicates.
16694 while Present (Stmt) loop
16696 -- Skip prior pragmas, but check for duplicates
16698 if Nkind (Stmt) = N_Pragma then
16699 if Pragma_Name (Stmt) = Pname then
16700 Error_Msg_Name_1 := Pname;
16701 Error_Msg_Sloc := Sloc (Stmt);
16703 ("pragma % duplicates pragma declared #", N);
16706 -- Skip internally generated code
16708 elsif not Comes_From_Source (Stmt) then
16711 -- The pragma applies to a package or subprogram declaration
16713 elsif Nkind_In (Stmt, N_Generic_Package_Declaration,
16714 N_Generic_Subprogram_Declaration,
16715 N_Package_Declaration,
16716 N_Subprogram_Declaration)
16718 Spec_Id := Defining_Unit_Name (Specification (Stmt));
16719 Chain_Pragma (Spec_Id, N);
16722 -- The pragma does not apply to a legal construct, issue an
16723 -- error and stop the analysis.
16730 Stmt := Prev (Stmt);
16733 -- Handle all cases where the pragma is actually an aspect and
16734 -- applies to a library-level package spec, body or subprogram.
16736 -- function F ... with SPARK_Mode => ...;
16737 -- package P with SPARK_Mode => ...;
16738 -- package body P with SPARK_Mode => ... is
16740 -- The following circuitry simply prepares the proper context
16741 -- for the general pragma processing mechanism below.
16743 if Nkind (Context) = N_Compilation_Unit_Aux then
16744 Context := Unit (Parent (Context));
16746 if Nkind_In (Context, N_Package_Declaration,
16747 N_Subprogram_Declaration)
16749 Context := Specification (Context);
16753 -- The pragma is at the top level of a package spec or appears
16754 -- as an aspect on a subprogram.
16756 -- function F ... with SPARK_Mode => ...;
16759 -- pragma SPARK_Mode;
16761 if Nkind_In (Context, N_Function_Specification,
16762 N_Package_Specification,
16763 N_Procedure_Specification)
16765 Spec_Id := Defining_Unit_Name (Context);
16766 Chain_Pragma (Spec_Id, N);
16768 -- The pragma is immediately within a package or subprogram
16771 -- function F ... is
16772 -- pragma SPARK_Mode;
16774 -- package body P is
16775 -- pragma SPARK_Mode;
16777 elsif Nkind_In (Context, N_Package_Body,
16780 Spec_Id := Corresponding_Spec (Context);
16782 if Nkind (Context) = N_Subprogram_Body then
16783 Context := Specification (Context);
16786 Body_Id := Defining_Unit_Name (Context);
16788 Chain_Pragma (Body_Id, N);
16790 -- Verify that the SPARK modes are consistent between
16791 -- body and spec, if any.
16793 if Present (Spec_Id) then
16794 Check_Spark_Mode_Conformance (Spec_Id, Body_Id);
16797 -- The pragma applies to the statements of a package body
16799 -- package body P is
16801 -- pragma SPARK_Mode;
16803 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
16804 and then Nkind (Parent (Context)) = N_Package_Body
16806 Context := Parent (Context);
16807 Spec_Id := Corresponding_Spec (Context);
16808 Body_Id := Defining_Unit_Name (Context);
16810 Chain_Pragma (Body_Id, N);
16811 Check_Spark_Mode_Conformance (Spec_Id, Body_Id);
16813 -- The pragma does not apply to a legal construct, issue error
16821 --------------------------------
16822 -- Static_Elaboration_Desired --
16823 --------------------------------
16825 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
16827 when Pragma_Static_Elaboration_Desired =>
16829 Check_At_Most_N_Arguments (1);
16831 if Is_Compilation_Unit (Current_Scope)
16832 and then Ekind (Current_Scope) = E_Package
16834 Set_Static_Elaboration_Desired (Current_Scope, True);
16836 Error_Pragma ("pragma% must apply to a library-level package");
16843 -- pragma Storage_Size (EXPRESSION);
16845 when Pragma_Storage_Size => Storage_Size : declare
16846 P : constant Node_Id := Parent (N);
16850 Check_No_Identifiers;
16851 Check_Arg_Count (1);
16853 -- The expression must be analyzed in the special manner described
16854 -- in "Handling of Default Expressions" in sem.ads.
16856 Arg := Get_Pragma_Arg (Arg1);
16857 Preanalyze_Spec_Expression (Arg, Any_Integer);
16859 if not Is_Static_Expression (Arg) then
16860 Check_Restriction (Static_Storage_Size, Arg);
16863 if Nkind (P) /= N_Task_Definition then
16868 if Has_Storage_Size_Pragma (P) then
16869 Error_Pragma ("duplicate pragma% not allowed");
16871 Set_Has_Storage_Size_Pragma (P, True);
16874 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
16882 -- pragma Storage_Unit (NUMERIC_LITERAL);
16884 -- Only permitted argument is System'Storage_Unit value
16886 when Pragma_Storage_Unit =>
16887 Check_No_Identifiers;
16888 Check_Arg_Count (1);
16889 Check_Arg_Is_Integer_Literal (Arg1);
16891 if Intval (Get_Pragma_Arg (Arg1)) /=
16892 UI_From_Int (Ttypes.System_Storage_Unit)
16894 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
16896 ("the only allowed argument for pragma% is ^", Arg1);
16899 --------------------
16900 -- Stream_Convert --
16901 --------------------
16903 -- pragma Stream_Convert (
16904 -- [Entity =>] type_LOCAL_NAME,
16905 -- [Read =>] function_NAME,
16906 -- [Write =>] function NAME);
16908 when Pragma_Stream_Convert => Stream_Convert : declare
16910 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
16911 -- Check that the given argument is the name of a local function
16912 -- of one argument that is not overloaded earlier in the current
16913 -- local scope. A check is also made that the argument is a
16914 -- function with one parameter.
16916 --------------------------------------
16917 -- Check_OK_Stream_Convert_Function --
16918 --------------------------------------
16920 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
16924 Check_Arg_Is_Local_Name (Arg);
16925 Ent := Entity (Get_Pragma_Arg (Arg));
16927 if Has_Homonym (Ent) then
16929 ("argument for pragma% may not be overloaded", Arg);
16932 if Ekind (Ent) /= E_Function
16933 or else No (First_Formal (Ent))
16934 or else Present (Next_Formal (First_Formal (Ent)))
16937 ("argument for pragma% must be function of one argument",
16940 end Check_OK_Stream_Convert_Function;
16942 -- Start of processing for Stream_Convert
16946 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
16947 Check_Arg_Count (3);
16948 Check_Optional_Identifier (Arg1, Name_Entity);
16949 Check_Optional_Identifier (Arg2, Name_Read);
16950 Check_Optional_Identifier (Arg3, Name_Write);
16951 Check_Arg_Is_Local_Name (Arg1);
16952 Check_OK_Stream_Convert_Function (Arg2);
16953 Check_OK_Stream_Convert_Function (Arg3);
16956 Typ : constant Entity_Id :=
16957 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
16958 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
16959 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
16962 Check_First_Subtype (Arg1);
16964 -- Check for too early or too late. Note that we don't enforce
16965 -- the rule about primitive operations in this case, since, as
16966 -- is the case for explicit stream attributes themselves, these
16967 -- restrictions are not appropriate. Note that the chaining of
16968 -- the pragma by Rep_Item_Too_Late is actually the critical
16969 -- processing done for this pragma.
16971 if Rep_Item_Too_Early (Typ, N)
16973 Rep_Item_Too_Late (Typ, N, FOnly => True)
16978 -- Return if previous error
16980 if Etype (Typ) = Any_Type
16982 Etype (Read) = Any_Type
16984 Etype (Write) = Any_Type
16991 if Underlying_Type (Etype (Read)) /= Typ then
16993 ("incorrect return type for function&", Arg2);
16996 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
16998 ("incorrect parameter type for function&", Arg3);
17001 if Underlying_Type (Etype (First_Formal (Read))) /=
17002 Underlying_Type (Etype (Write))
17005 ("result type of & does not match Read parameter type",
17009 end Stream_Convert;
17015 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
17017 -- This is processed by the parser since some of the style checks
17018 -- take place during source scanning and parsing. This means that
17019 -- we don't need to issue error messages here.
17021 when Pragma_Style_Checks => Style_Checks : declare
17022 A : constant Node_Id := Get_Pragma_Arg (Arg1);
17028 Check_No_Identifiers;
17030 -- Two argument form
17032 if Arg_Count = 2 then
17033 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
17040 E_Id := Get_Pragma_Arg (Arg2);
17043 if not Is_Entity_Name (E_Id) then
17045 ("second argument of pragma% must be entity name",
17049 E := Entity (E_Id);
17051 if not Ignore_Style_Checks_Pragmas then
17056 Set_Suppress_Style_Checks
17057 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off);
17058 exit when No (Homonym (E));
17065 -- One argument form
17068 Check_Arg_Count (1);
17070 if Nkind (A) = N_String_Literal then
17074 Slen : constant Natural := Natural (String_Length (S));
17075 Options : String (1 .. Slen);
17081 C := Get_String_Char (S, Int (J));
17082 exit when not In_Character_Range (C);
17083 Options (J) := Get_Character (C);
17085 -- If at end of string, set options. As per discussion
17086 -- above, no need to check for errors, since we issued
17087 -- them in the parser.
17090 if not Ignore_Style_Checks_Pragmas then
17091 Set_Style_Check_Options (Options);
17101 elsif Nkind (A) = N_Identifier then
17102 if Chars (A) = Name_All_Checks then
17103 if not Ignore_Style_Checks_Pragmas then
17105 Set_GNAT_Style_Check_Options;
17107 Set_Default_Style_Check_Options;
17111 elsif Chars (A) = Name_On then
17112 if not Ignore_Style_Checks_Pragmas then
17113 Style_Check := True;
17116 elsif Chars (A) = Name_Off then
17117 if not Ignore_Style_Checks_Pragmas then
17118 Style_Check := False;
17129 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
17131 when Pragma_Subtitle =>
17133 Check_Arg_Count (1);
17134 Check_Optional_Identifier (Arg1, Name_Subtitle);
17135 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
17142 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
17144 when Pragma_Suppress =>
17145 Process_Suppress_Unsuppress (True);
17151 -- pragma Suppress_All;
17153 -- The only check made here is that the pragma has no arguments.
17154 -- There are no placement rules, and the processing required (setting
17155 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
17156 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
17157 -- then creates and inserts a pragma Suppress (All_Checks).
17159 when Pragma_Suppress_All =>
17161 Check_Arg_Count (0);
17163 -------------------------
17164 -- Suppress_Debug_Info --
17165 -------------------------
17167 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
17169 when Pragma_Suppress_Debug_Info =>
17171 Check_Arg_Count (1);
17172 Check_Optional_Identifier (Arg1, Name_Entity);
17173 Check_Arg_Is_Local_Name (Arg1);
17174 Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1)));
17176 ----------------------------------
17177 -- Suppress_Exception_Locations --
17178 ----------------------------------
17180 -- pragma Suppress_Exception_Locations;
17182 when Pragma_Suppress_Exception_Locations =>
17184 Check_Arg_Count (0);
17185 Check_Valid_Configuration_Pragma;
17186 Exception_Locations_Suppressed := True;
17188 -----------------------------
17189 -- Suppress_Initialization --
17190 -----------------------------
17192 -- pragma Suppress_Initialization ([Entity =>] type_Name);
17194 when Pragma_Suppress_Initialization => Suppress_Init : declare
17200 Check_Arg_Count (1);
17201 Check_Optional_Identifier (Arg1, Name_Entity);
17202 Check_Arg_Is_Local_Name (Arg1);
17204 E_Id := Get_Pragma_Arg (Arg1);
17206 if Etype (E_Id) = Any_Type then
17210 E := Entity (E_Id);
17212 if not Is_Type (E) then
17213 Error_Pragma_Arg ("pragma% requires type or subtype", Arg1);
17216 if Rep_Item_Too_Early (E, N)
17218 Rep_Item_Too_Late (E, N, FOnly => True)
17223 -- For incomplete/private type, set flag on full view
17225 if Is_Incomplete_Or_Private_Type (E) then
17226 if No (Full_View (Base_Type (E))) then
17228 ("argument of pragma% cannot be an incomplete type", Arg1);
17230 Set_Suppress_Initialization (Full_View (Base_Type (E)));
17233 -- For first subtype, set flag on base type
17235 elsif Is_First_Subtype (E) then
17236 Set_Suppress_Initialization (Base_Type (E));
17238 -- For other than first subtype, set flag on subtype itself
17241 Set_Suppress_Initialization (E);
17249 -- pragma System_Name (DIRECT_NAME);
17251 -- Syntax check: one argument, which must be the identifier GNAT or
17252 -- the identifier GCC, no other identifiers are acceptable.
17254 when Pragma_System_Name =>
17256 Check_No_Identifiers;
17257 Check_Arg_Count (1);
17258 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
17260 -----------------------------
17261 -- Task_Dispatching_Policy --
17262 -----------------------------
17264 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
17266 when Pragma_Task_Dispatching_Policy => declare
17270 Check_Ada_83_Warning;
17271 Check_Arg_Count (1);
17272 Check_No_Identifiers;
17273 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
17274 Check_Valid_Configuration_Pragma;
17275 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
17276 DP := Fold_Upper (Name_Buffer (1));
17278 if Task_Dispatching_Policy /= ' '
17279 and then Task_Dispatching_Policy /= DP
17281 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
17283 ("task dispatching policy incompatible with policy#");
17285 -- Set new policy, but always preserve System_Location since we
17286 -- like the error message with the run time name.
17289 Task_Dispatching_Policy := DP;
17291 if Task_Dispatching_Policy_Sloc /= System_Location then
17292 Task_Dispatching_Policy_Sloc := Loc;
17301 -- pragma Task_Info (EXPRESSION);
17303 when Pragma_Task_Info => Task_Info : declare
17304 P : constant Node_Id := Parent (N);
17310 if Nkind (P) /= N_Task_Definition then
17311 Error_Pragma ("pragma% must appear in task definition");
17314 Check_No_Identifiers;
17315 Check_Arg_Count (1);
17317 Analyze_And_Resolve
17318 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
17320 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
17324 Ent := Defining_Identifier (Parent (P));
17326 -- Check duplicate pragma before we chain the pragma in the Rep
17327 -- Item chain of Ent.
17330 (Ent, Name_Task_Info, Check_Parents => False)
17332 Error_Pragma ("duplicate pragma% not allowed");
17335 Record_Rep_Item (Ent, N);
17342 -- pragma Task_Name (string_EXPRESSION);
17344 when Pragma_Task_Name => Task_Name : declare
17345 P : constant Node_Id := Parent (N);
17350 Check_No_Identifiers;
17351 Check_Arg_Count (1);
17353 Arg := Get_Pragma_Arg (Arg1);
17355 -- The expression is used in the call to Create_Task, and must be
17356 -- expanded there, not in the context of the current spec. It must
17357 -- however be analyzed to capture global references, in case it
17358 -- appears in a generic context.
17360 Preanalyze_And_Resolve (Arg, Standard_String);
17362 if Nkind (P) /= N_Task_Definition then
17366 Ent := Defining_Identifier (Parent (P));
17368 -- Check duplicate pragma before we chain the pragma in the Rep
17369 -- Item chain of Ent.
17372 (Ent, Name_Task_Name, Check_Parents => False)
17374 Error_Pragma ("duplicate pragma% not allowed");
17377 Record_Rep_Item (Ent, N);
17384 -- pragma Task_Storage (
17385 -- [Task_Type =>] LOCAL_NAME,
17386 -- [Top_Guard =>] static_integer_EXPRESSION);
17388 when Pragma_Task_Storage => Task_Storage : declare
17389 Args : Args_List (1 .. 2);
17390 Names : constant Name_List (1 .. 2) := (
17394 Task_Type : Node_Id renames Args (1);
17395 Top_Guard : Node_Id renames Args (2);
17401 Gather_Associations (Names, Args);
17403 if No (Task_Type) then
17405 ("missing task_type argument for pragma%");
17408 Check_Arg_Is_Local_Name (Task_Type);
17410 Ent := Entity (Task_Type);
17412 if not Is_Task_Type (Ent) then
17414 ("argument for pragma% must be task type", Task_Type);
17417 if No (Top_Guard) then
17419 ("pragma% takes two arguments", Task_Type);
17421 Check_Arg_Is_Static_Expression (Top_Guard, Any_Integer);
17424 Check_First_Subtype (Task_Type);
17426 if Rep_Item_Too_Late (Ent, N) then
17435 -- pragma Test_Case
17436 -- ([Name =>] Static_String_EXPRESSION
17437 -- ,[Mode =>] MODE_TYPE
17438 -- [, Requires => Boolean_EXPRESSION]
17439 -- [, Ensures => Boolean_EXPRESSION]);
17441 -- MODE_TYPE ::= Nominal | Robustness
17443 when Pragma_Test_Case =>
17447 --------------------------
17448 -- Thread_Local_Storage --
17449 --------------------------
17451 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
17453 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
17459 Check_Arg_Count (1);
17460 Check_Optional_Identifier (Arg1, Name_Entity);
17461 Check_Arg_Is_Library_Level_Local_Name (Arg1);
17463 Id := Get_Pragma_Arg (Arg1);
17466 if not Is_Entity_Name (Id)
17467 or else Ekind (Entity (Id)) /= E_Variable
17469 Error_Pragma_Arg ("local variable name required", Arg1);
17474 if Rep_Item_Too_Early (E, N)
17475 or else Rep_Item_Too_Late (E, N)
17480 Set_Has_Pragma_Thread_Local_Storage (E);
17481 Set_Has_Gigi_Rep_Item (E);
17482 end Thread_Local_Storage;
17488 -- pragma Time_Slice (static_duration_EXPRESSION);
17490 when Pragma_Time_Slice => Time_Slice : declare
17496 Check_Arg_Count (1);
17497 Check_No_Identifiers;
17498 Check_In_Main_Program;
17499 Check_Arg_Is_Static_Expression (Arg1, Standard_Duration);
17501 if not Error_Posted (Arg1) then
17503 while Present (Nod) loop
17504 if Nkind (Nod) = N_Pragma
17505 and then Pragma_Name (Nod) = Name_Time_Slice
17507 Error_Msg_Name_1 := Pname;
17508 Error_Msg_N ("duplicate pragma% not permitted", Nod);
17515 -- Process only if in main unit
17517 if Get_Source_Unit (Loc) = Main_Unit then
17518 Opt.Time_Slice_Set := True;
17519 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
17521 if Val <= Ureal_0 then
17522 Opt.Time_Slice_Value := 0;
17524 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
17525 Opt.Time_Slice_Value := 1_000_000_000;
17528 Opt.Time_Slice_Value :=
17529 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
17538 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
17540 -- TITLING_OPTION ::=
17541 -- [Title =>] STRING_LITERAL
17542 -- | [Subtitle =>] STRING_LITERAL
17544 when Pragma_Title => Title : declare
17545 Args : Args_List (1 .. 2);
17546 Names : constant Name_List (1 .. 2) := (
17552 Gather_Associations (Names, Args);
17555 for J in 1 .. 2 loop
17556 if Present (Args (J)) then
17557 Check_Arg_Is_Static_Expression (Args (J), Standard_String);
17562 ---------------------
17563 -- Unchecked_Union --
17564 ---------------------
17566 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
17568 when Pragma_Unchecked_Union => Unchecked_Union : declare
17569 Assoc : constant Node_Id := Arg1;
17570 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
17580 Check_No_Identifiers;
17581 Check_Arg_Count (1);
17582 Check_Arg_Is_Local_Name (Arg1);
17584 Find_Type (Type_Id);
17586 Typ := Entity (Type_Id);
17589 or else Rep_Item_Too_Early (Typ, N)
17593 Typ := Underlying_Type (Typ);
17596 if Rep_Item_Too_Late (Typ, N) then
17600 Check_First_Subtype (Arg1);
17602 -- Note remaining cases are references to a type in the current
17603 -- declarative part. If we find an error, we post the error on
17604 -- the relevant type declaration at an appropriate point.
17606 if not Is_Record_Type (Typ) then
17607 Error_Msg_N ("unchecked union must be record type", Typ);
17610 elsif Is_Tagged_Type (Typ) then
17611 Error_Msg_N ("unchecked union must not be tagged", Typ);
17614 elsif not Has_Discriminants (Typ) then
17616 ("unchecked union must have one discriminant", Typ);
17619 -- Note: in previous versions of GNAT we used to check for limited
17620 -- types and give an error, but in fact the standard does allow
17621 -- Unchecked_Union on limited types, so this check was removed.
17623 -- Similarly, GNAT used to require that all discriminants have
17624 -- default values, but this is not mandated by the RM.
17626 -- Proceed with basic error checks completed
17629 Tdef := Type_Definition (Declaration_Node (Typ));
17630 Clist := Component_List (Tdef);
17632 -- Check presence of component list and variant part
17634 if No (Clist) or else No (Variant_Part (Clist)) then
17636 ("unchecked union must have variant part", Tdef);
17640 -- Check components
17642 Comp := First (Component_Items (Clist));
17643 while Present (Comp) loop
17644 Check_Component (Comp, Typ);
17648 -- Check variant part
17650 Vpart := Variant_Part (Clist);
17652 Variant := First (Variants (Vpart));
17653 while Present (Variant) loop
17654 Check_Variant (Variant, Typ);
17659 Set_Is_Unchecked_Union (Typ);
17660 Set_Convention (Typ, Convention_C);
17661 Set_Has_Unchecked_Union (Base_Type (Typ));
17662 Set_Is_Unchecked_Union (Base_Type (Typ));
17663 end Unchecked_Union;
17665 ------------------------
17666 -- Unimplemented_Unit --
17667 ------------------------
17669 -- pragma Unimplemented_Unit;
17671 -- Note: this only gives an error if we are generating code, or if
17672 -- we are in a generic library unit (where the pragma appears in the
17673 -- body, not in the spec).
17675 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
17676 Cunitent : constant Entity_Id :=
17677 Cunit_Entity (Get_Source_Unit (Loc));
17678 Ent_Kind : constant Entity_Kind :=
17683 Check_Arg_Count (0);
17685 if Operating_Mode = Generate_Code
17686 or else Ent_Kind = E_Generic_Function
17687 or else Ent_Kind = E_Generic_Procedure
17688 or else Ent_Kind = E_Generic_Package
17690 Get_Name_String (Chars (Cunitent));
17691 Set_Casing (Mixed_Case);
17692 Write_Str (Name_Buffer (1 .. Name_Len));
17693 Write_Str (" is not supported in this configuration");
17695 raise Unrecoverable_Error;
17697 end Unimplemented_Unit;
17699 ------------------------
17700 -- Universal_Aliasing --
17701 ------------------------
17703 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
17705 when Pragma_Universal_Aliasing => Universal_Alias : declare
17710 Check_Arg_Count (1);
17711 Check_Optional_Identifier (Arg2, Name_Entity);
17712 Check_Arg_Is_Local_Name (Arg1);
17713 E_Id := Entity (Get_Pragma_Arg (Arg1));
17715 if E_Id = Any_Type then
17717 elsif No (E_Id) or else not Is_Type (E_Id) then
17718 Error_Pragma_Arg ("pragma% requires type", Arg1);
17721 Set_Universal_Aliasing (Implementation_Base_Type (E_Id));
17722 Record_Rep_Item (E_Id, N);
17723 end Universal_Alias;
17725 --------------------
17726 -- Universal_Data --
17727 --------------------
17729 -- pragma Universal_Data [(library_unit_NAME)];
17731 when Pragma_Universal_Data =>
17734 -- If this is a configuration pragma, then set the universal
17735 -- addressing option, otherwise confirm that the pragma satisfies
17736 -- the requirements of library unit pragma placement and leave it
17737 -- to the GNAAMP back end to detect the pragma (avoids transitive
17738 -- setting of the option due to withed units).
17740 if Is_Configuration_Pragma then
17741 Universal_Addressing_On_AAMP := True;
17743 Check_Valid_Library_Unit_Pragma;
17746 if not AAMP_On_Target then
17747 Error_Pragma ("??pragma% ignored (applies only to AAMP)");
17754 -- pragma Unmodified (local_Name {, local_Name});
17756 when Pragma_Unmodified => Unmodified : declare
17757 Arg_Node : Node_Id;
17758 Arg_Expr : Node_Id;
17759 Arg_Ent : Entity_Id;
17763 Check_At_Least_N_Arguments (1);
17765 -- Loop through arguments
17768 while Present (Arg_Node) loop
17769 Check_No_Identifier (Arg_Node);
17771 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
17772 -- in fact generate reference, so that the entity will have a
17773 -- reference, which will inhibit any warnings about it not
17774 -- being referenced, and also properly show up in the ali file
17775 -- as a reference. But this reference is recorded before the
17776 -- Has_Pragma_Unreferenced flag is set, so that no warning is
17777 -- generated for this reference.
17779 Check_Arg_Is_Local_Name (Arg_Node);
17780 Arg_Expr := Get_Pragma_Arg (Arg_Node);
17782 if Is_Entity_Name (Arg_Expr) then
17783 Arg_Ent := Entity (Arg_Expr);
17785 if not Is_Assignable (Arg_Ent) then
17787 ("pragma% can only be applied to a variable",
17790 Set_Has_Pragma_Unmodified (Arg_Ent);
17802 -- pragma Unreferenced (local_Name {, local_Name});
17804 -- or when used in a context clause:
17806 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
17808 when Pragma_Unreferenced => Unreferenced : declare
17809 Arg_Node : Node_Id;
17810 Arg_Expr : Node_Id;
17811 Arg_Ent : Entity_Id;
17816 Check_At_Least_N_Arguments (1);
17818 -- Check case of appearing within context clause
17820 if Is_In_Context_Clause then
17822 -- The arguments must all be units mentioned in a with clause
17823 -- in the same context clause. Note we already checked (in
17824 -- Par.Prag) that the arguments are either identifiers or
17825 -- selected components.
17828 while Present (Arg_Node) loop
17829 Citem := First (List_Containing (N));
17830 while Citem /= N loop
17831 if Nkind (Citem) = N_With_Clause
17833 Same_Name (Name (Citem), Get_Pragma_Arg (Arg_Node))
17835 Set_Has_Pragma_Unreferenced
17838 (Library_Unit (Citem))));
17840 (Get_Pragma_Arg (Arg_Node), Name (Citem));
17849 ("argument of pragma% is not withed unit", Arg_Node);
17855 -- Case of not in list of context items
17859 while Present (Arg_Node) loop
17860 Check_No_Identifier (Arg_Node);
17862 -- Note: the analyze call done by Check_Arg_Is_Local_Name
17863 -- will in fact generate reference, so that the entity will
17864 -- have a reference, which will inhibit any warnings about
17865 -- it not being referenced, and also properly show up in the
17866 -- ali file as a reference. But this reference is recorded
17867 -- before the Has_Pragma_Unreferenced flag is set, so that
17868 -- no warning is generated for this reference.
17870 Check_Arg_Is_Local_Name (Arg_Node);
17871 Arg_Expr := Get_Pragma_Arg (Arg_Node);
17873 if Is_Entity_Name (Arg_Expr) then
17874 Arg_Ent := Entity (Arg_Expr);
17876 -- If the entity is overloaded, the pragma applies to the
17877 -- most recent overloading, as documented. In this case,
17878 -- name resolution does not generate a reference, so it
17879 -- must be done here explicitly.
17881 if Is_Overloaded (Arg_Expr) then
17882 Generate_Reference (Arg_Ent, N);
17885 Set_Has_Pragma_Unreferenced (Arg_Ent);
17893 --------------------------
17894 -- Unreferenced_Objects --
17895 --------------------------
17897 -- pragma Unreferenced_Objects (local_Name {, local_Name});
17899 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
17900 Arg_Node : Node_Id;
17901 Arg_Expr : Node_Id;
17905 Check_At_Least_N_Arguments (1);
17908 while Present (Arg_Node) loop
17909 Check_No_Identifier (Arg_Node);
17910 Check_Arg_Is_Local_Name (Arg_Node);
17911 Arg_Expr := Get_Pragma_Arg (Arg_Node);
17913 if not Is_Entity_Name (Arg_Expr)
17914 or else not Is_Type (Entity (Arg_Expr))
17917 ("argument for pragma% must be type or subtype", Arg_Node);
17920 Set_Has_Pragma_Unreferenced_Objects (Entity (Arg_Expr));
17923 end Unreferenced_Objects;
17925 ------------------------------
17926 -- Unreserve_All_Interrupts --
17927 ------------------------------
17929 -- pragma Unreserve_All_Interrupts;
17931 when Pragma_Unreserve_All_Interrupts =>
17933 Check_Arg_Count (0);
17935 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
17936 Unreserve_All_Interrupts := True;
17943 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
17945 when Pragma_Unsuppress =>
17947 Process_Suppress_Unsuppress (False);
17949 -------------------
17950 -- Use_VADS_Size --
17951 -------------------
17953 -- pragma Use_VADS_Size;
17955 when Pragma_Use_VADS_Size =>
17957 Check_Arg_Count (0);
17958 Check_Valid_Configuration_Pragma;
17959 Use_VADS_Size := True;
17961 ---------------------
17962 -- Validity_Checks --
17963 ---------------------
17965 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
17967 when Pragma_Validity_Checks => Validity_Checks : declare
17968 A : constant Node_Id := Get_Pragma_Arg (Arg1);
17974 Check_Arg_Count (1);
17975 Check_No_Identifiers;
17977 if Nkind (A) = N_String_Literal then
17981 Slen : constant Natural := Natural (String_Length (S));
17982 Options : String (1 .. Slen);
17988 C := Get_String_Char (S, Int (J));
17989 exit when not In_Character_Range (C);
17990 Options (J) := Get_Character (C);
17993 Set_Validity_Check_Options (Options);
18001 elsif Nkind (A) = N_Identifier then
18002 if Chars (A) = Name_All_Checks then
18003 Set_Validity_Check_Options ("a");
18004 elsif Chars (A) = Name_On then
18005 Validity_Checks_On := True;
18006 elsif Chars (A) = Name_Off then
18007 Validity_Checks_On := False;
18010 end Validity_Checks;
18016 -- pragma Volatile (LOCAL_NAME);
18018 when Pragma_Volatile =>
18019 Process_Atomic_Shared_Volatile;
18021 -------------------------
18022 -- Volatile_Components --
18023 -------------------------
18025 -- pragma Volatile_Components (array_LOCAL_NAME);
18027 -- Volatile is handled by the same circuit as Atomic_Components
18033 -- pragma Warnings (On | Off [,REASON]);
18034 -- pragma Warnings (On | Off, LOCAL_NAME [,REASON]);
18035 -- pragma Warnings (static_string_EXPRESSION [,REASON]);
18036 -- pragma Warnings (On | Off, STRING_LITERAL [,REASON]);
18038 -- REASON ::= Reason => Static_String_Expression
18040 when Pragma_Warnings => Warnings : begin
18042 Check_At_Least_N_Arguments (1);
18044 -- See if last argument is labeled Reason. If so, make sure we
18045 -- have a static string expression, but otherwise just ignore
18046 -- the REASON argument by decreasing Num_Args by 1 (all the
18047 -- remaining tests look only at the first Num_Args arguments).
18050 Last_Arg : constant Node_Id :=
18051 Last (Pragma_Argument_Associations (N));
18053 if Nkind (Last_Arg) = N_Pragma_Argument_Association
18054 and then Chars (Last_Arg) = Name_Reason
18056 Check_Arg_Is_Static_Expression (Last_Arg, Standard_String);
18057 Arg_Count := Arg_Count - 1;
18059 -- Not allowed in compiler units (bootstrap issues)
18061 Check_Compiler_Unit (N);
18065 -- Now proceed with REASON taken care of and eliminated
18067 Check_No_Identifiers;
18069 -- If debug flag -gnatd.i is set, pragma is ignored
18071 if Debug_Flag_Dot_I then
18075 -- Process various forms of the pragma
18078 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
18081 -- One argument case
18083 if Arg_Count = 1 then
18085 -- On/Off one argument case was processed by parser
18087 if Nkind (Argx) = N_Identifier
18088 and then Nam_In (Chars (Argx), Name_On, Name_Off)
18092 -- One argument case must be ON/OFF or static string expr
18094 elsif not Is_Static_String_Expression (Arg1) then
18096 ("argument of pragma% must be On/Off or static string "
18097 & "expression", Arg1);
18099 -- One argument string expression case
18103 Lit : constant Node_Id := Expr_Value_S (Argx);
18104 Str : constant String_Id := Strval (Lit);
18105 Len : constant Nat := String_Length (Str);
18113 while J <= Len loop
18114 C := Get_String_Char (Str, J);
18115 OK := In_Character_Range (C);
18118 Chr := Get_Character (C);
18120 -- Dash case: only -Wxxx is accepted
18127 C := Get_String_Char (Str, J);
18128 Chr := Get_Character (C);
18129 exit when Chr = 'W';
18134 elsif J < Len and then Chr = '.' then
18136 C := Get_String_Char (Str, J);
18137 Chr := Get_Character (C);
18139 if not Set_Dot_Warning_Switch (Chr) then
18141 ("invalid warning switch character "
18142 & '.' & Chr, Arg1);
18148 OK := Set_Warning_Switch (Chr);
18154 ("invalid warning switch character " & Chr,
18163 -- Two or more arguments (must be two)
18166 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
18167 Check_At_Most_N_Arguments (2);
18175 E_Id := Get_Pragma_Arg (Arg2);
18178 -- In the expansion of an inlined body, a reference to
18179 -- the formal may be wrapped in a conversion if the
18180 -- actual is a conversion. Retrieve the real entity name.
18182 if (In_Instance_Body or In_Inlined_Body)
18183 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
18185 E_Id := Expression (E_Id);
18188 -- Entity name case
18190 if Is_Entity_Name (E_Id) then
18191 E := Entity (E_Id);
18198 (E, (Chars (Get_Pragma_Arg (Arg1)) =
18201 -- For OFF case, make entry in warnings off
18202 -- pragma table for later processing. But we do
18203 -- not do that within an instance, since these
18204 -- warnings are about what is needed in the
18205 -- template, not an instance of it.
18207 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
18208 and then Warn_On_Warnings_Off
18209 and then not In_Instance
18211 Warnings_Off_Pragmas.Append ((N, E));
18214 if Is_Enumeration_Type (E) then
18218 Lit := First_Literal (E);
18219 while Present (Lit) loop
18220 Set_Warnings_Off (Lit);
18221 Next_Literal (Lit);
18226 exit when No (Homonym (E));
18231 -- Error if not entity or static string literal case
18233 elsif not Is_Static_String_Expression (Arg2) then
18235 ("second argument of pragma% must be entity name "
18236 & "or static string expression", Arg2);
18238 -- String literal case
18241 String_To_Name_Buffer
18242 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg2))));
18244 -- Note on configuration pragma case: If this is a
18245 -- configuration pragma, then for an OFF pragma, we
18246 -- just set Config True in the call, which is all
18247 -- that needs to be done. For the case of ON, this
18248 -- is normally an error, unless it is canceling the
18249 -- effect of a previous OFF pragma in the same file.
18250 -- In any other case, an error will be signalled (ON
18251 -- with no matching OFF).
18253 -- Note: We set Used if we are inside a generic to
18254 -- disable the test that the non-config case actually
18255 -- cancels a warning. That's because we can't be sure
18256 -- there isn't an instantiation in some other unit
18257 -- where a warning is suppressed.
18259 -- We could do a little better here by checking if the
18260 -- generic unit we are inside is public, but for now
18261 -- we don't bother with that refinement.
18263 if Chars (Argx) = Name_Off then
18264 Set_Specific_Warning_Off
18265 (Loc, Name_Buffer (1 .. Name_Len),
18266 Config => Is_Configuration_Pragma,
18267 Used => Inside_A_Generic or else In_Instance);
18269 elsif Chars (Argx) = Name_On then
18270 Set_Specific_Warning_On
18271 (Loc, Name_Buffer (1 .. Name_Len), Err);
18275 ("??pragma Warnings On with no matching "
18276 & "Warnings Off", Loc);
18285 -------------------
18286 -- Weak_External --
18287 -------------------
18289 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
18291 when Pragma_Weak_External => Weak_External : declare
18296 Check_Arg_Count (1);
18297 Check_Optional_Identifier (Arg1, Name_Entity);
18298 Check_Arg_Is_Library_Level_Local_Name (Arg1);
18299 Ent := Entity (Get_Pragma_Arg (Arg1));
18301 if Rep_Item_Too_Early (Ent, N) then
18304 Ent := Underlying_Type (Ent);
18307 -- The only processing required is to link this item on to the
18308 -- list of rep items for the given entity. This is accomplished
18309 -- by the call to Rep_Item_Too_Late (when no error is detected
18310 -- and False is returned).
18312 if Rep_Item_Too_Late (Ent, N) then
18315 Set_Has_Gigi_Rep_Item (Ent);
18319 -----------------------------
18320 -- Wide_Character_Encoding --
18321 -----------------------------
18323 -- pragma Wide_Character_Encoding (IDENTIFIER);
18325 when Pragma_Wide_Character_Encoding =>
18328 -- Nothing to do, handled in parser. Note that we do not enforce
18329 -- configuration pragma placement, this pragma can appear at any
18330 -- place in the source, allowing mixed encodings within a single
18335 --------------------
18336 -- Unknown_Pragma --
18337 --------------------
18339 -- Should be impossible, since the case of an unknown pragma is
18340 -- separately processed before the case statement is entered.
18342 when Unknown_Pragma =>
18343 raise Program_Error;
18346 -- AI05-0144: detect dangerous order dependence. Disabled for now,
18347 -- until AI is formally approved.
18349 -- Check_Order_Dependence;
18352 when Pragma_Exit => null;
18353 end Analyze_Pragma;
18355 ---------------------------------------------
18356 -- Analyze_Pre_Post_Condition_In_Decl_Part --
18357 ---------------------------------------------
18359 procedure Analyze_Pre_Post_Condition_In_Decl_Part
18361 Subp_Id : Entity_Id)
18363 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (Prag));
18366 Restore_Scope : Boolean := False;
18367 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
18370 -- Ensure that the subprogram and its formals are visible when analyzing
18371 -- the expression of the pragma.
18373 if Current_Scope /= Subp_Id then
18374 Restore_Scope := True;
18375 Push_Scope (Subp_Id);
18376 Install_Formals (Subp_Id);
18379 -- Preanalyze the boolean expression, we treat this as a spec expression
18380 -- (i.e. similar to a default expression).
18382 Expr := Get_Pragma_Arg (Arg1);
18384 -- In ASIS mode, for a pragma generated from a source aspect, analyze
18385 -- the original aspect expression, which is shared with the generated
18388 if ASIS_Mode and then Present (Corresponding_Aspect (Prag)) then
18389 Expr := Expression (Corresponding_Aspect (Prag));
18392 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
18394 -- For a class-wide condition, a reference to a controlling formal must
18395 -- be interpreted as having the class-wide type (or an access to such)
18396 -- so that the inherited condition can be properly applied to any
18397 -- overriding operation (see ARM12 6.6.1 (7)).
18399 if Class_Present (Prag) then
18400 Class_Wide_Condition : declare
18401 T : constant Entity_Id := Find_Dispatching_Type (Subp_Id);
18403 ACW : Entity_Id := Empty;
18404 -- Access to T'class, created if there is a controlling formal
18405 -- that is an access parameter.
18407 function Get_ACW return Entity_Id;
18408 -- If the expression has a reference to an controlling access
18409 -- parameter, create an access to T'class for the necessary
18410 -- conversions if one does not exist.
18412 function Process (N : Node_Id) return Traverse_Result;
18413 -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
18414 -- aspect for a primitive subprogram of a tagged type T, a name
18415 -- that denotes a formal parameter of type T is interpreted as
18416 -- having type T'Class. Similarly, a name that denotes a formal
18417 -- accessparameter of type access-to-T is interpreted as having
18418 -- type access-to-T'Class. This ensures the expression is well-
18419 -- defined for a primitive subprogram of a type descended from T.
18420 -- Note that this replacement is not done for selector names in
18421 -- parameter associations. These carry an entity for reference
18422 -- purposes, but semantically they are just identifiers.
18428 function Get_ACW return Entity_Id is
18429 Loc : constant Source_Ptr := Sloc (Prag);
18435 Make_Full_Type_Declaration (Loc,
18436 Defining_Identifier => Make_Temporary (Loc, 'T'),
18438 Make_Access_To_Object_Definition (Loc,
18439 Subtype_Indication =>
18440 New_Occurrence_Of (Class_Wide_Type (T), Loc),
18441 All_Present => True));
18443 Insert_Before (Unit_Declaration_Node (Subp_Id), Decl);
18445 ACW := Defining_Identifier (Decl);
18446 Freeze_Before (Unit_Declaration_Node (Subp_Id), ACW);
18456 function Process (N : Node_Id) return Traverse_Result is
18457 Loc : constant Source_Ptr := Sloc (N);
18461 if Is_Entity_Name (N)
18462 and then Present (Entity (N))
18463 and then Is_Formal (Entity (N))
18464 and then Nkind (Parent (N)) /= N_Type_Conversion
18466 (Nkind (Parent (N)) /= N_Parameter_Association
18467 or else N /= Selector_Name (Parent (N)))
18469 if Etype (Entity (N)) = T then
18470 Typ := Class_Wide_Type (T);
18472 elsif Is_Access_Type (Etype (Entity (N)))
18473 and then Designated_Type (Etype (Entity (N))) = T
18480 if Present (Typ) then
18482 Make_Type_Conversion (Loc,
18484 New_Occurrence_Of (Typ, Loc),
18485 Expression => New_Occurrence_Of (Entity (N), Loc)));
18486 Set_Etype (N, Typ);
18493 procedure Replace_Type is new Traverse_Proc (Process);
18495 -- Start of processing for Class_Wide_Condition
18498 if not Present (T) then
18499 Error_Msg_Name_1 :=
18500 Chars (Identifier (Corresponding_Aspect (Prag)));
18502 Error_Msg_Name_2 := Name_Class;
18505 ("aspect `%''%` can only be specified for a primitive "
18506 & "operation of a tagged type", Corresponding_Aspect (Prag));
18509 Replace_Type (Get_Pragma_Arg (Arg1));
18510 end Class_Wide_Condition;
18513 -- Remove the subprogram from the scope stack now that the pre-analysis
18514 -- of the precondition/postcondition is done.
18516 if Restore_Scope then
18519 end Analyze_Pre_Post_Condition_In_Decl_Part;
18521 ------------------------------------------
18522 -- Analyze_Refined_Depends_In_Decl_Part --
18523 ------------------------------------------
18525 -- ??? To be implemented
18527 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
18528 pragma Unreferenced (N);
18531 end Analyze_Refined_Depends_In_Decl_Part;
18533 -----------------------------------------
18534 -- Analyze_Refined_Global_In_Decl_Part --
18535 -----------------------------------------
18537 -- ??? To be implemented
18539 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is
18540 pragma Unreferenced (N);
18543 end Analyze_Refined_Global_In_Decl_Part;
18545 ----------------------------------------
18546 -- Analyze_Refined_State_In_Decl_Part --
18547 ----------------------------------------
18549 procedure Analyze_Refined_State_In_Decl_Part (N : Node_Id) is
18550 Pack_Body : constant Node_Id := Parent (N);
18551 Spec_Id : constant Entity_Id := Corresponding_Spec (Pack_Body);
18553 Abstr_States : Elist_Id := No_Elist;
18554 -- A list of all abstract states defined in the package declaration. The
18555 -- list is used to report unrefined states.
18557 Constituents_Seen : Elist_Id := No_Elist;
18558 -- A list that contains all constituents processed so far. The list is
18559 -- used to detect multiple uses of the same constituent.
18561 Hidden_States : Elist_Id := No_Elist;
18562 -- A list of all hidden states (abstract states and variables) that
18563 -- appear in the package spec and body. The list is used to report
18564 -- unused hidden states.
18566 Refined_States_Seen : Elist_Id := No_Elist;
18567 -- A list that contains all refined states processed so far. The list is
18568 -- used to detect duplicate refinements.
18570 procedure Analyze_Refinement_Clause (Clause : Node_Id);
18571 -- Perform full analysis of a single refinement clause
18573 function Collect_Hidden_States return Elist_Id;
18574 -- Gather the entities of all hidden states that appear in the spec and
18575 -- body of the related package.
18577 procedure Report_Unrefined_States;
18578 -- Emit errors for all abstract states that have not been refined by
18581 procedure Report_Unused_Hidden_States;
18582 -- Emit errors for all hidden states of the related package that do not
18583 -- participate in a refinement.
18585 -------------------------------
18586 -- Analyze_Refinement_Clause --
18587 -------------------------------
18589 procedure Analyze_Refinement_Clause (Clause : Node_Id) is
18590 Non_Null_Seen : Boolean := False;
18591 Null_Seen : Boolean := False;
18592 -- Flags used to detect multiple uses of null in a single clause or a
18593 -- mixture of null and non-null constituents.
18595 procedure Analyze_Constituent (Constit : Node_Id);
18596 -- Perform full analysis of a single constituent
18598 procedure Check_Matching_State
18600 State_Id : Entity_Id);
18601 -- Determine whether state State denoted by its name State_Id appears
18602 -- in Abstr_States. Emit an error when attempting to re-refine the
18603 -- state or when the state is not defined in the package declaration.
18604 -- Otherwise remove the state from Abstr_States.
18606 -------------------------
18607 -- Analyze_Constituent --
18608 -------------------------
18610 procedure Analyze_Constituent (Constit : Node_Id) is
18611 procedure Check_Matching_Constituent (Constit_Id : Entity_Id);
18612 -- Determine whether constituent Constit denoted by its entity
18613 -- Constit_Id appears in Hidden_States. Emit an error when the
18614 -- constituent is not a valid hidden state of the related package
18615 -- or when it is used more than once. Otherwise remove the
18616 -- constituent from Hidden_States.
18618 --------------------------------
18619 -- Check_Matching_Constituent --
18620 --------------------------------
18622 procedure Check_Matching_Constituent (Constit_Id : Entity_Id) is
18623 State_Elmt : Elmt_Id;
18626 -- Detect a duplicate use of a constituent
18628 if Contains (Constituents_Seen, Constit_Id) then
18630 ("duplicate use of constituent &", Constit, Constit_Id);
18634 -- Inspect the hidden states of the related package looking for
18637 State_Elmt := First_Elmt (Hidden_States);
18638 while Present (State_Elmt) loop
18640 -- A valid hidden state or variable participates in a
18641 -- refinement. Add the constituent to the list of processed
18642 -- items to aid with the detection of duplicate constituent
18643 -- use. Remove the constituent from Hidden_States to signal
18644 -- that it has already been used.
18646 if Node (State_Elmt) = Constit_Id then
18647 Add_Item (Constit_Id, Constituents_Seen);
18648 Remove_Elmt (Hidden_States, State_Elmt);
18653 Next_Elmt (State_Elmt);
18656 -- If we get here, we are refining a state that is not hidden
18657 -- with respect to the related package.
18659 Error_Msg_Name_1 := Chars (Spec_Id);
18661 ("cannot use & in refinement, constituent is not a hidden "
18662 & "state of package %", Constit, Constit_Id);
18663 end Check_Matching_Constituent;
18667 Constit_Id : Entity_Id;
18669 -- Start of processing for Analyze_Constituent
18672 -- Detect multiple uses of null in a single refinement clause or a
18673 -- mixture of null and non-null constituents.
18675 if Nkind (Constit) = N_Null then
18678 ("multiple null constituents not allowed", Constit);
18680 elsif Non_Null_Seen then
18682 ("cannot mix null and non-null constituents", Constit);
18688 -- Non-null constituents
18691 Non_Null_Seen := True;
18695 ("cannot mix null and non-null constituents", Constit);
18700 -- Ensure that the constituent denotes a valid state or a
18703 if Is_Entity_Name (Constit) then
18704 Constit_Id := Entity (Constit);
18706 if Ekind_In (Constit_Id, E_Abstract_State, E_Variable) then
18707 Check_Matching_Constituent (Constit_Id);
18710 ("constituent & must denote a variable or state",
18711 Constit, Constit_Id);
18714 -- The constituent is illegal
18717 Error_Msg_N ("malformed constituent", Constit);
18720 end Analyze_Constituent;
18722 --------------------------
18723 -- Check_Matching_State --
18724 --------------------------
18726 procedure Check_Matching_State
18728 State_Id : Entity_Id)
18730 State_Elmt : Elmt_Id;
18733 -- Detect a duplicate refinement of a state
18735 if Contains (Refined_States_Seen, State_Id) then
18737 ("duplicate refinement of state &", State, State_Id);
18741 -- Inspect the abstract states defined in the package declaration
18742 -- looking for a match.
18744 State_Elmt := First_Elmt (Abstr_States);
18745 while Present (State_Elmt) loop
18747 -- A valid abstract state is being refined in the body. Add
18748 -- the state to the list of processed refined states to aid
18749 -- with the detection of duplicate refinements. Remove the
18750 -- state from Abstr_States to signal that it has already been
18753 if Node (State_Elmt) = State_Id then
18754 Add_Item (State_Id, Refined_States_Seen);
18755 Remove_Elmt (Abstr_States, State_Elmt);
18760 Next_Elmt (State_Elmt);
18763 -- If we get here, we are refining a state that is not defined in
18764 -- the package declaration.
18766 Error_Msg_Name_1 := Chars (Spec_Id);
18768 ("cannot refine state, & is not defined in package %",
18770 end Check_Matching_State;
18772 -- Local declarations
18776 State_Id : Entity_Id := Empty;
18778 -- Start of processing for Analyze_Refinement_Clause
18781 -- Analyze the state name of a refinement clause
18783 State := First (Choices (Clause));
18784 while Present (State) loop
18785 if Present (State_Id) then
18787 ("refinement clause cannot cover multiple states", State);
18792 -- Ensure that the state name denotes a valid abstract state
18793 -- that is defined in the spec of the related package.
18795 if Is_Entity_Name (State) then
18796 State_Id := Entity (State);
18798 -- Catch any attempts to re-refine a state or refine a
18799 -- state that is not defined in the package declaration.
18801 if Ekind (State_Id) = E_Abstract_State then
18802 Check_Matching_State (State, State_Id);
18805 ("& must denote an abstract state", State, State_Id);
18808 -- The state name is illegal
18812 ("malformed state name in refinement clause", State);
18819 -- Analyze all constituents of the refinement. Multiple constituents
18820 -- appear as an aggregate.
18822 Constit := Expression (Clause);
18824 if Nkind (Constit) = N_Aggregate then
18825 if Present (Component_Associations (Constit)) then
18827 ("constituents of refinement clause must appear in "
18828 & "positional form", Constit);
18830 else pragma Assert (Present (Expressions (Constit)));
18831 Constit := First (Expressions (Constit));
18832 while Present (Constit) loop
18833 Analyze_Constituent (Constit);
18839 -- Various forms of a single constituent. Note that these may include
18840 -- malformed constituents.
18843 Analyze_Constituent (Constit);
18845 end Analyze_Refinement_Clause;
18847 ---------------------------
18848 -- Collect_Hidden_States --
18849 ---------------------------
18851 function Collect_Hidden_States return Elist_Id is
18852 Result : Elist_Id := No_Elist;
18854 procedure Collect_Hidden_States_In_Decls (Decls : List_Id);
18855 -- Find all hidden states that appear in declarative list Decls and
18856 -- append their entities to Result.
18858 ------------------------------------
18859 -- Collect_Hidden_States_In_Decls --
18860 ------------------------------------
18862 procedure Collect_Hidden_States_In_Decls (Decls : List_Id) is
18863 procedure Collect_Abstract_States (States : Elist_Id);
18864 -- Copy the abstract states defined in list States to list Result
18866 -----------------------------
18867 -- Collect_Abstract_States --
18868 -----------------------------
18870 procedure Collect_Abstract_States (States : Elist_Id) is
18871 State_Elmt : Elmt_Id;
18874 State_Elmt := First_Elmt (States);
18875 while Present (State_Elmt) loop
18876 Add_Item (Node (State_Elmt), Result);
18878 Next_Elmt (State_Elmt);
18880 end Collect_Abstract_States;
18886 -- Start of processing for Collect_Hidden_States_In_Decls
18889 Decl := First (Decls);
18890 while Present (Decl) loop
18892 -- Objects (non-constants) are valid hidden states
18894 if Nkind (Decl) = N_Object_Declaration
18895 and then not Constant_Present (Decl)
18897 Add_Item (Defining_Entity (Decl), Result);
18899 -- Gather the abstract states of a package along with all
18900 -- hidden states in its visible declarations.
18902 elsif Nkind (Decl) = N_Package_Declaration then
18903 Collect_Abstract_States
18904 (Abstract_States (Defining_Entity (Decl)));
18906 Collect_Hidden_States_In_Decls
18907 (Visible_Declarations (Specification (Decl)));
18912 end Collect_Hidden_States_In_Decls;
18916 Pack_Spec : constant Node_Id := Parent (Spec_Id);
18918 -- Start of processing for Collect_Hidden_States
18921 -- Process the private declarations of the package spec and the
18922 -- declarations of the body.
18924 Collect_Hidden_States_In_Decls (Private_Declarations (Pack_Spec));
18925 Collect_Hidden_States_In_Decls (Declarations (Pack_Body));
18928 end Collect_Hidden_States;
18930 -----------------------------
18931 -- Report_Unrefined_States --
18932 -----------------------------
18934 procedure Report_Unrefined_States is
18935 State_Elmt : Elmt_Id;
18938 if Present (Abstr_States) then
18939 State_Elmt := First_Elmt (Abstr_States);
18940 while Present (State_Elmt) loop
18942 ("abstract state & must be refined", Node (State_Elmt));
18944 Next_Elmt (State_Elmt);
18947 end Report_Unrefined_States;
18949 ---------------------------------
18950 -- Report_Unused_Hidden_States --
18951 ---------------------------------
18953 procedure Report_Unused_Hidden_States is
18954 Posted : Boolean := False;
18955 State_Elmt : Elmt_Id;
18956 State_Id : Entity_Id;
18959 if Present (Hidden_States) then
18960 State_Elmt := First_Elmt (Hidden_States);
18961 while Present (State_Elmt) loop
18962 State_Id := Node (State_Elmt);
18964 -- Generate an error message of the form:
18966 -- package ... has unused hidden states
18967 -- abstract state ... defined at ...
18968 -- variable ... defined at ...
18973 ("package & has unused hidden states", N, Spec_Id);
18976 Error_Msg_Sloc := Sloc (State_Id);
18978 if Ekind (State_Id) = E_Abstract_State then
18979 Error_Msg_NE ("\ abstract state & defined #", N, State_Id);
18981 Error_Msg_NE ("\ variable & defined #", N, State_Id);
18984 Next_Elmt (State_Elmt);
18987 end Report_Unused_Hidden_States;
18989 -- Local declarations
18991 Clauses : constant Node_Id :=
18992 Expression (First (Pragma_Argument_Associations (N)));
18995 -- Start of processing for Analyze_Refined_State_In_Decl_Part
19000 -- Initialize the various lists used during analysis
19002 Abstr_States := Clone (Abstract_States (Spec_Id));
19003 Hidden_States := Collect_Hidden_States;
19005 -- Multiple state refinements appear as an aggregate
19007 if Nkind (Clauses) = N_Aggregate then
19008 if Present (Expressions (Clauses)) then
19010 ("state refinements must appear as component associations",
19013 else pragma Assert (Present (Component_Associations (Clauses)));
19014 Clause := First (Component_Associations (Clauses));
19015 while Present (Clause) loop
19016 Analyze_Refinement_Clause (Clause);
19022 -- Various forms of a single state refinement. Note that these may
19023 -- include malformed refinements.
19026 Analyze_Refinement_Clause (Clauses);
19029 -- Ensure that all abstract states have been refined and all hidden
19030 -- states of the related package unilized in refinements.
19032 Report_Unrefined_States;
19033 Report_Unused_Hidden_States;
19034 end Analyze_Refined_State_In_Decl_Part;
19036 ------------------------------------
19037 -- Analyze_Test_Case_In_Decl_Part --
19038 ------------------------------------
19040 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id; S : Entity_Id) is
19042 -- Install formals and push subprogram spec onto scope stack so that we
19043 -- can see the formals from the pragma.
19046 Install_Formals (S);
19048 -- Preanalyze the boolean expressions, we treat these as spec
19049 -- expressions (i.e. similar to a default expression).
19051 if Pragma_Name (N) = Name_Test_Case then
19052 Preanalyze_CTC_Args
19054 Get_Requires_From_CTC_Pragma (N),
19055 Get_Ensures_From_CTC_Pragma (N));
19058 -- Remove the subprogram from the scope stack now that the pre-analysis
19059 -- of the expressions in the contract case or test case is done.
19062 end Analyze_Test_Case_In_Decl_Part;
19068 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is
19073 if Present (List) then
19074 Elmt := First_Elmt (List);
19075 while Present (Elmt) loop
19076 if Nkind (Node (Elmt)) = N_Defining_Identifier then
19079 Id := Entity (Node (Elmt));
19082 if Id = Item_Id then
19097 function Check_Kind (Nam : Name_Id) return Name_Id is
19101 -- Loop through entries in check policy list
19103 PP := Opt.Check_Policy_List;
19104 while Present (PP) loop
19106 PPA : constant List_Id := Pragma_Argument_Associations (PP);
19107 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
19111 or else (Pnm = Name_Assertion
19112 and then Is_Valid_Assertion_Kind (Nam))
19113 or else (Pnm = Name_Statement_Assertions
19114 and then Nam_In (Nam, Name_Assert,
19115 Name_Assert_And_Cut,
19117 Name_Loop_Invariant))
19119 case (Chars (Get_Pragma_Arg (Last (PPA)))) is
19120 when Name_On | Name_Check =>
19122 when Name_Off | Name_Ignore =>
19123 return Name_Ignore;
19124 when Name_Disable =>
19125 return Name_Disable;
19127 raise Program_Error;
19131 PP := Next_Pragma (PP);
19136 -- If there are no specific entries that matched, then we let the
19137 -- setting of assertions govern. Note that this provides the needed
19138 -- compatibility with the RM for the cases of assertion, invariant,
19139 -- precondition, predicate, and postcondition.
19141 if Assertions_Enabled then
19144 return Name_Ignore;
19148 -----------------------------
19149 -- Check_Applicable_Policy --
19150 -----------------------------
19152 procedure Check_Applicable_Policy (N : Node_Id) is
19156 Ename : constant Name_Id := Original_Name (N);
19159 -- No effect if not valid assertion kind name
19161 if not Is_Valid_Assertion_Kind (Ename) then
19165 -- Loop through entries in check policy list
19167 PP := Opt.Check_Policy_List;
19168 while Present (PP) loop
19170 PPA : constant List_Id := Pragma_Argument_Associations (PP);
19171 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
19175 or else Pnm = Name_Assertion
19176 or else (Pnm = Name_Statement_Assertions
19177 and then (Ename = Name_Assert or else
19178 Ename = Name_Assert_And_Cut or else
19179 Ename = Name_Assume or else
19180 Ename = Name_Loop_Invariant))
19182 Policy := Chars (Get_Pragma_Arg (Last (PPA)));
19185 when Name_Off | Name_Ignore =>
19186 Set_Is_Ignored (N, True);
19187 Set_Is_Checked (N, False);
19189 when Name_On | Name_Check =>
19190 Set_Is_Checked (N, True);
19191 Set_Is_Ignored (N, False);
19193 when Name_Disable =>
19194 Set_Is_Ignored (N, True);
19195 Set_Is_Checked (N, False);
19196 Set_Is_Disabled (N, True);
19198 -- That should be exhaustive, the null here is a defence
19199 -- against a malformed tree from previous errors.
19208 PP := Next_Pragma (PP);
19212 -- If there are no specific entries that matched, then we let the
19213 -- setting of assertions govern. Note that this provides the needed
19214 -- compatibility with the RM for the cases of assertion, invariant,
19215 -- precondition, predicate, and postcondition.
19217 if Assertions_Enabled then
19218 Set_Is_Checked (N, True);
19219 Set_Is_Ignored (N, False);
19221 Set_Is_Checked (N, False);
19222 Set_Is_Ignored (N, True);
19224 end Check_Applicable_Policy;
19226 ---------------------------------------
19227 -- Collect_Subprogram_Inputs_Outputs --
19228 ---------------------------------------
19230 procedure Collect_Subprogram_Inputs_Outputs
19231 (Subp_Id : Entity_Id;
19232 Subp_Inputs : in out Elist_Id;
19233 Subp_Outputs : in out Elist_Id;
19234 Global_Seen : out Boolean)
19236 procedure Collect_Global_List
19238 Mode : Name_Id := Name_Input);
19239 -- Collect all relevant items from a global list
19241 -------------------------
19242 -- Collect_Global_List --
19243 -------------------------
19245 procedure Collect_Global_List
19247 Mode : Name_Id := Name_Input)
19249 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id);
19250 -- Add an item to the proper subprogram input or output collection
19252 -------------------------
19253 -- Collect_Global_Item --
19254 -------------------------
19256 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is
19258 if Nam_In (Mode, Name_In_Out, Name_Input) then
19259 Add_Item (Item, Subp_Inputs);
19262 if Nam_In (Mode, Name_In_Out, Name_Output) then
19263 Add_Item (Item, Subp_Outputs);
19265 end Collect_Global_Item;
19272 -- Start of processing for Collect_Global_List
19275 -- Single global item declaration
19277 if Nkind_In (List, N_Expanded_Name,
19279 N_Selected_Component)
19281 Collect_Global_Item (List, Mode);
19283 -- Simple global list or moded global list declaration
19286 if Present (Expressions (List)) then
19287 Item := First (Expressions (List));
19288 while Present (Item) loop
19289 Collect_Global_Item (Item, Mode);
19294 Assoc := First (Component_Associations (List));
19295 while Present (Assoc) loop
19296 Collect_Global_List
19297 (List => Expression (Assoc),
19298 Mode => Chars (First (Choices (Assoc))));
19303 end Collect_Global_List;
19307 Formal : Entity_Id;
19311 -- Start of processing for Collect_Subprogram_Inputs_Outputs
19314 Global_Seen := False;
19316 -- Process all formal parameters
19318 Formal := First_Formal (Subp_Id);
19319 while Present (Formal) loop
19320 if Ekind_In (Formal, E_In_Out_Parameter, E_In_Parameter) then
19321 Add_Item (Formal, Subp_Inputs);
19324 if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then
19325 Add_Item (Formal, Subp_Outputs);
19328 Next_Formal (Formal);
19331 -- If the subprogram is subject to pragma Global, traverse all global
19332 -- lists and gather the relevant items.
19334 Global := Find_Aspect (Subp_Id, Aspect_Global);
19335 if Present (Global) then
19336 Global_Seen := True;
19338 -- Retrieve the pragma as it contains the analyzed lists
19340 Global := Aspect_Rep_Item (Global);
19341 List := Expression (First (Pragma_Argument_Associations (Global)));
19343 -- The pragma may not have been analyzed because of the arbitrary
19344 -- declaration order of aspects. Make sure that it is analyzed for
19345 -- the purposes of item extraction.
19347 if not Analyzed (List) then
19348 Analyze_Global_In_Decl_Part (Global);
19351 -- Nothing to be done for a null global list
19353 if Nkind (List) /= N_Null then
19354 Collect_Global_List (List);
19357 end Collect_Subprogram_Inputs_Outputs;
19359 ---------------------------------
19360 -- Delay_Config_Pragma_Analyze --
19361 ---------------------------------
19363 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
19365 return Nam_In (Pragma_Name (N), Name_Interrupt_State,
19366 Name_Priority_Specific_Dispatching);
19367 end Delay_Config_Pragma_Analyze;
19369 -----------------------------
19370 -- Find_Related_Subprogram --
19371 -----------------------------
19373 function Find_Related_Subprogram
19375 Check_Duplicates : Boolean := False) return Node_Id
19377 Context : constant Node_Id := Parent (Prag);
19378 Nam : constant Name_Id := Pragma_Name (Prag);
19380 Subp_Decl : Node_Id;
19383 pragma Assert (Nkind (Prag) = N_Pragma);
19385 -- If the pragma comes from an aspect, then what we want is the
19386 -- declaration to which the aspect is attached, i.e. its parent.
19388 if Present (Corresponding_Aspect (Prag)) then
19389 return Parent (Corresponding_Aspect (Prag));
19392 -- Otherwise the pragma must be a list element, and the first thing to
19393 -- do is to position past any previous pragmas or generated code. What
19394 -- we are doing here is looking for the preceding declaration. This is
19395 -- also where we will check for a duplicate pragma.
19397 pragma Assert (Is_List_Member (Prag));
19401 Elmt := Prev (Elmt);
19402 exit when No (Elmt);
19404 -- Typically want we will want is the declaration original node. But
19405 -- for the generic subprogram case, don't go to to the original node,
19406 -- which is the unanalyzed tree: we need to attach the pre- and post-
19407 -- conditions to the analyzed version at this point. They propagate
19408 -- to the original tree when analyzing the corresponding body.
19410 if Nkind (Elmt) not in N_Generic_Declaration then
19411 Subp_Decl := Original_Node (Elmt);
19416 -- Skip prior pragmas
19418 if Nkind (Subp_Decl) = N_Pragma then
19419 if Check_Duplicates and then Pragma_Name (Subp_Decl) = Nam then
19420 Error_Msg_Name_1 := Nam;
19421 Error_Msg_Sloc := Sloc (Subp_Decl);
19422 Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
19425 -- Skip internally generated code
19427 elsif not Comes_From_Source (Subp_Decl) then
19430 -- Otherwise we have a declaration to return
19437 -- We fell through, which means there was no declaration preceding the
19438 -- pragma (either it was the first element of the list, or we only had
19439 -- other pragmas and generated code before it).
19441 -- The pragma is associated with a library-level subprogram
19443 if Nkind (Context) = N_Compilation_Unit_Aux then
19444 return Unit (Parent (Context));
19446 -- The pragma appears inside the declarative part of a subprogram body
19448 elsif Nkind (Context) = N_Subprogram_Body then
19451 -- Otherwise no subprogram found, return original pragma
19456 end Find_Related_Subprogram;
19458 -------------------------
19459 -- Get_Base_Subprogram --
19460 -------------------------
19462 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
19463 Result : Entity_Id;
19466 -- Follow subprogram renaming chain
19470 if Is_Subprogram (Result)
19472 Nkind (Parent (Declaration_Node (Result))) =
19473 N_Subprogram_Renaming_Declaration
19474 and then Present (Alias (Result))
19476 Result := Alias (Result);
19480 end Get_Base_Subprogram;
19482 -----------------------
19483 -- Get_SPARK_Mode_Id --
19484 -----------------------
19486 function Get_SPARK_Mode_Id (N : Name_Id) return SPARK_Mode_Id is
19488 if N = Name_On then
19490 elsif N = Name_Off then
19492 elsif N = Name_Auto then
19495 -- Any other argument is erroneous
19498 raise Program_Error;
19500 end Get_SPARK_Mode_Id;
19502 -----------------------
19503 -- Get_SPARK_Mode_Id --
19504 -----------------------
19506 function Get_SPARK_Mode_Id (N : Node_Id) return SPARK_Mode_Id is
19511 pragma Assert (Nkind (N) = N_Pragma);
19512 Args := Pragma_Argument_Associations (N);
19514 -- Extract the mode from the argument list
19516 if Present (Args) then
19517 Mode := First (Pragma_Argument_Associations (N));
19518 return Get_SPARK_Mode_Id (Chars (Get_Pragma_Arg (Mode)));
19520 -- When SPARK_Mode appears without an argument, the default is ON
19525 end Get_SPARK_Mode_Id;
19531 procedure Initialize is
19536 -----------------------------
19537 -- Is_Config_Static_String --
19538 -----------------------------
19540 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
19542 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
19543 -- This is an internal recursive function that is just like the outer
19544 -- function except that it adds the string to the name buffer rather
19545 -- than placing the string in the name buffer.
19547 ------------------------------
19548 -- Add_Config_Static_String --
19549 ------------------------------
19551 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
19558 if Nkind (N) = N_Op_Concat then
19559 if Add_Config_Static_String (Left_Opnd (N)) then
19560 N := Right_Opnd (N);
19566 if Nkind (N) /= N_String_Literal then
19567 Error_Msg_N ("string literal expected for pragma argument", N);
19571 for J in 1 .. String_Length (Strval (N)) loop
19572 C := Get_String_Char (Strval (N), J);
19574 if not In_Character_Range (C) then
19576 ("string literal contains invalid wide character",
19577 Sloc (N) + 1 + Source_Ptr (J));
19581 Add_Char_To_Name_Buffer (Get_Character (C));
19586 end Add_Config_Static_String;
19588 -- Start of processing for Is_Config_Static_String
19593 return Add_Config_Static_String (Arg);
19594 end Is_Config_Static_String;
19596 -------------------------------
19597 -- Is_Elaboration_SPARK_Mode --
19598 -------------------------------
19600 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is
19603 (Nkind (N) = N_Pragma
19604 and then Pragma_Name (N) = Name_SPARK_Mode
19605 and then Is_List_Member (N));
19607 -- Pragma SPARK_Mode affects the elaboration of a package body when it
19608 -- appears in the statement part of the body.
19611 Present (Parent (N))
19612 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
19613 and then List_Containing (N) = Statements (Parent (N))
19614 and then Present (Parent (Parent (N)))
19615 and then Nkind (Parent (Parent (N))) = N_Package_Body;
19616 end Is_Elaboration_SPARK_Mode;
19618 -----------------------------------------
19619 -- Is_Non_Significant_Pragma_Reference --
19620 -----------------------------------------
19622 -- This function makes use of the following static table which indicates
19623 -- whether appearance of some name in a given pragma is to be considered
19624 -- as a reference for the purposes of warnings about unreferenced objects.
19626 -- -1 indicates that references in any argument position are significant
19627 -- 0 indicates that appearance in any argument is not significant
19628 -- +n indicates that appearance as argument n is significant, but all
19629 -- other arguments are not significant
19630 -- 99 special processing required (e.g. for pragma Check)
19632 Sig_Flags : constant array (Pragma_Id) of Int :=
19633 (Pragma_AST_Entry => -1,
19634 Pragma_Abort_Defer => -1,
19635 Pragma_Abstract_State => -1,
19636 Pragma_Ada_83 => -1,
19637 Pragma_Ada_95 => -1,
19638 Pragma_Ada_05 => -1,
19639 Pragma_Ada_2005 => -1,
19640 Pragma_Ada_12 => -1,
19641 Pragma_Ada_2012 => -1,
19642 Pragma_All_Calls_Remote => -1,
19643 Pragma_Annotate => -1,
19644 Pragma_Assert => -1,
19645 Pragma_Assert_And_Cut => -1,
19646 Pragma_Assertion_Policy => 0,
19647 Pragma_Assume => -1,
19648 Pragma_Assume_No_Invalid_Values => 0,
19649 Pragma_Attribute_Definition => +3,
19650 Pragma_Asynchronous => -1,
19651 Pragma_Atomic => 0,
19652 Pragma_Atomic_Components => 0,
19653 Pragma_Attach_Handler => -1,
19654 Pragma_Check => 99,
19655 Pragma_Check_Float_Overflow => 0,
19656 Pragma_Check_Name => 0,
19657 Pragma_Check_Policy => 0,
19658 Pragma_CIL_Constructor => -1,
19659 Pragma_CPP_Class => 0,
19660 Pragma_CPP_Constructor => 0,
19661 Pragma_CPP_Virtual => 0,
19662 Pragma_CPP_Vtable => 0,
19664 Pragma_C_Pass_By_Copy => 0,
19665 Pragma_Comment => 0,
19666 Pragma_Common_Object => -1,
19667 Pragma_Compile_Time_Error => -1,
19668 Pragma_Compile_Time_Warning => -1,
19669 Pragma_Compiler_Unit => 0,
19670 Pragma_Complete_Representation => 0,
19671 Pragma_Complex_Representation => 0,
19672 Pragma_Component_Alignment => -1,
19673 Pragma_Contract_Cases => -1,
19674 Pragma_Controlled => 0,
19675 Pragma_Convention => 0,
19676 Pragma_Convention_Identifier => 0,
19677 Pragma_Debug => -1,
19678 Pragma_Debug_Policy => 0,
19679 Pragma_Detect_Blocking => -1,
19680 Pragma_Default_Storage_Pool => -1,
19681 Pragma_Depends => -1,
19682 Pragma_Disable_Atomic_Synchronization => -1,
19683 Pragma_Discard_Names => 0,
19684 Pragma_Dispatching_Domain => -1,
19685 Pragma_Elaborate => -1,
19686 Pragma_Elaborate_All => -1,
19687 Pragma_Elaborate_Body => -1,
19688 Pragma_Elaboration_Checks => -1,
19689 Pragma_Eliminate => -1,
19690 Pragma_Enable_Atomic_Synchronization => -1,
19691 Pragma_Export => -1,
19692 Pragma_Export_Exception => -1,
19693 Pragma_Export_Function => -1,
19694 Pragma_Export_Object => -1,
19695 Pragma_Export_Procedure => -1,
19696 Pragma_Export_Value => -1,
19697 Pragma_Export_Valued_Procedure => -1,
19698 Pragma_Extend_System => -1,
19699 Pragma_Extensions_Allowed => -1,
19700 Pragma_External => -1,
19701 Pragma_Favor_Top_Level => -1,
19702 Pragma_External_Name_Casing => -1,
19703 Pragma_Fast_Math => -1,
19704 Pragma_Finalize_Storage_Only => 0,
19705 Pragma_Float_Representation => 0,
19706 Pragma_Global => -1,
19707 Pragma_Ident => -1,
19708 Pragma_Implementation_Defined => -1,
19709 Pragma_Implemented => -1,
19710 Pragma_Implicit_Packing => 0,
19711 Pragma_Import => +2,
19712 Pragma_Import_Exception => 0,
19713 Pragma_Import_Function => 0,
19714 Pragma_Import_Object => 0,
19715 Pragma_Import_Procedure => 0,
19716 Pragma_Import_Valued_Procedure => 0,
19717 Pragma_Independent => 0,
19718 Pragma_Independent_Components => 0,
19719 Pragma_Initialize_Scalars => -1,
19720 Pragma_Inline => 0,
19721 Pragma_Inline_Always => 0,
19722 Pragma_Inline_Generic => 0,
19723 Pragma_Inspection_Point => -1,
19724 Pragma_Interface => +2,
19725 Pragma_Interface_Name => +2,
19726 Pragma_Interrupt_Handler => -1,
19727 Pragma_Interrupt_Priority => -1,
19728 Pragma_Interrupt_State => -1,
19729 Pragma_Invariant => -1,
19730 Pragma_Java_Constructor => -1,
19731 Pragma_Java_Interface => -1,
19732 Pragma_Keep_Names => 0,
19733 Pragma_License => -1,
19734 Pragma_Link_With => -1,
19735 Pragma_Linker_Alias => -1,
19736 Pragma_Linker_Constructor => -1,
19737 Pragma_Linker_Destructor => -1,
19738 Pragma_Linker_Options => -1,
19739 Pragma_Linker_Section => -1,
19741 Pragma_Lock_Free => -1,
19742 Pragma_Locking_Policy => -1,
19743 Pragma_Long_Float => -1,
19744 Pragma_Loop_Invariant => -1,
19745 Pragma_Loop_Optimize => -1,
19746 Pragma_Loop_Variant => -1,
19747 Pragma_Machine_Attribute => -1,
19749 Pragma_Main_Storage => -1,
19750 Pragma_Memory_Size => -1,
19751 Pragma_No_Return => 0,
19752 Pragma_No_Body => 0,
19753 Pragma_No_Inline => 0,
19754 Pragma_No_Run_Time => -1,
19755 Pragma_No_Strict_Aliasing => -1,
19756 Pragma_Normalize_Scalars => -1,
19757 Pragma_Obsolescent => 0,
19758 Pragma_Optimize => -1,
19759 Pragma_Optimize_Alignment => -1,
19760 Pragma_Overflow_Mode => 0,
19761 Pragma_Overriding_Renamings => 0,
19762 Pragma_Ordered => 0,
19765 Pragma_Partition_Elaboration_Policy => -1,
19766 Pragma_Passive => -1,
19767 Pragma_Persistent_BSS => 0,
19768 Pragma_Polling => -1,
19769 Pragma_Postcondition => -1,
19770 Pragma_Precondition => -1,
19771 Pragma_Predicate => -1,
19772 Pragma_Preelaborable_Initialization => -1,
19773 Pragma_Preelaborate => -1,
19774 Pragma_Preelaborate_05 => -1,
19775 Pragma_Priority => -1,
19776 Pragma_Priority_Specific_Dispatching => -1,
19777 Pragma_Profile => 0,
19778 Pragma_Profile_Warnings => 0,
19779 Pragma_Propagate_Exceptions => -1,
19780 Pragma_Psect_Object => -1,
19782 Pragma_Pure_05 => -1,
19783 Pragma_Pure_12 => -1,
19784 Pragma_Pure_Function => -1,
19785 Pragma_Queuing_Policy => -1,
19786 Pragma_Rational => -1,
19787 Pragma_Ravenscar => -1,
19788 Pragma_Refined_Depends => -1,
19789 Pragma_Refined_Global => -1,
19790 Pragma_Refined_Post => -1,
19791 Pragma_Refined_Pre => -1,
19792 Pragma_Refined_State => -1,
19793 Pragma_Relative_Deadline => -1,
19794 Pragma_Remote_Access_Type => -1,
19795 Pragma_Remote_Call_Interface => -1,
19796 Pragma_Remote_Types => -1,
19797 Pragma_Restricted_Run_Time => -1,
19798 Pragma_Restriction_Warnings => -1,
19799 Pragma_Restrictions => -1,
19800 Pragma_Reviewable => -1,
19801 Pragma_Short_Circuit_And_Or => -1,
19802 Pragma_Share_Generic => -1,
19803 Pragma_Shared => -1,
19804 Pragma_Shared_Passive => -1,
19805 Pragma_Short_Descriptors => 0,
19806 Pragma_Simple_Storage_Pool_Type => 0,
19807 Pragma_Source_File_Name => -1,
19808 Pragma_Source_File_Name_Project => -1,
19809 Pragma_Source_Reference => -1,
19810 Pragma_SPARK_Mode => 0,
19811 Pragma_Storage_Size => -1,
19812 Pragma_Storage_Unit => -1,
19813 Pragma_Static_Elaboration_Desired => -1,
19814 Pragma_Stream_Convert => -1,
19815 Pragma_Style_Checks => -1,
19816 Pragma_Subtitle => -1,
19817 Pragma_Suppress => 0,
19818 Pragma_Suppress_Exception_Locations => 0,
19819 Pragma_Suppress_All => -1,
19820 Pragma_Suppress_Debug_Info => 0,
19821 Pragma_Suppress_Initialization => 0,
19822 Pragma_System_Name => -1,
19823 Pragma_Task_Dispatching_Policy => -1,
19824 Pragma_Task_Info => -1,
19825 Pragma_Task_Name => -1,
19826 Pragma_Task_Storage => 0,
19827 Pragma_Test_Case => -1,
19828 Pragma_Thread_Local_Storage => 0,
19829 Pragma_Time_Slice => -1,
19830 Pragma_Title => -1,
19831 Pragma_Unchecked_Union => 0,
19832 Pragma_Unimplemented_Unit => -1,
19833 Pragma_Universal_Aliasing => -1,
19834 Pragma_Universal_Data => -1,
19835 Pragma_Unmodified => -1,
19836 Pragma_Unreferenced => -1,
19837 Pragma_Unreferenced_Objects => -1,
19838 Pragma_Unreserve_All_Interrupts => -1,
19839 Pragma_Unsuppress => 0,
19840 Pragma_Use_VADS_Size => -1,
19841 Pragma_Validity_Checks => -1,
19842 Pragma_Volatile => 0,
19843 Pragma_Volatile_Components => 0,
19844 Pragma_Warnings => -1,
19845 Pragma_Weak_External => -1,
19846 Pragma_Wide_Character_Encoding => 0,
19847 Unknown_Pragma => 0);
19849 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
19858 if Nkind (P) /= N_Pragma_Argument_Association then
19862 Id := Get_Pragma_Id (Parent (P));
19863 C := Sig_Flags (Id);
19875 -- For pragma Check, the first argument is not significant,
19876 -- the second and the third (if present) arguments are
19879 when Pragma_Check =>
19881 P = First (Pragma_Argument_Associations (Parent (P)));
19884 raise Program_Error;
19888 A := First (Pragma_Argument_Associations (Parent (P)));
19889 for J in 1 .. C - 1 loop
19897 return A = P; -- is this wrong way round ???
19900 end Is_Non_Significant_Pragma_Reference;
19902 ------------------------------
19903 -- Is_Pragma_String_Literal --
19904 ------------------------------
19906 -- This function returns true if the corresponding pragma argument is a
19907 -- static string expression. These are the only cases in which string
19908 -- literals can appear as pragma arguments. We also allow a string literal
19909 -- as the first argument to pragma Assert (although it will of course
19910 -- always generate a type error).
19912 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
19913 Pragn : constant Node_Id := Parent (Par);
19914 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
19915 Pname : constant Name_Id := Pragma_Name (Pragn);
19921 N := First (Assoc);
19928 if Pname = Name_Assert then
19931 elsif Pname = Name_Export then
19934 elsif Pname = Name_Ident then
19937 elsif Pname = Name_Import then
19940 elsif Pname = Name_Interface_Name then
19943 elsif Pname = Name_Linker_Alias then
19946 elsif Pname = Name_Linker_Section then
19949 elsif Pname = Name_Machine_Attribute then
19952 elsif Pname = Name_Source_File_Name then
19955 elsif Pname = Name_Source_Reference then
19958 elsif Pname = Name_Title then
19961 elsif Pname = Name_Subtitle then
19967 end Is_Pragma_String_Literal;
19969 ---------------------------
19970 -- Is_Private_SPARK_Mode --
19971 ---------------------------
19973 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is
19976 (Nkind (N) = N_Pragma
19977 and then Pragma_Name (N) = Name_SPARK_Mode
19978 and then Is_List_Member (N));
19980 -- For pragma SPARK_Mode to be private, it has to appear in the private
19981 -- declarations of a package.
19984 Present (Parent (N))
19985 and then Nkind (Parent (N)) = N_Package_Specification
19986 and then List_Containing (N) = Private_Declarations (Parent (N));
19987 end Is_Private_SPARK_Mode;
19989 -----------------------------
19990 -- Is_Valid_Assertion_Kind --
19991 -----------------------------
19993 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is
20000 Name_Static_Predicate |
20001 Name_Dynamic_Predicate |
20006 Name_Type_Invariant |
20007 Name_uType_Invariant |
20011 Name_Assert_And_Cut |
20013 Name_Contract_Cases |
20017 Name_Loop_Invariant |
20018 Name_Loop_Variant |
20019 Name_Postcondition |
20020 Name_Precondition |
20022 Name_Refined_Post |
20024 Name_Statement_Assertions => return True;
20026 when others => return False;
20028 end Is_Valid_Assertion_Kind;
20030 -----------------------------------------
20031 -- Make_Aspect_For_PPC_In_Gen_Sub_Decl --
20032 -----------------------------------------
20034 procedure Make_Aspect_For_PPC_In_Gen_Sub_Decl (Decl : Node_Id) is
20035 Aspects : constant List_Id := New_List;
20036 Loc : constant Source_Ptr := Sloc (Decl);
20037 Or_Decl : constant Node_Id := Original_Node (Decl);
20039 Original_Aspects : List_Id;
20040 -- To capture global references, a copy of the created aspects must be
20041 -- inserted in the original tree.
20044 Prag_Arg_Ass : Node_Id;
20045 Prag_Id : Pragma_Id;
20048 -- Check for any PPC pragmas that appear within Decl
20050 Prag := Next (Decl);
20051 while Nkind (Prag) = N_Pragma loop
20052 Prag_Id := Get_Pragma_Id (Chars (Pragma_Identifier (Prag)));
20055 when Pragma_Postcondition | Pragma_Precondition =>
20056 Prag_Arg_Ass := First (Pragma_Argument_Associations (Prag));
20058 -- Make an aspect from any PPC pragma
20060 Append_To (Aspects,
20061 Make_Aspect_Specification (Loc,
20063 Make_Identifier (Loc, Chars (Pragma_Identifier (Prag))),
20065 Copy_Separate_Tree (Expression (Prag_Arg_Ass))));
20067 -- Generate the analysis information in the pragma expression
20068 -- and then set the pragma node analyzed to avoid any further
20071 Analyze (Expression (Prag_Arg_Ass));
20072 Set_Analyzed (Prag, True);
20074 when others => null;
20080 -- Set all new aspects into the generic declaration node
20082 if Is_Non_Empty_List (Aspects) then
20084 -- Create the list of aspects to be inserted in the original tree
20086 Original_Aspects := Copy_Separate_List (Aspects);
20088 -- Check if Decl already has aspects
20090 -- Attach the new lists of aspects to both the generic copy and the
20093 if Has_Aspects (Decl) then
20094 Append_List (Aspects, Aspect_Specifications (Decl));
20095 Append_List (Original_Aspects, Aspect_Specifications (Or_Decl));
20098 Set_Parent (Aspects, Decl);
20099 Set_Aspect_Specifications (Decl, Aspects);
20100 Set_Parent (Original_Aspects, Or_Decl);
20101 Set_Aspect_Specifications (Or_Decl, Original_Aspects);
20104 end Make_Aspect_For_PPC_In_Gen_Sub_Decl;
20106 -------------------
20107 -- Original_Name --
20108 -------------------
20110 function Original_Name (N : Node_Id) return Name_Id is
20115 pragma Assert (Nkind_In (N, N_Aspect_Specification, N_Pragma));
20118 if Is_Rewrite_Substitution (Pras)
20119 and then Nkind (Original_Node (Pras)) = N_Pragma
20121 Pras := Original_Node (Pras);
20124 -- Case where we came from aspect specication
20126 if Nkind (Pras) = N_Pragma and then From_Aspect_Specification (Pras) then
20127 Pras := Corresponding_Aspect (Pras);
20130 -- Get name from aspect or pragma
20132 if Nkind (Pras) = N_Pragma then
20133 Name := Pragma_Name (Pras);
20135 Name := Chars (Identifier (Pras));
20138 -- Deal with 'Class
20140 if Class_Present (Pras) then
20143 -- Names that need converting to special _xxx form
20145 when Name_Pre => Name := Name_uPre;
20146 when Name_Post => Name := Name_uPost;
20147 when Name_Invariant => Name := Name_uInvariant;
20148 when Name_Type_Invariant => Name := Name_uType_Invariant;
20150 -- Names already in special _xxx form (leave them alone)
20152 when Name_uPre => null;
20153 when Name_uPost => null;
20154 when Name_uInvariant => null;
20155 when Name_uType_Invariant => null;
20157 -- Anything else is impossible with Class_Present set True
20159 when others => raise Program_Error;
20166 -------------------------
20167 -- Preanalyze_CTC_Args --
20168 -------------------------
20170 procedure Preanalyze_CTC_Args (N, Arg_Req, Arg_Ens : Node_Id) is
20172 -- Preanalyze the boolean expressions, we treat these as spec
20173 -- expressions (i.e. similar to a default expression).
20175 if Present (Arg_Req) then
20176 Preanalyze_Assert_Expression
20177 (Get_Pragma_Arg (Arg_Req), Standard_Boolean);
20179 -- In ASIS mode, for a pragma generated from a source aspect, also
20180 -- analyze the original aspect expression.
20182 if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
20183 Preanalyze_Assert_Expression
20184 (Original_Node (Get_Pragma_Arg (Arg_Req)), Standard_Boolean);
20188 if Present (Arg_Ens) then
20189 Preanalyze_Assert_Expression
20190 (Get_Pragma_Arg (Arg_Ens), Standard_Boolean);
20192 -- In ASIS mode, for a pragma generated from a source aspect, also
20193 -- analyze the original aspect expression.
20195 if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
20196 Preanalyze_Assert_Expression
20197 (Original_Node (Get_Pragma_Arg (Arg_Ens)), Standard_Boolean);
20200 end Preanalyze_CTC_Args;
20202 --------------------------------------
20203 -- Process_Compilation_Unit_Pragmas --
20204 --------------------------------------
20206 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
20208 -- A special check for pragma Suppress_All, a very strange DEC pragma,
20209 -- strange because it comes at the end of the unit. Rational has the
20210 -- same name for a pragma, but treats it as a program unit pragma, In
20211 -- GNAT we just decide to allow it anywhere at all. If it appeared then
20212 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
20213 -- node, and we insert a pragma Suppress (All_Checks) at the start of
20214 -- the context clause to ensure the correct processing.
20216 if Has_Pragma_Suppress_All (N) then
20217 Prepend_To (Context_Items (N),
20218 Make_Pragma (Sloc (N),
20219 Chars => Name_Suppress,
20220 Pragma_Argument_Associations => New_List (
20221 Make_Pragma_Argument_Association (Sloc (N),
20222 Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
20225 -- Nothing else to do at the current time!
20227 end Process_Compilation_Unit_Pragmas;
20229 ------------------------------
20230 -- Relocate_Pragmas_To_Body --
20231 ------------------------------
20233 procedure Relocate_Pragmas_To_Body
20234 (Subp_Body : Node_Id;
20235 Target_Body : Node_Id := Empty)
20237 procedure Relocate_Pragma (Prag : Node_Id);
20238 -- Remove a single pragma from its current list and add it to the
20239 -- declarations of the proper body (either Subp_Body or Target_Body).
20241 ---------------------
20242 -- Relocate_Pragma --
20243 ---------------------
20245 procedure Relocate_Pragma (Prag : Node_Id) is
20250 -- When subprogram stubs or expression functions are involves, the
20251 -- destination declaration list belongs to the proper body.
20253 if Present (Target_Body) then
20254 Target := Target_Body;
20256 Target := Subp_Body;
20259 Decls := Declarations (Target);
20263 Set_Declarations (Target, Decls);
20266 -- Unhook the pragma from its current list
20269 Prepend (Prag, Decls);
20270 end Relocate_Pragma;
20274 Body_Id : constant Entity_Id :=
20275 Defining_Unit_Name (Specification (Subp_Body));
20276 Next_Stmt : Node_Id;
20279 -- Start of processing for Relocate_Pragmas_To_Body
20282 -- Do not process a body that comes from a separate unit as no construct
20283 -- can possibly follow it.
20285 if not Is_List_Member (Subp_Body) then
20288 -- Do not relocate pragmas that follow a stub if the stub does not have
20291 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub
20292 and then No (Target_Body)
20296 -- Do not process internally generated routine _Postconditions
20298 elsif Ekind (Body_Id) = E_Procedure
20299 and then Chars (Body_Id) = Name_uPostconditions
20304 -- Look at what is following the body. We are interested in certain kind
20305 -- of pragmas (either from source or byproducts of expansion) that can
20306 -- apply to a body [stub].
20308 Stmt := Next (Subp_Body);
20309 while Present (Stmt) loop
20311 -- Preserve the following statement for iteration purposes due to a
20312 -- possible relocation of a pragma.
20314 Next_Stmt := Next (Stmt);
20316 -- Move a candidate pragma following the body to the declarations of
20319 if Nkind (Stmt) = N_Pragma
20320 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt))
20322 Relocate_Pragma (Stmt);
20324 -- Skip internally generated code
20326 elsif not Comes_From_Source (Stmt) then
20329 -- No candidate pragmas are available for relocation
20337 end Relocate_Pragmas_To_Body;
20339 ----------------------------
20340 -- Rewrite_Assertion_Kind --
20341 ----------------------------
20343 procedure Rewrite_Assertion_Kind (N : Node_Id) is
20347 if Nkind (N) = N_Attribute_Reference
20348 and then Attribute_Name (N) = Name_Class
20349 and then Nkind (Prefix (N)) = N_Identifier
20351 case Chars (Prefix (N)) is
20356 when Name_Type_Invariant =>
20357 Nam := Name_uType_Invariant;
20358 when Name_Invariant =>
20359 Nam := Name_uInvariant;
20364 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam));
20366 end Rewrite_Assertion_Kind;
20377 -----------------------------------
20378 -- Requires_Profile_Installation --
20379 -----------------------------------
20381 function Requires_Profile_Installation
20383 Subp : Node_Id) return Boolean
20386 -- When aspects Depends and Global are associated with a subprogram
20387 -- declaration, their corresponding pragmas are analyzed at the end of
20388 -- the declarative part. This is done out of context, therefore the
20389 -- formals must be installed in visibility.
20391 if Nkind (Subp) = N_Subprogram_Declaration then
20394 -- When aspects Depends and Global are associated with a subprogram body
20395 -- which is also a compilation unit, their corresponding pragmas appear
20396 -- in the Pragmas_After list. The Pragmas_After collection is analyzed
20397 -- out of context and the formals must be installed in visibility. This
20398 -- does not apply when the pragma is a source construct.
20400 elsif Nkind (Subp) = N_Subprogram_Body then
20401 if Nkind (Parent (Subp)) = N_Compilation_Unit then
20402 return Present (Corresponding_Aspect (Prag));
20407 -- In all other cases the two corresponding pragmas are analyzed in
20408 -- context and the formals are already visibile.
20413 end Requires_Profile_Installation;
20415 --------------------------------
20416 -- Set_Encoded_Interface_Name --
20417 --------------------------------
20419 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
20420 Str : constant String_Id := Strval (S);
20421 Len : constant Int := String_Length (Str);
20426 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
20429 -- Stores encoded value of character code CC. The encoding we use an
20430 -- underscore followed by four lower case hex digits.
20436 procedure Encode is
20438 Store_String_Char (Get_Char_Code ('_'));
20440 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
20442 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
20444 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
20446 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
20449 -- Start of processing for Set_Encoded_Interface_Name
20452 -- If first character is asterisk, this is a link name, and we leave it
20453 -- completely unmodified. We also ignore null strings (the latter case
20454 -- happens only in error cases) and no encoding should occur for Java or
20455 -- AAMP interface names.
20458 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
20459 or else VM_Target /= No_VM
20460 or else AAMP_On_Target
20462 Set_Interface_Name (E, S);
20467 CC := Get_String_Char (Str, J);
20469 exit when not In_Character_Range (CC);
20471 C := Get_Character (CC);
20473 exit when C /= '_' and then C /= '$'
20474 and then C not in '0' .. '9'
20475 and then C not in 'a' .. 'z'
20476 and then C not in 'A' .. 'Z';
20479 Set_Interface_Name (E, S);
20487 -- Here we need to encode. The encoding we use as follows:
20488 -- three underscores + four hex digits (lower case)
20492 for J in 1 .. String_Length (Str) loop
20493 CC := Get_String_Char (Str, J);
20495 if not In_Character_Range (CC) then
20498 C := Get_Character (CC);
20500 if C = '_' or else C = '$'
20501 or else C in '0' .. '9'
20502 or else C in 'a' .. 'z'
20503 or else C in 'A' .. 'Z'
20505 Store_String_Char (CC);
20512 Set_Interface_Name (E,
20513 Make_String_Literal (Sloc (S),
20514 Strval => End_String));
20516 end Set_Encoded_Interface_Name;
20518 -------------------
20519 -- Set_Unit_Name --
20520 -------------------
20522 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id) is
20527 if Nkind (N) = N_Identifier
20528 and then Nkind (With_Item) = N_Identifier
20530 Set_Entity (N, Entity (With_Item));
20532 elsif Nkind (N) = N_Selected_Component then
20533 Change_Selected_Component_To_Expanded_Name (N);
20534 Set_Entity (N, Entity (With_Item));
20535 Set_Entity (Selector_Name (N), Entity (N));
20537 Pref := Prefix (N);
20538 Scop := Scope (Entity (N));
20539 while Nkind (Pref) = N_Selected_Component loop
20540 Change_Selected_Component_To_Expanded_Name (Pref);
20541 Set_Entity (Selector_Name (Pref), Scop);
20542 Set_Entity (Pref, Scop);
20543 Pref := Prefix (Pref);
20544 Scop := Scope (Scop);
20547 Set_Entity (Pref, Scop);