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_Global_Items
209 In_Items : in out Elist_Id;
210 In_Out_Items : in out Elist_Id;
211 Out_Items : in out Elist_Id;
212 Has_In_State : out Boolean;
213 Has_In_Out_State : out Boolean;
214 Has_Out_State : out Boolean;
215 Has_Null_State : out Boolean);
216 -- Subsidiary to the analysis of pragma Refined_Depends/Refined_Global.
217 -- Prag denotes pragma [Refined_]Global. Gather all input, in out and
218 -- output items of Prag in lists In_Items, In_Out_Items and Out_Items.
219 -- Flags Has_In_State, Has_In_Out_State and Has_Out_State are set when
220 -- there is at least one abstract state with visible refinement available
221 -- in the corresponding mode. Flag Has_Null_State is set when at least
222 -- state has a null refinement.
224 procedure Collect_Subprogram_Inputs_Outputs
225 (Subp_Id : Entity_Id;
226 Subp_Inputs : in out Elist_Id;
227 Subp_Outputs : in out Elist_Id;
228 Global_Seen : out Boolean);
229 -- Subsidiary to the analysis of pragma Depends, Global, Refined_Depends
230 -- and Refined_Global. Gather all inputs and outputs of subprogram Subp_Id
231 -- in lists Subp_Inputs and Subp_Outputs. If the case where the subprogram
232 -- has no inputs and/oroutputs, the returned list is No_Elist. Global_Seen
233 -- is set when the related subprogram has pragma [Refined_]Global.
235 function Find_Related_Subprogram_Or_Body
237 Do_Checks : Boolean := False) return Node_Id;
238 -- Subsidiary to the analysis of pragmas Contract_Cases, Depends, Global,
239 -- Refined_Depends, Refined_Global, Refined_Post and Refined_Pre. Find the
240 -- declaration of the related subprogram [body or stub] subject to pragma
241 -- Prag. If flag Do_Checks is set, the routine reports duplicate pragmas
242 -- and detects improper use of refinement pragmas in stand alone expression
243 -- functions. The returned value depends on the related pragma as follows:
244 -- 1) Pragmas Contract_Cases, Depends and Global yield the corresponding
245 -- N_Subprogram_Declaration node or if the pragma applies to a stand
246 -- alone body, the N_Subprogram_Body node or Empty if illegal.
247 -- 2) Pragmas Refined_Depends, Refined_Global, Refined_Post and
248 -- Refined_Pre yield N_Subprogram_Body or N_Subprogram_Body_Stub nodes
249 -- or Empty if illegal.
251 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
252 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
253 -- original one, following the renaming chain) is returned. Otherwise the
254 -- entity is returned unchanged. Should be in Einfo???
256 function Get_SPARK_Mode_Id (N : Name_Id) return SPARK_Mode_Id;
257 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
258 -- Get_SPARK_Mode_Id. Convert a name into a corresponding value of type
263 Ancestor : Entity_Id) return Boolean;
264 -- Subsidiary to the processing of pragma Refined_Depends and pragma
265 -- Refined_Global. Determine whether abstract state State is part of an
266 -- ancestor abstract state Ancestor. For this relationship to hold, State
267 -- must have option Part_Of in its Abstract_State definition.
269 function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean;
270 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
271 -- pragma Depends. Determine whether the type of dependency item Item is
272 -- tagged, unconstrained array, unconstrained record or a record with at
273 -- least one unconstrained component.
275 procedure Preanalyze_CTC_Args (N, Arg_Req, Arg_Ens : Node_Id);
276 -- Preanalyze the boolean expressions in the Requires and Ensures arguments
277 -- of a Test_Case pragma if present (possibly Empty). We treat these as
278 -- spec expressions (i.e. similar to a default expression).
280 procedure Rewrite_Assertion_Kind (N : Node_Id);
281 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
282 -- then it is rewritten as an identifier with the corresponding special
283 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas
284 -- Check, Check_Policy.
287 -- This is a dummy function called by the processing for pragma Reviewable.
288 -- It is there for assisting front end debugging. By placing a Reviewable
289 -- pragma in the source program, a breakpoint on rv catches this place in
290 -- the source, allowing convenient stepping to the point of interest.
292 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id);
293 -- Place semantic information on the argument of an Elaborate/Elaborate_All
294 -- pragma. Entity name for unit and its parents is taken from item in
295 -- previous with_clause that mentions the unit.
301 procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id) is
304 To_List := New_Elmt_List;
307 Append_Elmt (Item, To_List);
310 -------------------------------
311 -- Adjust_External_Name_Case --
312 -------------------------------
314 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
318 -- Adjust case of literal if required
320 if Opt.External_Name_Exp_Casing = As_Is then
324 -- Copy existing string
330 for J in 1 .. String_Length (Strval (N)) loop
331 CC := Get_String_Char (Strval (N), J);
333 if Opt.External_Name_Exp_Casing = Uppercase
334 and then CC >= Get_Char_Code ('a')
335 and then CC <= Get_Char_Code ('z')
337 Store_String_Char (CC - 32);
339 elsif Opt.External_Name_Exp_Casing = Lowercase
340 and then CC >= Get_Char_Code ('A')
341 and then CC <= Get_Char_Code ('Z')
343 Store_String_Char (CC + 32);
346 Store_String_Char (CC);
351 Make_String_Literal (Sloc (N),
352 Strval => End_String);
354 end Adjust_External_Name_Case;
356 -----------------------------------------
357 -- Analyze_Contract_Cases_In_Decl_Part --
358 -----------------------------------------
360 procedure Analyze_Contract_Cases_In_Decl_Part (N : Node_Id) is
361 Others_Seen : Boolean := False;
363 procedure Analyze_Contract_Case (CCase : Node_Id);
364 -- Verify the legality of a single contract case
366 ---------------------------
367 -- Analyze_Contract_Case --
368 ---------------------------
370 procedure Analyze_Contract_Case (CCase : Node_Id) is
371 Case_Guard : Node_Id;
373 Extra_Guard : Node_Id;
376 if Nkind (CCase) = N_Component_Association then
377 Case_Guard := First (Choices (CCase));
378 Conseq := Expression (CCase);
380 -- Each contract case must have exactly one case guard
382 Extra_Guard := Next (Case_Guard);
384 if Present (Extra_Guard) then
386 ("contract case may have only one case guard", Extra_Guard);
389 -- Check the placement of "others" (if available)
391 if Nkind (Case_Guard) = N_Others_Choice then
394 ("only one others choice allowed in aspect Contract_Cases",
400 elsif Others_Seen then
402 ("others must be the last choice in aspect Contract_Cases",
406 -- Preanalyze the case guard and consequence
408 if Nkind (Case_Guard) /= N_Others_Choice then
409 Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean);
412 Preanalyze_Assert_Expression (Conseq, Standard_Boolean);
414 -- The contract case is malformed
417 Error_Msg_N ("wrong syntax in contract case", CCase);
419 end Analyze_Contract_Case;
428 Restore_Scope : Boolean := False;
429 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
431 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
436 Subp_Decl := Find_Related_Subprogram_Or_Body (N);
437 Subp_Id := Defining_Entity (Subp_Decl);
438 All_Cases := Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
440 -- Multiple contract cases appear in aggregate form
442 if Nkind (All_Cases) = N_Aggregate then
443 if No (Component_Associations (All_Cases)) then
444 Error_Msg_N ("wrong syntax for aspect Contract_Cases", N);
446 -- Individual contract cases appear as component associations
449 -- Ensure that the formal parameters are visible when analyzing
450 -- all clauses. This falls out of the general rule of aspects
451 -- pertaining to subprogram declarations. Skip the installation
452 -- for subprogram bodies because the formals are already visible.
454 if not In_Open_Scopes (Subp_Id) then
455 Restore_Scope := True;
456 Push_Scope (Subp_Id);
457 Install_Formals (Subp_Id);
460 CCase := First (Component_Associations (All_Cases));
461 while Present (CCase) loop
462 Analyze_Contract_Case (CCase);
466 if Restore_Scope then
472 Error_Msg_N ("wrong syntax for aspect Contract_Cases", N);
474 end Analyze_Contract_Cases_In_Decl_Part;
476 ----------------------------------
477 -- Analyze_Depends_In_Decl_Part --
478 ----------------------------------
480 procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is
481 Loc : constant Source_Ptr := Sloc (N);
483 All_Inputs_Seen : Elist_Id := No_Elist;
484 -- A list containing the entities of all the inputs processed so far.
485 -- The list is populated with unique entities because the same input
486 -- may appear in multiple input lists.
488 All_Outputs_Seen : Elist_Id := No_Elist;
489 -- A list containing the entities of all the outputs processed so far.
490 -- The list is populated with unique entities because output items are
491 -- unique in a dependence relation.
493 Global_Seen : Boolean := False;
494 -- A flag set when pragma Global has been processed
496 Null_Output_Seen : Boolean := False;
497 -- A flag used to track the legality of a null output
499 Result_Seen : Boolean := False;
500 -- A flag set when Subp_Id'Result is processed
503 -- The entity of the subprogram subject to pragma [Refined_]Depends
506 -- The entity of the subprogram [body or stub] subject to pragma
507 -- [Refined_]Depends.
509 Subp_Inputs : Elist_Id := No_Elist;
510 Subp_Outputs : Elist_Id := No_Elist;
511 -- Two lists containing the full set of inputs and output of the related
512 -- subprograms. Note that these lists contain both nodes and entities.
514 procedure Analyze_Dependency_Clause
517 -- Verify the legality of a single dependency clause. Flag Is_Last
518 -- denotes whether Clause is the last clause in the relation.
520 procedure Check_Function_Return;
521 -- Verify that Funtion'Result appears as one of the outputs
528 -- Ensure that an item has a proper IN, IN OUT, or OUT mode depending
529 -- on its function. If this is not the case, emit an error. Item and
530 -- Item_Id denote the attributes of an item. Flag Is_Input should be set
531 -- when item comes from an input list. Flag Self_Ref should be set when
532 -- the item is an output and the dependency clause has operator "+".
534 procedure Check_Usage
535 (Subp_Items : Elist_Id;
536 Used_Items : Elist_Id;
538 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
539 -- error if this is not the case.
541 procedure Normalize_Clause (Clause : Node_Id);
542 -- Remove a self-dependency "+" from the input list of a clause. Split
543 -- a clause with multiple outputs into multiple clauses with a single
546 -------------------------------
547 -- Analyze_Dependency_Clause --
548 -------------------------------
550 procedure Analyze_Dependency_Clause
554 procedure Analyze_Input_List (Inputs : Node_Id);
555 -- Verify the legality of a single input list
557 procedure Analyze_Input_Output
562 Seen : in out Elist_Id;
563 Null_Seen : in out Boolean);
564 -- Verify the legality of a single input or output item. Flag
565 -- Is_Input should be set whenever Item is an input, False when it
566 -- denotes an output. Flag Self_Ref should be set when the item is an
567 -- output and the dependency clause has a "+". Flag Top_Level should
568 -- be set whenever Item appears immediately within an input or output
569 -- list. Seen is a collection of all abstract states, variables and
570 -- formals processed so far. Flag Null_Seen denotes whether a null
571 -- input or output has been encountered.
573 ------------------------
574 -- Analyze_Input_List --
575 ------------------------
577 procedure Analyze_Input_List (Inputs : Node_Id) is
578 Inputs_Seen : Elist_Id := No_Elist;
579 -- A list containing the entities of all inputs that appear in the
580 -- current input list.
582 Null_Input_Seen : Boolean := False;
583 -- A flag used to track the legality of a null input
588 -- Multiple inputs appear as an aggregate
590 if Nkind (Inputs) = N_Aggregate then
591 if Present (Component_Associations (Inputs)) then
593 ("nested dependency relations not allowed", Inputs);
595 elsif Present (Expressions (Inputs)) then
596 Input := First (Expressions (Inputs));
597 while Present (Input) loop
604 Null_Seen => Null_Input_Seen);
610 Error_Msg_N ("malformed input dependency list", Inputs);
613 -- Process a solitary input
622 Null_Seen => Null_Input_Seen);
625 -- Detect an illegal dependency clause of the form
629 if Null_Output_Seen and then Null_Input_Seen then
631 ("null dependency clause cannot have a null input list",
634 end Analyze_Input_List;
636 --------------------------
637 -- Analyze_Input_Output --
638 --------------------------
640 procedure Analyze_Input_Output
645 Seen : in out Elist_Id;
646 Null_Seen : in out Boolean)
648 Is_Output : constant Boolean := not Is_Input;
653 -- Multiple input or output items appear as an aggregate
655 if Nkind (Item) = N_Aggregate then
656 if not Top_Level then
657 Error_Msg_N ("nested grouping of items not allowed", Item);
659 elsif Present (Component_Associations (Item)) then
661 ("nested dependency relations not allowed", Item);
663 -- Recursively analyze the grouped items
665 elsif Present (Expressions (Item)) then
666 Grouped := First (Expressions (Item));
667 while Present (Grouped) loop
670 Is_Input => Is_Input,
671 Self_Ref => Self_Ref,
674 Null_Seen => Null_Seen);
680 Error_Msg_N ("malformed dependency list", Item);
683 -- Process Function'Result in the context of a dependency clause
685 elsif Is_Attribute_Result (Item) then
687 -- It is sufficent to analyze the prefix of 'Result in order to
688 -- establish legality of the attribute.
690 Analyze (Prefix (Item));
692 -- The prefix of 'Result must denote the function for which
693 -- pragma Depends applies.
695 if not Is_Entity_Name (Prefix (Item))
696 or else Ekind (Spec_Id) /= E_Function
697 or else Entity (Prefix (Item)) /= Spec_Id
699 Error_Msg_Name_1 := Name_Result;
701 ("prefix of attribute % must denote the enclosing "
704 -- Function'Result is allowed to appear on the output side of a
705 -- dependency clause.
708 Error_Msg_N ("function result cannot act as input", Item);
714 -- Detect multiple uses of null in a single dependency list or
715 -- throughout the whole relation. Verify the placement of a null
716 -- output list relative to the other clauses.
718 elsif Nkind (Item) = N_Null then
721 ("multiple null dependency relations not allowed", Item);
725 if Is_Output and then not Is_Last then
727 ("null output list must be the last clause in a "
728 & "dependency relation", Item);
737 -- Find the entity of the item. If this is a renaming, climb
738 -- the renaming chain to reach the root object. Renamings of
739 -- non-entire objects do not yield an entity (Empty).
741 Item_Id := Entity_Of (Item);
743 if Present (Item_Id) then
744 if Ekind_In (Item_Id, E_Abstract_State,
750 -- Ensure that the item is of the correct mode depending
753 Check_Mode (Item, Item_Id, Is_Input, Self_Ref);
755 -- Detect multiple uses of the same state, variable or
756 -- formal parameter. If this is not the case, add the
757 -- item to the list of processed relations.
759 if Contains (Seen, Item_Id) then
760 Error_Msg_N ("duplicate use of item", Item);
762 Add_Item (Item_Id, Seen);
765 -- Detect illegal use of an input related to a null
766 -- output. Such input items cannot appear in other
770 and then Null_Output_Seen
771 and then Contains (All_Inputs_Seen, Item_Id)
774 ("input of a null output list appears in multiple "
775 & "input lists", Item);
778 -- Add an input or a self-referential output to the list
779 -- of all processed inputs.
781 if Is_Input or else Self_Ref then
782 Add_Item (Item_Id, All_Inputs_Seen);
785 if Ekind (Item_Id) = E_Abstract_State then
787 -- The state acts as a constituent of some other
788 -- state. Ensure that the other state is a proper
789 -- ancestor of the item.
791 if Present (Refined_State (Item_Id)) then
793 (Item_Id, Refined_State (Item_Id))
796 Chars (Refined_State (Item_Id));
798 ("state & is not a valid constituent of "
799 & "ancestor state %", Item, Item_Id);
803 -- An abstract state with visible refinement cannot
804 -- appear in pragma [Refined_]Global as its place must
805 -- be taken by some of its constituents.
807 elsif Has_Visible_Refinement (Item_Id) then
809 ("cannot mention state & in global refinement, "
810 & "use its constituents instead", Item, Item_Id);
815 -- When the item renames an entire object, replace the
816 -- item with a reference to the object.
818 if Present (Renamed_Object (Entity (Item))) then
820 New_Reference_To (Item_Id, Sloc (Item)));
824 -- All other input/output items are illegal
828 ("item must denote variable, state or formal "
829 & "parameter", Item);
832 -- All other input/output items are illegal
836 ("item must denote variable, state or formal parameter",
840 end Analyze_Input_Output;
848 -- Start of processing for Analyze_Dependency_Clause
851 Inputs := Expression (Clause);
854 -- An input list with a self-dependency appears as operator "+" where
855 -- the actuals inputs are the right operand.
857 if Nkind (Inputs) = N_Op_Plus then
858 Inputs := Right_Opnd (Inputs);
862 -- Process the output_list of a dependency_clause
864 Output := First (Choices (Clause));
865 while Present (Output) loop
869 Self_Ref => Self_Ref,
871 Seen => All_Outputs_Seen,
872 Null_Seen => Null_Output_Seen);
877 -- Process the input_list of a dependency_clause
879 Analyze_Input_List (Inputs);
880 end Analyze_Dependency_Clause;
882 ----------------------------
883 -- Check_Function_Return --
884 ----------------------------
886 procedure Check_Function_Return is
888 if Ekind (Spec_Id) = E_Function and then not Result_Seen then
890 ("result of & must appear in exactly one output list",
893 end Check_Function_Return;
910 -- IN and IN OUT parameters already have the proper mode to act
911 -- as input. OUT parameters are valid inputs only when their type
912 -- is unconstrained or tagged as their discriminants, array bouns
913 -- or tags can be read. In general, states and variables are
914 -- considered to have mode IN OUT unless they are moded by pragma
915 -- [Refined_]Global. In that case, the item must appear in an
916 -- input global list.
918 if (Ekind (Item_Id) = E_Out_Parameter
919 and then not Is_Unconstrained_Or_Tagged_Item (Item_Id))
921 (Global_Seen and then not Appears_In (Subp_Inputs, Item_Id))
924 ("item & must have mode IN or `IN OUT`", Item, Item_Id);
927 -- Self-referential output
931 -- In general, states and variables are considered to have mode
932 -- IN OUT unless they are explicitly moded by pragma [Refined_]
933 -- Global. If this is the case, then the item must appear in both
934 -- an input and output global list.
936 if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
939 (Appears_In (Subp_Inputs, Item_Id)
941 Appears_In (Subp_Outputs, Item_Id))
944 ("item & must have mode `IN OUT`", Item, Item_Id);
947 -- A self-referential OUT parameter of an unconstrained or tagged
948 -- type acts as an input because the discriminants, array bounds
949 -- or the tag may be read. Note that the presence of [Refined_]
950 -- Global is not significant here because the item is a parameter.
952 elsif Ekind (Item_Id) = E_Out_Parameter
953 and then Is_Unconstrained_Or_Tagged_Item (Item_Id)
957 -- The remaining cases are IN, IN OUT, and OUT parameters. To
958 -- qualify as self-referential item, the parameter must be of
961 elsif Ekind (Item_Id) /= E_In_Out_Parameter then
962 Error_Msg_NE ("item & must have mode `IN OUT`", Item, Item_Id);
967 -- IN OUT and OUT parameters already have the proper mode to act as
968 -- output. In general, states and variables are considered to have
969 -- mode IN OUT unless they are moded by pragma [Refined_]Global. In
970 -- that case, the item must appear in an output global list.
972 elsif Ekind (Item_Id) = E_In_Parameter
974 (Global_Seen and then not Appears_In (Subp_Outputs, Item_Id))
977 ("item & must have mode OUT or `IN OUT`", Item, Item_Id);
985 procedure Check_Usage
986 (Subp_Items : Elist_Id;
987 Used_Items : Elist_Id;
990 procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id);
991 -- Emit an error concerning the erroneous usage of an item
997 procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id) is
1001 ("item & must appear in at least one input list of aspect "
1002 & "Depends", Item, Item_Id);
1005 ("item & must appear in exactly one output list of aspect "
1006 & "Depends", Item, Item_Id);
1014 Item_Id : Entity_Id;
1016 -- Start of processing for Check_Usage
1019 if No (Subp_Items) then
1023 -- Each input or output of the subprogram must appear in a dependency
1026 Elmt := First_Elmt (Subp_Items);
1027 while Present (Elmt) loop
1028 Item := Node (Elmt);
1030 if Nkind (Item) = N_Defining_Identifier then
1033 Item_Id := Entity (Item);
1036 -- The item does not appear in a dependency
1038 if not Contains (Used_Items, Item_Id) then
1039 if Is_Formal (Item_Id) then
1040 Usage_Error (Item, Item_Id);
1042 -- States and global variables are not used properly only when
1043 -- the subprogram is subject to pragma Global.
1045 elsif Global_Seen then
1046 Usage_Error (Item, Item_Id);
1054 ----------------------
1055 -- Normalize_Clause --
1056 ----------------------
1058 procedure Normalize_Clause (Clause : Node_Id) is
1059 procedure Create_Or_Modify_Clause
1065 Multiple : Boolean);
1066 -- Create a brand new clause to represent the self-reference or
1067 -- modify the input and/or output lists of an existing clause. Output
1068 -- denotes a self-referencial output. Outputs is the output list of a
1069 -- clause. Inputs is the input list of a clause. After denotes the
1070 -- clause after which the new clause is to be inserted. Flag In_Place
1071 -- should be set when normalizing the last output of an output list.
1072 -- Flag Multiple should be set when Output comes from a list with
1075 procedure Split_Multiple_Outputs;
1076 -- If Clause contains more than one output, split the clause into
1077 -- multiple clauses with a single output. All new clauses are added
1080 -----------------------------
1081 -- Create_Or_Modify_Clause --
1082 -----------------------------
1084 procedure Create_Or_Modify_Clause
1092 procedure Propagate_Output
1095 -- Handle the various cases of output propagation to the input
1096 -- list. Output denotes a self-referencial output item. Inputs is
1097 -- the input list of a clause.
1099 ----------------------
1100 -- Propagate_Output --
1101 ----------------------
1103 procedure Propagate_Output
1107 function In_Input_List
1109 Inputs : List_Id) return Boolean;
1110 -- Determine whether a particulat item appears in the input
1111 -- list of a clause.
1117 function In_Input_List
1119 Inputs : List_Id) return Boolean
1124 Elmt := First (Inputs);
1125 while Present (Elmt) loop
1126 if Entity_Of (Elmt) = Item then
1138 Output_Id : constant Entity_Id := Entity_Of (Output);
1141 -- Start of processing for Propagate_Output
1144 -- The clause is of the form:
1146 -- (Output =>+ null)
1148 -- Remove the null input and replace it with a copy of the
1151 -- (Output => Output)
1153 if Nkind (Inputs) = N_Null then
1154 Rewrite (Inputs, New_Copy_Tree (Output));
1156 -- The clause is of the form:
1158 -- (Output =>+ (Input1, ..., InputN))
1160 -- Determine whether the output is not already mentioned in the
1161 -- input list and if not, add it to the list of inputs:
1163 -- (Output => (Output, Input1, ..., InputN))
1165 elsif Nkind (Inputs) = N_Aggregate then
1166 Grouped := Expressions (Inputs);
1168 if not In_Input_List
1172 Prepend_To (Grouped, New_Copy_Tree (Output));
1175 -- The clause is of the form:
1177 -- (Output =>+ Input)
1179 -- If the input does not mention the output, group the two
1182 -- (Output => (Output, Input))
1184 elsif Entity_Of (Inputs) /= Output_Id then
1186 Make_Aggregate (Loc,
1187 Expressions => New_List (
1188 New_Copy_Tree (Output),
1189 New_Copy_Tree (Inputs))));
1191 end Propagate_Output;
1195 Loc : constant Source_Ptr := Sloc (Clause);
1196 New_Clause : Node_Id;
1198 -- Start of processing for Create_Or_Modify_Clause
1201 -- A null output depending on itself does not require any
1204 if Nkind (Output) = N_Null then
1207 -- A function result cannot depend on itself because it cannot
1208 -- appear in the input list of a relation.
1210 elsif Is_Attribute_Result (Output) then
1211 Error_Msg_N ("function result cannot depend on itself", Output);
1215 -- When performing the transformation in place, simply add the
1216 -- output to the list of inputs (if not already there). This case
1217 -- arises when dealing with the last output of an output list -
1218 -- we perform the normalization in place to avoid generating a
1222 Propagate_Output (Output, Inputs);
1224 -- A list with multiple outputs is slowly trimmed until only
1225 -- one element remains. When this happens, replace the
1226 -- aggregate with the element itself.
1230 Rewrite (Outputs, Output);
1236 -- Unchain the output from its output list as it will appear in
1237 -- a new clause. Note that we cannot simply rewrite the output
1238 -- as null because this will violate the semantics of pragma
1243 -- Generate a new clause of the form:
1244 -- (Output => Inputs)
1247 Make_Component_Association (Loc,
1248 Choices => New_List (Output),
1249 Expression => New_Copy_Tree (Inputs));
1251 -- The new clause contains replicated content that has already
1252 -- been analyzed. There is not need to reanalyze it or
1253 -- renormalize it again.
1255 Set_Analyzed (New_Clause);
1258 (Output => First (Choices (New_Clause)),
1259 Inputs => Expression (New_Clause));
1261 Insert_After (After, New_Clause);
1263 end Create_Or_Modify_Clause;
1265 ----------------------------
1266 -- Split_Multiple_Outputs --
1267 ----------------------------
1269 procedure Split_Multiple_Outputs is
1270 Inputs : constant Node_Id := Expression (Clause);
1271 Loc : constant Source_Ptr := Sloc (Clause);
1272 Outputs : constant Node_Id := First (Choices (Clause));
1273 Last_Output : Node_Id;
1274 Next_Output : Node_Id;
1278 -- Start of processing for Split_Multiple_Outputs
1281 -- Multiple outputs appear as an aggregate. Nothing to do when
1282 -- the clause has exactly one output.
1284 if Nkind (Outputs) = N_Aggregate then
1285 Last_Output := Last (Expressions (Outputs));
1287 -- Create a clause for each output. Note that each time a new
1288 -- clause is created, the original output list slowly shrinks
1289 -- until there is one item left.
1291 Output := First (Expressions (Outputs));
1292 while Present (Output) loop
1293 Next_Output := Next (Output);
1295 -- Unhook the output from the original output list as it
1296 -- will be relocated to a new clause.
1300 -- Special processing for the last output. At this point
1301 -- the original aggregate has been stripped down to one
1302 -- element. Replace the aggregate by the element itself.
1304 if Output = Last_Output then
1305 Rewrite (Outputs, Output);
1308 -- Generate a clause of the form:
1309 -- (Output => Inputs)
1312 Make_Component_Association (Loc,
1313 Choices => New_List (Output),
1314 Expression => New_Copy_Tree (Inputs));
1316 -- The new clause contains replicated content that has
1317 -- already been analyzed. There is not need to reanalyze
1320 Set_Analyzed (Split);
1321 Insert_After (Clause, Split);
1324 Output := Next_Output;
1327 end Split_Multiple_Outputs;
1331 Outputs : constant Node_Id := First (Choices (Clause));
1333 Last_Output : Node_Id;
1334 Next_Output : Node_Id;
1337 -- Start of processing for Normalize_Clause
1340 -- A self-dependency appears as operator "+". Remove the "+" from the
1341 -- tree by moving the real inputs to their proper place.
1343 if Nkind (Expression (Clause)) = N_Op_Plus then
1344 Rewrite (Expression (Clause), Right_Opnd (Expression (Clause)));
1345 Inputs := Expression (Clause);
1347 -- Multiple outputs appear as an aggregate
1349 if Nkind (Outputs) = N_Aggregate then
1350 Last_Output := Last (Expressions (Outputs));
1352 Output := First (Expressions (Outputs));
1353 while Present (Output) loop
1355 -- Normalization may remove an output from its list,
1356 -- preserve the subsequent output now.
1358 Next_Output := Next (Output);
1360 Create_Or_Modify_Clause
1365 In_Place => Output = Last_Output,
1368 Output := Next_Output;
1374 Create_Or_Modify_Clause
1384 -- Split a clause with multiple outputs into multiple clauses with a
1387 Split_Multiple_Outputs;
1388 end Normalize_Clause;
1394 Last_Clause : Node_Id;
1395 Subp_Decl : Node_Id;
1397 Restore_Scope : Boolean := False;
1398 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
1400 -- Start of processing for Analyze_Depends_In_Decl_Part
1405 Subp_Decl := Find_Related_Subprogram_Or_Body (N);
1406 Subp_Id := Defining_Entity (Subp_Decl);
1408 -- The logic in this routine is used to analyze both pragma Depends and
1409 -- pragma Refined_Depends since they have the same syntax and base
1410 -- semantics. Find the entity of the corresponding spec when analyzing
1413 if Nkind (Subp_Decl) = N_Subprogram_Body
1414 and then not Acts_As_Spec (Subp_Decl)
1416 Spec_Id := Corresponding_Spec (Subp_Decl);
1418 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub then
1419 Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl);
1425 Clause := Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
1427 -- Empty dependency list
1429 if Nkind (Clause) = N_Null then
1431 -- Gather all states, variables and formal parameters that the
1432 -- subprogram may depend on. These items are obtained from the
1433 -- parameter profile or pragma [Refined_]Global (if available).
1435 Collect_Subprogram_Inputs_Outputs
1436 (Subp_Id => Subp_Id,
1437 Subp_Inputs => Subp_Inputs,
1438 Subp_Outputs => Subp_Outputs,
1439 Global_Seen => Global_Seen);
1441 -- Verify that every input or output of the subprogram appear in a
1444 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1445 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1446 Check_Function_Return;
1448 -- Dependency clauses appear as component associations of an aggregate
1450 elsif Nkind (Clause) = N_Aggregate
1451 and then Present (Component_Associations (Clause))
1453 Last_Clause := Last (Component_Associations (Clause));
1455 -- Gather all states, variables and formal parameters that the
1456 -- subprogram may depend on. These items are obtained from the
1457 -- parameter profile or pragma [Refined_]Global (if available).
1459 Collect_Subprogram_Inputs_Outputs
1460 (Subp_Id => Subp_Id,
1461 Subp_Inputs => Subp_Inputs,
1462 Subp_Outputs => Subp_Outputs,
1463 Global_Seen => Global_Seen);
1465 -- Ensure that the formal parameters are visible when analyzing all
1466 -- clauses. This falls out of the general rule of aspects pertaining
1467 -- to subprogram declarations. Skip the installation for subprogram
1468 -- bodies because the formals are already visible.
1470 if not In_Open_Scopes (Spec_Id) then
1471 Restore_Scope := True;
1472 Push_Scope (Spec_Id);
1473 Install_Formals (Spec_Id);
1476 Clause := First (Component_Associations (Clause));
1477 while Present (Clause) loop
1478 Errors := Serious_Errors_Detected;
1480 -- Normalization may create extra clauses that contain replicated
1481 -- input and output names. There is no need to reanalyze them.
1483 if not Analyzed (Clause) then
1484 Set_Analyzed (Clause);
1486 Analyze_Dependency_Clause
1488 Is_Last => Clause = Last_Clause);
1491 -- Do not normalize an erroneous clause because the inputs and/or
1492 -- outputs may denote illegal items.
1494 if Serious_Errors_Detected = Errors then
1495 Normalize_Clause (Clause);
1501 if Restore_Scope then
1505 -- Verify that every input or output of the subprogram appear in a
1508 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1509 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1510 Check_Function_Return;
1512 -- The top level dependency relation is malformed
1515 Error_Msg_N ("malformed dependency relation", Clause);
1517 end Analyze_Depends_In_Decl_Part;
1519 ---------------------------------
1520 -- Analyze_Global_In_Decl_Part --
1521 ---------------------------------
1523 procedure Analyze_Global_In_Decl_Part (N : Node_Id) is
1524 Seen : Elist_Id := No_Elist;
1525 -- A list containing the entities of all the items processed so far. It
1526 -- plays a role in detecting distinct entities.
1528 Spec_Id : Entity_Id;
1529 -- The entity of the subprogram subject to pragma [Refined_]Global
1531 Subp_Id : Entity_Id;
1532 -- The entity of the subprogram [body or stub] subject to pragma
1533 -- [Refined_]Global.
1535 In_Out_Seen : Boolean := False;
1536 Input_Seen : Boolean := False;
1537 Output_Seen : Boolean := False;
1538 Proof_Seen : Boolean := False;
1539 -- Flags used to verify the consistency of modes
1541 procedure Analyze_Global_List
1543 Global_Mode : Name_Id := Name_Input);
1544 -- Verify the legality of a single global list declaration. Global_Mode
1545 -- denotes the current mode in effect.
1547 -------------------------
1548 -- Analyze_Global_List --
1549 -------------------------
1551 procedure Analyze_Global_List
1553 Global_Mode : Name_Id := Name_Input)
1555 procedure Analyze_Global_Item
1557 Global_Mode : Name_Id);
1558 -- Verify the legality of a single global item declaration.
1559 -- Global_Mode denotes the current mode in effect.
1561 procedure Check_Duplicate_Mode
1563 Status : in out Boolean);
1564 -- Flag Status denotes whether a particular mode has been seen while
1565 -- processing a global list. This routine verifies that Mode is not a
1566 -- duplicate mode and sets the flag Status.
1568 procedure Check_Mode_Restriction_In_Enclosing_Context
1570 Item_Id : Entity_Id);
1571 -- Verify that an item of mode In_Out or Output does not appear as an
1572 -- input in the Global aspect of an enclosing subprogram. If this is
1573 -- the case, emit an error. Item and Item_Id are respectively the
1574 -- item and its entity.
1576 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id);
1577 -- Mode denotes either In_Out or Output. Depending on the kind of the
1578 -- related subprogram, emit an error if those two modes apply to a
1581 -------------------------
1582 -- Analyze_Global_Item --
1583 -------------------------
1585 procedure Analyze_Global_Item
1587 Global_Mode : Name_Id)
1589 Item_Id : Entity_Id;
1592 -- Detect one of the following cases
1594 -- with Global => (null, Name)
1595 -- with Global => (Name_1, null, Name_2)
1596 -- with Global => (Name, null)
1598 if Nkind (Item) = N_Null then
1599 Error_Msg_N ("cannot mix null and non-null global items", Item);
1605 -- Find the entity of the item. If this is a renaming, climb the
1606 -- renaming chain to reach the root object. Renamings of non-
1607 -- entire objects do not yield an entity (Empty).
1609 Item_Id := Entity_Of (Item);
1611 if Present (Item_Id) then
1613 -- A global item may denote a formal parameter of an enclosing
1614 -- subprogram. Do this check first to provide a better error
1617 if Is_Formal (Item_Id) then
1618 if Scope (Item_Id) = Spec_Id then
1620 ("global item cannot reference formal parameter", Item);
1624 -- The only legal references are those to abstract states and
1627 elsif not Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
1629 ("global item must denote variable or state", Item);
1633 if Ekind (Item_Id) = E_Abstract_State then
1635 -- The state acts as a constituent of some other state.
1636 -- Ensure that the other state is a proper ancestor of the
1639 if Present (Refined_State (Item_Id)) then
1640 if not Is_Part_Of (Item_Id, Refined_State (Item_Id)) then
1641 Error_Msg_Name_1 := Chars (Refined_State (Item_Id));
1643 ("state & is not a valid constituent of ancestor "
1644 & "state %", Item, Item_Id);
1648 -- An abstract state with visible refinement cannot appear
1649 -- in pragma [Refined_]Global as its place must be taken by
1650 -- some of its constituents.
1652 elsif Has_Visible_Refinement (Item_Id) then
1654 ("cannot mention state & in global refinement, use its "
1655 & "constituents instead", Item, Item_Id);
1660 -- When the item renames an entire object, replace the item
1661 -- with a reference to the object.
1663 if Present (Renamed_Object (Entity (Item))) then
1664 Rewrite (Item, New_Reference_To (Item_Id, Sloc (Item)));
1668 -- Some form of illegal construct masquerading as a name
1671 Error_Msg_N ("global item must denote variable or state", Item);
1675 -- At this point we know that the global item is one of the two
1676 -- valid choices. Perform mode- and usage-specific checks.
1678 if Ekind (Item_Id) = E_Abstract_State
1679 and then Is_External_State (Item_Id)
1681 -- A global item of mode In_Out or Output cannot denote an
1682 -- external Input_Only state.
1684 if Is_Input_Only_State (Item_Id)
1685 and then Nam_In (Global_Mode, Name_In_Out, Name_Output)
1688 ("global item of mode In_Out or Output cannot reference "
1689 & "External Input_Only state", Item);
1691 -- A global item of mode In_Out or Input cannot reference an
1692 -- external Output_Only state.
1694 elsif Is_Output_Only_State (Item_Id)
1695 and then Nam_In (Global_Mode, Name_In_Out, Name_Input)
1698 ("global item of mode In_Out or Input cannot reference "
1699 & "External Output_Only state", Item);
1703 -- Verify that an output does not appear as an input in an
1704 -- enclosing subprogram.
1706 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
1707 Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id);
1710 -- The same entity might be referenced through various way. Check
1711 -- the entity of the item rather than the item itself.
1713 if Contains (Seen, Item_Id) then
1714 Error_Msg_N ("duplicate global item", Item);
1716 -- Add the entity of the current item to the list of processed
1720 Add_Item (Item_Id, Seen);
1722 end Analyze_Global_Item;
1724 --------------------------
1725 -- Check_Duplicate_Mode --
1726 --------------------------
1728 procedure Check_Duplicate_Mode
1730 Status : in out Boolean)
1734 Error_Msg_N ("duplicate global mode", Mode);
1738 end Check_Duplicate_Mode;
1740 -------------------------------------------------
1741 -- Check_Mode_Restriction_In_Enclosing_Context --
1742 -------------------------------------------------
1744 procedure Check_Mode_Restriction_In_Enclosing_Context
1746 Item_Id : Entity_Id)
1748 Context : Entity_Id;
1750 Inputs : Elist_Id := No_Elist;
1751 Outputs : Elist_Id := No_Elist;
1754 -- Traverse the scope stack looking for enclosing subprograms
1755 -- subject to pragma [Refined_]Global.
1757 Context := Scope (Subp_Id);
1758 while Present (Context) and then Context /= Standard_Standard loop
1759 if Is_Subprogram (Context)
1760 and then Present (Get_Pragma (Context, Pragma_Global))
1762 Collect_Subprogram_Inputs_Outputs
1763 (Subp_Id => Context,
1764 Subp_Inputs => Inputs,
1765 Subp_Outputs => Outputs,
1766 Global_Seen => Dummy);
1768 -- The item is classified as In_Out or Output but appears as
1769 -- an Input in an enclosing subprogram.
1771 if Appears_In (Inputs, Item_Id)
1772 and then not Appears_In (Outputs, Item_Id)
1775 ("global item & cannot have mode In_Out or Output",
1778 ("\item already appears as input of subprogram &",
1781 -- Stop the traversal once an error has been detected
1787 Context := Scope (Context);
1789 end Check_Mode_Restriction_In_Enclosing_Context;
1791 ----------------------------------------
1792 -- Check_Mode_Restriction_In_Function --
1793 ----------------------------------------
1795 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
1797 if Ekind (Spec_Id) = E_Function then
1799 ("global mode & not applicable to functions", Mode);
1801 end Check_Mode_Restriction_In_Function;
1809 -- Start of processing for Analyze_Global_List
1812 if Nkind (List) = N_Null then
1815 -- Single global item declaration
1817 elsif Nkind_In (List, N_Expanded_Name,
1819 N_Selected_Component)
1821 Analyze_Global_Item (List, Global_Mode);
1823 -- Simple global list or moded global list declaration
1825 elsif Nkind (List) = N_Aggregate then
1827 -- The declaration of a simple global list appear as a collection
1830 if Present (Expressions (List)) then
1831 if Present (Component_Associations (List)) then
1833 ("cannot mix moded and non-moded global lists", List);
1836 Item := First (Expressions (List));
1837 while Present (Item) loop
1838 Analyze_Global_Item (Item, Global_Mode);
1843 -- The declaration of a moded global list appears as a collection
1844 -- of component associations where individual choices denote
1847 elsif Present (Component_Associations (List)) then
1848 if Present (Expressions (List)) then
1850 ("cannot mix moded and non-moded global lists", List);
1853 Assoc := First (Component_Associations (List));
1854 while Present (Assoc) loop
1855 Mode := First (Choices (Assoc));
1857 if Nkind (Mode) = N_Identifier then
1858 if Chars (Mode) = Name_In_Out then
1859 Check_Duplicate_Mode (Mode, In_Out_Seen);
1860 Check_Mode_Restriction_In_Function (Mode);
1862 elsif Chars (Mode) = Name_Input then
1863 Check_Duplicate_Mode (Mode, Input_Seen);
1865 elsif Chars (Mode) = Name_Output then
1866 Check_Duplicate_Mode (Mode, Output_Seen);
1867 Check_Mode_Restriction_In_Function (Mode);
1869 elsif Chars (Mode) = Name_Proof_In then
1870 Check_Duplicate_Mode (Mode, Proof_Seen);
1873 Error_Msg_N ("invalid mode selector", Mode);
1877 Error_Msg_N ("invalid mode selector", Mode);
1880 -- Items in a moded list appear as a collection of
1881 -- expressions. Reuse the existing machinery to analyze
1885 (List => Expression (Assoc),
1886 Global_Mode => Chars (Mode));
1894 raise Program_Error;
1897 -- Any other attempt to declare a global item is erroneous
1900 Error_Msg_N ("malformed global list declaration", List);
1902 end Analyze_Global_List;
1907 Subp_Decl : Node_Id;
1909 Restore_Scope : Boolean := False;
1910 -- Set True if we do a Push_Scope requiring a Pop_Scope on exit
1912 -- Start of processing for Analyze_Global_In_Decl_List
1917 Subp_Decl := Find_Related_Subprogram_Or_Body (N);
1918 Subp_Id := Defining_Entity (Subp_Decl);
1920 -- The logic in this routine is used to analyze both pragma Global and
1921 -- pragma Refined_Global since they have the same syntax and base
1922 -- semantics. Find the entity of the corresponding spec when analyzing
1925 if Nkind (Subp_Decl) = N_Subprogram_Body
1926 and then not Acts_As_Spec (Subp_Decl)
1928 Spec_Id := Corresponding_Spec (Subp_Decl);
1930 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub then
1931 Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl);
1937 Items := Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
1939 -- There is nothing to be done for a null global list
1941 if Nkind (Items) = N_Null then
1944 -- Analyze the various forms of global lists and items. Note that some
1945 -- of these may be malformed in which case the analysis emits error
1949 -- Ensure that the formal parameters are visible when processing an
1950 -- item. This falls out of the general rule of aspects pertaining to
1951 -- subprogram declarations.
1953 if not In_Open_Scopes (Spec_Id) then
1954 Restore_Scope := True;
1955 Push_Scope (Spec_Id);
1956 Install_Formals (Spec_Id);
1959 Analyze_Global_List (Items);
1961 if Restore_Scope then
1965 end Analyze_Global_In_Decl_Part;
1967 --------------------------------------
1968 -- Analyze_Initializes_In_Decl_Part --
1969 --------------------------------------
1971 procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is
1972 Pack_Spec : constant Node_Id := Parent (N);
1973 Pack_Id : constant Entity_Id := Defining_Entity (Parent (Pack_Spec));
1975 Items_Seen : Elist_Id := No_Elist;
1976 -- A list of all initialization items processed so far. This list is
1977 -- used to detect duplicate items.
1979 Non_Null_Seen : Boolean := False;
1980 Null_Seen : Boolean := False;
1981 -- Flags used to check the legality of a null initialization list
1983 States_And_Vars : Elist_Id := No_Elist;
1984 -- A list of all abstract states and variables declared in the visible
1985 -- declarations of the related package. This list is used to detect the
1986 -- legality of initialization items.
1988 procedure Analyze_Initialization_Item (Item : Node_Id);
1989 -- Verify the legality of a single initialization item
1991 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id);
1992 -- Verify the legality of a single initialization item followed by a
1993 -- list of input items.
1995 procedure Collect_States_And_Variables;
1996 -- Inspect the visible declarations of the related package and gather
1997 -- the entities of all abstract states and variables in States_And_Vars.
1999 ---------------------------------
2000 -- Analyze_Initialization_Item --
2001 ---------------------------------
2003 procedure Analyze_Initialization_Item (Item : Node_Id) is
2004 Item_Id : Entity_Id;
2007 -- A package with null initialization list is not allowed to have
2008 -- additional initializations.
2011 Error_Msg_NE ("package & has null initialization", Item, Pack_Id);
2013 -- Null initialization list
2015 elsif Nkind (Item) = N_Null then
2017 -- Catch a case where a null initialization item appears in a list
2018 -- of non-null items.
2020 if Non_Null_Seen then
2022 ("package & has non-null initialization", Item, Pack_Id);
2027 -- Initialization item
2030 Non_Null_Seen := True;
2034 if Is_Entity_Name (Item) then
2035 Item_Id := Entity (Item);
2037 if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
2039 -- The state or variable must be declared in the visible
2040 -- declarations of the package.
2042 if not Contains (States_And_Vars, Item_Id) then
2043 Error_Msg_Name_1 := Chars (Pack_Id);
2045 ("initialization item & must appear in the visible "
2046 & "declarations of package %", Item, Item_Id);
2048 -- Detect a duplicate use of the same initialization item
2050 elsif Contains (Items_Seen, Item_Id) then
2051 Error_Msg_N ("duplicate initialization item", Item);
2053 -- The item is legal, add it to the list of processed states
2057 Add_Item (Item_Id, Items_Seen);
2060 -- The item references something that is not a state or a
2065 ("initialization item must denote variable or state",
2069 -- Some form of illegal construct masquerading as a name
2073 ("initialization item must denote variable or state", Item);
2076 end Analyze_Initialization_Item;
2078 ---------------------------------------------
2079 -- Analyze_Initialization_Item_With_Inputs --
2080 ---------------------------------------------
2082 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is
2083 Inputs_Seen : Elist_Id := No_Elist;
2084 -- A list of all inputs processed so far. This list is used to detect
2085 -- duplicate uses of an input.
2087 Non_Null_Seen : Boolean := False;
2088 Null_Seen : Boolean := False;
2089 -- Flags used to check the legality of an input list
2091 procedure Analyze_Input_Item (Input : Node_Id);
2092 -- Verify the legality of a single input item
2094 ------------------------
2095 -- Analyze_Input_Item --
2096 ------------------------
2098 procedure Analyze_Input_Item (Input : Node_Id) is
2099 Input_Id : Entity_Id;
2102 -- An initialization item with null inputs is not allowed to have
2103 -- assitional inputs.
2106 Error_Msg_N ("item has null input list", Item);
2110 elsif Nkind (Input) = N_Null then
2112 -- Catch a case where a null input appears in a list of non-
2115 if Non_Null_Seen then
2116 Error_Msg_N ("item has non-null input list", Item);
2124 Non_Null_Seen := True;
2128 if Is_Entity_Name (Input) then
2129 Input_Id := Entity (Input);
2131 if Ekind_In (Input_Id, E_Abstract_State, E_Variable) then
2133 -- The input cannot denote states or variables declared
2134 -- within the visible declarations of the package.
2136 if Contains (States_And_Vars, Input_Id) then
2137 Error_Msg_Name_1 := Chars (Pack_Id);
2139 ("input item & cannot denote a visible variable or "
2140 & "state of package %", Input, Input_Id);
2142 -- Detect a duplicate use of the same input item
2144 elsif Contains (Inputs_Seen, Input_Id) then
2145 Error_Msg_N ("duplicate input item", Input);
2147 -- The input is legal, add it to the list of processed
2151 Add_Item (Input_Id, Inputs_Seen);
2154 -- The input references something that is not a state or a
2159 ("input item must denote variable or state", Input);
2162 -- Some form of illegal construct masquerading as a name
2166 ("input item must denote variable or state", Input);
2169 end Analyze_Input_Item;
2173 Inputs : constant Node_Id := Expression (Item);
2177 Name_Seen : Boolean := False;
2178 -- A flag used to detect multiple item names
2180 -- Start of processing for Analyze_Initialization_Item_With_Inputs
2183 -- Inspect the name of an item with inputs
2185 Elmt := First (Choices (Item));
2186 while Present (Elmt) loop
2188 Error_Msg_N ("only one item allowed in initialization", Elmt);
2192 Analyze_Initialization_Item (Elmt);
2198 -- Multiple input items appear as an aggregate
2200 if Nkind (Inputs) = N_Aggregate then
2201 if Present (Expressions (Inputs)) then
2202 Input := First (Expressions (Inputs));
2203 while Present (Input) loop
2204 Analyze_Input_Item (Input);
2210 if Present (Component_Associations (Inputs)) then
2212 ("inputs must appear in named association form", Inputs);
2215 -- Single input item
2218 Analyze_Input_Item (Inputs);
2220 end Analyze_Initialization_Item_With_Inputs;
2222 ----------------------------------
2223 -- Collect_States_And_Variables --
2224 ----------------------------------
2226 procedure Collect_States_And_Variables is
2230 -- Collect the abstract states defined in the package (if any)
2232 if Present (Abstract_States (Pack_Id)) then
2233 States_And_Vars := New_Copy_Elist (Abstract_States (Pack_Id));
2236 -- Collect all variables the appear in the visible declarations of
2237 -- the related package.
2239 if Present (Visible_Declarations (Pack_Spec)) then
2240 Decl := First (Visible_Declarations (Pack_Spec));
2241 while Present (Decl) loop
2242 if Nkind (Decl) = N_Object_Declaration
2243 and then Ekind (Defining_Entity (Decl)) = E_Variable
2244 and then Comes_From_Source (Decl)
2246 Add_Item (Defining_Entity (Decl), States_And_Vars);
2252 end Collect_States_And_Variables;
2256 Inits : constant Node_Id :=
2257 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
2260 -- Start of processing for Analyze_Initializes_In_Decl_Part
2265 -- Initialize the various lists used during analysis
2267 Collect_States_And_Variables;
2269 -- Multiple initialization clauses appear as an aggregate
2271 if Nkind (Inits) = N_Aggregate then
2272 if Present (Expressions (Inits)) then
2273 Init := First (Expressions (Inits));
2274 while Present (Init) loop
2275 Analyze_Initialization_Item (Init);
2281 if Present (Component_Associations (Inits)) then
2282 Init := First (Component_Associations (Inits));
2283 while Present (Init) loop
2284 Analyze_Initialization_Item_With_Inputs (Init);
2290 -- Various forms of a single initialization clause. Note that these may
2291 -- include malformed initializations.
2294 Analyze_Initialization_Item (Inits);
2296 end Analyze_Initializes_In_Decl_Part;
2298 --------------------
2299 -- Analyze_Pragma --
2300 --------------------
2302 procedure Analyze_Pragma (N : Node_Id) is
2303 Loc : constant Source_Ptr := Sloc (N);
2304 Prag_Id : Pragma_Id;
2307 -- Name of the source pragma, or name of the corresponding aspect for
2308 -- pragmas which originate in a source aspect. In the latter case, the
2309 -- name may be different from the pragma name.
2311 Pragma_Exit : exception;
2312 -- This exception is used to exit pragma processing completely. It is
2313 -- used when an error is detected, and no further processing is
2314 -- required. It is also used if an earlier error has left the tree in
2315 -- a state where the pragma should not be processed.
2318 -- Number of pragma argument associations
2324 -- First four pragma arguments (pragma argument association nodes, or
2325 -- Empty if the corresponding argument does not exist).
2327 type Name_List is array (Natural range <>) of Name_Id;
2328 type Args_List is array (Natural range <>) of Node_Id;
2329 -- Types used for arguments to Check_Arg_Order and Gather_Associations
2331 procedure Ada_2005_Pragma;
2332 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
2333 -- Ada 95 mode, these are implementation defined pragmas, so should be
2334 -- caught by the No_Implementation_Pragmas restriction.
2336 procedure Ada_2012_Pragma;
2337 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
2338 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
2339 -- should be caught by the No_Implementation_Pragmas restriction.
2341 procedure Analyze_Refined_Pragma
2342 (Spec_Id : out Entity_Id;
2343 Body_Id : out Entity_Id;
2344 Legal : out Boolean);
2345 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
2346 -- Refined_Global, Refined_Post and Refined_Pre. Check the placement and
2347 -- related context of the pragma. Spec_Id is the entity of the related
2348 -- subprogram. Body_Id is the entity of the subprogram body. Flag Legal
2349 -- is set when the pragma is properly placed.
2351 procedure Check_Ada_83_Warning;
2352 -- Issues a warning message for the current pragma if operating in Ada
2353 -- 83 mode (used for language pragmas that are not a standard part of
2354 -- Ada 83). This procedure does not raise Error_Pragma. Also notes use
2357 procedure Check_Arg_Count (Required : Nat);
2358 -- Check argument count for pragma is equal to given parameter. If not,
2359 -- then issue an error message and raise Pragma_Exit.
2361 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
2362 -- Arg which can either be a pragma argument association, in which case
2363 -- the check is applied to the expression of the association or an
2364 -- expression directly.
2366 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
2367 -- Check that an argument has the right form for an EXTERNAL_NAME
2368 -- parameter of an extended import/export pragma. The rule is that the
2369 -- name must be an identifier or string literal (in Ada 83 mode) or a
2370 -- static string expression (in Ada 95 mode).
2372 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
2373 -- Check the specified argument Arg to make sure that it is an
2374 -- identifier. If not give error and raise Pragma_Exit.
2376 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
2377 -- Check the specified argument Arg to make sure that it is an integer
2378 -- literal. If not give error and raise Pragma_Exit.
2380 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
2381 -- Check the specified argument Arg to make sure that it has the proper
2382 -- syntactic form for a local name and meets the semantic requirements
2383 -- for a local name. The local name is analyzed as part of the
2384 -- processing for this call. In addition, the local name is required
2385 -- to represent an entity at the library level.
2387 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
2388 -- Check the specified argument Arg to make sure that it has the proper
2389 -- syntactic form for a local name and meets the semantic requirements
2390 -- for a local name. The local name is analyzed as part of the
2391 -- processing for this call.
2393 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
2394 -- Check the specified argument Arg to make sure that it is a valid
2395 -- locking policy name. If not give error and raise Pragma_Exit.
2397 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
2398 -- Check the specified argument Arg to make sure that it is a valid
2399 -- elaboration policy name. If not give error and raise Pragma_Exit.
2401 procedure Check_Arg_Is_One_Of
2404 procedure Check_Arg_Is_One_Of
2406 N1, N2, N3 : Name_Id);
2407 procedure Check_Arg_Is_One_Of
2409 N1, N2, N3, N4 : Name_Id);
2410 procedure Check_Arg_Is_One_Of
2412 N1, N2, N3, N4, N5 : Name_Id);
2413 -- Check the specified argument Arg to make sure that it is an
2414 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
2415 -- present). If not then give error and raise Pragma_Exit.
2417 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
2418 -- Check the specified argument Arg to make sure that it is a valid
2419 -- queuing policy name. If not give error and raise Pragma_Exit.
2421 procedure Check_Arg_Is_Static_Expression
2423 Typ : Entity_Id := Empty);
2424 -- Check the specified argument Arg to make sure that it is a static
2425 -- expression of the given type (i.e. it will be analyzed and resolved
2426 -- using this type, which can be any valid argument to Resolve, e.g.
2427 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
2428 -- Typ is left Empty, then any static expression is allowed.
2430 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
2431 -- Check the specified argument Arg to make sure that it is a valid task
2432 -- dispatching policy name. If not give error and raise Pragma_Exit.
2434 procedure Check_Arg_Order (Names : Name_List);
2435 -- Checks for an instance of two arguments with identifiers for the
2436 -- current pragma which are not in the sequence indicated by Names,
2437 -- and if so, generates a fatal message about bad order of arguments.
2439 procedure Check_At_Least_N_Arguments (N : Nat);
2440 -- Check there are at least N arguments present
2442 procedure Check_At_Most_N_Arguments (N : Nat);
2443 -- Check there are no more than N arguments present
2445 procedure Check_Component
2448 In_Variant_Part : Boolean := False);
2449 -- Examine an Unchecked_Union component for correct use of per-object
2450 -- constrained subtypes, and for restrictions on finalizable components.
2451 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
2452 -- should be set when Comp comes from a record variant.
2454 procedure Check_Declaration_Order (States : Node_Id; Inits : Node_Id);
2455 -- Subsidiary routine to the analysis of pragmas Abstract_State and
2456 -- Initializes. Determine whether pragma Abstract_State denoted by
2457 -- States is defined earlier than pragma Initializes denoted by Inits.
2459 procedure Check_Duplicate_Pragma (E : Entity_Id);
2460 -- Check if a rep item of the same name as the current pragma is already
2461 -- chained as a rep pragma to the given entity. If so give a message
2462 -- about the duplicate, and then raise Pragma_Exit so does not return.
2464 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
2465 -- Nam is an N_String_Literal node containing the external name set by
2466 -- an Import or Export pragma (or extended Import or Export pragma).
2467 -- This procedure checks for possible duplications if this is the export
2468 -- case, and if found, issues an appropriate error message.
2470 procedure Check_Expr_Is_Static_Expression
2472 Typ : Entity_Id := Empty);
2473 -- Check the specified expression Expr to make sure that it is a static
2474 -- expression of the given type (i.e. it will be analyzed and resolved
2475 -- using this type, which can be any valid argument to Resolve, e.g.
2476 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
2477 -- Typ is left Empty, then any static expression is allowed.
2479 procedure Check_First_Subtype (Arg : Node_Id);
2480 -- Checks that Arg, whose expression is an entity name, references a
2483 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
2484 -- Checks that the given argument has an identifier, and if so, requires
2485 -- it to match the given identifier name. If there is no identifier, or
2486 -- a non-matching identifier, then an error message is given and
2487 -- Pragma_Exit is raised.
2489 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
2490 -- Checks that the given argument has an identifier, and if so, requires
2491 -- it to match one of the given identifier names. If there is no
2492 -- identifier, or a non-matching identifier, then an error message is
2493 -- given and Pragma_Exit is raised.
2495 procedure Check_In_Main_Program;
2496 -- Common checks for pragmas that appear within a main program
2497 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
2499 procedure Check_Interrupt_Or_Attach_Handler;
2500 -- Common processing for first argument of pragma Interrupt_Handler or
2501 -- pragma Attach_Handler.
2503 procedure Check_Loop_Pragma_Placement;
2504 -- Verify whether pragma Loop_Invariant or Loop_Optimize or Loop_Variant
2505 -- appear immediately within a construct restricted to loops.
2507 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
2508 -- Check that pragma appears in a declarative part, or in a package
2509 -- specification, i.e. that it does not occur in a statement sequence
2512 procedure Check_No_Identifier (Arg : Node_Id);
2513 -- Checks that the given argument does not have an identifier. If
2514 -- an identifier is present, then an error message is issued, and
2515 -- Pragma_Exit is raised.
2517 procedure Check_No_Identifiers;
2518 -- Checks that none of the arguments to the pragma has an identifier.
2519 -- If any argument has an identifier, then an error message is issued,
2520 -- and Pragma_Exit is raised.
2522 procedure Check_No_Link_Name;
2523 -- Checks that no link name is specified
2525 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
2526 -- Checks if the given argument has an identifier, and if so, requires
2527 -- it to match the given identifier name. If there is a non-matching
2528 -- identifier, then an error message is given and Pragma_Exit is raised.
2530 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
2531 -- Checks if the given argument has an identifier, and if so, requires
2532 -- it to match the given identifier name. If there is a non-matching
2533 -- identifier, then an error message is given and Pragma_Exit is raised.
2534 -- In this version of the procedure, the identifier name is given as
2535 -- a string with lower case letters.
2537 procedure Check_Pre_Post;
2538 -- Called to perform checks for Pre, Pre_Class, Post, Post_Class
2539 -- pragmas. These are processed by transformation to equivalent
2540 -- Precondition and Postcondition pragmas, but Pre and Post need an
2541 -- additional check that they are not used in a subprogram body when
2542 -- there is a separate spec present.
2544 procedure Check_Precondition_Postcondition (In_Body : out Boolean);
2545 -- Called to process a precondition or postcondition pragma. There are
2548 -- The pragma appears after a subprogram spec
2550 -- If the corresponding check is not enabled, the pragma is analyzed
2551 -- but otherwise ignored and control returns with In_Body set False.
2553 -- If the check is enabled, then the first step is to analyze the
2554 -- pragma, but this is skipped if the subprogram spec appears within
2555 -- a package specification (because this is the case where we delay
2556 -- analysis till the end of the spec). Then (whether or not it was
2557 -- analyzed), the pragma is chained to the subprogram in question
2558 -- (using Pre_Post_Conditions and Next_Pragma) and control returns
2559 -- to the caller with In_Body set False.
2561 -- The pragma appears at the start of subprogram body declarations
2563 -- In this case an immediate return to the caller is made with
2564 -- In_Body set True, and the pragma is NOT analyzed.
2566 -- In all other cases, an error message for bad placement is given
2568 procedure Check_Static_Constraint (Constr : Node_Id);
2569 -- Constr is a constraint from an N_Subtype_Indication node from a
2570 -- component constraint in an Unchecked_Union type. This routine checks
2571 -- that the constraint is static as required by the restrictions for
2574 procedure Check_Test_Case;
2575 -- Called to process a test-case pragma. It starts with checking pragma
2576 -- arguments, and the rest of the treatment is similar to the one for
2577 -- pre- and postcondition in Check_Precondition_Postcondition, except
2578 -- the placement rules for the test-case pragma are stricter. These
2579 -- pragmas may only occur after a subprogram spec declared directly
2580 -- in a package spec unit. In this case, the pragma is chained to the
2581 -- subprogram in question (using Contract_Test_Cases and Next_Pragma)
2582 -- and analysis of the pragma is delayed till the end of the spec. In
2583 -- all other cases, an error message for bad placement is given.
2585 procedure Check_Valid_Configuration_Pragma;
2586 -- Legality checks for placement of a configuration pragma
2588 procedure Check_Valid_Library_Unit_Pragma;
2589 -- Legality checks for library unit pragmas. A special case arises for
2590 -- pragmas in generic instances that come from copies of the original
2591 -- library unit pragmas in the generic templates. In the case of other
2592 -- than library level instantiations these can appear in contexts which
2593 -- would normally be invalid (they only apply to the original template
2594 -- and to library level instantiations), and they are simply ignored,
2595 -- which is implemented by rewriting them as null statements.
2597 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
2598 -- Check an Unchecked_Union variant for lack of nested variants and
2599 -- presence of at least one component. UU_Typ is the related Unchecked_
2602 procedure Error_Pragma (Msg : String);
2603 pragma No_Return (Error_Pragma);
2604 -- Outputs error message for current pragma. The message contains a %
2605 -- that will be replaced with the pragma name, and the flag is placed
2606 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
2607 -- calls Fix_Error (see spec of that procedure for details).
2609 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
2610 pragma No_Return (Error_Pragma_Arg);
2611 -- Outputs error message for current pragma. The message may contain
2612 -- a % that will be replaced with the pragma name. The parameter Arg
2613 -- may either be a pragma argument association, in which case the flag
2614 -- is placed on the expression of this association, or an expression,
2615 -- in which case the flag is placed directly on the expression. The
2616 -- message is placed using Error_Msg_N, so the message may also contain
2617 -- an & insertion character which will reference the given Arg value.
2618 -- After placing the message, Pragma_Exit is raised. Note: this routine
2619 -- calls Fix_Error (see spec of that procedure for details).
2621 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
2622 pragma No_Return (Error_Pragma_Arg);
2623 -- Similar to above form of Error_Pragma_Arg except that two messages
2624 -- are provided, the second is a continuation comment starting with \.
2626 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
2627 pragma No_Return (Error_Pragma_Arg_Ident);
2628 -- Outputs error message for current pragma. The message may contain
2629 -- a % that will be replaced with the pragma name. The parameter Arg
2630 -- must be a pragma argument association with a non-empty identifier
2631 -- (i.e. its Chars field must be set), and the error message is placed
2632 -- on the identifier. The message is placed using Error_Msg_N so
2633 -- the message may also contain an & insertion character which will
2634 -- reference the identifier. After placing the message, Pragma_Exit
2635 -- is raised. Note: this routine calls Fix_Error (see spec of that
2636 -- procedure for details).
2638 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
2639 pragma No_Return (Error_Pragma_Ref);
2640 -- Outputs error message for current pragma. The message may contain
2641 -- a % that will be replaced with the pragma name. The parameter Ref
2642 -- must be an entity whose name can be referenced by & and sloc by #.
2643 -- After placing the message, Pragma_Exit is raised. Note: this routine
2644 -- calls Fix_Error (see spec of that procedure for details).
2646 function Find_Lib_Unit_Name return Entity_Id;
2647 -- Used for a library unit pragma to find the entity to which the
2648 -- library unit pragma applies, returns the entity found.
2650 procedure Find_Program_Unit_Name (Id : Node_Id);
2651 -- If the pragma is a compilation unit pragma, the id must denote the
2652 -- compilation unit in the same compilation, and the pragma must appear
2653 -- in the list of preceding or trailing pragmas. If it is a program
2654 -- unit pragma that is not a compilation unit pragma, then the
2655 -- identifier must be visible.
2657 function Find_Unique_Parameterless_Procedure
2659 Arg : Node_Id) return Entity_Id;
2660 -- Used for a procedure pragma to find the unique parameterless
2661 -- procedure identified by Name, returns it if it exists, otherwise
2662 -- errors out and uses Arg as the pragma argument for the message.
2664 procedure Fix_Error (Msg : in out String);
2665 -- This is called prior to issuing an error message. Msg is a string
2666 -- that typically contains the substring "pragma". If the pragma comes
2667 -- from an aspect, each such "pragma" substring is replaced with the
2668 -- characters "aspect", and Error_Msg_Name_1 is set to the name of the
2669 -- aspect (which may be different from the pragma name). If the current
2670 -- pragma results from rewriting another pragma, then Error_Msg_Name_1
2671 -- is set to the original pragma name.
2673 procedure Gather_Associations
2675 Args : out Args_List);
2676 -- This procedure is used to gather the arguments for a pragma that
2677 -- permits arbitrary ordering of parameters using the normal rules
2678 -- for named and positional parameters. The Names argument is a list
2679 -- of Name_Id values that corresponds to the allowed pragma argument
2680 -- association identifiers in order. The result returned in Args is
2681 -- a list of corresponding expressions that are the pragma arguments.
2682 -- Note that this is a list of expressions, not of pragma argument
2683 -- associations (Gather_Associations has completely checked all the
2684 -- optional identifiers when it returns). An entry in Args is Empty
2685 -- on return if the corresponding argument is not present.
2687 procedure GNAT_Pragma;
2688 -- Called for all GNAT defined pragmas to check the relevant restriction
2689 -- (No_Implementation_Pragmas).
2691 procedure S14_Pragma;
2692 -- Called for all pragmas defined for formal verification to check that
2693 -- the S14_Extensions flag is set.
2694 -- This name needs fixing ??? There is no such thing as an
2695 -- "S14_Extensions" flag ???
2697 function Is_Before_First_Decl
2698 (Pragma_Node : Node_Id;
2699 Decls : List_Id) return Boolean;
2700 -- Return True if Pragma_Node is before the first declarative item in
2701 -- Decls where Decls is the list of declarative items.
2703 function Is_Configuration_Pragma return Boolean;
2704 -- Determines if the placement of the current pragma is appropriate
2705 -- for a configuration pragma.
2707 function Is_In_Context_Clause return Boolean;
2708 -- Returns True if pragma appears within the context clause of a unit,
2709 -- and False for any other placement (does not generate any messages).
2711 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
2712 -- Analyzes the argument, and determines if it is a static string
2713 -- expression, returns True if so, False if non-static or not String.
2715 procedure Pragma_Misplaced;
2716 pragma No_Return (Pragma_Misplaced);
2717 -- Issue fatal error message for misplaced pragma
2719 procedure Process_Atomic_Shared_Volatile;
2720 -- Common processing for pragmas Atomic, Shared, Volatile. Note that
2721 -- Shared is an obsolete Ada 83 pragma, treated as being identical
2722 -- in effect to pragma Atomic.
2724 procedure Process_Compile_Time_Warning_Or_Error;
2725 -- Common processing for Compile_Time_Error and Compile_Time_Warning
2727 procedure Process_Convention
2728 (C : out Convention_Id;
2729 Ent : out Entity_Id);
2730 -- Common processing for Convention, Interface, Import and Export.
2731 -- Checks first two arguments of pragma, and sets the appropriate
2732 -- convention value in the specified entity or entities. On return
2733 -- C is the convention, Ent is the referenced entity.
2735 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
2736 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
2737 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
2739 procedure Process_Extended_Import_Export_Exception_Pragma
2740 (Arg_Internal : Node_Id;
2741 Arg_External : Node_Id;
2743 Arg_Code : Node_Id);
2744 -- Common processing for the pragmas Import/Export_Exception. The three
2745 -- arguments correspond to the three named parameters of the pragma. An
2746 -- argument is empty if the corresponding parameter is not present in
2749 procedure Process_Extended_Import_Export_Object_Pragma
2750 (Arg_Internal : Node_Id;
2751 Arg_External : Node_Id;
2752 Arg_Size : Node_Id);
2753 -- Common processing for the pragmas Import/Export_Object. The three
2754 -- arguments correspond to the three named parameters of the pragmas. An
2755 -- argument is empty if the corresponding parameter is not present in
2758 procedure Process_Extended_Import_Export_Internal_Arg
2759 (Arg_Internal : Node_Id := Empty);
2760 -- Common processing for all extended Import and Export pragmas. The
2761 -- argument is the pragma parameter for the Internal argument. If
2762 -- Arg_Internal is empty or inappropriate, an error message is posted.
2763 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
2764 -- set to identify the referenced entity.
2766 procedure Process_Extended_Import_Export_Subprogram_Pragma
2767 (Arg_Internal : Node_Id;
2768 Arg_External : Node_Id;
2769 Arg_Parameter_Types : Node_Id;
2770 Arg_Result_Type : Node_Id := Empty;
2771 Arg_Mechanism : Node_Id;
2772 Arg_Result_Mechanism : Node_Id := Empty;
2773 Arg_First_Optional_Parameter : Node_Id := Empty);
2774 -- Common processing for all extended Import and Export pragmas applying
2775 -- to subprograms. The caller omits any arguments that do not apply to
2776 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
2777 -- only in the Import_Function and Export_Function cases). The argument
2778 -- names correspond to the allowed pragma association identifiers.
2780 procedure Process_Generic_List;
2781 -- Common processing for Share_Generic and Inline_Generic
2783 procedure Process_Import_Or_Interface;
2784 -- Common processing for Import of Interface
2786 procedure Process_Import_Predefined_Type;
2787 -- Processing for completing a type with pragma Import. This is used
2788 -- to declare types that match predefined C types, especially for cases
2789 -- without corresponding Ada predefined type.
2791 type Inline_Status is (Suppressed, Disabled, Enabled);
2792 -- Inline status of a subprogram, indicated as follows:
2793 -- Suppressed: inlining is suppressed for the subprogram
2794 -- Disabled: no inlining is requested for the subprogram
2795 -- Enabled: inlining is requested/required for the subprogram
2797 procedure Process_Inline (Status : Inline_Status);
2798 -- Common processing for Inline, Inline_Always and No_Inline. Parameter
2799 -- indicates the inline status specified by the pragma.
2801 procedure Process_Interface_Name
2802 (Subprogram_Def : Entity_Id;
2804 Link_Arg : Node_Id);
2805 -- Given the last two arguments of pragma Import, pragma Export, or
2806 -- pragma Interface_Name, performs validity checks and sets the
2807 -- Interface_Name field of the given subprogram entity to the
2808 -- appropriate external or link name, depending on the arguments given.
2809 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
2810 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
2811 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
2812 -- nor Link_Arg is present, the interface name is set to the default
2813 -- from the subprogram name.
2815 procedure Process_Interrupt_Or_Attach_Handler;
2816 -- Common processing for Interrupt and Attach_Handler pragmas
2818 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
2819 -- Common processing for Restrictions and Restriction_Warnings pragmas.
2820 -- Warn is True for Restriction_Warnings, or for Restrictions if the
2821 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
2822 -- is not set in the Restrictions case.
2824 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
2825 -- Common processing for Suppress and Unsuppress. The boolean parameter
2826 -- Suppress_Case is True for the Suppress case, and False for the
2829 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
2830 -- This procedure sets the Is_Exported flag for the given entity,
2831 -- checking that the entity was not previously imported. Arg is
2832 -- the argument that specified the entity. A check is also made
2833 -- for exporting inappropriate entities.
2835 procedure Set_Extended_Import_Export_External_Name
2836 (Internal_Ent : Entity_Id;
2837 Arg_External : Node_Id);
2838 -- Common processing for all extended import export pragmas. The first
2839 -- argument, Internal_Ent, is the internal entity, which has already
2840 -- been checked for validity by the caller. Arg_External is from the
2841 -- Import or Export pragma, and may be null if no External parameter
2842 -- was present. If Arg_External is present and is a non-null string
2843 -- (a null string is treated as the default), then the Interface_Name
2844 -- field of Internal_Ent is set appropriately.
2846 procedure Set_Imported (E : Entity_Id);
2847 -- This procedure sets the Is_Imported flag for the given entity,
2848 -- checking that it is not previously exported or imported.
2850 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
2851 -- Mech is a parameter passing mechanism (see Import_Function syntax
2852 -- for MECHANISM_NAME). This routine checks that the mechanism argument
2853 -- has the right form, and if not issues an error message. If the
2854 -- argument has the right form then the Mechanism field of Ent is
2855 -- set appropriately.
2857 procedure Set_Rational_Profile;
2858 -- Activate the set of configuration pragmas and permissions that make
2859 -- up the Rational profile.
2861 procedure Set_Ravenscar_Profile (N : Node_Id);
2862 -- Activate the set of configuration pragmas and restrictions that make
2863 -- up the Ravenscar Profile. N is the corresponding pragma node, which
2864 -- is used for error messages on any constructs that violate the
2867 ---------------------
2868 -- Ada_2005_Pragma --
2869 ---------------------
2871 procedure Ada_2005_Pragma is
2873 if Ada_Version <= Ada_95 then
2874 Check_Restriction (No_Implementation_Pragmas, N);
2876 end Ada_2005_Pragma;
2878 ---------------------
2879 -- Ada_2012_Pragma --
2880 ---------------------
2882 procedure Ada_2012_Pragma is
2884 if Ada_Version <= Ada_2005 then
2885 Check_Restriction (No_Implementation_Pragmas, N);
2887 end Ada_2012_Pragma;
2889 ----------------------------
2890 -- Analyze_Refined_Pragma --
2891 ----------------------------
2893 procedure Analyze_Refined_Pragma
2894 (Spec_Id : out Entity_Id;
2895 Body_Id : out Entity_Id;
2896 Legal : out Boolean)
2898 Body_Decl : Node_Id;
2899 Pack_Spec : Node_Id;
2900 Spec_Decl : Node_Id;
2903 -- Assume that the pragma is illegal
2910 Check_Arg_Count (1);
2911 Check_No_Identifiers;
2913 -- Verify the placement of the pragma and check for duplicates. The
2914 -- pragma must apply to a subprogram body [stub].
2916 Body_Decl := Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
2918 if not Nkind_In (Body_Decl, N_Subprogram_Body,
2919 N_Subprogram_Body_Stub)
2925 Body_Id := Defining_Entity (Body_Decl);
2927 -- The body [stub] must not act as a spec, in other words it has to
2928 -- be paired with a corresponding spec.
2930 if Nkind (Body_Decl) = N_Subprogram_Body then
2931 Spec_Id := Corresponding_Spec (Body_Decl);
2933 Spec_Id := Corresponding_Spec_Of_Stub (Body_Decl);
2936 if No (Spec_Id) then
2937 Error_Pragma ("pragma % cannot apply to a stand alone body");
2941 -- The pragma may only apply to the body [stub] of a subprogram
2942 -- declared in the visible part of a package. Retrieve the context of
2943 -- the subprogram declaration.
2945 Spec_Decl := Parent (Parent (Spec_Id));
2948 (Nkind_In (Spec_Decl, N_Abstract_Subprogram_Declaration,
2949 N_Generic_Subprogram_Declaration,
2950 N_Subprogram_Declaration));
2952 Pack_Spec := Parent (Spec_Decl);
2954 if Nkind (Pack_Spec) /= N_Package_Specification
2955 or else List_Containing (Spec_Decl) /=
2956 Visible_Declarations (Pack_Spec)
2959 ("pragma % must apply to the body of a visible subprogram");
2963 -- If we get here, then the pragma is legal
2966 end Analyze_Refined_Pragma;
2968 --------------------------
2969 -- Check_Ada_83_Warning --
2970 --------------------------
2972 procedure Check_Ada_83_Warning is
2974 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
2975 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
2977 end Check_Ada_83_Warning;
2979 ---------------------
2980 -- Check_Arg_Count --
2981 ---------------------
2983 procedure Check_Arg_Count (Required : Nat) is
2985 if Arg_Count /= Required then
2986 Error_Pragma ("wrong number of arguments for pragma%");
2988 end Check_Arg_Count;
2990 --------------------------------
2991 -- Check_Arg_Is_External_Name --
2992 --------------------------------
2994 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
2995 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
2998 if Nkind (Argx) = N_Identifier then
3002 Analyze_And_Resolve (Argx, Standard_String);
3004 if Is_OK_Static_Expression (Argx) then
3007 elsif Etype (Argx) = Any_Type then
3010 -- An interesting special case, if we have a string literal and
3011 -- we are in Ada 83 mode, then we allow it even though it will
3012 -- not be flagged as static. This allows expected Ada 83 mode
3013 -- use of external names which are string literals, even though
3014 -- technically these are not static in Ada 83.
3016 elsif Ada_Version = Ada_83
3017 and then Nkind (Argx) = N_String_Literal
3021 -- Static expression that raises Constraint_Error. This has
3022 -- already been flagged, so just exit from pragma processing.
3024 elsif Is_Static_Expression (Argx) then
3027 -- Here we have a real error (non-static expression)
3030 Error_Msg_Name_1 := Pname;
3034 "argument for pragma% must be a identifier or "
3035 & "static string expression!";
3038 Flag_Non_Static_Expr (Msg, Argx);
3043 end Check_Arg_Is_External_Name;
3045 -----------------------------
3046 -- Check_Arg_Is_Identifier --
3047 -----------------------------
3049 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
3050 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3052 if Nkind (Argx) /= N_Identifier then
3054 ("argument for pragma% must be identifier", Argx);
3056 end Check_Arg_Is_Identifier;
3058 ----------------------------------
3059 -- Check_Arg_Is_Integer_Literal --
3060 ----------------------------------
3062 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
3063 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3065 if Nkind (Argx) /= N_Integer_Literal then
3067 ("argument for pragma% must be integer literal", Argx);
3069 end Check_Arg_Is_Integer_Literal;
3071 -------------------------------------------
3072 -- Check_Arg_Is_Library_Level_Local_Name --
3073 -------------------------------------------
3077 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3078 -- | library_unit_NAME
3080 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
3082 Check_Arg_Is_Local_Name (Arg);
3084 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
3085 and then Comes_From_Source (N)
3088 ("argument for pragma% must be library level entity", Arg);
3090 end Check_Arg_Is_Library_Level_Local_Name;
3092 -----------------------------
3093 -- Check_Arg_Is_Local_Name --
3094 -----------------------------
3098 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3099 -- | library_unit_NAME
3101 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
3102 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3107 if Nkind (Argx) not in N_Direct_Name
3108 and then (Nkind (Argx) /= N_Attribute_Reference
3109 or else Present (Expressions (Argx))
3110 or else Nkind (Prefix (Argx)) /= N_Identifier)
3111 and then (not Is_Entity_Name (Argx)
3112 or else not Is_Compilation_Unit (Entity (Argx)))
3114 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
3117 -- No further check required if not an entity name
3119 if not Is_Entity_Name (Argx) then
3125 Ent : constant Entity_Id := Entity (Argx);
3126 Scop : constant Entity_Id := Scope (Ent);
3129 -- Case of a pragma applied to a compilation unit: pragma must
3130 -- occur immediately after the program unit in the compilation.
3132 if Is_Compilation_Unit (Ent) then
3134 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
3137 -- Case of pragma placed immediately after spec
3139 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
3142 -- Case of pragma placed immediately after body
3144 elsif Nkind (Decl) = N_Subprogram_Declaration
3145 and then Present (Corresponding_Body (Decl))
3149 (Parent (Unit_Declaration_Node
3150 (Corresponding_Body (Decl))));
3152 -- All other cases are illegal
3159 -- Special restricted placement rule from 10.2.1(11.8/2)
3161 elsif Is_Generic_Formal (Ent)
3162 and then Prag_Id = Pragma_Preelaborable_Initialization
3164 OK := List_Containing (N) =
3165 Generic_Formal_Declarations
3166 (Unit_Declaration_Node (Scop));
3168 -- Default case, just check that the pragma occurs in the scope
3169 -- of the entity denoted by the name.
3172 OK := Current_Scope = Scop;
3177 ("pragma% argument must be in same declarative part", Arg);
3181 end Check_Arg_Is_Local_Name;
3183 ---------------------------------
3184 -- Check_Arg_Is_Locking_Policy --
3185 ---------------------------------
3187 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
3188 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3191 Check_Arg_Is_Identifier (Argx);
3193 if not Is_Locking_Policy_Name (Chars (Argx)) then
3194 Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
3196 end Check_Arg_Is_Locking_Policy;
3198 -----------------------------------------------
3199 -- Check_Arg_Is_Partition_Elaboration_Policy --
3200 -----------------------------------------------
3202 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
3203 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3206 Check_Arg_Is_Identifier (Argx);
3208 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
3210 ("& is not a valid partition elaboration policy name", Argx);
3212 end Check_Arg_Is_Partition_Elaboration_Policy;
3214 -------------------------
3215 -- Check_Arg_Is_One_Of --
3216 -------------------------
3218 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
3219 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3222 Check_Arg_Is_Identifier (Argx);
3224 if not Nam_In (Chars (Argx), N1, N2) then
3225 Error_Msg_Name_2 := N1;
3226 Error_Msg_Name_3 := N2;
3227 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
3229 end Check_Arg_Is_One_Of;
3231 procedure Check_Arg_Is_One_Of
3233 N1, N2, N3 : Name_Id)
3235 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3238 Check_Arg_Is_Identifier (Argx);
3240 if not Nam_In (Chars (Argx), N1, N2, N3) then
3241 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
3243 end Check_Arg_Is_One_Of;
3245 procedure Check_Arg_Is_One_Of
3247 N1, N2, N3, N4 : Name_Id)
3249 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3252 Check_Arg_Is_Identifier (Argx);
3254 if not Nam_In (Chars (Argx), N1, N2, N3, N4) then
3255 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
3257 end Check_Arg_Is_One_Of;
3259 procedure Check_Arg_Is_One_Of
3261 N1, N2, N3, N4, N5 : Name_Id)
3263 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3266 Check_Arg_Is_Identifier (Argx);
3268 if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then
3269 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
3271 end Check_Arg_Is_One_Of;
3273 ---------------------------------
3274 -- Check_Arg_Is_Queuing_Policy --
3275 ---------------------------------
3277 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
3278 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3281 Check_Arg_Is_Identifier (Argx);
3283 if not Is_Queuing_Policy_Name (Chars (Argx)) then
3284 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
3286 end Check_Arg_Is_Queuing_Policy;
3288 ------------------------------------
3289 -- Check_Arg_Is_Static_Expression --
3290 ------------------------------------
3292 procedure Check_Arg_Is_Static_Expression
3294 Typ : Entity_Id := Empty)
3297 Check_Expr_Is_Static_Expression (Get_Pragma_Arg (Arg), Typ);
3298 end Check_Arg_Is_Static_Expression;
3300 ------------------------------------------
3301 -- Check_Arg_Is_Task_Dispatching_Policy --
3302 ------------------------------------------
3304 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
3305 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3308 Check_Arg_Is_Identifier (Argx);
3310 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
3312 ("& is not a valid task dispatching policy name", Argx);
3314 end Check_Arg_Is_Task_Dispatching_Policy;
3316 ---------------------
3317 -- Check_Arg_Order --
3318 ---------------------
3320 procedure Check_Arg_Order (Names : Name_List) is
3323 Highest_So_Far : Natural := 0;
3324 -- Highest index in Names seen do far
3328 for J in 1 .. Arg_Count loop
3329 if Chars (Arg) /= No_Name then
3330 for K in Names'Range loop
3331 if Chars (Arg) = Names (K) then
3332 if K < Highest_So_Far then
3333 Error_Msg_Name_1 := Pname;
3335 ("parameters out of order for pragma%", Arg);
3336 Error_Msg_Name_1 := Names (K);
3337 Error_Msg_Name_2 := Names (Highest_So_Far);
3338 Error_Msg_N ("\% must appear before %", Arg);
3342 Highest_So_Far := K;
3350 end Check_Arg_Order;
3352 --------------------------------
3353 -- Check_At_Least_N_Arguments --
3354 --------------------------------
3356 procedure Check_At_Least_N_Arguments (N : Nat) is
3358 if Arg_Count < N then
3359 Error_Pragma ("too few arguments for pragma%");
3361 end Check_At_Least_N_Arguments;
3363 -------------------------------
3364 -- Check_At_Most_N_Arguments --
3365 -------------------------------
3367 procedure Check_At_Most_N_Arguments (N : Nat) is
3370 if Arg_Count > N then
3372 for J in 1 .. N loop
3374 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
3377 end Check_At_Most_N_Arguments;
3379 ---------------------
3380 -- Check_Component --
3381 ---------------------
3383 procedure Check_Component
3386 In_Variant_Part : Boolean := False)
3388 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
3389 Sindic : constant Node_Id :=
3390 Subtype_Indication (Component_Definition (Comp));
3391 Typ : constant Entity_Id := Etype (Comp_Id);
3394 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
3395 -- object constraint, then the component type shall be an Unchecked_
3398 if Nkind (Sindic) = N_Subtype_Indication
3399 and then Has_Per_Object_Constraint (Comp_Id)
3400 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
3403 ("component subtype subject to per-object constraint "
3404 & "must be an Unchecked_Union", Comp);
3406 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
3407 -- the body of a generic unit, or within the body of any of its
3408 -- descendant library units, no part of the type of a component
3409 -- declared in a variant_part of the unchecked union type shall be of
3410 -- a formal private type or formal private extension declared within
3411 -- the formal part of the generic unit.
3413 elsif Ada_Version >= Ada_2012
3414 and then In_Generic_Body (UU_Typ)
3415 and then In_Variant_Part
3416 and then Is_Private_Type (Typ)
3417 and then Is_Generic_Type (Typ)
3420 ("component of unchecked union cannot be of generic type", Comp);
3422 elsif Needs_Finalization (Typ) then
3424 ("component of unchecked union cannot be controlled", Comp);
3426 elsif Has_Task (Typ) then
3428 ("component of unchecked union cannot have tasks", Comp);
3430 end Check_Component;
3432 -----------------------------
3433 -- Check_Declaration_Order --
3434 -----------------------------
3436 procedure Check_Declaration_Order (States : Node_Id; Inits : Node_Id) is
3437 procedure Check_Aspect_Specification_Order;
3438 -- Inspect the aspect specifications of the context to determine the
3441 --------------------------------------
3442 -- Check_Aspect_Specification_Order --
3443 --------------------------------------
3445 procedure Check_Aspect_Specification_Order is
3446 Asp_I : constant Node_Id := Corresponding_Aspect (Inits);
3447 Asp_S : constant Node_Id := Corresponding_Aspect (States);
3450 States_Seen : Boolean := False;
3453 -- Both aspects must be part of the same aspect specification list
3455 pragma Assert (List_Containing (Asp_I) = List_Containing (Asp_S));
3457 Asp := First (List_Containing (Asp_I));
3458 while Present (Asp) loop
3459 if Get_Aspect_Id (Asp) = Aspect_Abstract_State then
3460 States_Seen := True;
3462 elsif Get_Aspect_Id (Asp) = Aspect_Initializes then
3463 if not States_Seen then
3465 ("aspect % must come before aspect %", States);
3473 end Check_Aspect_Specification_Order;
3479 -- Start of processing for Check_Declaration_Order
3482 -- Cannot check the order if one of the pragmas is missing
3484 if No (States) or else No (Inits) then
3488 -- Set up the error names in case the order is incorrect
3490 Error_Msg_Name_1 := Name_Abstract_State;
3491 Error_Msg_Name_2 := Name_Initializes;
3493 if From_Aspect_Specification (States) then
3495 -- Both pragmas are actually aspects, check their declaration
3496 -- order in the associated aspect specification list. Otherwise
3497 -- States is an aspect and Inits a source pragma.
3499 if From_Aspect_Specification (Inits) then
3500 Check_Aspect_Specification_Order;
3503 -- Abstract_States is a source pragma
3506 if From_Aspect_Specification (Inits) then
3507 Error_Msg_N ("pragma % cannot come after aspect %", States);
3509 -- Both pragmas are source constructs. Try to reach States from
3510 -- Inits by traversing the declarations backwards.
3513 Stmt := Prev (Inits);
3514 while Present (Stmt) loop
3516 -- The order is ok, Abstract_States is first followed by
3519 if Nkind (Stmt) = N_Pragma
3520 and then Pragma_Name (Stmt) = Name_Abstract_State
3528 -- If we get here, then the pragmas are out of order
3530 Error_Msg_N ("pragma % cannot come after pragma %", States);
3533 end Check_Declaration_Order;
3535 ----------------------------
3536 -- Check_Duplicate_Pragma --
3537 ----------------------------
3539 procedure Check_Duplicate_Pragma (E : Entity_Id) is
3540 Id : Entity_Id := E;
3544 -- Nothing to do if this pragma comes from an aspect specification,
3545 -- since we could not be duplicating a pragma, and we dealt with the
3546 -- case of duplicated aspects in Analyze_Aspect_Specifications.
3548 if From_Aspect_Specification (N) then
3552 -- Otherwise current pragma may duplicate previous pragma or a
3553 -- previously given aspect specification or attribute definition
3554 -- clause for the same pragma.
3556 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
3559 Error_Msg_Name_1 := Pragma_Name (N);
3560 Error_Msg_Sloc := Sloc (P);
3562 -- For a single protected or a single task object, the error is
3563 -- issued on the original entity.
3565 if Ekind_In (Id, E_Task_Type, E_Protected_Type) then
3566 Id := Defining_Identifier (Original_Node (Parent (Id)));
3569 if Nkind (P) = N_Aspect_Specification
3570 or else From_Aspect_Specification (P)
3572 Error_Msg_NE ("aspect% for & previously given#", N, Id);
3574 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
3579 end Check_Duplicate_Pragma;
3581 ----------------------------------
3582 -- Check_Duplicated_Export_Name --
3583 ----------------------------------
3585 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
3586 String_Val : constant String_Id := Strval (Nam);
3589 -- We are only interested in the export case, and in the case of
3590 -- generics, it is the instance, not the template, that is the
3591 -- problem (the template will generate a warning in any case).
3593 if not Inside_A_Generic
3594 and then (Prag_Id = Pragma_Export
3596 Prag_Id = Pragma_Export_Procedure
3598 Prag_Id = Pragma_Export_Valued_Procedure
3600 Prag_Id = Pragma_Export_Function)
3602 for J in Externals.First .. Externals.Last loop
3603 if String_Equal (String_Val, Strval (Externals.Table (J))) then
3604 Error_Msg_Sloc := Sloc (Externals.Table (J));
3605 Error_Msg_N ("external name duplicates name given#", Nam);
3610 Externals.Append (Nam);
3612 end Check_Duplicated_Export_Name;
3614 -------------------------------------
3615 -- Check_Expr_Is_Static_Expression --
3616 -------------------------------------
3618 procedure Check_Expr_Is_Static_Expression
3620 Typ : Entity_Id := Empty)
3623 if Present (Typ) then
3624 Analyze_And_Resolve (Expr, Typ);
3626 Analyze_And_Resolve (Expr);
3629 if Is_OK_Static_Expression (Expr) then
3632 elsif Etype (Expr) = Any_Type then
3635 -- An interesting special case, if we have a string literal and we
3636 -- are in Ada 83 mode, then we allow it even though it will not be
3637 -- flagged as static. This allows the use of Ada 95 pragmas like
3638 -- Import in Ada 83 mode. They will of course be flagged with
3639 -- warnings as usual, but will not cause errors.
3641 elsif Ada_Version = Ada_83
3642 and then Nkind (Expr) = N_String_Literal
3646 -- Static expression that raises Constraint_Error. This has already
3647 -- been flagged, so just exit from pragma processing.
3649 elsif Is_Static_Expression (Expr) then
3652 -- Finally, we have a real error
3655 Error_Msg_Name_1 := Pname;
3659 "argument for pragma% must be a static expression!";
3662 Flag_Non_Static_Expr (Msg, Expr);
3667 end Check_Expr_Is_Static_Expression;
3669 -------------------------
3670 -- Check_First_Subtype --
3671 -------------------------
3673 procedure Check_First_Subtype (Arg : Node_Id) is
3674 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3675 Ent : constant Entity_Id := Entity (Argx);
3678 if Is_First_Subtype (Ent) then
3681 elsif Is_Type (Ent) then
3683 ("pragma% cannot apply to subtype", Argx);
3685 elsif Is_Object (Ent) then
3687 ("pragma% cannot apply to object, requires a type", Argx);
3691 ("pragma% cannot apply to&, requires a type", Argx);
3693 end Check_First_Subtype;
3695 ----------------------
3696 -- Check_Identifier --
3697 ----------------------
3699 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
3702 and then Nkind (Arg) = N_Pragma_Argument_Association
3704 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
3705 Error_Msg_Name_1 := Pname;
3706 Error_Msg_Name_2 := Id;
3707 Error_Msg_N ("pragma% argument expects identifier%", Arg);
3711 end Check_Identifier;
3713 --------------------------------
3714 -- Check_Identifier_Is_One_Of --
3715 --------------------------------
3717 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
3720 and then Nkind (Arg) = N_Pragma_Argument_Association
3722 if Chars (Arg) = No_Name then
3723 Error_Msg_Name_1 := Pname;
3724 Error_Msg_N ("pragma% argument expects an identifier", Arg);
3727 elsif Chars (Arg) /= N1
3728 and then Chars (Arg) /= N2
3730 Error_Msg_Name_1 := Pname;
3731 Error_Msg_N ("invalid identifier for pragma% argument", Arg);
3735 end Check_Identifier_Is_One_Of;
3737 ---------------------------
3738 -- Check_In_Main_Program --
3739 ---------------------------
3741 procedure Check_In_Main_Program is
3742 P : constant Node_Id := Parent (N);
3745 -- Must be at in subprogram body
3747 if Nkind (P) /= N_Subprogram_Body then
3748 Error_Pragma ("% pragma allowed only in subprogram");
3750 -- Otherwise warn if obviously not main program
3752 elsif Present (Parameter_Specifications (Specification (P)))
3753 or else not Is_Compilation_Unit (Defining_Entity (P))
3755 Error_Msg_Name_1 := Pname;
3757 ("??pragma% is only effective in main program", N);
3759 end Check_In_Main_Program;
3761 ---------------------------------------
3762 -- Check_Interrupt_Or_Attach_Handler --
3763 ---------------------------------------
3765 procedure Check_Interrupt_Or_Attach_Handler is
3766 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
3767 Handler_Proc, Proc_Scope : Entity_Id;
3772 if Prag_Id = Pragma_Interrupt_Handler then
3773 Check_Restriction (No_Dynamic_Attachment, N);
3776 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
3777 Proc_Scope := Scope (Handler_Proc);
3779 -- On AAMP only, a pragma Interrupt_Handler is supported for
3780 -- nonprotected parameterless procedures.
3782 if not AAMP_On_Target
3783 or else Prag_Id = Pragma_Attach_Handler
3785 if Ekind (Proc_Scope) /= E_Protected_Type then
3787 ("argument of pragma% must be protected procedure", Arg1);
3790 if Parent (N) /= Protected_Definition (Parent (Proc_Scope)) then
3791 Error_Pragma ("pragma% must be in protected definition");
3795 if not Is_Library_Level_Entity (Proc_Scope)
3796 or else (AAMP_On_Target
3797 and then not Is_Library_Level_Entity (Handler_Proc))
3800 ("argument for pragma% must be library level entity", Arg1);
3803 -- AI05-0033: A pragma cannot appear within a generic body, because
3804 -- instance can be in a nested scope. The check that protected type
3805 -- is itself a library-level declaration is done elsewhere.
3807 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
3808 -- handle code prior to AI-0033. Analysis tools typically are not
3809 -- interested in this pragma in any case, so no need to worry too
3810 -- much about its placement.
3812 if Inside_A_Generic then
3813 if Ekind (Scope (Current_Scope)) = E_Generic_Package
3814 and then In_Package_Body (Scope (Current_Scope))
3815 and then not Relaxed_RM_Semantics
3817 Error_Pragma ("pragma% cannot be used inside a generic");
3820 end Check_Interrupt_Or_Attach_Handler;
3822 ---------------------------------
3823 -- Check_Loop_Pragma_Placement --
3824 ---------------------------------
3826 procedure Check_Loop_Pragma_Placement is
3827 procedure Placement_Error (Constr : Node_Id);
3828 pragma No_Return (Placement_Error);
3829 -- Node Constr denotes the last loop restricted construct before we
3830 -- encountered an illegal relation between enclosing constructs. Emit
3831 -- an error depending on what Constr was.
3833 ---------------------
3834 -- Placement_Error --
3835 ---------------------
3837 procedure Placement_Error (Constr : Node_Id) is
3839 if Nkind (Constr) = N_Pragma then
3841 ("pragma % must appear immediately within the statements "
3845 ("block containing pragma % must appear immediately within "
3846 & "the statements of a loop", Constr);
3848 end Placement_Error;
3850 -- Local declarations
3855 -- Start of processing for Check_Loop_Pragma_Placement
3860 while Present (Stmt) loop
3862 -- The pragma or previous block must appear immediately within the
3863 -- current block's declarative or statement part.
3865 if Nkind (Stmt) = N_Block_Statement then
3866 if (No (Declarations (Stmt))
3867 or else List_Containing (Prev) /= Declarations (Stmt))
3869 List_Containing (Prev) /=
3870 Statements (Handled_Statement_Sequence (Stmt))
3872 Placement_Error (Prev);
3875 -- Keep inspecting the parents because we are now within a
3876 -- chain of nested blocks.
3880 Stmt := Parent (Stmt);
3883 -- The pragma or previous block must appear immediately within the
3884 -- statements of the loop.
3886 elsif Nkind (Stmt) = N_Loop_Statement then
3887 if List_Containing (Prev) /= Statements (Stmt) then
3888 Placement_Error (Prev);
3891 -- Stop the traversal because we reached the innermost loop
3892 -- regardless of whether we encountered an error or not.
3896 -- Ignore a handled statement sequence. Note that this node may
3897 -- be related to a subprogram body in which case we will emit an
3898 -- error on the next iteration of the search.
3900 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then
3901 Stmt := Parent (Stmt);
3903 -- Any other statement breaks the chain from the pragma to the
3907 Placement_Error (Prev);
3911 end Check_Loop_Pragma_Placement;
3913 -------------------------------------------
3914 -- Check_Is_In_Decl_Part_Or_Package_Spec --
3915 -------------------------------------------
3917 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
3926 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
3929 elsif Nkind_In (P, N_Package_Specification,
3934 -- Note: the following tests seem a little peculiar, because
3935 -- they test for bodies, but if we were in the statement part
3936 -- of the body, we would already have hit the handled statement
3937 -- sequence, so the only way we get here is by being in the
3938 -- declarative part of the body.
3940 elsif Nkind_In (P, N_Subprogram_Body,
3951 Error_Pragma ("pragma% is not in declarative part or package spec");
3952 end Check_Is_In_Decl_Part_Or_Package_Spec;
3954 -------------------------
3955 -- Check_No_Identifier --
3956 -------------------------
3958 procedure Check_No_Identifier (Arg : Node_Id) is
3960 if Nkind (Arg) = N_Pragma_Argument_Association
3961 and then Chars (Arg) /= No_Name
3963 Error_Pragma_Arg_Ident
3964 ("pragma% does not permit identifier& here", Arg);
3966 end Check_No_Identifier;
3968 --------------------------
3969 -- Check_No_Identifiers --
3970 --------------------------
3972 procedure Check_No_Identifiers is
3976 for J in 1 .. Arg_Count loop
3977 Check_No_Identifier (Arg_Node);
3980 end Check_No_Identifiers;
3982 ------------------------
3983 -- Check_No_Link_Name --
3984 ------------------------
3986 procedure Check_No_Link_Name is
3988 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then
3992 if Present (Arg4) then
3994 ("Link_Name argument not allowed for Import Intrinsic", Arg4);
3996 end Check_No_Link_Name;
3998 -------------------------------
3999 -- Check_Optional_Identifier --
4000 -------------------------------
4002 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
4005 and then Nkind (Arg) = N_Pragma_Argument_Association
4006 and then Chars (Arg) /= No_Name
4008 if Chars (Arg) /= Id then
4009 Error_Msg_Name_1 := Pname;
4010 Error_Msg_Name_2 := Id;
4011 Error_Msg_N ("pragma% argument expects identifier%", Arg);
4015 end Check_Optional_Identifier;
4017 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
4019 Name_Buffer (1 .. Id'Length) := Id;
4020 Name_Len := Id'Length;
4021 Check_Optional_Identifier (Arg, Name_Find);
4022 end Check_Optional_Identifier;
4024 --------------------
4025 -- Check_Pre_Post --
4026 --------------------
4028 procedure Check_Pre_Post is
4033 if not Is_List_Member (N) then
4037 -- If we are within an inlined body, the legality of the pragma
4038 -- has been checked already.
4040 if In_Inlined_Body then
4044 -- Search prior declarations
4047 while Present (Prev (P)) loop
4050 -- If the previous node is a generic subprogram, do not go to to
4051 -- the original node, which is the unanalyzed tree: we need to
4052 -- attach the pre/postconditions to the analyzed version at this
4053 -- point. They get propagated to the original tree when analyzing
4054 -- the corresponding body.
4056 if Nkind (P) not in N_Generic_Declaration then
4057 PO := Original_Node (P);
4062 -- Skip past prior pragma
4064 if Nkind (PO) = N_Pragma then
4067 -- Skip stuff not coming from source
4069 elsif not Comes_From_Source (PO) then
4071 -- The condition may apply to a subprogram instantiation
4073 if Nkind (PO) = N_Subprogram_Declaration
4074 and then Present (Generic_Parent (Specification (PO)))
4078 elsif Nkind (PO) = N_Subprogram_Declaration
4079 and then In_Instance
4083 -- For all other cases of non source code, do nothing
4089 -- Only remaining possibility is subprogram declaration
4096 -- If we fall through loop, pragma is at start of list, so see if it
4097 -- is at the start of declarations of a subprogram body.
4101 if Nkind (PO) = N_Subprogram_Body
4102 and then List_Containing (N) = Declarations (PO)
4104 -- This is only allowed if there is no separate specification
4106 if Present (Corresponding_Spec (PO)) then
4108 ("pragma% must apply to subprogram specification");
4115 --------------------------------------
4116 -- Check_Precondition_Postcondition --
4117 --------------------------------------
4119 procedure Check_Precondition_Postcondition (In_Body : out Boolean) is
4123 procedure Chain_PPC (PO : Node_Id);
4124 -- If PO is an entry or a [generic] subprogram declaration node, then
4125 -- the precondition/postcondition applies to this subprogram and the
4126 -- processing for the pragma is completed. Otherwise the pragma is
4133 procedure Chain_PPC (PO : Node_Id) is
4137 if Nkind (PO) = N_Abstract_Subprogram_Declaration then
4138 if not From_Aspect_Specification (N) then
4140 ("pragma% cannot be applied to abstract subprogram");
4142 elsif Class_Present (N) then
4147 ("aspect % requires ''Class for abstract subprogram");
4150 -- AI05-0230: The same restriction applies to null procedures. For
4151 -- compatibility with earlier uses of the Ada pragma, apply this
4152 -- rule only to aspect specifications.
4154 -- The above discrepency needs documentation. Robert is dubious
4155 -- about whether it is a good idea ???
4157 elsif Nkind (PO) = N_Subprogram_Declaration
4158 and then Nkind (Specification (PO)) = N_Procedure_Specification
4159 and then Null_Present (Specification (PO))
4160 and then From_Aspect_Specification (N)
4161 and then not Class_Present (N)
4164 ("aspect % requires ''Class for null procedure");
4166 -- Pre/postconditions are legal on a subprogram body if it is not
4167 -- a completion of a declaration. They are also legal on a stub
4168 -- with no previous declarations (this is checked when processing
4169 -- the corresponding aspects).
4171 elsif Nkind (PO) = N_Subprogram_Body
4172 and then Acts_As_Spec (PO)
4176 elsif Nkind (PO) = N_Subprogram_Body_Stub then
4179 elsif not Nkind_In (PO, N_Subprogram_Declaration,
4180 N_Expression_Function,
4181 N_Generic_Subprogram_Declaration,
4182 N_Entry_Declaration)
4187 -- Here if we have [generic] subprogram or entry declaration
4189 if Nkind (PO) = N_Entry_Declaration then
4190 S := Defining_Entity (PO);
4192 S := Defining_Unit_Name (Specification (PO));
4194 if Nkind (S) = N_Defining_Program_Unit_Name then
4195 S := Defining_Identifier (S);
4199 -- Note: we do not analyze the pragma at this point. Instead we
4200 -- delay this analysis until the end of the declarative part in
4201 -- which the pragma appears. This implements the required delay
4202 -- in this analysis, allowing forward references. The analysis
4203 -- happens at the end of Analyze_Declarations.
4205 -- Chain spec PPC pragma to list for subprogram
4207 Add_Contract_Item (N, S);
4209 -- Return indicating spec case
4215 -- Start of processing for Check_Precondition_Postcondition
4218 if not Is_List_Member (N) then
4222 -- Preanalyze message argument if present. Visibility in this
4223 -- argument is established at the point of pragma occurrence.
4225 if Arg_Count = 2 then
4226 Check_Optional_Identifier (Arg2, Name_Message);
4227 Preanalyze_Spec_Expression
4228 (Get_Pragma_Arg (Arg2), Standard_String);
4231 -- For a pragma PPC in the extended main source unit, record enabled
4234 if Is_Checked (N) and then not Split_PPC (N) then
4235 Set_SCO_Pragma_Enabled (Loc);
4238 -- If we are within an inlined body, the legality of the pragma
4239 -- has been checked already.
4241 if In_Inlined_Body then
4246 -- Search prior declarations
4249 while Present (Prev (P)) loop
4252 -- If the previous node is a generic subprogram, do not go to to
4253 -- the original node, which is the unanalyzed tree: we need to
4254 -- attach the pre/postconditions to the analyzed version at this
4255 -- point. They get propagated to the original tree when analyzing
4256 -- the corresponding body.
4258 if Nkind (P) not in N_Generic_Declaration then
4259 PO := Original_Node (P);
4264 -- Skip past prior pragma
4266 if Nkind (PO) = N_Pragma then
4269 -- Skip stuff not coming from source
4271 elsif not Comes_From_Source (PO) then
4273 -- The condition may apply to a subprogram instantiation
4275 if Nkind (PO) = N_Subprogram_Declaration
4276 and then Present (Generic_Parent (Specification (PO)))
4281 elsif Nkind (PO) = N_Subprogram_Declaration
4282 and then In_Instance
4287 -- For all other cases of non source code, do nothing
4293 -- Only remaining possibility is subprogram declaration
4301 -- If we fall through loop, pragma is at start of list, so see if it
4302 -- is at the start of declarations of a subprogram body.
4306 if Nkind (PO) = N_Subprogram_Body
4307 and then List_Containing (N) = Declarations (PO)
4309 if Operating_Mode /= Generate_Code or else Inside_A_Generic then
4311 -- Analyze pragma expression for correctness and for ASIS use
4313 Preanalyze_Assert_Expression
4314 (Get_Pragma_Arg (Arg1), Standard_Boolean);
4316 -- In ASIS mode, for a pragma generated from a source aspect,
4317 -- also analyze the original aspect expression.
4319 if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
4320 Preanalyze_Assert_Expression
4321 (Expression (Corresponding_Aspect (N)), Standard_Boolean);
4325 -- Retain a copy of the pre- or postcondition pragma for formal
4326 -- verification purposes. The copy is needed because the pragma is
4327 -- expanded into other constructs which are not acceptable in the
4330 if Acts_As_Spec (PO)
4331 and then (SPARK_Mode or Formal_Extensions)
4334 Prag : constant Node_Id := New_Copy_Tree (N);
4337 -- Preanalyze the pragma
4339 Preanalyze_Assert_Expression
4341 (First (Pragma_Argument_Associations (Prag))),
4344 -- Preanalyze the corresponding aspect (if any)
4346 if Present (Corresponding_Aspect (Prag)) then
4347 Preanalyze_Assert_Expression
4348 (Expression (Corresponding_Aspect (Prag)),
4352 -- Chain the copy on the contract of the body
4355 (Prag, Defining_Unit_Name (Specification (PO)));
4362 -- See if it is in the pragmas after a library level subprogram
4364 elsif Nkind (PO) = N_Compilation_Unit_Aux then
4366 -- In formal verification mode, analyze pragma expression for
4367 -- correctness, as it is not expanded later. Ditto in ASIS_Mode
4368 -- where there is no later point at which the aspect will be
4371 if SPARK_Mode or else ASIS_Mode then
4372 Analyze_Pre_Post_Condition_In_Decl_Part
4373 (N, Defining_Entity (Unit (Parent (PO))));
4376 Chain_PPC (Unit (Parent (PO)));
4380 -- If we fall through, pragma was misplaced
4383 end Check_Precondition_Postcondition;
4385 -----------------------------
4386 -- Check_Static_Constraint --
4387 -----------------------------
4389 -- Note: for convenience in writing this procedure, in addition to
4390 -- the officially (i.e. by spec) allowed argument which is always a
4391 -- constraint, it also allows ranges and discriminant associations.
4392 -- Above is not clear ???
4394 procedure Check_Static_Constraint (Constr : Node_Id) is
4396 procedure Require_Static (E : Node_Id);
4397 -- Require given expression to be static expression
4399 --------------------
4400 -- Require_Static --
4401 --------------------
4403 procedure Require_Static (E : Node_Id) is
4405 if not Is_OK_Static_Expression (E) then
4406 Flag_Non_Static_Expr
4407 ("non-static constraint not allowed in Unchecked_Union!", E);
4412 -- Start of processing for Check_Static_Constraint
4415 case Nkind (Constr) is
4416 when N_Discriminant_Association =>
4417 Require_Static (Expression (Constr));
4420 Require_Static (Low_Bound (Constr));
4421 Require_Static (High_Bound (Constr));
4423 when N_Attribute_Reference =>
4424 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
4425 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
4427 when N_Range_Constraint =>
4428 Check_Static_Constraint (Range_Expression (Constr));
4430 when N_Index_Or_Discriminant_Constraint =>
4434 IDC := First (Constraints (Constr));
4435 while Present (IDC) loop
4436 Check_Static_Constraint (IDC);
4444 end Check_Static_Constraint;
4446 ---------------------
4447 -- Check_Test_Case --
4448 ---------------------
4450 procedure Check_Test_Case is
4454 procedure Chain_CTC (PO : Node_Id);
4455 -- If PO is a [generic] subprogram declaration node, then the
4456 -- test-case applies to this subprogram and the processing for
4457 -- the pragma is completed. Otherwise the pragma is misplaced.
4463 procedure Chain_CTC (PO : Node_Id) is
4467 if Nkind (PO) = N_Abstract_Subprogram_Declaration then
4469 ("pragma% cannot be applied to abstract subprogram");
4471 elsif Nkind (PO) = N_Entry_Declaration then
4472 Error_Pragma ("pragma% cannot be applied to entry");
4474 elsif not Nkind_In (PO, N_Subprogram_Declaration,
4475 N_Generic_Subprogram_Declaration)
4480 -- Here if we have [generic] subprogram declaration
4482 S := Defining_Unit_Name (Specification (PO));
4484 -- Note: we do not analyze the pragma at this point. Instead we
4485 -- delay this analysis until the end of the declarative part in
4486 -- which the pragma appears. This implements the required delay
4487 -- in this analysis, allowing forward references. The analysis
4488 -- happens at the end of Analyze_Declarations.
4490 -- There should not be another test-case with the same name
4491 -- associated to this subprogram.
4494 Name : constant String_Id := Get_Name_From_CTC_Pragma (N);
4498 CTC := Contract_Test_Cases (Contract (S));
4499 while Present (CTC) loop
4501 -- Omit pragma Contract_Cases because it does not introduce
4502 -- a unique case name and it does not follow the syntax of
4505 if Pragma_Name (CTC) = Name_Contract_Cases then
4509 (Name, Get_Name_From_CTC_Pragma (CTC))
4511 Error_Msg_Sloc := Sloc (CTC);
4512 Error_Pragma ("name for pragma% is already used#");
4515 CTC := Next_Pragma (CTC);
4519 -- Chain spec CTC pragma to list for subprogram
4521 Add_Contract_Item (N, S);
4524 -- Start of processing for Check_Test_Case
4527 -- First check pragma arguments
4529 Check_At_Least_N_Arguments (2);
4530 Check_At_Most_N_Arguments (4);
4532 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
4534 Check_Optional_Identifier (Arg1, Name_Name);
4535 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
4537 -- In ASIS mode, for a pragma generated from a source aspect, also
4538 -- analyze the original aspect expression.
4540 if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
4541 Check_Expr_Is_Static_Expression
4542 (Original_Node (Get_Pragma_Arg (Arg1)), Standard_String);
4545 Check_Optional_Identifier (Arg2, Name_Mode);
4546 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
4548 if Arg_Count = 4 then
4549 Check_Identifier (Arg3, Name_Requires);
4550 Check_Identifier (Arg4, Name_Ensures);
4552 elsif Arg_Count = 3 then
4553 Check_Identifier_Is_One_Of (Arg3, Name_Requires, Name_Ensures);
4556 -- Check pragma placement
4558 if not Is_List_Member (N) then
4562 -- Test-case should only appear in package spec unit
4564 if Get_Source_Unit (N) = No_Unit
4565 or else not Nkind_In (Sinfo.Unit (Cunit (Get_Source_Unit (N))),
4566 N_Package_Declaration,
4567 N_Generic_Package_Declaration)
4572 -- Search prior declarations
4575 while Present (Prev (P)) loop
4578 -- If the previous node is a generic subprogram, do not go to to
4579 -- the original node, which is the unanalyzed tree: we need to
4580 -- attach the test-case to the analyzed version at this point.
4581 -- They get propagated to the original tree when analyzing the
4582 -- corresponding body.
4584 if Nkind (P) not in N_Generic_Declaration then
4585 PO := Original_Node (P);
4590 -- Skip past prior pragma
4592 if Nkind (PO) = N_Pragma then
4595 -- Skip stuff not coming from source
4597 elsif not Comes_From_Source (PO) then
4600 -- Only remaining possibility is subprogram declaration. First
4601 -- check that it is declared directly in a package declaration.
4602 -- This may be either the package declaration for the current unit
4603 -- being defined or a local package declaration.
4605 elsif not Present (Parent (Parent (PO)))
4606 or else not Present (Parent (Parent (Parent (PO))))
4607 or else not Nkind_In (Parent (Parent (PO)),
4608 N_Package_Declaration,
4609 N_Generic_Package_Declaration)
4619 -- If we fall through, pragma was misplaced
4622 end Check_Test_Case;
4624 --------------------------------------
4625 -- Check_Valid_Configuration_Pragma --
4626 --------------------------------------
4628 -- A configuration pragma must appear in the context clause of a
4629 -- compilation unit, and only other pragmas may precede it. Note that
4630 -- the test also allows use in a configuration pragma file.
4632 procedure Check_Valid_Configuration_Pragma is
4634 if not Is_Configuration_Pragma then
4635 Error_Pragma ("incorrect placement for configuration pragma%");
4637 end Check_Valid_Configuration_Pragma;
4639 -------------------------------------
4640 -- Check_Valid_Library_Unit_Pragma --
4641 -------------------------------------
4643 procedure Check_Valid_Library_Unit_Pragma is
4645 Parent_Node : Node_Id;
4646 Unit_Name : Entity_Id;
4647 Unit_Kind : Node_Kind;
4648 Unit_Node : Node_Id;
4649 Sindex : Source_File_Index;
4652 if not Is_List_Member (N) then
4656 Plist := List_Containing (N);
4657 Parent_Node := Parent (Plist);
4659 if Parent_Node = Empty then
4662 -- Case of pragma appearing after a compilation unit. In this case
4663 -- it must have an argument with the corresponding name and must
4664 -- be part of the following pragmas of its parent.
4666 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
4667 if Plist /= Pragmas_After (Parent_Node) then
4670 elsif Arg_Count = 0 then
4672 ("argument required if outside compilation unit");
4675 Check_No_Identifiers;
4676 Check_Arg_Count (1);
4677 Unit_Node := Unit (Parent (Parent_Node));
4678 Unit_Kind := Nkind (Unit_Node);
4680 Analyze (Get_Pragma_Arg (Arg1));
4682 if Unit_Kind = N_Generic_Subprogram_Declaration
4683 or else Unit_Kind = N_Subprogram_Declaration
4685 Unit_Name := Defining_Entity (Unit_Node);
4687 elsif Unit_Kind in N_Generic_Instantiation then
4688 Unit_Name := Defining_Entity (Unit_Node);
4691 Unit_Name := Cunit_Entity (Current_Sem_Unit);
4694 if Chars (Unit_Name) /=
4695 Chars (Entity (Get_Pragma_Arg (Arg1)))
4698 ("pragma% argument is not current unit name", Arg1);
4701 if Ekind (Unit_Name) = E_Package
4702 and then Present (Renamed_Entity (Unit_Name))
4704 Error_Pragma ("pragma% not allowed for renamed package");
4708 -- Pragma appears other than after a compilation unit
4711 -- Here we check for the generic instantiation case and also
4712 -- for the case of processing a generic formal package. We
4713 -- detect these cases by noting that the Sloc on the node
4714 -- does not belong to the current compilation unit.
4716 Sindex := Source_Index (Current_Sem_Unit);
4718 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
4719 Rewrite (N, Make_Null_Statement (Loc));
4722 -- If before first declaration, the pragma applies to the
4723 -- enclosing unit, and the name if present must be this name.
4725 elsif Is_Before_First_Decl (N, Plist) then
4726 Unit_Node := Unit_Declaration_Node (Current_Scope);
4727 Unit_Kind := Nkind (Unit_Node);
4729 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
4732 elsif Unit_Kind = N_Subprogram_Body
4733 and then not Acts_As_Spec (Unit_Node)
4737 elsif Nkind (Parent_Node) = N_Package_Body then
4740 elsif Nkind (Parent_Node) = N_Package_Specification
4741 and then Plist = Private_Declarations (Parent_Node)
4745 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
4746 or else Nkind (Parent_Node) =
4747 N_Generic_Subprogram_Declaration)
4748 and then Plist = Generic_Formal_Declarations (Parent_Node)
4752 elsif Arg_Count > 0 then
4753 Analyze (Get_Pragma_Arg (Arg1));
4755 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
4757 ("name in pragma% must be enclosing unit", Arg1);
4760 -- It is legal to have no argument in this context
4766 -- Error if not before first declaration. This is because a
4767 -- library unit pragma argument must be the name of a library
4768 -- unit (RM 10.1.5(7)), but the only names permitted in this
4769 -- context are (RM 10.1.5(6)) names of subprogram declarations,
4770 -- generic subprogram declarations or generic instantiations.
4774 ("pragma% misplaced, must be before first declaration");
4778 end Check_Valid_Library_Unit_Pragma;
4784 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
4785 Clist : constant Node_Id := Component_List (Variant);
4789 Comp := First (Component_Items (Clist));
4790 while Present (Comp) loop
4791 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
4800 procedure Error_Pragma (Msg : String) is
4801 MsgF : String := Msg;
4803 Error_Msg_Name_1 := Pname;
4805 Error_Msg_N (MsgF, N);
4809 ----------------------
4810 -- Error_Pragma_Arg --
4811 ----------------------
4813 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
4814 MsgF : String := Msg;
4816 Error_Msg_Name_1 := Pname;
4818 Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
4820 end Error_Pragma_Arg;
4822 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
4823 MsgF : String := Msg1;
4825 Error_Msg_Name_1 := Pname;
4827 Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
4828 Error_Pragma_Arg (Msg2, Arg);
4829 end Error_Pragma_Arg;
4831 ----------------------------
4832 -- Error_Pragma_Arg_Ident --
4833 ----------------------------
4835 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
4836 MsgF : String := Msg;
4838 Error_Msg_Name_1 := Pname;
4840 Error_Msg_N (MsgF, Arg);
4842 end Error_Pragma_Arg_Ident;
4844 ----------------------
4845 -- Error_Pragma_Ref --
4846 ----------------------
4848 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
4849 MsgF : String := Msg;
4851 Error_Msg_Name_1 := Pname;
4853 Error_Msg_Sloc := Sloc (Ref);
4854 Error_Msg_NE (MsgF, N, Ref);
4856 end Error_Pragma_Ref;
4858 ------------------------
4859 -- Find_Lib_Unit_Name --
4860 ------------------------
4862 function Find_Lib_Unit_Name return Entity_Id is
4864 -- Return inner compilation unit entity, for case of nested
4865 -- categorization pragmas. This happens in generic unit.
4867 if Nkind (Parent (N)) = N_Package_Specification
4868 and then Defining_Entity (Parent (N)) /= Current_Scope
4870 return Defining_Entity (Parent (N));
4872 return Current_Scope;
4874 end Find_Lib_Unit_Name;
4876 ----------------------------
4877 -- Find_Program_Unit_Name --
4878 ----------------------------
4880 procedure Find_Program_Unit_Name (Id : Node_Id) is
4881 Unit_Name : Entity_Id;
4882 Unit_Kind : Node_Kind;
4883 P : constant Node_Id := Parent (N);
4886 if Nkind (P) = N_Compilation_Unit then
4887 Unit_Kind := Nkind (Unit (P));
4889 if Unit_Kind = N_Subprogram_Declaration
4890 or else Unit_Kind = N_Package_Declaration
4891 or else Unit_Kind in N_Generic_Declaration
4893 Unit_Name := Defining_Entity (Unit (P));
4895 if Chars (Id) = Chars (Unit_Name) then
4896 Set_Entity (Id, Unit_Name);
4897 Set_Etype (Id, Etype (Unit_Name));
4899 Set_Etype (Id, Any_Type);
4901 ("cannot find program unit referenced by pragma%");
4905 Set_Etype (Id, Any_Type);
4906 Error_Pragma ("pragma% inapplicable to this unit");
4912 end Find_Program_Unit_Name;
4914 -----------------------------------------
4915 -- Find_Unique_Parameterless_Procedure --
4916 -----------------------------------------
4918 function Find_Unique_Parameterless_Procedure
4920 Arg : Node_Id) return Entity_Id
4922 Proc : Entity_Id := Empty;
4925 -- The body of this procedure needs some comments ???
4927 if not Is_Entity_Name (Name) then
4929 ("argument of pragma% must be entity name", Arg);
4931 elsif not Is_Overloaded (Name) then
4932 Proc := Entity (Name);
4934 if Ekind (Proc) /= E_Procedure
4935 or else Present (First_Formal (Proc))
4938 ("argument of pragma% must be parameterless procedure", Arg);
4943 Found : Boolean := False;
4945 Index : Interp_Index;
4948 Get_First_Interp (Name, Index, It);
4949 while Present (It.Nam) loop
4952 if Ekind (Proc) = E_Procedure
4953 and then No (First_Formal (Proc))
4957 Set_Entity (Name, Proc);
4958 Set_Is_Overloaded (Name, False);
4961 ("ambiguous handler name for pragma% ", Arg);
4965 Get_Next_Interp (Index, It);
4970 ("argument of pragma% must be parameterless procedure",
4973 Proc := Entity (Name);
4979 end Find_Unique_Parameterless_Procedure;
4985 procedure Fix_Error (Msg : in out String) is
4987 -- If we have a rewriting of another pragma, go to that pragma
4989 if Is_Rewrite_Substitution (N)
4990 and then Nkind (Original_Node (N)) = N_Pragma
4992 Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
4995 -- Case where pragma comes from an aspect specification
4997 if From_Aspect_Specification (N) then
4999 -- Change appearence of "pragma" in message to "aspect"
5001 for J in Msg'First .. Msg'Last - 5 loop
5002 if Msg (J .. J + 5) = "pragma" then
5003 Msg (J .. J + 5) := "aspect";
5007 -- Get name from corresponding aspect
5009 Error_Msg_Name_1 := Original_Aspect_Name (N);
5013 -------------------------
5014 -- Gather_Associations --
5015 -------------------------
5017 procedure Gather_Associations
5019 Args : out Args_List)
5024 -- Initialize all parameters to Empty
5026 for J in Args'Range loop
5030 -- That's all we have to do if there are no argument associations
5032 if No (Pragma_Argument_Associations (N)) then
5036 -- Otherwise first deal with any positional parameters present
5038 Arg := First (Pragma_Argument_Associations (N));
5039 for Index in Args'Range loop
5040 exit when No (Arg) or else Chars (Arg) /= No_Name;
5041 Args (Index) := Get_Pragma_Arg (Arg);
5045 -- Positional parameters all processed, if any left, then we
5046 -- have too many positional parameters.
5048 if Present (Arg) and then Chars (Arg) = No_Name then
5050 ("too many positional associations for pragma%", Arg);
5053 -- Process named parameters if any are present
5055 while Present (Arg) loop
5056 if Chars (Arg) = No_Name then
5058 ("positional association cannot follow named association",
5062 for Index in Names'Range loop
5063 if Names (Index) = Chars (Arg) then
5064 if Present (Args (Index)) then
5066 ("duplicate argument association for pragma%", Arg);
5068 Args (Index) := Get_Pragma_Arg (Arg);
5073 if Index = Names'Last then
5074 Error_Msg_Name_1 := Pname;
5075 Error_Msg_N ("pragma% does not allow & argument", Arg);
5077 -- Check for possible misspelling
5079 for Index1 in Names'Range loop
5080 if Is_Bad_Spelling_Of
5081 (Chars (Arg), Names (Index1))
5083 Error_Msg_Name_1 := Names (Index1);
5084 Error_Msg_N -- CODEFIX
5085 ("\possible misspelling of%", Arg);
5097 end Gather_Associations;
5103 procedure GNAT_Pragma is
5105 -- We need to check the No_Implementation_Pragmas restriction for
5106 -- the case of a pragma from source. Note that the case of aspects
5107 -- generating corresponding pragmas marks these pragmas as not being
5108 -- from source, so this test also catches that case.
5110 if Comes_From_Source (N) then
5111 Check_Restriction (No_Implementation_Pragmas, N);
5115 --------------------------
5116 -- Is_Before_First_Decl --
5117 --------------------------
5119 function Is_Before_First_Decl
5120 (Pragma_Node : Node_Id;
5121 Decls : List_Id) return Boolean
5123 Item : Node_Id := First (Decls);
5126 -- Only other pragmas can come before this pragma
5129 if No (Item) or else Nkind (Item) /= N_Pragma then
5132 elsif Item = Pragma_Node then
5138 end Is_Before_First_Decl;
5140 -----------------------------
5141 -- Is_Configuration_Pragma --
5142 -----------------------------
5144 -- A configuration pragma must appear in the context clause of a
5145 -- compilation unit, and only other pragmas may precede it. Note that
5146 -- the test below also permits use in a configuration pragma file.
5148 function Is_Configuration_Pragma return Boolean is
5149 Lis : constant List_Id := List_Containing (N);
5150 Par : constant Node_Id := Parent (N);
5154 -- If no parent, then we are in the configuration pragma file,
5155 -- so the placement is definitely appropriate.
5160 -- Otherwise we must be in the context clause of a compilation unit
5161 -- and the only thing allowed before us in the context list is more
5162 -- configuration pragmas.
5164 elsif Nkind (Par) = N_Compilation_Unit
5165 and then Context_Items (Par) = Lis
5172 elsif Nkind (Prg) /= N_Pragma then
5182 end Is_Configuration_Pragma;
5184 --------------------------
5185 -- Is_In_Context_Clause --
5186 --------------------------
5188 function Is_In_Context_Clause return Boolean is
5190 Parent_Node : Node_Id;
5193 if not Is_List_Member (N) then
5197 Plist := List_Containing (N);
5198 Parent_Node := Parent (Plist);
5200 if Parent_Node = Empty
5201 or else Nkind (Parent_Node) /= N_Compilation_Unit
5202 or else Context_Items (Parent_Node) /= Plist
5209 end Is_In_Context_Clause;
5211 ---------------------------------
5212 -- Is_Static_String_Expression --
5213 ---------------------------------
5215 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
5216 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5219 Analyze_And_Resolve (Argx);
5220 return Is_OK_Static_Expression (Argx)
5221 and then Nkind (Argx) = N_String_Literal;
5222 end Is_Static_String_Expression;
5224 ----------------------
5225 -- Pragma_Misplaced --
5226 ----------------------
5228 procedure Pragma_Misplaced is
5230 Error_Pragma ("incorrect placement of pragma%");
5231 end Pragma_Misplaced;
5233 ------------------------------------
5234 -- Process_Atomic_Shared_Volatile --
5235 ------------------------------------
5237 procedure Process_Atomic_Shared_Volatile is
5244 procedure Set_Atomic (E : Entity_Id);
5245 -- Set given type as atomic, and if no explicit alignment was given,
5246 -- set alignment to unknown, since back end knows what the alignment
5247 -- requirements are for atomic arrays. Note: this step is necessary
5248 -- for derived types.
5254 procedure Set_Atomic (E : Entity_Id) is
5258 if not Has_Alignment_Clause (E) then
5259 Set_Alignment (E, Uint_0);
5263 -- Start of processing for Process_Atomic_Shared_Volatile
5266 Check_Ada_83_Warning;
5267 Check_No_Identifiers;
5268 Check_Arg_Count (1);
5269 Check_Arg_Is_Local_Name (Arg1);
5270 E_Id := Get_Pragma_Arg (Arg1);
5272 if Etype (E_Id) = Any_Type then
5277 D := Declaration_Node (E);
5280 -- Check duplicate before we chain ourselves!
5282 Check_Duplicate_Pragma (E);
5284 -- Now check appropriateness of the entity
5287 if Rep_Item_Too_Early (E, N)
5289 Rep_Item_Too_Late (E, N)
5293 Check_First_Subtype (Arg1);
5296 if Prag_Id /= Pragma_Volatile then
5298 Set_Atomic (Underlying_Type (E));
5299 Set_Atomic (Base_Type (E));
5302 -- Attribute belongs on the base type. If the view of the type is
5303 -- currently private, it also belongs on the underlying type.
5305 Set_Is_Volatile (Base_Type (E));
5306 Set_Is_Volatile (Underlying_Type (E));
5308 Set_Treat_As_Volatile (E);
5309 Set_Treat_As_Volatile (Underlying_Type (E));
5311 elsif K = N_Object_Declaration
5312 or else (K = N_Component_Declaration
5313 and then Original_Record_Component (E) = E)
5315 if Rep_Item_Too_Late (E, N) then
5319 if Prag_Id /= Pragma_Volatile then
5322 -- If the object declaration has an explicit initialization, a
5323 -- temporary may have to be created to hold the expression, to
5324 -- ensure that access to the object remain atomic.
5326 if Nkind (Parent (E)) = N_Object_Declaration
5327 and then Present (Expression (Parent (E)))
5329 Set_Has_Delayed_Freeze (E);
5332 -- An interesting improvement here. If an object of composite
5333 -- type X is declared atomic, and the type X isn't, that's a
5334 -- pity, since it may not have appropriate alignment etc. We
5335 -- can rescue this in the special case where the object and
5336 -- type are in the same unit by just setting the type as
5337 -- atomic, so that the back end will process it as atomic.
5339 -- Note: we used to do this for elementary types as well,
5340 -- but that turns out to be a bad idea and can have unwanted
5341 -- effects, most notably if the type is elementary, the object
5342 -- a simple component within a record, and both are in a spec:
5343 -- every object of this type in the entire program will be
5344 -- treated as atomic, thus incurring a potentially costly
5345 -- synchronization operation for every access.
5347 -- Of course it would be best if the back end could just adjust
5348 -- the alignment etc for the specific object, but that's not
5349 -- something we are capable of doing at this point.
5351 Utyp := Underlying_Type (Etype (E));
5354 and then Is_Composite_Type (Utyp)
5355 and then Sloc (E) > No_Location
5356 and then Sloc (Utyp) > No_Location
5358 Get_Source_File_Index (Sloc (E)) =
5359 Get_Source_File_Index (Sloc (Underlying_Type (Etype (E))))
5361 Set_Is_Atomic (Underlying_Type (Etype (E)));
5365 Set_Is_Volatile (E);
5366 Set_Treat_As_Volatile (E);
5370 ("inappropriate entity for pragma%", Arg1);
5372 end Process_Atomic_Shared_Volatile;
5374 -------------------------------------------
5375 -- Process_Compile_Time_Warning_Or_Error --
5376 -------------------------------------------
5378 procedure Process_Compile_Time_Warning_Or_Error is
5379 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
5382 Check_Arg_Count (2);
5383 Check_No_Identifiers;
5384 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
5385 Analyze_And_Resolve (Arg1x, Standard_Boolean);
5387 if Compile_Time_Known_Value (Arg1x) then
5388 if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
5390 Str : constant String_Id :=
5391 Strval (Get_Pragma_Arg (Arg2));
5392 Len : constant Int := String_Length (Str);
5397 Cent : constant Entity_Id :=
5398 Cunit_Entity (Current_Sem_Unit);
5400 Force : constant Boolean :=
5401 Prag_Id = Pragma_Compile_Time_Warning
5403 Is_Spec_Name (Unit_Name (Current_Sem_Unit))
5404 and then (Ekind (Cent) /= E_Package
5405 or else not In_Private_Part (Cent));
5406 -- Set True if this is the warning case, and we are in the
5407 -- visible part of a package spec, or in a subprogram spec,
5408 -- in which case we want to force the client to see the
5409 -- warning, even though it is not in the main unit.
5412 -- Loop through segments of message separated by line feeds.
5413 -- We output these segments as separate messages with
5414 -- continuation marks for all but the first.
5419 Error_Msg_Strlen := 0;
5421 -- Loop to copy characters from argument to error message
5425 exit when Ptr > Len;
5426 CC := Get_String_Char (Str, Ptr);
5429 -- Ignore wide chars ??? else store character
5431 if In_Character_Range (CC) then
5432 C := Get_Character (CC);
5433 exit when C = ASCII.LF;
5434 Error_Msg_Strlen := Error_Msg_Strlen + 1;
5435 Error_Msg_String (Error_Msg_Strlen) := C;
5439 -- Here with one line ready to go
5441 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
5443 -- If this is a warning in a spec, then we want clients
5444 -- to see the warning, so mark the message with the
5445 -- special sequence !! to force the warning. In the case
5446 -- of a package spec, we do not force this if we are in
5447 -- the private part of the spec.
5450 if Cont = False then
5451 Error_Msg_N ("<~!!", Arg1);
5454 Error_Msg_N ("\<~!!", Arg1);
5457 -- Error, rather than warning, or in a body, so we do not
5458 -- need to force visibility for client (error will be
5459 -- output in any case, and this is the situation in which
5460 -- we do not want a client to get a warning, since the
5461 -- warning is in the body or the spec private part).
5464 if Cont = False then
5465 Error_Msg_N ("<~", Arg1);
5468 Error_Msg_N ("\<~", Arg1);
5472 exit when Ptr > Len;
5477 end Process_Compile_Time_Warning_Or_Error;
5479 ------------------------
5480 -- Process_Convention --
5481 ------------------------
5483 procedure Process_Convention
5484 (C : out Convention_Id;
5485 Ent : out Entity_Id)
5491 Comp_Unit : Unit_Number_Type;
5493 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
5494 -- Called if we have more than one Export/Import/Convention pragma.
5495 -- This is generally illegal, but we have a special case of allowing
5496 -- Import and Interface to coexist if they specify the convention in
5497 -- a consistent manner. We are allowed to do this, since Interface is
5498 -- an implementation defined pragma, and we choose to do it since we
5499 -- know Rational allows this combination. S is the entity id of the
5500 -- subprogram in question. This procedure also sets the special flag
5501 -- Import_Interface_Present in both pragmas in the case where we do
5502 -- have matching Import and Interface pragmas.
5504 procedure Set_Convention_From_Pragma (E : Entity_Id);
5505 -- Set convention in entity E, and also flag that the entity has a
5506 -- convention pragma. If entity is for a private or incomplete type,
5507 -- also set convention and flag on underlying type. This procedure
5508 -- also deals with the special case of C_Pass_By_Copy convention.
5510 -------------------------------
5511 -- Diagnose_Multiple_Pragmas --
5512 -------------------------------
5514 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
5515 Pdec : constant Node_Id := Declaration_Node (S);
5519 function Same_Convention (Decl : Node_Id) return Boolean;
5520 -- Decl is a pragma node. This function returns True if this
5521 -- pragma has a first argument that is an identifier with a
5522 -- Chars field corresponding to the Convention_Id C.
5524 function Same_Name (Decl : Node_Id) return Boolean;
5525 -- Decl is a pragma node. This function returns True if this
5526 -- pragma has a second argument that is an identifier with a
5527 -- Chars field that matches the Chars of the current subprogram.
5529 ---------------------
5530 -- Same_Convention --
5531 ---------------------
5533 function Same_Convention (Decl : Node_Id) return Boolean is
5534 Arg1 : constant Node_Id :=
5535 First (Pragma_Argument_Associations (Decl));
5538 if Present (Arg1) then
5540 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
5542 if Nkind (Arg) = N_Identifier
5543 and then Is_Convention_Name (Chars (Arg))
5544 and then Get_Convention_Id (Chars (Arg)) = C
5552 end Same_Convention;
5558 function Same_Name (Decl : Node_Id) return Boolean is
5559 Arg1 : constant Node_Id :=
5560 First (Pragma_Argument_Associations (Decl));
5568 Arg2 := Next (Arg1);
5575 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
5577 if Nkind (Arg) = N_Identifier
5578 and then Chars (Arg) = Chars (S)
5587 -- Start of processing for Diagnose_Multiple_Pragmas
5592 -- Definitely give message if we have Convention/Export here
5594 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
5597 -- If we have an Import or Export, scan back from pragma to
5598 -- find any previous pragma applying to the same procedure.
5599 -- The scan will be terminated by the start of the list, or
5600 -- hitting the subprogram declaration. This won't allow one
5601 -- pragma to appear in the public part and one in the private
5602 -- part, but that seems very unlikely in practice.
5606 while Present (Decl) and then Decl /= Pdec loop
5608 -- Look for pragma with same name as us
5610 if Nkind (Decl) = N_Pragma
5611 and then Same_Name (Decl)
5613 -- Give error if same as our pragma or Export/Convention
5615 if Nam_In (Pragma_Name (Decl), Name_Export,
5621 -- Case of Import/Interface or the other way round
5623 elsif Nam_In (Pragma_Name (Decl), Name_Interface,
5626 -- Here we know that we have Import and Interface. It
5627 -- doesn't matter which way round they are. See if
5628 -- they specify the same convention. If so, all OK,
5629 -- and set special flags to stop other messages
5631 if Same_Convention (Decl) then
5632 Set_Import_Interface_Present (N);
5633 Set_Import_Interface_Present (Decl);
5636 -- If different conventions, special message
5639 Error_Msg_Sloc := Sloc (Decl);
5641 ("convention differs from that given#", Arg1);
5651 -- Give message if needed if we fall through those tests
5652 -- except on Relaxed_RM_Semantics where we let go: either this
5653 -- is a case accepted/ignored by other Ada compilers (e.g.
5654 -- a mix of Convention and Import), or another error will be
5655 -- generated later (e.g. using both Import and Export).
5657 if Err and not Relaxed_RM_Semantics then
5659 ("at most one Convention/Export/Import pragma is allowed",
5662 end Diagnose_Multiple_Pragmas;
5664 --------------------------------
5665 -- Set_Convention_From_Pragma --
5666 --------------------------------
5668 procedure Set_Convention_From_Pragma (E : Entity_Id) is
5670 -- Ada 2005 (AI-430): Check invalid attempt to change convention
5671 -- for an overridden dispatching operation. Technically this is
5672 -- an amendment and should only be done in Ada 2005 mode. However,
5673 -- this is clearly a mistake, since the problem that is addressed
5674 -- by this AI is that there is a clear gap in the RM!
5676 if Is_Dispatching_Operation (E)
5677 and then Present (Overridden_Operation (E))
5678 and then C /= Convention (Overridden_Operation (E))
5680 -- An attempt to override a subprogram with a ghost subprogram
5681 -- appears as a mismatch in conventions.
5683 if C = Convention_Ghost then
5684 Error_Msg_N ("ghost subprogram & cannot be overriding", E);
5687 ("cannot change convention for overridden dispatching "
5688 & "operation", Arg1);
5692 -- Special checks for Convention_Stdcall
5694 if C = Convention_Stdcall then
5696 -- A dispatching call is not allowed. A dispatching subprogram
5697 -- cannot be used to interface to the Win32 API, so in fact
5698 -- this check does not impose any effective restriction.
5700 if Is_Dispatching_Operation (E) then
5701 Error_Msg_Sloc := Sloc (E);
5703 -- Note: make this unconditional so that if there is more
5704 -- than one call to which the pragma applies, we get a
5705 -- message for each call. Also don't use Error_Pragma,
5706 -- so that we get multiple messages!
5709 ("dispatching subprogram# cannot use Stdcall convention!",
5712 -- Subprogram is allowed, but not a generic subprogram
5714 elsif not Is_Subprogram (E)
5715 and then not Is_Generic_Subprogram (E)
5719 and then Ekind (E) /= E_Variable
5721 -- An access to subprogram is also allowed
5725 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
5727 -- Allow internal call to set convention of subprogram type
5729 and then not (Ekind (E) = E_Subprogram_Type)
5732 ("second argument of pragma% must be subprogram (type)",
5737 -- Set the convention
5739 Set_Convention (E, C);
5740 Set_Has_Convention_Pragma (E);
5742 if Is_Incomplete_Or_Private_Type (E)
5743 and then Present (Underlying_Type (E))
5745 Set_Convention (Underlying_Type (E), C);
5746 Set_Has_Convention_Pragma (Underlying_Type (E), True);
5749 -- A class-wide type should inherit the convention of the specific
5750 -- root type (although this isn't specified clearly by the RM).
5752 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
5753 Set_Convention (Class_Wide_Type (E), C);
5756 -- If the entity is a record type, then check for special case of
5757 -- C_Pass_By_Copy, which is treated the same as C except that the
5758 -- special record flag is set. This convention is only permitted
5759 -- on record types (see AI95-00131).
5761 if Cname = Name_C_Pass_By_Copy then
5762 if Is_Record_Type (E) then
5763 Set_C_Pass_By_Copy (Base_Type (E));
5764 elsif Is_Incomplete_Or_Private_Type (E)
5765 and then Is_Record_Type (Underlying_Type (E))
5767 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
5770 ("C_Pass_By_Copy convention allowed only for record type",
5775 -- If the entity is a derived boolean type, check for the special
5776 -- case of convention C, C++, or Fortran, where we consider any
5777 -- nonzero value to represent true.
5779 if Is_Discrete_Type (E)
5780 and then Root_Type (Etype (E)) = Standard_Boolean
5786 C = Convention_Fortran)
5788 Set_Nonzero_Is_True (Base_Type (E));
5790 end Set_Convention_From_Pragma;
5792 -- Start of processing for Process_Convention
5795 Check_At_Least_N_Arguments (2);
5796 Check_Optional_Identifier (Arg1, Name_Convention);
5797 Check_Arg_Is_Identifier (Arg1);
5798 Cname := Chars (Get_Pragma_Arg (Arg1));
5800 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
5801 -- tested again below to set the critical flag).
5803 if Cname = Name_C_Pass_By_Copy then
5806 -- Otherwise we must have something in the standard convention list
5808 elsif Is_Convention_Name (Cname) then
5809 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
5811 -- In DEC VMS, it seems that there is an undocumented feature that
5812 -- any unrecognized convention is treated as the default, which for
5813 -- us is convention C. It does not seem so terrible to do this
5814 -- unconditionally, silently in the VMS case, and with a warning
5815 -- in the non-VMS case.
5818 if Warn_On_Export_Import and not OpenVMS_On_Target then
5820 ("??unrecognized convention name, C assumed",
5821 Get_Pragma_Arg (Arg1));
5827 Check_Optional_Identifier (Arg2, Name_Entity);
5828 Check_Arg_Is_Local_Name (Arg2);
5830 Id := Get_Pragma_Arg (Arg2);
5833 if not Is_Entity_Name (Id) then
5834 Error_Pragma_Arg ("entity name required", Arg2);
5839 -- Set entity to return
5843 -- Ada_Pass_By_Copy special checking
5845 if C = Convention_Ada_Pass_By_Copy then
5846 if not Is_First_Subtype (E) then
5848 ("convention `Ada_Pass_By_Copy` only allowed for types",
5852 if Is_By_Reference_Type (E) then
5854 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
5859 -- Ada_Pass_By_Reference special checking
5861 if C = Convention_Ada_Pass_By_Reference then
5862 if not Is_First_Subtype (E) then
5864 ("convention `Ada_Pass_By_Reference` only allowed for types",
5868 if Is_By_Copy_Type (E) then
5870 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
5875 -- Ghost special checking
5877 if Is_Ghost_Subprogram (E)
5878 and then Present (Overridden_Operation (E))
5880 Error_Msg_N ("ghost subprogram & cannot be overriding", E);
5883 -- Go to renamed subprogram if present, since convention applies to
5884 -- the actual renamed entity, not to the renaming entity. If the
5885 -- subprogram is inherited, go to parent subprogram.
5887 if Is_Subprogram (E)
5888 and then Present (Alias (E))
5890 if Nkind (Parent (Declaration_Node (E))) =
5891 N_Subprogram_Renaming_Declaration
5893 if Scope (E) /= Scope (Alias (E)) then
5895 ("cannot apply pragma% to non-local entity&#", E);
5900 elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
5901 N_Private_Extension_Declaration)
5902 and then Scope (E) = Scope (Alias (E))
5906 -- Return the parent subprogram the entity was inherited from
5912 -- Check that we are not applying this to a specless body
5913 -- Relax this check if Relaxed_RM_Semantics to accomodate other Ada
5916 if Is_Subprogram (E)
5917 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
5918 and then not Relaxed_RM_Semantics
5921 ("pragma% requires separate spec and must come before body");
5924 -- Check that we are not applying this to a named constant
5926 if Ekind_In (E, E_Named_Integer, E_Named_Real) then
5927 Error_Msg_Name_1 := Pname;
5929 ("cannot apply pragma% to named constant!",
5930 Get_Pragma_Arg (Arg2));
5932 ("\supply appropriate type for&!", Arg2);
5935 if Ekind (E) = E_Enumeration_Literal then
5936 Error_Pragma ("enumeration literal not allowed for pragma%");
5939 -- Check for rep item appearing too early or too late
5941 if Etype (E) = Any_Type
5942 or else Rep_Item_Too_Early (E, N)
5946 elsif Present (Underlying_Type (E)) then
5947 E := Underlying_Type (E);
5950 if Rep_Item_Too_Late (E, N) then
5954 if Has_Convention_Pragma (E) then
5955 Diagnose_Multiple_Pragmas (E);
5957 elsif Convention (E) = Convention_Protected
5958 or else Ekind (Scope (E)) = E_Protected_Type
5961 ("a protected operation cannot be given a different convention",
5965 -- For Intrinsic, a subprogram is required
5967 if C = Convention_Intrinsic
5968 and then not Is_Subprogram (E)
5969 and then not Is_Generic_Subprogram (E)
5972 ("second argument of pragma% must be a subprogram", Arg2);
5975 -- Deal with non-subprogram cases
5977 if not Is_Subprogram (E)
5978 and then not Is_Generic_Subprogram (E)
5980 Set_Convention_From_Pragma (E);
5983 Check_First_Subtype (Arg2);
5984 Set_Convention_From_Pragma (Base_Type (E));
5986 -- For access subprograms, we must set the convention on the
5987 -- internally generated directly designated type as well.
5989 if Ekind (E) = E_Access_Subprogram_Type then
5990 Set_Convention_From_Pragma (Directly_Designated_Type (E));
5994 -- For the subprogram case, set proper convention for all homonyms
5995 -- in same scope and the same declarative part, i.e. the same
5996 -- compilation unit.
5999 Comp_Unit := Get_Source_Unit (E);
6000 Set_Convention_From_Pragma (E);
6002 -- Treat a pragma Import as an implicit body, and pragma import
6003 -- as implicit reference (for navigation in GPS).
6005 if Prag_Id = Pragma_Import then
6006 Generate_Reference (E, Id, 'b');
6008 -- For exported entities we restrict the generation of references
6009 -- to entities exported to foreign languages since entities
6010 -- exported to Ada do not provide further information to GPS and
6011 -- add undesired references to the output of the gnatxref tool.
6013 elsif Prag_Id = Pragma_Export
6014 and then Convention (E) /= Convention_Ada
6016 Generate_Reference (E, Id, 'i');
6019 -- If the pragma comes from from an aspect, it only applies to the
6020 -- given entity, not its homonyms.
6022 if From_Aspect_Specification (N) then
6026 -- Otherwise Loop through the homonyms of the pragma argument's
6027 -- entity, an apply convention to those in the current scope.
6033 exit when No (E1) or else Scope (E1) /= Current_Scope;
6035 -- Ignore entry for which convention is already set
6037 if Has_Convention_Pragma (E1) then
6041 -- Do not set the pragma on inherited operations or on formal
6044 if Comes_From_Source (E1)
6045 and then Comp_Unit = Get_Source_Unit (E1)
6046 and then not Is_Formal_Subprogram (E1)
6047 and then Nkind (Original_Node (Parent (E1))) /=
6048 N_Full_Type_Declaration
6050 if Present (Alias (E1))
6051 and then Scope (E1) /= Scope (Alias (E1))
6054 ("cannot apply pragma% to non-local entity& declared#",
6058 Set_Convention_From_Pragma (E1);
6060 if Prag_Id = Pragma_Import then
6061 Generate_Reference (E1, Id, 'b');
6069 end Process_Convention;
6071 ----------------------------------------
6072 -- Process_Disable_Enable_Atomic_Sync --
6073 ----------------------------------------
6075 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
6077 Check_No_Identifiers;
6078 Check_At_Most_N_Arguments (1);
6080 -- Modeled internally as
6081 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
6085 Pragma_Identifier =>
6086 Make_Identifier (Loc, Nam),
6087 Pragma_Argument_Associations => New_List (
6088 Make_Pragma_Argument_Association (Loc,
6090 Make_Identifier (Loc, Name_Atomic_Synchronization)))));
6092 if Present (Arg1) then
6093 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
6097 end Process_Disable_Enable_Atomic_Sync;
6099 -----------------------------------------------------
6100 -- Process_Extended_Import_Export_Exception_Pragma --
6101 -----------------------------------------------------
6103 procedure Process_Extended_Import_Export_Exception_Pragma
6104 (Arg_Internal : Node_Id;
6105 Arg_External : Node_Id;
6113 if not OpenVMS_On_Target then
6115 ("??pragma% ignored (applies only to Open'V'M'S)");
6118 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
6119 Def_Id := Entity (Arg_Internal);
6121 if Ekind (Def_Id) /= E_Exception then
6123 ("pragma% must refer to declared exception", Arg_Internal);
6126 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
6128 if Present (Arg_Form) then
6129 Check_Arg_Is_One_Of (Arg_Form, Name_Ada, Name_VMS);
6132 if Present (Arg_Form)
6133 and then Chars (Arg_Form) = Name_Ada
6137 Set_Is_VMS_Exception (Def_Id);
6138 Set_Exception_Code (Def_Id, No_Uint);
6141 if Present (Arg_Code) then
6142 if not Is_VMS_Exception (Def_Id) then
6144 ("Code option for pragma% not allowed for Ada case",
6148 Check_Arg_Is_Static_Expression (Arg_Code, Any_Integer);
6149 Code_Val := Expr_Value (Arg_Code);
6151 if not UI_Is_In_Int_Range (Code_Val) then
6153 ("Code option for pragma% must be in 32-bit range",
6157 Set_Exception_Code (Def_Id, Code_Val);
6160 end Process_Extended_Import_Export_Exception_Pragma;
6162 -------------------------------------------------
6163 -- Process_Extended_Import_Export_Internal_Arg --
6164 -------------------------------------------------
6166 procedure Process_Extended_Import_Export_Internal_Arg
6167 (Arg_Internal : Node_Id := Empty)
6170 if No (Arg_Internal) then
6171 Error_Pragma ("Internal parameter required for pragma%");
6174 if Nkind (Arg_Internal) = N_Identifier then
6177 elsif Nkind (Arg_Internal) = N_Operator_Symbol
6178 and then (Prag_Id = Pragma_Import_Function
6180 Prag_Id = Pragma_Export_Function)
6186 ("wrong form for Internal parameter for pragma%", Arg_Internal);
6189 Check_Arg_Is_Local_Name (Arg_Internal);
6190 end Process_Extended_Import_Export_Internal_Arg;
6192 --------------------------------------------------
6193 -- Process_Extended_Import_Export_Object_Pragma --
6194 --------------------------------------------------
6196 procedure Process_Extended_Import_Export_Object_Pragma
6197 (Arg_Internal : Node_Id;
6198 Arg_External : Node_Id;
6204 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
6205 Def_Id := Entity (Arg_Internal);
6207 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
6209 ("pragma% must designate an object", Arg_Internal);
6212 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
6214 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
6217 ("previous Common/Psect_Object applies, pragma % not permitted",
6221 if Rep_Item_Too_Late (Def_Id, N) then
6225 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
6227 if Present (Arg_Size) then
6228 Check_Arg_Is_External_Name (Arg_Size);
6231 -- Export_Object case
6233 if Prag_Id = Pragma_Export_Object then
6234 if not Is_Library_Level_Entity (Def_Id) then
6236 ("argument for pragma% must be library level entity",
6240 if Ekind (Current_Scope) = E_Generic_Package then
6241 Error_Pragma ("pragma& cannot appear in a generic unit");
6244 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
6246 ("exported object must have compile time known size",
6250 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
6251 Error_Msg_N ("??duplicate Export_Object pragma", N);
6253 Set_Exported (Def_Id, Arg_Internal);
6256 -- Import_Object case
6259 if Is_Concurrent_Type (Etype (Def_Id)) then
6261 ("cannot use pragma% for task/protected object",
6265 if Ekind (Def_Id) = E_Constant then
6267 ("cannot import a constant", Arg_Internal);
6270 if Warn_On_Export_Import
6271 and then Has_Discriminants (Etype (Def_Id))
6274 ("imported value must be initialized??", Arg_Internal);
6277 if Warn_On_Export_Import
6278 and then Is_Access_Type (Etype (Def_Id))
6281 ("cannot import object of an access type??", Arg_Internal);
6284 if Warn_On_Export_Import
6285 and then Is_Imported (Def_Id)
6287 Error_Msg_N ("??duplicate Import_Object pragma", N);
6289 -- Check for explicit initialization present. Note that an
6290 -- initialization generated by the code generator, e.g. for an
6291 -- access type, does not count here.
6293 elsif Present (Expression (Parent (Def_Id)))
6296 (Original_Node (Expression (Parent (Def_Id))))
6298 Error_Msg_Sloc := Sloc (Def_Id);
6300 ("imported entities cannot be initialized (RM B.1(24))",
6301 "\no initialization allowed for & declared#", Arg1);
6303 Set_Imported (Def_Id);
6304 Note_Possible_Modification (Arg_Internal, Sure => False);
6307 end Process_Extended_Import_Export_Object_Pragma;
6309 ------------------------------------------------------
6310 -- Process_Extended_Import_Export_Subprogram_Pragma --
6311 ------------------------------------------------------
6313 procedure Process_Extended_Import_Export_Subprogram_Pragma
6314 (Arg_Internal : Node_Id;
6315 Arg_External : Node_Id;
6316 Arg_Parameter_Types : Node_Id;
6317 Arg_Result_Type : Node_Id := Empty;
6318 Arg_Mechanism : Node_Id;
6319 Arg_Result_Mechanism : Node_Id := Empty;
6320 Arg_First_Optional_Parameter : Node_Id := Empty)
6326 Ambiguous : Boolean;
6330 function Same_Base_Type
6332 Formal : Entity_Id) return Boolean;
6333 -- Determines if Ptype references the type of Formal. Note that only
6334 -- the base types need to match according to the spec. Ptype here is
6335 -- the argument from the pragma, which is either a type name, or an
6336 -- access attribute.
6338 --------------------
6339 -- Same_Base_Type --
6340 --------------------
6342 function Same_Base_Type
6344 Formal : Entity_Id) return Boolean
6346 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
6350 -- Case where pragma argument is typ'Access
6352 if Nkind (Ptype) = N_Attribute_Reference
6353 and then Attribute_Name (Ptype) = Name_Access
6355 Pref := Prefix (Ptype);
6358 if not Is_Entity_Name (Pref)
6359 or else Entity (Pref) = Any_Type
6364 -- We have a match if the corresponding argument is of an
6365 -- anonymous access type, and its designated type matches the
6366 -- type of the prefix of the access attribute
6368 return Ekind (Ftyp) = E_Anonymous_Access_Type
6369 and then Base_Type (Entity (Pref)) =
6370 Base_Type (Etype (Designated_Type (Ftyp)));
6372 -- Case where pragma argument is a type name
6377 if not Is_Entity_Name (Ptype)
6378 or else Entity (Ptype) = Any_Type
6383 -- We have a match if the corresponding argument is of the type
6384 -- given in the pragma (comparing base types)
6386 return Base_Type (Entity (Ptype)) = Ftyp;
6390 -- Start of processing for
6391 -- Process_Extended_Import_Export_Subprogram_Pragma
6394 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
6398 -- Loop through homonyms (overloadings) of the entity
6400 Hom_Id := Entity (Arg_Internal);
6401 while Present (Hom_Id) loop
6402 Def_Id := Get_Base_Subprogram (Hom_Id);
6404 -- We need a subprogram in the current scope
6406 if not Is_Subprogram (Def_Id)
6407 or else Scope (Def_Id) /= Current_Scope
6414 -- Pragma cannot apply to subprogram body
6416 if Is_Subprogram (Def_Id)
6417 and then Nkind (Parent (Declaration_Node (Def_Id))) =
6421 ("pragma% requires separate spec"
6422 & " and must come before body");
6425 -- Test result type if given, note that the result type
6426 -- parameter can only be present for the function cases.
6428 if Present (Arg_Result_Type)
6429 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
6433 elsif Etype (Def_Id) /= Standard_Void_Type
6435 Nam_In (Pname, Name_Export_Procedure, Name_Import_Procedure)
6439 -- Test parameter types if given. Note that this parameter
6440 -- has not been analyzed (and must not be, since it is
6441 -- semantic nonsense), so we get it as the parser left it.
6443 elsif Present (Arg_Parameter_Types) then
6444 Check_Matching_Types : declare
6449 Formal := First_Formal (Def_Id);
6451 if Nkind (Arg_Parameter_Types) = N_Null then
6452 if Present (Formal) then
6456 -- A list of one type, e.g. (List) is parsed as
6457 -- a parenthesized expression.
6459 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
6460 and then Paren_Count (Arg_Parameter_Types) = 1
6463 or else Present (Next_Formal (Formal))
6468 Same_Base_Type (Arg_Parameter_Types, Formal);
6471 -- A list of more than one type is parsed as a aggregate
6473 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
6474 and then Paren_Count (Arg_Parameter_Types) = 0
6476 Ptype := First (Expressions (Arg_Parameter_Types));
6477 while Present (Ptype) or else Present (Formal) loop
6480 or else not Same_Base_Type (Ptype, Formal)
6485 Next_Formal (Formal);
6490 -- Anything else is of the wrong form
6494 ("wrong form for Parameter_Types parameter",
6495 Arg_Parameter_Types);
6497 end Check_Matching_Types;
6500 -- Match is now False if the entry we found did not match
6501 -- either a supplied Parameter_Types or Result_Types argument
6507 -- Ambiguous case, the flag Ambiguous shows if we already
6508 -- detected this and output the initial messages.
6511 if not Ambiguous then
6513 Error_Msg_Name_1 := Pname;
6515 ("pragma% does not uniquely identify subprogram!",
6517 Error_Msg_Sloc := Sloc (Ent);
6518 Error_Msg_N ("matching subprogram #!", N);
6522 Error_Msg_Sloc := Sloc (Def_Id);
6523 Error_Msg_N ("matching subprogram #!", N);
6528 Hom_Id := Homonym (Hom_Id);
6531 -- See if we found an entry
6534 if not Ambiguous then
6535 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
6537 ("pragma% cannot be given for generic subprogram");
6540 ("pragma% does not identify local subprogram");
6547 -- Import pragmas must be for imported entities
6549 if Prag_Id = Pragma_Import_Function
6551 Prag_Id = Pragma_Import_Procedure
6553 Prag_Id = Pragma_Import_Valued_Procedure
6555 if not Is_Imported (Ent) then
6557 ("pragma Import or Interface must precede pragma%");
6560 -- Here we have the Export case which can set the entity as exported
6562 -- But does not do so if the specified external name is null, since
6563 -- that is taken as a signal in DEC Ada 83 (with which we want to be
6564 -- compatible) to request no external name.
6566 elsif Nkind (Arg_External) = N_String_Literal
6567 and then String_Length (Strval (Arg_External)) = 0
6571 -- In all other cases, set entity as exported
6574 Set_Exported (Ent, Arg_Internal);
6577 -- Special processing for Valued_Procedure cases
6579 if Prag_Id = Pragma_Import_Valued_Procedure
6581 Prag_Id = Pragma_Export_Valued_Procedure
6583 Formal := First_Formal (Ent);
6586 Error_Pragma ("at least one parameter required for pragma%");
6588 elsif Ekind (Formal) /= E_Out_Parameter then
6589 Error_Pragma ("first parameter must have mode out for pragma%");
6592 Set_Is_Valued_Procedure (Ent);
6596 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
6598 -- Process Result_Mechanism argument if present. We have already
6599 -- checked that this is only allowed for the function case.
6601 if Present (Arg_Result_Mechanism) then
6602 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
6605 -- Process Mechanism parameter if present. Note that this parameter
6606 -- is not analyzed, and must not be analyzed since it is semantic
6607 -- nonsense, so we get it in exactly as the parser left it.
6609 if Present (Arg_Mechanism) then
6617 -- A single mechanism association without a formal parameter
6618 -- name is parsed as a parenthesized expression. All other
6619 -- cases are parsed as aggregates, so we rewrite the single
6620 -- parameter case as an aggregate for consistency.
6622 if Nkind (Arg_Mechanism) /= N_Aggregate
6623 and then Paren_Count (Arg_Mechanism) = 1
6625 Rewrite (Arg_Mechanism,
6626 Make_Aggregate (Sloc (Arg_Mechanism),
6627 Expressions => New_List (
6628 Relocate_Node (Arg_Mechanism))));
6631 -- Case of only mechanism name given, applies to all formals
6633 if Nkind (Arg_Mechanism) /= N_Aggregate then
6634 Formal := First_Formal (Ent);
6635 while Present (Formal) loop
6636 Set_Mechanism_Value (Formal, Arg_Mechanism);
6637 Next_Formal (Formal);
6640 -- Case of list of mechanism associations given
6643 if Null_Record_Present (Arg_Mechanism) then
6645 ("inappropriate form for Mechanism parameter",
6649 -- Deal with positional ones first
6651 Formal := First_Formal (Ent);
6653 if Present (Expressions (Arg_Mechanism)) then
6654 Mname := First (Expressions (Arg_Mechanism));
6655 while Present (Mname) loop
6658 ("too many mechanism associations", Mname);
6661 Set_Mechanism_Value (Formal, Mname);
6662 Next_Formal (Formal);
6667 -- Deal with named entries
6669 if Present (Component_Associations (Arg_Mechanism)) then
6670 Massoc := First (Component_Associations (Arg_Mechanism));
6671 while Present (Massoc) loop
6672 Choice := First (Choices (Massoc));
6674 if Nkind (Choice) /= N_Identifier
6675 or else Present (Next (Choice))
6678 ("incorrect form for mechanism association",
6682 Formal := First_Formal (Ent);
6686 ("parameter name & not present", Choice);
6689 if Chars (Choice) = Chars (Formal) then
6691 (Formal, Expression (Massoc));
6693 -- Set entity on identifier (needed by ASIS)
6695 Set_Entity (Choice, Formal);
6700 Next_Formal (Formal);
6710 -- Process First_Optional_Parameter argument if present. We have
6711 -- already checked that this is only allowed for the Import case.
6713 if Present (Arg_First_Optional_Parameter) then
6714 if Nkind (Arg_First_Optional_Parameter) /= N_Identifier then
6716 ("first optional parameter must be formal parameter name",
6717 Arg_First_Optional_Parameter);
6720 Formal := First_Formal (Ent);
6724 ("specified formal parameter& not found",
6725 Arg_First_Optional_Parameter);
6728 exit when Chars (Formal) =
6729 Chars (Arg_First_Optional_Parameter);
6731 Next_Formal (Formal);
6734 Set_First_Optional_Parameter (Ent, Formal);
6736 -- Check specified and all remaining formals have right form
6738 while Present (Formal) loop
6739 if Ekind (Formal) /= E_In_Parameter then
6741 ("optional formal& is not of mode in!",
6742 Arg_First_Optional_Parameter, Formal);
6745 Dval := Default_Value (Formal);
6749 ("optional formal& does not have default value!",
6750 Arg_First_Optional_Parameter, Formal);
6752 elsif Compile_Time_Known_Value_Or_Aggr (Dval) then
6757 ("default value for optional formal& is non-static!",
6758 Arg_First_Optional_Parameter, Formal);
6762 Set_Is_Optional_Parameter (Formal);
6763 Next_Formal (Formal);
6766 end Process_Extended_Import_Export_Subprogram_Pragma;
6768 --------------------------
6769 -- Process_Generic_List --
6770 --------------------------
6772 procedure Process_Generic_List is
6777 Check_No_Identifiers;
6778 Check_At_Least_N_Arguments (1);
6780 -- Check all arguments are names of generic units or instances
6783 while Present (Arg) loop
6784 Exp := Get_Pragma_Arg (Arg);
6787 if not Is_Entity_Name (Exp)
6789 (not Is_Generic_Instance (Entity (Exp))
6791 not Is_Generic_Unit (Entity (Exp)))
6794 ("pragma% argument must be name of generic unit/instance",
6800 end Process_Generic_List;
6802 ------------------------------------
6803 -- Process_Import_Predefined_Type --
6804 ------------------------------------
6806 procedure Process_Import_Predefined_Type is
6807 Loc : constant Source_Ptr := Sloc (N);
6809 Ftyp : Node_Id := Empty;
6815 String_To_Name_Buffer (Strval (Expression (Arg3)));
6818 Elmt := First_Elmt (Predefined_Float_Types);
6819 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
6823 Ftyp := Node (Elmt);
6825 if Present (Ftyp) then
6827 -- Don't build a derived type declaration, because predefined C
6828 -- types have no declaration anywhere, so cannot really be named.
6829 -- Instead build a full type declaration, starting with an
6830 -- appropriate type definition is built
6832 if Is_Floating_Point_Type (Ftyp) then
6833 Def := Make_Floating_Point_Definition (Loc,
6834 Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
6835 Make_Real_Range_Specification (Loc,
6836 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
6837 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
6839 -- Should never have a predefined type we cannot handle
6842 raise Program_Error;
6845 -- Build and insert a Full_Type_Declaration, which will be
6846 -- analyzed as soon as this list entry has been analyzed.
6848 Decl := Make_Full_Type_Declaration (Loc,
6849 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
6850 Type_Definition => Def);
6852 Insert_After (N, Decl);
6853 Mark_Rewrite_Insertion (Decl);
6856 Error_Pragma_Arg ("no matching type found for pragma%",
6859 end Process_Import_Predefined_Type;
6861 ---------------------------------
6862 -- Process_Import_Or_Interface --
6863 ---------------------------------
6865 procedure Process_Import_Or_Interface is
6871 Process_Convention (C, Def_Id);
6872 Kill_Size_Check_Code (Def_Id);
6873 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
6875 if Ekind_In (Def_Id, E_Variable, E_Constant) then
6877 -- We do not permit Import to apply to a renaming declaration
6879 if Present (Renamed_Object (Def_Id)) then
6881 ("pragma% not allowed for object renaming", Arg2);
6883 -- User initialization is not allowed for imported object, but
6884 -- the object declaration may contain a default initialization,
6885 -- that will be discarded. Note that an explicit initialization
6886 -- only counts if it comes from source, otherwise it is simply
6887 -- the code generator making an implicit initialization explicit.
6889 elsif Present (Expression (Parent (Def_Id)))
6890 and then Comes_From_Source (Expression (Parent (Def_Id)))
6892 Error_Msg_Sloc := Sloc (Def_Id);
6894 ("no initialization allowed for declaration of& #",
6895 "\imported entities cannot be initialized (RM B.1(24))",
6899 Set_Imported (Def_Id);
6900 Process_Interface_Name (Def_Id, Arg3, Arg4);
6902 -- Note that we do not set Is_Public here. That's because we
6903 -- only want to set it if there is no address clause, and we
6904 -- don't know that yet, so we delay that processing till
6907 -- pragma Import completes deferred constants
6909 if Ekind (Def_Id) = E_Constant then
6910 Set_Has_Completion (Def_Id);
6913 -- It is not possible to import a constant of an unconstrained
6914 -- array type (e.g. string) because there is no simple way to
6915 -- write a meaningful subtype for it.
6917 if Is_Array_Type (Etype (Def_Id))
6918 and then not Is_Constrained (Etype (Def_Id))
6921 ("imported constant& must have a constrained subtype",
6926 elsif Is_Subprogram (Def_Id)
6927 or else Is_Generic_Subprogram (Def_Id)
6929 -- If the name is overloaded, pragma applies to all of the denoted
6930 -- entities in the same declarative part, unless the pragma comes
6931 -- from an aspect specification.
6934 while Present (Hom_Id) loop
6936 Def_Id := Get_Base_Subprogram (Hom_Id);
6938 -- Ignore inherited subprograms because the pragma will apply
6939 -- to the parent operation, which is the one called.
6941 if Is_Overloadable (Def_Id)
6942 and then Present (Alias (Def_Id))
6946 -- If it is not a subprogram, it must be in an outer scope and
6947 -- pragma does not apply.
6949 elsif not Is_Subprogram (Def_Id)
6950 and then not Is_Generic_Subprogram (Def_Id)
6954 -- The pragma does not apply to primitives of interfaces
6956 elsif Is_Dispatching_Operation (Def_Id)
6957 and then Present (Find_Dispatching_Type (Def_Id))
6958 and then Is_Interface (Find_Dispatching_Type (Def_Id))
6962 -- Verify that the homonym is in the same declarative part (not
6963 -- just the same scope). If the pragma comes from an aspect
6964 -- specification we know that it is part of the declaration.
6966 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
6967 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
6968 and then not From_Aspect_Specification (N)
6973 Set_Imported (Def_Id);
6975 -- Reject an Import applied to an abstract subprogram
6977 if Is_Subprogram (Def_Id)
6978 and then Is_Abstract_Subprogram (Def_Id)
6980 Error_Msg_Sloc := Sloc (Def_Id);
6982 ("cannot import abstract subprogram& declared#",
6986 -- Special processing for Convention_Intrinsic
6988 if C = Convention_Intrinsic then
6990 -- Link_Name argument not allowed for intrinsic
6994 Set_Is_Intrinsic_Subprogram (Def_Id);
6996 -- If no external name is present, then check that this
6997 -- is a valid intrinsic subprogram. If an external name
6998 -- is present, then this is handled by the back end.
7001 Check_Intrinsic_Subprogram
7002 (Def_Id, Get_Pragma_Arg (Arg2));
7006 -- All interfaced procedures need an external symbol created
7007 -- for them since they are always referenced from another
7010 Set_Is_Public (Def_Id);
7012 -- Verify that the subprogram does not have a completion
7013 -- through a renaming declaration. For other completions the
7014 -- pragma appears as a too late representation.
7017 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
7021 and then Nkind (Decl) = N_Subprogram_Declaration
7022 and then Present (Corresponding_Body (Decl))
7023 and then Nkind (Unit_Declaration_Node
7024 (Corresponding_Body (Decl))) =
7025 N_Subprogram_Renaming_Declaration
7027 Error_Msg_Sloc := Sloc (Def_Id);
7029 ("cannot import&, renaming already provided for "
7030 & "declaration #", N, Def_Id);
7034 Set_Has_Completion (Def_Id);
7035 Process_Interface_Name (Def_Id, Arg3, Arg4);
7038 if Is_Compilation_Unit (Hom_Id) then
7040 -- Its possible homonyms are not affected by the pragma.
7041 -- Such homonyms might be present in the context of other
7042 -- units being compiled.
7046 elsif From_Aspect_Specification (N) then
7050 Hom_Id := Homonym (Hom_Id);
7054 -- When the convention is Java or CIL, we also allow Import to
7055 -- be given for packages, generic packages, exceptions, record
7056 -- components, and access to subprograms.
7058 elsif (C = Convention_Java or else C = Convention_CIL)
7060 (Is_Package_Or_Generic_Package (Def_Id)
7061 or else Ekind (Def_Id) = E_Exception
7062 or else Ekind (Def_Id) = E_Access_Subprogram_Type
7063 or else Nkind (Parent (Def_Id)) = N_Component_Declaration)
7065 Set_Imported (Def_Id);
7066 Set_Is_Public (Def_Id);
7067 Process_Interface_Name (Def_Id, Arg3, Arg4);
7069 -- Import a CPP class
7071 elsif C = Convention_CPP
7072 and then (Is_Record_Type (Def_Id)
7073 or else Ekind (Def_Id) = E_Incomplete_Type)
7075 if Ekind (Def_Id) = E_Incomplete_Type then
7076 if Present (Full_View (Def_Id)) then
7077 Def_Id := Full_View (Def_Id);
7081 ("cannot import 'C'P'P type before full declaration seen",
7082 Get_Pragma_Arg (Arg2));
7084 -- Although we have reported the error we decorate it as
7085 -- CPP_Class to avoid reporting spurious errors
7087 Set_Is_CPP_Class (Def_Id);
7092 -- Types treated as CPP classes must be declared limited (note:
7093 -- this used to be a warning but there is no real benefit to it
7094 -- since we did effectively intend to treat the type as limited
7097 if not Is_Limited_Type (Def_Id) then
7099 ("imported 'C'P'P type must be limited",
7100 Get_Pragma_Arg (Arg2));
7103 if Etype (Def_Id) /= Def_Id
7104 and then not Is_CPP_Class (Root_Type (Def_Id))
7106 Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
7109 Set_Is_CPP_Class (Def_Id);
7111 -- Imported CPP types must not have discriminants (because C++
7112 -- classes do not have discriminants).
7114 if Has_Discriminants (Def_Id) then
7116 ("imported 'C'P'P type cannot have discriminants",
7117 First (Discriminant_Specifications
7118 (Declaration_Node (Def_Id))));
7121 -- Check that components of imported CPP types do not have default
7122 -- expressions. For private types this check is performed when the
7123 -- full view is analyzed (see Process_Full_View).
7125 if not Is_Private_Type (Def_Id) then
7126 Check_CPP_Type_Has_No_Defaults (Def_Id);
7129 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
7131 Check_Arg_Count (3);
7132 Check_Arg_Is_Static_Expression (Arg3, Standard_String);
7134 Process_Import_Predefined_Type;
7138 ("second argument of pragma% must be object, subprogram "
7139 & "or incomplete type",
7143 -- If this pragma applies to a compilation unit, then the unit, which
7144 -- is a subprogram, does not require (or allow) a body. We also do
7145 -- not need to elaborate imported procedures.
7147 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
7149 Cunit : constant Node_Id := Parent (Parent (N));
7151 Set_Body_Required (Cunit, False);
7154 end Process_Import_Or_Interface;
7156 --------------------
7157 -- Process_Inline --
7158 --------------------
7160 procedure Process_Inline (Status : Inline_Status) is
7167 Effective : Boolean := False;
7168 -- Set True if inline has some effect, i.e. if there is at least one
7169 -- subprogram set as inlined as a result of the use of the pragma.
7171 procedure Make_Inline (Subp : Entity_Id);
7172 -- Subp is the defining unit name of the subprogram declaration. Set
7173 -- the flag, as well as the flag in the corresponding body, if there
7176 procedure Set_Inline_Flags (Subp : Entity_Id);
7177 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
7178 -- Has_Pragma_Inline_Always for the Inline_Always case.
7180 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
7181 -- Returns True if it can be determined at this stage that inlining
7182 -- is not possible, for example if the body is available and contains
7183 -- exception handlers, we prevent inlining, since otherwise we can
7184 -- get undefined symbols at link time. This function also emits a
7185 -- warning if front-end inlining is enabled and the pragma appears
7188 -- ??? is business with link symbols still valid, or does it relate
7189 -- to front end ZCX which is being phased out ???
7191 ---------------------------
7192 -- Inlining_Not_Possible --
7193 ---------------------------
7195 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
7196 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
7200 if Nkind (Decl) = N_Subprogram_Body then
7201 Stats := Handled_Statement_Sequence (Decl);
7202 return Present (Exception_Handlers (Stats))
7203 or else Present (At_End_Proc (Stats));
7205 elsif Nkind (Decl) = N_Subprogram_Declaration
7206 and then Present (Corresponding_Body (Decl))
7208 if Front_End_Inlining
7209 and then Analyzed (Corresponding_Body (Decl))
7211 Error_Msg_N ("pragma appears too late, ignored??", N);
7214 -- If the subprogram is a renaming as body, the body is just a
7215 -- call to the renamed subprogram, and inlining is trivially
7219 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
7220 N_Subprogram_Renaming_Declaration
7226 Handled_Statement_Sequence
7227 (Unit_Declaration_Node (Corresponding_Body (Decl)));
7230 Present (Exception_Handlers (Stats))
7231 or else Present (At_End_Proc (Stats));
7235 -- If body is not available, assume the best, the check is
7236 -- performed again when compiling enclosing package bodies.
7240 end Inlining_Not_Possible;
7246 procedure Make_Inline (Subp : Entity_Id) is
7247 Kind : constant Entity_Kind := Ekind (Subp);
7248 Inner_Subp : Entity_Id := Subp;
7251 -- Ignore if bad type, avoid cascaded error
7253 if Etype (Subp) = Any_Type then
7257 -- Ignore if all inlining is suppressed
7259 elsif Suppress_All_Inlining then
7263 -- If inlining is not possible, for now do not treat as an error
7265 elsif Status /= Suppressed
7266 and then Inlining_Not_Possible (Subp)
7271 -- Here we have a candidate for inlining, but we must exclude
7272 -- derived operations. Otherwise we would end up trying to inline
7273 -- a phantom declaration, and the result would be to drag in a
7274 -- body which has no direct inlining associated with it. That
7275 -- would not only be inefficient but would also result in the
7276 -- backend doing cross-unit inlining in cases where it was
7277 -- definitely inappropriate to do so.
7279 -- However, a simple Comes_From_Source test is insufficient, since
7280 -- we do want to allow inlining of generic instances which also do
7281 -- not come from source. We also need to recognize specs generated
7282 -- by the front-end for bodies that carry the pragma. Finally,
7283 -- predefined operators do not come from source but are not
7284 -- inlineable either.
7286 elsif Is_Generic_Instance (Subp)
7287 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
7291 elsif not Comes_From_Source (Subp)
7292 and then Scope (Subp) /= Standard_Standard
7298 -- The referenced entity must either be the enclosing entity, or
7299 -- an entity declared within the current open scope.
7301 if Present (Scope (Subp))
7302 and then Scope (Subp) /= Current_Scope
7303 and then Subp /= Current_Scope
7306 ("argument of% must be entity in current scope", Assoc);
7310 -- Processing for procedure, operator or function. If subprogram
7311 -- is aliased (as for an instance) indicate that the renamed
7312 -- entity (if declared in the same unit) is inlined.
7314 if Is_Subprogram (Subp) then
7315 Inner_Subp := Ultimate_Alias (Inner_Subp);
7317 if In_Same_Source_Unit (Subp, Inner_Subp) then
7318 Set_Inline_Flags (Inner_Subp);
7320 Decl := Parent (Parent (Inner_Subp));
7322 if Nkind (Decl) = N_Subprogram_Declaration
7323 and then Present (Corresponding_Body (Decl))
7325 Set_Inline_Flags (Corresponding_Body (Decl));
7327 elsif Is_Generic_Instance (Subp) then
7329 -- Indicate that the body needs to be created for
7330 -- inlining subsequent calls. The instantiation node
7331 -- follows the declaration of the wrapper package
7334 if Scope (Subp) /= Standard_Standard
7336 Need_Subprogram_Instance_Body
7337 (Next (Unit_Declaration_Node (Scope (Alias (Subp)))),
7343 -- Inline is a program unit pragma (RM 10.1.5) and cannot
7344 -- appear in a formal part to apply to a formal subprogram.
7345 -- Do not apply check within an instance or a formal package
7346 -- the test will have been applied to the original generic.
7348 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
7349 and then List_Containing (Decl) = List_Containing (N)
7350 and then not In_Instance
7353 ("Inline cannot apply to a formal subprogram", N);
7355 -- If Subp is a renaming, it is the renamed entity that
7356 -- will appear in any call, and be inlined. However, for
7357 -- ASIS uses it is convenient to indicate that the renaming
7358 -- itself is an inlined subprogram, so that some gnatcheck
7359 -- rules can be applied in the absence of expansion.
7361 elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then
7362 Set_Inline_Flags (Subp);
7368 -- For a generic subprogram set flag as well, for use at the point
7369 -- of instantiation, to determine whether the body should be
7372 elsif Is_Generic_Subprogram (Subp) then
7373 Set_Inline_Flags (Subp);
7376 -- Literals are by definition inlined
7378 elsif Kind = E_Enumeration_Literal then
7381 -- Anything else is an error
7385 ("expect subprogram name for pragma%", Assoc);
7389 ----------------------
7390 -- Set_Inline_Flags --
7391 ----------------------
7393 procedure Set_Inline_Flags (Subp : Entity_Id) is
7395 -- First set the Has_Pragma_XXX flags and issue the appropriate
7396 -- errors and warnings for suspicious combinations.
7398 if Prag_Id = Pragma_No_Inline then
7399 if Has_Pragma_Inline_Always (Subp) then
7401 ("Inline_Always and No_Inline are mutually exclusive", N);
7402 elsif Has_Pragma_Inline (Subp) then
7404 ("Inline and No_Inline both specified for& ??",
7405 N, Entity (Subp_Id));
7408 Set_Has_Pragma_No_Inline (Subp);
7410 if Prag_Id = Pragma_Inline_Always then
7411 if Has_Pragma_No_Inline (Subp) then
7413 ("Inline_Always and No_Inline are mutually exclusive",
7417 Set_Has_Pragma_Inline_Always (Subp);
7419 if Has_Pragma_No_Inline (Subp) then
7421 ("Inline and No_Inline both specified for& ??",
7422 N, Entity (Subp_Id));
7426 if not Has_Pragma_Inline (Subp) then
7427 Set_Has_Pragma_Inline (Subp);
7432 -- Then adjust the Is_Inlined flag. It can never be set if the
7433 -- subprogram is subject to pragma No_Inline.
7437 Set_Is_Inlined (Subp, False);
7441 if not Has_Pragma_No_Inline (Subp) then
7442 Set_Is_Inlined (Subp, True);
7445 end Set_Inline_Flags;
7447 -- Start of processing for Process_Inline
7450 Check_No_Identifiers;
7451 Check_At_Least_N_Arguments (1);
7453 if Status = Enabled then
7454 Inline_Processing_Required := True;
7458 while Present (Assoc) loop
7459 Subp_Id := Get_Pragma_Arg (Assoc);
7463 if Is_Entity_Name (Subp_Id) then
7464 Subp := Entity (Subp_Id);
7466 if Subp = Any_Id then
7468 -- If previous error, avoid cascaded errors
7470 Check_Error_Detected;
7477 -- For the pragma case, climb homonym chain. This is
7478 -- what implements allowing the pragma in the renaming
7479 -- case, with the result applying to the ancestors, and
7480 -- also allows Inline to apply to all previous homonyms.
7482 if not From_Aspect_Specification (N) then
7483 while Present (Homonym (Subp))
7484 and then Scope (Homonym (Subp)) = Current_Scope
7486 Make_Inline (Homonym (Subp));
7487 Subp := Homonym (Subp);
7495 ("inappropriate argument for pragma%", Assoc);
7498 and then Warn_On_Redundant_Constructs
7499 and then not (Status = Suppressed or else Suppress_All_Inlining)
7501 if Inlining_Not_Possible (Subp) then
7503 ("pragma Inline for& is ignored?r?",
7504 N, Entity (Subp_Id));
7507 ("pragma Inline for& is redundant?r?",
7508 N, Entity (Subp_Id));
7516 ----------------------------
7517 -- Process_Interface_Name --
7518 ----------------------------
7520 procedure Process_Interface_Name
7521 (Subprogram_Def : Entity_Id;
7527 String_Val : String_Id;
7529 procedure Check_Form_Of_Interface_Name
7531 Ext_Name_Case : Boolean);
7532 -- SN is a string literal node for an interface name. This routine
7533 -- performs some minimal checks that the name is reasonable. In
7534 -- particular that no spaces or other obviously incorrect characters
7535 -- appear. This is only a warning, since any characters are allowed.
7536 -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
7538 ----------------------------------
7539 -- Check_Form_Of_Interface_Name --
7540 ----------------------------------
7542 procedure Check_Form_Of_Interface_Name
7544 Ext_Name_Case : Boolean)
7546 S : constant String_Id := Strval (Expr_Value_S (SN));
7547 SL : constant Nat := String_Length (S);
7552 Error_Msg_N ("interface name cannot be null string", SN);
7555 for J in 1 .. SL loop
7556 C := Get_String_Char (S, J);
7558 -- Look for dubious character and issue unconditional warning.
7559 -- Definitely dubious if not in character range.
7561 if not In_Character_Range (C)
7563 -- For all cases except CLI target,
7564 -- commas, spaces and slashes are dubious (in CLI, we use
7565 -- commas and backslashes in external names to specify
7566 -- assembly version and public key, while slashes and spaces
7567 -- can be used in names to mark nested classes and
7570 or else ((not Ext_Name_Case or else VM_Target /= CLI_Target)
7571 and then (Get_Character (C) = ','
7573 Get_Character (C) = '\'))
7574 or else (VM_Target /= CLI_Target
7575 and then (Get_Character (C) = ' '
7577 Get_Character (C) = '/'))
7580 ("??interface name contains illegal character",
7581 Sloc (SN) + Source_Ptr (J));
7584 end Check_Form_Of_Interface_Name;
7586 -- Start of processing for Process_Interface_Name
7589 if No (Link_Arg) then
7590 if No (Ext_Arg) then
7591 if VM_Target = CLI_Target
7592 and then Ekind (Subprogram_Def) = E_Package
7593 and then Nkind (Parent (Subprogram_Def)) =
7594 N_Package_Specification
7595 and then Present (Generic_Parent (Parent (Subprogram_Def)))
7600 (Generic_Parent (Parent (Subprogram_Def))));
7605 elsif Chars (Ext_Arg) = Name_Link_Name then
7607 Link_Nam := Expression (Ext_Arg);
7610 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
7611 Ext_Nam := Expression (Ext_Arg);
7616 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
7617 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
7618 Ext_Nam := Expression (Ext_Arg);
7619 Link_Nam := Expression (Link_Arg);
7622 -- Check expressions for external name and link name are static
7624 if Present (Ext_Nam) then
7625 Check_Arg_Is_Static_Expression (Ext_Nam, Standard_String);
7626 Check_Form_Of_Interface_Name (Ext_Nam, Ext_Name_Case => True);
7628 -- Verify that external name is not the name of a local entity,
7629 -- which would hide the imported one and could lead to run-time
7630 -- surprises. The problem can only arise for entities declared in
7631 -- a package body (otherwise the external name is fully qualified
7632 -- and will not conflict).
7640 if Prag_Id = Pragma_Import then
7641 String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam)));
7643 E := Entity_Id (Get_Name_Table_Info (Nam));
7645 if Nam /= Chars (Subprogram_Def)
7646 and then Present (E)
7647 and then not Is_Overloadable (E)
7648 and then Is_Immediately_Visible (E)
7649 and then not Is_Imported (E)
7650 and then Ekind (Scope (E)) = E_Package
7653 while Present (Par) loop
7654 if Nkind (Par) = N_Package_Body then
7655 Error_Msg_Sloc := Sloc (E);
7657 ("imported entity is hidden by & declared#",
7662 Par := Parent (Par);
7669 if Present (Link_Nam) then
7670 Check_Arg_Is_Static_Expression (Link_Nam, Standard_String);
7671 Check_Form_Of_Interface_Name (Link_Nam, Ext_Name_Case => False);
7674 -- If there is no link name, just set the external name
7676 if No (Link_Nam) then
7677 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
7679 -- For the Link_Name case, the given literal is preceded by an
7680 -- asterisk, which indicates to GCC that the given name should be
7681 -- taken literally, and in particular that no prepending of
7682 -- underlines should occur, even in systems where this is the
7688 if VM_Target = No_VM then
7689 Store_String_Char (Get_Char_Code ('*'));
7692 String_Val := Strval (Expr_Value_S (Link_Nam));
7693 Store_String_Chars (String_Val);
7695 Make_String_Literal (Sloc (Link_Nam),
7696 Strval => End_String);
7699 -- Set the interface name. If the entity is a generic instance, use
7700 -- its alias, which is the callable entity.
7702 if Is_Generic_Instance (Subprogram_Def) then
7703 Set_Encoded_Interface_Name
7704 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
7706 Set_Encoded_Interface_Name
7707 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
7710 -- We allow duplicated export names in CIL/Java, as they are always
7711 -- enclosed in a namespace that differentiates them, and overloaded
7712 -- entities are supported by the VM.
7714 if Convention (Subprogram_Def) /= Convention_CIL
7716 Convention (Subprogram_Def) /= Convention_Java
7718 Check_Duplicated_Export_Name (Link_Nam);
7720 end Process_Interface_Name;
7722 -----------------------------------------
7723 -- Process_Interrupt_Or_Attach_Handler --
7724 -----------------------------------------
7726 procedure Process_Interrupt_Or_Attach_Handler is
7727 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
7728 Handler_Proc : constant Entity_Id := Entity (Arg1_X);
7729 Proc_Scope : constant Entity_Id := Scope (Handler_Proc);
7732 Set_Is_Interrupt_Handler (Handler_Proc);
7734 -- If the pragma is not associated with a handler procedure within a
7735 -- protected type, then it must be for a nonprotected procedure for
7736 -- the AAMP target, in which case we don't associate a representation
7737 -- item with the procedure's scope.
7739 if Ekind (Proc_Scope) = E_Protected_Type then
7740 if Prag_Id = Pragma_Interrupt_Handler
7742 Prag_Id = Pragma_Attach_Handler
7744 Record_Rep_Item (Proc_Scope, N);
7747 end Process_Interrupt_Or_Attach_Handler;
7749 --------------------------------------------------
7750 -- Process_Restrictions_Or_Restriction_Warnings --
7751 --------------------------------------------------
7753 -- Note: some of the simple identifier cases were handled in par-prag,
7754 -- but it is harmless (and more straightforward) to simply handle all
7755 -- cases here, even if it means we repeat a bit of work in some cases.
7757 procedure Process_Restrictions_Or_Restriction_Warnings
7761 R_Id : Restriction_Id;
7767 -- Ignore all Restrictions pragmas in CodePeer mode
7769 if CodePeer_Mode then
7773 Check_Ada_83_Warning;
7774 Check_At_Least_N_Arguments (1);
7775 Check_Valid_Configuration_Pragma;
7778 while Present (Arg) loop
7780 Expr := Get_Pragma_Arg (Arg);
7782 -- Case of no restriction identifier present
7784 if Id = No_Name then
7785 if Nkind (Expr) /= N_Identifier then
7787 ("invalid form for restriction", Arg);
7792 (Process_Restriction_Synonyms (Expr));
7794 if R_Id not in All_Boolean_Restrictions then
7795 Error_Msg_Name_1 := Pname;
7797 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
7799 -- Check for possible misspelling
7801 for J in Restriction_Id loop
7803 Rnm : constant String := Restriction_Id'Image (J);
7806 Name_Buffer (1 .. Rnm'Length) := Rnm;
7807 Name_Len := Rnm'Length;
7808 Set_Casing (All_Lower_Case);
7810 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
7812 (Identifier_Casing (Current_Source_File));
7813 Error_Msg_String (1 .. Rnm'Length) :=
7814 Name_Buffer (1 .. Name_Len);
7815 Error_Msg_Strlen := Rnm'Length;
7816 Error_Msg_N -- CODEFIX
7817 ("\possible misspelling of ""~""",
7818 Get_Pragma_Arg (Arg));
7827 if Implementation_Restriction (R_Id) then
7828 Check_Restriction (No_Implementation_Restrictions, Arg);
7831 -- Special processing for No_Elaboration_Code restriction
7833 if R_Id = No_Elaboration_Code then
7835 -- Restriction is only recognized within a configuration
7836 -- pragma file, or within a unit of the main extended
7837 -- program. Note: the test for Main_Unit is needed to
7838 -- properly include the case of configuration pragma files.
7840 if not (Current_Sem_Unit = Main_Unit
7841 or else In_Extended_Main_Source_Unit (N))
7845 -- Don't allow in a subunit unless already specified in
7848 elsif Nkind (Parent (N)) = N_Compilation_Unit
7849 and then Nkind (Unit (Parent (N))) = N_Subunit
7850 and then not Restriction_Active (No_Elaboration_Code)
7853 ("invalid specification of ""No_Elaboration_Code""",
7856 ("\restriction cannot be specified in a subunit", N);
7858 ("\unless also specified in body or spec", N);
7861 -- If we have a No_Elaboration_Code pragma that we
7862 -- accept, then it needs to be added to the configuration
7863 -- restrcition set so that we get proper application to
7864 -- other units in the main extended source as required.
7867 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
7871 -- If this is a warning, then set the warning unless we already
7872 -- have a real restriction active (we never want a warning to
7873 -- override a real restriction).
7876 if not Restriction_Active (R_Id) then
7877 Set_Restriction (R_Id, N);
7878 Restriction_Warnings (R_Id) := True;
7881 -- If real restriction case, then set it and make sure that the
7882 -- restriction warning flag is off, since a real restriction
7883 -- always overrides a warning.
7886 Set_Restriction (R_Id, N);
7887 Restriction_Warnings (R_Id) := False;
7890 -- Check for obsolescent restrictions in Ada 2005 mode
7893 and then Ada_Version >= Ada_2005
7894 and then (R_Id = No_Asynchronous_Control
7896 R_Id = No_Unchecked_Deallocation
7898 R_Id = No_Unchecked_Conversion)
7900 Check_Restriction (No_Obsolescent_Features, N);
7903 -- A very special case that must be processed here: pragma
7904 -- Restrictions (No_Exceptions) turns off all run-time
7905 -- checking. This is a bit dubious in terms of the formal
7906 -- language definition, but it is what is intended by RM
7907 -- H.4(12). Restriction_Warnings never affects generated code
7908 -- so this is done only in the real restriction case.
7910 -- Atomic_Synchronization is not a real check, so it is not
7911 -- affected by this processing).
7913 if R_Id = No_Exceptions and then not Warn then
7914 for J in Scope_Suppress.Suppress'Range loop
7915 if J /= Atomic_Synchronization then
7916 Scope_Suppress.Suppress (J) := True;
7921 -- Case of No_Dependence => unit-name. Note that the parser
7922 -- already made the necessary entry in the No_Dependence table.
7924 elsif Id = Name_No_Dependence then
7925 if not OK_No_Dependence_Unit_Name (Expr) then
7929 -- Case of No_Specification_Of_Aspect => Identifier.
7931 elsif Id = Name_No_Specification_Of_Aspect then
7936 if Nkind (Expr) /= N_Identifier then
7939 A_Id := Get_Aspect_Id (Chars (Expr));
7942 if A_Id = No_Aspect then
7943 Error_Pragma_Arg ("invalid restriction name", Arg);
7945 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
7949 elsif Id = Name_No_Use_Of_Attribute then
7950 if Nkind (Expr) /= N_Identifier
7951 or else not Is_Attribute_Name (Chars (Expr))
7953 Error_Msg_N ("unknown attribute name?", Expr);
7956 Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
7959 elsif Id = Name_No_Use_Of_Pragma then
7960 if Nkind (Expr) /= N_Identifier
7961 or else not Is_Pragma_Name (Chars (Expr))
7963 Error_Msg_N ("unknown pragma name?", Expr);
7966 Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
7969 -- All other cases of restriction identifier present
7972 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
7973 Analyze_And_Resolve (Expr, Any_Integer);
7975 if R_Id not in All_Parameter_Restrictions then
7977 ("invalid restriction parameter identifier", Arg);
7979 elsif not Is_OK_Static_Expression (Expr) then
7980 Flag_Non_Static_Expr
7981 ("value must be static expression!", Expr);
7984 elsif not Is_Integer_Type (Etype (Expr))
7985 or else Expr_Value (Expr) < 0
7988 ("value must be non-negative integer", Arg);
7991 -- Restriction pragma is active
7993 Val := Expr_Value (Expr);
7995 if not UI_Is_In_Int_Range (Val) then
7997 ("pragma ignored, value too large??", Arg);
8000 -- Warning case. If the real restriction is active, then we
8001 -- ignore the request, since warning never overrides a real
8002 -- restriction. Otherwise we set the proper warning. Note that
8003 -- this circuit sets the warning again if it is already set,
8004 -- which is what we want, since the constant may have changed.
8007 if not Restriction_Active (R_Id) then
8009 (R_Id, N, Integer (UI_To_Int (Val)));
8010 Restriction_Warnings (R_Id) := True;
8013 -- Real restriction case, set restriction and make sure warning
8014 -- flag is off since real restriction always overrides warning.
8017 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
8018 Restriction_Warnings (R_Id) := False;
8024 end Process_Restrictions_Or_Restriction_Warnings;
8026 ---------------------------------
8027 -- Process_Suppress_Unsuppress --
8028 ---------------------------------
8030 -- Note: this procedure makes entries in the check suppress data
8031 -- structures managed by Sem. See spec of package Sem for full
8032 -- details on how we handle recording of check suppression.
8034 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
8039 In_Package_Spec : constant Boolean :=
8040 Is_Package_Or_Generic_Package (Current_Scope)
8041 and then not In_Package_Body (Current_Scope);
8043 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
8044 -- Used to suppress a single check on the given entity
8046 --------------------------------
8047 -- Suppress_Unsuppress_Echeck --
8048 --------------------------------
8050 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
8052 -- Check for error of trying to set atomic synchronization for
8053 -- a non-atomic variable.
8055 if C = Atomic_Synchronization
8056 and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
8059 ("pragma & requires atomic type or variable",
8060 Pragma_Identifier (Original_Node (N)));
8063 Set_Checks_May_Be_Suppressed (E);
8065 if In_Package_Spec then
8066 Push_Global_Suppress_Stack_Entry
8069 Suppress => Suppress_Case);
8071 Push_Local_Suppress_Stack_Entry
8074 Suppress => Suppress_Case);
8077 -- If this is a first subtype, and the base type is distinct,
8078 -- then also set the suppress flags on the base type.
8080 if Is_First_Subtype (E) and then Etype (E) /= E then
8081 Suppress_Unsuppress_Echeck (Etype (E), C);
8083 end Suppress_Unsuppress_Echeck;
8085 -- Start of processing for Process_Suppress_Unsuppress
8088 -- Ignore pragma Suppress/Unsuppress in CodePeer and SPARK modes on
8089 -- user code: we want to generate checks for analysis purposes, as
8090 -- set respectively by -gnatC and -gnatd.F
8092 if (CodePeer_Mode or SPARK_Mode) and then Comes_From_Source (N) then
8096 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
8097 -- declarative part or a package spec (RM 11.5(5)).
8099 if not Is_Configuration_Pragma then
8100 Check_Is_In_Decl_Part_Or_Package_Spec;
8103 Check_At_Least_N_Arguments (1);
8104 Check_At_Most_N_Arguments (2);
8105 Check_No_Identifier (Arg1);
8106 Check_Arg_Is_Identifier (Arg1);
8108 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
8110 if C = No_Check_Id then
8112 ("argument of pragma% is not valid check name", Arg1);
8115 if Arg_Count = 1 then
8117 -- Make an entry in the local scope suppress table. This is the
8118 -- table that directly shows the current value of the scope
8119 -- suppress check for any check id value.
8121 if C = All_Checks then
8123 -- For All_Checks, we set all specific predefined checks with
8124 -- the exception of Elaboration_Check, which is handled
8125 -- specially because of not wanting All_Checks to have the
8126 -- effect of deactivating static elaboration order processing.
8127 -- Atomic_Synchronization is also not affected, since this is
8128 -- not a real check.
8130 for J in Scope_Suppress.Suppress'Range loop
8131 if J /= Elaboration_Check
8133 J /= Atomic_Synchronization
8135 Scope_Suppress.Suppress (J) := Suppress_Case;
8139 -- If not All_Checks, and predefined check, then set appropriate
8140 -- scope entry. Note that we will set Elaboration_Check if this
8141 -- is explicitly specified. Atomic_Synchronization is allowed
8142 -- only if internally generated and entity is atomic.
8144 elsif C in Predefined_Check_Id
8145 and then (not Comes_From_Source (N)
8146 or else C /= Atomic_Synchronization)
8148 Scope_Suppress.Suppress (C) := Suppress_Case;
8151 -- Also make an entry in the Local_Entity_Suppress table
8153 Push_Local_Suppress_Stack_Entry
8156 Suppress => Suppress_Case);
8158 -- Case of two arguments present, where the check is suppressed for
8159 -- a specified entity (given as the second argument of the pragma)
8162 -- This is obsolescent in Ada 2005 mode
8164 if Ada_Version >= Ada_2005 then
8165 Check_Restriction (No_Obsolescent_Features, Arg2);
8168 Check_Optional_Identifier (Arg2, Name_On);
8169 E_Id := Get_Pragma_Arg (Arg2);
8172 if not Is_Entity_Name (E_Id) then
8174 ("second argument of pragma% must be entity name", Arg2);
8183 -- Enforce RM 11.5(7) which requires that for a pragma that
8184 -- appears within a package spec, the named entity must be
8185 -- within the package spec. We allow the package name itself
8186 -- to be mentioned since that makes sense, although it is not
8187 -- strictly allowed by 11.5(7).
8190 and then E /= Current_Scope
8191 and then Scope (E) /= Current_Scope
8194 ("entity in pragma% is not in package spec (RM 11.5(7))",
8198 -- Loop through homonyms. As noted below, in the case of a package
8199 -- spec, only homonyms within the package spec are considered.
8202 Suppress_Unsuppress_Echeck (E, C);
8204 if Is_Generic_Instance (E)
8205 and then Is_Subprogram (E)
8206 and then Present (Alias (E))
8208 Suppress_Unsuppress_Echeck (Alias (E), C);
8211 -- Move to next homonym if not aspect spec case
8213 exit when From_Aspect_Specification (N);
8217 -- If we are within a package specification, the pragma only
8218 -- applies to homonyms in the same scope.
8220 exit when In_Package_Spec
8221 and then Scope (E) /= Current_Scope;
8224 end Process_Suppress_Unsuppress;
8230 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
8232 if Is_Imported (E) then
8234 ("cannot export entity& that was previously imported", Arg);
8236 elsif Present (Address_Clause (E))
8237 and then not Relaxed_RM_Semantics
8240 ("cannot export entity& that has an address clause", Arg);
8243 Set_Is_Exported (E);
8245 -- Generate a reference for entity explicitly, because the
8246 -- identifier may be overloaded and name resolution will not
8249 Generate_Reference (E, Arg);
8251 -- Deal with exporting non-library level entity
8253 if not Is_Library_Level_Entity (E) then
8255 -- Not allowed at all for subprograms
8257 if Is_Subprogram (E) then
8258 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
8260 -- Otherwise set public and statically allocated
8264 Set_Is_Statically_Allocated (E);
8266 -- Warn if the corresponding W flag is set and the pragma comes
8267 -- from source. The latter may not be true e.g. on VMS where we
8268 -- expand export pragmas for exception codes associated with
8269 -- imported or exported exceptions. We do not want to generate
8270 -- a warning for something that the user did not write.
8272 if Warn_On_Export_Import
8273 and then Comes_From_Source (Arg)
8276 ("?x?& has been made static as a result of Export",
8279 ("\?x?this usage is non-standard and non-portable",
8285 if Warn_On_Export_Import and then Is_Type (E) then
8286 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
8289 if Warn_On_Export_Import and Inside_A_Generic then
8291 ("all instances of& will have the same external name?x?",
8296 ----------------------------------------------
8297 -- Set_Extended_Import_Export_External_Name --
8298 ----------------------------------------------
8300 procedure Set_Extended_Import_Export_External_Name
8301 (Internal_Ent : Entity_Id;
8302 Arg_External : Node_Id)
8304 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
8308 if No (Arg_External) then
8312 Check_Arg_Is_External_Name (Arg_External);
8314 if Nkind (Arg_External) = N_String_Literal then
8315 if String_Length (Strval (Arg_External)) = 0 then
8318 New_Name := Adjust_External_Name_Case (Arg_External);
8321 elsif Nkind (Arg_External) = N_Identifier then
8322 New_Name := Get_Default_External_Name (Arg_External);
8324 -- Check_Arg_Is_External_Name should let through only identifiers and
8325 -- string literals or static string expressions (which are folded to
8326 -- string literals).
8329 raise Program_Error;
8332 -- If we already have an external name set (by a prior normal Import
8333 -- or Export pragma), then the external names must match
8335 if Present (Interface_Name (Internal_Ent)) then
8336 Check_Matching_Internal_Names : declare
8337 S1 : constant String_Id := Strval (Old_Name);
8338 S2 : constant String_Id := Strval (New_Name);
8341 pragma No_Return (Mismatch);
8342 -- Called if names do not match
8348 procedure Mismatch is
8350 Error_Msg_Sloc := Sloc (Old_Name);
8352 ("external name does not match that given #",
8356 -- Start of processing for Check_Matching_Internal_Names
8359 if String_Length (S1) /= String_Length (S2) then
8363 for J in 1 .. String_Length (S1) loop
8364 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
8369 end Check_Matching_Internal_Names;
8371 -- Otherwise set the given name
8374 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
8375 Check_Duplicated_Export_Name (New_Name);
8377 end Set_Extended_Import_Export_External_Name;
8383 procedure Set_Imported (E : Entity_Id) is
8385 -- Error message if already imported or exported
8387 if Is_Exported (E) or else Is_Imported (E) then
8389 -- Error if being set Exported twice
8391 if Is_Exported (E) then
8392 Error_Msg_NE ("entity& was previously exported", N, E);
8394 -- Ignore error in CodePeer mode where we treat all imported
8395 -- subprograms as unknown.
8397 elsif CodePeer_Mode then
8400 -- OK if Import/Interface case
8402 elsif Import_Interface_Present (N) then
8405 -- Error if being set Imported twice
8408 Error_Msg_NE ("entity& was previously imported", N, E);
8411 Error_Msg_Name_1 := Pname;
8413 ("\(pragma% applies to all previous entities)", N);
8415 Error_Msg_Sloc := Sloc (E);
8416 Error_Msg_NE ("\import not allowed for& declared#", N, E);
8418 -- Here if not previously imported or exported, OK to import
8421 Set_Is_Imported (E);
8423 -- If the entity is an object that is not at the library level,
8424 -- then it is statically allocated. We do not worry about objects
8425 -- with address clauses in this context since they are not really
8426 -- imported in the linker sense.
8429 and then not Is_Library_Level_Entity (E)
8430 and then No (Address_Clause (E))
8432 Set_Is_Statically_Allocated (E);
8439 -------------------------
8440 -- Set_Mechanism_Value --
8441 -------------------------
8443 -- Note: the mechanism name has not been analyzed (and cannot indeed be
8444 -- analyzed, since it is semantic nonsense), so we get it in the exact
8445 -- form created by the parser.
8447 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
8450 Mech_Name_Id : Name_Id;
8452 procedure Bad_Class;
8453 pragma No_Return (Bad_Class);
8454 -- Signal bad descriptor class name
8456 procedure Bad_Mechanism;
8457 pragma No_Return (Bad_Mechanism);
8458 -- Signal bad mechanism name
8464 procedure Bad_Class is
8466 Error_Pragma_Arg ("unrecognized descriptor class name", Class);
8469 -------------------------
8470 -- Bad_Mechanism_Value --
8471 -------------------------
8473 procedure Bad_Mechanism is
8475 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
8478 -- Start of processing for Set_Mechanism_Value
8481 if Mechanism (Ent) /= Default_Mechanism then
8483 ("mechanism for & has already been set", Mech_Name, Ent);
8486 -- MECHANISM_NAME ::= value | reference | descriptor |
8489 if Nkind (Mech_Name) = N_Identifier then
8490 if Chars (Mech_Name) = Name_Value then
8491 Set_Mechanism (Ent, By_Copy);
8494 elsif Chars (Mech_Name) = Name_Reference then
8495 Set_Mechanism (Ent, By_Reference);
8498 elsif Chars (Mech_Name) = Name_Descriptor then
8499 Check_VMS (Mech_Name);
8501 -- Descriptor => Short_Descriptor if pragma was given
8503 if Short_Descriptors then
8504 Set_Mechanism (Ent, By_Short_Descriptor);
8506 Set_Mechanism (Ent, By_Descriptor);
8511 elsif Chars (Mech_Name) = Name_Short_Descriptor then
8512 Check_VMS (Mech_Name);
8513 Set_Mechanism (Ent, By_Short_Descriptor);
8516 elsif Chars (Mech_Name) = Name_Copy then
8518 ("bad mechanism name, Value assumed", Mech_Name);
8524 -- MECHANISM_NAME ::= descriptor (CLASS_NAME) |
8525 -- short_descriptor (CLASS_NAME)
8526 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
8528 -- Note: this form is parsed as an indexed component
8530 elsif Nkind (Mech_Name) = N_Indexed_Component then
8531 Class := First (Expressions (Mech_Name));
8533 if Nkind (Prefix (Mech_Name)) /= N_Identifier
8535 not Nam_In (Chars (Prefix (Mech_Name)), Name_Descriptor,
8536 Name_Short_Descriptor)
8537 or else Present (Next (Class))
8541 Mech_Name_Id := Chars (Prefix (Mech_Name));
8543 -- Change Descriptor => Short_Descriptor if pragma was given
8545 if Mech_Name_Id = Name_Descriptor
8546 and then Short_Descriptors
8548 Mech_Name_Id := Name_Short_Descriptor;
8552 -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) |
8553 -- short_descriptor (Class => CLASS_NAME)
8554 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
8556 -- Note: this form is parsed as a function call
8558 elsif Nkind (Mech_Name) = N_Function_Call then
8559 Param := First (Parameter_Associations (Mech_Name));
8561 if Nkind (Name (Mech_Name)) /= N_Identifier
8563 not Nam_In (Chars (Name (Mech_Name)), Name_Descriptor,
8564 Name_Short_Descriptor)
8565 or else Present (Next (Param))
8566 or else No (Selector_Name (Param))
8567 or else Chars (Selector_Name (Param)) /= Name_Class
8571 Class := Explicit_Actual_Parameter (Param);
8572 Mech_Name_Id := Chars (Name (Mech_Name));
8579 -- Fall through here with Class set to descriptor class name
8581 Check_VMS (Mech_Name);
8583 if Nkind (Class) /= N_Identifier then
8586 elsif Mech_Name_Id = Name_Descriptor
8587 and then Chars (Class) = Name_UBS
8589 Set_Mechanism (Ent, By_Descriptor_UBS);
8591 elsif Mech_Name_Id = Name_Descriptor
8592 and then Chars (Class) = Name_UBSB
8594 Set_Mechanism (Ent, By_Descriptor_UBSB);
8596 elsif Mech_Name_Id = Name_Descriptor
8597 and then Chars (Class) = Name_UBA
8599 Set_Mechanism (Ent, By_Descriptor_UBA);
8601 elsif Mech_Name_Id = Name_Descriptor
8602 and then Chars (Class) = Name_S
8604 Set_Mechanism (Ent, By_Descriptor_S);
8606 elsif Mech_Name_Id = Name_Descriptor
8607 and then Chars (Class) = Name_SB
8609 Set_Mechanism (Ent, By_Descriptor_SB);
8611 elsif Mech_Name_Id = Name_Descriptor
8612 and then Chars (Class) = Name_A
8614 Set_Mechanism (Ent, By_Descriptor_A);
8616 elsif Mech_Name_Id = Name_Descriptor
8617 and then Chars (Class) = Name_NCA
8619 Set_Mechanism (Ent, By_Descriptor_NCA);
8621 elsif Mech_Name_Id = Name_Short_Descriptor
8622 and then Chars (Class) = Name_UBS
8624 Set_Mechanism (Ent, By_Short_Descriptor_UBS);
8626 elsif Mech_Name_Id = Name_Short_Descriptor
8627 and then Chars (Class) = Name_UBSB
8629 Set_Mechanism (Ent, By_Short_Descriptor_UBSB);
8631 elsif Mech_Name_Id = Name_Short_Descriptor
8632 and then Chars (Class) = Name_UBA
8634 Set_Mechanism (Ent, By_Short_Descriptor_UBA);
8636 elsif Mech_Name_Id = Name_Short_Descriptor
8637 and then Chars (Class) = Name_S
8639 Set_Mechanism (Ent, By_Short_Descriptor_S);
8641 elsif Mech_Name_Id = Name_Short_Descriptor
8642 and then Chars (Class) = Name_SB
8644 Set_Mechanism (Ent, By_Short_Descriptor_SB);
8646 elsif Mech_Name_Id = Name_Short_Descriptor
8647 and then Chars (Class) = Name_A
8649 Set_Mechanism (Ent, By_Short_Descriptor_A);
8651 elsif Mech_Name_Id = Name_Short_Descriptor
8652 and then Chars (Class) = Name_NCA
8654 Set_Mechanism (Ent, By_Short_Descriptor_NCA);
8659 end Set_Mechanism_Value;
8661 --------------------------
8662 -- Set_Rational_Profile --
8663 --------------------------
8665 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
8666 -- and extension to the semantics of renaming declarations.
8668 procedure Set_Rational_Profile is
8670 Implicit_Packing := True;
8671 Overriding_Renamings := True;
8672 Use_VADS_Size := True;
8673 end Set_Rational_Profile;
8675 ---------------------------
8676 -- Set_Ravenscar_Profile --
8677 ---------------------------
8679 -- The tasks to be done here are
8681 -- Set required policies
8683 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
8684 -- pragma Locking_Policy (Ceiling_Locking)
8686 -- Set Detect_Blocking mode
8688 -- Set required restrictions (see System.Rident for detailed list)
8690 -- Set the No_Dependence rules
8691 -- No_Dependence => Ada.Asynchronous_Task_Control
8692 -- No_Dependence => Ada.Calendar
8693 -- No_Dependence => Ada.Execution_Time.Group_Budget
8694 -- No_Dependence => Ada.Execution_Time.Timers
8695 -- No_Dependence => Ada.Task_Attributes
8696 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
8698 procedure Set_Ravenscar_Profile (N : Node_Id) is
8699 Prefix_Entity : Entity_Id;
8700 Selector_Entity : Entity_Id;
8701 Prefix_Node : Node_Id;
8705 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
8707 if Task_Dispatching_Policy /= ' '
8708 and then Task_Dispatching_Policy /= 'F'
8710 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
8711 Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
8713 -- Set the FIFO_Within_Priorities policy, but always preserve
8714 -- System_Location since we like the error message with the run time
8718 Task_Dispatching_Policy := 'F';
8720 if Task_Dispatching_Policy_Sloc /= System_Location then
8721 Task_Dispatching_Policy_Sloc := Loc;
8725 -- pragma Locking_Policy (Ceiling_Locking)
8727 if Locking_Policy /= ' '
8728 and then Locking_Policy /= 'C'
8730 Error_Msg_Sloc := Locking_Policy_Sloc;
8731 Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
8733 -- Set the Ceiling_Locking policy, but preserve System_Location since
8734 -- we like the error message with the run time name.
8737 Locking_Policy := 'C';
8739 if Locking_Policy_Sloc /= System_Location then
8740 Locking_Policy_Sloc := Loc;
8744 -- pragma Detect_Blocking
8746 Detect_Blocking := True;
8748 -- Set the corresponding restrictions
8750 Set_Profile_Restrictions
8751 (Ravenscar, N, Warn => Treat_Restrictions_As_Warnings);
8753 -- Set the No_Dependence restrictions
8755 -- The following No_Dependence restrictions:
8756 -- No_Dependence => Ada.Asynchronous_Task_Control
8757 -- No_Dependence => Ada.Calendar
8758 -- No_Dependence => Ada.Task_Attributes
8759 -- are already set by previous call to Set_Profile_Restrictions.
8761 -- Set the following restrictions which were added to Ada 2005:
8762 -- No_Dependence => Ada.Execution_Time.Group_Budget
8763 -- No_Dependence => Ada.Execution_Time.Timers
8765 if Ada_Version >= Ada_2005 then
8766 Name_Buffer (1 .. 3) := "ada";
8769 Prefix_Entity := Make_Identifier (Loc, Name_Find);
8771 Name_Buffer (1 .. 14) := "execution_time";
8774 Selector_Entity := Make_Identifier (Loc, Name_Find);
8777 Make_Selected_Component
8779 Prefix => Prefix_Entity,
8780 Selector_Name => Selector_Entity);
8782 Name_Buffer (1 .. 13) := "group_budgets";
8785 Selector_Entity := Make_Identifier (Loc, Name_Find);
8788 Make_Selected_Component
8790 Prefix => Prefix_Node,
8791 Selector_Name => Selector_Entity);
8793 Set_Restriction_No_Dependence
8795 Warn => Treat_Restrictions_As_Warnings,
8796 Profile => Ravenscar);
8798 Name_Buffer (1 .. 6) := "timers";
8801 Selector_Entity := Make_Identifier (Loc, Name_Find);
8804 Make_Selected_Component
8806 Prefix => Prefix_Node,
8807 Selector_Name => Selector_Entity);
8809 Set_Restriction_No_Dependence
8811 Warn => Treat_Restrictions_As_Warnings,
8812 Profile => Ravenscar);
8815 -- Set the following restrictions which was added to Ada 2012 (see
8817 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
8819 if Ada_Version >= Ada_2012 then
8820 Name_Buffer (1 .. 6) := "system";
8823 Prefix_Entity := Make_Identifier (Loc, Name_Find);
8825 Name_Buffer (1 .. 15) := "multiprocessors";
8828 Selector_Entity := Make_Identifier (Loc, Name_Find);
8831 Make_Selected_Component
8833 Prefix => Prefix_Entity,
8834 Selector_Name => Selector_Entity);
8836 Name_Buffer (1 .. 19) := "dispatching_domains";
8839 Selector_Entity := Make_Identifier (Loc, Name_Find);
8842 Make_Selected_Component
8844 Prefix => Prefix_Node,
8845 Selector_Name => Selector_Entity);
8847 Set_Restriction_No_Dependence
8849 Warn => Treat_Restrictions_As_Warnings,
8850 Profile => Ravenscar);
8852 end Set_Ravenscar_Profile;
8858 procedure S14_Pragma is
8860 if not Formal_Extensions then
8861 Error_Pragma ("pragma% requires the use of debug switch -gnatd.V");
8865 -- Start of processing for Analyze_Pragma
8868 -- The following code is a defense against recursion. Not clear that
8869 -- this can happen legitimately, but perhaps some error situations
8870 -- can cause it, and we did see this recursion during testing.
8872 if Analyzed (N) then
8875 Set_Analyzed (N, True);
8878 -- Deal with unrecognized pragma
8880 Pname := Pragma_Name (N);
8882 if not Is_Pragma_Name (Pname) then
8883 if Warn_On_Unrecognized_Pragma then
8884 Error_Msg_Name_1 := Pname;
8885 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
8887 for PN in First_Pragma_Name .. Last_Pragma_Name loop
8888 if Is_Bad_Spelling_Of (Pname, PN) then
8889 Error_Msg_Name_1 := PN;
8890 Error_Msg_N -- CODEFIX
8891 ("\?g?possible misspelling of %!", Pragma_Identifier (N));
8900 -- Here to start processing for recognized pragma
8902 Prag_Id := Get_Pragma_Id (Pname);
8903 Pname := Original_Aspect_Name (N);
8905 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
8906 -- is already set, indicating that we have already checked the policy
8907 -- at the right point. This happens for example in the case of a pragma
8908 -- that is derived from an Aspect.
8910 if Is_Ignored (N) or else Is_Checked (N) then
8913 -- For a pragma that is a rewriting of another pragma, copy the
8914 -- Is_Checked/Is_Ignored status from the rewritten pragma.
8916 elsif Is_Rewrite_Substitution (N)
8917 and then Nkind (Original_Node (N)) = N_Pragma
8918 and then Original_Node (N) /= N
8920 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
8921 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
8923 -- Otherwise query the applicable policy at this point
8926 Check_Applicable_Policy (N);
8928 -- If pragma is disabled, rewrite as NULL and skip analysis
8930 if Is_Disabled (N) then
8931 Rewrite (N, Make_Null_Statement (Loc));
8945 if Present (Pragma_Argument_Associations (N)) then
8946 Arg_Count := List_Length (Pragma_Argument_Associations (N));
8947 Arg1 := First (Pragma_Argument_Associations (N));
8949 if Present (Arg1) then
8950 Arg2 := Next (Arg1);
8952 if Present (Arg2) then
8953 Arg3 := Next (Arg2);
8955 if Present (Arg3) then
8956 Arg4 := Next (Arg3);
8962 Check_Restriction_No_Use_Of_Pragma (N);
8964 -- An enumeration type defines the pragmas that are supported by the
8965 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
8966 -- into the corresponding enumeration value for the following case.
8974 -- pragma Abort_Defer;
8976 when Pragma_Abort_Defer =>
8978 Check_Arg_Count (0);
8980 -- The only required semantic processing is to check the
8981 -- placement. This pragma must appear at the start of the
8982 -- statement sequence of a handled sequence of statements.
8984 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
8985 or else N /= First (Statements (Parent (N)))
8990 --------------------
8991 -- Abstract_State --
8992 --------------------
8994 -- pragma Abstract_State (ABSTRACT_STATE_LIST)
8996 -- ABSTRACT_STATE_LIST ::=
8998 -- | STATE_NAME_WITH_OPTIONS
8999 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
9001 -- STATE_NAME_WITH_OPTIONS ::=
9003 -- | (state_NAME with OPTION_LIST)
9005 -- OPTION_LIST ::= OPTION {, OPTION}
9007 -- OPTION ::= SIMPLE_OPTION | NAME_VALUE_OPTION
9009 -- SIMPLE_OPTION ::=
9010 -- External | Non_Volatile | Input_Only | Output_Only
9012 -- NAME_VALUE_OPTION ::= Part_Of => abstract_state_NAME
9014 when Pragma_Abstract_State => Abstract_State : declare
9015 Pack_Id : Entity_Id;
9017 -- Flags used to verify the consistency of states
9019 Non_Null_Seen : Boolean := False;
9020 Null_Seen : Boolean := False;
9022 procedure Analyze_Abstract_State (State : Node_Id);
9023 -- Verify the legality of a single state declaration. Create and
9024 -- decorate a state abstraction entity and introduce it into the
9025 -- visibility chain.
9027 ----------------------------
9028 -- Analyze_Abstract_State --
9029 ----------------------------
9031 procedure Analyze_Abstract_State (State : Node_Id) is
9032 procedure Check_Duplicate_Option
9034 Status : in out Boolean);
9035 -- Flag Status denotes whether a particular option has been
9036 -- seen while processing a state. This routine verifies that
9037 -- Opt is not a duplicate property and sets the flag Status.
9039 ----------------------------
9040 -- Check_Duplicate_Option --
9041 ----------------------------
9043 procedure Check_Duplicate_Option
9045 Status : in out Boolean)
9049 Error_Msg_N ("duplicate state option", Opt);
9053 end Check_Duplicate_Option;
9057 Errors : constant Nat := Serious_Errors_Detected;
9058 Loc : constant Source_Ptr := Sloc (State);
9061 Is_Null : Boolean := False;
9064 Par_State : Node_Id;
9066 -- Flags used to verify the consistency of options
9068 External_Seen : Boolean := False;
9069 Input_Seen : Boolean := False;
9070 Non_Volatile_Seen : Boolean := False;
9071 Output_Seen : Boolean := False;
9072 Part_Of_Seen : Boolean := False;
9074 -- Start of processing for Analyze_Abstract_State
9077 -- A package with a null abstract state is not allowed to
9078 -- declare additional states.
9082 ("package & has null abstract state", State, Pack_Id);
9084 -- Null states appear as internally generated entities
9086 elsif Nkind (State) = N_Null then
9087 Name := New_Internal_Name ('S');
9091 -- Catch a case where a null state appears in a list of
9094 if Non_Null_Seen then
9096 ("package & has non-null abstract state",
9100 -- Simple state declaration
9102 elsif Nkind (State) = N_Identifier then
9103 Name := Chars (State);
9104 Non_Null_Seen := True;
9106 -- State declaration with various options. This construct
9107 -- appears as an extension aggregate in the tree.
9109 elsif Nkind (State) = N_Extension_Aggregate then
9110 if Nkind (Ancestor_Part (State)) = N_Identifier then
9111 Name := Chars (Ancestor_Part (State));
9112 Non_Null_Seen := True;
9115 ("state name must be an identifier",
9116 Ancestor_Part (State));
9119 -- Process options External, Input_Only, Output_Only and
9120 -- Volatile. Ensure that none of them appear more than once.
9122 Opt := First (Expressions (State));
9123 while Present (Opt) loop
9124 if Nkind (Opt) = N_Identifier then
9125 if Chars (Opt) = Name_External then
9126 Check_Duplicate_Option (Opt, External_Seen);
9127 elsif Chars (Opt) = Name_Input_Only then
9128 Check_Duplicate_Option (Opt, Input_Seen);
9129 elsif Chars (Opt) = Name_Output_Only then
9130 Check_Duplicate_Option (Opt, Output_Seen);
9131 elsif Chars (Opt) = Name_Non_Volatile then
9132 Check_Duplicate_Option (Opt, Non_Volatile_Seen);
9134 -- Ensure that the abstract state component of option
9135 -- Part_Of has not been omitted.
9137 elsif Chars (Opt) = Name_Part_Of then
9139 ("option Part_Of requires an abstract state",
9142 Error_Msg_N ("invalid state option", Opt);
9145 Error_Msg_N ("invalid state option", Opt);
9151 -- External may appear on its own or with exactly one option
9152 -- Input_Only or Output_Only, but not both.
9156 and then Output_Seen
9159 ("option External requires exactly one option "
9160 & "Input_Only or Output_Only", State);
9163 -- Either Input_Only or Output_Only require External
9165 if (Input_Seen or Output_Seen)
9166 and then not External_Seen
9169 ("options Input_Only and Output_Only require option "
9170 & "External", State);
9173 -- Option Part_Of appears as a component association
9175 Assoc := First (Component_Associations (State));
9176 while Present (Assoc) loop
9177 Opt := First (Choices (Assoc));
9178 while Present (Opt) loop
9179 if Nkind (Opt) = N_Identifier
9180 and then Chars (Opt) = Name_Part_Of
9182 Check_Duplicate_Option (Opt, Part_Of_Seen);
9184 Error_Msg_N ("invalid state option", Opt);
9190 -- Part_Of must denote a parent state. Ensure that the
9191 -- tree is not malformed by checking the expression of
9192 -- the component association.
9194 Par_State := Expression (Assoc);
9195 pragma Assert (Present (Par_State));
9197 Analyze (Par_State);
9199 -- Part_Of specified a legal state
9201 if Is_Entity_Name (Par_State)
9202 and then Present (Entity (Par_State))
9203 and then Ekind (Entity (Par_State)) = E_Abstract_State
9208 ("option Part_Of must denote an abstract state",
9215 -- Any other attempt to declare a state is erroneous
9218 Error_Msg_N ("malformed abstract state declaration", State);
9221 -- Do not generate a state abstraction entity if it was not
9222 -- properly declared.
9224 if Serious_Errors_Detected > Errors then
9228 -- The generated state abstraction reuses the same characters
9229 -- from the original state declaration. Decorate the entity.
9231 Id := Make_Defining_Identifier (Loc, New_External_Name (Name));
9232 Set_Comes_From_Source (Id, not Is_Null);
9233 Set_Parent (Id, State);
9234 Set_Ekind (Id, E_Abstract_State);
9235 Set_Etype (Id, Standard_Void_Type);
9236 Set_Refined_State (Id, Empty);
9237 Set_Refinement_Constituents (Id, New_Elmt_List);
9239 -- Every non-null state must be nameable and resolvable the
9240 -- same way a constant is.
9243 Push_Scope (Pack_Id);
9248 -- Verify whether the state introduces an illegal hidden state
9249 -- within a package subject to a null abstract state.
9251 if Formal_Extensions then
9252 Check_No_Hidden_State (Id);
9255 -- Associate the state with its related package
9257 if No (Abstract_States (Pack_Id)) then
9258 Set_Abstract_States (Pack_Id, New_Elmt_List);
9261 Append_Elmt (Id, Abstract_States (Pack_Id));
9262 end Analyze_Abstract_State;
9266 Context : constant Node_Id := Parent (Parent (N));
9269 -- Start of processing for Abstract_State
9274 Check_Arg_Count (1);
9276 -- Ensure the proper placement of the pragma. Abstract states must
9277 -- be associated with a package declaration.
9279 if not Nkind_In (Context, N_Generic_Package_Declaration,
9280 N_Package_Declaration)
9286 Pack_Id := Defining_Entity (Context);
9287 Add_Contract_Item (N, Pack_Id);
9289 -- Verify the declaration order of pragmas Abstract_State and
9292 Check_Declaration_Order
9294 Inits => Get_Pragma (Pack_Id, Pragma_Initializes));
9296 State := Expression (Arg1);
9298 -- Multiple abstract states appear as an aggregate
9300 if Nkind (State) = N_Aggregate then
9301 State := First (Expressions (State));
9302 while Present (State) loop
9303 Analyze_Abstract_State (State);
9308 -- Various forms of a single abstract state. Note that these may
9309 -- include malformed state declarations.
9312 Analyze_Abstract_State (State);
9322 -- Note: this pragma also has some specific processing in Par.Prag
9323 -- because we want to set the Ada version mode during parsing.
9325 when Pragma_Ada_83 =>
9327 Check_Arg_Count (0);
9329 -- We really should check unconditionally for proper configuration
9330 -- pragma placement, since we really don't want mixed Ada modes
9331 -- within a single unit, and the GNAT reference manual has always
9332 -- said this was a configuration pragma, but we did not check and
9333 -- are hesitant to add the check now.
9335 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
9336 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
9337 -- or Ada 2012 mode.
9339 if Ada_Version >= Ada_2005 then
9340 Check_Valid_Configuration_Pragma;
9343 -- Now set Ada 83 mode
9345 Ada_Version := Ada_83;
9346 Ada_Version_Explicit := Ada_83;
9347 Ada_Version_Pragma := N;
9355 -- Note: this pragma also has some specific processing in Par.Prag
9356 -- because we want to set the Ada 83 version mode during parsing.
9358 when Pragma_Ada_95 =>
9360 Check_Arg_Count (0);
9362 -- We really should check unconditionally for proper configuration
9363 -- pragma placement, since we really don't want mixed Ada modes
9364 -- within a single unit, and the GNAT reference manual has always
9365 -- said this was a configuration pragma, but we did not check and
9366 -- are hesitant to add the check now.
9368 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
9369 -- or Ada 95, so we must check if we are in Ada 2005 mode.
9371 if Ada_Version >= Ada_2005 then
9372 Check_Valid_Configuration_Pragma;
9375 -- Now set Ada 95 mode
9377 Ada_Version := Ada_95;
9378 Ada_Version_Explicit := Ada_95;
9379 Ada_Version_Pragma := N;
9381 ---------------------
9382 -- Ada_05/Ada_2005 --
9383 ---------------------
9386 -- pragma Ada_05 (LOCAL_NAME);
9389 -- pragma Ada_2005 (LOCAL_NAME):
9391 -- Note: these pragmas also have some specific processing in Par.Prag
9392 -- because we want to set the Ada 2005 version mode during parsing.
9394 when Pragma_Ada_05 | Pragma_Ada_2005 => declare
9400 if Arg_Count = 1 then
9401 Check_Arg_Is_Local_Name (Arg1);
9402 E_Id := Get_Pragma_Arg (Arg1);
9404 if Etype (E_Id) = Any_Type then
9408 Set_Is_Ada_2005_Only (Entity (E_Id));
9409 Record_Rep_Item (Entity (E_Id), N);
9412 Check_Arg_Count (0);
9414 -- For Ada_2005 we unconditionally enforce the documented
9415 -- configuration pragma placement, since we do not want to
9416 -- tolerate mixed modes in a unit involving Ada 2005. That
9417 -- would cause real difficulties for those cases where there
9418 -- are incompatibilities between Ada 95 and Ada 2005.
9420 Check_Valid_Configuration_Pragma;
9422 -- Now set appropriate Ada mode
9424 Ada_Version := Ada_2005;
9425 Ada_Version_Explicit := Ada_2005;
9426 Ada_Version_Pragma := N;
9430 ---------------------
9431 -- Ada_12/Ada_2012 --
9432 ---------------------
9435 -- pragma Ada_12 (LOCAL_NAME);
9438 -- pragma Ada_2012 (LOCAL_NAME):
9440 -- Note: these pragmas also have some specific processing in Par.Prag
9441 -- because we want to set the Ada 2012 version mode during parsing.
9443 when Pragma_Ada_12 | Pragma_Ada_2012 => declare
9449 if Arg_Count = 1 then
9450 Check_Arg_Is_Local_Name (Arg1);
9451 E_Id := Get_Pragma_Arg (Arg1);
9453 if Etype (E_Id) = Any_Type then
9457 Set_Is_Ada_2012_Only (Entity (E_Id));
9458 Record_Rep_Item (Entity (E_Id), N);
9461 Check_Arg_Count (0);
9463 -- For Ada_2012 we unconditionally enforce the documented
9464 -- configuration pragma placement, since we do not want to
9465 -- tolerate mixed modes in a unit involving Ada 2012. That
9466 -- would cause real difficulties for those cases where there
9467 -- are incompatibilities between Ada 95 and Ada 2012. We could
9468 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
9470 Check_Valid_Configuration_Pragma;
9472 -- Now set appropriate Ada mode
9474 Ada_Version := Ada_2012;
9475 Ada_Version_Explicit := Ada_2012;
9476 Ada_Version_Pragma := N;
9480 ----------------------
9481 -- All_Calls_Remote --
9482 ----------------------
9484 -- pragma All_Calls_Remote [(library_package_NAME)];
9486 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
9487 Lib_Entity : Entity_Id;
9490 Check_Ada_83_Warning;
9491 Check_Valid_Library_Unit_Pragma;
9493 if Nkind (N) = N_Null_Statement then
9497 Lib_Entity := Find_Lib_Unit_Name;
9499 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
9501 if Present (Lib_Entity)
9502 and then not Debug_Flag_U
9504 if not Is_Remote_Call_Interface (Lib_Entity) then
9505 Error_Pragma ("pragma% only apply to rci unit");
9507 -- Set flag for entity of the library unit
9510 Set_Has_All_Calls_Remote (Lib_Entity);
9514 end All_Calls_Remote;
9520 -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]);
9521 -- ARG ::= NAME | EXPRESSION
9523 -- The first two arguments are by convention intended to refer to an
9524 -- external tool and a tool-specific function. These arguments are
9527 when Pragma_Annotate => Annotate : declare
9533 Check_At_Least_N_Arguments (1);
9534 Check_Arg_Is_Identifier (Arg1);
9535 Check_No_Identifiers;
9538 -- Second parameter is optional, it is never analyzed
9543 -- Here if we have a second parameter
9546 -- Second parameter must be identifier
9548 Check_Arg_Is_Identifier (Arg2);
9550 -- Process remaining parameters if any
9553 while Present (Arg) loop
9554 Exp := Get_Pragma_Arg (Arg);
9557 if Is_Entity_Name (Exp) then
9560 -- For string literals, we assume Standard_String as the
9561 -- type, unless the string contains wide or wide_wide
9564 elsif Nkind (Exp) = N_String_Literal then
9565 if Has_Wide_Wide_Character (Exp) then
9566 Resolve (Exp, Standard_Wide_Wide_String);
9567 elsif Has_Wide_Character (Exp) then
9568 Resolve (Exp, Standard_Wide_String);
9570 Resolve (Exp, Standard_String);
9573 elsif Is_Overloaded (Exp) then
9575 ("ambiguous argument for pragma%", Exp);
9586 -------------------------------------------------
9587 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
9588 -------------------------------------------------
9591 -- ( [Check => ] Boolean_EXPRESSION
9592 -- [, [Message =>] Static_String_EXPRESSION]);
9594 -- pragma Assert_And_Cut
9595 -- ( [Check => ] Boolean_EXPRESSION
9596 -- [, [Message =>] Static_String_EXPRESSION]);
9599 -- ( [Check => ] Boolean_EXPRESSION
9600 -- [, [Message =>] Static_String_EXPRESSION]);
9602 -- pragma Loop_Invariant
9603 -- ( [Check => ] Boolean_EXPRESSION
9604 -- [, [Message =>] Static_String_EXPRESSION]);
9606 when Pragma_Assert |
9607 Pragma_Assert_And_Cut |
9609 Pragma_Loop_Invariant =>
9615 -- Assert is an Ada 2005 RM-defined pragma
9617 if Prag_Id = Pragma_Assert then
9620 -- The remaining ones are GNAT pragmas
9626 Check_At_Least_N_Arguments (1);
9627 Check_At_Most_N_Arguments (2);
9628 Check_Arg_Order ((Name_Check, Name_Message));
9629 Check_Optional_Identifier (Arg1, Name_Check);
9631 -- Special processing for Loop_Invariant
9633 if Prag_Id = Pragma_Loop_Invariant then
9635 -- Check restricted placement, must be within a loop
9637 Check_Loop_Pragma_Placement;
9639 -- Do preanalyze to deal with embedded Loop_Entry attribute
9641 Preanalyze_Assert_Expression (Expression (Arg1), Any_Boolean);
9644 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
9645 -- a corresponding Check pragma:
9647 -- pragma Check (name, condition [, msg]);
9649 -- Where name is the identifier matching the pragma name. So
9650 -- rewrite pragma in this manner, transfer the message argument
9651 -- if present, and analyze the result
9653 -- Note: When dealing with a semantically analyzed tree, the
9654 -- information that a Check node N corresponds to a source Assert,
9655 -- Assume, or Assert_And_Cut pragma can be retrieved from the
9656 -- pragma kind of Original_Node(N).
9658 Expr := Get_Pragma_Arg (Arg1);
9660 Make_Pragma_Argument_Association (Loc,
9661 Expression => Make_Identifier (Loc, Pname)),
9662 Make_Pragma_Argument_Association (Sloc (Expr),
9663 Expression => Expr));
9665 if Arg_Count > 1 then
9666 Check_Optional_Identifier (Arg2, Name_Message);
9667 Append_To (Newa, New_Copy_Tree (Arg2));
9670 -- Rewrite as Check pragma
9674 Chars => Name_Check,
9675 Pragma_Argument_Associations => Newa));
9679 ----------------------
9680 -- Assertion_Policy --
9681 ----------------------
9683 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
9685 -- The following form is Ada 2012 only, but we allow it in all modes
9687 -- Pragma Assertion_Policy (
9688 -- ASSERTION_KIND => POLICY_IDENTIFIER
9689 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
9691 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
9693 -- RM_ASSERTION_KIND ::= Assert |
9694 -- Static_Predicate |
9695 -- Dynamic_Predicate |
9701 -- Type_Invariant'Class
9703 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
9714 -- Statement_Assertions
9716 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
9717 -- ID_ASSERTION_KIND list contains implementation-defined additions
9718 -- recognized by GNAT. The effect is to control the behavior of
9719 -- identically named aspects and pragmas, depending on the specified
9720 -- policy identifier:
9722 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
9724 -- Note: Check and Ignore are language-defined. Disable is a GNAT
9725 -- implementation defined addition that results in totally ignoring
9726 -- the corresponding assertion. If Disable is specified, then the
9727 -- argument of the assertion is not even analyzed. This is useful
9728 -- when the aspect/pragma argument references entities in a with'ed
9729 -- package that is replaced by a dummy package in the final build.
9731 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
9732 -- and Type_Invariant'Class were recognized by the parser and
9733 -- transformed into references to the special internal identifiers
9734 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
9735 -- processing is required here.
9737 when Pragma_Assertion_Policy => Assertion_Policy : declare
9746 -- This can always appear as a configuration pragma
9748 if Is_Configuration_Pragma then
9751 -- It can also appear in a declarative part or package spec in Ada
9752 -- 2012 mode. We allow this in other modes, but in that case we
9753 -- consider that we have an Ada 2012 pragma on our hands.
9756 Check_Is_In_Decl_Part_Or_Package_Spec;
9760 -- One argument case with no identifier (first form above)
9763 and then (Nkind (Arg1) /= N_Pragma_Argument_Association
9764 or else Chars (Arg1) = No_Name)
9767 (Arg1, Name_Check, Name_Disable, Name_Ignore);
9769 -- Treat one argument Assertion_Policy as equivalent to:
9771 -- pragma Check_Policy (Assertion, policy)
9773 -- So rewrite pragma in that manner and link on to the chain
9774 -- of Check_Policy pragmas, marking the pragma as analyzed.
9776 Policy := Get_Pragma_Arg (Arg1);
9780 Chars => Name_Check_Policy,
9781 Pragma_Argument_Associations => New_List (
9782 Make_Pragma_Argument_Association (Loc,
9783 Expression => Make_Identifier (Loc, Name_Assertion)),
9785 Make_Pragma_Argument_Association (Loc,
9787 Make_Identifier (Sloc (Policy), Chars (Policy))))));
9790 -- Here if we have two or more arguments
9793 Check_At_Least_N_Arguments (1);
9796 -- Loop through arguments
9799 while Present (Arg) loop
9802 -- Kind must be specified
9804 if Nkind (Arg) /= N_Pragma_Argument_Association
9805 or else Chars (Arg) = No_Name
9808 ("missing assertion kind for pragma%", Arg);
9811 -- Check Kind and Policy have allowed forms
9813 Kind := Chars (Arg);
9815 if not Is_Valid_Assertion_Kind (Kind) then
9817 ("invalid assertion kind for pragma%", Arg);
9821 (Arg, Name_Check, Name_Disable, Name_Ignore);
9823 -- We rewrite the Assertion_Policy pragma as a series of
9824 -- Check_Policy pragmas:
9826 -- Check_Policy (Kind, Policy);
9830 Chars => Name_Check_Policy,
9831 Pragma_Argument_Associations => New_List (
9832 Make_Pragma_Argument_Association (LocP,
9833 Expression => Make_Identifier (LocP, Kind)),
9834 Make_Pragma_Argument_Association (LocP,
9835 Expression => Get_Pragma_Arg (Arg)))));
9840 -- Rewrite the Assertion_Policy pragma as null since we have
9841 -- now inserted all the equivalent Check pragmas.
9843 Rewrite (N, Make_Null_Statement (Loc));
9846 end Assertion_Policy;
9848 ------------------------------
9849 -- Assume_No_Invalid_Values --
9850 ------------------------------
9852 -- pragma Assume_No_Invalid_Values (On | Off);
9854 when Pragma_Assume_No_Invalid_Values =>
9856 Check_Valid_Configuration_Pragma;
9857 Check_Arg_Count (1);
9858 Check_No_Identifiers;
9859 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
9861 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
9862 Assume_No_Invalid_Values := True;
9864 Assume_No_Invalid_Values := False;
9867 --------------------------
9868 -- Attribute_Definition --
9869 --------------------------
9871 -- pragma Attribute_Definition
9872 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
9873 -- [Entity =>] LOCAL_NAME,
9874 -- [Expression =>] EXPRESSION | NAME);
9876 when Pragma_Attribute_Definition => Attribute_Definition : declare
9877 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
9882 Check_Arg_Count (3);
9883 Check_Optional_Identifier (Arg1, "attribute");
9884 Check_Optional_Identifier (Arg2, "entity");
9885 Check_Optional_Identifier (Arg3, "expression");
9887 if Nkind (Attribute_Designator) /= N_Identifier then
9888 Error_Msg_N ("attribute name expected", Attribute_Designator);
9892 Check_Arg_Is_Local_Name (Arg2);
9894 -- If the attribute is not recognized, then issue a warning (not
9895 -- an error), and ignore the pragma.
9897 Aname := Chars (Attribute_Designator);
9899 if not Is_Attribute_Name (Aname) then
9900 Bad_Attribute (Attribute_Designator, Aname, Warn => True);
9904 -- Otherwise, rewrite the pragma as an attribute definition clause
9907 Make_Attribute_Definition_Clause (Loc,
9908 Name => Get_Pragma_Arg (Arg2),
9910 Expression => Get_Pragma_Arg (Arg3)));
9912 end Attribute_Definition;
9918 -- pragma AST_Entry (entry_IDENTIFIER);
9920 when Pragma_AST_Entry => AST_Entry : declare
9926 Check_Arg_Count (1);
9927 Check_No_Identifiers;
9928 Check_Arg_Is_Local_Name (Arg1);
9929 Ent := Entity (Get_Pragma_Arg (Arg1));
9931 -- Note: the implementation of the AST_Entry pragma could handle
9932 -- the entry family case fine, but for now we are consistent with
9933 -- the DEC rules, and do not allow the pragma, which of course
9934 -- has the effect of also forbidding the attribute.
9936 if Ekind (Ent) /= E_Entry then
9938 ("pragma% argument must be simple entry name", Arg1);
9940 elsif Is_AST_Entry (Ent) then
9942 ("duplicate % pragma for entry", Arg1);
9944 elsif Has_Homonym (Ent) then
9946 ("pragma% argument cannot specify overloaded entry", Arg1);
9950 FF : constant Entity_Id := First_Formal (Ent);
9953 if Present (FF) then
9954 if Present (Next_Formal (FF)) then
9956 ("entry for pragma% can have only one argument",
9959 elsif Parameter_Mode (FF) /= E_In_Parameter then
9961 ("entry parameter for pragma% must have mode IN",
9967 Set_Is_AST_Entry (Ent);
9975 -- pragma Asynchronous (LOCAL_NAME);
9977 when Pragma_Asynchronous => Asynchronous : declare
9985 procedure Process_Async_Pragma;
9986 -- Common processing for procedure and access-to-procedure case
9988 --------------------------
9989 -- Process_Async_Pragma --
9990 --------------------------
9992 procedure Process_Async_Pragma is
9995 Set_Is_Asynchronous (Nm);
9999 -- The formals should be of mode IN (RM E.4.1(6))
10002 while Present (S) loop
10003 Formal := Defining_Identifier (S);
10005 if Nkind (Formal) = N_Defining_Identifier
10006 and then Ekind (Formal) /= E_In_Parameter
10009 ("pragma% procedure can only have IN parameter",
10016 Set_Is_Asynchronous (Nm);
10017 end Process_Async_Pragma;
10019 -- Start of processing for pragma Asynchronous
10022 Check_Ada_83_Warning;
10023 Check_No_Identifiers;
10024 Check_Arg_Count (1);
10025 Check_Arg_Is_Local_Name (Arg1);
10027 if Debug_Flag_U then
10031 C_Ent := Cunit_Entity (Current_Sem_Unit);
10032 Analyze (Get_Pragma_Arg (Arg1));
10033 Nm := Entity (Get_Pragma_Arg (Arg1));
10035 if not Is_Remote_Call_Interface (C_Ent)
10036 and then not Is_Remote_Types (C_Ent)
10038 -- This pragma should only appear in an RCI or Remote Types
10039 -- unit (RM E.4.1(4)).
10042 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
10045 if Ekind (Nm) = E_Procedure
10046 and then Nkind (Parent (Nm)) = N_Procedure_Specification
10048 if not Is_Remote_Call_Interface (Nm) then
10050 ("pragma% cannot be applied on non-remote procedure",
10054 L := Parameter_Specifications (Parent (Nm));
10055 Process_Async_Pragma;
10058 elsif Ekind (Nm) = E_Function then
10060 ("pragma% cannot be applied to function", Arg1);
10062 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
10063 if Is_Record_Type (Nm) then
10065 -- A record type that is the Equivalent_Type for a remote
10066 -- access-to-subprogram type.
10068 N := Declaration_Node (Corresponding_Remote_Type (Nm));
10071 -- A non-expanded RAS type (distribution is not enabled)
10073 N := Declaration_Node (Nm);
10076 if Nkind (N) = N_Full_Type_Declaration
10077 and then Nkind (Type_Definition (N)) =
10078 N_Access_Procedure_Definition
10080 L := Parameter_Specifications (Type_Definition (N));
10081 Process_Async_Pragma;
10083 if Is_Asynchronous (Nm)
10084 and then Expander_Active
10085 and then Get_PCS_Name /= Name_No_DSA
10087 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
10092 ("pragma% cannot reference access-to-function type",
10096 -- Only other possibility is Access-to-class-wide type
10098 elsif Is_Access_Type (Nm)
10099 and then Is_Class_Wide_Type (Designated_Type (Nm))
10101 Check_First_Subtype (Arg1);
10102 Set_Is_Asynchronous (Nm);
10103 if Expander_Active then
10104 RACW_Type_Is_Asynchronous (Nm);
10108 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
10116 -- pragma Atomic (LOCAL_NAME);
10118 when Pragma_Atomic =>
10119 Process_Atomic_Shared_Volatile;
10121 -----------------------
10122 -- Atomic_Components --
10123 -----------------------
10125 -- pragma Atomic_Components (array_LOCAL_NAME);
10127 -- This processing is shared by Volatile_Components
10129 when Pragma_Atomic_Components |
10130 Pragma_Volatile_Components =>
10132 Atomic_Components : declare
10139 Check_Ada_83_Warning;
10140 Check_No_Identifiers;
10141 Check_Arg_Count (1);
10142 Check_Arg_Is_Local_Name (Arg1);
10143 E_Id := Get_Pragma_Arg (Arg1);
10145 if Etype (E_Id) = Any_Type then
10149 E := Entity (E_Id);
10151 Check_Duplicate_Pragma (E);
10153 if Rep_Item_Too_Early (E, N)
10155 Rep_Item_Too_Late (E, N)
10160 D := Declaration_Node (E);
10163 if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
10165 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
10166 and then Nkind (D) = N_Object_Declaration
10167 and then Nkind (Object_Definition (D)) =
10168 N_Constrained_Array_Definition)
10170 -- The flag is set on the object, or on the base type
10172 if Nkind (D) /= N_Object_Declaration then
10173 E := Base_Type (E);
10176 Set_Has_Volatile_Components (E);
10178 if Prag_Id = Pragma_Atomic_Components then
10179 Set_Has_Atomic_Components (E);
10183 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
10185 end Atomic_Components;
10187 --------------------
10188 -- Attach_Handler --
10189 --------------------
10191 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
10193 when Pragma_Attach_Handler =>
10194 Check_Ada_83_Warning;
10195 Check_No_Identifiers;
10196 Check_Arg_Count (2);
10198 if No_Run_Time_Mode then
10199 Error_Msg_CRT ("Attach_Handler pragma", N);
10201 Check_Interrupt_Or_Attach_Handler;
10203 -- The expression that designates the attribute may depend on a
10204 -- discriminant, and is therefore a per-object expression, to
10205 -- be expanded in the init proc. If expansion is enabled, then
10206 -- perform semantic checks on a copy only.
10208 if Expander_Active then
10210 Temp : constant Node_Id :=
10211 New_Copy_Tree (Get_Pragma_Arg (Arg2));
10213 Set_Parent (Temp, N);
10214 Preanalyze_And_Resolve (Temp, RTE (RE_Interrupt_ID));
10218 Analyze (Get_Pragma_Arg (Arg2));
10219 Resolve (Get_Pragma_Arg (Arg2), RTE (RE_Interrupt_ID));
10222 Process_Interrupt_Or_Attach_Handler;
10225 --------------------
10226 -- C_Pass_By_Copy --
10227 --------------------
10229 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
10231 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
10237 Check_Valid_Configuration_Pragma;
10238 Check_Arg_Count (1);
10239 Check_Optional_Identifier (Arg1, "max_size");
10241 Arg := Get_Pragma_Arg (Arg1);
10242 Check_Arg_Is_Static_Expression (Arg, Any_Integer);
10244 Val := Expr_Value (Arg);
10248 ("maximum size for pragma% must be positive", Arg1);
10250 elsif UI_Is_In_Int_Range (Val) then
10251 Default_C_Record_Mechanism := UI_To_Int (Val);
10253 -- If a giant value is given, Int'Last will do well enough.
10254 -- If sometime someone complains that a record larger than
10255 -- two gigabytes is not copied, we will worry about it then!
10258 Default_C_Record_Mechanism := Mechanism_Type'Last;
10260 end C_Pass_By_Copy;
10266 -- pragma Check ([Name =>] CHECK_KIND,
10267 -- [Check =>] Boolean_EXPRESSION
10268 -- [,[Message =>] String_EXPRESSION]);
10270 -- CHECK_KIND ::= IDENTIFIER |
10273 -- Invariant'Class |
10274 -- Type_Invariant'Class
10276 -- The identifiers Assertions and Statement_Assertions are not
10277 -- allowed, since they have special meaning for Check_Policy.
10279 when Pragma_Check => Check : declare
10287 Check_At_Least_N_Arguments (2);
10288 Check_At_Most_N_Arguments (3);
10289 Check_Optional_Identifier (Arg1, Name_Name);
10290 Check_Optional_Identifier (Arg2, Name_Check);
10292 if Arg_Count = 3 then
10293 Check_Optional_Identifier (Arg3, Name_Message);
10294 Str := Get_Pragma_Arg (Arg3);
10297 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
10298 Check_Arg_Is_Identifier (Arg1);
10299 Cname := Chars (Get_Pragma_Arg (Arg1));
10301 -- Check forbidden name Assertions or Statement_Assertions
10304 when Name_Assertions =>
10306 ("""Assertions"" is not allowed as a check kind "
10307 & "for pragma%", Arg1);
10309 when Name_Statement_Assertions =>
10311 ("""Statement_Assertions"" is not allowed as a check kind "
10312 & "for pragma%", Arg1);
10318 -- Check applicable policy. We skip this if Checked/Ignored status
10319 -- is already set (e.g. in the casse of a pragma from an aspect).
10321 if Is_Checked (N) or else Is_Ignored (N) then
10324 -- For a non-source pragma that is a rewriting of another pragma,
10325 -- copy the Is_Checked/Ignored status from the rewritten pragma.
10327 elsif Is_Rewrite_Substitution (N)
10328 and then Nkind (Original_Node (N)) = N_Pragma
10329 and then Original_Node (N) /= N
10331 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
10332 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
10334 -- Otherwise query the applicable policy at this point
10337 case Check_Kind (Cname) is
10338 when Name_Ignore =>
10339 Set_Is_Ignored (N, True);
10340 Set_Is_Checked (N, False);
10343 Set_Is_Ignored (N, False);
10344 Set_Is_Checked (N, True);
10346 -- For disable, rewrite pragma as null statement and skip
10347 -- rest of the analysis of the pragma.
10349 when Name_Disable =>
10350 Rewrite (N, Make_Null_Statement (Loc));
10354 -- No other possibilities
10357 raise Program_Error;
10361 -- If check kind was not Disable, then continue pragma analysis
10363 Expr := Get_Pragma_Arg (Arg2);
10365 -- Deal with SCO generation
10368 when Name_Predicate |
10371 -- Nothing to do: since checks occur in client units,
10372 -- the SCO for the aspect in the declaration unit is
10373 -- conservatively always enabled.
10379 if Is_Checked (N) and then not Split_PPC (N) then
10381 -- Mark aspect/pragma SCO as enabled
10383 Set_SCO_Pragma_Enabled (Loc);
10387 -- Deal with analyzing the string argument.
10389 if Arg_Count = 3 then
10391 -- If checks are not on we don't want any expansion (since
10392 -- such expansion would not get properly deleted) but
10393 -- we do want to analyze (to get proper references).
10394 -- The Preanalyze_And_Resolve routine does just what we want
10396 if Is_Ignored (N) then
10397 Preanalyze_And_Resolve (Str, Standard_String);
10399 -- Otherwise we need a proper analysis and expansion
10402 Analyze_And_Resolve (Str, Standard_String);
10406 -- Now you might think we could just do the same with the Boolean
10407 -- expression if checks are off (and expansion is on) and then
10408 -- rewrite the check as a null statement. This would work but we
10409 -- would lose the useful warnings about an assertion being bound
10410 -- to fail even if assertions are turned off.
10412 -- So instead we wrap the boolean expression in an if statement
10413 -- that looks like:
10415 -- if False and then condition then
10419 -- The reason we do this rewriting during semantic analysis rather
10420 -- than as part of normal expansion is that we cannot analyze and
10421 -- expand the code for the boolean expression directly, or it may
10422 -- cause insertion of actions that would escape the attempt to
10423 -- suppress the check code.
10425 -- Note that the Sloc for the if statement corresponds to the
10426 -- argument condition, not the pragma itself. The reason for
10427 -- this is that we may generate a warning if the condition is
10428 -- False at compile time, and we do not want to delete this
10429 -- warning when we delete the if statement.
10431 if Expander_Active and Is_Ignored (N) then
10432 Eloc := Sloc (Expr);
10435 Make_If_Statement (Eloc,
10437 Make_And_Then (Eloc,
10438 Left_Opnd => New_Occurrence_Of (Standard_False, Eloc),
10439 Right_Opnd => Expr),
10440 Then_Statements => New_List (
10441 Make_Null_Statement (Eloc))));
10443 In_Assertion_Expr := In_Assertion_Expr + 1;
10445 In_Assertion_Expr := In_Assertion_Expr - 1;
10447 -- Check is active or expansion not active. In these cases we can
10448 -- just go ahead and analyze the boolean with no worries.
10451 In_Assertion_Expr := In_Assertion_Expr + 1;
10452 Analyze_And_Resolve (Expr, Any_Boolean);
10453 In_Assertion_Expr := In_Assertion_Expr - 1;
10457 --------------------------
10458 -- Check_Float_Overflow --
10459 --------------------------
10461 -- pragma Check_Float_Overflow;
10463 when Pragma_Check_Float_Overflow =>
10465 Check_Valid_Configuration_Pragma;
10466 Check_Arg_Count (0);
10467 Check_Float_Overflow := True;
10473 -- pragma Check_Name (check_IDENTIFIER);
10475 when Pragma_Check_Name =>
10477 Check_No_Identifiers;
10478 Check_Valid_Configuration_Pragma;
10479 Check_Arg_Count (1);
10480 Check_Arg_Is_Identifier (Arg1);
10483 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
10486 for J in Check_Names.First .. Check_Names.Last loop
10487 if Check_Names.Table (J) = Nam then
10492 Check_Names.Append (Nam);
10499 -- This is the old style syntax, which is still allowed in all modes:
10501 -- pragma Check_Policy ([Name =>] CHECK_KIND
10502 -- [Policy =>] POLICY_IDENTIFIER);
10504 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
10506 -- CHECK_KIND ::= IDENTIFIER |
10509 -- Type_Invariant'Class |
10512 -- This is the new style syntax, compatible with Assertion_Policy
10513 -- and also allowed in all modes.
10515 -- Pragma Check_Policy (
10516 -- CHECK_KIND => POLICY_IDENTIFIER
10517 -- {, CHECK_KIND => POLICY_IDENTIFIER});
10519 -- Note: the identifiers Name and Policy are not allowed as
10520 -- Check_Kind values. This avoids ambiguities between the old and
10521 -- new form syntax.
10523 when Pragma_Check_Policy => Check_Policy : declare
10528 Check_At_Least_N_Arguments (1);
10530 -- A Check_Policy pragma can appear either as a configuration
10531 -- pragma, or in a declarative part or a package spec (see RM
10532 -- 11.5(5) for rules for Suppress/Unsuppress which are also
10533 -- followed for Check_Policy).
10535 if not Is_Configuration_Pragma then
10536 Check_Is_In_Decl_Part_Or_Package_Spec;
10539 -- Figure out if we have the old or new syntax. We have the
10540 -- old syntax if the first argument has no identifier, or the
10541 -- identifier is Name.
10543 if Nkind (Arg1) /= N_Pragma_Argument_Association
10544 or else Nam_In (Chars (Arg1), No_Name, Name_Name)
10548 Check_Arg_Count (2);
10549 Check_Optional_Identifier (Arg1, Name_Name);
10550 Kind := Get_Pragma_Arg (Arg1);
10551 Rewrite_Assertion_Kind (Kind);
10552 Check_Arg_Is_Identifier (Arg1);
10554 -- Check forbidden check kind
10556 if Nam_In (Chars (Kind), Name_Name, Name_Policy) then
10557 Error_Msg_Name_2 := Chars (Kind);
10559 ("pragma% does not allow% as check name", Arg1);
10564 Check_Optional_Identifier (Arg2, Name_Policy);
10565 Check_Arg_Is_One_Of
10567 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
10569 -- And chain pragma on the Check_Policy_List for search
10571 Set_Next_Pragma (N, Opt.Check_Policy_List);
10572 Opt.Check_Policy_List := N;
10574 -- For the new syntax, what we do is to convert each argument to
10575 -- an old syntax equivalent. We do that because we want to chain
10576 -- old style Check_Policy pragmas for the search (we don't want
10577 -- to have to deal with multiple arguments in the search).
10587 while Present (Arg) loop
10588 LocP := Sloc (Arg);
10589 Argx := Get_Pragma_Arg (Arg);
10591 -- Kind must be specified
10593 if Nkind (Arg) /= N_Pragma_Argument_Association
10594 or else Chars (Arg) = No_Name
10597 ("missing assertion kind for pragma%", Arg);
10600 -- Construct equivalent old form syntax Check_Policy
10601 -- pragma and insert it to get remaining checks.
10605 Chars => Name_Check_Policy,
10606 Pragma_Argument_Associations => New_List (
10607 Make_Pragma_Argument_Association (LocP,
10609 Make_Identifier (LocP, Chars (Arg))),
10610 Make_Pragma_Argument_Association (Sloc (Argx),
10611 Expression => Argx))));
10616 -- Rewrite original Check_Policy pragma to null, since we
10617 -- have converted it into a series of old syntax pragmas.
10619 Rewrite (N, Make_Null_Statement (Loc));
10625 ---------------------
10626 -- CIL_Constructor --
10627 ---------------------
10629 -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
10631 -- Processing for this pragma is shared with Java_Constructor
10637 -- pragma Comment (static_string_EXPRESSION)
10639 -- Processing for pragma Comment shares the circuitry for pragma
10640 -- Ident. The only differences are that Ident enforces a limit of 31
10641 -- characters on its argument, and also enforces limitations on
10642 -- placement for DEC compatibility. Pragma Comment shares neither of
10643 -- these restrictions.
10645 -------------------
10646 -- Common_Object --
10647 -------------------
10649 -- pragma Common_Object (
10650 -- [Internal =>] LOCAL_NAME
10651 -- [, [External =>] EXTERNAL_SYMBOL]
10652 -- [, [Size =>] EXTERNAL_SYMBOL]);
10654 -- Processing for this pragma is shared with Psect_Object
10656 ------------------------
10657 -- Compile_Time_Error --
10658 ------------------------
10660 -- pragma Compile_Time_Error
10661 -- (boolean_EXPRESSION, static_string_EXPRESSION);
10663 when Pragma_Compile_Time_Error =>
10665 Process_Compile_Time_Warning_Or_Error;
10667 --------------------------
10668 -- Compile_Time_Warning --
10669 --------------------------
10671 -- pragma Compile_Time_Warning
10672 -- (boolean_EXPRESSION, static_string_EXPRESSION);
10674 when Pragma_Compile_Time_Warning =>
10676 Process_Compile_Time_Warning_Or_Error;
10678 -------------------
10679 -- Compiler_Unit --
10680 -------------------
10682 when Pragma_Compiler_Unit =>
10684 Check_Arg_Count (0);
10685 Set_Is_Compiler_Unit (Get_Source_Unit (N));
10687 -----------------------------
10688 -- Complete_Representation --
10689 -----------------------------
10691 -- pragma Complete_Representation;
10693 when Pragma_Complete_Representation =>
10695 Check_Arg_Count (0);
10697 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
10699 ("pragma & must appear within record representation clause");
10702 ----------------------------
10703 -- Complex_Representation --
10704 ----------------------------
10706 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
10708 when Pragma_Complex_Representation => Complex_Representation : declare
10715 Check_Arg_Count (1);
10716 Check_Optional_Identifier (Arg1, Name_Entity);
10717 Check_Arg_Is_Local_Name (Arg1);
10718 E_Id := Get_Pragma_Arg (Arg1);
10720 if Etype (E_Id) = Any_Type then
10724 E := Entity (E_Id);
10726 if not Is_Record_Type (E) then
10728 ("argument for pragma% must be record type", Arg1);
10731 Ent := First_Entity (E);
10734 or else No (Next_Entity (Ent))
10735 or else Present (Next_Entity (Next_Entity (Ent)))
10736 or else not Is_Floating_Point_Type (Etype (Ent))
10737 or else Etype (Ent) /= Etype (Next_Entity (Ent))
10740 ("record for pragma% must have two fields of the same "
10741 & "floating-point type", Arg1);
10744 Set_Has_Complex_Representation (Base_Type (E));
10746 -- We need to treat the type has having a non-standard
10747 -- representation, for back-end purposes, even though in
10748 -- general a complex will have the default representation
10749 -- of a record with two real components.
10751 Set_Has_Non_Standard_Rep (Base_Type (E));
10753 end Complex_Representation;
10755 -------------------------
10756 -- Component_Alignment --
10757 -------------------------
10759 -- pragma Component_Alignment (
10760 -- [Form =>] ALIGNMENT_CHOICE
10761 -- [, [Name =>] type_LOCAL_NAME]);
10763 -- ALIGNMENT_CHOICE ::=
10765 -- | Component_Size_4
10769 when Pragma_Component_Alignment => Component_AlignmentP : declare
10770 Args : Args_List (1 .. 2);
10771 Names : constant Name_List (1 .. 2) := (
10775 Form : Node_Id renames Args (1);
10776 Name : Node_Id renames Args (2);
10778 Atype : Component_Alignment_Kind;
10783 Gather_Associations (Names, Args);
10786 Error_Pragma ("missing Form argument for pragma%");
10789 Check_Arg_Is_Identifier (Form);
10791 -- Get proper alignment, note that Default = Component_Size on all
10792 -- machines we have so far, and we want to set this value rather
10793 -- than the default value to indicate that it has been explicitly
10794 -- set (and thus will not get overridden by the default component
10795 -- alignment for the current scope)
10797 if Chars (Form) = Name_Component_Size then
10798 Atype := Calign_Component_Size;
10800 elsif Chars (Form) = Name_Component_Size_4 then
10801 Atype := Calign_Component_Size_4;
10803 elsif Chars (Form) = Name_Default then
10804 Atype := Calign_Component_Size;
10806 elsif Chars (Form) = Name_Storage_Unit then
10807 Atype := Calign_Storage_Unit;
10811 ("invalid Form parameter for pragma%", Form);
10814 -- Case with no name, supplied, affects scope table entry
10818 (Scope_Stack.Last).Component_Alignment_Default := Atype;
10820 -- Case of name supplied
10823 Check_Arg_Is_Local_Name (Name);
10825 Typ := Entity (Name);
10828 or else Rep_Item_Too_Early (Typ, N)
10832 Typ := Underlying_Type (Typ);
10835 if not Is_Record_Type (Typ)
10836 and then not Is_Array_Type (Typ)
10839 ("Name parameter of pragma% must identify record or "
10840 & "array type", Name);
10843 -- An explicit Component_Alignment pragma overrides an
10844 -- implicit pragma Pack, but not an explicit one.
10846 if not Has_Pragma_Pack (Base_Type (Typ)) then
10847 Set_Is_Packed (Base_Type (Typ), False);
10848 Set_Component_Alignment (Base_Type (Typ), Atype);
10851 end Component_AlignmentP;
10853 --------------------
10854 -- Contract_Cases --
10855 --------------------
10857 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
10859 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
10861 -- CASE_GUARD ::= boolean_EXPRESSION | others
10863 -- CONSEQUENCE ::= boolean_EXPRESSION
10865 when Pragma_Contract_Cases => Contract_Cases : declare
10866 Subp_Decl : Node_Id;
10870 Check_Arg_Count (1);
10872 -- Ensure the proper placement of the pragma. Contract_Cases must
10873 -- be associated with a subprogram declaration or a body that acts
10877 Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
10879 if Nkind (Subp_Decl) /= N_Subprogram_Declaration
10880 and then (Nkind (Subp_Decl) /= N_Subprogram_Body
10881 or else not Acts_As_Spec (Subp_Decl))
10887 -- The pragma is analyzed at the end of the declarative part which
10888 -- contains the related subprogram. Reset the analyzed flag.
10890 Set_Analyzed (N, False);
10892 -- When the pragma appears on a subprogram body, perform the full
10895 if Nkind (Subp_Decl) = N_Subprogram_Body then
10896 Analyze_Contract_Cases_In_Decl_Part (N);
10898 -- When Contract_Cases applies to a subprogram compilation unit,
10899 -- the corresponding pragma is placed after the unit's declaration
10900 -- node and needs to be analyzed immediately.
10902 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration
10903 and then Nkind (Parent (Subp_Decl)) = N_Compilation_Unit
10905 Analyze_Contract_Cases_In_Decl_Part (N);
10908 -- Chain the pragma on the contract for further processing
10910 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
10911 end Contract_Cases;
10917 -- pragma Controlled (first_subtype_LOCAL_NAME);
10919 when Pragma_Controlled => Controlled : declare
10923 Check_No_Identifiers;
10924 Check_Arg_Count (1);
10925 Check_Arg_Is_Local_Name (Arg1);
10926 Arg := Get_Pragma_Arg (Arg1);
10928 if not Is_Entity_Name (Arg)
10929 or else not Is_Access_Type (Entity (Arg))
10931 Error_Pragma_Arg ("pragma% requires access type", Arg1);
10933 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
10941 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
10942 -- [Entity =>] LOCAL_NAME);
10944 when Pragma_Convention => Convention : declare
10947 pragma Warnings (Off, C);
10948 pragma Warnings (Off, E);
10950 Check_Arg_Order ((Name_Convention, Name_Entity));
10951 Check_Ada_83_Warning;
10952 Check_Arg_Count (2);
10953 Process_Convention (C, E);
10956 ---------------------------
10957 -- Convention_Identifier --
10958 ---------------------------
10960 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
10961 -- [Convention =>] convention_IDENTIFIER);
10963 when Pragma_Convention_Identifier => Convention_Identifier : declare
10969 Check_Arg_Order ((Name_Name, Name_Convention));
10970 Check_Arg_Count (2);
10971 Check_Optional_Identifier (Arg1, Name_Name);
10972 Check_Optional_Identifier (Arg2, Name_Convention);
10973 Check_Arg_Is_Identifier (Arg1);
10974 Check_Arg_Is_Identifier (Arg2);
10975 Idnam := Chars (Get_Pragma_Arg (Arg1));
10976 Cname := Chars (Get_Pragma_Arg (Arg2));
10978 if Is_Convention_Name (Cname) then
10979 Record_Convention_Identifier
10980 (Idnam, Get_Convention_Id (Cname));
10983 ("second arg for % pragma must be convention", Arg2);
10985 end Convention_Identifier;
10991 -- pragma CPP_Class ([Entity =>] local_NAME)
10993 when Pragma_CPP_Class => CPP_Class : declare
10997 if Warn_On_Obsolescent_Feature then
10999 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
11000 & "effect; replace it by pragma import?j?", N);
11003 Check_Arg_Count (1);
11007 Chars => Name_Import,
11008 Pragma_Argument_Associations => New_List (
11009 Make_Pragma_Argument_Association (Loc,
11010 Expression => Make_Identifier (Loc, Name_CPP)),
11011 New_Copy (First (Pragma_Argument_Associations (N))))));
11015 ---------------------
11016 -- CPP_Constructor --
11017 ---------------------
11019 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
11020 -- [, [External_Name =>] static_string_EXPRESSION ]
11021 -- [, [Link_Name =>] static_string_EXPRESSION ]);
11023 when Pragma_CPP_Constructor => CPP_Constructor : declare
11026 Def_Id : Entity_Id;
11027 Tag_Typ : Entity_Id;
11031 Check_At_Least_N_Arguments (1);
11032 Check_At_Most_N_Arguments (3);
11033 Check_Optional_Identifier (Arg1, Name_Entity);
11034 Check_Arg_Is_Local_Name (Arg1);
11036 Id := Get_Pragma_Arg (Arg1);
11037 Find_Program_Unit_Name (Id);
11039 -- If we did not find the name, we are done
11041 if Etype (Id) = Any_Type then
11045 Def_Id := Entity (Id);
11047 -- Check if already defined as constructor
11049 if Is_Constructor (Def_Id) then
11051 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
11055 if Ekind (Def_Id) = E_Function
11056 and then (Is_CPP_Class (Etype (Def_Id))
11057 or else (Is_Class_Wide_Type (Etype (Def_Id))
11059 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
11061 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
11063 ("'C'P'P constructor must be defined in the scope of "
11064 & "its returned type", Arg1);
11067 if Arg_Count >= 2 then
11068 Set_Imported (Def_Id);
11069 Set_Is_Public (Def_Id);
11070 Process_Interface_Name (Def_Id, Arg2, Arg3);
11073 Set_Has_Completion (Def_Id);
11074 Set_Is_Constructor (Def_Id);
11075 Set_Convention (Def_Id, Convention_CPP);
11077 -- Imported C++ constructors are not dispatching primitives
11078 -- because in C++ they don't have a dispatch table slot.
11079 -- However, in Ada the constructor has the profile of a
11080 -- function that returns a tagged type and therefore it has
11081 -- been treated as a primitive operation during semantic
11082 -- analysis. We now remove it from the list of primitive
11083 -- operations of the type.
11085 if Is_Tagged_Type (Etype (Def_Id))
11086 and then not Is_Class_Wide_Type (Etype (Def_Id))
11087 and then Is_Dispatching_Operation (Def_Id)
11089 Tag_Typ := Etype (Def_Id);
11091 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
11092 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
11096 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
11097 Set_Is_Dispatching_Operation (Def_Id, False);
11100 -- For backward compatibility, if the constructor returns a
11101 -- class wide type, and we internally change the return type to
11102 -- the corresponding root type.
11104 if Is_Class_Wide_Type (Etype (Def_Id)) then
11105 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
11109 ("pragma% requires function returning a 'C'P'P_Class type",
11112 end CPP_Constructor;
11118 when Pragma_CPP_Virtual => CPP_Virtual : declare
11122 if Warn_On_Obsolescent_Feature then
11124 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
11133 when Pragma_CPP_Vtable => CPP_Vtable : declare
11137 if Warn_On_Obsolescent_Feature then
11139 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
11148 -- pragma CPU (EXPRESSION);
11150 when Pragma_CPU => CPU : declare
11151 P : constant Node_Id := Parent (N);
11157 Check_No_Identifiers;
11158 Check_Arg_Count (1);
11162 if Nkind (P) = N_Subprogram_Body then
11163 Check_In_Main_Program;
11165 Arg := Get_Pragma_Arg (Arg1);
11166 Analyze_And_Resolve (Arg, Any_Integer);
11168 Ent := Defining_Unit_Name (Specification (P));
11170 if Nkind (Ent) = N_Defining_Program_Unit_Name then
11171 Ent := Defining_Identifier (Ent);
11176 if not Is_Static_Expression (Arg) then
11177 Flag_Non_Static_Expr
11178 ("main subprogram affinity is not static!", Arg);
11181 -- If constraint error, then we already signalled an error
11183 elsif Raises_Constraint_Error (Arg) then
11186 -- Otherwise check in range
11190 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
11191 -- This is the entity System.Multiprocessors.CPU_Range;
11193 Val : constant Uint := Expr_Value (Arg);
11196 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
11198 Val > Expr_Value (Type_High_Bound (CPU_Id))
11201 ("main subprogram CPU is out of range", Arg1);
11207 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
11211 elsif Nkind (P) = N_Task_Definition then
11212 Arg := Get_Pragma_Arg (Arg1);
11213 Ent := Defining_Identifier (Parent (P));
11215 -- The expression must be analyzed in the special manner
11216 -- described in "Handling of Default and Per-Object
11217 -- Expressions" in sem.ads.
11219 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
11221 -- Anything else is incorrect
11227 -- Check duplicate pragma before we chain the pragma in the Rep
11228 -- Item chain of Ent.
11230 Check_Duplicate_Pragma (Ent);
11231 Record_Rep_Item (Ent, N);
11238 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
11240 when Pragma_Debug => Debug : declare
11247 -- The condition for executing the call is that the expander
11248 -- is active and that we are not ignoring this debug pragma.
11253 (Expander_Active and then not Is_Ignored (N)),
11256 if not Is_Ignored (N) then
11257 Set_SCO_Pragma_Enabled (Loc);
11260 if Arg_Count = 2 then
11262 Make_And_Then (Loc,
11263 Left_Opnd => Relocate_Node (Cond),
11264 Right_Opnd => Get_Pragma_Arg (Arg1));
11265 Call := Get_Pragma_Arg (Arg2);
11267 Call := Get_Pragma_Arg (Arg1);
11271 N_Indexed_Component,
11275 N_Selected_Component)
11277 -- If this pragma Debug comes from source, its argument was
11278 -- parsed as a name form (which is syntactically identical).
11279 -- In a generic context a parameterless call will be left as
11280 -- an expanded name (if global) or selected_component if local.
11281 -- Change it to a procedure call statement now.
11283 Change_Name_To_Procedure_Call_Statement (Call);
11285 elsif Nkind (Call) = N_Procedure_Call_Statement then
11287 -- Already in the form of a procedure call statement: nothing
11288 -- to do (could happen in case of an internally generated
11294 -- All other cases: diagnose error
11297 ("argument of pragma ""Debug"" is not procedure call",
11302 -- Rewrite into a conditional with an appropriate condition. We
11303 -- wrap the procedure call in a block so that overhead from e.g.
11304 -- use of the secondary stack does not generate execution overhead
11305 -- for suppressed conditions.
11307 -- Normally the analysis that follows will freeze the subprogram
11308 -- being called. However, if the call is to a null procedure,
11309 -- we want to freeze it before creating the block, because the
11310 -- analysis that follows may be done with expansion disabled, in
11311 -- which case the body will not be generated, leading to spurious
11314 if Nkind (Call) = N_Procedure_Call_Statement
11315 and then Is_Entity_Name (Name (Call))
11317 Analyze (Name (Call));
11318 Freeze_Before (N, Entity (Name (Call)));
11321 Rewrite (N, Make_Implicit_If_Statement (N,
11323 Then_Statements => New_List (
11324 Make_Block_Statement (Loc,
11325 Handled_Statement_Sequence =>
11326 Make_Handled_Sequence_Of_Statements (Loc,
11327 Statements => New_List (Relocate_Node (Call)))))));
11335 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
11337 when Pragma_Debug_Policy =>
11339 Check_Arg_Count (1);
11340 Check_No_Identifiers;
11341 Check_Arg_Is_Identifier (Arg1);
11343 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
11344 -- rewrite it that way, and let the rest of the checking come
11345 -- from analyzing the rewritten pragma.
11349 Chars => Name_Check_Policy,
11350 Pragma_Argument_Associations => New_List (
11351 Make_Pragma_Argument_Association (Loc,
11352 Expression => Make_Identifier (Loc, Name_Debug)),
11354 Make_Pragma_Argument_Association (Loc,
11355 Expression => Get_Pragma_Arg (Arg1)))));
11362 -- pragma Depends (DEPENDENCY_RELATION);
11364 -- DEPENDENCY_RELATION ::=
11366 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
11368 -- DEPENDENCY_CLAUSE ::=
11369 -- OUTPUT_LIST =>[+] INPUT_LIST
11370 -- | NULL_DEPENDENCY_CLAUSE
11372 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
11374 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
11376 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
11378 -- OUTPUT ::= NAME | FUNCTION_RESULT
11381 -- where FUNCTION_RESULT is a function Result attribute_reference
11383 when Pragma_Depends => Depends : declare
11384 Subp_Decl : Node_Id;
11389 Check_Arg_Count (1);
11391 -- Ensure the proper placement of the pragma. Depends must be
11392 -- associated with a subprogram declaration or a body that acts
11396 Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
11398 if Nkind (Subp_Decl) /= N_Subprogram_Declaration
11399 and then (Nkind (Subp_Decl) /= N_Subprogram_Body
11400 or else not Acts_As_Spec (Subp_Decl))
11406 -- When the pragma appears on a subprogram body, perform the full
11409 if Nkind (Subp_Decl) = N_Subprogram_Body then
11410 Analyze_Depends_In_Decl_Part (N);
11412 -- When Depends applies to a subprogram compilation unit, the
11413 -- corresponding pragma is placed after the unit's declaration
11414 -- node and needs to be analyzed immediately.
11416 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration
11417 and then Nkind (Parent (Subp_Decl)) = N_Compilation_Unit
11419 Analyze_Depends_In_Decl_Part (N);
11422 -- Chain the pragma on the contract for further processing
11424 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
11427 ---------------------
11428 -- Detect_Blocking --
11429 ---------------------
11431 -- pragma Detect_Blocking;
11433 when Pragma_Detect_Blocking =>
11435 Check_Arg_Count (0);
11436 Check_Valid_Configuration_Pragma;
11437 Detect_Blocking := True;
11439 --------------------------
11440 -- Default_Storage_Pool --
11441 --------------------------
11443 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
11445 when Pragma_Default_Storage_Pool =>
11447 Check_Arg_Count (1);
11449 -- Default_Storage_Pool can appear as a configuration pragma, or
11450 -- in a declarative part or a package spec.
11452 if not Is_Configuration_Pragma then
11453 Check_Is_In_Decl_Part_Or_Package_Spec;
11456 -- Case of Default_Storage_Pool (null);
11458 if Nkind (Expression (Arg1)) = N_Null then
11459 Analyze (Expression (Arg1));
11461 -- This is an odd case, this is not really an expression, so
11462 -- we don't have a type for it. So just set the type to Empty.
11464 Set_Etype (Expression (Arg1), Empty);
11466 -- Case of Default_Storage_Pool (storage_pool_NAME);
11469 -- If it's a configuration pragma, then the only allowed
11470 -- argument is "null".
11472 if Is_Configuration_Pragma then
11473 Error_Pragma_Arg ("NULL expected", Arg1);
11476 -- The expected type for a non-"null" argument is
11477 -- Root_Storage_Pool'Class.
11479 Analyze_And_Resolve
11480 (Get_Pragma_Arg (Arg1),
11481 Typ => Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
11484 -- Finally, record the pool name (or null). Freeze.Freeze_Entity
11485 -- for an access type will use this information to set the
11486 -- appropriate attributes of the access type.
11488 Default_Pool := Expression (Arg1);
11490 ------------------------------------
11491 -- Disable_Atomic_Synchronization --
11492 ------------------------------------
11494 -- pragma Disable_Atomic_Synchronization [(Entity)];
11496 when Pragma_Disable_Atomic_Synchronization =>
11498 Process_Disable_Enable_Atomic_Sync (Name_Suppress);
11500 -------------------
11501 -- Discard_Names --
11502 -------------------
11504 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
11506 when Pragma_Discard_Names => Discard_Names : declare
11511 Check_Ada_83_Warning;
11513 -- Deal with configuration pragma case
11515 if Arg_Count = 0 and then Is_Configuration_Pragma then
11516 Global_Discard_Names := True;
11519 -- Otherwise, check correct appropriate context
11522 Check_Is_In_Decl_Part_Or_Package_Spec;
11524 if Arg_Count = 0 then
11526 -- If there is no parameter, then from now on this pragma
11527 -- applies to any enumeration, exception or tagged type
11528 -- defined in the current declarative part, and recursively
11529 -- to any nested scope.
11531 Set_Discard_Names (Current_Scope);
11535 Check_Arg_Count (1);
11536 Check_Optional_Identifier (Arg1, Name_On);
11537 Check_Arg_Is_Local_Name (Arg1);
11539 E_Id := Get_Pragma_Arg (Arg1);
11541 if Etype (E_Id) = Any_Type then
11544 E := Entity (E_Id);
11547 if (Is_First_Subtype (E)
11549 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
11550 or else Ekind (E) = E_Exception
11552 Set_Discard_Names (E);
11553 Record_Rep_Item (E, N);
11557 ("inappropriate entity for pragma%", Arg1);
11564 ------------------------
11565 -- Dispatching_Domain --
11566 ------------------------
11568 -- pragma Dispatching_Domain (EXPRESSION);
11570 when Pragma_Dispatching_Domain => Dispatching_Domain : declare
11571 P : constant Node_Id := Parent (N);
11577 Check_No_Identifiers;
11578 Check_Arg_Count (1);
11580 -- This pragma is born obsolete, but not the aspect
11582 if not From_Aspect_Specification (N) then
11584 (No_Obsolescent_Features, Pragma_Identifier (N));
11587 if Nkind (P) = N_Task_Definition then
11588 Arg := Get_Pragma_Arg (Arg1);
11589 Ent := Defining_Identifier (Parent (P));
11591 -- The expression must be analyzed in the special manner
11592 -- described in "Handling of Default and Per-Object
11593 -- Expressions" in sem.ads.
11595 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
11597 -- Check duplicate pragma before we chain the pragma in the Rep
11598 -- Item chain of Ent.
11600 Check_Duplicate_Pragma (Ent);
11601 Record_Rep_Item (Ent, N);
11603 -- Anything else is incorrect
11608 end Dispatching_Domain;
11614 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
11616 when Pragma_Elaborate => Elaborate : declare
11621 -- Pragma must be in context items list of a compilation unit
11623 if not Is_In_Context_Clause then
11627 -- Must be at least one argument
11629 if Arg_Count = 0 then
11630 Error_Pragma ("pragma% requires at least one argument");
11633 -- In Ada 83 mode, there can be no items following it in the
11634 -- context list except other pragmas and implicit with clauses
11635 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
11636 -- placement rule does not apply.
11638 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
11640 while Present (Citem) loop
11641 if Nkind (Citem) = N_Pragma
11642 or else (Nkind (Citem) = N_With_Clause
11643 and then Implicit_With (Citem))
11648 ("(Ada 83) pragma% must be at end of context clause");
11655 -- Finally, the arguments must all be units mentioned in a with
11656 -- clause in the same context clause. Note we already checked (in
11657 -- Par.Prag) that the arguments are all identifiers or selected
11661 Outer : while Present (Arg) loop
11662 Citem := First (List_Containing (N));
11663 Inner : while Citem /= N loop
11664 if Nkind (Citem) = N_With_Clause
11665 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
11667 Set_Elaborate_Present (Citem, True);
11668 Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
11669 Generate_Reference (Entity (Name (Citem)), Citem);
11671 -- With the pragma present, elaboration calls on
11672 -- subprograms from the named unit need no further
11673 -- checks, as long as the pragma appears in the current
11674 -- compilation unit. If the pragma appears in some unit
11675 -- in the context, there might still be a need for an
11676 -- Elaborate_All_Desirable from the current compilation
11677 -- to the named unit, so we keep the check enabled.
11679 if In_Extended_Main_Source_Unit (N) then
11680 Set_Suppress_Elaboration_Warnings
11681 (Entity (Name (Citem)));
11692 ("argument of pragma% is not withed unit", Arg);
11698 -- Give a warning if operating in static mode with -gnatwl
11699 -- (elaboration warnings enabled) switch set.
11701 if Elab_Warnings and not Dynamic_Elaboration_Checks then
11703 ("?l?use of pragma Elaborate may not be safe", N);
11705 ("?l?use pragma Elaborate_All instead if possible", N);
11709 -------------------
11710 -- Elaborate_All --
11711 -------------------
11713 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
11715 when Pragma_Elaborate_All => Elaborate_All : declare
11720 Check_Ada_83_Warning;
11722 -- Pragma must be in context items list of a compilation unit
11724 if not Is_In_Context_Clause then
11728 -- Must be at least one argument
11730 if Arg_Count = 0 then
11731 Error_Pragma ("pragma% requires at least one argument");
11734 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
11735 -- have to appear at the end of the context clause, but may
11736 -- appear mixed in with other items, even in Ada 83 mode.
11738 -- Final check: the arguments must all be units mentioned in
11739 -- a with clause in the same context clause. Note that we
11740 -- already checked (in Par.Prag) that all the arguments are
11741 -- either identifiers or selected components.
11744 Outr : while Present (Arg) loop
11745 Citem := First (List_Containing (N));
11746 Innr : while Citem /= N loop
11747 if Nkind (Citem) = N_With_Clause
11748 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
11750 Set_Elaborate_All_Present (Citem, True);
11751 Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
11753 -- Suppress warnings and elaboration checks on the named
11754 -- unit if the pragma is in the current compilation, as
11755 -- for pragma Elaborate.
11757 if In_Extended_Main_Source_Unit (N) then
11758 Set_Suppress_Elaboration_Warnings
11759 (Entity (Name (Citem)));
11768 Set_Error_Posted (N);
11770 ("argument of pragma% is not withed unit", Arg);
11777 --------------------
11778 -- Elaborate_Body --
11779 --------------------
11781 -- pragma Elaborate_Body [( library_unit_NAME )];
11783 when Pragma_Elaborate_Body => Elaborate_Body : declare
11784 Cunit_Node : Node_Id;
11785 Cunit_Ent : Entity_Id;
11788 Check_Ada_83_Warning;
11789 Check_Valid_Library_Unit_Pragma;
11791 if Nkind (N) = N_Null_Statement then
11795 Cunit_Node := Cunit (Current_Sem_Unit);
11796 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
11798 if Nkind_In (Unit (Cunit_Node), N_Package_Body,
11801 Error_Pragma ("pragma% must refer to a spec, not a body");
11803 Set_Body_Required (Cunit_Node, True);
11804 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
11806 -- If we are in dynamic elaboration mode, then we suppress
11807 -- elaboration warnings for the unit, since it is definitely
11808 -- fine NOT to do dynamic checks at the first level (and such
11809 -- checks will be suppressed because no elaboration boolean
11810 -- is created for Elaborate_Body packages).
11812 -- But in the static model of elaboration, Elaborate_Body is
11813 -- definitely NOT good enough to ensure elaboration safety on
11814 -- its own, since the body may WITH other units that are not
11815 -- safe from an elaboration point of view, so a client must
11816 -- still do an Elaborate_All on such units.
11818 -- Debug flag -gnatdD restores the old behavior of 3.13, where
11819 -- Elaborate_Body always suppressed elab warnings.
11821 if Dynamic_Elaboration_Checks or Debug_Flag_DD then
11822 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
11825 end Elaborate_Body;
11827 ------------------------
11828 -- Elaboration_Checks --
11829 ------------------------
11831 -- pragma Elaboration_Checks (Static | Dynamic);
11833 when Pragma_Elaboration_Checks =>
11835 Check_Arg_Count (1);
11836 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
11837 Dynamic_Elaboration_Checks :=
11838 (Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic);
11844 -- pragma Eliminate (
11845 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
11846 -- [,[Entity =>] IDENTIFIER |
11847 -- SELECTED_COMPONENT |
11849 -- [, OVERLOADING_RESOLUTION]);
11851 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
11854 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
11855 -- FUNCTION_PROFILE
11857 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
11859 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
11860 -- Result_Type => result_SUBTYPE_NAME]
11862 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
11863 -- SUBTYPE_NAME ::= STRING_LITERAL
11865 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
11866 -- SOURCE_TRACE ::= STRING_LITERAL
11868 when Pragma_Eliminate => Eliminate : declare
11869 Args : Args_List (1 .. 5);
11870 Names : constant Name_List (1 .. 5) := (
11873 Name_Parameter_Types,
11875 Name_Source_Location);
11877 Unit_Name : Node_Id renames Args (1);
11878 Entity : Node_Id renames Args (2);
11879 Parameter_Types : Node_Id renames Args (3);
11880 Result_Type : Node_Id renames Args (4);
11881 Source_Location : Node_Id renames Args (5);
11885 Check_Valid_Configuration_Pragma;
11886 Gather_Associations (Names, Args);
11888 if No (Unit_Name) then
11889 Error_Pragma ("missing Unit_Name argument for pragma%");
11893 and then (Present (Parameter_Types)
11895 Present (Result_Type)
11897 Present (Source_Location))
11899 Error_Pragma ("missing Entity argument for pragma%");
11902 if (Present (Parameter_Types)
11904 Present (Result_Type))
11906 Present (Source_Location)
11909 ("parameter profile and source location cannot be used "
11910 & "together in pragma%");
11913 Process_Eliminate_Pragma
11922 -----------------------------------
11923 -- Enable_Atomic_Synchronization --
11924 -----------------------------------
11926 -- pragma Enable_Atomic_Synchronization [(Entity)];
11928 when Pragma_Enable_Atomic_Synchronization =>
11930 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
11937 -- [ Convention =>] convention_IDENTIFIER,
11938 -- [ Entity =>] local_NAME
11939 -- [, [External_Name =>] static_string_EXPRESSION ]
11940 -- [, [Link_Name =>] static_string_EXPRESSION ]);
11942 when Pragma_Export => Export : declare
11944 Def_Id : Entity_Id;
11946 pragma Warnings (Off, C);
11949 Check_Ada_83_Warning;
11953 Name_External_Name,
11956 Check_At_Least_N_Arguments (2);
11957 Check_At_Most_N_Arguments (4);
11958 Process_Convention (C, Def_Id);
11960 if Ekind (Def_Id) /= E_Constant then
11961 Note_Possible_Modification
11962 (Get_Pragma_Arg (Arg2), Sure => False);
11965 Process_Interface_Name (Def_Id, Arg3, Arg4);
11966 Set_Exported (Def_Id, Arg2);
11968 -- If the entity is a deferred constant, propagate the information
11969 -- to the full view, because gigi elaborates the full view only.
11971 if Ekind (Def_Id) = E_Constant
11972 and then Present (Full_View (Def_Id))
11975 Id2 : constant Entity_Id := Full_View (Def_Id);
11977 Set_Is_Exported (Id2, Is_Exported (Def_Id));
11978 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
11979 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
11984 ----------------------
11985 -- Export_Exception --
11986 ----------------------
11988 -- pragma Export_Exception (
11989 -- [Internal =>] LOCAL_NAME
11990 -- [, [External =>] EXTERNAL_SYMBOL]
11991 -- [, [Form =>] Ada | VMS]
11992 -- [, [Code =>] static_integer_EXPRESSION]);
11994 when Pragma_Export_Exception => Export_Exception : declare
11995 Args : Args_List (1 .. 4);
11996 Names : constant Name_List (1 .. 4) := (
12002 Internal : Node_Id renames Args (1);
12003 External : Node_Id renames Args (2);
12004 Form : Node_Id renames Args (3);
12005 Code : Node_Id renames Args (4);
12010 if Inside_A_Generic then
12011 Error_Pragma ("pragma% cannot be used for generic entities");
12014 Gather_Associations (Names, Args);
12015 Process_Extended_Import_Export_Exception_Pragma (
12016 Arg_Internal => Internal,
12017 Arg_External => External,
12021 if not Is_VMS_Exception (Entity (Internal)) then
12022 Set_Exported (Entity (Internal), Internal);
12024 end Export_Exception;
12026 ---------------------
12027 -- Export_Function --
12028 ---------------------
12030 -- pragma Export_Function (
12031 -- [Internal =>] LOCAL_NAME
12032 -- [, [External =>] EXTERNAL_SYMBOL]
12033 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
12034 -- [, [Result_Type =>] TYPE_DESIGNATOR]
12035 -- [, [Mechanism =>] MECHANISM]
12036 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
12038 -- EXTERNAL_SYMBOL ::=
12040 -- | static_string_EXPRESSION
12042 -- PARAMETER_TYPES ::=
12044 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
12046 -- TYPE_DESIGNATOR ::=
12048 -- | subtype_Name ' Access
12052 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
12054 -- MECHANISM_ASSOCIATION ::=
12055 -- [formal_parameter_NAME =>] MECHANISM_NAME
12057 -- MECHANISM_NAME ::=
12060 -- | Descriptor [([Class =>] CLASS_NAME)]
12062 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
12064 when Pragma_Export_Function => Export_Function : declare
12065 Args : Args_List (1 .. 6);
12066 Names : constant Name_List (1 .. 6) := (
12069 Name_Parameter_Types,
12072 Name_Result_Mechanism);
12074 Internal : Node_Id renames Args (1);
12075 External : Node_Id renames Args (2);
12076 Parameter_Types : Node_Id renames Args (3);
12077 Result_Type : Node_Id renames Args (4);
12078 Mechanism : Node_Id renames Args (5);
12079 Result_Mechanism : Node_Id renames Args (6);
12083 Gather_Associations (Names, Args);
12084 Process_Extended_Import_Export_Subprogram_Pragma (
12085 Arg_Internal => Internal,
12086 Arg_External => External,
12087 Arg_Parameter_Types => Parameter_Types,
12088 Arg_Result_Type => Result_Type,
12089 Arg_Mechanism => Mechanism,
12090 Arg_Result_Mechanism => Result_Mechanism);
12091 end Export_Function;
12093 -------------------
12094 -- Export_Object --
12095 -------------------
12097 -- pragma Export_Object (
12098 -- [Internal =>] LOCAL_NAME
12099 -- [, [External =>] EXTERNAL_SYMBOL]
12100 -- [, [Size =>] EXTERNAL_SYMBOL]);
12102 -- EXTERNAL_SYMBOL ::=
12104 -- | static_string_EXPRESSION
12106 -- PARAMETER_TYPES ::=
12108 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
12110 -- TYPE_DESIGNATOR ::=
12112 -- | subtype_Name ' Access
12116 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
12118 -- MECHANISM_ASSOCIATION ::=
12119 -- [formal_parameter_NAME =>] MECHANISM_NAME
12121 -- MECHANISM_NAME ::=
12124 -- | Descriptor [([Class =>] CLASS_NAME)]
12126 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
12128 when Pragma_Export_Object => Export_Object : declare
12129 Args : Args_List (1 .. 3);
12130 Names : constant Name_List (1 .. 3) := (
12135 Internal : Node_Id renames Args (1);
12136 External : Node_Id renames Args (2);
12137 Size : Node_Id renames Args (3);
12141 Gather_Associations (Names, Args);
12142 Process_Extended_Import_Export_Object_Pragma (
12143 Arg_Internal => Internal,
12144 Arg_External => External,
12148 ----------------------
12149 -- Export_Procedure --
12150 ----------------------
12152 -- pragma Export_Procedure (
12153 -- [Internal =>] LOCAL_NAME
12154 -- [, [External =>] EXTERNAL_SYMBOL]
12155 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
12156 -- [, [Mechanism =>] MECHANISM]);
12158 -- EXTERNAL_SYMBOL ::=
12160 -- | static_string_EXPRESSION
12162 -- PARAMETER_TYPES ::=
12164 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
12166 -- TYPE_DESIGNATOR ::=
12168 -- | subtype_Name ' Access
12172 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
12174 -- MECHANISM_ASSOCIATION ::=
12175 -- [formal_parameter_NAME =>] MECHANISM_NAME
12177 -- MECHANISM_NAME ::=
12180 -- | Descriptor [([Class =>] CLASS_NAME)]
12182 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
12184 when Pragma_Export_Procedure => Export_Procedure : declare
12185 Args : Args_List (1 .. 4);
12186 Names : constant Name_List (1 .. 4) := (
12189 Name_Parameter_Types,
12192 Internal : Node_Id renames Args (1);
12193 External : Node_Id renames Args (2);
12194 Parameter_Types : Node_Id renames Args (3);
12195 Mechanism : Node_Id renames Args (4);
12199 Gather_Associations (Names, Args);
12200 Process_Extended_Import_Export_Subprogram_Pragma (
12201 Arg_Internal => Internal,
12202 Arg_External => External,
12203 Arg_Parameter_Types => Parameter_Types,
12204 Arg_Mechanism => Mechanism);
12205 end Export_Procedure;
12211 -- pragma Export_Value (
12212 -- [Value =>] static_integer_EXPRESSION,
12213 -- [Link_Name =>] static_string_EXPRESSION);
12215 when Pragma_Export_Value =>
12217 Check_Arg_Order ((Name_Value, Name_Link_Name));
12218 Check_Arg_Count (2);
12220 Check_Optional_Identifier (Arg1, Name_Value);
12221 Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
12223 Check_Optional_Identifier (Arg2, Name_Link_Name);
12224 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
12226 -----------------------------
12227 -- Export_Valued_Procedure --
12228 -----------------------------
12230 -- pragma Export_Valued_Procedure (
12231 -- [Internal =>] LOCAL_NAME
12232 -- [, [External =>] EXTERNAL_SYMBOL,]
12233 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
12234 -- [, [Mechanism =>] MECHANISM]);
12236 -- EXTERNAL_SYMBOL ::=
12238 -- | static_string_EXPRESSION
12240 -- PARAMETER_TYPES ::=
12242 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
12244 -- TYPE_DESIGNATOR ::=
12246 -- | subtype_Name ' Access
12250 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
12252 -- MECHANISM_ASSOCIATION ::=
12253 -- [formal_parameter_NAME =>] MECHANISM_NAME
12255 -- MECHANISM_NAME ::=
12258 -- | Descriptor [([Class =>] CLASS_NAME)]
12260 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
12262 when Pragma_Export_Valued_Procedure =>
12263 Export_Valued_Procedure : declare
12264 Args : Args_List (1 .. 4);
12265 Names : constant Name_List (1 .. 4) := (
12268 Name_Parameter_Types,
12271 Internal : Node_Id renames Args (1);
12272 External : Node_Id renames Args (2);
12273 Parameter_Types : Node_Id renames Args (3);
12274 Mechanism : Node_Id renames Args (4);
12278 Gather_Associations (Names, Args);
12279 Process_Extended_Import_Export_Subprogram_Pragma (
12280 Arg_Internal => Internal,
12281 Arg_External => External,
12282 Arg_Parameter_Types => Parameter_Types,
12283 Arg_Mechanism => Mechanism);
12284 end Export_Valued_Procedure;
12286 -------------------
12287 -- Extend_System --
12288 -------------------
12290 -- pragma Extend_System ([Name =>] Identifier);
12292 when Pragma_Extend_System => Extend_System : declare
12295 Check_Valid_Configuration_Pragma;
12296 Check_Arg_Count (1);
12297 Check_Optional_Identifier (Arg1, Name_Name);
12298 Check_Arg_Is_Identifier (Arg1);
12300 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
12303 and then Name_Buffer (1 .. 4) = "aux_"
12305 if Present (System_Extend_Pragma_Arg) then
12306 if Chars (Get_Pragma_Arg (Arg1)) =
12307 Chars (Expression (System_Extend_Pragma_Arg))
12311 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
12312 Error_Pragma ("pragma% conflicts with that #");
12316 System_Extend_Pragma_Arg := Arg1;
12318 if not GNAT_Mode then
12319 System_Extend_Unit := Arg1;
12323 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
12327 ------------------------
12328 -- Extensions_Allowed --
12329 ------------------------
12331 -- pragma Extensions_Allowed (ON | OFF);
12333 when Pragma_Extensions_Allowed =>
12335 Check_Arg_Count (1);
12336 Check_No_Identifiers;
12337 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
12339 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
12340 Extensions_Allowed := True;
12341 Ada_Version := Ada_Version_Type'Last;
12344 Extensions_Allowed := False;
12345 Ada_Version := Ada_Version_Explicit;
12346 Ada_Version_Pragma := Empty;
12353 -- pragma External (
12354 -- [ Convention =>] convention_IDENTIFIER,
12355 -- [ Entity =>] local_NAME
12356 -- [, [External_Name =>] static_string_EXPRESSION ]
12357 -- [, [Link_Name =>] static_string_EXPRESSION ]);
12359 when Pragma_External => External : declare
12360 Def_Id : Entity_Id;
12363 pragma Warnings (Off, C);
12370 Name_External_Name,
12372 Check_At_Least_N_Arguments (2);
12373 Check_At_Most_N_Arguments (4);
12374 Process_Convention (C, Def_Id);
12375 Note_Possible_Modification
12376 (Get_Pragma_Arg (Arg2), Sure => False);
12377 Process_Interface_Name (Def_Id, Arg3, Arg4);
12378 Set_Exported (Def_Id, Arg2);
12381 --------------------------
12382 -- External_Name_Casing --
12383 --------------------------
12385 -- pragma External_Name_Casing (
12386 -- UPPERCASE | LOWERCASE
12387 -- [, AS_IS | UPPERCASE | LOWERCASE]);
12389 when Pragma_External_Name_Casing => External_Name_Casing : declare
12392 Check_No_Identifiers;
12394 if Arg_Count = 2 then
12395 Check_Arg_Is_One_Of
12396 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
12398 case Chars (Get_Pragma_Arg (Arg2)) is
12400 Opt.External_Name_Exp_Casing := As_Is;
12402 when Name_Uppercase =>
12403 Opt.External_Name_Exp_Casing := Uppercase;
12405 when Name_Lowercase =>
12406 Opt.External_Name_Exp_Casing := Lowercase;
12413 Check_Arg_Count (1);
12416 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
12418 case Chars (Get_Pragma_Arg (Arg1)) is
12419 when Name_Uppercase =>
12420 Opt.External_Name_Imp_Casing := Uppercase;
12422 when Name_Lowercase =>
12423 Opt.External_Name_Imp_Casing := Lowercase;
12428 end External_Name_Casing;
12434 -- pragma Fast_Math;
12436 when Pragma_Fast_Math =>
12438 Check_No_Identifiers;
12439 Check_Valid_Configuration_Pragma;
12442 --------------------------
12443 -- Favor_Top_Level --
12444 --------------------------
12446 -- pragma Favor_Top_Level (type_NAME);
12448 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
12449 Named_Entity : Entity_Id;
12453 Check_No_Identifiers;
12454 Check_Arg_Count (1);
12455 Check_Arg_Is_Local_Name (Arg1);
12456 Named_Entity := Entity (Get_Pragma_Arg (Arg1));
12458 -- If it's an access-to-subprogram type (in particular, not a
12459 -- subtype), set the flag on that type.
12461 if Is_Access_Subprogram_Type (Named_Entity) then
12462 Set_Can_Use_Internal_Rep (Named_Entity, False);
12464 -- Otherwise it's an error (name denotes the wrong sort of entity)
12468 ("access-to-subprogram type expected",
12469 Get_Pragma_Arg (Arg1));
12471 end Favor_Top_Level;
12473 ---------------------------
12474 -- Finalize_Storage_Only --
12475 ---------------------------
12477 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
12479 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
12480 Assoc : constant Node_Id := Arg1;
12481 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
12486 Check_No_Identifiers;
12487 Check_Arg_Count (1);
12488 Check_Arg_Is_Local_Name (Arg1);
12490 Find_Type (Type_Id);
12491 Typ := Entity (Type_Id);
12494 or else Rep_Item_Too_Early (Typ, N)
12498 Typ := Underlying_Type (Typ);
12501 if not Is_Controlled (Typ) then
12502 Error_Pragma ("pragma% must specify controlled type");
12505 Check_First_Subtype (Arg1);
12507 if Finalize_Storage_Only (Typ) then
12508 Error_Pragma ("duplicate pragma%, only one allowed");
12510 elsif not Rep_Item_Too_Late (Typ, N) then
12511 Set_Finalize_Storage_Only (Base_Type (Typ), True);
12513 end Finalize_Storage;
12515 --------------------------
12516 -- Float_Representation --
12517 --------------------------
12519 -- pragma Float_Representation (FLOAT_REP[, float_type_LOCAL_NAME]);
12521 -- FLOAT_REP ::= VAX_Float | IEEE_Float
12523 when Pragma_Float_Representation => Float_Representation : declare
12531 if Arg_Count = 1 then
12532 Check_Valid_Configuration_Pragma;
12534 Check_Arg_Count (2);
12535 Check_Optional_Identifier (Arg2, Name_Entity);
12536 Check_Arg_Is_Local_Name (Arg2);
12539 Check_No_Identifier (Arg1);
12540 Check_Arg_Is_One_Of (Arg1, Name_VAX_Float, Name_IEEE_Float);
12542 if not OpenVMS_On_Target then
12543 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
12545 ("??pragma% ignored (applies only to Open'V'M'S)");
12551 -- One argument case
12553 if Arg_Count = 1 then
12554 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
12555 if Opt.Float_Format = 'I' then
12556 Error_Pragma ("'I'E'E'E format previously specified");
12559 Opt.Float_Format := 'V';
12562 if Opt.Float_Format = 'V' then
12563 Error_Pragma ("'V'A'X format previously specified");
12566 Opt.Float_Format := 'I';
12569 Set_Standard_Fpt_Formats;
12571 -- Two argument case
12574 Argx := Get_Pragma_Arg (Arg2);
12576 if not Is_Entity_Name (Argx)
12577 or else not Is_Floating_Point_Type (Entity (Argx))
12580 ("second argument of% pragma must be floating-point type",
12584 Ent := Entity (Argx);
12585 Digs := UI_To_Int (Digits_Value (Ent));
12587 -- Two arguments, VAX_Float case
12589 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
12591 when 6 => Set_F_Float (Ent);
12592 when 9 => Set_D_Float (Ent);
12593 when 15 => Set_G_Float (Ent);
12597 ("wrong digits value, must be 6,9 or 15", Arg2);
12600 -- Two arguments, IEEE_Float case
12604 when 6 => Set_IEEE_Short (Ent);
12605 when 15 => Set_IEEE_Long (Ent);
12609 ("wrong digits value, must be 6 or 15", Arg2);
12613 end Float_Representation;
12619 -- pragma Global (GLOBAL_SPECIFICATION);
12621 -- GLOBAL_SPECIFICATION ::=
12624 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
12626 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
12628 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
12629 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
12630 -- GLOBAL_ITEM ::= NAME
12632 when Pragma_Global => Global : declare
12633 Subp_Decl : Node_Id;
12638 Check_Arg_Count (1);
12640 -- Ensure the proper placement of the pragma. Global must be
12641 -- associated with a subprogram declaration or a body that acts
12645 Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
12647 if Nkind (Subp_Decl) /= N_Subprogram_Declaration
12648 and then (Nkind (Subp_Decl) /= N_Subprogram_Body
12649 or else not Acts_As_Spec (Subp_Decl))
12655 -- When the pragma appears on a subprogram body, perform the full
12658 if Nkind (Subp_Decl) = N_Subprogram_Body then
12659 Analyze_Global_In_Decl_Part (N);
12661 -- When Global applies to a subprogram compilation unit, the
12662 -- corresponding pragma is placed after the unit's declaration
12663 -- node and needs to be analyzed immediately.
12665 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration
12666 and then Nkind (Parent (Subp_Decl)) = N_Compilation_Unit
12668 Analyze_Global_In_Decl_Part (N);
12671 -- Chain the pragma on the contract for further processing
12673 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
12680 -- pragma Ident (static_string_EXPRESSION)
12682 -- Note: pragma Comment shares this processing. Pragma Comment is
12683 -- identical to Ident, except that the restriction of the argument to
12684 -- 31 characters and the placement restrictions are not enforced for
12687 when Pragma_Ident | Pragma_Comment => Ident : declare
12692 Check_Arg_Count (1);
12693 Check_No_Identifiers;
12694 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
12697 -- For pragma Ident, preserve DEC compatibility by requiring the
12698 -- pragma to appear in a declarative part or package spec.
12700 if Prag_Id = Pragma_Ident then
12701 Check_Is_In_Decl_Part_Or_Package_Spec;
12704 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
12711 GP := Parent (Parent (N));
12713 if Nkind_In (GP, N_Package_Declaration,
12714 N_Generic_Package_Declaration)
12719 -- If we have a compilation unit, then record the ident value,
12720 -- checking for improper duplication.
12722 if Nkind (GP) = N_Compilation_Unit then
12723 CS := Ident_String (Current_Sem_Unit);
12725 if Present (CS) then
12727 -- For Ident, we do not permit multiple instances
12729 if Prag_Id = Pragma_Ident then
12730 Error_Pragma ("duplicate% pragma not permitted");
12732 -- For Comment, we concatenate the string, unless we want
12733 -- to preserve the tree structure for ASIS.
12735 elsif not ASIS_Mode then
12736 Start_String (Strval (CS));
12737 Store_String_Char (' ');
12738 Store_String_Chars (Strval (Str));
12739 Set_Strval (CS, End_String);
12743 -- In VMS, the effect of IDENT is achieved by passing
12744 -- --identification=name as a --for-linker switch.
12746 if OpenVMS_On_Target then
12749 ("--for-linker=--identification=");
12750 String_To_Name_Buffer (Strval (Str));
12751 Store_String_Chars (Name_Buffer (1 .. Name_Len));
12753 -- Only the last processed IDENT is saved. The main
12754 -- purpose is so an IDENT associated with a main
12755 -- procedure will be used in preference to an IDENT
12756 -- associated with a with'd package.
12758 Replace_Linker_Option_String
12759 (End_String, "--for-linker=--identification=");
12762 Set_Ident_String (Current_Sem_Unit, Str);
12765 -- For subunits, we just ignore the Ident, since in GNAT these
12766 -- are not separate object files, and hence not separate units
12767 -- in the unit table.
12769 elsif Nkind (GP) = N_Subunit then
12772 -- Otherwise we have a misplaced pragma Ident, but we ignore
12773 -- this if we are in an instantiation, since it comes from
12774 -- a generic, and has no relevance to the instantiation.
12776 elsif Prag_Id = Pragma_Ident then
12777 if Instantiation_Location (Loc) = No_Location then
12778 Error_Pragma ("pragma% only allowed at outer level");
12784 ----------------------------
12785 -- Implementation_Defined --
12786 ----------------------------
12788 -- pragma Implementation_Defined (local_NAME);
12790 -- Marks previously declared entity as implementation defined. For
12791 -- an overloaded entity, applies to the most recent homonym.
12793 -- pragma Implementation_Defined;
12795 -- The form with no arguments appears anywhere within a scope, most
12796 -- typically a package spec, and indicates that all entities that are
12797 -- defined within the package spec are Implementation_Defined.
12799 when Pragma_Implementation_Defined => Implementation_Defined : declare
12804 Check_No_Identifiers;
12806 -- Form with no arguments
12808 if Arg_Count = 0 then
12809 Set_Is_Implementation_Defined (Current_Scope);
12811 -- Form with one argument
12814 Check_Arg_Count (1);
12815 Check_Arg_Is_Local_Name (Arg1);
12816 Ent := Entity (Get_Pragma_Arg (Arg1));
12817 Set_Is_Implementation_Defined (Ent);
12819 end Implementation_Defined;
12825 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
12827 -- IMPLEMENTATION_KIND ::=
12828 -- By_Entry | By_Protected_Procedure | By_Any | Optional
12830 -- "By_Any" and "Optional" are treated as synonyms in order to
12831 -- support Ada 2012 aspect Synchronization.
12833 when Pragma_Implemented => Implemented : declare
12834 Proc_Id : Entity_Id;
12839 Check_Arg_Count (2);
12840 Check_No_Identifiers;
12841 Check_Arg_Is_Identifier (Arg1);
12842 Check_Arg_Is_Local_Name (Arg1);
12843 Check_Arg_Is_One_Of (Arg2,
12846 Name_By_Protected_Procedure,
12849 -- Extract the name of the local procedure
12851 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
12853 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
12854 -- primitive procedure of a synchronized tagged type.
12856 if Ekind (Proc_Id) = E_Procedure
12857 and then Is_Primitive (Proc_Id)
12858 and then Present (First_Formal (Proc_Id))
12860 Typ := Etype (First_Formal (Proc_Id));
12862 if Is_Tagged_Type (Typ)
12865 -- Check for a protected, a synchronized or a task interface
12867 ((Is_Interface (Typ)
12868 and then Is_Synchronized_Interface (Typ))
12870 -- Check for a protected type or a task type that implements
12874 (Is_Concurrent_Record_Type (Typ)
12875 and then Present (Interfaces (Typ)))
12877 -- Check for a private record extension with keyword
12881 (Ekind_In (Typ, E_Record_Type_With_Private,
12882 E_Record_Subtype_With_Private)
12883 and then Synchronized_Present (Parent (Typ))))
12888 ("controlling formal must be of synchronized tagged type",
12893 -- Procedures declared inside a protected type must be accepted
12895 elsif Ekind (Proc_Id) = E_Procedure
12896 and then Is_Protected_Type (Scope (Proc_Id))
12900 -- The first argument is not a primitive procedure
12904 ("pragma % must be applied to a primitive procedure", Arg1);
12908 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
12909 -- By_Protected_Procedure to the primitive procedure of a task
12912 if Chars (Arg2) = Name_By_Protected_Procedure
12913 and then Is_Interface (Typ)
12914 and then Is_Task_Interface (Typ)
12917 ("implementation kind By_Protected_Procedure cannot be "
12918 & "applied to a task interface primitive", Arg2);
12922 Record_Rep_Item (Proc_Id, N);
12925 ----------------------
12926 -- Implicit_Packing --
12927 ----------------------
12929 -- pragma Implicit_Packing;
12931 when Pragma_Implicit_Packing =>
12933 Check_Arg_Count (0);
12934 Implicit_Packing := True;
12941 -- [Convention =>] convention_IDENTIFIER,
12942 -- [Entity =>] local_NAME
12943 -- [, [External_Name =>] static_string_EXPRESSION ]
12944 -- [, [Link_Name =>] static_string_EXPRESSION ]);
12946 when Pragma_Import =>
12947 Check_Ada_83_Warning;
12951 Name_External_Name,
12954 Check_At_Least_N_Arguments (2);
12955 Check_At_Most_N_Arguments (4);
12956 Process_Import_Or_Interface;
12958 ----------------------
12959 -- Import_Exception --
12960 ----------------------
12962 -- pragma Import_Exception (
12963 -- [Internal =>] LOCAL_NAME
12964 -- [, [External =>] EXTERNAL_SYMBOL]
12965 -- [, [Form =>] Ada | VMS]
12966 -- [, [Code =>] static_integer_EXPRESSION]);
12968 when Pragma_Import_Exception => Import_Exception : declare
12969 Args : Args_List (1 .. 4);
12970 Names : constant Name_List (1 .. 4) := (
12976 Internal : Node_Id renames Args (1);
12977 External : Node_Id renames Args (2);
12978 Form : Node_Id renames Args (3);
12979 Code : Node_Id renames Args (4);
12983 Gather_Associations (Names, Args);
12985 if Present (External) and then Present (Code) then
12987 ("cannot give both External and Code options for pragma%");
12990 Process_Extended_Import_Export_Exception_Pragma (
12991 Arg_Internal => Internal,
12992 Arg_External => External,
12996 if not Is_VMS_Exception (Entity (Internal)) then
12997 Set_Imported (Entity (Internal));
12999 end Import_Exception;
13001 ---------------------
13002 -- Import_Function --
13003 ---------------------
13005 -- pragma Import_Function (
13006 -- [Internal =>] LOCAL_NAME,
13007 -- [, [External =>] EXTERNAL_SYMBOL]
13008 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13009 -- [, [Result_Type =>] SUBTYPE_MARK]
13010 -- [, [Mechanism =>] MECHANISM]
13011 -- [, [Result_Mechanism =>] MECHANISM_NAME]
13012 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
13014 -- EXTERNAL_SYMBOL ::=
13016 -- | static_string_EXPRESSION
13018 -- PARAMETER_TYPES ::=
13020 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13022 -- TYPE_DESIGNATOR ::=
13024 -- | subtype_Name ' Access
13028 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13030 -- MECHANISM_ASSOCIATION ::=
13031 -- [formal_parameter_NAME =>] MECHANISM_NAME
13033 -- MECHANISM_NAME ::=
13036 -- | Descriptor [([Class =>] CLASS_NAME)]
13038 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
13040 when Pragma_Import_Function => Import_Function : declare
13041 Args : Args_List (1 .. 7);
13042 Names : constant Name_List (1 .. 7) := (
13045 Name_Parameter_Types,
13048 Name_Result_Mechanism,
13049 Name_First_Optional_Parameter);
13051 Internal : Node_Id renames Args (1);
13052 External : Node_Id renames Args (2);
13053 Parameter_Types : Node_Id renames Args (3);
13054 Result_Type : Node_Id renames Args (4);
13055 Mechanism : Node_Id renames Args (5);
13056 Result_Mechanism : Node_Id renames Args (6);
13057 First_Optional_Parameter : Node_Id renames Args (7);
13061 Gather_Associations (Names, Args);
13062 Process_Extended_Import_Export_Subprogram_Pragma (
13063 Arg_Internal => Internal,
13064 Arg_External => External,
13065 Arg_Parameter_Types => Parameter_Types,
13066 Arg_Result_Type => Result_Type,
13067 Arg_Mechanism => Mechanism,
13068 Arg_Result_Mechanism => Result_Mechanism,
13069 Arg_First_Optional_Parameter => First_Optional_Parameter);
13070 end Import_Function;
13072 -------------------
13073 -- Import_Object --
13074 -------------------
13076 -- pragma Import_Object (
13077 -- [Internal =>] LOCAL_NAME
13078 -- [, [External =>] EXTERNAL_SYMBOL]
13079 -- [, [Size =>] EXTERNAL_SYMBOL]);
13081 -- EXTERNAL_SYMBOL ::=
13083 -- | static_string_EXPRESSION
13085 when Pragma_Import_Object => Import_Object : declare
13086 Args : Args_List (1 .. 3);
13087 Names : constant Name_List (1 .. 3) := (
13092 Internal : Node_Id renames Args (1);
13093 External : Node_Id renames Args (2);
13094 Size : Node_Id renames Args (3);
13098 Gather_Associations (Names, Args);
13099 Process_Extended_Import_Export_Object_Pragma (
13100 Arg_Internal => Internal,
13101 Arg_External => External,
13105 ----------------------
13106 -- Import_Procedure --
13107 ----------------------
13109 -- pragma Import_Procedure (
13110 -- [Internal =>] LOCAL_NAME
13111 -- [, [External =>] EXTERNAL_SYMBOL]
13112 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13113 -- [, [Mechanism =>] MECHANISM]
13114 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
13116 -- EXTERNAL_SYMBOL ::=
13118 -- | static_string_EXPRESSION
13120 -- PARAMETER_TYPES ::=
13122 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13124 -- TYPE_DESIGNATOR ::=
13126 -- | subtype_Name ' Access
13130 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13132 -- MECHANISM_ASSOCIATION ::=
13133 -- [formal_parameter_NAME =>] MECHANISM_NAME
13135 -- MECHANISM_NAME ::=
13138 -- | Descriptor [([Class =>] CLASS_NAME)]
13140 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
13142 when Pragma_Import_Procedure => Import_Procedure : declare
13143 Args : Args_List (1 .. 5);
13144 Names : constant Name_List (1 .. 5) := (
13147 Name_Parameter_Types,
13149 Name_First_Optional_Parameter);
13151 Internal : Node_Id renames Args (1);
13152 External : Node_Id renames Args (2);
13153 Parameter_Types : Node_Id renames Args (3);
13154 Mechanism : Node_Id renames Args (4);
13155 First_Optional_Parameter : Node_Id renames Args (5);
13159 Gather_Associations (Names, Args);
13160 Process_Extended_Import_Export_Subprogram_Pragma (
13161 Arg_Internal => Internal,
13162 Arg_External => External,
13163 Arg_Parameter_Types => Parameter_Types,
13164 Arg_Mechanism => Mechanism,
13165 Arg_First_Optional_Parameter => First_Optional_Parameter);
13166 end Import_Procedure;
13168 -----------------------------
13169 -- Import_Valued_Procedure --
13170 -----------------------------
13172 -- pragma Import_Valued_Procedure (
13173 -- [Internal =>] LOCAL_NAME
13174 -- [, [External =>] EXTERNAL_SYMBOL]
13175 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13176 -- [, [Mechanism =>] MECHANISM]
13177 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
13179 -- EXTERNAL_SYMBOL ::=
13181 -- | static_string_EXPRESSION
13183 -- PARAMETER_TYPES ::=
13185 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13187 -- TYPE_DESIGNATOR ::=
13189 -- | subtype_Name ' Access
13193 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13195 -- MECHANISM_ASSOCIATION ::=
13196 -- [formal_parameter_NAME =>] MECHANISM_NAME
13198 -- MECHANISM_NAME ::=
13201 -- | Descriptor [([Class =>] CLASS_NAME)]
13203 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
13205 when Pragma_Import_Valued_Procedure =>
13206 Import_Valued_Procedure : declare
13207 Args : Args_List (1 .. 5);
13208 Names : constant Name_List (1 .. 5) := (
13211 Name_Parameter_Types,
13213 Name_First_Optional_Parameter);
13215 Internal : Node_Id renames Args (1);
13216 External : Node_Id renames Args (2);
13217 Parameter_Types : Node_Id renames Args (3);
13218 Mechanism : Node_Id renames Args (4);
13219 First_Optional_Parameter : Node_Id renames Args (5);
13223 Gather_Associations (Names, Args);
13224 Process_Extended_Import_Export_Subprogram_Pragma (
13225 Arg_Internal => Internal,
13226 Arg_External => External,
13227 Arg_Parameter_Types => Parameter_Types,
13228 Arg_Mechanism => Mechanism,
13229 Arg_First_Optional_Parameter => First_Optional_Parameter);
13230 end Import_Valued_Procedure;
13236 -- pragma Independent (LOCAL_NAME);
13238 when Pragma_Independent => Independent : declare
13245 Check_Ada_83_Warning;
13247 Check_No_Identifiers;
13248 Check_Arg_Count (1);
13249 Check_Arg_Is_Local_Name (Arg1);
13250 E_Id := Get_Pragma_Arg (Arg1);
13252 if Etype (E_Id) = Any_Type then
13256 E := Entity (E_Id);
13257 D := Declaration_Node (E);
13260 -- Check duplicate before we chain ourselves!
13262 Check_Duplicate_Pragma (E);
13264 -- Check appropriate entity
13266 if Is_Type (E) then
13267 if Rep_Item_Too_Early (E, N)
13269 Rep_Item_Too_Late (E, N)
13273 Check_First_Subtype (Arg1);
13276 elsif K = N_Object_Declaration
13277 or else (K = N_Component_Declaration
13278 and then Original_Record_Component (E) = E)
13280 if Rep_Item_Too_Late (E, N) then
13286 ("inappropriate entity for pragma%", Arg1);
13289 Independence_Checks.Append ((N, E));
13292 ----------------------------
13293 -- Independent_Components --
13294 ----------------------------
13296 -- pragma Atomic_Components (array_LOCAL_NAME);
13298 -- This processing is shared by Volatile_Components
13300 when Pragma_Independent_Components => Independent_Components : declare
13307 Check_Ada_83_Warning;
13309 Check_No_Identifiers;
13310 Check_Arg_Count (1);
13311 Check_Arg_Is_Local_Name (Arg1);
13312 E_Id := Get_Pragma_Arg (Arg1);
13314 if Etype (E_Id) = Any_Type then
13318 E := Entity (E_Id);
13320 -- Check duplicate before we chain ourselves!
13322 Check_Duplicate_Pragma (E);
13324 -- Check appropriate entity
13326 if Rep_Item_Too_Early (E, N)
13328 Rep_Item_Too_Late (E, N)
13333 D := Declaration_Node (E);
13336 if K = N_Full_Type_Declaration
13337 and then (Is_Array_Type (E) or else Is_Record_Type (E))
13339 Independence_Checks.Append ((N, E));
13340 Set_Has_Independent_Components (Base_Type (E));
13342 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
13343 and then Nkind (D) = N_Object_Declaration
13344 and then Nkind (Object_Definition (D)) =
13345 N_Constrained_Array_Definition
13347 Independence_Checks.Append ((N, E));
13348 Set_Has_Independent_Components (E);
13351 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
13353 end Independent_Components;
13355 ------------------------
13356 -- Initialize_Scalars --
13357 ------------------------
13359 -- pragma Initialize_Scalars;
13361 when Pragma_Initialize_Scalars =>
13363 Check_Arg_Count (0);
13364 Check_Valid_Configuration_Pragma;
13365 Check_Restriction (No_Initialize_Scalars, N);
13367 -- Initialize_Scalars creates false positives in CodePeer, and
13368 -- incorrect negative results in SPARK mode, so ignore this pragma
13371 if not Restriction_Active (No_Initialize_Scalars)
13372 and then not (CodePeer_Mode or SPARK_Mode)
13374 Init_Or_Norm_Scalars := True;
13375 Initialize_Scalars := True;
13382 -- pragma Initializes (INITIALIZATION_SPEC);
13384 -- INITIALIZATION_SPEC ::= null | INITIALIZATION_LIST
13386 -- INITIALIZATION_LIST ::=
13387 -- INITIALIZATION_ITEM
13388 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
13390 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
13395 -- | (INPUT {, INPUT})
13399 when Pragma_Initializes => Initializes : declare
13400 Context : constant Node_Id := Parent (Parent (N));
13401 Pack_Id : Entity_Id;
13407 Check_Arg_Count (1);
13409 -- Ensure the proper placement of the pragma. Initializes must be
13410 -- associated with a package declaration.
13412 if not Nkind_In (Context, N_Generic_Package_Declaration,
13413 N_Package_Declaration)
13420 while Present (Stmt) loop
13422 -- Skip prior pragmas, but check for duplicates
13424 if Nkind (Stmt) = N_Pragma then
13425 if Pragma_Name (Stmt) = Pname then
13426 Error_Msg_Name_1 := Pname;
13427 Error_Msg_Sloc := Sloc (Stmt);
13428 Error_Msg_N ("pragma % duplicates pragma declared #", N);
13431 -- Skip internally generated code
13433 elsif not Comes_From_Source (Stmt) then
13436 -- The pragma does not apply to a legal construct, issue an
13437 -- error and stop the analysis.
13444 Stmt := Prev (Stmt);
13447 -- The pragma must be analyzed at the end of the visible
13448 -- declarations of the related package. Save the pragma for later
13449 -- (see Analyze_Initializes_In_Decl_Part) by adding it to the
13450 -- contract of the package.
13452 Pack_Id := Defining_Entity (Context);
13453 Add_Contract_Item (N, Pack_Id);
13455 -- Verify the declaration order of pragmas Abstract_State and
13458 Check_Declaration_Order
13459 (States => Get_Pragma (Pack_Id, Pragma_Abstract_State),
13467 -- pragma Inline ( NAME {, NAME} );
13469 when Pragma_Inline =>
13471 -- Inline status is Enabled if inlining option is active
13473 if Inline_Active then
13474 Process_Inline (Enabled);
13476 Process_Inline (Disabled);
13479 -------------------
13480 -- Inline_Always --
13481 -------------------
13483 -- pragma Inline_Always ( NAME {, NAME} );
13485 when Pragma_Inline_Always =>
13488 -- Pragma always active unless in CodePeer or SPARK mode, since
13489 -- this causes walk order issues.
13491 if not (CodePeer_Mode or SPARK_Mode) then
13492 Process_Inline (Enabled);
13495 --------------------
13496 -- Inline_Generic --
13497 --------------------
13499 -- pragma Inline_Generic (NAME {, NAME});
13501 when Pragma_Inline_Generic =>
13503 Process_Generic_List;
13505 ----------------------
13506 -- Inspection_Point --
13507 ----------------------
13509 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
13511 when Pragma_Inspection_Point => Inspection_Point : declare
13516 if Arg_Count > 0 then
13519 Exp := Get_Pragma_Arg (Arg);
13522 if not Is_Entity_Name (Exp)
13523 or else not Is_Object (Entity (Exp))
13525 Error_Pragma_Arg ("object name required", Arg);
13529 exit when No (Arg);
13532 end Inspection_Point;
13538 -- pragma Interface (
13539 -- [ Convention =>] convention_IDENTIFIER,
13540 -- [ Entity =>] local_NAME
13541 -- [, [External_Name =>] static_string_EXPRESSION ]
13542 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13544 when Pragma_Interface =>
13549 Name_External_Name,
13551 Check_At_Least_N_Arguments (2);
13552 Check_At_Most_N_Arguments (4);
13553 Process_Import_Or_Interface;
13555 -- In Ada 2005, the permission to use Interface (a reserved word)
13556 -- as a pragma name is considered an obsolescent feature, and this
13557 -- pragma was already obsolescent in Ada 95.
13559 if Ada_Version >= Ada_95 then
13561 (No_Obsolescent_Features, Pragma_Identifier (N));
13563 if Warn_On_Obsolescent_Feature then
13565 ("pragma Interface is an obsolescent feature?j?", N);
13567 ("|use pragma Import instead?j?", N);
13571 --------------------
13572 -- Interface_Name --
13573 --------------------
13575 -- pragma Interface_Name (
13576 -- [ Entity =>] local_NAME
13577 -- [,[External_Name =>] static_string_EXPRESSION ]
13578 -- [,[Link_Name =>] static_string_EXPRESSION ]);
13580 when Pragma_Interface_Name => Interface_Name : declare
13582 Def_Id : Entity_Id;
13583 Hom_Id : Entity_Id;
13589 ((Name_Entity, Name_External_Name, Name_Link_Name));
13590 Check_At_Least_N_Arguments (2);
13591 Check_At_Most_N_Arguments (3);
13592 Id := Get_Pragma_Arg (Arg1);
13595 -- This is obsolete from Ada 95 on, but it is an implementation
13596 -- defined pragma, so we do not consider that it violates the
13597 -- restriction (No_Obsolescent_Features).
13599 if Ada_Version >= Ada_95 then
13600 if Warn_On_Obsolescent_Feature then
13602 ("pragma Interface_Name is an obsolescent feature?j?", N);
13604 ("|use pragma Import instead?j?", N);
13608 if not Is_Entity_Name (Id) then
13610 ("first argument for pragma% must be entity name", Arg1);
13611 elsif Etype (Id) = Any_Type then
13614 Def_Id := Entity (Id);
13617 -- Special DEC-compatible processing for the object case, forces
13618 -- object to be imported.
13620 if Ekind (Def_Id) = E_Variable then
13621 Kill_Size_Check_Code (Def_Id);
13622 Note_Possible_Modification (Id, Sure => False);
13624 -- Initialization is not allowed for imported variable
13626 if Present (Expression (Parent (Def_Id)))
13627 and then Comes_From_Source (Expression (Parent (Def_Id)))
13629 Error_Msg_Sloc := Sloc (Def_Id);
13631 ("no initialization allowed for declaration of& #",
13635 -- For compatibility, support VADS usage of providing both
13636 -- pragmas Interface and Interface_Name to obtain the effect
13637 -- of a single Import pragma.
13639 if Is_Imported (Def_Id)
13640 and then Present (First_Rep_Item (Def_Id))
13641 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
13643 Pragma_Name (First_Rep_Item (Def_Id)) = Name_Interface
13647 Set_Imported (Def_Id);
13650 Set_Is_Public (Def_Id);
13651 Process_Interface_Name (Def_Id, Arg2, Arg3);
13654 -- Otherwise must be subprogram
13656 elsif not Is_Subprogram (Def_Id) then
13658 ("argument of pragma% is not subprogram", Arg1);
13661 Check_At_Most_N_Arguments (3);
13665 -- Loop through homonyms
13668 Def_Id := Get_Base_Subprogram (Hom_Id);
13670 if Is_Imported (Def_Id) then
13671 Process_Interface_Name (Def_Id, Arg2, Arg3);
13675 exit when From_Aspect_Specification (N);
13676 Hom_Id := Homonym (Hom_Id);
13678 exit when No (Hom_Id)
13679 or else Scope (Hom_Id) /= Current_Scope;
13684 ("argument of pragma% is not imported subprogram",
13688 end Interface_Name;
13690 -----------------------
13691 -- Interrupt_Handler --
13692 -----------------------
13694 -- pragma Interrupt_Handler (handler_NAME);
13696 when Pragma_Interrupt_Handler =>
13697 Check_Ada_83_Warning;
13698 Check_Arg_Count (1);
13699 Check_No_Identifiers;
13701 if No_Run_Time_Mode then
13702 Error_Msg_CRT ("Interrupt_Handler pragma", N);
13704 Check_Interrupt_Or_Attach_Handler;
13705 Process_Interrupt_Or_Attach_Handler;
13708 ------------------------
13709 -- Interrupt_Priority --
13710 ------------------------
13712 -- pragma Interrupt_Priority [(EXPRESSION)];
13714 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
13715 P : constant Node_Id := Parent (N);
13720 Check_Ada_83_Warning;
13722 if Arg_Count /= 0 then
13723 Arg := Get_Pragma_Arg (Arg1);
13724 Check_Arg_Count (1);
13725 Check_No_Identifiers;
13727 -- The expression must be analyzed in the special manner
13728 -- described in "Handling of Default and Per-Object
13729 -- Expressions" in sem.ads.
13731 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
13734 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
13739 Ent := Defining_Identifier (Parent (P));
13741 -- Check duplicate pragma before we chain the pragma in the Rep
13742 -- Item chain of Ent.
13744 Check_Duplicate_Pragma (Ent);
13745 Record_Rep_Item (Ent, N);
13747 end Interrupt_Priority;
13749 ---------------------
13750 -- Interrupt_State --
13751 ---------------------
13753 -- pragma Interrupt_State (
13754 -- [Name =>] INTERRUPT_ID,
13755 -- [State =>] INTERRUPT_STATE);
13757 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
13758 -- INTERRUPT_STATE => System | Runtime | User
13760 -- Note: if the interrupt id is given as an identifier, then it must
13761 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
13762 -- given as a static integer expression which must be in the range of
13763 -- Ada.Interrupts.Interrupt_ID.
13765 when Pragma_Interrupt_State => Interrupt_State : declare
13767 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
13768 -- This is the entity Ada.Interrupts.Interrupt_ID;
13770 State_Type : Character;
13771 -- Set to 's'/'r'/'u' for System/Runtime/User
13774 -- Index to entry in Interrupt_States table
13777 -- Value of interrupt
13779 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
13780 -- The first argument to the pragma
13782 Int_Ent : Entity_Id;
13783 -- Interrupt entity in Ada.Interrupts.Names
13787 Check_Arg_Order ((Name_Name, Name_State));
13788 Check_Arg_Count (2);
13790 Check_Optional_Identifier (Arg1, Name_Name);
13791 Check_Optional_Identifier (Arg2, Name_State);
13792 Check_Arg_Is_Identifier (Arg2);
13794 -- First argument is identifier
13796 if Nkind (Arg1X) = N_Identifier then
13798 -- Search list of names in Ada.Interrupts.Names
13800 Int_Ent := First_Entity (RTE (RE_Names));
13802 if No (Int_Ent) then
13803 Error_Pragma_Arg ("invalid interrupt name", Arg1);
13805 elsif Chars (Int_Ent) = Chars (Arg1X) then
13806 Int_Val := Expr_Value (Constant_Value (Int_Ent));
13810 Next_Entity (Int_Ent);
13813 -- First argument is not an identifier, so it must be a static
13814 -- expression of type Ada.Interrupts.Interrupt_ID.
13817 Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
13818 Int_Val := Expr_Value (Arg1X);
13820 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
13822 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
13825 ("value not in range of type "
13826 & """Ada.Interrupts.Interrupt_'I'D""", Arg1);
13832 case Chars (Get_Pragma_Arg (Arg2)) is
13833 when Name_Runtime => State_Type := 'r';
13834 when Name_System => State_Type := 's';
13835 when Name_User => State_Type := 'u';
13838 Error_Pragma_Arg ("invalid interrupt state", Arg2);
13841 -- Check if entry is already stored
13843 IST_Num := Interrupt_States.First;
13845 -- If entry not found, add it
13847 if IST_Num > Interrupt_States.Last then
13848 Interrupt_States.Append
13849 ((Interrupt_Number => UI_To_Int (Int_Val),
13850 Interrupt_State => State_Type,
13851 Pragma_Loc => Loc));
13854 -- Case of entry for the same entry
13856 elsif Int_Val = Interrupt_States.Table (IST_Num).
13859 -- If state matches, done, no need to make redundant entry
13862 State_Type = Interrupt_States.Table (IST_Num).
13865 -- Otherwise if state does not match, error
13868 Interrupt_States.Table (IST_Num).Pragma_Loc;
13870 ("state conflicts with that given #", Arg2);
13874 IST_Num := IST_Num + 1;
13876 end Interrupt_State;
13882 -- pragma Invariant
13883 -- ([Entity =>] type_LOCAL_NAME,
13884 -- [Check =>] EXPRESSION
13885 -- [,[Message =>] String_Expression]);
13887 when Pragma_Invariant => Invariant : declare
13893 pragma Unreferenced (Discard);
13897 Check_At_Least_N_Arguments (2);
13898 Check_At_Most_N_Arguments (3);
13899 Check_Optional_Identifier (Arg1, Name_Entity);
13900 Check_Optional_Identifier (Arg2, Name_Check);
13902 if Arg_Count = 3 then
13903 Check_Optional_Identifier (Arg3, Name_Message);
13904 Check_Arg_Is_Static_Expression (Arg3, Standard_String);
13907 Check_Arg_Is_Local_Name (Arg1);
13909 Type_Id := Get_Pragma_Arg (Arg1);
13910 Find_Type (Type_Id);
13911 Typ := Entity (Type_Id);
13913 if Typ = Any_Type then
13916 -- An invariant must apply to a private type, or appear in the
13917 -- private part of a package spec and apply to a completion.
13919 elsif Ekind_In (Typ, E_Private_Type,
13920 E_Record_Type_With_Private,
13921 E_Limited_Private_Type)
13925 elsif In_Private_Part (Current_Scope)
13926 and then Has_Private_Declaration (Typ)
13930 elsif In_Private_Part (Current_Scope) then
13932 ("pragma% only allowed for private type declared in "
13933 & "visible part", Arg1);
13937 ("pragma% only allowed for private type", Arg1);
13940 -- Note that the type has at least one invariant, and also that
13941 -- it has inheritable invariants if we have Invariant'Class
13942 -- or Type_Invariant'Class. Build the corresponding invariant
13943 -- procedure declaration, so that calls to it can be generated
13944 -- before the body is built (e.g. within an expression function).
13946 PDecl := Build_Invariant_Procedure_Declaration (Typ);
13948 Insert_After (N, PDecl);
13951 if Class_Present (N) then
13952 Set_Has_Inheritable_Invariants (Typ);
13955 -- The remaining processing is simply to link the pragma on to
13956 -- the rep item chain, for processing when the type is frozen.
13957 -- This is accomplished by a call to Rep_Item_Too_Late.
13959 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
13962 ----------------------
13963 -- Java_Constructor --
13964 ----------------------
13966 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
13968 -- Also handles pragma CIL_Constructor
13970 when Pragma_CIL_Constructor | Pragma_Java_Constructor =>
13971 Java_Constructor : declare
13972 Convention : Convention_Id;
13973 Def_Id : Entity_Id;
13974 Hom_Id : Entity_Id;
13976 This_Formal : Entity_Id;
13980 Check_Arg_Count (1);
13981 Check_Optional_Identifier (Arg1, Name_Entity);
13982 Check_Arg_Is_Local_Name (Arg1);
13984 Id := Get_Pragma_Arg (Arg1);
13985 Find_Program_Unit_Name (Id);
13987 -- If we did not find the name, we are done
13989 if Etype (Id) = Any_Type then
13993 -- Check wrong use of pragma in wrong VM target
13995 if VM_Target = No_VM then
13998 elsif VM_Target = CLI_Target
13999 and then Prag_Id = Pragma_Java_Constructor
14001 Error_Pragma ("must use pragma 'C'I'L_'Constructor");
14003 elsif VM_Target = JVM_Target
14004 and then Prag_Id = Pragma_CIL_Constructor
14006 Error_Pragma ("must use pragma 'Java_'Constructor");
14010 when Pragma_CIL_Constructor => Convention := Convention_CIL;
14011 when Pragma_Java_Constructor => Convention := Convention_Java;
14012 when others => null;
14015 Hom_Id := Entity (Id);
14017 -- Loop through homonyms
14020 Def_Id := Get_Base_Subprogram (Hom_Id);
14022 -- The constructor is required to be a function
14024 if Ekind (Def_Id) /= E_Function then
14025 if VM_Target = JVM_Target then
14027 ("pragma% requires function returning a 'Java access "
14031 ("pragma% requires function returning a 'C'I'L access "
14036 -- Check arguments: For tagged type the first formal must be
14037 -- named "this" and its type must be a named access type
14038 -- designating a class-wide tagged type that has convention
14039 -- CIL/Java. The first formal must also have a null default
14040 -- value. For example:
14042 -- type Typ is tagged ...
14043 -- type Ref is access all Typ;
14044 -- pragma Convention (CIL, Typ);
14046 -- function New_Typ (This : Ref) return Ref;
14047 -- function New_Typ (This : Ref; I : Integer) return Ref;
14048 -- pragma Cil_Constructor (New_Typ);
14050 -- Reason: The first formal must NOT be a primitive of the
14053 -- This rule also applies to constructors of delegates used
14054 -- to interface with standard target libraries. For example:
14056 -- type Delegate is access procedure ...
14057 -- pragma Import (CIL, Delegate, ...);
14059 -- function new_Delegate
14060 -- (This : Delegate := null; ... ) return Delegate;
14062 -- For value-types this rule does not apply.
14064 if not Is_Value_Type (Etype (Def_Id)) then
14065 if No (First_Formal (Def_Id)) then
14066 Error_Msg_Name_1 := Pname;
14067 Error_Msg_N ("% function must have parameters", Def_Id);
14071 -- In the JRE library we have several occurrences in which
14072 -- the "this" parameter is not the first formal.
14074 This_Formal := First_Formal (Def_Id);
14076 -- In the JRE library we have several occurrences in which
14077 -- the "this" parameter is not the first formal. Search for
14080 if VM_Target = JVM_Target then
14081 while Present (This_Formal)
14082 and then Get_Name_String (Chars (This_Formal)) /= "this"
14084 Next_Formal (This_Formal);
14087 if No (This_Formal) then
14088 This_Formal := First_Formal (Def_Id);
14092 -- Warning: The first parameter should be named "this".
14093 -- We temporarily allow it because we have the following
14094 -- case in the Java runtime (file s-osinte.ads) ???
14096 -- function new_Thread
14097 -- (Self_Id : System.Address) return Thread_Id;
14098 -- pragma Java_Constructor (new_Thread);
14100 if VM_Target = JVM_Target
14101 and then Get_Name_String (Chars (First_Formal (Def_Id)))
14103 and then Etype (First_Formal (Def_Id)) = RTE (RE_Address)
14107 elsif Get_Name_String (Chars (This_Formal)) /= "this" then
14108 Error_Msg_Name_1 := Pname;
14110 ("first formal of % function must be named `this`",
14111 Parent (This_Formal));
14113 elsif not Is_Access_Type (Etype (This_Formal)) then
14114 Error_Msg_Name_1 := Pname;
14116 ("first formal of % function must be an access type",
14117 Parameter_Type (Parent (This_Formal)));
14119 -- For delegates the type of the first formal must be a
14120 -- named access-to-subprogram type (see previous example)
14122 elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type
14123 and then Ekind (Etype (This_Formal))
14124 /= E_Access_Subprogram_Type
14126 Error_Msg_Name_1 := Pname;
14128 ("first formal of % function must be a named access "
14129 & "to subprogram type",
14130 Parameter_Type (Parent (This_Formal)));
14132 -- Warning: We should reject anonymous access types because
14133 -- the constructor must not be handled as a primitive of the
14134 -- tagged type. We temporarily allow it because this profile
14135 -- is currently generated by cil2ada???
14137 elsif Ekind (Etype (Def_Id)) /= E_Access_Subprogram_Type
14138 and then not Ekind_In (Etype (This_Formal),
14140 E_General_Access_Type,
14141 E_Anonymous_Access_Type)
14143 Error_Msg_Name_1 := Pname;
14145 ("first formal of % function must be a named access "
14146 & "type", Parameter_Type (Parent (This_Formal)));
14148 elsif Atree.Convention
14149 (Designated_Type (Etype (This_Formal))) /= Convention
14151 Error_Msg_Name_1 := Pname;
14153 if Convention = Convention_Java then
14155 ("pragma% requires convention 'Cil in designated "
14156 & "type", Parameter_Type (Parent (This_Formal)));
14159 ("pragma% requires convention 'Java in designated "
14160 & "type", Parameter_Type (Parent (This_Formal)));
14163 elsif No (Expression (Parent (This_Formal)))
14164 or else Nkind (Expression (Parent (This_Formal))) /= N_Null
14166 Error_Msg_Name_1 := Pname;
14168 ("pragma% requires first formal with default `null`",
14169 Parameter_Type (Parent (This_Formal)));
14173 -- Check result type: the constructor must be a function
14175 -- * a value type (only allowed in the CIL compiler)
14176 -- * an access-to-subprogram type with convention Java/CIL
14177 -- * an access-type designating a type that has convention
14180 if Is_Value_Type (Etype (Def_Id)) then
14183 -- Access-to-subprogram type with convention Java/CIL
14185 elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type then
14186 if Atree.Convention (Etype (Def_Id)) /= Convention then
14187 if Convention = Convention_Java then
14189 ("pragma% requires function returning a 'Java "
14190 & "access type", Arg1);
14192 pragma Assert (Convention = Convention_CIL);
14194 ("pragma% requires function returning a 'C'I'L "
14195 & "access type", Arg1);
14199 elsif Ekind (Etype (Def_Id)) in Access_Kind then
14200 if not Ekind_In (Etype (Def_Id), E_Access_Type,
14201 E_General_Access_Type)
14204 (Designated_Type (Etype (Def_Id))) /= Convention
14206 Error_Msg_Name_1 := Pname;
14208 if Convention = Convention_Java then
14210 ("pragma% requires function returning a named "
14211 & "'Java access type", Arg1);
14214 ("pragma% requires function returning a named "
14215 & "'C'I'L access type", Arg1);
14220 Set_Is_Constructor (Def_Id);
14221 Set_Convention (Def_Id, Convention);
14222 Set_Is_Imported (Def_Id);
14224 exit when From_Aspect_Specification (N);
14225 Hom_Id := Homonym (Hom_Id);
14227 exit when No (Hom_Id) or else Scope (Hom_Id) /= Current_Scope;
14229 end Java_Constructor;
14231 ----------------------
14232 -- Java_Interface --
14233 ----------------------
14235 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
14237 when Pragma_Java_Interface => Java_Interface : declare
14243 Check_Arg_Count (1);
14244 Check_Optional_Identifier (Arg1, Name_Entity);
14245 Check_Arg_Is_Local_Name (Arg1);
14247 Arg := Get_Pragma_Arg (Arg1);
14250 if Etype (Arg) = Any_Type then
14254 if not Is_Entity_Name (Arg)
14255 or else not Is_Type (Entity (Arg))
14257 Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
14260 Typ := Underlying_Type (Entity (Arg));
14262 -- For now simply check some of the semantic constraints on the
14263 -- type. This currently leaves out some restrictions on interface
14264 -- types, namely that the parent type must be java.lang.Object.Typ
14265 -- and that all primitives of the type should be declared
14268 if not Is_Tagged_Type (Typ) or else not Is_Abstract_Type (Typ) then
14270 ("pragma% requires an abstract tagged type", Arg1);
14272 elsif not Has_Discriminants (Typ)
14273 or else Ekind (Etype (First_Discriminant (Typ)))
14274 /= E_Anonymous_Access_Type
14276 not Is_Class_Wide_Type
14277 (Designated_Type (Etype (First_Discriminant (Typ))))
14280 ("type must have a class-wide access discriminant", Arg1);
14282 end Java_Interface;
14288 -- pragma Keep_Names ([On => ] local_NAME);
14290 when Pragma_Keep_Names => Keep_Names : declare
14295 Check_Arg_Count (1);
14296 Check_Optional_Identifier (Arg1, Name_On);
14297 Check_Arg_Is_Local_Name (Arg1);
14299 Arg := Get_Pragma_Arg (Arg1);
14302 if Etype (Arg) = Any_Type then
14306 if not Is_Entity_Name (Arg)
14307 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
14310 ("pragma% requires a local enumeration type", Arg1);
14313 Set_Discard_Names (Entity (Arg), False);
14320 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
14322 when Pragma_License =>
14324 Check_Arg_Count (1);
14325 Check_No_Identifiers;
14326 Check_Valid_Configuration_Pragma;
14327 Check_Arg_Is_Identifier (Arg1);
14330 Sind : constant Source_File_Index :=
14331 Source_Index (Current_Sem_Unit);
14334 case Chars (Get_Pragma_Arg (Arg1)) is
14336 Set_License (Sind, GPL);
14338 when Name_Modified_GPL =>
14339 Set_License (Sind, Modified_GPL);
14341 when Name_Restricted =>
14342 Set_License (Sind, Restricted);
14344 when Name_Unrestricted =>
14345 Set_License (Sind, Unrestricted);
14348 Error_Pragma_Arg ("invalid license name", Arg1);
14356 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
14358 when Pragma_Link_With => Link_With : declare
14364 if Operating_Mode = Generate_Code
14365 and then In_Extended_Main_Source_Unit (N)
14367 Check_At_Least_N_Arguments (1);
14368 Check_No_Identifiers;
14369 Check_Is_In_Decl_Part_Or_Package_Spec;
14370 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
14374 while Present (Arg) loop
14375 Check_Arg_Is_Static_Expression (Arg, Standard_String);
14377 -- Store argument, converting sequences of spaces to a
14378 -- single null character (this is one of the differences
14379 -- in processing between Link_With and Linker_Options).
14381 Arg_Store : declare
14382 C : constant Char_Code := Get_Char_Code (' ');
14383 S : constant String_Id :=
14384 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
14385 L : constant Nat := String_Length (S);
14388 procedure Skip_Spaces;
14389 -- Advance F past any spaces
14395 procedure Skip_Spaces is
14397 while F <= L and then Get_String_Char (S, F) = C loop
14402 -- Start of processing for Arg_Store
14405 Skip_Spaces; -- skip leading spaces
14407 -- Loop through characters, changing any embedded
14408 -- sequence of spaces to a single null character (this
14409 -- is how Link_With/Linker_Options differ)
14412 if Get_String_Char (S, F) = C then
14415 Store_String_Char (ASCII.NUL);
14418 Store_String_Char (Get_String_Char (S, F));
14426 if Present (Arg) then
14427 Store_String_Char (ASCII.NUL);
14431 Store_Linker_Option_String (End_String);
14439 -- pragma Linker_Alias (
14440 -- [Entity =>] LOCAL_NAME
14441 -- [Target =>] static_string_EXPRESSION);
14443 when Pragma_Linker_Alias =>
14445 Check_Arg_Order ((Name_Entity, Name_Target));
14446 Check_Arg_Count (2);
14447 Check_Optional_Identifier (Arg1, Name_Entity);
14448 Check_Optional_Identifier (Arg2, Name_Target);
14449 Check_Arg_Is_Library_Level_Local_Name (Arg1);
14450 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
14452 -- The only processing required is to link this item on to the
14453 -- list of rep items for the given entity. This is accomplished
14454 -- by the call to Rep_Item_Too_Late (when no error is detected
14455 -- and False is returned).
14457 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
14460 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
14463 ------------------------
14464 -- Linker_Constructor --
14465 ------------------------
14467 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
14469 -- Code is shared with Linker_Destructor
14471 -----------------------
14472 -- Linker_Destructor --
14473 -----------------------
14475 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
14477 when Pragma_Linker_Constructor |
14478 Pragma_Linker_Destructor =>
14479 Linker_Constructor : declare
14485 Check_Arg_Count (1);
14486 Check_No_Identifiers;
14487 Check_Arg_Is_Local_Name (Arg1);
14488 Arg1_X := Get_Pragma_Arg (Arg1);
14490 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
14492 if not Is_Library_Level_Entity (Proc) then
14494 ("argument for pragma% must be library level entity", Arg1);
14497 -- The only processing required is to link this item on to the
14498 -- list of rep items for the given entity. This is accomplished
14499 -- by the call to Rep_Item_Too_Late (when no error is detected
14500 -- and False is returned).
14502 if Rep_Item_Too_Late (Proc, N) then
14505 Set_Has_Gigi_Rep_Item (Proc);
14507 end Linker_Constructor;
14509 --------------------
14510 -- Linker_Options --
14511 --------------------
14513 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
14515 when Pragma_Linker_Options => Linker_Options : declare
14519 Check_Ada_83_Warning;
14520 Check_No_Identifiers;
14521 Check_Arg_Count (1);
14522 Check_Is_In_Decl_Part_Or_Package_Spec;
14523 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
14524 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
14527 while Present (Arg) loop
14528 Check_Arg_Is_Static_Expression (Arg, Standard_String);
14529 Store_String_Char (ASCII.NUL);
14531 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
14535 if Operating_Mode = Generate_Code
14536 and then In_Extended_Main_Source_Unit (N)
14538 Store_Linker_Option_String (End_String);
14540 end Linker_Options;
14542 --------------------
14543 -- Linker_Section --
14544 --------------------
14546 -- pragma Linker_Section (
14547 -- [Entity =>] LOCAL_NAME
14548 -- [Section =>] static_string_EXPRESSION);
14550 when Pragma_Linker_Section =>
14552 Check_Arg_Order ((Name_Entity, Name_Section));
14553 Check_Arg_Count (2);
14554 Check_Optional_Identifier (Arg1, Name_Entity);
14555 Check_Optional_Identifier (Arg2, Name_Section);
14556 Check_Arg_Is_Library_Level_Local_Name (Arg1);
14557 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
14559 -- This pragma applies to objects and types
14561 if not Is_Object (Entity (Get_Pragma_Arg (Arg1)))
14562 and then not Is_Type (Entity (Get_Pragma_Arg (Arg1)))
14565 ("pragma% applies only to objects and types", Arg1);
14568 -- The only processing required is to link this item on to the
14569 -- list of rep items for the given entity. This is accomplished
14570 -- by the call to Rep_Item_Too_Late (when no error is detected
14571 -- and False is returned).
14573 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
14576 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
14583 -- pragma List (On | Off)
14585 -- There is nothing to do here, since we did all the processing for
14586 -- this pragma in Par.Prag (so that it works properly even in syntax
14589 when Pragma_List =>
14596 -- pragma Lock_Free [(Boolean_EXPRESSION)];
14598 when Pragma_Lock_Free => Lock_Free : declare
14599 P : constant Node_Id := Parent (N);
14605 Check_No_Identifiers;
14606 Check_At_Most_N_Arguments (1);
14608 -- Protected definition case
14610 if Nkind (P) = N_Protected_Definition then
14611 Ent := Defining_Identifier (Parent (P));
14615 if Arg_Count = 1 then
14616 Arg := Get_Pragma_Arg (Arg1);
14617 Val := Is_True (Static_Boolean (Arg));
14619 -- No arguments (expression is considered to be True)
14625 -- Check duplicate pragma before we chain the pragma in the Rep
14626 -- Item chain of Ent.
14628 Check_Duplicate_Pragma (Ent);
14629 Record_Rep_Item (Ent, N);
14630 Set_Uses_Lock_Free (Ent, Val);
14632 -- Anything else is incorrect placement
14639 --------------------
14640 -- Locking_Policy --
14641 --------------------
14643 -- pragma Locking_Policy (policy_IDENTIFIER);
14645 when Pragma_Locking_Policy => declare
14646 subtype LP_Range is Name_Id
14647 range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
14652 Check_Ada_83_Warning;
14653 Check_Arg_Count (1);
14654 Check_No_Identifiers;
14655 Check_Arg_Is_Locking_Policy (Arg1);
14656 Check_Valid_Configuration_Pragma;
14657 LP_Val := Chars (Get_Pragma_Arg (Arg1));
14660 when Name_Ceiling_Locking =>
14662 when Name_Inheritance_Locking =>
14664 when Name_Concurrent_Readers_Locking =>
14668 if Locking_Policy /= ' '
14669 and then Locking_Policy /= LP
14671 Error_Msg_Sloc := Locking_Policy_Sloc;
14672 Error_Pragma ("locking policy incompatible with policy#");
14674 -- Set new policy, but always preserve System_Location since we
14675 -- like the error message with the run time name.
14678 Locking_Policy := LP;
14680 if Locking_Policy_Sloc /= System_Location then
14681 Locking_Policy_Sloc := Loc;
14690 -- pragma Long_Float (D_Float | G_Float);
14692 when Pragma_Long_Float => Long_Float : declare
14695 Check_Valid_Configuration_Pragma;
14696 Check_Arg_Count (1);
14697 Check_No_Identifier (Arg1);
14698 Check_Arg_Is_One_Of (Arg1, Name_D_Float, Name_G_Float);
14700 if not OpenVMS_On_Target then
14701 Error_Pragma ("??pragma% ignored (applies only to Open'V'M'S)");
14706 if Chars (Get_Pragma_Arg (Arg1)) = Name_D_Float then
14707 if Opt.Float_Format_Long = 'G' then
14709 ("G_Float previously specified", Arg1);
14711 elsif Current_Sem_Unit /= Main_Unit
14712 and then Opt.Float_Format_Long /= 'D'
14715 ("main unit not compiled with pragma Long_Float (D_Float)",
14716 "\pragma% must be used consistently for whole partition",
14720 Opt.Float_Format_Long := 'D';
14723 -- G_Float case (this is the default, does not need overriding)
14726 if Opt.Float_Format_Long = 'D' then
14727 Error_Pragma ("D_Float previously specified");
14729 elsif Current_Sem_Unit /= Main_Unit
14730 and then Opt.Float_Format_Long /= 'G'
14733 ("main unit not compiled with pragma Long_Float (G_Float)",
14734 "\pragma% must be used consistently for whole partition",
14738 Opt.Float_Format_Long := 'G';
14742 Set_Standard_Fpt_Formats;
14745 -------------------
14746 -- Loop_Optimize --
14747 -------------------
14749 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
14751 -- OPTIMIZATION_HINT ::= No_Unroll | Unroll | No_Vector | Vector
14753 when Pragma_Loop_Optimize => Loop_Optimize : declare
14758 Check_At_Least_N_Arguments (1);
14759 Check_No_Identifiers;
14761 Hint := First (Pragma_Argument_Associations (N));
14762 while Present (Hint) loop
14763 Check_Arg_Is_One_Of (Hint,
14764 Name_No_Unroll, Name_Unroll, Name_No_Vector, Name_Vector);
14768 Check_Loop_Pragma_Placement;
14775 -- pragma Loop_Variant
14776 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
14778 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
14780 -- CHANGE_DIRECTION ::= Increases | Decreases
14782 when Pragma_Loop_Variant => Loop_Variant : declare
14787 Check_At_Least_N_Arguments (1);
14788 Check_Loop_Pragma_Placement;
14790 -- Process all increasing / decreasing expressions
14792 Variant := First (Pragma_Argument_Associations (N));
14793 while Present (Variant) loop
14794 if not Nam_In (Chars (Variant), Name_Decreases,
14797 Error_Pragma_Arg ("wrong change modifier", Variant);
14800 Preanalyze_Assert_Expression
14801 (Expression (Variant), Any_Discrete);
14807 -----------------------
14808 -- Machine_Attribute --
14809 -----------------------
14811 -- pragma Machine_Attribute (
14812 -- [Entity =>] LOCAL_NAME,
14813 -- [Attribute_Name =>] static_string_EXPRESSION
14814 -- [, [Info =>] static_EXPRESSION] );
14816 when Pragma_Machine_Attribute => Machine_Attribute : declare
14817 Def_Id : Entity_Id;
14821 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
14823 if Arg_Count = 3 then
14824 Check_Optional_Identifier (Arg3, Name_Info);
14825 Check_Arg_Is_Static_Expression (Arg3);
14827 Check_Arg_Count (2);
14830 Check_Optional_Identifier (Arg1, Name_Entity);
14831 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
14832 Check_Arg_Is_Local_Name (Arg1);
14833 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
14834 Def_Id := Entity (Get_Pragma_Arg (Arg1));
14836 if Is_Access_Type (Def_Id) then
14837 Def_Id := Designated_Type (Def_Id);
14840 if Rep_Item_Too_Early (Def_Id, N) then
14844 Def_Id := Underlying_Type (Def_Id);
14846 -- The only processing required is to link this item on to the
14847 -- list of rep items for the given entity. This is accomplished
14848 -- by the call to Rep_Item_Too_Late (when no error is detected
14849 -- and False is returned).
14851 if Rep_Item_Too_Late (Def_Id, N) then
14854 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
14856 end Machine_Attribute;
14863 -- (MAIN_OPTION [, MAIN_OPTION]);
14866 -- [STACK_SIZE =>] static_integer_EXPRESSION
14867 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
14868 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
14870 when Pragma_Main => Main : declare
14871 Args : Args_List (1 .. 3);
14872 Names : constant Name_List (1 .. 3) := (
14874 Name_Task_Stack_Size_Default,
14875 Name_Time_Slicing_Enabled);
14881 Gather_Associations (Names, Args);
14883 for J in 1 .. 2 loop
14884 if Present (Args (J)) then
14885 Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
14889 if Present (Args (3)) then
14890 Check_Arg_Is_Static_Expression (Args (3), Standard_Boolean);
14894 while Present (Nod) loop
14895 if Nkind (Nod) = N_Pragma
14896 and then Pragma_Name (Nod) = Name_Main
14898 Error_Msg_Name_1 := Pname;
14899 Error_Msg_N ("duplicate pragma% not permitted", Nod);
14910 -- pragma Main_Storage
14911 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
14913 -- MAIN_STORAGE_OPTION ::=
14914 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
14915 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
14917 when Pragma_Main_Storage => Main_Storage : declare
14918 Args : Args_List (1 .. 2);
14919 Names : constant Name_List (1 .. 2) := (
14920 Name_Working_Storage,
14927 Gather_Associations (Names, Args);
14929 for J in 1 .. 2 loop
14930 if Present (Args (J)) then
14931 Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
14935 Check_In_Main_Program;
14938 while Present (Nod) loop
14939 if Nkind (Nod) = N_Pragma
14940 and then Pragma_Name (Nod) = Name_Main_Storage
14942 Error_Msg_Name_1 := Pname;
14943 Error_Msg_N ("duplicate pragma% not permitted", Nod);
14954 -- pragma Memory_Size (NUMERIC_LITERAL)
14956 when Pragma_Memory_Size =>
14959 -- Memory size is simply ignored
14961 Check_No_Identifiers;
14962 Check_Arg_Count (1);
14963 Check_Arg_Is_Integer_Literal (Arg1);
14971 -- The only correct use of this pragma is on its own in a file, in
14972 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
14973 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
14974 -- check for a file containing nothing but a No_Body pragma). If we
14975 -- attempt to process it during normal semantics processing, it means
14976 -- it was misplaced.
14978 when Pragma_No_Body =>
14986 -- pragma No_Inline ( NAME {, NAME} );
14988 when Pragma_No_Inline =>
14990 Process_Inline (Suppressed);
14996 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
14998 when Pragma_No_Return => No_Return : declare
15006 Check_At_Least_N_Arguments (1);
15008 -- Loop through arguments of pragma
15011 while Present (Arg) loop
15012 Check_Arg_Is_Local_Name (Arg);
15013 Id := Get_Pragma_Arg (Arg);
15016 if not Is_Entity_Name (Id) then
15017 Error_Pragma_Arg ("entity name required", Arg);
15020 if Etype (Id) = Any_Type then
15024 -- Loop to find matching procedures
15029 and then Scope (E) = Current_Scope
15031 if Ekind_In (E, E_Procedure, E_Generic_Procedure) then
15034 -- Set flag on any alias as well
15036 if Is_Overloadable (E) and then Present (Alias (E)) then
15037 Set_No_Return (Alias (E));
15043 exit when From_Aspect_Specification (N);
15048 Error_Pragma_Arg ("no procedure & found for pragma%", Arg);
15059 -- pragma No_Run_Time;
15061 -- Note: this pragma is retained for backwards compatibility. See
15062 -- body of Rtsfind for full details on its handling.
15064 when Pragma_No_Run_Time =>
15066 Check_Valid_Configuration_Pragma;
15067 Check_Arg_Count (0);
15069 No_Run_Time_Mode := True;
15070 Configurable_Run_Time_Mode := True;
15072 -- Set Duration to 32 bits if word size is 32
15074 if Ttypes.System_Word_Size = 32 then
15075 Duration_32_Bits_On_Target := True;
15078 -- Set appropriate restrictions
15080 Set_Restriction (No_Finalization, N);
15081 Set_Restriction (No_Exception_Handlers, N);
15082 Set_Restriction (Max_Tasks, N, 0);
15083 Set_Restriction (No_Tasking, N);
15085 ------------------------
15086 -- No_Strict_Aliasing --
15087 ------------------------
15089 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
15091 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
15096 Check_At_Most_N_Arguments (1);
15098 if Arg_Count = 0 then
15099 Check_Valid_Configuration_Pragma;
15100 Opt.No_Strict_Aliasing := True;
15103 Check_Optional_Identifier (Arg2, Name_Entity);
15104 Check_Arg_Is_Local_Name (Arg1);
15105 E_Id := Entity (Get_Pragma_Arg (Arg1));
15107 if E_Id = Any_Type then
15109 elsif No (E_Id) or else not Is_Access_Type (E_Id) then
15110 Error_Pragma_Arg ("pragma% requires access type", Arg1);
15113 Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id));
15115 end No_Strict_Aliasing;
15117 -----------------------
15118 -- Normalize_Scalars --
15119 -----------------------
15121 -- pragma Normalize_Scalars;
15123 when Pragma_Normalize_Scalars =>
15124 Check_Ada_83_Warning;
15125 Check_Arg_Count (0);
15126 Check_Valid_Configuration_Pragma;
15128 -- Normalize_Scalars creates false positives in CodePeer, and
15129 -- incorrect negative results in SPARK mode, so ignore this pragma
15132 if not (CodePeer_Mode or SPARK_Mode) then
15133 Normalize_Scalars := True;
15134 Init_Or_Norm_Scalars := True;
15141 -- pragma Obsolescent;
15143 -- pragma Obsolescent (
15144 -- [Message =>] static_string_EXPRESSION
15145 -- [,[Version =>] Ada_05]]);
15147 -- pragma Obsolescent (
15148 -- [Entity =>] NAME
15149 -- [,[Message =>] static_string_EXPRESSION
15150 -- [,[Version =>] Ada_05]] );
15152 when Pragma_Obsolescent => Obsolescent : declare
15156 procedure Set_Obsolescent (E : Entity_Id);
15157 -- Given an entity Ent, mark it as obsolescent if appropriate
15159 ---------------------
15160 -- Set_Obsolescent --
15161 ---------------------
15163 procedure Set_Obsolescent (E : Entity_Id) is
15172 -- Entity name was given
15174 if Present (Ename) then
15176 -- If entity name matches, we are fine. Save entity in
15177 -- pragma argument, for ASIS use.
15179 if Chars (Ename) = Chars (Ent) then
15180 Set_Entity (Ename, Ent);
15181 Generate_Reference (Ent, Ename);
15183 -- If entity name does not match, only possibility is an
15184 -- enumeration literal from an enumeration type declaration.
15186 elsif Ekind (Ent) /= E_Enumeration_Type then
15188 ("pragma % entity name does not match declaration");
15191 Ent := First_Literal (E);
15195 ("pragma % entity name does not match any "
15196 & "enumeration literal");
15198 elsif Chars (Ent) = Chars (Ename) then
15199 Set_Entity (Ename, Ent);
15200 Generate_Reference (Ent, Ename);
15204 Ent := Next_Literal (Ent);
15210 -- Ent points to entity to be marked
15212 if Arg_Count >= 1 then
15214 -- Deal with static string argument
15216 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
15217 S := Strval (Get_Pragma_Arg (Arg1));
15219 for J in 1 .. String_Length (S) loop
15220 if not In_Character_Range (Get_String_Char (S, J)) then
15222 ("pragma% argument does not allow wide characters",
15227 Obsolescent_Warnings.Append
15228 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
15230 -- Check for Ada_05 parameter
15232 if Arg_Count /= 1 then
15233 Check_Arg_Count (2);
15236 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
15239 Check_Arg_Is_Identifier (Argx);
15241 if Chars (Argx) /= Name_Ada_05 then
15242 Error_Msg_Name_2 := Name_Ada_05;
15244 ("only allowed argument for pragma% is %", Argx);
15247 if Ada_Version_Explicit < Ada_2005
15248 or else not Warn_On_Ada_2005_Compatibility
15256 -- Set flag if pragma active
15259 Set_Is_Obsolescent (Ent);
15263 end Set_Obsolescent;
15265 -- Start of processing for pragma Obsolescent
15270 Check_At_Most_N_Arguments (3);
15272 -- See if first argument specifies an entity name
15276 (Chars (Arg1) = Name_Entity
15278 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
15280 N_Operator_Symbol))
15282 Ename := Get_Pragma_Arg (Arg1);
15284 -- Eliminate first argument, so we can share processing
15288 Arg_Count := Arg_Count - 1;
15290 -- No Entity name argument given
15296 if Arg_Count >= 1 then
15297 Check_Optional_Identifier (Arg1, Name_Message);
15299 if Arg_Count = 2 then
15300 Check_Optional_Identifier (Arg2, Name_Version);
15304 -- Get immediately preceding declaration
15307 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
15311 -- Cases where we do not follow anything other than another pragma
15315 -- First case: library level compilation unit declaration with
15316 -- the pragma immediately following the declaration.
15318 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
15320 (Defining_Entity (Unit (Parent (Parent (N)))));
15323 -- Case 2: library unit placement for package
15327 Ent : constant Entity_Id := Find_Lib_Unit_Name;
15329 if Is_Package_Or_Generic_Package (Ent) then
15330 Set_Obsolescent (Ent);
15336 -- Cases where we must follow a declaration
15339 if Nkind (Decl) not in N_Declaration
15340 and then Nkind (Decl) not in N_Later_Decl_Item
15341 and then Nkind (Decl) not in N_Generic_Declaration
15342 and then Nkind (Decl) not in N_Renaming_Declaration
15345 ("pragma% misplaced, "
15346 & "must immediately follow a declaration");
15349 Set_Obsolescent (Defining_Entity (Decl));
15359 -- pragma Optimize (Time | Space | Off);
15361 -- The actual check for optimize is done in Gigi. Note that this
15362 -- pragma does not actually change the optimization setting, it
15363 -- simply checks that it is consistent with the pragma.
15365 when Pragma_Optimize =>
15366 Check_No_Identifiers;
15367 Check_Arg_Count (1);
15368 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
15370 ------------------------
15371 -- Optimize_Alignment --
15372 ------------------------
15374 -- pragma Optimize_Alignment (Time | Space | Off);
15376 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
15378 Check_No_Identifiers;
15379 Check_Arg_Count (1);
15380 Check_Valid_Configuration_Pragma;
15383 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
15387 Opt.Optimize_Alignment := 'T';
15389 Opt.Optimize_Alignment := 'S';
15391 Opt.Optimize_Alignment := 'O';
15393 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
15397 -- Set indication that mode is set locally. If we are in fact in a
15398 -- configuration pragma file, this setting is harmless since the
15399 -- switch will get reset anyway at the start of each unit.
15401 Optimize_Alignment_Local := True;
15402 end Optimize_Alignment;
15408 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
15410 when Pragma_Ordered => Ordered : declare
15411 Assoc : constant Node_Id := Arg1;
15417 Check_No_Identifiers;
15418 Check_Arg_Count (1);
15419 Check_Arg_Is_Local_Name (Arg1);
15421 Type_Id := Get_Pragma_Arg (Assoc);
15422 Find_Type (Type_Id);
15423 Typ := Entity (Type_Id);
15425 if Typ = Any_Type then
15428 Typ := Underlying_Type (Typ);
15431 if not Is_Enumeration_Type (Typ) then
15432 Error_Pragma ("pragma% must specify enumeration type");
15435 Check_First_Subtype (Arg1);
15436 Set_Has_Pragma_Ordered (Base_Type (Typ));
15439 -------------------
15440 -- Overflow_Mode --
15441 -------------------
15443 -- pragma Overflow_Mode
15444 -- ([General => ] MODE [, [Assertions => ] MODE]);
15446 -- MODE := STRICT | MINIMIZED | ELIMINATED
15448 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
15449 -- since System.Bignums makes this assumption. This is true of nearly
15450 -- all (all?) targets.
15452 when Pragma_Overflow_Mode => Overflow_Mode : declare
15453 function Get_Overflow_Mode
15455 Arg : Node_Id) return Overflow_Mode_Type;
15456 -- Function to process one pragma argument, Arg. If an identifier
15457 -- is present, it must be Name. Mode type is returned if a valid
15458 -- argument exists, otherwise an error is signalled.
15460 -----------------------
15461 -- Get_Overflow_Mode --
15462 -----------------------
15464 function Get_Overflow_Mode
15466 Arg : Node_Id) return Overflow_Mode_Type
15468 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
15471 Check_Optional_Identifier (Arg, Name);
15472 Check_Arg_Is_Identifier (Argx);
15474 if Chars (Argx) = Name_Strict then
15477 elsif Chars (Argx) = Name_Minimized then
15480 elsif Chars (Argx) = Name_Eliminated then
15481 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then
15483 ("Eliminated not implemented on this target", Argx);
15489 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
15491 end Get_Overflow_Mode;
15493 -- Start of processing for Overflow_Mode
15497 Check_At_Least_N_Arguments (1);
15498 Check_At_Most_N_Arguments (2);
15500 -- Process first argument
15502 Scope_Suppress.Overflow_Mode_General :=
15503 Get_Overflow_Mode (Name_General, Arg1);
15505 -- Case of only one argument
15507 if Arg_Count = 1 then
15508 Scope_Suppress.Overflow_Mode_Assertions :=
15509 Scope_Suppress.Overflow_Mode_General;
15511 -- Case of two arguments present
15514 Scope_Suppress.Overflow_Mode_Assertions :=
15515 Get_Overflow_Mode (Name_Assertions, Arg2);
15519 --------------------------
15520 -- Overriding Renamings --
15521 --------------------------
15523 -- pragma Overriding_Renamings;
15525 when Pragma_Overriding_Renamings =>
15527 Check_Arg_Count (0);
15528 Check_Valid_Configuration_Pragma;
15529 Overriding_Renamings := True;
15535 -- pragma Pack (first_subtype_LOCAL_NAME);
15537 when Pragma_Pack => Pack : declare
15538 Assoc : constant Node_Id := Arg1;
15542 Ignore : Boolean := False;
15545 Check_No_Identifiers;
15546 Check_Arg_Count (1);
15547 Check_Arg_Is_Local_Name (Arg1);
15549 Type_Id := Get_Pragma_Arg (Assoc);
15550 Find_Type (Type_Id);
15551 Typ := Entity (Type_Id);
15554 or else Rep_Item_Too_Early (Typ, N)
15558 Typ := Underlying_Type (Typ);
15561 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
15562 Error_Pragma ("pragma% must specify array or record type");
15565 Check_First_Subtype (Arg1);
15566 Check_Duplicate_Pragma (Typ);
15570 if Is_Array_Type (Typ) then
15571 Ctyp := Component_Type (Typ);
15573 -- Ignore pack that does nothing
15575 if Known_Static_Esize (Ctyp)
15576 and then Known_Static_RM_Size (Ctyp)
15577 and then Esize (Ctyp) = RM_Size (Ctyp)
15578 and then Addressable (Esize (Ctyp))
15583 -- Process OK pragma Pack. Note that if there is a separate
15584 -- component clause present, the Pack will be cancelled. This
15585 -- processing is in Freeze.
15587 if not Rep_Item_Too_Late (Typ, N) then
15589 -- In the context of static code analysis, we do not need
15590 -- complex front-end expansions related to pragma Pack,
15591 -- so disable handling of pragma Pack in these cases.
15593 if CodePeer_Mode or SPARK_Mode then
15596 -- Don't attempt any packing for VM targets. We possibly
15597 -- could deal with some cases of array bit-packing, but we
15598 -- don't bother, since this is not a typical kind of
15599 -- representation in the VM context anyway (and would not
15600 -- for example work nicely with the debugger).
15602 elsif VM_Target /= No_VM then
15603 if not GNAT_Mode then
15605 ("??pragma% ignored in this configuration");
15608 -- Normal case where we do the pack action
15612 Set_Is_Packed (Base_Type (Typ));
15613 Set_Has_Non_Standard_Rep (Base_Type (Typ));
15616 Set_Has_Pragma_Pack (Base_Type (Typ));
15620 -- For record types, the pack is always effective
15622 else pragma Assert (Is_Record_Type (Typ));
15623 if not Rep_Item_Too_Late (Typ, N) then
15625 -- Ignore pack request with warning in VM mode (skip warning
15626 -- if we are compiling GNAT run time library).
15628 if VM_Target /= No_VM then
15629 if not GNAT_Mode then
15631 ("??pragma% ignored in this configuration");
15634 -- Normal case of pack request active
15637 Set_Is_Packed (Base_Type (Typ));
15638 Set_Has_Pragma_Pack (Base_Type (Typ));
15639 Set_Has_Non_Standard_Rep (Base_Type (Typ));
15651 -- There is nothing to do here, since we did all the processing for
15652 -- this pragma in Par.Prag (so that it works properly even in syntax
15655 when Pragma_Page =>
15658 ----------------------------------
15659 -- Partition_Elaboration_Policy --
15660 ----------------------------------
15662 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
15664 when Pragma_Partition_Elaboration_Policy => declare
15665 subtype PEP_Range is Name_Id
15666 range First_Partition_Elaboration_Policy_Name
15667 .. Last_Partition_Elaboration_Policy_Name;
15668 PEP_Val : PEP_Range;
15673 Check_Arg_Count (1);
15674 Check_No_Identifiers;
15675 Check_Arg_Is_Partition_Elaboration_Policy (Arg1);
15676 Check_Valid_Configuration_Pragma;
15677 PEP_Val := Chars (Get_Pragma_Arg (Arg1));
15680 when Name_Concurrent =>
15682 when Name_Sequential =>
15686 if Partition_Elaboration_Policy /= ' '
15687 and then Partition_Elaboration_Policy /= PEP
15689 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc;
15691 ("partition elaboration policy incompatible with policy#");
15693 -- Set new policy, but always preserve System_Location since we
15694 -- like the error message with the run time name.
15697 Partition_Elaboration_Policy := PEP;
15699 if Partition_Elaboration_Policy_Sloc /= System_Location then
15700 Partition_Elaboration_Policy_Sloc := Loc;
15709 -- pragma Passive [(PASSIVE_FORM)];
15711 -- PASSIVE_FORM ::= Semaphore | No
15713 when Pragma_Passive =>
15716 if Nkind (Parent (N)) /= N_Task_Definition then
15717 Error_Pragma ("pragma% must be within task definition");
15720 if Arg_Count /= 0 then
15721 Check_Arg_Count (1);
15722 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
15725 ----------------------------------
15726 -- Preelaborable_Initialization --
15727 ----------------------------------
15729 -- pragma Preelaborable_Initialization (DIRECT_NAME);
15731 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
15736 Check_Arg_Count (1);
15737 Check_No_Identifiers;
15738 Check_Arg_Is_Identifier (Arg1);
15739 Check_Arg_Is_Local_Name (Arg1);
15740 Check_First_Subtype (Arg1);
15741 Ent := Entity (Get_Pragma_Arg (Arg1));
15743 -- The pragma may come from an aspect on a private declaration,
15744 -- even if the freeze point at which this is analyzed in the
15745 -- private part after the full view.
15747 if Has_Private_Declaration (Ent)
15748 and then From_Aspect_Specification (N)
15752 elsif Is_Private_Type (Ent)
15753 or else Is_Protected_Type (Ent)
15754 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))
15760 ("pragma % can only be applied to private, formal derived or "
15761 & "protected type",
15765 -- Give an error if the pragma is applied to a protected type that
15766 -- does not qualify (due to having entries, or due to components
15767 -- that do not qualify).
15769 if Is_Protected_Type (Ent)
15770 and then not Has_Preelaborable_Initialization (Ent)
15773 ("protected type & does not have preelaborable "
15774 & "initialization", Ent);
15776 -- Otherwise mark the type as definitely having preelaborable
15780 Set_Known_To_Have_Preelab_Init (Ent);
15783 if Has_Pragma_Preelab_Init (Ent)
15784 and then Warn_On_Redundant_Constructs
15786 Error_Pragma ("?r?duplicate pragma%!");
15788 Set_Has_Pragma_Preelab_Init (Ent);
15792 --------------------
15793 -- Persistent_BSS --
15794 --------------------
15796 -- pragma Persistent_BSS [(object_NAME)];
15798 when Pragma_Persistent_BSS => Persistent_BSS : declare
15805 Check_At_Most_N_Arguments (1);
15807 -- Case of application to specific object (one argument)
15809 if Arg_Count = 1 then
15810 Check_Arg_Is_Library_Level_Local_Name (Arg1);
15812 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
15814 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
15817 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
15820 Ent := Entity (Get_Pragma_Arg (Arg1));
15821 Decl := Parent (Ent);
15823 -- Check for duplication before inserting in list of
15824 -- representation items.
15826 Check_Duplicate_Pragma (Ent);
15828 if Rep_Item_Too_Late (Ent, N) then
15832 if Present (Expression (Decl)) then
15834 ("object for pragma% cannot have initialization", Arg1);
15837 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
15839 ("object type for pragma% is not potentially persistent",
15844 Make_Linker_Section_Pragma
15845 (Ent, Sloc (N), ".persistent.bss");
15846 Insert_After (N, Prag);
15849 -- Case of use as configuration pragma with no arguments
15852 Check_Valid_Configuration_Pragma;
15853 Persistent_BSS_Mode := True;
15855 end Persistent_BSS;
15861 -- pragma Polling (ON | OFF);
15863 when Pragma_Polling =>
15865 Check_Arg_Count (1);
15866 Check_No_Identifiers;
15867 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
15868 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
15874 -- pragma Post (Boolean_EXPRESSION);
15875 -- pragma Post_Class (Boolean_EXPRESSION);
15877 when Pragma_Post | Pragma_Post_Class => Post : declare
15878 PC_Pragma : Node_Id;
15882 Check_Arg_Count (1);
15883 Check_No_Identifiers;
15886 -- Rewrite Post[_Class] pragma as Precondition pragma setting the
15887 -- flag Class_Present to True for the Post_Class case.
15889 Set_Class_Present (N, Prag_Id = Pragma_Pre_Class);
15890 PC_Pragma := New_Copy (N);
15891 Set_Pragma_Identifier
15892 (PC_Pragma, Make_Identifier (Loc, Name_Postcondition));
15893 Rewrite (N, PC_Pragma);
15894 Set_Analyzed (N, False);
15898 -------------------
15899 -- Postcondition --
15900 -------------------
15902 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
15903 -- [,[Message =>] String_EXPRESSION]);
15905 when Pragma_Postcondition => Postcondition : declare
15910 Check_At_Least_N_Arguments (1);
15911 Check_At_Most_N_Arguments (2);
15912 Check_Optional_Identifier (Arg1, Name_Check);
15914 -- Verify the proper placement of the pragma. The remainder of the
15915 -- processing is found in Sem_Ch6/Sem_Ch7.
15917 Check_Precondition_Postcondition (In_Body);
15919 -- When the pragma is a source construct appearing inside a body,
15920 -- preanalyze the boolean_expression to detect illegal forward
15924 -- pragma Postcondition (X'Old ...);
15927 if Comes_From_Source (N) and then In_Body then
15928 Preanalyze_Spec_Expression (Expression (Arg1), Any_Boolean);
15936 -- pragma Pre (Boolean_EXPRESSION);
15937 -- pragma Pre_Class (Boolean_EXPRESSION);
15939 when Pragma_Pre | Pragma_Pre_Class => Pre : declare
15940 PC_Pragma : Node_Id;
15944 Check_Arg_Count (1);
15945 Check_No_Identifiers;
15948 -- Rewrite Pre[_Class] pragma as Precondition pragma setting the
15949 -- flag Class_Present to True for the Pre_Class case.
15951 Set_Class_Present (N, Prag_Id = Pragma_Pre_Class);
15952 PC_Pragma := New_Copy (N);
15953 Set_Pragma_Identifier
15954 (PC_Pragma, Make_Identifier (Loc, Name_Precondition));
15955 Rewrite (N, PC_Pragma);
15956 Set_Analyzed (N, False);
15964 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
15965 -- [,[Message =>] String_EXPRESSION]);
15967 when Pragma_Precondition => Precondition : declare
15972 Check_At_Least_N_Arguments (1);
15973 Check_At_Most_N_Arguments (2);
15974 Check_Optional_Identifier (Arg1, Name_Check);
15975 Check_Precondition_Postcondition (In_Body);
15977 -- If in spec, nothing more to do. If in body, then we convert
15978 -- the pragma to an equivalent pragma Check. That works fine since
15979 -- pragma Check will analyze the condition in the proper context.
15981 -- The form of the pragma Check is either:
15983 -- pragma Check (Precondition, cond [, msg])
15985 -- pragma Check (Pre, cond [, msg])
15987 -- We use the Pre form if this pragma derived from a Pre aspect.
15988 -- This is needed to make sure that the right set of Policy
15989 -- pragmas are checked.
15993 -- Rewrite as Check pragma
15997 Chars => Name_Check,
15998 Pragma_Argument_Associations => New_List (
15999 Make_Pragma_Argument_Association (Loc,
16000 Expression => Make_Identifier (Loc, Pname)),
16002 Make_Pragma_Argument_Association (Sloc (Arg1),
16004 Relocate_Node (Get_Pragma_Arg (Arg1))))));
16006 if Arg_Count = 2 then
16007 Append_To (Pragma_Argument_Associations (N),
16008 Make_Pragma_Argument_Association (Sloc (Arg2),
16010 Relocate_Node (Get_Pragma_Arg (Arg2))));
16021 -- pragma Predicate
16022 -- ([Entity =>] type_LOCAL_NAME,
16023 -- [Check =>] boolean_EXPRESSION);
16025 when Pragma_Predicate => Predicate : declare
16030 pragma Unreferenced (Discard);
16034 Check_Arg_Count (2);
16035 Check_Optional_Identifier (Arg1, Name_Entity);
16036 Check_Optional_Identifier (Arg2, Name_Check);
16038 Check_Arg_Is_Local_Name (Arg1);
16040 Type_Id := Get_Pragma_Arg (Arg1);
16041 Find_Type (Type_Id);
16042 Typ := Entity (Type_Id);
16044 if Typ = Any_Type then
16048 -- The remaining processing is simply to link the pragma on to
16049 -- the rep item chain, for processing when the type is frozen.
16050 -- This is accomplished by a call to Rep_Item_Too_Late. We also
16051 -- mark the type as having predicates.
16053 Set_Has_Predicates (Typ);
16054 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
16061 -- pragma Preelaborate [(library_unit_NAME)];
16063 -- Set the flag Is_Preelaborated of program unit name entity
16065 when Pragma_Preelaborate => Preelaborate : declare
16066 Pa : constant Node_Id := Parent (N);
16067 Pk : constant Node_Kind := Nkind (Pa);
16071 Check_Ada_83_Warning;
16072 Check_Valid_Library_Unit_Pragma;
16074 if Nkind (N) = N_Null_Statement then
16078 Ent := Find_Lib_Unit_Name;
16079 Check_Duplicate_Pragma (Ent);
16081 -- This filters out pragmas inside generic parents that show up
16082 -- inside instantiations. Pragmas that come from aspects in the
16083 -- unit are not ignored.
16085 if Present (Ent) then
16086 if Pk = N_Package_Specification
16087 and then Present (Generic_Parent (Pa))
16088 and then not From_Aspect_Specification (N)
16093 if not Debug_Flag_U then
16094 Set_Is_Preelaborated (Ent);
16095 Set_Suppress_Elaboration_Warnings (Ent);
16101 ---------------------
16102 -- Preelaborate_05 --
16103 ---------------------
16105 -- pragma Preelaborate_05 [(library_unit_NAME)];
16107 -- This pragma is useable only in GNAT_Mode, where it is used like
16108 -- pragma Preelaborate but it is only effective in Ada 2005 mode
16109 -- (otherwise it is ignored). This is used to implement AI-362 which
16110 -- recategorizes some run-time packages in Ada 2005 mode.
16112 when Pragma_Preelaborate_05 => Preelaborate_05 : declare
16117 Check_Valid_Library_Unit_Pragma;
16119 if not GNAT_Mode then
16120 Error_Pragma ("pragma% only available in GNAT mode");
16123 if Nkind (N) = N_Null_Statement then
16127 -- This is one of the few cases where we need to test the value of
16128 -- Ada_Version_Explicit rather than Ada_Version (which is always
16129 -- set to Ada_2012 in a predefined unit), we need to know the
16130 -- explicit version set to know if this pragma is active.
16132 if Ada_Version_Explicit >= Ada_2005 then
16133 Ent := Find_Lib_Unit_Name;
16134 Set_Is_Preelaborated (Ent);
16135 Set_Suppress_Elaboration_Warnings (Ent);
16137 end Preelaborate_05;
16143 -- pragma Priority (EXPRESSION);
16145 when Pragma_Priority => Priority : declare
16146 P : constant Node_Id := Parent (N);
16151 Check_No_Identifiers;
16152 Check_Arg_Count (1);
16156 if Nkind (P) = N_Subprogram_Body then
16157 Check_In_Main_Program;
16159 Ent := Defining_Unit_Name (Specification (P));
16161 if Nkind (Ent) = N_Defining_Program_Unit_Name then
16162 Ent := Defining_Identifier (Ent);
16165 Arg := Get_Pragma_Arg (Arg1);
16166 Analyze_And_Resolve (Arg, Standard_Integer);
16170 if not Is_Static_Expression (Arg) then
16171 Flag_Non_Static_Expr
16172 ("main subprogram priority is not static!", Arg);
16175 -- If constraint error, then we already signalled an error
16177 elsif Raises_Constraint_Error (Arg) then
16180 -- Otherwise check in range
16184 Val : constant Uint := Expr_Value (Arg);
16188 or else Val > Expr_Value (Expression
16189 (Parent (RTE (RE_Max_Priority))))
16192 ("main subprogram priority is out of range", Arg1);
16198 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
16200 -- Load an arbitrary entity from System.Tasking.Stages or
16201 -- System.Tasking.Restricted.Stages (depending on the
16202 -- supported profile) to make sure that one of these packages
16203 -- is implicitly with'ed, since we need to have the tasking
16204 -- run time active for the pragma Priority to have any effect.
16205 -- Previously with with'ed the package System.Tasking, but
16206 -- this package does not trigger the required initialization
16207 -- of the run-time library.
16210 Discard : Entity_Id;
16211 pragma Warnings (Off, Discard);
16213 if Restricted_Profile then
16214 Discard := RTE (RE_Activate_Restricted_Tasks);
16216 Discard := RTE (RE_Activate_Tasks);
16220 -- Task or Protected, must be of type Integer
16222 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
16223 Arg := Get_Pragma_Arg (Arg1);
16224 Ent := Defining_Identifier (Parent (P));
16226 -- The expression must be analyzed in the special manner
16227 -- described in "Handling of Default and Per-Object
16228 -- Expressions" in sem.ads.
16230 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority));
16232 if not Is_Static_Expression (Arg) then
16233 Check_Restriction (Static_Priorities, Arg);
16236 -- Anything else is incorrect
16242 -- Check duplicate pragma before we chain the pragma in the Rep
16243 -- Item chain of Ent.
16245 Check_Duplicate_Pragma (Ent);
16246 Record_Rep_Item (Ent, N);
16249 -----------------------------------
16250 -- Priority_Specific_Dispatching --
16251 -----------------------------------
16253 -- pragma Priority_Specific_Dispatching (
16254 -- policy_IDENTIFIER,
16255 -- first_priority_EXPRESSION,
16256 -- last_priority_EXPRESSION);
16258 when Pragma_Priority_Specific_Dispatching =>
16259 Priority_Specific_Dispatching : declare
16260 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
16261 -- This is the entity System.Any_Priority;
16264 Lower_Bound : Node_Id;
16265 Upper_Bound : Node_Id;
16271 Check_Arg_Count (3);
16272 Check_No_Identifiers;
16273 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
16274 Check_Valid_Configuration_Pragma;
16275 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
16276 DP := Fold_Upper (Name_Buffer (1));
16278 Lower_Bound := Get_Pragma_Arg (Arg2);
16279 Check_Arg_Is_Static_Expression (Lower_Bound, Standard_Integer);
16280 Lower_Val := Expr_Value (Lower_Bound);
16282 Upper_Bound := Get_Pragma_Arg (Arg3);
16283 Check_Arg_Is_Static_Expression (Upper_Bound, Standard_Integer);
16284 Upper_Val := Expr_Value (Upper_Bound);
16286 -- It is not allowed to use Task_Dispatching_Policy and
16287 -- Priority_Specific_Dispatching in the same partition.
16289 if Task_Dispatching_Policy /= ' ' then
16290 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
16292 ("pragma% incompatible with Task_Dispatching_Policy#");
16294 -- Check lower bound in range
16296 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
16298 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
16301 ("first_priority is out of range", Arg2);
16303 -- Check upper bound in range
16305 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
16307 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
16310 ("last_priority is out of range", Arg3);
16312 -- Check that the priority range is valid
16314 elsif Lower_Val > Upper_Val then
16316 ("last_priority_expression must be greater than or equal to "
16317 & "first_priority_expression");
16319 -- Store the new policy, but always preserve System_Location since
16320 -- we like the error message with the run-time name.
16323 -- Check overlapping in the priority ranges specified in other
16324 -- Priority_Specific_Dispatching pragmas within the same
16325 -- partition. We can only check those we know about!
16328 Specific_Dispatching.First .. Specific_Dispatching.Last
16330 if Specific_Dispatching.Table (J).First_Priority in
16331 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
16332 or else Specific_Dispatching.Table (J).Last_Priority in
16333 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
16336 Specific_Dispatching.Table (J).Pragma_Loc;
16338 ("priority range overlaps with "
16339 & "Priority_Specific_Dispatching#");
16343 -- The use of Priority_Specific_Dispatching is incompatible
16344 -- with Task_Dispatching_Policy.
16346 if Task_Dispatching_Policy /= ' ' then
16347 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
16349 ("Priority_Specific_Dispatching incompatible "
16350 & "with Task_Dispatching_Policy#");
16353 -- The use of Priority_Specific_Dispatching forces ceiling
16356 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
16357 Error_Msg_Sloc := Locking_Policy_Sloc;
16359 ("Priority_Specific_Dispatching incompatible "
16360 & "with Locking_Policy#");
16362 -- Set the Ceiling_Locking policy, but preserve System_Location
16363 -- since we like the error message with the run time name.
16366 Locking_Policy := 'C';
16368 if Locking_Policy_Sloc /= System_Location then
16369 Locking_Policy_Sloc := Loc;
16373 -- Add entry in the table
16375 Specific_Dispatching.Append
16376 ((Dispatching_Policy => DP,
16377 First_Priority => UI_To_Int (Lower_Val),
16378 Last_Priority => UI_To_Int (Upper_Val),
16379 Pragma_Loc => Loc));
16381 end Priority_Specific_Dispatching;
16387 -- pragma Profile (profile_IDENTIFIER);
16389 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
16391 when Pragma_Profile =>
16393 Check_Arg_Count (1);
16394 Check_Valid_Configuration_Pragma;
16395 Check_No_Identifiers;
16398 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
16401 if Chars (Argx) = Name_Ravenscar then
16402 Set_Ravenscar_Profile (N);
16404 elsif Chars (Argx) = Name_Restricted then
16405 Set_Profile_Restrictions
16407 N, Warn => Treat_Restrictions_As_Warnings);
16409 elsif Chars (Argx) = Name_Rational then
16410 Set_Rational_Profile;
16412 elsif Chars (Argx) = Name_No_Implementation_Extensions then
16413 Set_Profile_Restrictions
16414 (No_Implementation_Extensions,
16415 N, Warn => Treat_Restrictions_As_Warnings);
16418 Error_Pragma_Arg ("& is not a valid profile", Argx);
16422 ----------------------
16423 -- Profile_Warnings --
16424 ----------------------
16426 -- pragma Profile_Warnings (profile_IDENTIFIER);
16428 -- profile_IDENTIFIER => Restricted | Ravenscar
16430 when Pragma_Profile_Warnings =>
16432 Check_Arg_Count (1);
16433 Check_Valid_Configuration_Pragma;
16434 Check_No_Identifiers;
16437 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
16440 if Chars (Argx) = Name_Ravenscar then
16441 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
16443 elsif Chars (Argx) = Name_Restricted then
16444 Set_Profile_Restrictions (Restricted, N, Warn => True);
16446 elsif Chars (Argx) = Name_No_Implementation_Extensions then
16447 Set_Profile_Restrictions
16448 (No_Implementation_Extensions, N, Warn => True);
16451 Error_Pragma_Arg ("& is not a valid profile", Argx);
16455 --------------------------
16456 -- Propagate_Exceptions --
16457 --------------------------
16459 -- pragma Propagate_Exceptions;
16461 -- Note: this pragma is obsolete and has no effect
16463 when Pragma_Propagate_Exceptions =>
16465 Check_Arg_Count (0);
16467 if Warn_On_Obsolescent_Feature then
16469 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
16470 "and has no effect?j?", N);
16477 -- pragma Psect_Object (
16478 -- [Internal =>] LOCAL_NAME,
16479 -- [, [External =>] EXTERNAL_SYMBOL]
16480 -- [, [Size =>] EXTERNAL_SYMBOL]);
16482 when Pragma_Psect_Object | Pragma_Common_Object =>
16483 Psect_Object : declare
16484 Args : Args_List (1 .. 3);
16485 Names : constant Name_List (1 .. 3) := (
16490 Internal : Node_Id renames Args (1);
16491 External : Node_Id renames Args (2);
16492 Size : Node_Id renames Args (3);
16494 Def_Id : Entity_Id;
16496 procedure Check_Too_Long (Arg : Node_Id);
16497 -- Posts message if the argument is an identifier with more
16498 -- than 31 characters, or a string literal with more than
16499 -- 31 characters, and we are operating under VMS
16501 --------------------
16502 -- Check_Too_Long --
16503 --------------------
16505 procedure Check_Too_Long (Arg : Node_Id) is
16506 X : constant Node_Id := Original_Node (Arg);
16509 if not Nkind_In (X, N_String_Literal, N_Identifier) then
16511 ("inappropriate argument for pragma %", Arg);
16514 if OpenVMS_On_Target then
16515 if (Nkind (X) = N_String_Literal
16516 and then String_Length (Strval (X)) > 31)
16518 (Nkind (X) = N_Identifier
16519 and then Length_Of_Name (Chars (X)) > 31)
16522 ("argument for pragma % is longer than 31 characters",
16526 end Check_Too_Long;
16528 -- Start of processing for Common_Object/Psect_Object
16532 Gather_Associations (Names, Args);
16533 Process_Extended_Import_Export_Internal_Arg (Internal);
16535 Def_Id := Entity (Internal);
16537 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
16539 ("pragma% must designate an object", Internal);
16542 Check_Too_Long (Internal);
16544 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
16546 ("cannot use pragma% for imported/exported object",
16550 if Is_Concurrent_Type (Etype (Internal)) then
16552 ("cannot specify pragma % for task/protected object",
16556 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
16558 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
16560 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N);
16563 if Ekind (Def_Id) = E_Constant then
16565 ("cannot specify pragma % for a constant", Internal);
16568 if Is_Record_Type (Etype (Internal)) then
16574 Ent := First_Entity (Etype (Internal));
16575 while Present (Ent) loop
16576 Decl := Declaration_Node (Ent);
16578 if Ekind (Ent) = E_Component
16579 and then Nkind (Decl) = N_Component_Declaration
16580 and then Present (Expression (Decl))
16581 and then Warn_On_Export_Import
16584 ("?x?object for pragma % has defaults", Internal);
16594 if Present (Size) then
16595 Check_Too_Long (Size);
16598 if Present (External) then
16599 Check_Arg_Is_External_Name (External);
16600 Check_Too_Long (External);
16603 -- If all error tests pass, link pragma on to the rep item chain
16605 Record_Rep_Item (Def_Id, N);
16612 -- pragma Pure [(library_unit_NAME)];
16614 when Pragma_Pure => Pure : declare
16618 Check_Ada_83_Warning;
16619 Check_Valid_Library_Unit_Pragma;
16621 if Nkind (N) = N_Null_Statement then
16625 Ent := Find_Lib_Unit_Name;
16627 Set_Has_Pragma_Pure (Ent);
16628 Set_Suppress_Elaboration_Warnings (Ent);
16635 -- pragma Pure_05 [(library_unit_NAME)];
16637 -- This pragma is useable only in GNAT_Mode, where it is used like
16638 -- pragma Pure but it is only effective in Ada 2005 mode (otherwise
16639 -- it is ignored). It may be used after a pragma Preelaborate, in
16640 -- which case it overrides the effect of the pragma Preelaborate.
16641 -- This is used to implement AI-362 which recategorizes some run-time
16642 -- packages in Ada 2005 mode.
16644 when Pragma_Pure_05 => Pure_05 : declare
16649 Check_Valid_Library_Unit_Pragma;
16651 if not GNAT_Mode then
16652 Error_Pragma ("pragma% only available in GNAT mode");
16655 if Nkind (N) = N_Null_Statement then
16659 -- This is one of the few cases where we need to test the value of
16660 -- Ada_Version_Explicit rather than Ada_Version (which is always
16661 -- set to Ada_2012 in a predefined unit), we need to know the
16662 -- explicit version set to know if this pragma is active.
16664 if Ada_Version_Explicit >= Ada_2005 then
16665 Ent := Find_Lib_Unit_Name;
16666 Set_Is_Preelaborated (Ent, False);
16668 Set_Suppress_Elaboration_Warnings (Ent);
16676 -- pragma Pure_12 [(library_unit_NAME)];
16678 -- This pragma is useable only in GNAT_Mode, where it is used like
16679 -- pragma Pure but it is only effective in Ada 2012 mode (otherwise
16680 -- it is ignored). It may be used after a pragma Preelaborate, in
16681 -- which case it overrides the effect of the pragma Preelaborate.
16682 -- This is used to implement AI05-0212 which recategorizes some
16683 -- run-time packages in Ada 2012 mode.
16685 when Pragma_Pure_12 => Pure_12 : declare
16690 Check_Valid_Library_Unit_Pragma;
16692 if not GNAT_Mode then
16693 Error_Pragma ("pragma% only available in GNAT mode");
16696 if Nkind (N) = N_Null_Statement then
16700 -- This is one of the few cases where we need to test the value of
16701 -- Ada_Version_Explicit rather than Ada_Version (which is always
16702 -- set to Ada_2012 in a predefined unit), we need to know the
16703 -- explicit version set to know if this pragma is active.
16705 if Ada_Version_Explicit >= Ada_2012 then
16706 Ent := Find_Lib_Unit_Name;
16707 Set_Is_Preelaborated (Ent, False);
16709 Set_Suppress_Elaboration_Warnings (Ent);
16713 -------------------
16714 -- Pure_Function --
16715 -------------------
16717 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
16719 when Pragma_Pure_Function => Pure_Function : declare
16722 Def_Id : Entity_Id;
16723 Effective : Boolean := False;
16727 Check_Arg_Count (1);
16728 Check_Optional_Identifier (Arg1, Name_Entity);
16729 Check_Arg_Is_Local_Name (Arg1);
16730 E_Id := Get_Pragma_Arg (Arg1);
16732 if Error_Posted (E_Id) then
16736 -- Loop through homonyms (overloadings) of referenced entity
16738 E := Entity (E_Id);
16740 if Present (E) then
16742 Def_Id := Get_Base_Subprogram (E);
16744 if not Ekind_In (Def_Id, E_Function,
16745 E_Generic_Function,
16749 ("pragma% requires a function name", Arg1);
16752 Set_Is_Pure (Def_Id);
16754 if not Has_Pragma_Pure_Function (Def_Id) then
16755 Set_Has_Pragma_Pure_Function (Def_Id);
16759 exit when From_Aspect_Specification (N);
16761 exit when No (E) or else Scope (E) /= Current_Scope;
16765 and then Warn_On_Redundant_Constructs
16768 ("pragma Pure_Function on& is redundant?r?",
16774 --------------------
16775 -- Queuing_Policy --
16776 --------------------
16778 -- pragma Queuing_Policy (policy_IDENTIFIER);
16780 when Pragma_Queuing_Policy => declare
16784 Check_Ada_83_Warning;
16785 Check_Arg_Count (1);
16786 Check_No_Identifiers;
16787 Check_Arg_Is_Queuing_Policy (Arg1);
16788 Check_Valid_Configuration_Pragma;
16789 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
16790 QP := Fold_Upper (Name_Buffer (1));
16792 if Queuing_Policy /= ' '
16793 and then Queuing_Policy /= QP
16795 Error_Msg_Sloc := Queuing_Policy_Sloc;
16796 Error_Pragma ("queuing policy incompatible with policy#");
16798 -- Set new policy, but always preserve System_Location since we
16799 -- like the error message with the run time name.
16802 Queuing_Policy := QP;
16804 if Queuing_Policy_Sloc /= System_Location then
16805 Queuing_Policy_Sloc := Loc;
16814 -- pragma Rational, for compatibility with foreign compiler
16816 when Pragma_Rational =>
16817 Set_Rational_Profile;
16819 ------------------------------------
16820 -- Refined_Depends/Refined_Global --
16821 ------------------------------------
16823 -- pragma Refined_Depends (DEPENDENCY_RELATION);
16825 -- DEPENDENCY_RELATION ::=
16827 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
16829 -- DEPENDENCY_CLAUSE ::=
16830 -- OUTPUT_LIST =>[+] INPUT_LIST
16831 -- | NULL_DEPENDENCY_CLAUSE
16833 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
16835 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
16837 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
16839 -- OUTPUT ::= NAME | FUNCTION_RESULT
16842 -- where FUNCTION_RESULT is a function Result attribute_reference
16844 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
16846 -- GLOBAL_SPECIFICATION ::=
16849 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
16851 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
16853 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
16854 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
16855 -- GLOBAL_ITEM ::= NAME
16857 when Pragma_Refined_Depends |
16858 Pragma_Refined_Global => Refined_Depends_Global :
16860 Body_Id : Entity_Id;
16862 Spec_Id : Entity_Id;
16865 Analyze_Refined_Pragma (Spec_Id, Body_Id, Legal);
16867 -- Save the pragma in the contract of the subprogram body. The
16868 -- remaining analysis is performed at the end of the enclosing
16872 Add_Contract_Item (N, Body_Id);
16874 end Refined_Depends_Global;
16876 ------------------------------
16877 -- Refined_Post/Refined_Pre --
16878 ------------------------------
16880 -- pragma Refined_Post (boolean_EXPRESSION);
16881 -- pragma Refined_Pre (boolean_EXPRESSION);
16883 when Pragma_Refined_Post |
16884 Pragma_Refined_Pre => Refined_Pre_Post :
16886 Body_Id : Entity_Id;
16888 Spec_Id : Entity_Id;
16891 Analyze_Refined_Pragma (Spec_Id, Body_Id, Legal);
16893 -- Analyze the boolean expression as a "spec expression"
16896 Analyze_Pre_Post_Condition_In_Decl_Part (N, Spec_Id);
16898 end Refined_Pre_Post;
16900 -------------------
16901 -- Refined_State --
16902 -------------------
16904 -- pragma Refined_State (REFINEMENT_LIST);
16906 -- REFINEMENT_LIST ::=
16907 -- REFINEMENT_CLAUSE
16908 -- | (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
16910 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
16912 -- CONSTITUENT_LIST ::=
16915 -- | (CONSTITUENT {, CONSTITUENT})
16917 -- CONSTITUENT ::= object_NAME | state_NAME
16919 when Pragma_Refined_State => Refined_State : declare
16920 Context : constant Node_Id := Parent (N);
16921 Spec_Id : Entity_Id;
16927 Check_Arg_Count (1);
16929 -- Ensure the proper placement of the pragma. Refined states must
16930 -- be associated with a package body.
16932 if Nkind (Context) /= N_Package_Body then
16938 while Present (Stmt) loop
16940 -- Skip prior pragmas, but check for duplicates
16942 if Nkind (Stmt) = N_Pragma then
16943 if Pragma_Name (Stmt) = Pname then
16944 Error_Msg_Name_1 := Pname;
16945 Error_Msg_Sloc := Sloc (Stmt);
16946 Error_Msg_N ("pragma % duplicates pragma declared #", N);
16949 -- Skip internally generated code
16951 elsif not Comes_From_Source (Stmt) then
16954 -- The pragma does not apply to a legal construct, issue an
16955 -- error and stop the analysis.
16962 Stmt := Prev (Stmt);
16965 -- State refinement is allowed only when the corresponding package
16966 -- declaration has a non-null pragma Abstract_State.
16968 Spec_Id := Corresponding_Spec (Context);
16970 if No (Abstract_States (Spec_Id))
16971 or else Has_Null_Abstract_State (Spec_Id)
16974 ("useless refinement, package & does not define abstract "
16975 & "states", N, Spec_Id);
16979 -- The pragma must be analyzed at the end of the declarations as
16980 -- it has visibility over the whole declarative region. Save the
16981 -- pragma for later (see Analyze_Refined_Depends_In_Decl_Part) by
16982 -- adding it to the contract of the package body.
16984 Add_Contract_Item (N, Defining_Entity (Context));
16987 -----------------------
16988 -- Relative_Deadline --
16989 -----------------------
16991 -- pragma Relative_Deadline (time_span_EXPRESSION);
16993 when Pragma_Relative_Deadline => Relative_Deadline : declare
16994 P : constant Node_Id := Parent (N);
16999 Check_No_Identifiers;
17000 Check_Arg_Count (1);
17002 Arg := Get_Pragma_Arg (Arg1);
17004 -- The expression must be analyzed in the special manner described
17005 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
17007 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
17011 if Nkind (P) = N_Subprogram_Body then
17012 Check_In_Main_Program;
17014 -- Only Task and subprogram cases allowed
17016 elsif Nkind (P) /= N_Task_Definition then
17020 -- Check duplicate pragma before we set the corresponding flag
17022 if Has_Relative_Deadline_Pragma (P) then
17023 Error_Pragma ("duplicate pragma% not allowed");
17026 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
17027 -- Relative_Deadline pragma node cannot be inserted in the Rep
17028 -- Item chain of Ent since it is rewritten by the expander as a
17029 -- procedure call statement that will break the chain.
17031 Set_Has_Relative_Deadline_Pragma (P, True);
17032 end Relative_Deadline;
17034 ------------------------
17035 -- Remote_Access_Type --
17036 ------------------------
17038 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
17040 when Pragma_Remote_Access_Type => Remote_Access_Type : declare
17045 Check_Arg_Count (1);
17046 Check_Optional_Identifier (Arg1, Name_Entity);
17047 Check_Arg_Is_Local_Name (Arg1);
17049 E := Entity (Get_Pragma_Arg (Arg1));
17051 if Nkind (Parent (E)) = N_Formal_Type_Declaration
17052 and then Ekind (E) = E_General_Access_Type
17053 and then Is_Class_Wide_Type (Directly_Designated_Type (E))
17054 and then Scope (Root_Type (Directly_Designated_Type (E)))
17056 and then Is_Valid_Remote_Object_Type
17057 (Root_Type (Directly_Designated_Type (E)))
17059 Set_Is_Remote_Types (E);
17063 ("pragma% applies only to formal access to classwide types",
17066 end Remote_Access_Type;
17068 ---------------------------
17069 -- Remote_Call_Interface --
17070 ---------------------------
17072 -- pragma Remote_Call_Interface [(library_unit_NAME)];
17074 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
17075 Cunit_Node : Node_Id;
17076 Cunit_Ent : Entity_Id;
17080 Check_Ada_83_Warning;
17081 Check_Valid_Library_Unit_Pragma;
17083 if Nkind (N) = N_Null_Statement then
17087 Cunit_Node := Cunit (Current_Sem_Unit);
17088 K := Nkind (Unit (Cunit_Node));
17089 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
17091 if K = N_Package_Declaration
17092 or else K = N_Generic_Package_Declaration
17093 or else K = N_Subprogram_Declaration
17094 or else K = N_Generic_Subprogram_Declaration
17095 or else (K = N_Subprogram_Body
17096 and then Acts_As_Spec (Unit (Cunit_Node)))
17101 "pragma% must apply to package or subprogram declaration");
17104 Set_Is_Remote_Call_Interface (Cunit_Ent);
17105 end Remote_Call_Interface;
17111 -- pragma Remote_Types [(library_unit_NAME)];
17113 when Pragma_Remote_Types => Remote_Types : declare
17114 Cunit_Node : Node_Id;
17115 Cunit_Ent : Entity_Id;
17118 Check_Ada_83_Warning;
17119 Check_Valid_Library_Unit_Pragma;
17121 if Nkind (N) = N_Null_Statement then
17125 Cunit_Node := Cunit (Current_Sem_Unit);
17126 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
17128 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
17129 N_Generic_Package_Declaration)
17132 ("pragma% can only apply to a package declaration");
17135 Set_Is_Remote_Types (Cunit_Ent);
17142 -- pragma Ravenscar;
17144 when Pragma_Ravenscar =>
17146 Check_Arg_Count (0);
17147 Check_Valid_Configuration_Pragma;
17148 Set_Ravenscar_Profile (N);
17150 if Warn_On_Obsolescent_Feature then
17152 ("pragma Ravenscar is an obsolescent feature?j?", N);
17154 ("|use pragma Profile (Ravenscar) instead?j?", N);
17157 -------------------------
17158 -- Restricted_Run_Time --
17159 -------------------------
17161 -- pragma Restricted_Run_Time;
17163 when Pragma_Restricted_Run_Time =>
17165 Check_Arg_Count (0);
17166 Check_Valid_Configuration_Pragma;
17167 Set_Profile_Restrictions
17168 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
17170 if Warn_On_Obsolescent_Feature then
17172 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
17175 ("|use pragma Profile (Restricted) instead?j?", N);
17182 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
17185 -- restriction_IDENTIFIER
17186 -- | restriction_parameter_IDENTIFIER => EXPRESSION
17188 when Pragma_Restrictions =>
17189 Process_Restrictions_Or_Restriction_Warnings
17190 (Warn => Treat_Restrictions_As_Warnings);
17192 --------------------------
17193 -- Restriction_Warnings --
17194 --------------------------
17196 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
17199 -- restriction_IDENTIFIER
17200 -- | restriction_parameter_IDENTIFIER => EXPRESSION
17202 when Pragma_Restriction_Warnings =>
17204 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
17210 -- pragma Reviewable;
17212 when Pragma_Reviewable =>
17213 Check_Ada_83_Warning;
17214 Check_Arg_Count (0);
17216 -- Call dummy debugging function rv. This is done to assist front
17217 -- end debugging. By placing a Reviewable pragma in the source
17218 -- program, a breakpoint on rv catches this place in the source,
17219 -- allowing convenient stepping to the point of interest.
17223 --------------------------
17224 -- Short_Circuit_And_Or --
17225 --------------------------
17227 -- pragma Short_Circuit_And_Or;
17229 when Pragma_Short_Circuit_And_Or =>
17231 Check_Arg_Count (0);
17232 Check_Valid_Configuration_Pragma;
17233 Short_Circuit_And_Or := True;
17235 -------------------
17236 -- Share_Generic --
17237 -------------------
17239 -- pragma Share_Generic (GNAME {, GNAME});
17241 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
17243 when Pragma_Share_Generic =>
17245 Process_Generic_List;
17251 -- pragma Shared (LOCAL_NAME);
17253 when Pragma_Shared =>
17255 Process_Atomic_Shared_Volatile;
17257 --------------------
17258 -- Shared_Passive --
17259 --------------------
17261 -- pragma Shared_Passive [(library_unit_NAME)];
17263 -- Set the flag Is_Shared_Passive of program unit name entity
17265 when Pragma_Shared_Passive => Shared_Passive : declare
17266 Cunit_Node : Node_Id;
17267 Cunit_Ent : Entity_Id;
17270 Check_Ada_83_Warning;
17271 Check_Valid_Library_Unit_Pragma;
17273 if Nkind (N) = N_Null_Statement then
17277 Cunit_Node := Cunit (Current_Sem_Unit);
17278 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
17280 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
17281 N_Generic_Package_Declaration)
17284 ("pragma% can only apply to a package declaration");
17287 Set_Is_Shared_Passive (Cunit_Ent);
17288 end Shared_Passive;
17290 -----------------------
17291 -- Short_Descriptors --
17292 -----------------------
17294 -- pragma Short_Descriptors;
17296 when Pragma_Short_Descriptors =>
17298 Check_Arg_Count (0);
17299 Check_Valid_Configuration_Pragma;
17300 Short_Descriptors := True;
17302 ------------------------------
17303 -- Simple_Storage_Pool_Type --
17304 ------------------------------
17306 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
17308 when Pragma_Simple_Storage_Pool_Type =>
17309 Simple_Storage_Pool_Type : declare
17315 Check_Arg_Count (1);
17316 Check_Arg_Is_Library_Level_Local_Name (Arg1);
17318 Type_Id := Get_Pragma_Arg (Arg1);
17319 Find_Type (Type_Id);
17320 Typ := Entity (Type_Id);
17322 if Typ = Any_Type then
17326 -- We require the pragma to apply to a type declared in a package
17327 -- declaration, but not (immediately) within a package body.
17329 if Ekind (Current_Scope) /= E_Package
17330 or else In_Package_Body (Current_Scope)
17333 ("pragma% can only apply to type declared immediately "
17334 & "within a package declaration");
17337 -- A simple storage pool type must be an immutably limited record
17338 -- or private type. If the pragma is given for a private type,
17339 -- the full type is similarly restricted (which is checked later
17340 -- in Freeze_Entity).
17342 if Is_Record_Type (Typ)
17343 and then not Is_Immutably_Limited_Type (Typ)
17346 ("pragma% can only apply to explicitly limited record type");
17348 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
17350 ("pragma% can only apply to a private type that is limited");
17352 elsif not Is_Record_Type (Typ)
17353 and then not Is_Private_Type (Typ)
17356 ("pragma% can only apply to limited record or private type");
17359 Record_Rep_Item (Typ, N);
17360 end Simple_Storage_Pool_Type;
17362 ----------------------
17363 -- Source_File_Name --
17364 ----------------------
17366 -- There are five forms for this pragma:
17368 -- pragma Source_File_Name (
17369 -- [UNIT_NAME =>] unit_NAME,
17370 -- BODY_FILE_NAME => STRING_LITERAL
17371 -- [, [INDEX =>] INTEGER_LITERAL]);
17373 -- pragma Source_File_Name (
17374 -- [UNIT_NAME =>] unit_NAME,
17375 -- SPEC_FILE_NAME => STRING_LITERAL
17376 -- [, [INDEX =>] INTEGER_LITERAL]);
17378 -- pragma Source_File_Name (
17379 -- BODY_FILE_NAME => STRING_LITERAL
17380 -- [, DOT_REPLACEMENT => STRING_LITERAL]
17381 -- [, CASING => CASING_SPEC]);
17383 -- pragma Source_File_Name (
17384 -- SPEC_FILE_NAME => STRING_LITERAL
17385 -- [, DOT_REPLACEMENT => STRING_LITERAL]
17386 -- [, CASING => CASING_SPEC]);
17388 -- pragma Source_File_Name (
17389 -- SUBUNIT_FILE_NAME => STRING_LITERAL
17390 -- [, DOT_REPLACEMENT => STRING_LITERAL]
17391 -- [, CASING => CASING_SPEC]);
17393 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
17395 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
17396 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
17397 -- only be used when no project file is used, while SFNP can only be
17398 -- used when a project file is used.
17400 -- No processing here. Processing was completed during parsing, since
17401 -- we need to have file names set as early as possible. Units are
17402 -- loaded well before semantic processing starts.
17404 -- The only processing we defer to this point is the check for
17405 -- correct placement.
17407 when Pragma_Source_File_Name =>
17409 Check_Valid_Configuration_Pragma;
17411 ------------------------------
17412 -- Source_File_Name_Project --
17413 ------------------------------
17415 -- See Source_File_Name for syntax
17417 -- No processing here. Processing was completed during parsing, since
17418 -- we need to have file names set as early as possible. Units are
17419 -- loaded well before semantic processing starts.
17421 -- The only processing we defer to this point is the check for
17422 -- correct placement.
17424 when Pragma_Source_File_Name_Project =>
17426 Check_Valid_Configuration_Pragma;
17428 -- Check that a pragma Source_File_Name_Project is used only in a
17429 -- configuration pragmas file.
17431 -- Pragmas Source_File_Name_Project should only be generated by
17432 -- the Project Manager in configuration pragmas files.
17434 -- This is really an ugly test. It seems to depend on some
17435 -- accidental and undocumented property. At the very least it
17436 -- needs to be documented, but it would be better to have a
17437 -- clean way of testing if we are in a configuration file???
17439 if Present (Parent (N)) then
17441 ("pragma% can only appear in a configuration pragmas file");
17444 ----------------------
17445 -- Source_Reference --
17446 ----------------------
17448 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
17450 -- Nothing to do, all processing completed in Par.Prag, since we need
17451 -- the information for possible parser messages that are output.
17453 when Pragma_Source_Reference =>
17460 -- pragma SPARK_Mode [(On | Off | Auto)];
17462 when Pragma_SPARK_Mode => SPARK_Mod : declare
17463 procedure Chain_Pragma (Context : Entity_Id; Prag : Node_Id);
17464 -- Associate a SPARK_Mode pragma with the context where it lives.
17465 -- If the context is a package spec or a body, the routine checks
17466 -- the consistency between modes of visible/private declarations
17467 -- and body declarations/statements.
17469 procedure Check_Spark_Mode_Conformance
17470 (Governing_Id : Entity_Id;
17471 New_Id : Entity_Id);
17472 -- Verify the "monotonicity" of SPARK modes between two entities.
17473 -- The order of modes is Off < Auto < On. Governing_Id establishes
17474 -- the mode of the context. New_Id attempts to redefine the known
17477 procedure Check_Pragma_Conformance
17478 (Governing_Mode : Node_Id;
17479 New_Mode : Node_Id);
17480 -- Verify the "monotonicity" of two SPARK_Mode pragmas. The order
17481 -- of modes is Off < Auto < On. Governing_Mode is the established
17482 -- mode dictated by the context. New_Mode attempts to redefine the
17485 function Get_SPARK_Mode_Name (Id : SPARK_Mode_Id) return Name_Id;
17486 -- Convert a value of type SPARK_Mode_Id into a corresponding name
17492 procedure Chain_Pragma (Context : Entity_Id; Prag : Node_Id) is
17493 Existing_Prag : constant Node_Id :=
17494 SPARK_Mode_Pragmas (Context);
17496 -- The context does not have a prior mode defined
17498 if No (Existing_Prag) then
17499 Set_SPARK_Mode_Pragmas (Context, Prag);
17501 -- Chain the new mode on the list of SPARK_Mode pragmas. Verify
17502 -- the consistency between the existing mode and the new one.
17505 Set_Next_Pragma (Existing_Prag, Prag);
17507 Check_Pragma_Conformance
17508 (Governing_Mode => Existing_Prag,
17513 ----------------------------------
17514 -- Check_Spark_Mode_Conformance --
17515 ----------------------------------
17517 procedure Check_Spark_Mode_Conformance
17518 (Governing_Id : Entity_Id;
17519 New_Id : Entity_Id)
17521 Gov_Prag : constant Node_Id :=
17522 SPARK_Mode_Pragmas (Governing_Id);
17523 New_Prag : constant Node_Id := SPARK_Mode_Pragmas (New_Id);
17526 -- Nothing to do when one or both entities lack a mode
17528 if No (Gov_Prag) or else No (New_Prag) then
17532 -- Do not compare the modes of a package spec and body when the
17533 -- spec mode appears in the private part. In this case the spec
17534 -- mode does not affect the body.
17536 if Ekind_In (Governing_Id, E_Generic_Package, E_Package)
17537 and then Ekind (New_Id) = E_Package_Body
17538 and then Is_Private_SPARK_Mode (Gov_Prag)
17542 -- Test the pragmas
17545 Check_Pragma_Conformance
17546 (Governing_Mode => Gov_Prag,
17547 New_Mode => New_Prag);
17549 end Check_Spark_Mode_Conformance;
17551 ------------------------------
17552 -- Check_Pragma_Conformance --
17553 ------------------------------
17555 procedure Check_Pragma_Conformance
17556 (Governing_Mode : Node_Id;
17557 New_Mode : Node_Id)
17559 Gov_M : constant SPARK_Mode_Id :=
17560 Get_SPARK_Mode_Id (Governing_Mode);
17561 New_M : constant SPARK_Mode_Id := Get_SPARK_Mode_Id (New_Mode);
17564 -- The new mode is less restrictive than the established mode
17566 if Gov_M < New_M then
17567 Error_Msg_Name_1 := Get_SPARK_Mode_Name (New_M);
17568 Error_Msg_N ("cannot define 'S'P'A'R'K mode %", New_Mode);
17570 Error_Msg_Name_1 := Get_SPARK_Mode_Name (Gov_M);
17571 Error_Msg_Sloc := Sloc (Governing_Mode);
17573 ("\mode is less restrictive than mode % defined #",
17576 end Check_Pragma_Conformance;
17578 -------------------------
17579 -- Get_SPARK_Mode_Name --
17580 -------------------------
17582 function Get_SPARK_Mode_Name (Id : SPARK_Mode_Id) return Name_Id is
17584 if Id = SPARK_On then
17586 elsif Id = SPARK_Off then
17588 elsif Id = SPARK_Auto then
17591 -- Mode "None" should never be used in error message generation
17594 raise Program_Error;
17596 end Get_SPARK_Mode_Name;
17600 Body_Id : Entity_Id;
17603 Mode_Id : SPARK_Mode_Id;
17604 Spec_Id : Entity_Id;
17607 -- Start of processing for SPARK_Mode
17611 Check_No_Identifiers;
17612 Check_At_Most_N_Arguments (1);
17614 -- Check the legality of the mode
17616 if Arg_Count = 1 then
17617 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off, Name_Auto);
17618 Mode := Chars (Get_Pragma_Arg (Arg1));
17620 -- A SPARK_Mode without an argument defaults to "On"
17626 Mode_Id := Get_SPARK_Mode_Id (Mode);
17627 Context := Parent (N);
17629 -- The pragma appears in a configuration file
17631 if No (Context) then
17632 Check_Valid_Configuration_Pragma;
17633 Global_SPARK_Mode := Mode_Id;
17635 -- When the pragma is placed before the declaration of a unit, it
17636 -- configures the whole unit.
17638 elsif Nkind (Context) = N_Compilation_Unit then
17639 Check_Valid_Configuration_Pragma;
17640 Set_SPARK_Mode_Pragma (Current_Sem_Unit, N);
17642 -- The pragma applies to a [library unit] subprogram or package
17645 -- Mode "Auto" cannot be used in nested subprograms or packages
17647 if Mode_Id = SPARK_Auto then
17649 ("mode `Auto` can only apply to the configuration variant "
17650 & "of pragma %", Arg1);
17653 -- Verify the placement of the pragma with respect to package
17654 -- or subprogram declarations and detect duplicates.
17657 while Present (Stmt) loop
17659 -- Skip prior pragmas, but check for duplicates
17661 if Nkind (Stmt) = N_Pragma then
17662 if Pragma_Name (Stmt) = Pname then
17663 Error_Msg_Name_1 := Pname;
17664 Error_Msg_Sloc := Sloc (Stmt);
17666 ("pragma % duplicates pragma declared #", N);
17669 -- Skip internally generated code
17671 elsif not Comes_From_Source (Stmt) then
17674 -- The pragma applies to a package or subprogram declaration
17676 elsif Nkind_In (Stmt, N_Generic_Package_Declaration,
17677 N_Generic_Subprogram_Declaration,
17678 N_Package_Declaration,
17679 N_Subprogram_Declaration)
17681 Spec_Id := Defining_Unit_Name (Specification (Stmt));
17682 Chain_Pragma (Spec_Id, N);
17685 -- The pragma does not apply to a legal construct, issue an
17686 -- error and stop the analysis.
17693 Stmt := Prev (Stmt);
17696 -- Handle all cases where the pragma is actually an aspect and
17697 -- applies to a library-level package spec, body or subprogram.
17699 -- function F ... with SPARK_Mode => ...;
17700 -- package P with SPARK_Mode => ...;
17701 -- package body P with SPARK_Mode => ... is
17703 -- The following circuitry simply prepares the proper context
17704 -- for the general pragma processing mechanism below.
17706 if Nkind (Context) = N_Compilation_Unit_Aux then
17707 Context := Unit (Parent (Context));
17709 if Nkind_In (Context, N_Package_Declaration,
17710 N_Subprogram_Declaration)
17712 Context := Specification (Context);
17716 -- The pragma is at the top level of a package spec or appears
17717 -- as an aspect on a subprogram.
17719 -- function F ... with SPARK_Mode => ...;
17722 -- pragma SPARK_Mode;
17724 if Nkind_In (Context, N_Function_Specification,
17725 N_Package_Specification,
17726 N_Procedure_Specification)
17728 Spec_Id := Defining_Unit_Name (Context);
17729 Chain_Pragma (Spec_Id, N);
17731 -- The pragma is immediately within a package or subprogram
17734 -- function F ... is
17735 -- pragma SPARK_Mode;
17737 -- package body P is
17738 -- pragma SPARK_Mode;
17740 elsif Nkind_In (Context, N_Package_Body,
17743 Spec_Id := Corresponding_Spec (Context);
17745 if Nkind (Context) = N_Subprogram_Body then
17746 Context := Specification (Context);
17749 Body_Id := Defining_Unit_Name (Context);
17751 Chain_Pragma (Body_Id, N);
17753 -- Verify that the SPARK modes are consistent between
17754 -- body and spec, if any.
17756 if Present (Spec_Id) then
17757 Check_Spark_Mode_Conformance (Spec_Id, Body_Id);
17760 -- The pragma applies to the statements of a package body
17762 -- package body P is
17764 -- pragma SPARK_Mode;
17766 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
17767 and then Nkind (Parent (Context)) = N_Package_Body
17769 Context := Parent (Context);
17770 Spec_Id := Corresponding_Spec (Context);
17771 Body_Id := Defining_Unit_Name (Context);
17773 Chain_Pragma (Body_Id, N);
17774 Check_Spark_Mode_Conformance (Spec_Id, Body_Id);
17776 -- The pragma does not apply to a legal construct, issue error
17784 --------------------------------
17785 -- Static_Elaboration_Desired --
17786 --------------------------------
17788 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
17790 when Pragma_Static_Elaboration_Desired =>
17792 Check_At_Most_N_Arguments (1);
17794 if Is_Compilation_Unit (Current_Scope)
17795 and then Ekind (Current_Scope) = E_Package
17797 Set_Static_Elaboration_Desired (Current_Scope, True);
17799 Error_Pragma ("pragma% must apply to a library-level package");
17806 -- pragma Storage_Size (EXPRESSION);
17808 when Pragma_Storage_Size => Storage_Size : declare
17809 P : constant Node_Id := Parent (N);
17813 Check_No_Identifiers;
17814 Check_Arg_Count (1);
17816 -- The expression must be analyzed in the special manner described
17817 -- in "Handling of Default Expressions" in sem.ads.
17819 Arg := Get_Pragma_Arg (Arg1);
17820 Preanalyze_Spec_Expression (Arg, Any_Integer);
17822 if not Is_Static_Expression (Arg) then
17823 Check_Restriction (Static_Storage_Size, Arg);
17826 if Nkind (P) /= N_Task_Definition then
17831 if Has_Storage_Size_Pragma (P) then
17832 Error_Pragma ("duplicate pragma% not allowed");
17834 Set_Has_Storage_Size_Pragma (P, True);
17837 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
17845 -- pragma Storage_Unit (NUMERIC_LITERAL);
17847 -- Only permitted argument is System'Storage_Unit value
17849 when Pragma_Storage_Unit =>
17850 Check_No_Identifiers;
17851 Check_Arg_Count (1);
17852 Check_Arg_Is_Integer_Literal (Arg1);
17854 if Intval (Get_Pragma_Arg (Arg1)) /=
17855 UI_From_Int (Ttypes.System_Storage_Unit)
17857 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
17859 ("the only allowed argument for pragma% is ^", Arg1);
17862 --------------------
17863 -- Stream_Convert --
17864 --------------------
17866 -- pragma Stream_Convert (
17867 -- [Entity =>] type_LOCAL_NAME,
17868 -- [Read =>] function_NAME,
17869 -- [Write =>] function NAME);
17871 when Pragma_Stream_Convert => Stream_Convert : declare
17873 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
17874 -- Check that the given argument is the name of a local function
17875 -- of one argument that is not overloaded earlier in the current
17876 -- local scope. A check is also made that the argument is a
17877 -- function with one parameter.
17879 --------------------------------------
17880 -- Check_OK_Stream_Convert_Function --
17881 --------------------------------------
17883 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
17887 Check_Arg_Is_Local_Name (Arg);
17888 Ent := Entity (Get_Pragma_Arg (Arg));
17890 if Has_Homonym (Ent) then
17892 ("argument for pragma% may not be overloaded", Arg);
17895 if Ekind (Ent) /= E_Function
17896 or else No (First_Formal (Ent))
17897 or else Present (Next_Formal (First_Formal (Ent)))
17900 ("argument for pragma% must be function of one argument",
17903 end Check_OK_Stream_Convert_Function;
17905 -- Start of processing for Stream_Convert
17909 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
17910 Check_Arg_Count (3);
17911 Check_Optional_Identifier (Arg1, Name_Entity);
17912 Check_Optional_Identifier (Arg2, Name_Read);
17913 Check_Optional_Identifier (Arg3, Name_Write);
17914 Check_Arg_Is_Local_Name (Arg1);
17915 Check_OK_Stream_Convert_Function (Arg2);
17916 Check_OK_Stream_Convert_Function (Arg3);
17919 Typ : constant Entity_Id :=
17920 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
17921 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
17922 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
17925 Check_First_Subtype (Arg1);
17927 -- Check for too early or too late. Note that we don't enforce
17928 -- the rule about primitive operations in this case, since, as
17929 -- is the case for explicit stream attributes themselves, these
17930 -- restrictions are not appropriate. Note that the chaining of
17931 -- the pragma by Rep_Item_Too_Late is actually the critical
17932 -- processing done for this pragma.
17934 if Rep_Item_Too_Early (Typ, N)
17936 Rep_Item_Too_Late (Typ, N, FOnly => True)
17941 -- Return if previous error
17943 if Etype (Typ) = Any_Type
17945 Etype (Read) = Any_Type
17947 Etype (Write) = Any_Type
17954 if Underlying_Type (Etype (Read)) /= Typ then
17956 ("incorrect return type for function&", Arg2);
17959 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
17961 ("incorrect parameter type for function&", Arg3);
17964 if Underlying_Type (Etype (First_Formal (Read))) /=
17965 Underlying_Type (Etype (Write))
17968 ("result type of & does not match Read parameter type",
17972 end Stream_Convert;
17978 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
17980 -- This is processed by the parser since some of the style checks
17981 -- take place during source scanning and parsing. This means that
17982 -- we don't need to issue error messages here.
17984 when Pragma_Style_Checks => Style_Checks : declare
17985 A : constant Node_Id := Get_Pragma_Arg (Arg1);
17991 Check_No_Identifiers;
17993 -- Two argument form
17995 if Arg_Count = 2 then
17996 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
18003 E_Id := Get_Pragma_Arg (Arg2);
18006 if not Is_Entity_Name (E_Id) then
18008 ("second argument of pragma% must be entity name",
18012 E := Entity (E_Id);
18014 if not Ignore_Style_Checks_Pragmas then
18019 Set_Suppress_Style_Checks
18020 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off);
18021 exit when No (Homonym (E));
18028 -- One argument form
18031 Check_Arg_Count (1);
18033 if Nkind (A) = N_String_Literal then
18037 Slen : constant Natural := Natural (String_Length (S));
18038 Options : String (1 .. Slen);
18044 C := Get_String_Char (S, Int (J));
18045 exit when not In_Character_Range (C);
18046 Options (J) := Get_Character (C);
18048 -- If at end of string, set options. As per discussion
18049 -- above, no need to check for errors, since we issued
18050 -- them in the parser.
18053 if not Ignore_Style_Checks_Pragmas then
18054 Set_Style_Check_Options (Options);
18064 elsif Nkind (A) = N_Identifier then
18065 if Chars (A) = Name_All_Checks then
18066 if not Ignore_Style_Checks_Pragmas then
18068 Set_GNAT_Style_Check_Options;
18070 Set_Default_Style_Check_Options;
18074 elsif Chars (A) = Name_On then
18075 if not Ignore_Style_Checks_Pragmas then
18076 Style_Check := True;
18079 elsif Chars (A) = Name_Off then
18080 if not Ignore_Style_Checks_Pragmas then
18081 Style_Check := False;
18092 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
18094 when Pragma_Subtitle =>
18096 Check_Arg_Count (1);
18097 Check_Optional_Identifier (Arg1, Name_Subtitle);
18098 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
18105 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
18107 when Pragma_Suppress =>
18108 Process_Suppress_Unsuppress (True);
18114 -- pragma Suppress_All;
18116 -- The only check made here is that the pragma has no arguments.
18117 -- There are no placement rules, and the processing required (setting
18118 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
18119 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
18120 -- then creates and inserts a pragma Suppress (All_Checks).
18122 when Pragma_Suppress_All =>
18124 Check_Arg_Count (0);
18126 -------------------------
18127 -- Suppress_Debug_Info --
18128 -------------------------
18130 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
18132 when Pragma_Suppress_Debug_Info =>
18134 Check_Arg_Count (1);
18135 Check_Optional_Identifier (Arg1, Name_Entity);
18136 Check_Arg_Is_Local_Name (Arg1);
18137 Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1)));
18139 ----------------------------------
18140 -- Suppress_Exception_Locations --
18141 ----------------------------------
18143 -- pragma Suppress_Exception_Locations;
18145 when Pragma_Suppress_Exception_Locations =>
18147 Check_Arg_Count (0);
18148 Check_Valid_Configuration_Pragma;
18149 Exception_Locations_Suppressed := True;
18151 -----------------------------
18152 -- Suppress_Initialization --
18153 -----------------------------
18155 -- pragma Suppress_Initialization ([Entity =>] type_Name);
18157 when Pragma_Suppress_Initialization => Suppress_Init : declare
18163 Check_Arg_Count (1);
18164 Check_Optional_Identifier (Arg1, Name_Entity);
18165 Check_Arg_Is_Local_Name (Arg1);
18167 E_Id := Get_Pragma_Arg (Arg1);
18169 if Etype (E_Id) = Any_Type then
18173 E := Entity (E_Id);
18175 if not Is_Type (E) then
18176 Error_Pragma_Arg ("pragma% requires type or subtype", Arg1);
18179 if Rep_Item_Too_Early (E, N)
18181 Rep_Item_Too_Late (E, N, FOnly => True)
18186 -- For incomplete/private type, set flag on full view
18188 if Is_Incomplete_Or_Private_Type (E) then
18189 if No (Full_View (Base_Type (E))) then
18191 ("argument of pragma% cannot be an incomplete type", Arg1);
18193 Set_Suppress_Initialization (Full_View (Base_Type (E)));
18196 -- For first subtype, set flag on base type
18198 elsif Is_First_Subtype (E) then
18199 Set_Suppress_Initialization (Base_Type (E));
18201 -- For other than first subtype, set flag on subtype itself
18204 Set_Suppress_Initialization (E);
18212 -- pragma System_Name (DIRECT_NAME);
18214 -- Syntax check: one argument, which must be the identifier GNAT or
18215 -- the identifier GCC, no other identifiers are acceptable.
18217 when Pragma_System_Name =>
18219 Check_No_Identifiers;
18220 Check_Arg_Count (1);
18221 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
18223 -----------------------------
18224 -- Task_Dispatching_Policy --
18225 -----------------------------
18227 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
18229 when Pragma_Task_Dispatching_Policy => declare
18233 Check_Ada_83_Warning;
18234 Check_Arg_Count (1);
18235 Check_No_Identifiers;
18236 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
18237 Check_Valid_Configuration_Pragma;
18238 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
18239 DP := Fold_Upper (Name_Buffer (1));
18241 if Task_Dispatching_Policy /= ' '
18242 and then Task_Dispatching_Policy /= DP
18244 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
18246 ("task dispatching policy incompatible with policy#");
18248 -- Set new policy, but always preserve System_Location since we
18249 -- like the error message with the run time name.
18252 Task_Dispatching_Policy := DP;
18254 if Task_Dispatching_Policy_Sloc /= System_Location then
18255 Task_Dispatching_Policy_Sloc := Loc;
18264 -- pragma Task_Info (EXPRESSION);
18266 when Pragma_Task_Info => Task_Info : declare
18267 P : constant Node_Id := Parent (N);
18273 if Nkind (P) /= N_Task_Definition then
18274 Error_Pragma ("pragma% must appear in task definition");
18277 Check_No_Identifiers;
18278 Check_Arg_Count (1);
18280 Analyze_And_Resolve
18281 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
18283 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
18287 Ent := Defining_Identifier (Parent (P));
18289 -- Check duplicate pragma before we chain the pragma in the Rep
18290 -- Item chain of Ent.
18293 (Ent, Name_Task_Info, Check_Parents => False)
18295 Error_Pragma ("duplicate pragma% not allowed");
18298 Record_Rep_Item (Ent, N);
18305 -- pragma Task_Name (string_EXPRESSION);
18307 when Pragma_Task_Name => Task_Name : declare
18308 P : constant Node_Id := Parent (N);
18313 Check_No_Identifiers;
18314 Check_Arg_Count (1);
18316 Arg := Get_Pragma_Arg (Arg1);
18318 -- The expression is used in the call to Create_Task, and must be
18319 -- expanded there, not in the context of the current spec. It must
18320 -- however be analyzed to capture global references, in case it
18321 -- appears in a generic context.
18323 Preanalyze_And_Resolve (Arg, Standard_String);
18325 if Nkind (P) /= N_Task_Definition then
18329 Ent := Defining_Identifier (Parent (P));
18331 -- Check duplicate pragma before we chain the pragma in the Rep
18332 -- Item chain of Ent.
18335 (Ent, Name_Task_Name, Check_Parents => False)
18337 Error_Pragma ("duplicate pragma% not allowed");
18340 Record_Rep_Item (Ent, N);
18347 -- pragma Task_Storage (
18348 -- [Task_Type =>] LOCAL_NAME,
18349 -- [Top_Guard =>] static_integer_EXPRESSION);
18351 when Pragma_Task_Storage => Task_Storage : declare
18352 Args : Args_List (1 .. 2);
18353 Names : constant Name_List (1 .. 2) := (
18357 Task_Type : Node_Id renames Args (1);
18358 Top_Guard : Node_Id renames Args (2);
18364 Gather_Associations (Names, Args);
18366 if No (Task_Type) then
18368 ("missing task_type argument for pragma%");
18371 Check_Arg_Is_Local_Name (Task_Type);
18373 Ent := Entity (Task_Type);
18375 if not Is_Task_Type (Ent) then
18377 ("argument for pragma% must be task type", Task_Type);
18380 if No (Top_Guard) then
18382 ("pragma% takes two arguments", Task_Type);
18384 Check_Arg_Is_Static_Expression (Top_Guard, Any_Integer);
18387 Check_First_Subtype (Task_Type);
18389 if Rep_Item_Too_Late (Ent, N) then
18398 -- pragma Test_Case
18399 -- ([Name =>] Static_String_EXPRESSION
18400 -- ,[Mode =>] MODE_TYPE
18401 -- [, Requires => Boolean_EXPRESSION]
18402 -- [, Ensures => Boolean_EXPRESSION]);
18404 -- MODE_TYPE ::= Nominal | Robustness
18406 when Pragma_Test_Case =>
18410 --------------------------
18411 -- Thread_Local_Storage --
18412 --------------------------
18414 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
18416 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
18422 Check_Arg_Count (1);
18423 Check_Optional_Identifier (Arg1, Name_Entity);
18424 Check_Arg_Is_Library_Level_Local_Name (Arg1);
18426 Id := Get_Pragma_Arg (Arg1);
18429 if not Is_Entity_Name (Id)
18430 or else Ekind (Entity (Id)) /= E_Variable
18432 Error_Pragma_Arg ("local variable name required", Arg1);
18437 if Rep_Item_Too_Early (E, N)
18438 or else Rep_Item_Too_Late (E, N)
18443 Set_Has_Pragma_Thread_Local_Storage (E);
18444 Set_Has_Gigi_Rep_Item (E);
18445 end Thread_Local_Storage;
18451 -- pragma Time_Slice (static_duration_EXPRESSION);
18453 when Pragma_Time_Slice => Time_Slice : declare
18459 Check_Arg_Count (1);
18460 Check_No_Identifiers;
18461 Check_In_Main_Program;
18462 Check_Arg_Is_Static_Expression (Arg1, Standard_Duration);
18464 if not Error_Posted (Arg1) then
18466 while Present (Nod) loop
18467 if Nkind (Nod) = N_Pragma
18468 and then Pragma_Name (Nod) = Name_Time_Slice
18470 Error_Msg_Name_1 := Pname;
18471 Error_Msg_N ("duplicate pragma% not permitted", Nod);
18478 -- Process only if in main unit
18480 if Get_Source_Unit (Loc) = Main_Unit then
18481 Opt.Time_Slice_Set := True;
18482 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
18484 if Val <= Ureal_0 then
18485 Opt.Time_Slice_Value := 0;
18487 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
18488 Opt.Time_Slice_Value := 1_000_000_000;
18491 Opt.Time_Slice_Value :=
18492 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
18501 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
18503 -- TITLING_OPTION ::=
18504 -- [Title =>] STRING_LITERAL
18505 -- | [Subtitle =>] STRING_LITERAL
18507 when Pragma_Title => Title : declare
18508 Args : Args_List (1 .. 2);
18509 Names : constant Name_List (1 .. 2) := (
18515 Gather_Associations (Names, Args);
18518 for J in 1 .. 2 loop
18519 if Present (Args (J)) then
18520 Check_Arg_Is_Static_Expression (Args (J), Standard_String);
18525 ----------------------------
18526 -- Type_Invariant[_Class] --
18527 ----------------------------
18529 -- pragma Type_Invariant[_Class]
18530 -- ([Entity =>] type_LOCAL_NAME,
18531 -- [Check =>] EXPRESSION);
18533 when Pragma_Type_Invariant |
18534 Pragma_Type_Invariant_Class =>
18535 Type_Invariant : declare
18536 I_Pragma : Node_Id;
18539 Check_Arg_Count (2);
18541 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
18542 -- setting Class_Present for the Type_Invariant_Class case.
18544 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class);
18545 I_Pragma := New_Copy (N);
18546 Set_Pragma_Identifier
18547 (I_Pragma, Make_Identifier (Loc, Name_Invariant));
18548 Rewrite (N, I_Pragma);
18549 Set_Analyzed (N, False);
18551 end Type_Invariant;
18553 ---------------------
18554 -- Unchecked_Union --
18555 ---------------------
18557 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
18559 when Pragma_Unchecked_Union => Unchecked_Union : declare
18560 Assoc : constant Node_Id := Arg1;
18561 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
18571 Check_No_Identifiers;
18572 Check_Arg_Count (1);
18573 Check_Arg_Is_Local_Name (Arg1);
18575 Find_Type (Type_Id);
18577 Typ := Entity (Type_Id);
18580 or else Rep_Item_Too_Early (Typ, N)
18584 Typ := Underlying_Type (Typ);
18587 if Rep_Item_Too_Late (Typ, N) then
18591 Check_First_Subtype (Arg1);
18593 -- Note remaining cases are references to a type in the current
18594 -- declarative part. If we find an error, we post the error on
18595 -- the relevant type declaration at an appropriate point.
18597 if not Is_Record_Type (Typ) then
18598 Error_Msg_N ("unchecked union must be record type", Typ);
18601 elsif Is_Tagged_Type (Typ) then
18602 Error_Msg_N ("unchecked union must not be tagged", Typ);
18605 elsif not Has_Discriminants (Typ) then
18607 ("unchecked union must have one discriminant", Typ);
18610 -- Note: in previous versions of GNAT we used to check for limited
18611 -- types and give an error, but in fact the standard does allow
18612 -- Unchecked_Union on limited types, so this check was removed.
18614 -- Similarly, GNAT used to require that all discriminants have
18615 -- default values, but this is not mandated by the RM.
18617 -- Proceed with basic error checks completed
18620 Tdef := Type_Definition (Declaration_Node (Typ));
18621 Clist := Component_List (Tdef);
18623 -- Check presence of component list and variant part
18625 if No (Clist) or else No (Variant_Part (Clist)) then
18627 ("unchecked union must have variant part", Tdef);
18631 -- Check components
18633 Comp := First (Component_Items (Clist));
18634 while Present (Comp) loop
18635 Check_Component (Comp, Typ);
18639 -- Check variant part
18641 Vpart := Variant_Part (Clist);
18643 Variant := First (Variants (Vpart));
18644 while Present (Variant) loop
18645 Check_Variant (Variant, Typ);
18650 Set_Is_Unchecked_Union (Typ);
18651 Set_Convention (Typ, Convention_C);
18652 Set_Has_Unchecked_Union (Base_Type (Typ));
18653 Set_Is_Unchecked_Union (Base_Type (Typ));
18654 end Unchecked_Union;
18656 ------------------------
18657 -- Unimplemented_Unit --
18658 ------------------------
18660 -- pragma Unimplemented_Unit;
18662 -- Note: this only gives an error if we are generating code, or if
18663 -- we are in a generic library unit (where the pragma appears in the
18664 -- body, not in the spec).
18666 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
18667 Cunitent : constant Entity_Id :=
18668 Cunit_Entity (Get_Source_Unit (Loc));
18669 Ent_Kind : constant Entity_Kind :=
18674 Check_Arg_Count (0);
18676 if Operating_Mode = Generate_Code
18677 or else Ent_Kind = E_Generic_Function
18678 or else Ent_Kind = E_Generic_Procedure
18679 or else Ent_Kind = E_Generic_Package
18681 Get_Name_String (Chars (Cunitent));
18682 Set_Casing (Mixed_Case);
18683 Write_Str (Name_Buffer (1 .. Name_Len));
18684 Write_Str (" is not supported in this configuration");
18686 raise Unrecoverable_Error;
18688 end Unimplemented_Unit;
18690 ------------------------
18691 -- Universal_Aliasing --
18692 ------------------------
18694 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
18696 when Pragma_Universal_Aliasing => Universal_Alias : declare
18701 Check_Arg_Count (1);
18702 Check_Optional_Identifier (Arg2, Name_Entity);
18703 Check_Arg_Is_Local_Name (Arg1);
18704 E_Id := Entity (Get_Pragma_Arg (Arg1));
18706 if E_Id = Any_Type then
18708 elsif No (E_Id) or else not Is_Type (E_Id) then
18709 Error_Pragma_Arg ("pragma% requires type", Arg1);
18712 Set_Universal_Aliasing (Implementation_Base_Type (E_Id));
18713 Record_Rep_Item (E_Id, N);
18714 end Universal_Alias;
18716 --------------------
18717 -- Universal_Data --
18718 --------------------
18720 -- pragma Universal_Data [(library_unit_NAME)];
18722 when Pragma_Universal_Data =>
18725 -- If this is a configuration pragma, then set the universal
18726 -- addressing option, otherwise confirm that the pragma satisfies
18727 -- the requirements of library unit pragma placement and leave it
18728 -- to the GNAAMP back end to detect the pragma (avoids transitive
18729 -- setting of the option due to withed units).
18731 if Is_Configuration_Pragma then
18732 Universal_Addressing_On_AAMP := True;
18734 Check_Valid_Library_Unit_Pragma;
18737 if not AAMP_On_Target then
18738 Error_Pragma ("??pragma% ignored (applies only to AAMP)");
18745 -- pragma Unmodified (local_Name {, local_Name});
18747 when Pragma_Unmodified => Unmodified : declare
18748 Arg_Node : Node_Id;
18749 Arg_Expr : Node_Id;
18750 Arg_Ent : Entity_Id;
18754 Check_At_Least_N_Arguments (1);
18756 -- Loop through arguments
18759 while Present (Arg_Node) loop
18760 Check_No_Identifier (Arg_Node);
18762 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
18763 -- in fact generate reference, so that the entity will have a
18764 -- reference, which will inhibit any warnings about it not
18765 -- being referenced, and also properly show up in the ali file
18766 -- as a reference. But this reference is recorded before the
18767 -- Has_Pragma_Unreferenced flag is set, so that no warning is
18768 -- generated for this reference.
18770 Check_Arg_Is_Local_Name (Arg_Node);
18771 Arg_Expr := Get_Pragma_Arg (Arg_Node);
18773 if Is_Entity_Name (Arg_Expr) then
18774 Arg_Ent := Entity (Arg_Expr);
18776 if not Is_Assignable (Arg_Ent) then
18778 ("pragma% can only be applied to a variable",
18781 Set_Has_Pragma_Unmodified (Arg_Ent);
18793 -- pragma Unreferenced (local_Name {, local_Name});
18795 -- or when used in a context clause:
18797 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
18799 when Pragma_Unreferenced => Unreferenced : declare
18800 Arg_Node : Node_Id;
18801 Arg_Expr : Node_Id;
18802 Arg_Ent : Entity_Id;
18807 Check_At_Least_N_Arguments (1);
18809 -- Check case of appearing within context clause
18811 if Is_In_Context_Clause then
18813 -- The arguments must all be units mentioned in a with clause
18814 -- in the same context clause. Note we already checked (in
18815 -- Par.Prag) that the arguments are either identifiers or
18816 -- selected components.
18819 while Present (Arg_Node) loop
18820 Citem := First (List_Containing (N));
18821 while Citem /= N loop
18822 if Nkind (Citem) = N_With_Clause
18824 Same_Name (Name (Citem), Get_Pragma_Arg (Arg_Node))
18826 Set_Has_Pragma_Unreferenced
18829 (Library_Unit (Citem))));
18831 (Get_Pragma_Arg (Arg_Node), Name (Citem));
18840 ("argument of pragma% is not withed unit", Arg_Node);
18846 -- Case of not in list of context items
18850 while Present (Arg_Node) loop
18851 Check_No_Identifier (Arg_Node);
18853 -- Note: the analyze call done by Check_Arg_Is_Local_Name
18854 -- will in fact generate reference, so that the entity will
18855 -- have a reference, which will inhibit any warnings about
18856 -- it not being referenced, and also properly show up in the
18857 -- ali file as a reference. But this reference is recorded
18858 -- before the Has_Pragma_Unreferenced flag is set, so that
18859 -- no warning is generated for this reference.
18861 Check_Arg_Is_Local_Name (Arg_Node);
18862 Arg_Expr := Get_Pragma_Arg (Arg_Node);
18864 if Is_Entity_Name (Arg_Expr) then
18865 Arg_Ent := Entity (Arg_Expr);
18867 -- If the entity is overloaded, the pragma applies to the
18868 -- most recent overloading, as documented. In this case,
18869 -- name resolution does not generate a reference, so it
18870 -- must be done here explicitly.
18872 if Is_Overloaded (Arg_Expr) then
18873 Generate_Reference (Arg_Ent, N);
18876 Set_Has_Pragma_Unreferenced (Arg_Ent);
18884 --------------------------
18885 -- Unreferenced_Objects --
18886 --------------------------
18888 -- pragma Unreferenced_Objects (local_Name {, local_Name});
18890 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
18891 Arg_Node : Node_Id;
18892 Arg_Expr : Node_Id;
18896 Check_At_Least_N_Arguments (1);
18899 while Present (Arg_Node) loop
18900 Check_No_Identifier (Arg_Node);
18901 Check_Arg_Is_Local_Name (Arg_Node);
18902 Arg_Expr := Get_Pragma_Arg (Arg_Node);
18904 if not Is_Entity_Name (Arg_Expr)
18905 or else not Is_Type (Entity (Arg_Expr))
18908 ("argument for pragma% must be type or subtype", Arg_Node);
18911 Set_Has_Pragma_Unreferenced_Objects (Entity (Arg_Expr));
18914 end Unreferenced_Objects;
18916 ------------------------------
18917 -- Unreserve_All_Interrupts --
18918 ------------------------------
18920 -- pragma Unreserve_All_Interrupts;
18922 when Pragma_Unreserve_All_Interrupts =>
18924 Check_Arg_Count (0);
18926 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
18927 Unreserve_All_Interrupts := True;
18934 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
18936 when Pragma_Unsuppress =>
18938 Process_Suppress_Unsuppress (False);
18940 -------------------
18941 -- Use_VADS_Size --
18942 -------------------
18944 -- pragma Use_VADS_Size;
18946 when Pragma_Use_VADS_Size =>
18948 Check_Arg_Count (0);
18949 Check_Valid_Configuration_Pragma;
18950 Use_VADS_Size := True;
18952 ---------------------
18953 -- Validity_Checks --
18954 ---------------------
18956 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
18958 when Pragma_Validity_Checks => Validity_Checks : declare
18959 A : constant Node_Id := Get_Pragma_Arg (Arg1);
18965 Check_Arg_Count (1);
18966 Check_No_Identifiers;
18968 if Nkind (A) = N_String_Literal then
18972 Slen : constant Natural := Natural (String_Length (S));
18973 Options : String (1 .. Slen);
18979 C := Get_String_Char (S, Int (J));
18980 exit when not In_Character_Range (C);
18981 Options (J) := Get_Character (C);
18984 Set_Validity_Check_Options (Options);
18992 elsif Nkind (A) = N_Identifier then
18993 if Chars (A) = Name_All_Checks then
18994 Set_Validity_Check_Options ("a");
18995 elsif Chars (A) = Name_On then
18996 Validity_Checks_On := True;
18997 elsif Chars (A) = Name_Off then
18998 Validity_Checks_On := False;
19001 end Validity_Checks;
19007 -- pragma Volatile (LOCAL_NAME);
19009 when Pragma_Volatile =>
19010 Process_Atomic_Shared_Volatile;
19012 -------------------------
19013 -- Volatile_Components --
19014 -------------------------
19016 -- pragma Volatile_Components (array_LOCAL_NAME);
19018 -- Volatile is handled by the same circuit as Atomic_Components
19024 -- pragma Warnings (On | Off [,REASON]);
19025 -- pragma Warnings (On | Off, LOCAL_NAME [,REASON]);
19026 -- pragma Warnings (static_string_EXPRESSION [,REASON]);
19027 -- pragma Warnings (On | Off, STRING_LITERAL [,REASON]);
19029 -- REASON ::= Reason => Static_String_Expression
19031 when Pragma_Warnings => Warnings : begin
19033 Check_At_Least_N_Arguments (1);
19035 -- See if last argument is labeled Reason. If so, make sure we
19036 -- have a static string expression, but otherwise just ignore
19037 -- the REASON argument by decreasing Num_Args by 1 (all the
19038 -- remaining tests look only at the first Num_Args arguments).
19041 Last_Arg : constant Node_Id :=
19042 Last (Pragma_Argument_Associations (N));
19044 if Nkind (Last_Arg) = N_Pragma_Argument_Association
19045 and then Chars (Last_Arg) = Name_Reason
19047 Check_Arg_Is_Static_Expression (Last_Arg, Standard_String);
19048 Arg_Count := Arg_Count - 1;
19050 -- Not allowed in compiler units (bootstrap issues)
19052 Check_Compiler_Unit (N);
19056 -- Now proceed with REASON taken care of and eliminated
19058 Check_No_Identifiers;
19060 -- If debug flag -gnatd.i is set, pragma is ignored
19062 if Debug_Flag_Dot_I then
19066 -- Process various forms of the pragma
19069 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
19072 -- One argument case
19074 if Arg_Count = 1 then
19076 -- On/Off one argument case was processed by parser
19078 if Nkind (Argx) = N_Identifier
19079 and then Nam_In (Chars (Argx), Name_On, Name_Off)
19083 -- One argument case must be ON/OFF or static string expr
19085 elsif not Is_Static_String_Expression (Arg1) then
19087 ("argument of pragma% must be On/Off or static string "
19088 & "expression", Arg1);
19090 -- One argument string expression case
19094 Lit : constant Node_Id := Expr_Value_S (Argx);
19095 Str : constant String_Id := Strval (Lit);
19096 Len : constant Nat := String_Length (Str);
19104 while J <= Len loop
19105 C := Get_String_Char (Str, J);
19106 OK := In_Character_Range (C);
19109 Chr := Get_Character (C);
19111 -- Dash case: only -Wxxx is accepted
19118 C := Get_String_Char (Str, J);
19119 Chr := Get_Character (C);
19120 exit when Chr = 'W';
19125 elsif J < Len and then Chr = '.' then
19127 C := Get_String_Char (Str, J);
19128 Chr := Get_Character (C);
19130 if not Set_Dot_Warning_Switch (Chr) then
19132 ("invalid warning switch character "
19133 & '.' & Chr, Arg1);
19139 OK := Set_Warning_Switch (Chr);
19145 ("invalid warning switch character " & Chr,
19154 -- Two or more arguments (must be two)
19157 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
19158 Check_At_Most_N_Arguments (2);
19166 E_Id := Get_Pragma_Arg (Arg2);
19169 -- In the expansion of an inlined body, a reference to
19170 -- the formal may be wrapped in a conversion if the
19171 -- actual is a conversion. Retrieve the real entity name.
19173 if (In_Instance_Body or In_Inlined_Body)
19174 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
19176 E_Id := Expression (E_Id);
19179 -- Entity name case
19181 if Is_Entity_Name (E_Id) then
19182 E := Entity (E_Id);
19189 (E, (Chars (Get_Pragma_Arg (Arg1)) =
19192 -- For OFF case, make entry in warnings off
19193 -- pragma table for later processing. But we do
19194 -- not do that within an instance, since these
19195 -- warnings are about what is needed in the
19196 -- template, not an instance of it.
19198 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
19199 and then Warn_On_Warnings_Off
19200 and then not In_Instance
19202 Warnings_Off_Pragmas.Append ((N, E));
19205 if Is_Enumeration_Type (E) then
19209 Lit := First_Literal (E);
19210 while Present (Lit) loop
19211 Set_Warnings_Off (Lit);
19212 Next_Literal (Lit);
19217 exit when No (Homonym (E));
19222 -- Error if not entity or static string literal case
19224 elsif not Is_Static_String_Expression (Arg2) then
19226 ("second argument of pragma% must be entity name "
19227 & "or static string expression", Arg2);
19229 -- String literal case
19232 String_To_Name_Buffer
19233 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg2))));
19235 -- Note on configuration pragma case: If this is a
19236 -- configuration pragma, then for an OFF pragma, we
19237 -- just set Config True in the call, which is all
19238 -- that needs to be done. For the case of ON, this
19239 -- is normally an error, unless it is canceling the
19240 -- effect of a previous OFF pragma in the same file.
19241 -- In any other case, an error will be signalled (ON
19242 -- with no matching OFF).
19244 -- Note: We set Used if we are inside a generic to
19245 -- disable the test that the non-config case actually
19246 -- cancels a warning. That's because we can't be sure
19247 -- there isn't an instantiation in some other unit
19248 -- where a warning is suppressed.
19250 -- We could do a little better here by checking if the
19251 -- generic unit we are inside is public, but for now
19252 -- we don't bother with that refinement.
19254 if Chars (Argx) = Name_Off then
19255 Set_Specific_Warning_Off
19256 (Loc, Name_Buffer (1 .. Name_Len),
19257 Config => Is_Configuration_Pragma,
19258 Used => Inside_A_Generic or else In_Instance);
19260 elsif Chars (Argx) = Name_On then
19261 Set_Specific_Warning_On
19262 (Loc, Name_Buffer (1 .. Name_Len), Err);
19266 ("??pragma Warnings On with no matching "
19267 & "Warnings Off", Loc);
19276 -------------------
19277 -- Weak_External --
19278 -------------------
19280 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
19282 when Pragma_Weak_External => Weak_External : declare
19287 Check_Arg_Count (1);
19288 Check_Optional_Identifier (Arg1, Name_Entity);
19289 Check_Arg_Is_Library_Level_Local_Name (Arg1);
19290 Ent := Entity (Get_Pragma_Arg (Arg1));
19292 if Rep_Item_Too_Early (Ent, N) then
19295 Ent := Underlying_Type (Ent);
19298 -- The only processing required is to link this item on to the
19299 -- list of rep items for the given entity. This is accomplished
19300 -- by the call to Rep_Item_Too_Late (when no error is detected
19301 -- and False is returned).
19303 if Rep_Item_Too_Late (Ent, N) then
19306 Set_Has_Gigi_Rep_Item (Ent);
19310 -----------------------------
19311 -- Wide_Character_Encoding --
19312 -----------------------------
19314 -- pragma Wide_Character_Encoding (IDENTIFIER);
19316 when Pragma_Wide_Character_Encoding =>
19319 -- Nothing to do, handled in parser. Note that we do not enforce
19320 -- configuration pragma placement, this pragma can appear at any
19321 -- place in the source, allowing mixed encodings within a single
19326 --------------------
19327 -- Unknown_Pragma --
19328 --------------------
19330 -- Should be impossible, since the case of an unknown pragma is
19331 -- separately processed before the case statement is entered.
19333 when Unknown_Pragma =>
19334 raise Program_Error;
19337 -- AI05-0144: detect dangerous order dependence. Disabled for now,
19338 -- until AI is formally approved.
19340 -- Check_Order_Dependence;
19343 when Pragma_Exit => null;
19344 end Analyze_Pragma;
19346 ---------------------------------------------
19347 -- Analyze_Pre_Post_Condition_In_Decl_Part --
19348 ---------------------------------------------
19350 procedure Analyze_Pre_Post_Condition_In_Decl_Part
19352 Subp_Id : Entity_Id)
19354 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (Prag));
19355 Nam : constant Name_Id := Original_Aspect_Name (Prag);
19358 Restore_Scope : Boolean := False;
19359 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
19362 -- Ensure that the subprogram and its formals are visible when analyzing
19363 -- the expression of the pragma.
19365 if not In_Open_Scopes (Subp_Id) then
19366 Restore_Scope := True;
19367 Push_Scope (Subp_Id);
19368 Install_Formals (Subp_Id);
19371 -- Preanalyze the boolean expression, we treat this as a spec expression
19372 -- (i.e. similar to a default expression).
19374 Expr := Get_Pragma_Arg (Arg1);
19376 -- In ASIS mode, for a pragma generated from a source aspect, analyze
19377 -- the original aspect expression, which is shared with the generated
19380 if ASIS_Mode and then Present (Corresponding_Aspect (Prag)) then
19381 Expr := Expression (Corresponding_Aspect (Prag));
19384 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
19386 -- For a class-wide condition, a reference to a controlling formal must
19387 -- be interpreted as having the class-wide type (or an access to such)
19388 -- so that the inherited condition can be properly applied to any
19389 -- overriding operation (see ARM12 6.6.1 (7)).
19391 if Class_Present (Prag) then
19392 Class_Wide_Condition : declare
19393 T : constant Entity_Id := Find_Dispatching_Type (Subp_Id);
19395 ACW : Entity_Id := Empty;
19396 -- Access to T'class, created if there is a controlling formal
19397 -- that is an access parameter.
19399 function Get_ACW return Entity_Id;
19400 -- If the expression has a reference to an controlling access
19401 -- parameter, create an access to T'class for the necessary
19402 -- conversions if one does not exist.
19404 function Process (N : Node_Id) return Traverse_Result;
19405 -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
19406 -- aspect for a primitive subprogram of a tagged type T, a name
19407 -- that denotes a formal parameter of type T is interpreted as
19408 -- having type T'Class. Similarly, a name that denotes a formal
19409 -- accessparameter of type access-to-T is interpreted as having
19410 -- type access-to-T'Class. This ensures the expression is well-
19411 -- defined for a primitive subprogram of a type descended from T.
19412 -- Note that this replacement is not done for selector names in
19413 -- parameter associations. These carry an entity for reference
19414 -- purposes, but semantically they are just identifiers.
19420 function Get_ACW return Entity_Id is
19421 Loc : constant Source_Ptr := Sloc (Prag);
19427 Make_Full_Type_Declaration (Loc,
19428 Defining_Identifier => Make_Temporary (Loc, 'T'),
19430 Make_Access_To_Object_Definition (Loc,
19431 Subtype_Indication =>
19432 New_Occurrence_Of (Class_Wide_Type (T), Loc),
19433 All_Present => True));
19435 Insert_Before (Unit_Declaration_Node (Subp_Id), Decl);
19437 ACW := Defining_Identifier (Decl);
19438 Freeze_Before (Unit_Declaration_Node (Subp_Id), ACW);
19448 function Process (N : Node_Id) return Traverse_Result is
19449 Loc : constant Source_Ptr := Sloc (N);
19453 if Is_Entity_Name (N)
19454 and then Present (Entity (N))
19455 and then Is_Formal (Entity (N))
19456 and then Nkind (Parent (N)) /= N_Type_Conversion
19458 (Nkind (Parent (N)) /= N_Parameter_Association
19459 or else N /= Selector_Name (Parent (N)))
19461 if Etype (Entity (N)) = T then
19462 Typ := Class_Wide_Type (T);
19464 elsif Is_Access_Type (Etype (Entity (N)))
19465 and then Designated_Type (Etype (Entity (N))) = T
19472 if Present (Typ) then
19474 Make_Type_Conversion (Loc,
19476 New_Occurrence_Of (Typ, Loc),
19477 Expression => New_Occurrence_Of (Entity (N), Loc)));
19478 Set_Etype (N, Typ);
19485 procedure Replace_Type is new Traverse_Proc (Process);
19487 -- Start of processing for Class_Wide_Condition
19490 if not Present (T) then
19492 -- Pre'Class/Post'Class aspect cases
19494 if From_Aspect_Specification (Prag) then
19495 if Nam = Name_uPre then
19496 Error_Msg_Name_1 := Name_Pre;
19498 Error_Msg_Name_1 := Name_Post;
19501 Error_Msg_Name_2 := Name_Class;
19504 ("aspect `%''%` can only be specified for a primitive "
19505 & "operation of a tagged type",
19506 Corresponding_Aspect (Prag));
19508 -- Pre_Class, Post_Class pragma cases
19511 if Nam = Name_uPre then
19512 Error_Msg_Name_1 := Name_Pre_Class;
19514 Error_Msg_Name_1 := Name_Post_Class;
19518 ("pragma% can only be specified for a primitive "
19519 & "operation of a tagged type",
19520 Corresponding_Aspect (Prag));
19524 Replace_Type (Get_Pragma_Arg (Arg1));
19525 end Class_Wide_Condition;
19528 -- Remove the subprogram from the scope stack now that the pre-analysis
19529 -- of the precondition/postcondition is done.
19531 if Restore_Scope then
19534 end Analyze_Pre_Post_Condition_In_Decl_Part;
19536 ------------------------------------------
19537 -- Analyze_Refined_Depends_In_Decl_Part --
19538 ------------------------------------------
19540 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
19541 Dependencies : List_Id := No_List;
19543 -- The corresponding Depends pragma along with its clauses
19545 Global : Node_Id := Empty;
19546 -- The corresponding Refined_Global pragma (if any)
19548 Out_Items : Elist_Id := No_Elist;
19549 -- All output items as defined in pragma Refined_Global (if any)
19551 Refinements : List_Id := No_List;
19552 -- The clauses of pragma Refined_Depends
19554 Spec_Id : Entity_Id;
19555 -- The entity of the subprogram subject to pragma Refined_Depends
19557 procedure Check_Dependency_Clause (Dep_Clause : Node_Id);
19558 -- Verify the legality of a single clause
19560 procedure Report_Extra_Clauses;
19561 -- Emit an error for each extra clause the appears in Refined_Depends
19563 -----------------------------
19564 -- Check_Dependency_Clause --
19565 -----------------------------
19567 procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is
19568 function Inputs_Match
19569 (Ref_Clause : Node_Id;
19570 Do_Checks : Boolean) return Boolean;
19571 -- Determine whether the inputs of clause Dep_Clause match those of
19572 -- clause Ref_Clause. If flag Do_Checks is set, the routine reports
19573 -- missed or extra input items.
19575 function Output_Constituents (State_Id : Entity_Id) return Elist_Id;
19576 -- Given a state denoted by State_Id, return a list of all output
19577 -- constituents that may be referenced within Refined_Depends. The
19578 -- contents of the list depend on whethe Refined_Global is present.
19580 procedure Report_Unused_Constituents (Constits : Elist_Id);
19581 -- Emit errors for all constituents found in list Constits
19587 function Inputs_Match
19588 (Ref_Clause : Node_Id;
19589 Do_Checks : Boolean) return Boolean
19591 Ref_Inputs : List_Id;
19592 -- The input list of the refinement clause
19594 function Is_Matching_Input (Dep_Input : Node_Id) return Boolean;
19595 -- Determine whether input Dep_Input matches one of the inputs of
19596 -- clause Ref_Clause.
19598 procedure Report_Extra_Inputs;
19599 -- Emit errors for all extra inputs that appear in Ref_Clause
19601 -----------------------
19602 -- Is_Matching_Input --
19603 -----------------------
19605 function Is_Matching_Input (Dep_Input : Node_Id) return Boolean is
19606 procedure Match_Error (Msg : String; N : Node_Id);
19607 -- Emit a matching error if flag Do_Checks is set
19613 procedure Match_Error (Msg : String; N : Node_Id) is
19616 Error_Msg_N (Msg, N);
19623 Next_Ref_Input : Node_Id;
19624 Ref_Id : Entity_Id;
19625 Ref_Input : Node_Id;
19627 Has_Constituent : Boolean := False;
19628 -- Flag set when the refinement input list contains at least
19629 -- one constituent of the state denoted by Dep_Id.
19631 Has_Null_State : Boolean := False;
19632 -- Flag set when the dependency input is a state with a null
19635 Has_Refined_State : Boolean := False;
19636 -- Flag set when the dependency input is a state with visible
19639 -- Start of processing for Is_Matching_Input
19642 -- Match a null input with another null input
19644 if Nkind (Dep_Input) = N_Null then
19645 if Nkind (Expression (Ref_Clause)) = N_Null then
19649 ("null input cannot be matched in corresponding "
19650 & "refinement clause", Dep_Input);
19653 -- The remaining cases are formal parameters, variables and
19657 Dep_Id := Entity_Of (Dep_Input);
19659 -- Inspect all inputs of the refinement clause and attempt
19660 -- to match against the inputs of the dependance clause.
19662 Ref_Input := First (Ref_Inputs);
19663 while Present (Ref_Input) loop
19665 -- Store the next input now because a match will remove
19666 -- it from the list.
19668 Next_Ref_Input := Next (Ref_Input);
19670 if Ekind (Dep_Id) = E_Abstract_State then
19672 -- A state with a null refinement matches either a
19673 -- null input list or nothing at all (no input):
19675 -- Refined_State (State => null)
19679 -- Depends => (<output> => (State, Input))
19680 -- Refined_Depends => (<output> => Input -- OK
19684 -- Depends => (<output> => State)
19685 -- Refined_Depends => (<output> => null) -- OK
19687 if Has_Null_Refinement (Dep_Id) then
19688 Has_Null_State := True;
19690 -- Remove the matching null from the pool of
19693 if Nkind (Ref_Input) = N_Null then
19694 Remove (Ref_Input);
19699 -- The state has a non-null refinement in which case
19700 -- remove all the matching constituents of the state:
19702 -- Refined_State => (State => (C1, C2))
19703 -- Depends => (<output> => State)
19704 -- Refined_Depends => (<output> => (C1, C2))
19706 elsif Has_Non_Null_Refinement (Dep_Id) then
19707 Has_Refined_State := True;
19709 if Is_Entity_Name (Ref_Input) then
19710 Ref_Id := Entity_Of (Ref_Input);
19712 -- The input of the refinement clause is a valid
19713 -- constituent of the state. Remove the input
19714 -- from the pool of candidates. Note that the
19715 -- search continues because the state may be
19716 -- represented by multiple constituents.
19718 if Ekind_In (Ref_Id, E_Abstract_State,
19720 and then Present (Refined_State (Ref_Id))
19721 and then Refined_State (Ref_Id) = Dep_Id
19723 Has_Constituent := True;
19724 Remove (Ref_Input);
19729 -- Formal parameters and variables are matched on
19730 -- entities. If this is the case, remove the input from
19731 -- the candidate list.
19733 elsif Is_Entity_Name (Ref_Input)
19734 and then Entity_Of (Ref_Input) = Dep_Id
19736 Remove (Ref_Input);
19740 Ref_Input := Next_Ref_Input;
19744 -- A state with visible refinement was matched against one or
19745 -- more of its constituents.
19747 if Has_Constituent then
19750 -- A state with a null refinement matched null or nothing
19752 elsif Has_Null_State then
19755 -- The input of a dependence clause does not have a matching
19756 -- input in the refinement clause, emit an error.
19760 ("input cannot be matched in corresponding refinement "
19761 & "clause", Dep_Input);
19763 if Has_Refined_State then
19765 ("\check the use of constituents in dependence "
19766 & "refinement", Dep_Input);
19771 end Is_Matching_Input;
19773 -------------------------
19774 -- Report_Extra_Inputs --
19775 -------------------------
19777 procedure Report_Extra_Inputs is
19781 if Present (Ref_Inputs) and then Do_Checks then
19782 Input := First (Ref_Inputs);
19783 while Present (Input) loop
19785 ("unmatched or extra input in refinement clause",
19791 end Report_Extra_Inputs;
19795 Dep_Inputs : constant Node_Id := Expression (Dep_Clause);
19796 Inputs : constant Node_Id := Expression (Ref_Clause);
19797 Dep_Input : Node_Id;
19800 -- Start of processing for Inputs_Match
19803 -- Construct a list of all refinement inputs. Note that the input
19804 -- list is copied because the algorithm modifies its contents and
19805 -- this should not be visible in Refined_Depends.
19807 if Nkind (Inputs) = N_Aggregate then
19808 Ref_Inputs := New_Copy_List (Expressions (Inputs));
19810 Ref_Inputs := New_List (Inputs);
19813 -- Depending on whether the original dependency clause mentions
19814 -- states with visible refinement, the corresponding refinement
19815 -- clause may differ greatly in structure and contents:
19817 -- State with null refinement
19819 -- Refined_State => (State => null)
19820 -- Depends => (<output> => State)
19821 -- Refined_Depends => (<output> => null)
19823 -- Depends => (<output> => (State, Input))
19824 -- Refined_Depends => (<output> => Input)
19826 -- Depends => (<output> => (Input_1, State, Input_2))
19827 -- Refined_Depends => (<output> => (Input_1, Input_2))
19829 -- State with non-null refinement
19831 -- Refined_State => (State_1 => (C1, C2))
19832 -- Depends => (<output> => State)
19833 -- Refined_Depends => (<output> => C1)
19835 -- Refined_Depends => (<output> => (C1, C2))
19837 if Nkind (Dep_Inputs) = N_Aggregate then
19838 Dep_Input := First (Expressions (Dep_Inputs));
19839 while Present (Dep_Input) loop
19840 if not Is_Matching_Input (Dep_Input) then
19852 Result := Is_Matching_Input (Dep_Inputs);
19855 Report_Extra_Inputs;
19859 -------------------------
19860 -- Output_Constituents --
19861 -------------------------
19863 function Output_Constituents (State_Id : Entity_Id) return Elist_Id is
19864 Item_Elmt : Elmt_Id;
19865 Item_Id : Entity_Id;
19866 Result : Elist_Id := No_Elist;
19869 -- The related subprogram is subject to pragma Refined_Global. All
19870 -- usable output constituents are defined in its output item list.
19872 if Present (Global) then
19873 Item_Elmt := First_Elmt (Out_Items);
19874 while Present (Item_Elmt) loop
19875 Item_Id := Node (Item_Elmt);
19877 -- The constituent is part of the refinement of the input
19878 -- state, add it to the result list.
19880 if Refined_State (Item_Id) = State_Id then
19881 Add_Item (Item_Id, Result);
19884 Next_Elmt (Item_Elmt);
19887 -- When pragma Refined_Global is not present, the usable output
19888 -- constituents are all the constituents as defined in pragma
19889 -- Refined_State. Note that the elements are copied because the
19890 -- algorithm trims the list and this should not be reflected in
19891 -- the state itself.
19894 Result := New_Copy_Elist (Refinement_Constituents (State_Id));
19898 end Output_Constituents;
19900 --------------------------------
19901 -- Report_Unused_Constituents --
19902 --------------------------------
19904 procedure Report_Unused_Constituents (Constits : Elist_Id) is
19905 Constit : Entity_Id;
19907 Posted : Boolean := False;
19910 if Present (Constits) then
19911 Elmt := First_Elmt (Constits);
19912 while Present (Elmt) loop
19913 Constit := Node (Elmt);
19915 -- A constituent must always refine a state
19917 pragma Assert (Present (Refined_State (Constit)));
19919 -- When a state has a visible refinement and its mode is
19920 -- Output_Only, all its constituents must be used as
19926 ("output only state & must be replaced by all its "
19927 & "constituents in dependence refinement",
19928 N, Refined_State (Constit));
19932 ("\ constituent & is missing in output list", N, Constit);
19937 end Report_Unused_Constituents;
19941 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
19942 Dep_Id : Entity_Id;
19943 Matching_Clause : Node_Id := Empty;
19944 Next_Ref_Clause : Node_Id;
19945 Ref_Clause : Node_Id;
19946 Ref_Id : Entity_Id;
19947 Ref_Output : Node_Id;
19949 Has_Constituent : Boolean := False;
19950 -- Flag set when the refinement output list contains at least one
19951 -- constituent of the state denoted by Dep_Id.
19953 Has_Null_State : Boolean := False;
19954 -- Flag set when the output of clause Dep_Clause is a state with a
19955 -- null refinement.
19957 Has_Refined_State : Boolean := False;
19958 -- Flag set when the output of clause Dep_Clause is a state with
19959 -- visible refinement.
19961 Out_Constits : Elist_Id := No_Elist;
19962 -- This list contains the entities all output constituents of state
19963 -- Dep_Id as defined in pragma Refined_State.
19965 -- Start of processing for Check_Dependency_Clause
19968 -- The analysis of pragma Depends should produce normalized clauses
19969 -- with exactly one output. This is important because output items
19970 -- are unique in the whole dependance relation and can be used as
19973 pragma Assert (No (Next (Dep_Output)));
19975 -- Inspect all clauses of Refined_Depends and attempt to match the
19976 -- output of Dep_Clause against an output from the refinement clauses
19979 Ref_Clause := First (Refinements);
19980 while Present (Ref_Clause) loop
19981 Matching_Clause := Empty;
19983 -- Store the next clause now because a match will trim the list of
19984 -- refinement clauses and this side effect should not be visible
19985 -- in pragma Refined_Depends.
19987 Next_Ref_Clause := Next (Ref_Clause);
19989 -- The analysis of pragma Refined_Depends should produce
19990 -- normalized clauses with exactly one output.
19992 Ref_Output := First (Choices (Ref_Clause));
19993 pragma Assert (No (Next (Ref_Output)));
19995 -- Two null output lists match if their inputs match
19997 if Nkind (Dep_Output) = N_Null
19998 and then Nkind (Ref_Output) = N_Null
20000 Matching_Clause := Ref_Clause;
20003 -- Two function 'Result attributes match if their inputs match.
20004 -- Note that there is no need to compare the two prefixes because
20005 -- the attributes cannot denote anything but the related function.
20007 elsif Is_Attribute_Result (Dep_Output)
20008 and then Is_Attribute_Result (Ref_Output)
20010 Matching_Clause := Ref_Clause;
20013 -- The remaining cases are formal parameters, variables and states
20015 elsif Is_Entity_Name (Dep_Output) then
20016 Dep_Id := Entity_Of (Dep_Output);
20018 if Ekind (Dep_Id) = E_Abstract_State then
20020 -- A state with a null refinement matches either a null
20021 -- output list or nothing at all (no clause):
20023 -- Refined_State => (State => null)
20027 -- Depends => (State => null)
20028 -- Refined_Depends => null -- OK
20030 -- Null output list
20032 -- Depends => (State => <input>)
20033 -- Refined_Depends => (null => <input>) -- OK
20035 if Has_Null_Refinement (Dep_Id) then
20036 Has_Null_State := True;
20038 -- When a state with null refinement matches a null
20039 -- output, compare their inputs.
20041 if Nkind (Ref_Output) = N_Null then
20042 Matching_Clause := Ref_Clause;
20047 -- The state has a non-null refinement in which case the
20048 -- match is based on constituents and inputs. A state with
20049 -- multiple output constituents may match multiple clauses:
20051 -- Refined_State => (State => (C1, C2))
20052 -- Depends => (State => <input>)
20053 -- Refined_Depends => ((C1, C2) => <input>)
20055 -- When normalized, the above becomes:
20057 -- Refined_Depends => (C1 => <input>,
20060 elsif Has_Non_Null_Refinement (Dep_Id) then
20061 Has_Refined_State := True;
20063 -- Store the entities of all output constituents of an
20064 -- Output_Only state with visible refinement.
20066 if No (Out_Constits)
20067 and then Is_Output_Only_State (Dep_Id)
20069 Out_Constits := Output_Constituents (Dep_Id);
20072 if Is_Entity_Name (Ref_Output) then
20073 Ref_Id := Entity_Of (Ref_Output);
20075 -- The output of the refinement clause is a valid
20076 -- constituent of the state. Remove the clause from
20077 -- the pool of candidates if both input lists match.
20078 -- Note that the search continues because one clause
20079 -- may have been normalized into multiple clauses as
20080 -- per the example above.
20082 if Ekind_In (Ref_Id, E_Abstract_State, E_Variable)
20083 and then Present (Refined_State (Ref_Id))
20084 and then Refined_State (Ref_Id) = Dep_Id
20085 and then Inputs_Match
20086 (Ref_Clause, Do_Checks => False)
20088 Has_Constituent := True;
20089 Remove (Ref_Clause);
20091 -- The matching constituent may act as an output
20092 -- for an Output_Only state. Remove the item from
20093 -- the available output constituents.
20095 Remove (Out_Constits, Ref_Id);
20100 -- Formal parameters and variables match when their inputs
20103 elsif Is_Entity_Name (Ref_Output)
20104 and then Entity_Of (Ref_Output) = Dep_Id
20106 Matching_Clause := Ref_Clause;
20111 Ref_Clause := Next_Ref_Clause;
20114 -- Handle the case where pragma Depends contains one or more clauses
20115 -- that only mention states with null refinements. In that case the
20116 -- corresponding pragma Refined_Depends may have a null relation.
20118 -- Refined_State => (State => null)
20119 -- Depends => (State => null)
20120 -- Refined_Depends => null -- OK
20122 if No (Refinements) and then Is_Entity_Name (Dep_Output) then
20123 Dep_Id := Entity_Of (Dep_Output);
20125 if Ekind (Dep_Id) = E_Abstract_State
20126 and then Has_Null_Refinement (Dep_Id)
20128 Has_Null_State := True;
20132 -- The above search produced a match based on unique output. Ensure
20133 -- that the inputs match as well and if they do, remove the clause
20134 -- from the pool of candidates.
20136 if Present (Matching_Clause) then
20137 if Inputs_Match (Matching_Clause, Do_Checks => True) then
20138 Remove (Matching_Clause);
20141 -- A state with a visible refinement was matched against one or
20142 -- more clauses containing appropriate constituents.
20144 elsif Has_Constituent then
20147 -- A state with a null refinement did not warrant a clause
20149 elsif Has_Null_State then
20152 -- The dependence relation of pragma Refined_Depends does not contain
20153 -- a matching clause, emit an error.
20157 ("dependence clause of subprogram & has no matching refinement "
20158 & "in body", Ref_Clause, Spec_Id);
20160 if Has_Refined_State then
20162 ("\check the use of constituents in dependence refinement",
20167 -- Emit errors for all unused constituents of an Output_Only state
20168 -- with visible refinement.
20170 Report_Unused_Constituents (Out_Constits);
20171 end Check_Dependency_Clause;
20173 --------------------------
20174 -- Report_Extra_Clauses --
20175 --------------------------
20177 procedure Report_Extra_Clauses is
20181 if Present (Refinements) then
20182 Clause := First (Refinements);
20183 while Present (Clause) loop
20185 ("unmatched or extra clause in dependence refinement",
20191 end Report_Extra_Clauses;
20195 Body_Decl : constant Node_Id := Parent (N);
20196 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
20197 Errors : constant Nat := Serious_Errors_Detected;
20202 -- The following are dummy variables that capture unused output of
20203 -- routine Collect_Global_Items.
20205 D1, D2 : Elist_Id := No_Elist;
20206 D3, D4, D5, D6 : Boolean;
20208 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
20211 Spec_Id := Corresponding_Spec (Body_Decl);
20212 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
20214 -- The subprogram declarations lacks pragma Depends. This renders
20215 -- Refined_Depends useless as there is nothing to refine.
20217 if No (Depends) then
20219 ("useless refinement, subprogram & lacks dependence clauses",
20224 Deps := Get_Pragma_Arg (First (Pragma_Argument_Associations (Depends)));
20226 -- A null dependency relation renders the refinement useless because it
20227 -- cannot possibly mention abstract states with visible refinement. Note
20228 -- that the inverse is not true as states may be refined to null.
20230 if Nkind (Deps) = N_Null then
20232 ("useless refinement, subprogram & does not depend on abstract "
20233 & "state with visible refinement", N, Spec_Id);
20237 -- Multiple dependency clauses appear as component associations of an
20240 pragma Assert (Nkind (Deps) = N_Aggregate);
20241 Dependencies := Component_Associations (Deps);
20243 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
20244 -- This ensures that the categorization of all refined dependency items
20245 -- is consistent with their role.
20247 Analyze_Depends_In_Decl_Part (N);
20248 Refs := Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
20250 if Serious_Errors_Detected = Errors then
20252 -- The related subprogram may be subject to pragma Refined_Global. If
20253 -- this is the case, gather all output items. These are needed when
20254 -- verifying the use of constituents that apply to output states with
20255 -- visible refinement.
20257 Global := Get_Pragma (Body_Id, Pragma_Refined_Global);
20259 if Present (Global) then
20260 Collect_Global_Items
20263 In_Out_Items => D2,
20264 Out_Items => Out_Items,
20265 Has_In_State => D3,
20266 Has_In_Out_State => D4,
20267 Has_Out_State => D5,
20268 Has_Null_State => D6);
20271 if Nkind (Refs) = N_Null then
20272 Refinements := No_List;
20274 -- Multiple dependeny clauses appear as component associations of an
20275 -- aggregate. Note that the clauses are copied because the algorithm
20276 -- modifies them and this should not be visible in Refined_Depends.
20278 else pragma Assert (Nkind (Refs) = N_Aggregate);
20279 Refinements := New_Copy_List (Component_Associations (Refs));
20282 -- Inspect all the clauses of pragma Depends trying to find a
20283 -- matching clause in pragma Refined_Depends. The approach is to use
20284 -- the sole output of a clause as a key. Output items are unique in a
20285 -- dependence relation. Clause normalization also ensured that all
20286 -- clauses have exactly on output. Depending on what the key is, one
20287 -- or more refinement clauses may satisfy the dependency clause. Each
20288 -- time a dependency clause is matched, its related refinement clause
20289 -- is consumed. In the end, two things may happen:
20291 -- 1) A clause of pragma Depends was not matched in which case
20292 -- Check_Dependency_Clause reports the error.
20294 -- 2) Refined_Depends has an extra clause in which case the error
20295 -- is reported by Report_Extra_Clauses.
20297 Clause := First (Dependencies);
20298 while Present (Clause) loop
20299 Check_Dependency_Clause (Clause);
20305 if Serious_Errors_Detected = Errors then
20306 Report_Extra_Clauses;
20308 end Analyze_Refined_Depends_In_Decl_Part;
20310 -----------------------------------------
20311 -- Analyze_Refined_Global_In_Decl_Part --
20312 -----------------------------------------
20314 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is
20316 -- The corresponding Global pragma
20318 Has_In_State : Boolean := False;
20319 Has_In_Out_State : Boolean := False;
20320 Has_Out_State : Boolean := False;
20321 -- These flags are set when the corresponding Global pragma has a state
20322 -- of mode Input, In_Out and Output respectively with a visible
20325 Has_Null_State : Boolean := False;
20326 -- This flag is set when the corresponding Global pragma has at least
20327 -- one state with a null refinement.
20329 In_Constits : Elist_Id := No_Elist;
20330 In_Out_Constits : Elist_Id := No_Elist;
20331 Out_Constits : Elist_Id := No_Elist;
20332 -- These lists contain the entities of all Input, In_Out and Output
20333 -- constituents that appear in Refined_Global and participate in state
20336 In_Items : Elist_Id := No_Elist;
20337 In_Out_Items : Elist_Id := No_Elist;
20338 Out_Items : Elist_Id := No_Elist;
20339 -- These list contain the entities of all Input, In_Out and Output items
20340 -- defined in the corresponding Global pragma.
20342 procedure Check_In_Out_States;
20343 -- Determine whether the corresponding Global pragma mentions In_Out
20344 -- states with visible refinement and if so, ensure that one of the
20345 -- following completions apply to the constituents of the state:
20346 -- 1) there is at least one constituent of mode In_Out
20347 -- 2) there is at least one Input and one Output constituent
20348 -- 3) not all constituents are present and one of them is of mode
20350 -- This routine may remove elements from In_Constits, In_Out_Constits
20351 -- and Out_Constits.
20353 procedure Check_Input_States;
20354 -- Determine whether the corresponding Global pragma mentions Input
20355 -- states with visible refinement and if so, ensure that at least one of
20356 -- its constituents appears as an Input item in Refined_Global.
20357 -- This routine may remove elements from In_Constits, In_Out_Constits
20358 -- and Out_Constits.
20360 procedure Check_Output_States;
20361 -- Determine whether the corresponding Global pragma mentions Output
20362 -- states with visible refinement and if so, ensure that all of its
20363 -- constituents appear as Output items in Refined_Global. This routine
20364 -- may remove elements from In_Constits, In_Out_Constits and
20367 procedure Check_Refined_Global_List
20369 Global_Mode : Name_Id := Name_Input);
20370 -- Verify the legality of a single global list declaration. Global_Mode
20371 -- denotes the current mode in effect.
20373 function Present_Then_Remove
20375 Item : Entity_Id) return Boolean;
20376 -- Search List for a particular entity Item. If Item has been found,
20377 -- remove it from List. This routine is used to strip lists In_Constits,
20378 -- In_Out_Constits and Out_Constits of valid constituents.
20380 procedure Report_Extra_Constituents;
20381 -- Emit an error for each constituent found in lists In_Constits,
20382 -- In_Out_Constits and Out_Constits.
20384 -------------------------
20385 -- Check_In_Out_States --
20386 -------------------------
20388 procedure Check_In_Out_States is
20389 procedure Check_Constituent_Usage (State_Id : Entity_Id);
20390 -- Determine whether one of the following coverage scenarios is in
20392 -- 1) there is at least one constituent of mode In_Out
20393 -- 2) there is at least one Input and one Output constituent
20394 -- 3) not all constituents are present and one of them is of mode
20396 -- If this is not the case, emit an error.
20398 -----------------------------
20399 -- Check_Constituent_Usage --
20400 -----------------------------
20402 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
20403 Constit_Elmt : Elmt_Id;
20404 Constit_Id : Entity_Id;
20405 Has_Missing : Boolean := False;
20406 In_Out_Seen : Boolean := False;
20407 In_Seen : Boolean := False;
20408 Out_Seen : Boolean := False;
20411 -- Process all the constituents of the state and note their modes
20412 -- within the global refinement.
20414 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
20415 while Present (Constit_Elmt) loop
20416 Constit_Id := Node (Constit_Elmt);
20418 if Present_Then_Remove (In_Constits, Constit_Id) then
20421 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then
20422 In_Out_Seen := True;
20424 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
20428 Has_Missing := True;
20431 Next_Elmt (Constit_Elmt);
20434 -- A single In_Out constituent is a valid completion
20436 if In_Out_Seen then
20439 -- A pair of one Input and one Output constituent is a valid
20442 elsif In_Seen and then Out_Seen then
20445 -- A single Output constituent is a valid completion only when
20446 -- some of the other constituents are missing.
20448 elsif Has_Missing and then Out_Seen then
20453 ("global refinement of state & redefines the mode of its "
20454 & "constituents", N, State_Id);
20456 end Check_Constituent_Usage;
20460 Item_Elmt : Elmt_Id;
20461 Item_Id : Entity_Id;
20463 -- Start of processing for Check_In_Out_States
20466 -- Inspect the In_Out items of the corresponding Global pragma
20467 -- looking for a state with a visible refinement.
20469 if Has_In_Out_State and then Present (In_Out_Items) then
20470 Item_Elmt := First_Elmt (In_Out_Items);
20471 while Present (Item_Elmt) loop
20472 Item_Id := Node (Item_Elmt);
20474 -- Ensure that one of the three coverage variants is satisfied
20476 if Ekind (Item_Id) = E_Abstract_State
20477 and then Has_Non_Null_Refinement (Item_Id)
20479 Check_Constituent_Usage (Item_Id);
20482 Next_Elmt (Item_Elmt);
20485 end Check_In_Out_States;
20487 ------------------------
20488 -- Check_Input_States --
20489 ------------------------
20491 procedure Check_Input_States is
20492 procedure Check_Constituent_Usage (State_Id : Entity_Id);
20493 -- Determine whether at least one constituent of state State_Id with
20494 -- visible refinement is used and has mode Input. Ensure that the
20495 -- remaining constituents do not have In_Out or Output modes.
20497 -----------------------------
20498 -- Check_Constituent_Usage --
20499 -----------------------------
20501 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
20502 Constit_Elmt : Elmt_Id;
20503 Constit_Id : Entity_Id;
20504 In_Seen : Boolean := False;
20507 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
20508 while Present (Constit_Elmt) loop
20509 Constit_Id := Node (Constit_Elmt);
20511 -- At least one of the constituents appears as an Input
20513 if Present_Then_Remove (In_Constits, Constit_Id) then
20516 -- The constituent appears in the global refinement, but has
20517 -- mode In_Out or Output.
20519 elsif Present_Then_Remove (In_Out_Constits, Constit_Id)
20520 or else Present_Then_Remove (Out_Constits, Constit_Id)
20522 Error_Msg_Name_1 := Chars (State_Id);
20524 ("constituent & of state % must have mode Input in global "
20525 & "refinement", N, Constit_Id);
20528 Next_Elmt (Constit_Elmt);
20531 -- Not one of the constituents appeared as Input
20533 if not In_Seen then
20535 ("global refinement of state & must include at least one "
20536 & "constituent of mode Input", N, State_Id);
20538 end Check_Constituent_Usage;
20542 Item_Elmt : Elmt_Id;
20543 Item_Id : Entity_Id;
20545 -- Start of processing for Check_Input_States
20548 -- Inspect the Input items of the corresponding Global pragma
20549 -- looking for a state with a visible refinement.
20551 if Has_In_State and then Present (In_Items) then
20552 Item_Elmt := First_Elmt (In_Items);
20553 while Present (Item_Elmt) loop
20554 Item_Id := Node (Item_Elmt);
20556 -- Ensure that at least one of the constituents is utilized and
20557 -- is of mode Input.
20559 if Ekind (Item_Id) = E_Abstract_State
20560 and then Has_Non_Null_Refinement (Item_Id)
20562 Check_Constituent_Usage (Item_Id);
20565 Next_Elmt (Item_Elmt);
20568 end Check_Input_States;
20570 -------------------------
20571 -- Check_Output_States --
20572 -------------------------
20574 procedure Check_Output_States is
20575 procedure Check_Constituent_Usage (State_Id : Entity_Id);
20576 -- Determine whether all constituents of state State_Id with visible
20577 -- refinement are used and have mode Output. Emit an error if this is
20580 -----------------------------
20581 -- Check_Constituent_Usage --
20582 -----------------------------
20584 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
20585 Constit_Elmt : Elmt_Id;
20586 Constit_Id : Entity_Id;
20589 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
20590 while Present (Constit_Elmt) loop
20591 Constit_Id := Node (Constit_Elmt);
20593 if Present_Then_Remove (Out_Constits, Constit_Id) then
20597 Remove (In_Constits, Constit_Id);
20598 Remove (In_Out_Constits, Constit_Id);
20600 Error_Msg_Name_1 := Chars (State_Id);
20602 ("constituent & of state % must have mode Output in "
20603 & "global refinement", N, Constit_Id);
20606 Next_Elmt (Constit_Elmt);
20608 end Check_Constituent_Usage;
20612 Item_Elmt : Elmt_Id;
20613 Item_Id : Entity_Id;
20615 -- Start of processing for Check_Output_States
20618 -- Inspect the Output items of the corresponding Global pragma
20619 -- looking for a state with a visible refinement.
20621 if Has_Out_State and then Present (Out_Items) then
20622 Item_Elmt := First_Elmt (Out_Items);
20623 while Present (Item_Elmt) loop
20624 Item_Id := Node (Item_Elmt);
20626 -- Ensure that all of the constituents are utilized and they
20627 -- have mode Output.
20629 if Ekind (Item_Id) = E_Abstract_State
20630 and then Has_Non_Null_Refinement (Item_Id)
20632 Check_Constituent_Usage (Item_Id);
20635 Next_Elmt (Item_Elmt);
20638 end Check_Output_States;
20640 -------------------------------
20641 -- Check_Refined_Global_List --
20642 -------------------------------
20644 procedure Check_Refined_Global_List
20646 Global_Mode : Name_Id := Name_Input)
20648 procedure Check_Refined_Global_Item
20650 Global_Mode : Name_Id);
20651 -- Verify the legality of a single global item declaration. Parameter
20652 -- Global_Mode denotes the current mode in effect.
20654 -------------------------------
20655 -- Check_Refined_Global_Item --
20656 -------------------------------
20658 procedure Check_Refined_Global_Item
20660 Global_Mode : Name_Id)
20662 procedure Add_Constituent (Item_Id : Entity_Id);
20663 -- Add a single constituent to one of the three constituent lists
20664 -- depending on Global_Mode.
20666 procedure Check_Matching_Modes (Item_Id : Entity_Id);
20667 -- Verify that the global modes of item Item_Id are the same in
20668 -- both pragmas Global and Refined_Global.
20670 ---------------------
20671 -- Add_Constituent --
20672 ---------------------
20674 procedure Add_Constituent (Item_Id : Entity_Id) is
20676 if Global_Mode = Name_Input then
20677 Add_Item (Item_Id, In_Constits);
20679 elsif Global_Mode = Name_In_Out then
20680 Add_Item (Item_Id, In_Out_Constits);
20682 elsif Global_Mode = Name_Output then
20683 Add_Item (Item_Id, Out_Constits);
20685 end Add_Constituent;
20687 --------------------------
20688 -- Check_Matching_Modes --
20689 --------------------------
20691 procedure Check_Matching_Modes (Item_Id : Entity_Id) is
20692 procedure Inconsistent_Mode_Error (Expect : Name_Id);
20693 -- Issue a common error message for all mode mismatche. Expect
20694 -- denotes the expected mode.
20696 -----------------------------
20697 -- Inconsistent_Mode_Error --
20698 -----------------------------
20700 procedure Inconsistent_Mode_Error (Expect : Name_Id) is
20703 ("global item & has inconsistent modes", Item, Item_Id);
20705 Error_Msg_Name_1 := Global_Mode;
20706 Error_Msg_N ("\ expected mode %", Item);
20708 Error_Msg_Name_1 := Expect;
20709 Error_Msg_N ("\ found mode %", Item);
20710 end Inconsistent_Mode_Error;
20712 -- Start processing for Check_Matching_Modes
20715 if Contains (In_Items, Item_Id) then
20716 if Global_Mode /= Name_Input then
20717 Inconsistent_Mode_Error (Name_Input);
20720 elsif Contains (In_Out_Items, Item_Id) then
20721 if Global_Mode /= Name_In_Out then
20722 Inconsistent_Mode_Error (Name_In_Out);
20725 elsif Contains (Out_Items, Item_Id) then
20726 if Global_Mode /= Name_Output then
20727 Inconsistent_Mode_Error (Name_Output);
20730 -- The item does not appear in the corresponding Global aspect,
20731 -- it must be an extra.
20734 Error_Msg_NE ("extra global item &", Item, Item_Id);
20736 end Check_Matching_Modes;
20740 Item_Id : constant Entity_Id := Entity_Of (Item);
20742 -- Start of processing for Check_Refined_Global_Item
20745 if Ekind (Item_Id) = E_Abstract_State then
20747 -- The state is neither a constituent of an ancestor state nor
20748 -- has a visible refinement. Ensure that the modes of both its
20749 -- occurrences in Global and Refined_Global match.
20751 if No (Refined_State (Item_Id))
20752 and then not Has_Visible_Refinement (Item_Id)
20754 Check_Matching_Modes (Item_Id);
20757 else pragma Assert (Ekind (Item_Id) = E_Variable);
20759 -- The variable acts as a constituent of a state, collect it
20760 -- for the state completeness checks performed later on.
20762 if Present (Refined_State (Item_Id)) then
20763 Add_Constituent (Item_Id);
20765 -- The variable is not a constituent. Ensure that the modes of
20766 -- both its occurrences in Global and Refined_Global match.
20769 Check_Matching_Modes (Item_Id);
20772 end Check_Refined_Global_Item;
20778 -- Start of processing for Check_Refined_Global_List
20781 if Nkind (List) = N_Null then
20784 -- Single global item declaration
20786 elsif Nkind_In (List, N_Expanded_Name,
20788 N_Selected_Component)
20790 Check_Refined_Global_Item (List, Global_Mode);
20792 -- Simple global list or moded global list declaration
20794 elsif Nkind (List) = N_Aggregate then
20796 -- The declaration of a simple global list appear as a collection
20799 if Present (Expressions (List)) then
20800 Item := First (Expressions (List));
20801 while Present (Item) loop
20802 Check_Refined_Global_Item (Item, Global_Mode);
20807 -- The declaration of a moded global list appears as a collection
20808 -- of component associations where individual choices denote
20811 elsif Present (Component_Associations (List)) then
20812 Item := First (Component_Associations (List));
20813 while Present (Item) loop
20814 Check_Refined_Global_List
20815 (List => Expression (Item),
20816 Global_Mode => Chars (First (Choices (Item))));
20824 raise Program_Error;
20830 raise Program_Error;
20832 end Check_Refined_Global_List;
20834 -------------------------
20835 -- Present_Then_Remove --
20836 -------------------------
20838 function Present_Then_Remove
20840 Item : Entity_Id) return Boolean
20845 if Present (List) then
20846 Elmt := First_Elmt (List);
20847 while Present (Elmt) loop
20848 if Node (Elmt) = Item then
20849 Remove_Elmt (List, Elmt);
20858 end Present_Then_Remove;
20860 -------------------------------
20861 -- Report_Extra_Constituents --
20862 -------------------------------
20864 procedure Report_Extra_Constituents is
20865 procedure Report_Extra_Constituents_In_List (List : Elist_Id);
20866 -- Emit an error for every element of List
20868 ---------------------------------------
20869 -- Report_Extra_Constituents_In_List --
20870 ---------------------------------------
20872 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is
20873 Constit_Elmt : Elmt_Id;
20876 if Present (List) then
20877 Constit_Elmt := First_Elmt (List);
20878 while Present (Constit_Elmt) loop
20879 Error_Msg_NE ("extra constituent &", N, Node (Constit_Elmt));
20880 Next_Elmt (Constit_Elmt);
20883 end Report_Extra_Constituents_In_List;
20885 -- Start of processing for Report_Extra_Constituents
20888 Report_Extra_Constituents_In_List (In_Constits);
20889 Report_Extra_Constituents_In_List (In_Out_Constits);
20890 Report_Extra_Constituents_In_List (Out_Constits);
20891 end Report_Extra_Constituents;
20895 Body_Decl : constant Node_Id := Parent (N);
20896 Errors : constant Nat := Serious_Errors_Detected;
20897 Items : constant Node_Id :=
20898 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
20899 Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl);
20901 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
20904 Global := Get_Pragma (Spec_Id, Pragma_Global);
20906 -- The subprogram declaration lacks pragma Global. This renders
20907 -- Refined_Global useless as there is nothing to refine.
20909 if No (Global) then
20911 ("useless refinement, subprogram & lacks global items", N, Spec_Id);
20915 -- Extract all relevant items from the corresponding Global pragma
20917 Collect_Global_Items
20919 In_Items => In_Items,
20920 In_Out_Items => In_Out_Items,
20921 Out_Items => Out_Items,
20922 Has_In_State => Has_In_State,
20923 Has_In_Out_State => Has_In_Out_State,
20924 Has_Out_State => Has_Out_State,
20925 Has_Null_State => Has_Null_State);
20927 -- The corresponding Global pragma must mention at least one state with
20928 -- a visible refinement at the point Refined_Global is processed. States
20929 -- with null refinements warrant a Refined_Global pragma.
20931 if not Has_In_State
20932 and then not Has_In_Out_State
20933 and then not Has_Out_State
20934 and then not Has_Null_State
20937 ("useless refinement, subprogram & does not mention abstract state "
20938 & "with visible refinement", N, Spec_Id);
20942 -- The global refinement of inputs and outputs cannot be null when the
20943 -- corresponding Global pragma contains at least one item except in the
20944 -- case where we have states with null refinements.
20946 if Nkind (Items) = N_Null
20948 (Present (In_Items)
20949 or else Present (In_Out_Items)
20950 or else Present (Out_Items))
20951 and then not Has_Null_State
20954 ("refinement cannot be null, subprogram & has global items",
20959 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
20960 -- This ensures that the categorization of all refined global items is
20961 -- consistent with their role.
20963 Analyze_Global_In_Decl_Part (N);
20965 -- Perform all refinement checks with respect to completeness and mode
20968 if Serious_Errors_Detected = Errors then
20969 Check_Refined_Global_List (Items);
20972 -- For Input states with visible refinement, at least one constituent
20973 -- must be used as an Input in the global refinement.
20975 if Serious_Errors_Detected = Errors then
20976 Check_Input_States;
20979 -- Verify all possible completion variants for In_Out states with
20980 -- visible refinement.
20982 if Serious_Errors_Detected = Errors then
20983 Check_In_Out_States;
20986 -- For Output states with visible refinement, all constituents must be
20987 -- used as Outputs in the global refinement.
20989 if Serious_Errors_Detected = Errors then
20990 Check_Output_States;
20993 -- Emit errors for all constituents that belong to other states with
20994 -- visible refinement that do not appear in Global.
20996 if Serious_Errors_Detected = Errors then
20997 Report_Extra_Constituents;
20999 end Analyze_Refined_Global_In_Decl_Part;
21001 ----------------------------------------
21002 -- Analyze_Refined_State_In_Decl_Part --
21003 ----------------------------------------
21005 procedure Analyze_Refined_State_In_Decl_Part (N : Node_Id) is
21006 Pack_Body : constant Node_Id := Parent (N);
21007 Spec_Id : constant Entity_Id := Corresponding_Spec (Pack_Body);
21009 Abstr_States : Elist_Id := No_Elist;
21010 -- A list of all abstract states defined in the package declaration. The
21011 -- list is used to report unrefined states.
21013 Constituents_Seen : Elist_Id := No_Elist;
21014 -- A list that contains all constituents processed so far. The list is
21015 -- used to detect multiple uses of the same constituent.
21017 Hidden_States : Elist_Id := No_Elist;
21018 -- A list of all hidden states (abstract states and variables) that
21019 -- appear in the package spec and body. The list is used to report
21020 -- unused hidden states.
21022 Refined_States_Seen : Elist_Id := No_Elist;
21023 -- A list that contains all refined states processed so far. The list is
21024 -- used to detect duplicate refinements.
21026 procedure Analyze_Refinement_Clause (Clause : Node_Id);
21027 -- Perform full analysis of a single refinement clause
21029 procedure Collect_Hidden_States;
21030 -- Gather the entities of all hidden states that appear in the spec and
21031 -- body of the related package in Hidden_States.
21033 procedure Report_Unrefined_States;
21034 -- Emit errors for all abstract states that have not been refined by
21037 procedure Report_Unused_Hidden_States;
21038 -- Emit errors for all hidden states of the related package that do not
21039 -- participate in a refinement.
21041 -------------------------------
21042 -- Analyze_Refinement_Clause --
21043 -------------------------------
21045 procedure Analyze_Refinement_Clause (Clause : Node_Id) is
21046 State_Id : Entity_Id := Empty;
21047 -- The entity of the state being refined in the current clause
21049 Non_Null_Seen : Boolean := False;
21050 Null_Seen : Boolean := False;
21051 -- Flags used to detect multiple uses of null in a single clause or a
21052 -- mixture of null and non-null constituents.
21054 procedure Analyze_Constituent (Constit : Node_Id);
21055 -- Perform full analysis of a single constituent
21057 procedure Check_Matching_State
21059 State_Id : Entity_Id);
21060 -- Determine whether state State denoted by its name State_Id appears
21061 -- in Abstr_States. Emit an error when attempting to re-refine the
21062 -- state or when the state is not defined in the package declaration.
21063 -- Otherwise remove the state from Abstr_States.
21065 -------------------------
21066 -- Analyze_Constituent --
21067 -------------------------
21069 procedure Analyze_Constituent (Constit : Node_Id) is
21070 procedure Check_Matching_Constituent (Constit_Id : Entity_Id);
21071 -- Determine whether constituent Constit denoted by its entity
21072 -- Constit_Id appears in Hidden_States. Emit an error when the
21073 -- constituent is not a valid hidden state of the related package
21074 -- or when it is used more than once. Otherwise remove the
21075 -- constituent from Hidden_States.
21077 --------------------------------
21078 -- Check_Matching_Constituent --
21079 --------------------------------
21081 procedure Check_Matching_Constituent (Constit_Id : Entity_Id) is
21082 State_Elmt : Elmt_Id;
21085 -- Detect a duplicate use of a constituent
21087 if Contains (Constituents_Seen, Constit_Id) then
21089 ("duplicate use of constituent &", Constit, Constit_Id);
21093 -- Inspect the hidden states of the related package looking for
21096 State_Elmt := First_Elmt (Hidden_States);
21097 while Present (State_Elmt) loop
21099 -- A valid hidden state or variable participates in a
21100 -- refinement. Add the constituent to the list of processed
21101 -- items to aid with the detection of duplicate constituent
21102 -- use. Remove the constituent from Hidden_States to signal
21103 -- that it has already been used.
21105 if Node (State_Elmt) = Constit_Id then
21106 Add_Item (Constit_Id, Constituents_Seen);
21107 Remove_Elmt (Hidden_States, State_Elmt);
21109 -- Collect the constituent in the list of refinement
21110 -- items. Establish a relation between the refined state
21111 -- and its constituent.
21114 (Constit_Id, Refinement_Constituents (State_Id));
21115 Set_Refined_State (Constit_Id, State_Id);
21117 -- The state has at least one legal constituent, mark the
21118 -- start of the refinement region. The region ends when
21119 -- the body declarations end (see Analyze_Declarations).
21121 Set_Has_Visible_Refinement (State_Id);
21126 Next_Elmt (State_Elmt);
21129 -- If we get here, we are refining a state that is not hidden
21130 -- with respect to the related package.
21132 Error_Msg_Name_1 := Chars (Spec_Id);
21134 ("cannot use & in refinement, constituent is not a hidden "
21135 & "state of package %", Constit, Constit_Id);
21136 end Check_Matching_Constituent;
21140 Constit_Id : Entity_Id;
21142 -- Start of processing for Analyze_Constituent
21145 -- Detect multiple uses of null in a single refinement clause or a
21146 -- mixture of null and non-null constituents.
21148 if Nkind (Constit) = N_Null then
21151 ("multiple null constituents not allowed", Constit);
21153 elsif Non_Null_Seen then
21155 ("cannot mix null and non-null constituents", Constit);
21160 -- Collect the constituent in the list of refinement items
21162 Append_Elmt (Constit, Refinement_Constituents (State_Id));
21164 -- The state has at least one legal constituent, mark the
21165 -- start of the refinement region. The region ends when the
21166 -- body declarations end (see Analyze_Declarations).
21168 Set_Has_Visible_Refinement (State_Id);
21171 -- Non-null constituents
21174 Non_Null_Seen := True;
21178 ("cannot mix null and non-null constituents", Constit);
21183 -- Ensure that the constituent denotes a valid state or a
21186 if Is_Entity_Name (Constit) then
21187 Constit_Id := Entity (Constit);
21189 if Ekind_In (Constit_Id, E_Abstract_State, E_Variable) then
21190 Check_Matching_Constituent (Constit_Id);
21193 ("constituent & must denote a variable or state",
21194 Constit, Constit_Id);
21197 -- The constituent is illegal
21200 Error_Msg_N ("malformed constituent", Constit);
21203 end Analyze_Constituent;
21205 --------------------------
21206 -- Check_Matching_State --
21207 --------------------------
21209 procedure Check_Matching_State
21211 State_Id : Entity_Id)
21213 State_Elmt : Elmt_Id;
21216 -- Detect a duplicate refinement of a state
21218 if Contains (Refined_States_Seen, State_Id) then
21220 ("duplicate refinement of state &", State, State_Id);
21224 -- Inspect the abstract states defined in the package declaration
21225 -- looking for a match.
21227 State_Elmt := First_Elmt (Abstr_States);
21228 while Present (State_Elmt) loop
21230 -- A valid abstract state is being refined in the body. Add
21231 -- the state to the list of processed refined states to aid
21232 -- with the detection of duplicate refinements. Remove the
21233 -- state from Abstr_States to signal that it has already been
21236 if Node (State_Elmt) = State_Id then
21237 Add_Item (State_Id, Refined_States_Seen);
21238 Remove_Elmt (Abstr_States, State_Elmt);
21243 Next_Elmt (State_Elmt);
21246 -- If we get here, we are refining a state that is not defined in
21247 -- the package declaration.
21249 Error_Msg_Name_1 := Chars (Spec_Id);
21251 ("cannot refine state, & is not defined in package %",
21253 end Check_Matching_State;
21255 -- Local declarations
21260 -- Start of processing for Analyze_Refinement_Clause
21263 -- Analyze the state name of a refinement clause
21265 State := First (Choices (Clause));
21266 while Present (State) loop
21267 if Present (State_Id) then
21269 ("refinement clause cannot cover multiple states", State);
21274 -- Ensure that the state name denotes a valid abstract state
21275 -- that is defined in the spec of the related package.
21277 if Is_Entity_Name (State) then
21278 State_Id := Entity (State);
21280 -- Catch any attempts to re-refine a state or refine a
21281 -- state that is not defined in the package declaration.
21283 if Ekind (State_Id) = E_Abstract_State then
21284 Check_Matching_State (State, State_Id);
21287 ("& must denote an abstract state", State, State_Id);
21290 -- The state name is illegal
21294 ("malformed state name in refinement clause", State);
21301 -- Analyze all constituents of the refinement. Multiple constituents
21302 -- appear as an aggregate.
21304 Constit := Expression (Clause);
21306 if Nkind (Constit) = N_Aggregate then
21307 if Present (Component_Associations (Constit)) then
21309 ("constituents of refinement clause must appear in "
21310 & "positional form", Constit);
21312 else pragma Assert (Present (Expressions (Constit)));
21313 Constit := First (Expressions (Constit));
21314 while Present (Constit) loop
21315 Analyze_Constituent (Constit);
21321 -- Various forms of a single constituent. Note that these may include
21322 -- malformed constituents.
21325 Analyze_Constituent (Constit);
21327 end Analyze_Refinement_Clause;
21329 ---------------------------
21330 -- Collect_Hidden_States --
21331 ---------------------------
21333 procedure Collect_Hidden_States is
21334 procedure Collect_Hidden_States_In_Decls (Decls : List_Id);
21335 -- Find all hidden states that appear in declarative list Decls and
21336 -- append their entities to Result.
21338 ------------------------------------
21339 -- Collect_Hidden_States_In_Decls --
21340 ------------------------------------
21342 procedure Collect_Hidden_States_In_Decls (Decls : List_Id) is
21343 procedure Collect_Abstract_States (States : Elist_Id);
21344 -- Copy the abstract states defined in list States to list Result
21346 -----------------------------
21347 -- Collect_Abstract_States --
21348 -----------------------------
21350 procedure Collect_Abstract_States (States : Elist_Id) is
21351 State_Elmt : Elmt_Id;
21354 State_Elmt := First_Elmt (States);
21355 while Present (State_Elmt) loop
21356 Add_Item (Node (State_Elmt), Hidden_States);
21358 Next_Elmt (State_Elmt);
21360 end Collect_Abstract_States;
21366 -- Start of processing for Collect_Hidden_States_In_Decls
21369 Decl := First (Decls);
21370 while Present (Decl) loop
21372 -- Source objects (non-constants) are valid hidden states
21374 if Nkind (Decl) = N_Object_Declaration
21375 and then Ekind (Defining_Entity (Decl)) = E_Variable
21376 and then Comes_From_Source (Decl)
21378 Add_Item (Defining_Entity (Decl), Hidden_States);
21380 -- Gather the abstract states of a package along with all
21381 -- hidden states in its visible declarations.
21383 elsif Nkind (Decl) = N_Package_Declaration then
21384 Collect_Abstract_States
21385 (Abstract_States (Defining_Entity (Decl)));
21387 Collect_Hidden_States_In_Decls
21388 (Visible_Declarations (Specification (Decl)));
21393 end Collect_Hidden_States_In_Decls;
21397 Pack_Spec : constant Node_Id := Parent (Spec_Id);
21399 -- Start of processing for Collect_Hidden_States
21402 -- Process the private declarations of the package spec and the
21403 -- declarations of the body.
21405 Collect_Hidden_States_In_Decls (Private_Declarations (Pack_Spec));
21406 Collect_Hidden_States_In_Decls (Declarations (Pack_Body));
21407 end Collect_Hidden_States;
21409 -----------------------------
21410 -- Report_Unrefined_States --
21411 -----------------------------
21413 procedure Report_Unrefined_States is
21414 State_Elmt : Elmt_Id;
21417 if Present (Abstr_States) then
21418 State_Elmt := First_Elmt (Abstr_States);
21419 while Present (State_Elmt) loop
21421 ("abstract state & must be refined", Node (State_Elmt));
21423 Next_Elmt (State_Elmt);
21426 end Report_Unrefined_States;
21428 ---------------------------------
21429 -- Report_Unused_Hidden_States --
21430 ---------------------------------
21432 procedure Report_Unused_Hidden_States is
21433 Posted : Boolean := False;
21434 State_Elmt : Elmt_Id;
21435 State_Id : Entity_Id;
21438 if Present (Hidden_States) then
21439 State_Elmt := First_Elmt (Hidden_States);
21440 while Present (State_Elmt) loop
21441 State_Id := Node (State_Elmt);
21443 -- Generate an error message of the form:
21445 -- package ... has unused hidden states
21446 -- abstract state ... defined at ...
21447 -- variable ... defined at ...
21452 ("package & has unused hidden states", N, Spec_Id);
21455 Error_Msg_Sloc := Sloc (State_Id);
21457 if Ekind (State_Id) = E_Abstract_State then
21458 Error_Msg_NE ("\ abstract state & defined #", N, State_Id);
21460 Error_Msg_NE ("\ variable & defined #", N, State_Id);
21463 Next_Elmt (State_Elmt);
21466 end Report_Unused_Hidden_States;
21468 -- Local declarations
21470 Clauses : constant Node_Id :=
21471 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
21474 -- Start of processing for Analyze_Refined_State_In_Decl_Part
21479 -- Initialize the various lists used during analysis
21481 Abstr_States := New_Copy_Elist (Abstract_States (Spec_Id));
21482 Collect_Hidden_States;
21484 -- Multiple state refinements appear as an aggregate
21486 if Nkind (Clauses) = N_Aggregate then
21487 if Present (Expressions (Clauses)) then
21489 ("state refinements must appear as component associations",
21492 else pragma Assert (Present (Component_Associations (Clauses)));
21493 Clause := First (Component_Associations (Clauses));
21494 while Present (Clause) loop
21495 Analyze_Refinement_Clause (Clause);
21501 -- Various forms of a single state refinement. Note that these may
21502 -- include malformed refinements.
21505 Analyze_Refinement_Clause (Clauses);
21508 -- Ensure that all abstract states have been refined and all hidden
21509 -- states of the related package unilized in refinements.
21511 Report_Unrefined_States;
21512 Report_Unused_Hidden_States;
21513 end Analyze_Refined_State_In_Decl_Part;
21515 ------------------------------------
21516 -- Analyze_Test_Case_In_Decl_Part --
21517 ------------------------------------
21519 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id; S : Entity_Id) is
21521 -- Install formals and push subprogram spec onto scope stack so that we
21522 -- can see the formals from the pragma.
21525 Install_Formals (S);
21527 -- Preanalyze the boolean expressions, we treat these as spec
21528 -- expressions (i.e. similar to a default expression).
21530 if Pragma_Name (N) = Name_Test_Case then
21531 Preanalyze_CTC_Args
21533 Get_Requires_From_CTC_Pragma (N),
21534 Get_Ensures_From_CTC_Pragma (N));
21537 -- Remove the subprogram from the scope stack now that the pre-analysis
21538 -- of the expressions in the contract case or test case is done.
21541 end Analyze_Test_Case_In_Decl_Part;
21547 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is
21552 if Present (List) then
21553 Elmt := First_Elmt (List);
21554 while Present (Elmt) loop
21555 if Nkind (Node (Elmt)) = N_Defining_Identifier then
21558 Id := Entity (Node (Elmt));
21561 if Id = Item_Id then
21576 function Check_Kind (Nam : Name_Id) return Name_Id is
21580 -- Loop through entries in check policy list
21582 PP := Opt.Check_Policy_List;
21583 while Present (PP) loop
21585 PPA : constant List_Id := Pragma_Argument_Associations (PP);
21586 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
21590 or else (Pnm = Name_Assertion
21591 and then Is_Valid_Assertion_Kind (Nam))
21592 or else (Pnm = Name_Statement_Assertions
21593 and then Nam_In (Nam, Name_Assert,
21594 Name_Assert_And_Cut,
21596 Name_Loop_Invariant))
21598 case (Chars (Get_Pragma_Arg (Last (PPA)))) is
21599 when Name_On | Name_Check =>
21601 when Name_Off | Name_Ignore =>
21602 return Name_Ignore;
21603 when Name_Disable =>
21604 return Name_Disable;
21606 raise Program_Error;
21610 PP := Next_Pragma (PP);
21615 -- If there are no specific entries that matched, then we let the
21616 -- setting of assertions govern. Note that this provides the needed
21617 -- compatibility with the RM for the cases of assertion, invariant,
21618 -- precondition, predicate, and postcondition.
21620 if Assertions_Enabled then
21623 return Name_Ignore;
21627 -----------------------------
21628 -- Check_Applicable_Policy --
21629 -----------------------------
21631 procedure Check_Applicable_Policy (N : Node_Id) is
21635 Ename : constant Name_Id := Original_Aspect_Name (N);
21638 -- No effect if not valid assertion kind name
21640 if not Is_Valid_Assertion_Kind (Ename) then
21644 -- Loop through entries in check policy list
21646 PP := Opt.Check_Policy_List;
21647 while Present (PP) loop
21649 PPA : constant List_Id := Pragma_Argument_Associations (PP);
21650 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
21654 or else Pnm = Name_Assertion
21655 or else (Pnm = Name_Statement_Assertions
21656 and then (Ename = Name_Assert or else
21657 Ename = Name_Assert_And_Cut or else
21658 Ename = Name_Assume or else
21659 Ename = Name_Loop_Invariant))
21661 Policy := Chars (Get_Pragma_Arg (Last (PPA)));
21664 when Name_Off | Name_Ignore =>
21665 Set_Is_Ignored (N, True);
21666 Set_Is_Checked (N, False);
21668 when Name_On | Name_Check =>
21669 Set_Is_Checked (N, True);
21670 Set_Is_Ignored (N, False);
21672 when Name_Disable =>
21673 Set_Is_Ignored (N, True);
21674 Set_Is_Checked (N, False);
21675 Set_Is_Disabled (N, True);
21677 -- That should be exhaustive, the null here is a defence
21678 -- against a malformed tree from previous errors.
21687 PP := Next_Pragma (PP);
21691 -- If there are no specific entries that matched, then we let the
21692 -- setting of assertions govern. Note that this provides the needed
21693 -- compatibility with the RM for the cases of assertion, invariant,
21694 -- precondition, predicate, and postcondition.
21696 if Assertions_Enabled then
21697 Set_Is_Checked (N, True);
21698 Set_Is_Ignored (N, False);
21700 Set_Is_Checked (N, False);
21701 Set_Is_Ignored (N, True);
21703 end Check_Applicable_Policy;
21705 --------------------------
21706 -- Collect_Global_Items --
21707 --------------------------
21709 procedure Collect_Global_Items
21711 In_Items : in out Elist_Id;
21712 In_Out_Items : in out Elist_Id;
21713 Out_Items : in out Elist_Id;
21714 Has_In_State : out Boolean;
21715 Has_In_Out_State : out Boolean;
21716 Has_Out_State : out Boolean;
21717 Has_Null_State : out Boolean)
21719 procedure Process_Global_List
21721 Mode : Name_Id := Name_Input);
21722 -- Collect all items housed in a global list. Formal Mode denotes the
21723 -- current mode in effect.
21725 -------------------------
21726 -- Process_Global_List --
21727 -------------------------
21729 procedure Process_Global_List
21731 Mode : Name_Id := Name_Input)
21733 procedure Process_Global_Item (Item : Node_Id; Mode : Name_Id);
21734 -- Add a single item to the appropriate list. Formal Mode denotes the
21735 -- current mode in effect.
21737 -------------------------
21738 -- Process_Global_Item --
21739 -------------------------
21741 procedure Process_Global_Item (Item : Node_Id; Mode : Name_Id) is
21742 Item_Id : constant Entity_Id := Entity_Of (Item);
21745 -- Signal that the global list contains at least one abstract
21746 -- state with a visible refinement. Note that the refinement may
21747 -- be null in which case there are no constituents.
21749 if Ekind (Item_Id) = E_Abstract_State then
21750 if Has_Null_Refinement (Item_Id) then
21751 Has_Null_State := True;
21753 elsif Has_Non_Null_Refinement (Item_Id) then
21754 if Mode = Name_Input then
21755 Has_In_State := True;
21756 elsif Mode = Name_In_Out then
21757 Has_In_Out_State := True;
21758 elsif Mode = Name_Output then
21759 Has_Out_State := True;
21764 -- Add the item to the proper list
21766 if Mode = Name_Input then
21767 Add_Item (Item_Id, In_Items);
21768 elsif Mode = Name_In_Out then
21769 Add_Item (Item_Id, In_Out_Items);
21770 elsif Mode = Name_Output then
21771 Add_Item (Item_Id, Out_Items);
21773 end Process_Global_Item;
21779 -- Start of processing for Process_Global_List
21782 if Nkind (List) = N_Null then
21785 -- Single global item declaration
21787 elsif Nkind_In (List, N_Expanded_Name,
21789 N_Selected_Component)
21791 Process_Global_Item (List, Mode);
21793 -- Single global list or moded global list declaration
21795 elsif Nkind (List) = N_Aggregate then
21797 -- The declaration of a simple global list appear as a collection
21800 if Present (Expressions (List)) then
21801 Item := First (Expressions (List));
21802 while Present (Item) loop
21803 Process_Global_Item (Item, Mode);
21808 -- The declaration of a moded global list appears as a collection
21809 -- of component associations where individual choices denote mode.
21811 elsif Present (Component_Associations (List)) then
21812 Item := First (Component_Associations (List));
21813 while Present (Item) loop
21814 Process_Global_List
21815 (List => Expression (Item),
21816 Mode => Chars (First (Choices (Item))));
21824 raise Program_Error;
21830 raise Program_Error;
21832 end Process_Global_List;
21836 Items : constant Node_Id :=
21837 Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
21839 -- Start of processing for Collect_Global_Items
21842 -- Assume that no states have been encountered
21844 Has_In_State := False;
21845 Has_In_Out_State := False;
21846 Has_Out_State := False;
21847 Has_Null_State := False;
21849 Process_Global_List (Items);
21850 end Collect_Global_Items;
21852 ---------------------------------------
21853 -- Collect_Subprogram_Inputs_Outputs --
21854 ---------------------------------------
21856 procedure Collect_Subprogram_Inputs_Outputs
21857 (Subp_Id : Entity_Id;
21858 Subp_Inputs : in out Elist_Id;
21859 Subp_Outputs : in out Elist_Id;
21860 Global_Seen : out Boolean)
21862 procedure Collect_Global_List
21864 Mode : Name_Id := Name_Input);
21865 -- Collect all relevant items from a global list
21867 -------------------------
21868 -- Collect_Global_List --
21869 -------------------------
21871 procedure Collect_Global_List
21873 Mode : Name_Id := Name_Input)
21875 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id);
21876 -- Add an item to the proper subprogram input or output collection
21878 -------------------------
21879 -- Collect_Global_Item --
21880 -------------------------
21882 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is
21884 if Nam_In (Mode, Name_In_Out, Name_Input) then
21885 Add_Item (Item, Subp_Inputs);
21888 if Nam_In (Mode, Name_In_Out, Name_Output) then
21889 Add_Item (Item, Subp_Outputs);
21891 end Collect_Global_Item;
21898 -- Start of processing for Collect_Global_List
21901 if Nkind (List) = N_Null then
21904 -- Single global item declaration
21906 elsif Nkind_In (List, N_Expanded_Name,
21908 N_Selected_Component)
21910 Collect_Global_Item (List, Mode);
21912 -- Simple global list or moded global list declaration
21914 elsif Nkind (List) = N_Aggregate then
21915 if Present (Expressions (List)) then
21916 Item := First (Expressions (List));
21917 while Present (Item) loop
21918 Collect_Global_Item (Item, Mode);
21923 Assoc := First (Component_Associations (List));
21924 while Present (Assoc) loop
21925 Collect_Global_List
21926 (List => Expression (Assoc),
21927 Mode => Chars (First (Choices (Assoc))));
21935 raise Program_Error;
21937 end Collect_Global_List;
21941 Formal : Entity_Id;
21944 Spec_Id : Entity_Id;
21946 -- Start of processing for Collect_Subprogram_Inputs_Outputs
21949 Global_Seen := False;
21951 -- Find the entity of the corresponding spec when processing a body
21953 if Ekind (Subp_Id) = E_Subprogram_Body then
21954 Spec_Id := Corresponding_Spec (Parent (Parent (Subp_Id)));
21956 Spec_Id := Subp_Id;
21959 -- Process all formal parameters
21961 Formal := First_Formal (Spec_Id);
21962 while Present (Formal) loop
21963 if Ekind_In (Formal, E_In_Out_Parameter, E_In_Parameter) then
21964 Add_Item (Formal, Subp_Inputs);
21967 if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then
21968 Add_Item (Formal, Subp_Outputs);
21970 -- Out parameters can act as inputs when the related type is
21971 -- tagged, unconstrained array, unconstrained record or record
21972 -- with unconstrained components.
21974 if Ekind (Formal) = E_Out_Parameter
21975 and then Is_Unconstrained_Or_Tagged_Item (Formal)
21977 Add_Item (Formal, Subp_Inputs);
21981 Next_Formal (Formal);
21984 -- When processing a subprogram body, look for pragma Refined_Global as
21985 -- it provides finer granularity of inputs and outputs.
21987 if Ekind (Subp_Id) = E_Subprogram_Body then
21988 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global);
21990 -- Subprogram declaration case, look for pragma Global
21993 Global := Get_Pragma (Spec_Id, Pragma_Global);
21996 if Present (Global) then
21997 Global_Seen := True;
21998 List := Expression (First (Pragma_Argument_Associations (Global)));
22000 -- The pragma may not have been analyzed because of the arbitrary
22001 -- declaration order of aspects. Make sure that it is analyzed for
22002 -- the purposes of item extraction.
22004 if not Analyzed (List) then
22005 if Pragma_Name (Global) = Name_Refined_Global then
22006 Analyze_Refined_Global_In_Decl_Part (Global);
22008 Analyze_Global_In_Decl_Part (Global);
22012 -- Nothing to be done for a null global list
22014 if Nkind (List) /= N_Null then
22015 Collect_Global_List (List);
22018 end Collect_Subprogram_Inputs_Outputs;
22020 ---------------------------------
22021 -- Delay_Config_Pragma_Analyze --
22022 ---------------------------------
22024 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
22026 return Nam_In (Pragma_Name (N), Name_Interrupt_State,
22027 Name_Priority_Specific_Dispatching);
22028 end Delay_Config_Pragma_Analyze;
22030 -------------------------------------
22031 -- Find_Related_Subprogram_Or_Body --
22032 -------------------------------------
22034 function Find_Related_Subprogram_Or_Body
22036 Do_Checks : Boolean := False) return Node_Id
22038 Context : constant Node_Id := Parent (Prag);
22039 Nam : constant Name_Id := Pragma_Name (Prag);
22042 Look_For_Body : constant Boolean :=
22043 Nam_In (Nam, Name_Refined_Depends,
22044 Name_Refined_Global,
22047 -- Refinement pragmas must be associated with a subprogram body [stub]
22050 pragma Assert (Nkind (Prag) = N_Pragma);
22052 -- If the pragma is a byproduct of aspect expansion, return the related
22053 -- context of the original aspect.
22055 if Present (Corresponding_Aspect (Prag)) then
22056 return Parent (Corresponding_Aspect (Prag));
22059 -- Otherwise the pragma is a source construct, most likely part of a
22060 -- declarative list. Skip preceding declarations while looking for a
22061 -- proper subprogram declaration.
22063 pragma Assert (Is_List_Member (Prag));
22065 Stmt := Prev (Prag);
22066 while Present (Stmt) loop
22068 -- Skip prior pragmas, but check for duplicates
22070 if Nkind (Stmt) = N_Pragma then
22071 if Do_Checks and then Pragma_Name (Stmt) = Nam then
22072 Error_Msg_Name_1 := Nam;
22073 Error_Msg_Sloc := Sloc (Stmt);
22074 Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
22077 -- Emit an error when a refinement pragma appears on an expression
22078 -- function without a completion.
22081 and then Look_For_Body
22082 and then Nkind (Stmt) = N_Subprogram_Declaration
22083 and then Nkind (Original_Node (Stmt)) = N_Expression_Function
22084 and then not Has_Completion (Defining_Entity (Stmt))
22086 Error_Msg_Name_1 := Nam;
22088 ("pragma % cannot apply to a stand alone expression function",
22093 -- The refinement pragma applies to a subprogram body stub
22095 elsif Look_For_Body
22096 and then Nkind (Stmt) = N_Subprogram_Body_Stub
22100 -- Skip internally generated code
22102 elsif not Comes_From_Source (Stmt) then
22105 -- Return the current construct which is either a subprogram body,
22106 -- a subprogram declaration or is illegal.
22115 -- If we fall through, then the pragma was either the first declaration
22116 -- or it was preceded by other pragmas and no source constructs.
22118 -- The pragma is associated with a library-level subprogram
22120 if Nkind (Context) = N_Compilation_Unit_Aux then
22121 return Unit (Parent (Context));
22123 -- The pragma appears inside the declarative part of a subprogram body
22125 elsif Nkind (Context) = N_Subprogram_Body then
22128 -- No candidate subprogram [body] found
22133 end Find_Related_Subprogram_Or_Body;
22135 -------------------------
22136 -- Get_Base_Subprogram --
22137 -------------------------
22139 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
22140 Result : Entity_Id;
22143 -- Follow subprogram renaming chain
22147 if Is_Subprogram (Result)
22149 Nkind (Parent (Declaration_Node (Result))) =
22150 N_Subprogram_Renaming_Declaration
22151 and then Present (Alias (Result))
22153 Result := Alias (Result);
22157 end Get_Base_Subprogram;
22159 -----------------------
22160 -- Get_SPARK_Mode_Id --
22161 -----------------------
22163 function Get_SPARK_Mode_Id (N : Name_Id) return SPARK_Mode_Id is
22165 if N = Name_On then
22167 elsif N = Name_Off then
22169 elsif N = Name_Auto then
22172 -- Any other argument is erroneous
22175 raise Program_Error;
22177 end Get_SPARK_Mode_Id;
22179 -----------------------
22180 -- Get_SPARK_Mode_Id --
22181 -----------------------
22183 function Get_SPARK_Mode_Id (N : Node_Id) return SPARK_Mode_Id is
22188 pragma Assert (Nkind (N) = N_Pragma);
22189 Args := Pragma_Argument_Associations (N);
22191 -- Extract the mode from the argument list
22193 if Present (Args) then
22194 Mode := First (Pragma_Argument_Associations (N));
22195 return Get_SPARK_Mode_Id (Chars (Get_Pragma_Arg (Mode)));
22197 -- When SPARK_Mode appears without an argument, the default is ON
22202 end Get_SPARK_Mode_Id;
22208 procedure Initialize is
22213 -----------------------------
22214 -- Is_Config_Static_String --
22215 -----------------------------
22217 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
22219 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
22220 -- This is an internal recursive function that is just like the outer
22221 -- function except that it adds the string to the name buffer rather
22222 -- than placing the string in the name buffer.
22224 ------------------------------
22225 -- Add_Config_Static_String --
22226 ------------------------------
22228 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
22235 if Nkind (N) = N_Op_Concat then
22236 if Add_Config_Static_String (Left_Opnd (N)) then
22237 N := Right_Opnd (N);
22243 if Nkind (N) /= N_String_Literal then
22244 Error_Msg_N ("string literal expected for pragma argument", N);
22248 for J in 1 .. String_Length (Strval (N)) loop
22249 C := Get_String_Char (Strval (N), J);
22251 if not In_Character_Range (C) then
22253 ("string literal contains invalid wide character",
22254 Sloc (N) + 1 + Source_Ptr (J));
22258 Add_Char_To_Name_Buffer (Get_Character (C));
22263 end Add_Config_Static_String;
22265 -- Start of processing for Is_Config_Static_String
22270 return Add_Config_Static_String (Arg);
22271 end Is_Config_Static_String;
22273 -------------------------------
22274 -- Is_Elaboration_SPARK_Mode --
22275 -------------------------------
22277 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is
22280 (Nkind (N) = N_Pragma
22281 and then Pragma_Name (N) = Name_SPARK_Mode
22282 and then Is_List_Member (N));
22284 -- Pragma SPARK_Mode affects the elaboration of a package body when it
22285 -- appears in the statement part of the body.
22288 Present (Parent (N))
22289 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
22290 and then List_Containing (N) = Statements (Parent (N))
22291 and then Present (Parent (Parent (N)))
22292 and then Nkind (Parent (Parent (N))) = N_Package_Body;
22293 end Is_Elaboration_SPARK_Mode;
22295 -----------------------------------------
22296 -- Is_Non_Significant_Pragma_Reference --
22297 -----------------------------------------
22299 -- This function makes use of the following static table which indicates
22300 -- whether appearance of some name in a given pragma is to be considered
22301 -- as a reference for the purposes of warnings about unreferenced objects.
22303 -- -1 indicates that references in any argument position are significant
22304 -- 0 indicates that appearance in any argument is not significant
22305 -- +n indicates that appearance as argument n is significant, but all
22306 -- other arguments are not significant
22307 -- 99 special processing required (e.g. for pragma Check)
22309 Sig_Flags : constant array (Pragma_Id) of Int :=
22310 (Pragma_AST_Entry => -1,
22311 Pragma_Abort_Defer => -1,
22312 Pragma_Abstract_State => -1,
22313 Pragma_Ada_83 => -1,
22314 Pragma_Ada_95 => -1,
22315 Pragma_Ada_05 => -1,
22316 Pragma_Ada_2005 => -1,
22317 Pragma_Ada_12 => -1,
22318 Pragma_Ada_2012 => -1,
22319 Pragma_All_Calls_Remote => -1,
22320 Pragma_Annotate => -1,
22321 Pragma_Assert => -1,
22322 Pragma_Assert_And_Cut => -1,
22323 Pragma_Assertion_Policy => 0,
22324 Pragma_Assume => -1,
22325 Pragma_Assume_No_Invalid_Values => 0,
22326 Pragma_Attribute_Definition => +3,
22327 Pragma_Asynchronous => -1,
22328 Pragma_Atomic => 0,
22329 Pragma_Atomic_Components => 0,
22330 Pragma_Attach_Handler => -1,
22331 Pragma_Check => 99,
22332 Pragma_Check_Float_Overflow => 0,
22333 Pragma_Check_Name => 0,
22334 Pragma_Check_Policy => 0,
22335 Pragma_CIL_Constructor => -1,
22336 Pragma_CPP_Class => 0,
22337 Pragma_CPP_Constructor => 0,
22338 Pragma_CPP_Virtual => 0,
22339 Pragma_CPP_Vtable => 0,
22341 Pragma_C_Pass_By_Copy => 0,
22342 Pragma_Comment => 0,
22343 Pragma_Common_Object => -1,
22344 Pragma_Compile_Time_Error => -1,
22345 Pragma_Compile_Time_Warning => -1,
22346 Pragma_Compiler_Unit => 0,
22347 Pragma_Complete_Representation => 0,
22348 Pragma_Complex_Representation => 0,
22349 Pragma_Component_Alignment => -1,
22350 Pragma_Contract_Cases => -1,
22351 Pragma_Controlled => 0,
22352 Pragma_Convention => 0,
22353 Pragma_Convention_Identifier => 0,
22354 Pragma_Debug => -1,
22355 Pragma_Debug_Policy => 0,
22356 Pragma_Detect_Blocking => -1,
22357 Pragma_Default_Storage_Pool => -1,
22358 Pragma_Depends => -1,
22359 Pragma_Disable_Atomic_Synchronization => -1,
22360 Pragma_Discard_Names => 0,
22361 Pragma_Dispatching_Domain => -1,
22362 Pragma_Elaborate => -1,
22363 Pragma_Elaborate_All => -1,
22364 Pragma_Elaborate_Body => -1,
22365 Pragma_Elaboration_Checks => -1,
22366 Pragma_Eliminate => -1,
22367 Pragma_Enable_Atomic_Synchronization => -1,
22368 Pragma_Export => -1,
22369 Pragma_Export_Exception => -1,
22370 Pragma_Export_Function => -1,
22371 Pragma_Export_Object => -1,
22372 Pragma_Export_Procedure => -1,
22373 Pragma_Export_Value => -1,
22374 Pragma_Export_Valued_Procedure => -1,
22375 Pragma_Extend_System => -1,
22376 Pragma_Extensions_Allowed => -1,
22377 Pragma_External => -1,
22378 Pragma_Favor_Top_Level => -1,
22379 Pragma_External_Name_Casing => -1,
22380 Pragma_Fast_Math => -1,
22381 Pragma_Finalize_Storage_Only => 0,
22382 Pragma_Float_Representation => 0,
22383 Pragma_Global => -1,
22384 Pragma_Ident => -1,
22385 Pragma_Implementation_Defined => -1,
22386 Pragma_Implemented => -1,
22387 Pragma_Implicit_Packing => 0,
22388 Pragma_Import => +2,
22389 Pragma_Import_Exception => 0,
22390 Pragma_Import_Function => 0,
22391 Pragma_Import_Object => 0,
22392 Pragma_Import_Procedure => 0,
22393 Pragma_Import_Valued_Procedure => 0,
22394 Pragma_Independent => 0,
22395 Pragma_Independent_Components => 0,
22396 Pragma_Initialize_Scalars => -1,
22397 Pragma_Initializes => -1,
22398 Pragma_Inline => 0,
22399 Pragma_Inline_Always => 0,
22400 Pragma_Inline_Generic => 0,
22401 Pragma_Inspection_Point => -1,
22402 Pragma_Interface => +2,
22403 Pragma_Interface_Name => +2,
22404 Pragma_Interrupt_Handler => -1,
22405 Pragma_Interrupt_Priority => -1,
22406 Pragma_Interrupt_State => -1,
22407 Pragma_Invariant => -1,
22408 Pragma_Java_Constructor => -1,
22409 Pragma_Java_Interface => -1,
22410 Pragma_Keep_Names => 0,
22411 Pragma_License => -1,
22412 Pragma_Link_With => -1,
22413 Pragma_Linker_Alias => -1,
22414 Pragma_Linker_Constructor => -1,
22415 Pragma_Linker_Destructor => -1,
22416 Pragma_Linker_Options => -1,
22417 Pragma_Linker_Section => -1,
22419 Pragma_Lock_Free => -1,
22420 Pragma_Locking_Policy => -1,
22421 Pragma_Long_Float => -1,
22422 Pragma_Loop_Invariant => -1,
22423 Pragma_Loop_Optimize => -1,
22424 Pragma_Loop_Variant => -1,
22425 Pragma_Machine_Attribute => -1,
22427 Pragma_Main_Storage => -1,
22428 Pragma_Memory_Size => -1,
22429 Pragma_No_Return => 0,
22430 Pragma_No_Body => 0,
22431 Pragma_No_Inline => 0,
22432 Pragma_No_Run_Time => -1,
22433 Pragma_No_Strict_Aliasing => -1,
22434 Pragma_Normalize_Scalars => -1,
22435 Pragma_Obsolescent => 0,
22436 Pragma_Optimize => -1,
22437 Pragma_Optimize_Alignment => -1,
22438 Pragma_Overflow_Mode => 0,
22439 Pragma_Overriding_Renamings => 0,
22440 Pragma_Ordered => 0,
22443 Pragma_Partition_Elaboration_Policy => -1,
22444 Pragma_Passive => -1,
22445 Pragma_Persistent_BSS => 0,
22446 Pragma_Polling => -1,
22448 Pragma_Postcondition => -1,
22449 Pragma_Post_Class => -1,
22451 Pragma_Precondition => -1,
22452 Pragma_Predicate => -1,
22453 Pragma_Preelaborable_Initialization => -1,
22454 Pragma_Preelaborate => -1,
22455 Pragma_Preelaborate_05 => -1,
22456 Pragma_Pre_Class => -1,
22457 Pragma_Priority => -1,
22458 Pragma_Priority_Specific_Dispatching => -1,
22459 Pragma_Profile => 0,
22460 Pragma_Profile_Warnings => 0,
22461 Pragma_Propagate_Exceptions => -1,
22462 Pragma_Psect_Object => -1,
22464 Pragma_Pure_05 => -1,
22465 Pragma_Pure_12 => -1,
22466 Pragma_Pure_Function => -1,
22467 Pragma_Queuing_Policy => -1,
22468 Pragma_Rational => -1,
22469 Pragma_Ravenscar => -1,
22470 Pragma_Refined_Depends => -1,
22471 Pragma_Refined_Global => -1,
22472 Pragma_Refined_Post => -1,
22473 Pragma_Refined_Pre => -1,
22474 Pragma_Refined_State => -1,
22475 Pragma_Relative_Deadline => -1,
22476 Pragma_Remote_Access_Type => -1,
22477 Pragma_Remote_Call_Interface => -1,
22478 Pragma_Remote_Types => -1,
22479 Pragma_Restricted_Run_Time => -1,
22480 Pragma_Restriction_Warnings => -1,
22481 Pragma_Restrictions => -1,
22482 Pragma_Reviewable => -1,
22483 Pragma_Short_Circuit_And_Or => -1,
22484 Pragma_Share_Generic => -1,
22485 Pragma_Shared => -1,
22486 Pragma_Shared_Passive => -1,
22487 Pragma_Short_Descriptors => 0,
22488 Pragma_Simple_Storage_Pool_Type => 0,
22489 Pragma_Source_File_Name => -1,
22490 Pragma_Source_File_Name_Project => -1,
22491 Pragma_Source_Reference => -1,
22492 Pragma_SPARK_Mode => 0,
22493 Pragma_Storage_Size => -1,
22494 Pragma_Storage_Unit => -1,
22495 Pragma_Static_Elaboration_Desired => -1,
22496 Pragma_Stream_Convert => -1,
22497 Pragma_Style_Checks => -1,
22498 Pragma_Subtitle => -1,
22499 Pragma_Suppress => 0,
22500 Pragma_Suppress_Exception_Locations => 0,
22501 Pragma_Suppress_All => -1,
22502 Pragma_Suppress_Debug_Info => 0,
22503 Pragma_Suppress_Initialization => 0,
22504 Pragma_System_Name => -1,
22505 Pragma_Task_Dispatching_Policy => -1,
22506 Pragma_Task_Info => -1,
22507 Pragma_Task_Name => -1,
22508 Pragma_Task_Storage => 0,
22509 Pragma_Test_Case => -1,
22510 Pragma_Thread_Local_Storage => 0,
22511 Pragma_Time_Slice => -1,
22512 Pragma_Title => -1,
22513 Pragma_Type_Invariant => -1,
22514 Pragma_Type_Invariant_Class => -1,
22515 Pragma_Unchecked_Union => 0,
22516 Pragma_Unimplemented_Unit => -1,
22517 Pragma_Universal_Aliasing => -1,
22518 Pragma_Universal_Data => -1,
22519 Pragma_Unmodified => -1,
22520 Pragma_Unreferenced => -1,
22521 Pragma_Unreferenced_Objects => -1,
22522 Pragma_Unreserve_All_Interrupts => -1,
22523 Pragma_Unsuppress => 0,
22524 Pragma_Use_VADS_Size => -1,
22525 Pragma_Validity_Checks => -1,
22526 Pragma_Volatile => 0,
22527 Pragma_Volatile_Components => 0,
22528 Pragma_Warnings => -1,
22529 Pragma_Weak_External => -1,
22530 Pragma_Wide_Character_Encoding => 0,
22531 Unknown_Pragma => 0);
22533 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
22542 if Nkind (P) /= N_Pragma_Argument_Association then
22546 Id := Get_Pragma_Id (Parent (P));
22547 C := Sig_Flags (Id);
22559 -- For pragma Check, the first argument is not significant,
22560 -- the second and the third (if present) arguments are
22563 when Pragma_Check =>
22565 P = First (Pragma_Argument_Associations (Parent (P)));
22568 raise Program_Error;
22572 A := First (Pragma_Argument_Associations (Parent (P)));
22573 for J in 1 .. C - 1 loop
22581 return A = P; -- is this wrong way round ???
22584 end Is_Non_Significant_Pragma_Reference;
22590 function Is_Part_Of
22591 (State : Entity_Id;
22592 Ancestor : Entity_Id) return Boolean
22594 Options : constant Node_Id := Parent (State);
22600 -- A state declaration with option Part_Of appears as an extension
22601 -- aggregate with component associations.
22603 if Nkind (Options) = N_Extension_Aggregate then
22604 Option := First (Component_Associations (Options));
22605 while Present (Option) loop
22606 Name := First (Choices (Option));
22607 Value := Expression (Option);
22609 if Chars (Name) = Name_Part_Of then
22610 return Entity (Value) = Ancestor;
22620 ------------------------------
22621 -- Is_Pragma_String_Literal --
22622 ------------------------------
22624 -- This function returns true if the corresponding pragma argument is a
22625 -- static string expression. These are the only cases in which string
22626 -- literals can appear as pragma arguments. We also allow a string literal
22627 -- as the first argument to pragma Assert (although it will of course
22628 -- always generate a type error).
22630 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
22631 Pragn : constant Node_Id := Parent (Par);
22632 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
22633 Pname : constant Name_Id := Pragma_Name (Pragn);
22639 N := First (Assoc);
22646 if Pname = Name_Assert then
22649 elsif Pname = Name_Export then
22652 elsif Pname = Name_Ident then
22655 elsif Pname = Name_Import then
22658 elsif Pname = Name_Interface_Name then
22661 elsif Pname = Name_Linker_Alias then
22664 elsif Pname = Name_Linker_Section then
22667 elsif Pname = Name_Machine_Attribute then
22670 elsif Pname = Name_Source_File_Name then
22673 elsif Pname = Name_Source_Reference then
22676 elsif Pname = Name_Title then
22679 elsif Pname = Name_Subtitle then
22685 end Is_Pragma_String_Literal;
22687 ---------------------------
22688 -- Is_Private_SPARK_Mode --
22689 ---------------------------
22691 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is
22694 (Nkind (N) = N_Pragma
22695 and then Pragma_Name (N) = Name_SPARK_Mode
22696 and then Is_List_Member (N));
22698 -- For pragma SPARK_Mode to be private, it has to appear in the private
22699 -- declarations of a package.
22702 Present (Parent (N))
22703 and then Nkind (Parent (N)) = N_Package_Specification
22704 and then List_Containing (N) = Private_Declarations (Parent (N));
22705 end Is_Private_SPARK_Mode;
22707 -------------------------------------
22708 -- Is_Unconstrained_Or_Tagged_Item --
22709 -------------------------------------
22711 function Is_Unconstrained_Or_Tagged_Item
22712 (Item : Entity_Id) return Boolean
22714 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean;
22715 -- Determine whether record type Typ has at least one unconstrained
22718 ---------------------------------
22719 -- Has_Unconstrained_Component --
22720 ---------------------------------
22722 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is
22726 Comp := First_Component (Typ);
22727 while Present (Comp) loop
22728 if Is_Unconstrained_Or_Tagged_Item (Comp) then
22732 Next_Component (Comp);
22736 end Has_Unconstrained_Component;
22740 Typ : constant Entity_Id := Etype (Item);
22742 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
22745 if Is_Tagged_Type (Typ) then
22748 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
22751 elsif Is_Record_Type (Typ) then
22752 if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then
22755 return Has_Unconstrained_Component (Typ);
22761 end Is_Unconstrained_Or_Tagged_Item;
22763 -----------------------------
22764 -- Is_Valid_Assertion_Kind --
22765 -----------------------------
22767 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is
22774 Name_Static_Predicate |
22775 Name_Dynamic_Predicate |
22780 Name_Type_Invariant |
22781 Name_uType_Invariant |
22785 Name_Assert_And_Cut |
22787 Name_Contract_Cases |
22791 Name_Loop_Invariant |
22792 Name_Loop_Variant |
22793 Name_Postcondition |
22794 Name_Precondition |
22796 Name_Refined_Post |
22798 Name_Statement_Assertions => return True;
22800 when others => return False;
22802 end Is_Valid_Assertion_Kind;
22804 -----------------------------------------
22805 -- Make_Aspect_For_PPC_In_Gen_Sub_Decl --
22806 -----------------------------------------
22808 procedure Make_Aspect_For_PPC_In_Gen_Sub_Decl (Decl : Node_Id) is
22809 Aspects : constant List_Id := New_List;
22810 Loc : constant Source_Ptr := Sloc (Decl);
22811 Or_Decl : constant Node_Id := Original_Node (Decl);
22813 Original_Aspects : List_Id;
22814 -- To capture global references, a copy of the created aspects must be
22815 -- inserted in the original tree.
22818 Prag_Arg_Ass : Node_Id;
22819 Prag_Id : Pragma_Id;
22822 -- Check for any PPC pragmas that appear within Decl
22824 Prag := Next (Decl);
22825 while Nkind (Prag) = N_Pragma loop
22826 Prag_Id := Get_Pragma_Id (Chars (Pragma_Identifier (Prag)));
22829 when Pragma_Postcondition | Pragma_Precondition =>
22830 Prag_Arg_Ass := First (Pragma_Argument_Associations (Prag));
22832 -- Make an aspect from any PPC pragma
22834 Append_To (Aspects,
22835 Make_Aspect_Specification (Loc,
22837 Make_Identifier (Loc, Chars (Pragma_Identifier (Prag))),
22839 Copy_Separate_Tree (Expression (Prag_Arg_Ass))));
22841 -- Generate the analysis information in the pragma expression
22842 -- and then set the pragma node analyzed to avoid any further
22845 Analyze (Expression (Prag_Arg_Ass));
22846 Set_Analyzed (Prag, True);
22848 when others => null;
22854 -- Set all new aspects into the generic declaration node
22856 if Is_Non_Empty_List (Aspects) then
22858 -- Create the list of aspects to be inserted in the original tree
22860 Original_Aspects := Copy_Separate_List (Aspects);
22862 -- Check if Decl already has aspects
22864 -- Attach the new lists of aspects to both the generic copy and the
22867 if Has_Aspects (Decl) then
22868 Append_List (Aspects, Aspect_Specifications (Decl));
22869 Append_List (Original_Aspects, Aspect_Specifications (Or_Decl));
22872 Set_Parent (Aspects, Decl);
22873 Set_Aspect_Specifications (Decl, Aspects);
22874 Set_Parent (Original_Aspects, Or_Decl);
22875 Set_Aspect_Specifications (Or_Decl, Original_Aspects);
22878 end Make_Aspect_For_PPC_In_Gen_Sub_Decl;
22880 -------------------------
22881 -- Preanalyze_CTC_Args --
22882 -------------------------
22884 procedure Preanalyze_CTC_Args (N, Arg_Req, Arg_Ens : Node_Id) is
22886 -- Preanalyze the boolean expressions, we treat these as spec
22887 -- expressions (i.e. similar to a default expression).
22889 if Present (Arg_Req) then
22890 Preanalyze_Assert_Expression
22891 (Get_Pragma_Arg (Arg_Req), Standard_Boolean);
22893 -- In ASIS mode, for a pragma generated from a source aspect, also
22894 -- analyze the original aspect expression.
22896 if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
22897 Preanalyze_Assert_Expression
22898 (Original_Node (Get_Pragma_Arg (Arg_Req)), Standard_Boolean);
22902 if Present (Arg_Ens) then
22903 Preanalyze_Assert_Expression
22904 (Get_Pragma_Arg (Arg_Ens), Standard_Boolean);
22906 -- In ASIS mode, for a pragma generated from a source aspect, also
22907 -- analyze the original aspect expression.
22909 if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
22910 Preanalyze_Assert_Expression
22911 (Original_Node (Get_Pragma_Arg (Arg_Ens)), Standard_Boolean);
22914 end Preanalyze_CTC_Args;
22916 --------------------------------------
22917 -- Process_Compilation_Unit_Pragmas --
22918 --------------------------------------
22920 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
22922 -- A special check for pragma Suppress_All, a very strange DEC pragma,
22923 -- strange because it comes at the end of the unit. Rational has the
22924 -- same name for a pragma, but treats it as a program unit pragma, In
22925 -- GNAT we just decide to allow it anywhere at all. If it appeared then
22926 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
22927 -- node, and we insert a pragma Suppress (All_Checks) at the start of
22928 -- the context clause to ensure the correct processing.
22930 if Has_Pragma_Suppress_All (N) then
22931 Prepend_To (Context_Items (N),
22932 Make_Pragma (Sloc (N),
22933 Chars => Name_Suppress,
22934 Pragma_Argument_Associations => New_List (
22935 Make_Pragma_Argument_Association (Sloc (N),
22936 Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
22939 -- Nothing else to do at the current time!
22941 end Process_Compilation_Unit_Pragmas;
22943 ------------------------------
22944 -- Relocate_Pragmas_To_Body --
22945 ------------------------------
22947 procedure Relocate_Pragmas_To_Body
22948 (Subp_Body : Node_Id;
22949 Target_Body : Node_Id := Empty)
22951 procedure Relocate_Pragma (Prag : Node_Id);
22952 -- Remove a single pragma from its current list and add it to the
22953 -- declarations of the proper body (either Subp_Body or Target_Body).
22955 ---------------------
22956 -- Relocate_Pragma --
22957 ---------------------
22959 procedure Relocate_Pragma (Prag : Node_Id) is
22964 -- When subprogram stubs or expression functions are involves, the
22965 -- destination declaration list belongs to the proper body.
22967 if Present (Target_Body) then
22968 Target := Target_Body;
22970 Target := Subp_Body;
22973 Decls := Declarations (Target);
22977 Set_Declarations (Target, Decls);
22980 -- Unhook the pragma from its current list
22983 Prepend (Prag, Decls);
22984 end Relocate_Pragma;
22988 Body_Id : constant Entity_Id :=
22989 Defining_Unit_Name (Specification (Subp_Body));
22990 Next_Stmt : Node_Id;
22993 -- Start of processing for Relocate_Pragmas_To_Body
22996 -- Do not process a body that comes from a separate unit as no construct
22997 -- can possibly follow it.
22999 if not Is_List_Member (Subp_Body) then
23002 -- Do not relocate pragmas that follow a stub if the stub does not have
23005 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub
23006 and then No (Target_Body)
23010 -- Do not process internally generated routine _Postconditions
23012 elsif Ekind (Body_Id) = E_Procedure
23013 and then Chars (Body_Id) = Name_uPostconditions
23018 -- Look at what is following the body. We are interested in certain kind
23019 -- of pragmas (either from source or byproducts of expansion) that can
23020 -- apply to a body [stub].
23022 Stmt := Next (Subp_Body);
23023 while Present (Stmt) loop
23025 -- Preserve the following statement for iteration purposes due to a
23026 -- possible relocation of a pragma.
23028 Next_Stmt := Next (Stmt);
23030 -- Move a candidate pragma following the body to the declarations of
23033 if Nkind (Stmt) = N_Pragma
23034 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt))
23036 Relocate_Pragma (Stmt);
23038 -- Skip internally generated code
23040 elsif not Comes_From_Source (Stmt) then
23043 -- No candidate pragmas are available for relocation
23051 end Relocate_Pragmas_To_Body;
23053 ----------------------------
23054 -- Rewrite_Assertion_Kind --
23055 ----------------------------
23057 procedure Rewrite_Assertion_Kind (N : Node_Id) is
23061 if Nkind (N) = N_Attribute_Reference
23062 and then Attribute_Name (N) = Name_Class
23063 and then Nkind (Prefix (N)) = N_Identifier
23065 case Chars (Prefix (N)) is
23070 when Name_Type_Invariant =>
23071 Nam := Name_uType_Invariant;
23072 when Name_Invariant =>
23073 Nam := Name_uInvariant;
23078 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam));
23080 end Rewrite_Assertion_Kind;
23091 --------------------------------
23092 -- Set_Encoded_Interface_Name --
23093 --------------------------------
23095 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
23096 Str : constant String_Id := Strval (S);
23097 Len : constant Int := String_Length (Str);
23102 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
23105 -- Stores encoded value of character code CC. The encoding we use an
23106 -- underscore followed by four lower case hex digits.
23112 procedure Encode is
23114 Store_String_Char (Get_Char_Code ('_'));
23116 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
23118 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
23120 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
23122 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
23125 -- Start of processing for Set_Encoded_Interface_Name
23128 -- If first character is asterisk, this is a link name, and we leave it
23129 -- completely unmodified. We also ignore null strings (the latter case
23130 -- happens only in error cases) and no encoding should occur for Java or
23131 -- AAMP interface names.
23134 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
23135 or else VM_Target /= No_VM
23136 or else AAMP_On_Target
23138 Set_Interface_Name (E, S);
23143 CC := Get_String_Char (Str, J);
23145 exit when not In_Character_Range (CC);
23147 C := Get_Character (CC);
23149 exit when C /= '_' and then C /= '$'
23150 and then C not in '0' .. '9'
23151 and then C not in 'a' .. 'z'
23152 and then C not in 'A' .. 'Z';
23155 Set_Interface_Name (E, S);
23163 -- Here we need to encode. The encoding we use as follows:
23164 -- three underscores + four hex digits (lower case)
23168 for J in 1 .. String_Length (Str) loop
23169 CC := Get_String_Char (Str, J);
23171 if not In_Character_Range (CC) then
23174 C := Get_Character (CC);
23176 if C = '_' or else C = '$'
23177 or else C in '0' .. '9'
23178 or else C in 'a' .. 'z'
23179 or else C in 'A' .. 'Z'
23181 Store_String_Char (CC);
23188 Set_Interface_Name (E,
23189 Make_String_Literal (Sloc (S),
23190 Strval => End_String));
23192 end Set_Encoded_Interface_Name;
23194 -------------------
23195 -- Set_Unit_Name --
23196 -------------------
23198 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id) is
23203 if Nkind (N) = N_Identifier
23204 and then Nkind (With_Item) = N_Identifier
23206 Set_Entity (N, Entity (With_Item));
23208 elsif Nkind (N) = N_Selected_Component then
23209 Change_Selected_Component_To_Expanded_Name (N);
23210 Set_Entity (N, Entity (With_Item));
23211 Set_Entity (Selector_Name (N), Entity (N));
23213 Pref := Prefix (N);
23214 Scop := Scope (Entity (N));
23215 while Nkind (Pref) = N_Selected_Component loop
23216 Change_Selected_Component_To_Expanded_Name (Pref);
23217 Set_Entity (Selector_Name (Pref), Scop);
23218 Set_Entity (Pref, Scop);
23219 Pref := Prefix (Pref);
23220 Scop := Scope (Scop);
23223 Set_Entity (Pref, Scop);