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;
50 with Output; use Output;
51 with Par_SCO; use Par_SCO;
52 with Restrict; use Restrict;
53 with Rident; use Rident;
54 with Rtsfind; use Rtsfind;
56 with Sem_Aux; use Sem_Aux;
57 with Sem_Ch3; use Sem_Ch3;
58 with Sem_Ch6; use Sem_Ch6;
59 with Sem_Ch8; use Sem_Ch8;
60 with Sem_Ch12; use Sem_Ch12;
61 with Sem_Ch13; use Sem_Ch13;
62 with Sem_Disp; use Sem_Disp;
63 with Sem_Dist; use Sem_Dist;
64 with Sem_Elim; use Sem_Elim;
65 with Sem_Eval; use Sem_Eval;
66 with Sem_Intr; use Sem_Intr;
67 with Sem_Mech; use Sem_Mech;
68 with Sem_Res; use Sem_Res;
69 with Sem_Type; use Sem_Type;
70 with Sem_Util; use Sem_Util;
71 with Sem_VFpt; use Sem_VFpt;
72 with Sem_Warn; use Sem_Warn;
73 with Stand; use Stand;
74 with Sinfo; use Sinfo;
75 with Sinfo.CN; use Sinfo.CN;
76 with Sinput; use Sinput;
77 with Stringt; use Stringt;
78 with Stylesw; use Stylesw;
80 with Targparm; use Targparm;
81 with Tbuild; use Tbuild;
83 with Uintp; use Uintp;
84 with Uname; use Uname;
85 with Urealp; use Urealp;
86 with Validsw; use Validsw;
87 with Warnsw; use Warnsw;
89 package body Sem_Prag is
91 ----------------------------------------------
92 -- Common Handling of Import-Export Pragmas --
93 ----------------------------------------------
95 -- In the following section, a number of Import_xxx and Export_xxx pragmas
96 -- are defined by GNAT. These are compatible with the DEC pragmas of the
97 -- same name, and all have the following common form and processing:
100 -- [Internal =>] LOCAL_NAME
101 -- [, [External =>] EXTERNAL_SYMBOL]
102 -- [, other optional parameters ]);
105 -- [Internal =>] LOCAL_NAME
106 -- [, [External =>] EXTERNAL_SYMBOL]
107 -- [, other optional parameters ]);
109 -- EXTERNAL_SYMBOL ::=
111 -- | static_string_EXPRESSION
113 -- The internal LOCAL_NAME designates the entity that is imported or
114 -- exported, and must refer to an entity in the current declarative
115 -- part (as required by the rules for LOCAL_NAME).
117 -- The external linker name is designated by the External parameter if
118 -- given, or the Internal parameter if not (if there is no External
119 -- parameter, the External parameter is a copy of the Internal name).
121 -- If the External parameter is given as a string, then this string is
122 -- treated as an external name (exactly as though it had been given as an
123 -- External_Name parameter for a normal Import pragma).
125 -- If the External parameter is given as an identifier (or there is no
126 -- External parameter, so that the Internal identifier is used), then
127 -- the external name is the characters of the identifier, translated
128 -- to all upper case letters for OpenVMS versions of GNAT, and to all
129 -- lower case letters for all other versions
131 -- Note: the external name specified or implied by any of these special
132 -- Import_xxx or Export_xxx pragmas override an external or link name
133 -- specified in a previous Import or Export pragma.
135 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
136 -- named notation, following the standard rules for subprogram calls, i.e.
137 -- parameters can be given in any order if named notation is used, and
138 -- positional and named notation can be mixed, subject to the rule that all
139 -- positional parameters must appear first.
141 -- Note: All these pragmas are implemented exactly following the DEC design
142 -- and implementation and are intended to be fully compatible with the use
143 -- of these pragmas in the DEC Ada compiler.
145 --------------------------------------------
146 -- Checking for Duplicated External Names --
147 --------------------------------------------
149 -- It is suspicious if two separate Export pragmas use the same external
150 -- name. The following table is used to diagnose this situation so that
151 -- an appropriate warning can be issued.
153 -- The Node_Id stored is for the N_String_Literal node created to hold
154 -- the value of the external name. The Sloc of this node is used to
155 -- cross-reference the location of the duplication.
157 package Externals is new Table.Table (
158 Table_Component_Type => Node_Id,
159 Table_Index_Type => Int,
160 Table_Low_Bound => 0,
161 Table_Initial => 100,
162 Table_Increment => 100,
163 Table_Name => "Name_Externals");
165 -------------------------------------
166 -- Local Subprograms and Variables --
167 -------------------------------------
169 procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id);
170 -- Subsidiary routine to the analysis of pragmas Depends, Global and
171 -- Refined_State. Append an entity to a list. If the list is empty, create
174 function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
175 -- This routine is used for possible casing adjustment of an explicit
176 -- external name supplied as a string literal (the node N), according to
177 -- the casing requirement of Opt.External_Name_Casing. If this is set to
178 -- As_Is, then the string literal is returned unchanged, but if it is set
179 -- to Uppercase or Lowercase, then a new string literal with appropriate
180 -- casing is constructed.
182 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean;
183 -- Subsidiary to the analysis of pragma Global and pragma Depends. Query
184 -- whether a particular item appears in a mixed list of nodes and entities.
185 -- It is assumed that all nodes in the list have entities.
187 procedure Check_Dependence_List_Syntax (List : Node_Id);
188 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
189 -- Verify the syntax of dependence relation List.
191 procedure Check_Global_List_Syntax (List : Node_Id);
192 -- Subsidiary to the analysis of pragmas Global and Refined_Global. Verify
193 -- the syntax of global list List.
195 procedure Check_Item_Syntax (Item : Node_Id);
196 -- Subsidiary to the analysis of pragmas Depends, Global, Initializes,
197 -- Part_Of, Refined_Depends, Refined_Depends and Refined_State. Verify the
198 -- syntax of a SPARK annotation item.
200 function Check_Kind (Nam : Name_Id) return Name_Id;
201 -- This function is used in connection with pragmas Assert, Check,
202 -- and assertion aspects and pragmas, to determine if Check pragmas
203 -- (or corresponding assertion aspects or pragmas) are currently active
204 -- as determined by the presence of -gnata on the command line (which
205 -- sets the default), and the appearance of pragmas Check_Policy and
206 -- Assertion_Policy as configuration pragmas either in a configuration
207 -- pragma file, or at the start of the current unit, or locally given
208 -- Check_Policy and Assertion_Policy pragmas that are currently active.
210 -- The value returned is one of the names Check, Ignore, Disable (On
211 -- returns Check, and Off returns Ignore).
213 -- Note: for assertion kinds Pre'Class, Post'Class, Invariant'Class,
214 -- and Type_Invariant'Class, the name passed is Name_uPre, Name_uPost,
215 -- Name_uInvariant, or Name_uType_Invariant, which corresponds to _Pre,
216 -- _Post, _Invariant, or _Type_Invariant, which are special names used
217 -- in identifiers to represent these attribute references.
219 procedure Check_SPARK_Aspect_For_ASIS (N : Node_Id);
220 -- In ASIS mode we need to analyze the original expression in the aspect
221 -- specification. For Initializes, Global, and related SPARK aspects, the
222 -- expression has a sui-generis syntax which may be a list, an expression,
225 procedure Check_State_And_Constituent_Use
229 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
230 -- Global and Initializes. Determine whether a state from list States and a
231 -- corresponding constituent from list Constits (if any) appear in the same
232 -- context denoted by Context. If this is the case, emit an error.
234 procedure Collect_Global_Items
236 In_Items : in out Elist_Id;
237 In_Out_Items : in out Elist_Id;
238 Out_Items : in out Elist_Id;
239 Proof_In_Items : in out Elist_Id;
240 Has_In_State : out Boolean;
241 Has_In_Out_State : out Boolean;
242 Has_Out_State : out Boolean;
243 Has_Proof_In_State : out Boolean;
244 Has_Null_State : out Boolean);
245 -- Subsidiary to the analysis of pragma Refined_Depends/Refined_Global.
246 -- Prag denotes pragma [Refined_]Global. Gather all input, in out, output
247 -- and Proof_In items of Prag in lists In_Items, In_Out_Items, Out_Items
248 -- and Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
249 -- and Has_Proof_In_State are set when there is at least one abstract state
250 -- with visible refinement available in the corresponding mode. Flag
251 -- Has_Null_State is set when at least state has a null refinement.
253 procedure Collect_Subprogram_Inputs_Outputs
254 (Subp_Id : Entity_Id;
255 Subp_Inputs : in out Elist_Id;
256 Subp_Outputs : in out Elist_Id;
257 Global_Seen : out Boolean);
258 -- Subsidiary to the analysis of pragma Depends, Global, Refined_Depends
259 -- and Refined_Global. Gather all inputs and outputs of subprogram Subp_Id
260 -- in lists Subp_Inputs and Subp_Outputs. If the case where the subprogram
261 -- has no inputs and/oroutputs, the returned list is No_Elist. Global_Seen
262 -- is set when the related subprogram has pragma [Refined_]Global.
264 function Find_Related_Subprogram_Or_Body
266 Do_Checks : Boolean := False) return Node_Id;
267 -- Subsidiary to the analysis of pragmas Contract_Cases, Depends, Global,
268 -- Refined_Depends, Refined_Global and Refined_Post. Find the declaration
269 -- of the related subprogram [body or stub] subject to pragma Prag. If flag
270 -- Do_Checks is set, the routine reports duplicate pragmas and detects
271 -- improper use of refinement pragmas in stand alone expression functions.
272 -- The returned value depends on the related pragma as follows:
273 -- 1) Pragmas Contract_Cases, Depends and Global yield the corresponding
274 -- N_Subprogram_Declaration node or if the pragma applies to a stand
275 -- alone body, the N_Subprogram_Body node or Empty if illegal.
276 -- 2) Pragmas Refined_Depends, Refined_Global and Refined_Post yield
277 -- N_Subprogram_Body or N_Subprogram_Body_Stub nodes or Empty if
280 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
281 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
282 -- original one, following the renaming chain) is returned. Otherwise the
283 -- entity is returned unchanged. Should be in Einfo???
285 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type;
286 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
287 -- Get_SPARK_Mode_Type. Convert a name into a corresponding value of type
290 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean;
291 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
292 -- Determine whether dependency clause Clause is surrounded by extra
293 -- parentheses. If this is the case, issue an error message.
295 function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean;
296 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
297 -- pragma Depends. Determine whether the type of dependency item Item is
298 -- tagged, unconstrained array, unconstrained record or a record with at
299 -- least one unconstrained component.
301 procedure Preanalyze_CTC_Args (N, Arg_Req, Arg_Ens : Node_Id);
302 -- Preanalyze the boolean expressions in the Requires and Ensures arguments
303 -- of a Test_Case pragma if present (possibly Empty). We treat these as
304 -- spec expressions (i.e. similar to a default expression).
306 procedure Record_Possible_Body_Reference
307 (State_Id : Entity_Id;
309 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
310 -- Global. Given an abstract state denoted by State_Id and a reference Ref
311 -- to it, determine whether the reference appears in a package body that
312 -- will eventually refine the state. If this is the case, record the
313 -- reference for future checks (see Analyze_Refined_State_In_Decls).
315 procedure Resolve_State (N : Node_Id);
316 -- Handle the overloading of state names by functions. When N denotes a
317 -- function, this routine finds the corresponding state and sets the entity
318 -- of N to that of the state.
320 procedure Rewrite_Assertion_Kind (N : Node_Id);
321 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
322 -- then it is rewritten as an identifier with the corresponding special
323 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas
324 -- Check, Check_Policy.
326 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id);
327 -- Place semantic information on the argument of an Elaborate/Elaborate_All
328 -- pragma. Entity name for unit and its parents is taken from item in
329 -- previous with_clause that mentions the unit.
332 -- This is a dummy function called by the processing for pragma Reviewable.
333 -- It is there for assisting front end debugging. By placing a Reviewable
334 -- pragma in the source program, a breakpoint on rv catches this place in
335 -- the source, allowing convenient stepping to the point of interest.
341 procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id) is
344 To_List := New_Elmt_List;
347 Append_Elmt (Item, To_List);
350 -------------------------------
351 -- Adjust_External_Name_Case --
352 -------------------------------
354 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
358 -- Adjust case of literal if required
360 if Opt.External_Name_Exp_Casing = As_Is then
364 -- Copy existing string
370 for J in 1 .. String_Length (Strval (N)) loop
371 CC := Get_String_Char (Strval (N), J);
373 if Opt.External_Name_Exp_Casing = Uppercase
374 and then CC >= Get_Char_Code ('a')
375 and then CC <= Get_Char_Code ('z')
377 Store_String_Char (CC - 32);
379 elsif Opt.External_Name_Exp_Casing = Lowercase
380 and then CC >= Get_Char_Code ('A')
381 and then CC <= Get_Char_Code ('Z')
383 Store_String_Char (CC + 32);
386 Store_String_Char (CC);
391 Make_String_Literal (Sloc (N),
392 Strval => End_String);
394 end Adjust_External_Name_Case;
396 -----------------------------------------
397 -- Analyze_Contract_Cases_In_Decl_Part --
398 -----------------------------------------
400 procedure Analyze_Contract_Cases_In_Decl_Part (N : Node_Id) is
401 Others_Seen : Boolean := False;
403 procedure Analyze_Contract_Case (CCase : Node_Id);
404 -- Verify the legality of a single contract case
406 ---------------------------
407 -- Analyze_Contract_Case --
408 ---------------------------
410 procedure Analyze_Contract_Case (CCase : Node_Id) is
411 Case_Guard : Node_Id;
413 Extra_Guard : Node_Id;
416 if Nkind (CCase) = N_Component_Association then
417 Case_Guard := First (Choices (CCase));
418 Conseq := Expression (CCase);
420 -- Each contract case must have exactly one case guard
422 Extra_Guard := Next (Case_Guard);
424 if Present (Extra_Guard) then
426 ("contract case must have exactly one case guard",
430 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
432 if Nkind (Case_Guard) = N_Others_Choice then
435 ("only one others choice allowed in contract cases",
441 elsif Others_Seen then
443 ("others must be the last choice in contract cases", N);
446 -- Preanalyze the case guard and consequence
448 if Nkind (Case_Guard) /= N_Others_Choice then
449 Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean);
452 Preanalyze_Assert_Expression (Conseq, Standard_Boolean);
454 -- The contract case is malformed
457 Error_Msg_N ("wrong syntax in contract case", CCase);
459 end Analyze_Contract_Case;
468 Restore_Scope : Boolean := False;
469 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
471 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
476 Subp_Decl := Find_Related_Subprogram_Or_Body (N);
477 Subp_Id := Defining_Entity (Subp_Decl);
478 All_Cases := Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
480 -- Single and multiple contract cases must appear in aggregate form. If
481 -- this is not the case, then either the parser of the analysis of the
482 -- pragma failed to produce an aggregate.
484 pragma Assert (Nkind (All_Cases) = N_Aggregate);
486 if No (Component_Associations (All_Cases)) then
487 Error_Msg_N ("wrong syntax for constract cases", N);
489 -- Individual contract cases appear as component associations
492 -- Ensure that the formal parameters are visible when analyzing all
493 -- clauses. This falls out of the general rule of aspects pertaining
494 -- to subprogram declarations. Skip the installation for subprogram
495 -- bodies because the formals are already visible.
497 if not In_Open_Scopes (Subp_Id) then
498 Restore_Scope := True;
499 Push_Scope (Subp_Id);
500 Install_Formals (Subp_Id);
503 CCase := First (Component_Associations (All_Cases));
504 while Present (CCase) loop
505 Analyze_Contract_Case (CCase);
509 if Restore_Scope then
513 end Analyze_Contract_Cases_In_Decl_Part;
515 ----------------------------------
516 -- Analyze_Depends_In_Decl_Part --
517 ----------------------------------
519 procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is
520 Loc : constant Source_Ptr := Sloc (N);
522 All_Inputs_Seen : Elist_Id := No_Elist;
523 -- A list containing the entities of all the inputs processed so far.
524 -- The list is populated with unique entities because the same input
525 -- may appear in multiple input lists.
527 All_Outputs_Seen : Elist_Id := No_Elist;
528 -- A list containing the entities of all the outputs processed so far.
529 -- The list is populated with unique entities because output items are
530 -- unique in a dependence relation.
532 Constits_Seen : Elist_Id := No_Elist;
533 -- A list containing the entities of all constituents processed so far.
534 -- It aids in detecting illegal usage of a state and a corresponding
535 -- constituent in pragma [Refinde_]Depends.
537 Global_Seen : Boolean := False;
538 -- A flag set when pragma Global has been processed
540 Null_Output_Seen : Boolean := False;
541 -- A flag used to track the legality of a null output
543 Result_Seen : Boolean := False;
544 -- A flag set when Subp_Id'Result is processed
547 -- The entity of the subprogram subject to pragma [Refined_]Depends
549 States_Seen : Elist_Id := No_Elist;
550 -- A list containing the entities of all states processed so far. It
551 -- helps in detecting illegal usage of a state and a corresponding
552 -- constituent in pragma [Refined_]Depends.
555 -- The entity of the subprogram [body or stub] subject to pragma
556 -- [Refined_]Depends.
558 Subp_Inputs : Elist_Id := No_Elist;
559 Subp_Outputs : Elist_Id := No_Elist;
560 -- Two lists containing the full set of inputs and output of the related
561 -- subprograms. Note that these lists contain both nodes and entities.
563 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id);
564 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
565 -- to the name buffer. The individual kinds are as follows:
566 -- E_Abstract_State - "state"
567 -- E_In_Parameter - "parameter"
568 -- E_In_Out_Parameter - "parameter"
569 -- E_Out_Parameter - "parameter"
570 -- E_Variable - "global"
572 procedure Analyze_Dependency_Clause
575 -- Verify the legality of a single dependency clause. Flag Is_Last
576 -- denotes whether Clause is the last clause in the relation.
578 procedure Check_Function_Return;
579 -- Verify that Funtion'Result appears as one of the outputs
580 -- (SPARK RM 6.1.5(10)).
587 -- Ensure that an item fulfils its designated input and/or output role
588 -- as specified by pragma Global (if any) or the enclosing context. If
589 -- this is not the case, emit an error. Item and Item_Id denote the
590 -- attributes of an item. Flag Is_Input should be set when item comes
591 -- from an input list. Flag Self_Ref should be set when the item is an
592 -- output and the dependency clause has operator "+".
594 procedure Check_Usage
595 (Subp_Items : Elist_Id;
596 Used_Items : Elist_Id;
598 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
599 -- error if this is not the case.
601 procedure Normalize_Clause (Clause : Node_Id);
602 -- Remove a self-dependency "+" from the input list of a clause. Split
603 -- a clause with multiple outputs into multiple clauses with a single
606 -----------------------------
607 -- Add_Item_To_Name_Buffer --
608 -----------------------------
610 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id) is
612 if Ekind (Item_Id) = E_Abstract_State then
613 Add_Str_To_Name_Buffer ("state");
615 elsif Is_Formal (Item_Id) then
616 Add_Str_To_Name_Buffer ("parameter");
618 elsif Ekind (Item_Id) = E_Variable then
619 Add_Str_To_Name_Buffer ("global");
621 -- The routine should not be called with non-SPARK items
626 end Add_Item_To_Name_Buffer;
628 -------------------------------
629 -- Analyze_Dependency_Clause --
630 -------------------------------
632 procedure Analyze_Dependency_Clause
636 procedure Analyze_Input_List (Inputs : Node_Id);
637 -- Verify the legality of a single input list
639 procedure Analyze_Input_Output
644 Seen : in out Elist_Id;
645 Null_Seen : in out Boolean;
646 Non_Null_Seen : in out Boolean);
647 -- Verify the legality of a single input or output item. Flag
648 -- Is_Input should be set whenever Item is an input, False when it
649 -- denotes an output. Flag Self_Ref should be set when the item is an
650 -- output and the dependency clause has a "+". Flag Top_Level should
651 -- be set whenever Item appears immediately within an input or output
652 -- list. Seen is a collection of all abstract states, variables and
653 -- formals processed so far. Flag Null_Seen denotes whether a null
654 -- input or output has been encountered. Flag Non_Null_Seen denotes
655 -- whether a non-null input or output has been encountered.
657 ------------------------
658 -- Analyze_Input_List --
659 ------------------------
661 procedure Analyze_Input_List (Inputs : Node_Id) is
662 Inputs_Seen : Elist_Id := No_Elist;
663 -- A list containing the entities of all inputs that appear in the
664 -- current input list.
666 Non_Null_Input_Seen : Boolean := False;
667 Null_Input_Seen : Boolean := False;
668 -- Flags used to check the legality of an input list
673 -- Multiple inputs appear as an aggregate
675 if Nkind (Inputs) = N_Aggregate then
676 if Present (Component_Associations (Inputs)) then
678 ("nested dependency relations not allowed", Inputs);
680 elsif Present (Expressions (Inputs)) then
681 Input := First (Expressions (Inputs));
682 while Present (Input) loop
689 Null_Seen => Null_Input_Seen,
690 Non_Null_Seen => Non_Null_Input_Seen);
696 Error_Msg_N ("malformed input dependency list", Inputs);
699 -- Process a solitary input
708 Null_Seen => Null_Input_Seen,
709 Non_Null_Seen => Non_Null_Input_Seen);
712 -- Detect an illegal dependency clause of the form
716 if Null_Output_Seen and then Null_Input_Seen then
718 ("null dependency clause cannot have a null input list",
721 end Analyze_Input_List;
723 --------------------------
724 -- Analyze_Input_Output --
725 --------------------------
727 procedure Analyze_Input_Output
732 Seen : in out Elist_Id;
733 Null_Seen : in out Boolean;
734 Non_Null_Seen : in out Boolean)
736 Is_Output : constant Boolean := not Is_Input;
741 -- Multiple input or output items appear as an aggregate
743 if Nkind (Item) = N_Aggregate then
744 if not Top_Level then
745 Error_Msg_N ("nested grouping of items not allowed", Item);
747 elsif Present (Component_Associations (Item)) then
749 ("nested dependency relations not allowed", Item);
751 -- Recursively analyze the grouped items
753 elsif Present (Expressions (Item)) then
754 Grouped := First (Expressions (Item));
755 while Present (Grouped) loop
758 Is_Input => Is_Input,
759 Self_Ref => Self_Ref,
762 Null_Seen => Null_Seen,
763 Non_Null_Seen => Non_Null_Seen);
769 Error_Msg_N ("malformed dependency list", Item);
772 -- Process Function'Result in the context of a dependency clause
774 elsif Is_Attribute_Result (Item) then
775 Non_Null_Seen := True;
777 -- It is sufficent to analyze the prefix of 'Result in order to
778 -- establish legality of the attribute.
780 Analyze (Prefix (Item));
782 -- The prefix of 'Result must denote the function for which
783 -- pragma Depends applies (SPARK RM 6.1.5(11)).
785 if not Is_Entity_Name (Prefix (Item))
786 or else Ekind (Spec_Id) /= E_Function
787 or else Entity (Prefix (Item)) /= Spec_Id
789 Error_Msg_Name_1 := Name_Result;
791 ("prefix of attribute % must denote the enclosing "
794 -- Function'Result is allowed to appear on the output side of a
795 -- dependency clause (SPARK RM 6.1.5(6)).
798 Error_Msg_N ("function result cannot act as input", Item);
802 ("cannot mix null and non-null dependency items", Item);
808 -- Detect multiple uses of null in a single dependency list or
809 -- throughout the whole relation. Verify the placement of a null
810 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
812 elsif Nkind (Item) = N_Null then
815 ("multiple null dependency relations not allowed", Item);
817 elsif Non_Null_Seen then
819 ("cannot mix null and non-null dependency items", Item);
827 ("null output list must be the last clause in a "
828 & "dependency relation", Item);
830 -- Catch a useless dependence of the form:
835 ("useless dependence, null depends on itself", Item);
843 Non_Null_Seen := True;
846 Error_Msg_N ("cannot mix null and non-null items", Item);
850 Resolve_State (Item);
852 -- Find the entity of the item. If this is a renaming, climb
853 -- the renaming chain to reach the root object. Renamings of
854 -- non-entire objects do not yield an entity (Empty).
856 Item_Id := Entity_Of (Item);
858 if Present (Item_Id) then
859 if Ekind_In (Item_Id, E_Abstract_State,
865 -- Ensure that the item fulfils its role as input and/or
866 -- output as specified by pragma Global or the enclosing
869 Check_Role (Item, Item_Id, Is_Input, Self_Ref);
871 -- Detect multiple uses of the same state, variable or
872 -- formal parameter. If this is not the case, add the
873 -- item to the list of processed relations.
875 if Contains (Seen, Item_Id) then
877 ("duplicate use of item &", Item, Item_Id);
879 Add_Item (Item_Id, Seen);
882 -- Detect illegal use of an input related to a null
883 -- output. Such input items cannot appear in other
884 -- input lists (SPARK RM 6.1.5(13)).
887 and then Null_Output_Seen
888 and then Contains (All_Inputs_Seen, Item_Id)
891 ("input of a null output list cannot appear in "
892 & "multiple input lists", Item);
895 -- Add an input or a self-referential output to the list
896 -- of all processed inputs.
898 if Is_Input or else Self_Ref then
899 Add_Item (Item_Id, All_Inputs_Seen);
902 -- State related checks (SPARK RM 6.1.5(3))
904 if Ekind (Item_Id) = E_Abstract_State then
905 if Has_Visible_Refinement (Item_Id) then
907 ("cannot mention state & in global refinement",
910 ("\use its constituents instead", Item);
913 -- If the reference to the abstract state appears in
914 -- an enclosing package body that will eventually
915 -- refine the state, record the reference for future
919 Record_Possible_Body_Reference
920 (State_Id => Item_Id,
925 -- When the item renames an entire object, replace the
926 -- item with a reference to the object.
928 if Present (Renamed_Object (Entity (Item))) then
930 New_Occurrence_Of (Item_Id, Sloc (Item)));
934 -- Add the entity of the current item to the list of
937 if Ekind (Item_Id) = E_Abstract_State then
938 Add_Item (Item_Id, States_Seen);
941 if Ekind_In (Item_Id, E_Abstract_State, E_Variable)
942 and then Present (Encapsulating_State (Item_Id))
944 Add_Item (Item_Id, Constits_Seen);
947 -- All other input/output items are illegal
948 -- (SPARK RM 6.1.5(1)).
952 ("item must denote parameter, variable, or state",
956 -- All other input/output items are illegal
957 -- (SPARK RM 6.1.5(1))
961 ("item must denote parameter, variable, or state",
965 end Analyze_Input_Output;
973 Non_Null_Output_Seen : Boolean := False;
974 -- Flag used to check the legality of an output list
976 -- Start of processing for Analyze_Dependency_Clause
979 Inputs := Expression (Clause);
982 -- An input list with a self-dependency appears as operator "+" where
983 -- the actuals inputs are the right operand.
985 if Nkind (Inputs) = N_Op_Plus then
986 Inputs := Right_Opnd (Inputs);
990 -- Process the output_list of a dependency_clause
992 Output := First (Choices (Clause));
993 while Present (Output) loop
997 Self_Ref => Self_Ref,
999 Seen => All_Outputs_Seen,
1000 Null_Seen => Null_Output_Seen,
1001 Non_Null_Seen => Non_Null_Output_Seen);
1006 -- Process the input_list of a dependency_clause
1008 Analyze_Input_List (Inputs);
1009 end Analyze_Dependency_Clause;
1011 ---------------------------
1012 -- Check_Function_Return --
1013 ---------------------------
1015 procedure Check_Function_Return is
1017 if Ekind (Spec_Id) = E_Function and then not Result_Seen then
1019 ("result of & must appear in exactly one output list",
1022 end Check_Function_Return;
1028 procedure Check_Role
1030 Item_Id : Entity_Id;
1035 (Item_Is_Input : out Boolean;
1036 Item_Is_Output : out Boolean);
1037 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1038 -- Item_Is_Output are set depending on the role.
1040 procedure Role_Error
1041 (Item_Is_Input : Boolean;
1042 Item_Is_Output : Boolean);
1043 -- Emit an error message concerning the incorrect use of Item in
1044 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1045 -- denote whether the item is an input and/or an output.
1052 (Item_Is_Input : out Boolean;
1053 Item_Is_Output : out Boolean)
1056 Item_Is_Input := False;
1057 Item_Is_Output := False;
1059 -- Abstract state cases
1061 if Ekind (Item_Id) = E_Abstract_State then
1063 -- When pragma Global is present, the mode of the state may be
1064 -- further constrained by setting a more restrictive mode.
1067 if Appears_In (Subp_Inputs, Item_Id) then
1068 Item_Is_Input := True;
1071 if Appears_In (Subp_Outputs, Item_Id) then
1072 Item_Is_Output := True;
1075 -- Otherwise the state has a default IN OUT mode
1078 Item_Is_Input := True;
1079 Item_Is_Output := True;
1084 elsif Ekind (Item_Id) = E_In_Parameter then
1085 Item_Is_Input := True;
1087 elsif Ekind (Item_Id) = E_In_Out_Parameter then
1088 Item_Is_Input := True;
1089 Item_Is_Output := True;
1091 elsif Ekind (Item_Id) = E_Out_Parameter then
1092 if Scope (Item_Id) = Spec_Id then
1094 -- An OUT parameter of the related subprogram has mode IN
1095 -- if its type is unconstrained or tagged because array
1096 -- bounds, discriminants or tags can be read.
1098 if Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1099 Item_Is_Input := True;
1102 Item_Is_Output := True;
1104 -- An OUT parameter of an enclosing subprogram behaves as a
1105 -- read-write variable in which case the mode is IN OUT.
1108 Item_Is_Input := True;
1109 Item_Is_Output := True;
1114 else pragma Assert (Ekind (Item_Id) = E_Variable);
1116 -- When pragma Global is present, the mode of the variable may
1117 -- be further constrained by setting a more restrictive mode.
1121 -- A variable has mode IN when its type is unconstrained or
1122 -- tagged because array bounds, discriminants or tags can be
1125 if Appears_In (Subp_Inputs, Item_Id)
1126 or else Is_Unconstrained_Or_Tagged_Item (Item_Id)
1128 Item_Is_Input := True;
1131 if Appears_In (Subp_Outputs, Item_Id) then
1132 Item_Is_Output := True;
1135 -- Otherwise the variable has a default IN OUT mode
1138 Item_Is_Input := True;
1139 Item_Is_Output := True;
1148 procedure Role_Error
1149 (Item_Is_Input : Boolean;
1150 Item_Is_Output : Boolean)
1152 Error_Msg : Name_Id;
1157 -- When the item is not part of the input and the output set of
1158 -- the related subprogram, then it appears as extra in pragma
1159 -- [Refined_]Depends.
1161 if not Item_Is_Input and then not Item_Is_Output then
1162 Add_Item_To_Name_Buffer (Item_Id);
1163 Add_Str_To_Name_Buffer
1164 (" & cannot appear in dependence relation");
1166 Error_Msg := Name_Find;
1167 Error_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1169 Error_Msg_Name_1 := Chars (Subp_Id);
1171 ("\& is not part of the input or output set of subprogram %",
1174 -- The mode of the item and its role in pragma [Refined_]Depends
1175 -- are in conflict. Construct a detailed message explaining the
1176 -- illegality (SPARK RM 6.1.5(5-6)).
1179 if Item_Is_Input then
1180 Add_Str_To_Name_Buffer ("read-only");
1182 Add_Str_To_Name_Buffer ("write-only");
1185 Add_Char_To_Name_Buffer (' ');
1186 Add_Item_To_Name_Buffer (Item_Id);
1187 Add_Str_To_Name_Buffer (" & cannot appear as ");
1189 if Item_Is_Input then
1190 Add_Str_To_Name_Buffer ("output");
1192 Add_Str_To_Name_Buffer ("input");
1195 Add_Str_To_Name_Buffer (" in dependence relation");
1196 Error_Msg := Name_Find;
1197 Error_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1203 Item_Is_Input : Boolean;
1204 Item_Is_Output : Boolean;
1206 -- Start of processing for Check_Role
1209 Find_Role (Item_Is_Input, Item_Is_Output);
1214 if not Item_Is_Input then
1215 Role_Error (Item_Is_Input, Item_Is_Output);
1218 -- Self-referential item
1221 if not Item_Is_Input or else not Item_Is_Output then
1222 Role_Error (Item_Is_Input, Item_Is_Output);
1227 elsif not Item_Is_Output then
1228 Role_Error (Item_Is_Input, Item_Is_Output);
1236 procedure Check_Usage
1237 (Subp_Items : Elist_Id;
1238 Used_Items : Elist_Id;
1241 procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id);
1242 -- Emit an error concerning the erroneous usage of an item
1248 procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id) is
1249 Error_Msg : Name_Id;
1256 -- Unconstrained and tagged items are not part of the explicit
1257 -- input set of the related subprogram, they do not have to be
1258 -- present in a dependence relation and should not be flagged
1259 -- (SPARK RM 6.1.5(8)).
1261 if not Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1264 Add_Item_To_Name_Buffer (Item_Id);
1265 Add_Str_To_Name_Buffer
1266 (" & must appear in at least one input dependence list");
1268 Error_Msg := Name_Find;
1269 Error_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1272 -- Output case (SPARK RM 6.1.5(10))
1277 Add_Item_To_Name_Buffer (Item_Id);
1278 Add_Str_To_Name_Buffer
1279 (" & must appear in exactly one output dependence list");
1281 Error_Msg := Name_Find;
1282 Error_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1290 Item_Id : Entity_Id;
1292 -- Start of processing for Check_Usage
1295 if No (Subp_Items) then
1299 -- Each input or output of the subprogram must appear in a dependency
1302 Elmt := First_Elmt (Subp_Items);
1303 while Present (Elmt) loop
1304 Item := Node (Elmt);
1306 if Nkind (Item) = N_Defining_Identifier then
1309 Item_Id := Entity_Of (Item);
1312 -- The item does not appear in a dependency
1314 if Present (Item_Id)
1315 and then not Contains (Used_Items, Item_Id)
1317 if Is_Formal (Item_Id) then
1318 Usage_Error (Item, Item_Id);
1320 -- States and global variables are not used properly only when
1321 -- the subprogram is subject to pragma Global.
1323 elsif Global_Seen then
1324 Usage_Error (Item, Item_Id);
1332 ----------------------
1333 -- Normalize_Clause --
1334 ----------------------
1336 procedure Normalize_Clause (Clause : Node_Id) is
1337 procedure Create_Or_Modify_Clause
1343 Multiple : Boolean);
1344 -- Create a brand new clause to represent the self-reference or
1345 -- modify the input and/or output lists of an existing clause. Output
1346 -- denotes a self-referencial output. Outputs is the output list of a
1347 -- clause. Inputs is the input list of a clause. After denotes the
1348 -- clause after which the new clause is to be inserted. Flag In_Place
1349 -- should be set when normalizing the last output of an output list.
1350 -- Flag Multiple should be set when Output comes from a list with
1353 procedure Split_Multiple_Outputs;
1354 -- If Clause contains more than one output, split the clause into
1355 -- multiple clauses with a single output. All new clauses are added
1358 -----------------------------
1359 -- Create_Or_Modify_Clause --
1360 -----------------------------
1362 procedure Create_Or_Modify_Clause
1370 procedure Propagate_Output
1373 -- Handle the various cases of output propagation to the input
1374 -- list. Output denotes a self-referencial output item. Inputs is
1375 -- the input list of a clause.
1377 ----------------------
1378 -- Propagate_Output --
1379 ----------------------
1381 procedure Propagate_Output
1385 function In_Input_List
1387 Inputs : List_Id) return Boolean;
1388 -- Determine whether a particulat item appears in the input
1389 -- list of a clause.
1395 function In_Input_List
1397 Inputs : List_Id) return Boolean
1402 Elmt := First (Inputs);
1403 while Present (Elmt) loop
1404 if Entity_Of (Elmt) = Item then
1416 Output_Id : constant Entity_Id := Entity_Of (Output);
1419 -- Start of processing for Propagate_Output
1422 -- The clause is of the form:
1424 -- (Output =>+ null)
1426 -- Remove the null input and replace it with a copy of the
1429 -- (Output => Output)
1431 if Nkind (Inputs) = N_Null then
1432 Rewrite (Inputs, New_Copy_Tree (Output));
1434 -- The clause is of the form:
1436 -- (Output =>+ (Input1, ..., InputN))
1438 -- Determine whether the output is not already mentioned in the
1439 -- input list and if not, add it to the list of inputs:
1441 -- (Output => (Output, Input1, ..., InputN))
1443 elsif Nkind (Inputs) = N_Aggregate then
1444 Grouped := Expressions (Inputs);
1446 if not In_Input_List
1450 Prepend_To (Grouped, New_Copy_Tree (Output));
1453 -- The clause is of the form:
1455 -- (Output =>+ Input)
1457 -- If the input does not mention the output, group the two
1460 -- (Output => (Output, Input))
1462 elsif Entity_Of (Inputs) /= Output_Id then
1464 Make_Aggregate (Loc,
1465 Expressions => New_List (
1466 New_Copy_Tree (Output),
1467 New_Copy_Tree (Inputs))));
1469 end Propagate_Output;
1473 Loc : constant Source_Ptr := Sloc (Clause);
1474 New_Clause : Node_Id;
1476 -- Start of processing for Create_Or_Modify_Clause
1479 -- A null output depending on itself does not require any
1482 if Nkind (Output) = N_Null then
1485 -- A function result cannot depend on itself because it cannot
1486 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1488 elsif Is_Attribute_Result (Output) then
1489 Error_Msg_N ("function result cannot depend on itself", Output);
1493 -- When performing the transformation in place, simply add the
1494 -- output to the list of inputs (if not already there). This case
1495 -- arises when dealing with the last output of an output list -
1496 -- we perform the normalization in place to avoid generating a
1500 Propagate_Output (Output, Inputs);
1502 -- A list with multiple outputs is slowly trimmed until only
1503 -- one element remains. When this happens, replace the
1504 -- aggregate with the element itself.
1508 Rewrite (Outputs, Output);
1514 -- Unchain the output from its output list as it will appear in
1515 -- a new clause. Note that we cannot simply rewrite the output
1516 -- as null because this will violate the semantics of pragma
1521 -- Generate a new clause of the form:
1522 -- (Output => Inputs)
1525 Make_Component_Association (Loc,
1526 Choices => New_List (Output),
1527 Expression => New_Copy_Tree (Inputs));
1529 -- The new clause contains replicated content that has already
1530 -- been analyzed. There is not need to reanalyze it or
1531 -- renormalize it again.
1533 Set_Analyzed (New_Clause);
1536 (Output => First (Choices (New_Clause)),
1537 Inputs => Expression (New_Clause));
1539 Insert_After (After, New_Clause);
1541 end Create_Or_Modify_Clause;
1543 ----------------------------
1544 -- Split_Multiple_Outputs --
1545 ----------------------------
1547 procedure Split_Multiple_Outputs is
1548 Inputs : constant Node_Id := Expression (Clause);
1549 Loc : constant Source_Ptr := Sloc (Clause);
1550 Outputs : constant Node_Id := First (Choices (Clause));
1551 Last_Output : Node_Id;
1552 Next_Output : Node_Id;
1556 -- Start of processing for Split_Multiple_Outputs
1559 -- Multiple outputs appear as an aggregate. Nothing to do when
1560 -- the clause has exactly one output.
1562 if Nkind (Outputs) = N_Aggregate then
1563 Last_Output := Last (Expressions (Outputs));
1565 -- Create a clause for each output. Note that each time a new
1566 -- clause is created, the original output list slowly shrinks
1567 -- until there is one item left.
1569 Output := First (Expressions (Outputs));
1570 while Present (Output) loop
1571 Next_Output := Next (Output);
1573 -- Unhook the output from the original output list as it
1574 -- will be relocated to a new clause.
1578 -- Special processing for the last output. At this point
1579 -- the original aggregate has been stripped down to one
1580 -- element. Replace the aggregate by the element itself.
1582 if Output = Last_Output then
1583 Rewrite (Outputs, Output);
1586 -- Generate a clause of the form:
1587 -- (Output => Inputs)
1590 Make_Component_Association (Loc,
1591 Choices => New_List (Output),
1592 Expression => New_Copy_Tree (Inputs));
1594 -- The new clause contains replicated content that has
1595 -- already been analyzed. There is not need to reanalyze
1598 Set_Analyzed (Split);
1599 Insert_After (Clause, Split);
1602 Output := Next_Output;
1605 end Split_Multiple_Outputs;
1609 Outputs : constant Node_Id := First (Choices (Clause));
1611 Last_Output : Node_Id;
1612 Next_Output : Node_Id;
1615 -- Start of processing for Normalize_Clause
1618 -- A self-dependency appears as operator "+". Remove the "+" from the
1619 -- tree by moving the real inputs to their proper place.
1621 if Nkind (Expression (Clause)) = N_Op_Plus then
1622 Rewrite (Expression (Clause), Right_Opnd (Expression (Clause)));
1623 Inputs := Expression (Clause);
1625 -- Multiple outputs appear as an aggregate
1627 if Nkind (Outputs) = N_Aggregate then
1628 Last_Output := Last (Expressions (Outputs));
1630 Output := First (Expressions (Outputs));
1631 while Present (Output) loop
1633 -- Normalization may remove an output from its list,
1634 -- preserve the subsequent output now.
1636 Next_Output := Next (Output);
1638 Create_Or_Modify_Clause
1643 In_Place => Output = Last_Output,
1646 Output := Next_Output;
1652 Create_Or_Modify_Clause
1662 -- Split a clause with multiple outputs into multiple clauses with a
1665 Split_Multiple_Outputs;
1666 end Normalize_Clause;
1670 Deps : constant Node_Id :=
1672 (First (Pragma_Argument_Associations (N)));
1675 Last_Clause : Node_Id;
1676 Subp_Decl : Node_Id;
1678 Restore_Scope : Boolean := False;
1679 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
1681 -- Start of processing for Analyze_Depends_In_Decl_Part
1686 -- Verify the syntax of pragma Depends when SPARK checks are suppressed.
1687 -- Semantic analysis and normalization are disabled in this mode.
1689 if SPARK_Mode = Off then
1690 Check_Dependence_List_Syntax (Deps);
1694 Subp_Decl := Find_Related_Subprogram_Or_Body (N);
1695 Subp_Id := Defining_Entity (Subp_Decl);
1697 -- The logic in this routine is used to analyze both pragma Depends and
1698 -- pragma Refined_Depends since they have the same syntax and base
1699 -- semantics. Find the entity of the corresponding spec when analyzing
1702 if Nkind (Subp_Decl) = N_Subprogram_Body
1703 and then not Acts_As_Spec (Subp_Decl)
1705 Spec_Id := Corresponding_Spec (Subp_Decl);
1707 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub then
1708 Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl);
1714 -- Empty dependency list
1716 if Nkind (Deps) = N_Null then
1718 -- Gather all states, variables and formal parameters that the
1719 -- subprogram may depend on. These items are obtained from the
1720 -- parameter profile or pragma [Refined_]Global (if available).
1722 Collect_Subprogram_Inputs_Outputs
1723 (Subp_Id => Subp_Id,
1724 Subp_Inputs => Subp_Inputs,
1725 Subp_Outputs => Subp_Outputs,
1726 Global_Seen => Global_Seen);
1728 -- Verify that every input or output of the subprogram appear in a
1731 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1732 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1733 Check_Function_Return;
1735 -- Dependency clauses appear as component associations of an aggregate
1737 elsif Nkind (Deps) = N_Aggregate then
1739 -- Do not attempt to perform analysis of a syntactically illegal
1740 -- clause as this will lead to misleading errors.
1742 if Has_Extra_Parentheses (Deps) then
1746 if Present (Component_Associations (Deps)) then
1747 Last_Clause := Last (Component_Associations (Deps));
1749 -- Gather all states, variables and formal parameters that the
1750 -- subprogram may depend on. These items are obtained from the
1751 -- parameter profile or pragma [Refined_]Global (if available).
1753 Collect_Subprogram_Inputs_Outputs
1754 (Subp_Id => Subp_Id,
1755 Subp_Inputs => Subp_Inputs,
1756 Subp_Outputs => Subp_Outputs,
1757 Global_Seen => Global_Seen);
1759 -- Ensure that the formal parameters are visible when analyzing
1760 -- all clauses. This falls out of the general rule of aspects
1761 -- pertaining to subprogram declarations. Skip the installation
1762 -- for subprogram bodies because the formals are already visible.
1764 if not In_Open_Scopes (Spec_Id) then
1765 Restore_Scope := True;
1766 Push_Scope (Spec_Id);
1767 Install_Formals (Spec_Id);
1770 Clause := First (Component_Associations (Deps));
1771 while Present (Clause) loop
1772 Errors := Serious_Errors_Detected;
1774 -- Normalization may create extra clauses that contain
1775 -- replicated input and output names. There is no need to
1778 if not Analyzed (Clause) then
1779 Set_Analyzed (Clause);
1781 Analyze_Dependency_Clause
1783 Is_Last => Clause = Last_Clause);
1786 -- Do not normalize an erroneous clause because the inputs
1787 -- and/or outputs may denote illegal items. Normalization is
1788 -- disabled in ASIS mode as it alters the tree by introducing
1789 -- new nodes similar to expansion.
1791 if Serious_Errors_Detected = Errors and then not ASIS_Mode then
1792 Normalize_Clause (Clause);
1798 if Restore_Scope then
1802 -- Verify that every input or output of the subprogram appear in a
1805 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1806 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1807 Check_Function_Return;
1809 -- The dependency list is malformed
1812 Error_Msg_N ("malformed dependency relation", Deps);
1816 -- The top level dependency relation is malformed
1819 Error_Msg_N ("malformed dependency relation", Deps);
1823 -- Ensure that a state and a corresponding constituent do not appear
1824 -- together in pragma [Refined_]Depends.
1826 Check_State_And_Constituent_Use
1827 (States => States_Seen,
1828 Constits => Constits_Seen,
1830 end Analyze_Depends_In_Decl_Part;
1832 --------------------------------------------
1833 -- Analyze_External_Property_In_Decl_Part --
1834 --------------------------------------------
1836 procedure Analyze_External_Property_In_Decl_Part
1838 Expr_Val : out Boolean)
1840 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
1841 Obj : constant Node_Id := Get_Pragma_Arg (Arg1);
1842 Expr : constant Node_Id := Get_Pragma_Arg (Next (Arg1));
1845 Error_Msg_Name_1 := Pragma_Name (N);
1847 -- The Async / Effective pragmas must apply to a volatile object other
1848 -- than a formal subprogram parameter (SPARK RM 7.1.3(2)).
1850 if Is_SPARK_Volatile_Object (Obj) then
1851 if Is_Entity_Name (Obj)
1852 and then Present (Entity (Obj))
1853 and then Is_Formal (Entity (Obj))
1855 Error_Msg_N ("external property % cannot apply to parameter", N);
1859 ("external property % must apply to a volatile object", N);
1862 -- Ensure that the expression (if present) is static Boolean. A missing
1863 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
1867 if Present (Expr) then
1868 Analyze_And_Resolve (Expr, Standard_Boolean);
1870 if Is_Static_Expression (Expr) then
1871 Expr_Val := Is_True (Expr_Value (Expr));
1873 Error_Msg_Name_1 := Pragma_Name (N);
1874 Error_Msg_N ("expression of % must be static", Expr);
1877 end Analyze_External_Property_In_Decl_Part;
1879 ---------------------------------
1880 -- Analyze_Global_In_Decl_Part --
1881 ---------------------------------
1883 procedure Analyze_Global_In_Decl_Part (N : Node_Id) is
1884 Constits_Seen : Elist_Id := No_Elist;
1885 -- A list containing the entities of all constituents processed so far.
1886 -- It aids in detecting illegal usage of a state and a corresponding
1887 -- constituent in pragma [Refinde_]Global.
1889 Seen : Elist_Id := No_Elist;
1890 -- A list containing the entities of all the items processed so far. It
1891 -- plays a role in detecting distinct entities.
1893 Spec_Id : Entity_Id;
1894 -- The entity of the subprogram subject to pragma [Refined_]Global
1896 States_Seen : Elist_Id := No_Elist;
1897 -- A list containing the entities of all states processed so far. It
1898 -- helps in detecting illegal usage of a state and a corresponding
1899 -- constituent in pragma [Refined_]Global.
1901 Subp_Id : Entity_Id;
1902 -- The entity of the subprogram [body or stub] subject to pragma
1903 -- [Refined_]Global.
1905 In_Out_Seen : Boolean := False;
1906 Input_Seen : Boolean := False;
1907 Output_Seen : Boolean := False;
1908 Proof_Seen : Boolean := False;
1909 -- Flags used to verify the consistency of modes
1911 procedure Analyze_Global_List
1913 Global_Mode : Name_Id := Name_Input);
1914 -- Verify the legality of a single global list declaration. Global_Mode
1915 -- denotes the current mode in effect.
1917 -------------------------
1918 -- Analyze_Global_List --
1919 -------------------------
1921 procedure Analyze_Global_List
1923 Global_Mode : Name_Id := Name_Input)
1925 procedure Analyze_Global_Item
1927 Global_Mode : Name_Id);
1928 -- Verify the legality of a single global item declaration.
1929 -- Global_Mode denotes the current mode in effect.
1931 procedure Check_Duplicate_Mode
1933 Status : in out Boolean);
1934 -- Flag Status denotes whether a particular mode has been seen while
1935 -- processing a global list. This routine verifies that Mode is not a
1936 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
1938 procedure Check_Mode_Restriction_In_Enclosing_Context
1940 Item_Id : Entity_Id);
1941 -- Verify that an item of mode In_Out or Output does not appear as an
1942 -- input in the Global aspect of an enclosing subprogram. If this is
1943 -- the case, emit an error. Item and Item_Id are respectively the
1944 -- item and its entity.
1946 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id);
1947 -- Mode denotes either In_Out or Output. Depending on the kind of the
1948 -- related subprogram, emit an error if those two modes apply to a
1949 -- function (SPARK RM 6.1.4(10)).
1951 -------------------------
1952 -- Analyze_Global_Item --
1953 -------------------------
1955 procedure Analyze_Global_Item
1957 Global_Mode : Name_Id)
1959 Item_Id : Entity_Id;
1962 -- Detect one of the following cases
1964 -- with Global => (null, Name)
1965 -- with Global => (Name_1, null, Name_2)
1966 -- with Global => (Name, null)
1968 if Nkind (Item) = N_Null then
1969 Error_Msg_N ("cannot mix null and non-null global items", Item);
1974 Resolve_State (Item);
1976 -- Find the entity of the item. If this is a renaming, climb the
1977 -- renaming chain to reach the root object. Renamings of non-
1978 -- entire objects do not yield an entity (Empty).
1980 Item_Id := Entity_Of (Item);
1982 if Present (Item_Id) then
1984 -- A global item may denote a formal parameter of an enclosing
1985 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
1986 -- provide a better error diagnostic.
1988 if Is_Formal (Item_Id) then
1989 if Scope (Item_Id) = Spec_Id then
1991 ("global item cannot reference parameter of subprogram",
1996 -- A constant cannot act as a global item (SPARK RM 6.1.4(7)).
1997 -- Do this check first to provide a better error diagnostic.
1999 elsif Ekind (Item_Id) = E_Constant then
2000 Error_Msg_N ("global item cannot denote a constant", Item);
2002 -- The only legal references are those to abstract states and
2003 -- variables (SPARK RM 6.1.4(4)).
2005 elsif not Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
2007 ("global item must denote variable or state", Item);
2011 -- State related checks
2013 if Ekind (Item_Id) = E_Abstract_State then
2015 -- An abstract state with visible refinement cannot appear
2016 -- in pragma [Refined_]Global as its place must be taken by
2017 -- some of its constituents (SPARK RM 6.1.4(8)).
2019 if Has_Visible_Refinement (Item_Id) then
2021 ("cannot mention state & in global refinement",
2023 Error_Msg_N ("\use its constituents instead", Item);
2026 -- If the reference to the abstract state appears in an
2027 -- enclosing package body that will eventually refine the
2028 -- state, record the reference for future checks.
2031 Record_Possible_Body_Reference
2032 (State_Id => Item_Id,
2036 -- Variable related checks. These are only relevant when
2037 -- SPARK_Mode is on as they are not standard Ada legality
2040 elsif SPARK_Mode = On
2041 and then Is_SPARK_Volatile_Object (Item_Id)
2043 -- A volatile object cannot appear as a global item of a
2044 -- function (SPARK RM 7.1.3(9)).
2046 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
2048 ("volatile object & cannot act as global item of a "
2049 & "function", Item, Item_Id);
2052 -- A volatile object with property Effective_Reads set to
2053 -- True must have mode Output or In_Out.
2055 elsif Effective_Reads_Enabled (Item_Id)
2056 and then Global_Mode = Name_Input
2059 ("volatile object & with property Effective_Reads must "
2060 & "have mode In_Out or Output (SPARK RM 7.1.3(11))",
2066 -- When the item renames an entire object, replace the item
2067 -- with a reference to the object.
2069 if Present (Renamed_Object (Entity (Item))) then
2070 Rewrite (Item, New_Occurrence_Of (Item_Id, Sloc (Item)));
2074 -- Some form of illegal construct masquerading as a name
2075 -- (SPARK RM 6.1.4(4)).
2078 Error_Msg_N ("global item must denote variable or state", Item);
2082 -- Verify that an output does not appear as an input in an
2083 -- enclosing subprogram.
2085 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2086 Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id);
2089 -- The same entity might be referenced through various way.
2090 -- Check the entity of the item rather than the item itself
2091 -- (SPARK RM 6.1.4(11)).
2093 if Contains (Seen, Item_Id) then
2094 Error_Msg_N ("duplicate global item", Item);
2096 -- Add the entity of the current item to the list of processed
2100 Add_Item (Item_Id, Seen);
2102 if Ekind (Item_Id) = E_Abstract_State then
2103 Add_Item (Item_Id, States_Seen);
2106 if Ekind_In (Item_Id, E_Abstract_State, E_Variable)
2107 and then Present (Encapsulating_State (Item_Id))
2109 Add_Item (Item_Id, Constits_Seen);
2112 end Analyze_Global_Item;
2114 --------------------------
2115 -- Check_Duplicate_Mode --
2116 --------------------------
2118 procedure Check_Duplicate_Mode
2120 Status : in out Boolean)
2124 Error_Msg_N ("duplicate global mode", Mode);
2128 end Check_Duplicate_Mode;
2130 -------------------------------------------------
2131 -- Check_Mode_Restriction_In_Enclosing_Context --
2132 -------------------------------------------------
2134 procedure Check_Mode_Restriction_In_Enclosing_Context
2136 Item_Id : Entity_Id)
2138 Context : Entity_Id;
2140 Inputs : Elist_Id := No_Elist;
2141 Outputs : Elist_Id := No_Elist;
2144 -- Traverse the scope stack looking for enclosing subprograms
2145 -- subject to pragma [Refined_]Global.
2147 Context := Scope (Subp_Id);
2148 while Present (Context) and then Context /= Standard_Standard loop
2149 if Is_Subprogram (Context)
2151 (Present (Get_Pragma (Context, Pragma_Global))
2153 Present (Get_Pragma (Context, Pragma_Refined_Global)))
2155 Collect_Subprogram_Inputs_Outputs
2156 (Subp_Id => Context,
2157 Subp_Inputs => Inputs,
2158 Subp_Outputs => Outputs,
2159 Global_Seen => Dummy);
2161 -- The item is classified as In_Out or Output but appears as
2162 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(12)).
2164 if Appears_In (Inputs, Item_Id)
2165 and then not Appears_In (Outputs, Item_Id)
2168 ("global item & cannot have mode In_Out or Output",
2171 ("\item already appears as input of subprogram &",
2174 -- Stop the traversal once an error has been detected
2180 Context := Scope (Context);
2182 end Check_Mode_Restriction_In_Enclosing_Context;
2184 ----------------------------------------
2185 -- Check_Mode_Restriction_In_Function --
2186 ----------------------------------------
2188 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
2190 if Ekind (Spec_Id) = E_Function then
2192 ("global mode & is not applicable to functions", Mode);
2194 end Check_Mode_Restriction_In_Function;
2202 -- Start of processing for Analyze_Global_List
2205 if Nkind (List) = N_Null then
2206 Set_Analyzed (List);
2208 -- Single global item declaration
2210 elsif Nkind_In (List, N_Expanded_Name,
2212 N_Selected_Component)
2214 Analyze_Global_Item (List, Global_Mode);
2216 -- Simple global list or moded global list declaration
2218 elsif Nkind (List) = N_Aggregate then
2219 Set_Analyzed (List);
2221 -- The declaration of a simple global list appear as a collection
2224 if Present (Expressions (List)) then
2225 if Present (Component_Associations (List)) then
2227 ("cannot mix moded and non-moded global lists", List);
2230 Item := First (Expressions (List));
2231 while Present (Item) loop
2232 Analyze_Global_Item (Item, Global_Mode);
2237 -- The declaration of a moded global list appears as a collection
2238 -- of component associations where individual choices denote
2241 elsif Present (Component_Associations (List)) then
2242 if Present (Expressions (List)) then
2244 ("cannot mix moded and non-moded global lists", List);
2247 Assoc := First (Component_Associations (List));
2248 while Present (Assoc) loop
2249 Mode := First (Choices (Assoc));
2251 if Nkind (Mode) = N_Identifier then
2252 if Chars (Mode) = Name_In_Out then
2253 Check_Duplicate_Mode (Mode, In_Out_Seen);
2254 Check_Mode_Restriction_In_Function (Mode);
2256 elsif Chars (Mode) = Name_Input then
2257 Check_Duplicate_Mode (Mode, Input_Seen);
2259 elsif Chars (Mode) = Name_Output then
2260 Check_Duplicate_Mode (Mode, Output_Seen);
2261 Check_Mode_Restriction_In_Function (Mode);
2263 elsif Chars (Mode) = Name_Proof_In then
2264 Check_Duplicate_Mode (Mode, Proof_Seen);
2267 Error_Msg_N ("invalid mode selector", Mode);
2271 Error_Msg_N ("invalid mode selector", Mode);
2274 -- Items in a moded list appear as a collection of
2275 -- expressions. Reuse the existing machinery to analyze
2279 (List => Expression (Assoc),
2280 Global_Mode => Chars (Mode));
2288 raise Program_Error;
2291 -- Any other attempt to declare a global item is erroneous
2294 Error_Msg_N ("malformed global list", List);
2296 end Analyze_Global_List;
2300 Items : constant Node_Id :=
2301 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
2302 Subp_Decl : Node_Id;
2304 Restore_Scope : Boolean := False;
2305 -- Set True if we do a Push_Scope requiring a Pop_Scope on exit
2307 -- Start of processing for Analyze_Global_In_Decl_List
2311 Check_SPARK_Aspect_For_ASIS (N);
2313 -- Verify the syntax of pragma Global when SPARK checks are suppressed.
2314 -- Semantic analysis is disabled in this mode.
2316 if SPARK_Mode = Off then
2317 Check_Global_List_Syntax (Items);
2321 Subp_Decl := Find_Related_Subprogram_Or_Body (N);
2322 Subp_Id := Defining_Entity (Subp_Decl);
2324 -- The logic in this routine is used to analyze both pragma Global and
2325 -- pragma Refined_Global since they have the same syntax and base
2326 -- semantics. Find the entity of the corresponding spec when analyzing
2329 if Nkind (Subp_Decl) = N_Subprogram_Body
2330 and then not Acts_As_Spec (Subp_Decl)
2332 Spec_Id := Corresponding_Spec (Subp_Decl);
2334 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub then
2335 Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl);
2341 -- There is nothing to be done for a null global list
2343 if Nkind (Items) = N_Null then
2344 Set_Analyzed (Items);
2346 -- Analyze the various forms of global lists and items. Note that some
2347 -- of these may be malformed in which case the analysis emits error
2351 -- Ensure that the formal parameters are visible when processing an
2352 -- item. This falls out of the general rule of aspects pertaining to
2353 -- subprogram declarations.
2355 if not In_Open_Scopes (Spec_Id) then
2356 Restore_Scope := True;
2357 Push_Scope (Spec_Id);
2358 Install_Formals (Spec_Id);
2361 Analyze_Global_List (Items);
2363 if Restore_Scope then
2368 -- Ensure that a state and a corresponding constituent do not appear
2369 -- together in pragma [Refined_]Global.
2371 Check_State_And_Constituent_Use
2372 (States => States_Seen,
2373 Constits => Constits_Seen,
2375 end Analyze_Global_In_Decl_Part;
2377 --------------------------------------------
2378 -- Analyze_Initial_Condition_In_Decl_Part --
2379 --------------------------------------------
2381 procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is
2382 Expr : constant Node_Id :=
2383 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
2388 -- The expression is preanalyzed because it has not been moved to its
2389 -- final place yet. A direct analysis may generate side effects and this
2390 -- is not desired at this point.
2392 Preanalyze_And_Resolve (Expr, Standard_Boolean);
2393 end Analyze_Initial_Condition_In_Decl_Part;
2395 --------------------------------------
2396 -- Analyze_Initializes_In_Decl_Part --
2397 --------------------------------------
2399 procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is
2400 Pack_Spec : constant Node_Id := Parent (N);
2401 Pack_Id : constant Entity_Id := Defining_Entity (Parent (Pack_Spec));
2403 Constits_Seen : Elist_Id := No_Elist;
2404 -- A list containing the entities of all constituents processed so far.
2405 -- It aids in detecting illegal usage of a state and a corresponding
2406 -- constituent in pragma Initializes.
2408 Items_Seen : Elist_Id := No_Elist;
2409 -- A list of all initialization items processed so far. This list is
2410 -- used to detect duplicate items.
2412 Non_Null_Seen : Boolean := False;
2413 Null_Seen : Boolean := False;
2414 -- Flags used to check the legality of a null initialization list
2416 States_And_Vars : Elist_Id := No_Elist;
2417 -- A list of all abstract states and variables declared in the visible
2418 -- declarations of the related package. This list is used to detect the
2419 -- legality of initialization items.
2421 States_Seen : Elist_Id := No_Elist;
2422 -- A list containing the entities of all states processed so far. It
2423 -- helps in detecting illegal usage of a state and a corresponding
2424 -- constituent in pragma Initializes.
2426 procedure Analyze_Initialization_Item (Item : Node_Id);
2427 -- Verify the legality of a single initialization item
2429 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id);
2430 -- Verify the legality of a single initialization item followed by a
2431 -- list of input items.
2433 procedure Check_Initialization_List_Syntax (List : Node_Id);
2434 -- Verify the syntax of initialization list List
2436 procedure Collect_States_And_Variables;
2437 -- Inspect the visible declarations of the related package and gather
2438 -- the entities of all abstract states and variables in States_And_Vars.
2440 ---------------------------------
2441 -- Analyze_Initialization_Item --
2442 ---------------------------------
2444 procedure Analyze_Initialization_Item (Item : Node_Id) is
2445 Item_Id : Entity_Id;
2448 -- Null initialization list
2450 if Nkind (Item) = N_Null then
2452 Error_Msg_N ("multiple null initializations not allowed", Item);
2454 elsif Non_Null_Seen then
2456 ("cannot mix null and non-null initialization items", Item);
2461 -- Initialization item
2464 Non_Null_Seen := True;
2468 ("cannot mix null and non-null initialization items", Item);
2472 Resolve_State (Item);
2474 if Is_Entity_Name (Item) then
2475 Item_Id := Entity_Of (Item);
2477 if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
2479 -- The state or variable must be declared in the visible
2480 -- declarations of the package (SPARK RM 7.1.5(7)).
2482 if not Contains (States_And_Vars, Item_Id) then
2483 Error_Msg_Name_1 := Chars (Pack_Id);
2485 ("initialization item & must appear in the visible "
2486 & "declarations of package %", Item, Item_Id);
2488 -- Detect a duplicate use of the same initialization item
2489 -- (SPARK RM 7.1.5(5)).
2491 elsif Contains (Items_Seen, Item_Id) then
2492 Error_Msg_N ("duplicate initialization item", Item);
2494 -- The item is legal, add it to the list of processed states
2498 Add_Item (Item_Id, Items_Seen);
2500 if Ekind (Item_Id) = E_Abstract_State then
2501 Add_Item (Item_Id, States_Seen);
2504 if Present (Encapsulating_State (Item_Id)) then
2505 Add_Item (Item_Id, Constits_Seen);
2509 -- The item references something that is not a state or a
2510 -- variable (SPARK RM 7.1.5(3)).
2514 ("initialization item must denote variable or state",
2518 -- Some form of illegal construct masquerading as a name
2519 -- (SPARK RM 7.1.5(3)).
2523 ("initialization item must denote variable or state", Item);
2526 end Analyze_Initialization_Item;
2528 ---------------------------------------------
2529 -- Analyze_Initialization_Item_With_Inputs --
2530 ---------------------------------------------
2532 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is
2533 Inputs_Seen : Elist_Id := No_Elist;
2534 -- A list of all inputs processed so far. This list is used to detect
2535 -- duplicate uses of an input.
2537 Non_Null_Seen : Boolean := False;
2538 Null_Seen : Boolean := False;
2539 -- Flags used to check the legality of an input list
2541 procedure Analyze_Input_Item (Input : Node_Id);
2542 -- Verify the legality of a single input item
2544 ------------------------
2545 -- Analyze_Input_Item --
2546 ------------------------
2548 procedure Analyze_Input_Item (Input : Node_Id) is
2549 Input_Id : Entity_Id;
2554 if Nkind (Input) = N_Null then
2557 ("multiple null initializations not allowed", Item);
2559 elsif Non_Null_Seen then
2561 ("cannot mix null and non-null initialization item", Item);
2569 Non_Null_Seen := True;
2573 ("cannot mix null and non-null initialization item", Item);
2577 Resolve_State (Input);
2579 if Is_Entity_Name (Input) then
2580 Input_Id := Entity_Of (Input);
2582 if Ekind_In (Input_Id, E_Abstract_State, E_Variable) then
2584 -- The input cannot denote states or variables declared
2585 -- within the related package.
2587 if Within_Scope (Input_Id, Current_Scope) then
2588 Error_Msg_Name_1 := Chars (Pack_Id);
2590 ("input item & cannot denote a visible variable or "
2591 & "state of package % (SPARK RM 7.1.5(4))",
2594 -- Detect a duplicate use of the same input item
2595 -- (SPARK RM 7.1.5(5)).
2597 elsif Contains (Inputs_Seen, Input_Id) then
2598 Error_Msg_N ("duplicate input item", Input);
2600 -- Input is legal, add it to the list of processed inputs
2603 Add_Item (Input_Id, Inputs_Seen);
2605 if Ekind (Input_Id) = E_Abstract_State then
2606 Add_Item (Input_Id, States_Seen);
2609 if Present (Encapsulating_State (Input_Id)) then
2610 Add_Item (Input_Id, Constits_Seen);
2614 -- The input references something that is not a state or a
2619 ("input item must denote variable or state", Input);
2622 -- Some form of illegal construct masquerading as a name
2626 ("input item must denote variable or state", Input);
2629 end Analyze_Input_Item;
2633 Inputs : constant Node_Id := Expression (Item);
2637 Name_Seen : Boolean := False;
2638 -- A flag used to detect multiple item names
2640 -- Start of processing for Analyze_Initialization_Item_With_Inputs
2643 -- Inspect the name of an item with inputs
2645 Elmt := First (Choices (Item));
2646 while Present (Elmt) loop
2648 Error_Msg_N ("only one item allowed in initialization", Elmt);
2651 Analyze_Initialization_Item (Elmt);
2657 -- Multiple input items appear as an aggregate
2659 if Nkind (Inputs) = N_Aggregate then
2660 if Present (Expressions (Inputs)) then
2661 Input := First (Expressions (Inputs));
2662 while Present (Input) loop
2663 Analyze_Input_Item (Input);
2668 if Present (Component_Associations (Inputs)) then
2670 ("inputs must appear in named association form", Inputs);
2673 -- Single input item
2676 Analyze_Input_Item (Inputs);
2678 end Analyze_Initialization_Item_With_Inputs;
2680 --------------------------------------
2681 -- Check_Initialization_List_Syntax --
2682 --------------------------------------
2684 procedure Check_Initialization_List_Syntax (List : Node_Id) is
2689 -- Null initialization list
2691 if Nkind (List) = N_Null then
2694 elsif Nkind (List) = N_Aggregate then
2696 -- Simple initialization items
2698 if Present (Expressions (List)) then
2699 Init := First (Expressions (List));
2700 while Present (Init) loop
2701 Check_Item_Syntax (Init);
2706 -- Initialization items with a input lists
2708 if Present (Component_Associations (List)) then
2709 Init := First (Component_Associations (List));
2710 while Present (Init) loop
2711 Check_Item_Syntax (First (Choices (Init)));
2713 if Nkind (Expression (Init)) = N_Aggregate
2714 and then Present (Expressions (Expression (Init)))
2716 Input := First (Expressions (Expression (Init)));
2717 while Present (Input) loop
2718 Check_Item_Syntax (Input);
2723 Error_Msg_N ("malformed initialization item", Init);
2731 Error_Msg_N ("malformed initialization list", List);
2733 end Check_Initialization_List_Syntax;
2735 ----------------------------------
2736 -- Collect_States_And_Variables --
2737 ----------------------------------
2739 procedure Collect_States_And_Variables is
2743 -- Collect the abstract states defined in the package (if any)
2745 if Present (Abstract_States (Pack_Id)) then
2746 States_And_Vars := New_Copy_Elist (Abstract_States (Pack_Id));
2749 -- Collect all variables the appear in the visible declarations of
2750 -- the related package.
2752 if Present (Visible_Declarations (Pack_Spec)) then
2753 Decl := First (Visible_Declarations (Pack_Spec));
2754 while Present (Decl) loop
2755 if Nkind (Decl) = N_Object_Declaration
2756 and then Ekind (Defining_Entity (Decl)) = E_Variable
2757 and then Comes_From_Source (Decl)
2759 Add_Item (Defining_Entity (Decl), States_And_Vars);
2765 end Collect_States_And_Variables;
2769 Inits : constant Node_Id :=
2770 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
2773 -- Start of processing for Analyze_Initializes_In_Decl_Part
2778 Check_SPARK_Aspect_For_ASIS (N);
2780 -- Nothing to do when the initialization list is empty
2782 if Nkind (Inits) = N_Null then
2785 -- Verify the syntax of pragma Initializes when SPARK checks are
2786 -- suppressed. Semantic analysis is disabled in this mode.
2788 elsif SPARK_Mode = Off then
2789 Check_Initialization_List_Syntax (Inits);
2793 -- Single and multiple initialization clauses appear as an aggregate. If
2794 -- this is not the case, then either the parser or the analysis of the
2795 -- pragma failed to produce an aggregate.
2797 pragma Assert (Nkind (Inits) = N_Aggregate);
2799 -- Initialize the various lists used during analysis
2801 Collect_States_And_Variables;
2803 if Present (Expressions (Inits)) then
2804 Init := First (Expressions (Inits));
2805 while Present (Init) loop
2806 Analyze_Initialization_Item (Init);
2811 if Present (Component_Associations (Inits)) then
2812 Init := First (Component_Associations (Inits));
2813 while Present (Init) loop
2814 Analyze_Initialization_Item_With_Inputs (Init);
2819 -- Ensure that a state and a corresponding constituent do not appear
2820 -- together in pragma Initializes.
2822 Check_State_And_Constituent_Use
2823 (States => States_Seen,
2824 Constits => Constits_Seen,
2826 end Analyze_Initializes_In_Decl_Part;
2828 --------------------
2829 -- Analyze_Pragma --
2830 --------------------
2832 --------------------
2833 -- Analyze_Pragma --
2834 --------------------
2836 procedure Analyze_Pragma (N : Node_Id) is
2837 Loc : constant Source_Ptr := Sloc (N);
2838 Prag_Id : Pragma_Id;
2841 -- Name of the source pragma, or name of the corresponding aspect for
2842 -- pragmas which originate in a source aspect. In the latter case, the
2843 -- name may be different from the pragma name.
2845 Pragma_Exit : exception;
2846 -- This exception is used to exit pragma processing completely. It
2847 -- is used when an error is detected, and no further processing is
2848 -- required. It is also used if an earlier error has left the tree in
2849 -- a state where the pragma should not be processed.
2852 -- Number of pragma argument associations
2858 -- First four pragma arguments (pragma argument association nodes, or
2859 -- Empty if the corresponding argument does not exist).
2861 type Name_List is array (Natural range <>) of Name_Id;
2862 type Args_List is array (Natural range <>) of Node_Id;
2863 -- Types used for arguments to Check_Arg_Order and Gather_Associations
2865 procedure Ada_2005_Pragma;
2866 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
2867 -- Ada 95 mode, these are implementation defined pragmas, so should be
2868 -- caught by the No_Implementation_Pragmas restriction.
2870 procedure Ada_2012_Pragma;
2871 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
2872 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
2873 -- should be caught by the No_Implementation_Pragmas restriction.
2875 procedure Analyze_Part_Of
2876 (Item_Id : Entity_Id;
2879 Legal : out Boolean);
2880 -- Subsidiary to the analysis of pragmas Abstract_State and Part_Of.
2881 -- Perform full analysis of indicator Part_Of. Item_Id is the entity of
2882 -- an abstract state, variable or package instantiation. State is the
2883 -- encapsulating state. Indic is the Part_Of indicator. Flag Legal is
2884 -- set when the indicator is legal.
2886 procedure Analyze_Refined_Pragma
2887 (Spec_Id : out Entity_Id;
2888 Body_Id : out Entity_Id;
2889 Legal : out Boolean);
2890 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
2891 -- Refined_Global and Refined_Post. Check the placement and related
2892 -- context of the pragma. Spec_Id is the entity of the related
2893 -- subprogram. Body_Id is the entity of the subprogram body. Flag
2894 -- Legal is set when the pragma is properly placed.
2896 procedure Check_Ada_83_Warning;
2897 -- Issues a warning message for the current pragma if operating in Ada
2898 -- 83 mode (used for language pragmas that are not a standard part of
2899 -- Ada 83). This procedure does not raise Error_Pragma. Also notes use
2902 procedure Check_Arg_Count (Required : Nat);
2903 -- Check argument count for pragma is equal to given parameter. If not,
2904 -- then issue an error message and raise Pragma_Exit.
2906 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
2907 -- Arg which can either be a pragma argument association, in which case
2908 -- the check is applied to the expression of the association or an
2909 -- expression directly.
2911 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
2912 -- Check that an argument has the right form for an EXTERNAL_NAME
2913 -- parameter of an extended import/export pragma. The rule is that the
2914 -- name must be an identifier or string literal (in Ada 83 mode) or a
2915 -- static string expression (in Ada 95 mode).
2917 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
2918 -- Check the specified argument Arg to make sure that it is an
2919 -- identifier. If not give error and raise Pragma_Exit.
2921 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
2922 -- Check the specified argument Arg to make sure that it is an integer
2923 -- literal. If not give error and raise Pragma_Exit.
2925 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
2926 -- Check the specified argument Arg to make sure that it has the proper
2927 -- syntactic form for a local name and meets the semantic requirements
2928 -- for a local name. The local name is analyzed as part of the
2929 -- processing for this call. In addition, the local name is required
2930 -- to represent an entity at the library level.
2932 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
2933 -- Check the specified argument Arg to make sure that it has the proper
2934 -- syntactic form for a local name and meets the semantic requirements
2935 -- for a local name. The local name is analyzed as part of the
2936 -- processing for this call.
2938 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
2939 -- Check the specified argument Arg to make sure that it is a valid
2940 -- locking policy name. If not give error and raise Pragma_Exit.
2942 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
2943 -- Check the specified argument Arg to make sure that it is a valid
2944 -- elaboration policy name. If not give error and raise Pragma_Exit.
2946 procedure Check_Arg_Is_One_Of
2949 procedure Check_Arg_Is_One_Of
2951 N1, N2, N3 : Name_Id);
2952 procedure Check_Arg_Is_One_Of
2954 N1, N2, N3, N4 : Name_Id);
2955 procedure Check_Arg_Is_One_Of
2957 N1, N2, N3, N4, N5 : Name_Id);
2958 -- Check the specified argument Arg to make sure that it is an
2959 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
2960 -- present). If not then give error and raise Pragma_Exit.
2962 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
2963 -- Check the specified argument Arg to make sure that it is a valid
2964 -- queuing policy name. If not give error and raise Pragma_Exit.
2966 procedure Check_Arg_Is_Static_Expression
2968 Typ : Entity_Id := Empty);
2969 -- Check the specified argument Arg to make sure that it is a static
2970 -- expression of the given type (i.e. it will be analyzed and resolved
2971 -- using this type, which can be any valid argument to Resolve, e.g.
2972 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
2973 -- Typ is left Empty, then any static expression is allowed.
2975 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
2976 -- Check the specified argument Arg to make sure that it is a valid task
2977 -- dispatching policy name. If not give error and raise Pragma_Exit.
2979 procedure Check_Arg_Order (Names : Name_List);
2980 -- Checks for an instance of two arguments with identifiers for the
2981 -- current pragma which are not in the sequence indicated by Names,
2982 -- and if so, generates a fatal message about bad order of arguments.
2984 procedure Check_At_Least_N_Arguments (N : Nat);
2985 -- Check there are at least N arguments present
2987 procedure Check_At_Most_N_Arguments (N : Nat);
2988 -- Check there are no more than N arguments present
2990 procedure Check_Component
2993 In_Variant_Part : Boolean := False);
2994 -- Examine an Unchecked_Union component for correct use of per-object
2995 -- constrained subtypes, and for restrictions on finalizable components.
2996 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
2997 -- should be set when Comp comes from a record variant.
2999 procedure Check_Declaration_Order (First : Node_Id; Second : Node_Id);
3000 -- Subsidiary routine to the analysis of pragmas Abstract_State,
3001 -- Initial_Condition and Initializes. Determine whether pragma First
3002 -- appears before pragma Second. If this is not the case, emit an error.
3004 procedure Check_Duplicate_Pragma (E : Entity_Id);
3005 -- Check if a rep item of the same name as the current pragma is already
3006 -- chained as a rep pragma to the given entity. If so give a message
3007 -- about the duplicate, and then raise Pragma_Exit so does not return.
3008 -- Note that if E is a type, then this routine avoids flagging a pragma
3009 -- which applies to a parent type from which E is derived.
3011 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
3012 -- Nam is an N_String_Literal node containing the external name set by
3013 -- an Import or Export pragma (or extended Import or Export pragma).
3014 -- This procedure checks for possible duplications if this is the export
3015 -- case, and if found, issues an appropriate error message.
3017 procedure Check_Expr_Is_Static_Expression
3019 Typ : Entity_Id := Empty);
3020 -- Check the specified expression Expr to make sure that it is a static
3021 -- expression of the given type (i.e. it will be analyzed and resolved
3022 -- using this type, which can be any valid argument to Resolve, e.g.
3023 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3024 -- Typ is left Empty, then any static expression is allowed.
3026 procedure Check_First_Subtype (Arg : Node_Id);
3027 -- Checks that Arg, whose expression is an entity name, references a
3030 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
3031 -- Checks that the given argument has an identifier, and if so, requires
3032 -- it to match the given identifier name. If there is no identifier, or
3033 -- a non-matching identifier, then an error message is given and
3034 -- Pragma_Exit is raised.
3036 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
3037 -- Checks that the given argument has an identifier, and if so, requires
3038 -- it to match one of the given identifier names. If there is no
3039 -- identifier, or a non-matching identifier, then an error message is
3040 -- given and Pragma_Exit is raised.
3042 procedure Check_In_Main_Program;
3043 -- Common checks for pragmas that appear within a main program
3044 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3046 procedure Check_Interrupt_Or_Attach_Handler;
3047 -- Common processing for first argument of pragma Interrupt_Handler or
3048 -- pragma Attach_Handler.
3050 procedure Check_Loop_Pragma_Placement;
3051 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3052 -- appear immediately within a construct restricted to loops, and that
3053 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
3055 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
3056 -- Check that pragma appears in a declarative part, or in a package
3057 -- specification, i.e. that it does not occur in a statement sequence
3060 procedure Check_No_Identifier (Arg : Node_Id);
3061 -- Checks that the given argument does not have an identifier. If
3062 -- an identifier is present, then an error message is issued, and
3063 -- Pragma_Exit is raised.
3065 procedure Check_No_Identifiers;
3066 -- Checks that none of the arguments to the pragma has an identifier.
3067 -- If any argument has an identifier, then an error message is issued,
3068 -- and Pragma_Exit is raised.
3070 procedure Check_No_Link_Name;
3071 -- Checks that no link name is specified
3073 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
3074 -- Checks if the given argument has an identifier, and if so, requires
3075 -- it to match the given identifier name. If there is a non-matching
3076 -- identifier, then an error message is given and Pragma_Exit is raised.
3078 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
3079 -- Checks if the given argument has an identifier, and if so, requires
3080 -- it to match the given identifier name. If there is a non-matching
3081 -- identifier, then an error message is given and Pragma_Exit is raised.
3082 -- In this version of the procedure, the identifier name is given as
3083 -- a string with lower case letters.
3085 procedure Check_Pre_Post;
3086 -- Called to perform checks for Pre, Pre_Class, Post, Post_Class
3087 -- pragmas. These are processed by transformation to equivalent
3088 -- Precondition and Postcondition pragmas, but Pre and Post need an
3089 -- additional check that they are not used in a subprogram body when
3090 -- there is a separate spec present.
3092 procedure Check_Precondition_Postcondition (In_Body : out Boolean);
3093 -- Called to process a precondition or postcondition pragma. There are
3096 -- The pragma appears after a subprogram spec
3098 -- If the corresponding check is not enabled, the pragma is analyzed
3099 -- but otherwise ignored and control returns with In_Body set False.
3101 -- If the check is enabled, then the first step is to analyze the
3102 -- pragma, but this is skipped if the subprogram spec appears within
3103 -- a package specification (because this is the case where we delay
3104 -- analysis till the end of the spec). Then (whether or not it was
3105 -- analyzed), the pragma is chained to the subprogram in question
3106 -- (using Pre_Post_Conditions and Next_Pragma) and control returns
3107 -- to the caller with In_Body set False.
3109 -- The pragma appears at the start of subprogram body declarations
3111 -- In this case an immediate return to the caller is made with
3112 -- In_Body set True, and the pragma is NOT analyzed.
3114 -- In all other cases, an error message for bad placement is given
3116 procedure Check_Static_Constraint (Constr : Node_Id);
3117 -- Constr is a constraint from an N_Subtype_Indication node from a
3118 -- component constraint in an Unchecked_Union type. This routine checks
3119 -- that the constraint is static as required by the restrictions for
3122 procedure Check_Test_Case;
3123 -- Called to process a test-case pragma. It starts with checking pragma
3124 -- arguments, and the rest of the treatment is similar to the one for
3125 -- pre- and postcondition in Check_Precondition_Postcondition, except
3126 -- the placement rules for the test-case pragma are stricter. These
3127 -- pragmas may only occur after a subprogram spec declared directly
3128 -- in a package spec unit. In this case, the pragma is chained to the
3129 -- subprogram in question (using Contract_Test_Cases and Next_Pragma)
3130 -- and analysis of the pragma is delayed till the end of the spec. In
3131 -- all other cases, an error message for bad placement is given.
3133 procedure Check_Valid_Configuration_Pragma;
3134 -- Legality checks for placement of a configuration pragma
3136 procedure Check_Valid_Library_Unit_Pragma;
3137 -- Legality checks for library unit pragmas. A special case arises for
3138 -- pragmas in generic instances that come from copies of the original
3139 -- library unit pragmas in the generic templates. In the case of other
3140 -- than library level instantiations these can appear in contexts which
3141 -- would normally be invalid (they only apply to the original template
3142 -- and to library level instantiations), and they are simply ignored,
3143 -- which is implemented by rewriting them as null statements.
3145 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
3146 -- Check an Unchecked_Union variant for lack of nested variants and
3147 -- presence of at least one component. UU_Typ is the related Unchecked_
3150 procedure Ensure_Aggregate_Form (Arg : Node_Id);
3151 -- Subsidiary routine to the processing of pragmas Abstract_State,
3152 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
3153 -- Refined_Global and Refined_State. Transform argument Arg into an
3154 -- aggregate if not one already. N_Null is never transformed.
3156 procedure Error_Pragma (Msg : String);
3157 pragma No_Return (Error_Pragma);
3158 -- Outputs error message for current pragma. The message contains a %
3159 -- that will be replaced with the pragma name, and the flag is placed
3160 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
3161 -- calls Fix_Error (see spec of that procedure for details).
3163 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
3164 pragma No_Return (Error_Pragma_Arg);
3165 -- Outputs error message for current pragma. The message may contain
3166 -- a % that will be replaced with the pragma name. The parameter Arg
3167 -- may either be a pragma argument association, in which case the flag
3168 -- is placed on the expression of this association, or an expression,
3169 -- in which case the flag is placed directly on the expression. The
3170 -- message is placed using Error_Msg_N, so the message may also contain
3171 -- an & insertion character which will reference the given Arg value.
3172 -- After placing the message, Pragma_Exit is raised. Note: this routine
3173 -- calls Fix_Error (see spec of that procedure for details).
3175 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
3176 pragma No_Return (Error_Pragma_Arg);
3177 -- Similar to above form of Error_Pragma_Arg except that two messages
3178 -- are provided, the second is a continuation comment starting with \.
3180 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
3181 pragma No_Return (Error_Pragma_Arg_Ident);
3182 -- Outputs error message for current pragma. The message may contain a %
3183 -- that will be replaced with the pragma name. The parameter Arg must be
3184 -- a pragma argument association with a non-empty identifier (i.e. its
3185 -- Chars field must be set), and the error message is placed on the
3186 -- identifier. The message is placed using Error_Msg_N so the message
3187 -- may also contain an & insertion character which will reference
3188 -- the identifier. After placing the message, Pragma_Exit is raised.
3189 -- Note: this routine calls Fix_Error (see spec of that procedure for
3192 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
3193 pragma No_Return (Error_Pragma_Ref);
3194 -- Outputs error message for current pragma. The message may contain
3195 -- a % that will be replaced with the pragma name. The parameter Ref
3196 -- must be an entity whose name can be referenced by & and sloc by #.
3197 -- After placing the message, Pragma_Exit is raised. Note: this routine
3198 -- calls Fix_Error (see spec of that procedure for details).
3200 function Find_Lib_Unit_Name return Entity_Id;
3201 -- Used for a library unit pragma to find the entity to which the
3202 -- library unit pragma applies, returns the entity found.
3204 procedure Find_Program_Unit_Name (Id : Node_Id);
3205 -- If the pragma is a compilation unit pragma, the id must denote the
3206 -- compilation unit in the same compilation, and the pragma must appear
3207 -- in the list of preceding or trailing pragmas. If it is a program
3208 -- unit pragma that is not a compilation unit pragma, then the
3209 -- identifier must be visible.
3211 function Find_Unique_Parameterless_Procedure
3213 Arg : Node_Id) return Entity_Id;
3214 -- Used for a procedure pragma to find the unique parameterless
3215 -- procedure identified by Name, returns it if it exists, otherwise
3216 -- errors out and uses Arg as the pragma argument for the message.
3218 procedure Fix_Error (Msg : in out String);
3219 -- This is called prior to issuing an error message. Msg is a string
3220 -- that typically contains the substring "pragma". If the pragma comes
3221 -- from an aspect, each such "pragma" substring is replaced with the
3222 -- characters "aspect", and Error_Msg_Name_1 is set to the name of the
3223 -- aspect (which may be different from the pragma name). If the current
3224 -- pragma results from rewriting another pragma, then Error_Msg_Name_1
3225 -- is set to the original pragma name.
3227 procedure Gather_Associations
3229 Args : out Args_List);
3230 -- This procedure is used to gather the arguments for a pragma that
3231 -- permits arbitrary ordering of parameters using the normal rules
3232 -- for named and positional parameters. The Names argument is a list
3233 -- of Name_Id values that corresponds to the allowed pragma argument
3234 -- association identifiers in order. The result returned in Args is
3235 -- a list of corresponding expressions that are the pragma arguments.
3236 -- Note that this is a list of expressions, not of pragma argument
3237 -- associations (Gather_Associations has completely checked all the
3238 -- optional identifiers when it returns). An entry in Args is Empty
3239 -- on return if the corresponding argument is not present.
3241 procedure GNAT_Pragma;
3242 -- Called for all GNAT defined pragmas to check the relevant restriction
3243 -- (No_Implementation_Pragmas).
3245 function Is_Before_First_Decl
3246 (Pragma_Node : Node_Id;
3247 Decls : List_Id) return Boolean;
3248 -- Return True if Pragma_Node is before the first declarative item in
3249 -- Decls where Decls is the list of declarative items.
3251 function Is_Configuration_Pragma return Boolean;
3252 -- Determines if the placement of the current pragma is appropriate
3253 -- for a configuration pragma.
3255 function Is_In_Context_Clause return Boolean;
3256 -- Returns True if pragma appears within the context clause of a unit,
3257 -- and False for any other placement (does not generate any messages).
3259 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
3260 -- Analyzes the argument, and determines if it is a static string
3261 -- expression, returns True if so, False if non-static or not String.
3263 procedure Pragma_Misplaced;
3264 pragma No_Return (Pragma_Misplaced);
3265 -- Issue fatal error message for misplaced pragma
3267 procedure Process_Atomic_Shared_Volatile;
3268 -- Common processing for pragmas Atomic, Shared, Volatile. Note that
3269 -- Shared is an obsolete Ada 83 pragma, treated as being identical
3270 -- in effect to pragma Atomic.
3272 procedure Process_Compile_Time_Warning_Or_Error;
3273 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3275 procedure Process_Convention
3276 (C : out Convention_Id;
3277 Ent : out Entity_Id);
3278 -- Common processing for Convention, Interface, Import and Export.
3279 -- Checks first two arguments of pragma, and sets the appropriate
3280 -- convention value in the specified entity or entities. On return
3281 -- C is the convention, Ent is the referenced entity.
3283 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
3284 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3285 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3287 procedure Process_Extended_Import_Export_Exception_Pragma
3288 (Arg_Internal : Node_Id;
3289 Arg_External : Node_Id;
3291 Arg_Code : Node_Id);
3292 -- Common processing for the pragmas Import/Export_Exception. The three
3293 -- arguments correspond to the three named parameters of the pragma. An
3294 -- argument is empty if the corresponding parameter is not present in
3297 procedure Process_Extended_Import_Export_Object_Pragma
3298 (Arg_Internal : Node_Id;
3299 Arg_External : Node_Id;
3300 Arg_Size : Node_Id);
3301 -- Common processing for the pragmas Import/Export_Object. The three
3302 -- arguments correspond to the three named parameters of the pragmas. An
3303 -- argument is empty if the corresponding parameter is not present in
3306 procedure Process_Extended_Import_Export_Internal_Arg
3307 (Arg_Internal : Node_Id := Empty);
3308 -- Common processing for all extended Import and Export pragmas. The
3309 -- argument is the pragma parameter for the Internal argument. If
3310 -- Arg_Internal is empty or inappropriate, an error message is posted.
3311 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
3312 -- set to identify the referenced entity.
3314 procedure Process_Extended_Import_Export_Subprogram_Pragma
3315 (Arg_Internal : Node_Id;
3316 Arg_External : Node_Id;
3317 Arg_Parameter_Types : Node_Id;
3318 Arg_Result_Type : Node_Id := Empty;
3319 Arg_Mechanism : Node_Id;
3320 Arg_Result_Mechanism : Node_Id := Empty;
3321 Arg_First_Optional_Parameter : Node_Id := Empty);
3322 -- Common processing for all extended Import and Export pragmas applying
3323 -- to subprograms. The caller omits any arguments that do not apply to
3324 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3325 -- only in the Import_Function and Export_Function cases). The argument
3326 -- names correspond to the allowed pragma association identifiers.
3328 procedure Process_Generic_List;
3329 -- Common processing for Share_Generic and Inline_Generic
3331 procedure Process_Import_Or_Interface;
3332 -- Common processing for Import of Interface
3334 procedure Process_Import_Predefined_Type;
3335 -- Processing for completing a type with pragma Import. This is used
3336 -- to declare types that match predefined C types, especially for cases
3337 -- without corresponding Ada predefined type.
3339 type Inline_Status is (Suppressed, Disabled, Enabled);
3340 -- Inline status of a subprogram, indicated as follows:
3341 -- Suppressed: inlining is suppressed for the subprogram
3342 -- Disabled: no inlining is requested for the subprogram
3343 -- Enabled: inlining is requested/required for the subprogram
3345 procedure Process_Inline (Status : Inline_Status);
3346 -- Common processing for Inline, Inline_Always and No_Inline. Parameter
3347 -- indicates the inline status specified by the pragma.
3349 procedure Process_Interface_Name
3350 (Subprogram_Def : Entity_Id;
3352 Link_Arg : Node_Id);
3353 -- Given the last two arguments of pragma Import, pragma Export, or
3354 -- pragma Interface_Name, performs validity checks and sets the
3355 -- Interface_Name field of the given subprogram entity to the
3356 -- appropriate external or link name, depending on the arguments given.
3357 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3358 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3359 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3360 -- nor Link_Arg is present, the interface name is set to the default
3361 -- from the subprogram name.
3363 procedure Process_Interrupt_Or_Attach_Handler;
3364 -- Common processing for Interrupt and Attach_Handler pragmas
3366 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
3367 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3368 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3369 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3370 -- is not set in the Restrictions case.
3372 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
3373 -- Common processing for Suppress and Unsuppress. The boolean parameter
3374 -- Suppress_Case is True for the Suppress case, and False for the
3377 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
3378 -- This procedure sets the Is_Exported flag for the given entity,
3379 -- checking that the entity was not previously imported. Arg is
3380 -- the argument that specified the entity. A check is also made
3381 -- for exporting inappropriate entities.
3383 procedure Set_Extended_Import_Export_External_Name
3384 (Internal_Ent : Entity_Id;
3385 Arg_External : Node_Id);
3386 -- Common processing for all extended import export pragmas. The first
3387 -- argument, Internal_Ent, is the internal entity, which has already
3388 -- been checked for validity by the caller. Arg_External is from the
3389 -- Import or Export pragma, and may be null if no External parameter
3390 -- was present. If Arg_External is present and is a non-null string
3391 -- (a null string is treated as the default), then the Interface_Name
3392 -- field of Internal_Ent is set appropriately.
3394 procedure Set_Imported (E : Entity_Id);
3395 -- This procedure sets the Is_Imported flag for the given entity,
3396 -- checking that it is not previously exported or imported.
3398 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
3399 -- Mech is a parameter passing mechanism (see Import_Function syntax
3400 -- for MECHANISM_NAME). This routine checks that the mechanism argument
3401 -- has the right form, and if not issues an error message. If the
3402 -- argument has the right form then the Mechanism field of Ent is
3403 -- set appropriately.
3405 procedure Set_Rational_Profile;
3406 -- Activate the set of configuration pragmas and permissions that make
3407 -- up the Rational profile.
3409 procedure Set_Ravenscar_Profile (N : Node_Id);
3410 -- Activate the set of configuration pragmas and restrictions that make
3411 -- up the Ravenscar Profile. N is the corresponding pragma node, which
3412 -- is used for error messages on any constructs that violate the
3415 ---------------------
3416 -- Ada_2005_Pragma --
3417 ---------------------
3419 procedure Ada_2005_Pragma is
3421 if Ada_Version <= Ada_95 then
3422 Check_Restriction (No_Implementation_Pragmas, N);
3424 end Ada_2005_Pragma;
3426 ---------------------
3427 -- Ada_2012_Pragma --
3428 ---------------------
3430 procedure Ada_2012_Pragma is
3432 if Ada_Version <= Ada_2005 then
3433 Check_Restriction (No_Implementation_Pragmas, N);
3435 end Ada_2012_Pragma;
3437 ---------------------
3438 -- Analyze_Part_Of --
3439 ---------------------
3441 procedure Analyze_Part_Of
3442 (Item_Id : Entity_Id;
3445 Legal : out Boolean)
3447 Pack_Id : Entity_Id;
3448 Placement : State_Space_Kind;
3449 State_Id : Entity_Id;
3452 -- Assume that the pragma/option is illegal
3456 -- Verify the syntax of the encapsulating state when SPARK check are
3457 -- suppressed. Semantic analysis is disabled in this mode.
3459 if SPARK_Mode = Off then
3460 Check_Item_Syntax (State);
3465 Resolve_State (State);
3467 if Is_Entity_Name (State)
3468 and then Ekind (Entity (State)) = E_Abstract_State
3470 State_Id := Entity (State);
3474 ("indicator Part_Of must denote an abstract state", State);
3478 -- Determine where the state, variable or the package instantiation
3479 -- lives with respect to the enclosing packages or package bodies (if
3480 -- any). This placement dictates the legality of the encapsulating
3483 Find_Placement_In_State_Space
3484 (Item_Id => Item_Id,
3485 Placement => Placement,
3486 Pack_Id => Pack_Id);
3488 -- The item appears in a non-package construct with a declarative
3489 -- part (subprogram, block, etc). As such, the item is not allowed
3490 -- to be a part of an encapsulating state because the item is not
3493 if Placement = Not_In_Package then
3495 ("indicator Part_Of cannot appear in this context "
3496 & "(SPARK RM 7.2.6(5))", Indic);
3497 Error_Msg_Name_1 := Chars (Scope (State_Id));
3499 ("\& is not part of the hidden state of package %",
3502 -- The item appears in the visible state space of some package. In
3503 -- general this scenario does not warrant Part_Of except when the
3504 -- package is a private child unit and the encapsulating state is
3505 -- declared in a parent unit or a public descendant of that parent
3508 elsif Placement = Visible_State_Space then
3509 if Is_Child_Unit (Pack_Id)
3510 and then Is_Private_Descendant (Pack_Id)
3512 if not Is_Child_Or_Sibling (Pack_Id, Scope (State_Id)) then
3514 ("indicator Part_Of must denote an abstract state of "
3515 & "parent unit or descendant (SPARK RM 7.2.6(3))", Indic);
3517 -- If the unit is a public child of a private unit it cannot
3518 -- refine the state of a private parent, only that of a
3519 -- public ancestor or descendant thereof.
3521 elsif not Private_Present
3522 (Parent (Unit_Declaration_Node (Pack_Id)))
3523 and then Is_Private_Descendant (Scope (State_Id))
3526 ("indicator Part_Of must denote the abstract state of "
3527 & "a public ancestor", State);
3530 -- Indicator Part_Of is not needed when the related package is not
3531 -- a private child unit or a public descendant thereof.
3535 ("indicator Part_Of cannot appear in this context (SPARK "
3536 & "RM 7.2.6(5))", Indic);
3537 Error_Msg_Name_1 := Chars (Pack_Id);
3539 ("\& is declared in the visible part of package %",
3543 -- When the item appears in the private state space of a package, the
3544 -- encapsulating state must be declared in the same package.
3546 elsif Placement = Private_State_Space then
3547 if Scope (State_Id) /= Pack_Id then
3549 ("indicator Part_Of must designate an abstract state of "
3550 & "package & (SPARK RM 7.2.6(2))", Indic, Pack_Id);
3551 Error_Msg_Name_1 := Chars (Pack_Id);
3553 ("\& is declared in the private part of package %",
3557 -- Items declared in the body state space of a package do not need
3558 -- Part_Of indicators as the refinement has already been seen.
3562 ("indicator Part_Of cannot appear in this context "
3563 & "(SPARK RM 7.2.6(5))", Indic);
3565 if Scope (State_Id) = Pack_Id then
3566 Error_Msg_Name_1 := Chars (Pack_Id);
3568 ("\& is declared in the body of package %", Indic, Item_Id);
3573 end Analyze_Part_Of;
3575 ----------------------------
3576 -- Analyze_Refined_Pragma --
3577 ----------------------------
3579 procedure Analyze_Refined_Pragma
3580 (Spec_Id : out Entity_Id;
3581 Body_Id : out Entity_Id;
3582 Legal : out Boolean)
3584 Body_Decl : Node_Id;
3585 Spec_Decl : Node_Id;
3588 -- Assume that the pragma is illegal
3595 Check_Arg_Count (1);
3596 Check_No_Identifiers;
3598 if Nam_In (Pname, Name_Refined_Depends,
3599 Name_Refined_Global,
3602 Ensure_Aggregate_Form (Arg1);
3605 -- Verify the placement of the pragma and check for duplicates. The
3606 -- pragma must apply to a subprogram body [stub].
3608 Body_Decl := Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
3610 -- Extract the entities of the spec and body
3612 if Nkind (Body_Decl) = N_Subprogram_Body then
3613 Body_Id := Defining_Entity (Body_Decl);
3614 Spec_Id := Corresponding_Spec (Body_Decl);
3616 elsif Nkind (Body_Decl) = N_Subprogram_Body_Stub then
3617 Body_Id := Defining_Entity (Body_Decl);
3618 Spec_Id := Corresponding_Spec_Of_Stub (Body_Decl);
3625 -- The pragma must apply to the second declaration of a subprogram.
3626 -- In other words, the body [stub] cannot acts as a spec.
3628 if No (Spec_Id) then
3629 Error_Pragma ("pragma % cannot apply to a stand alone body");
3632 -- Catch the case where the subprogram body is a subunit and acts as
3633 -- the third declaration of the subprogram.
3635 elsif Nkind (Parent (Body_Decl)) = N_Subunit then
3636 Error_Pragma ("pragma % cannot apply to a subunit");
3640 -- The pragma can only apply to the body [stub] of a subprogram
3641 -- declared in the visible part of a package. Retrieve the context of
3642 -- the subprogram declaration.
3644 Spec_Decl := Parent (Parent (Spec_Id));
3646 if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then
3648 ("pragma % must apply to the body of a subprogram declared in a "
3649 & "package specification");
3653 -- If we get here, then the pragma is legal
3656 end Analyze_Refined_Pragma;
3658 --------------------------
3659 -- Check_Ada_83_Warning --
3660 --------------------------
3662 procedure Check_Ada_83_Warning is
3664 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
3665 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
3667 end Check_Ada_83_Warning;
3669 ---------------------
3670 -- Check_Arg_Count --
3671 ---------------------
3673 procedure Check_Arg_Count (Required : Nat) is
3675 if Arg_Count /= Required then
3676 Error_Pragma ("wrong number of arguments for pragma%");
3678 end Check_Arg_Count;
3680 --------------------------------
3681 -- Check_Arg_Is_External_Name --
3682 --------------------------------
3684 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
3685 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3688 if Nkind (Argx) = N_Identifier then
3692 Analyze_And_Resolve (Argx, Standard_String);
3694 if Is_OK_Static_Expression (Argx) then
3697 elsif Etype (Argx) = Any_Type then
3700 -- An interesting special case, if we have a string literal and
3701 -- we are in Ada 83 mode, then we allow it even though it will
3702 -- not be flagged as static. This allows expected Ada 83 mode
3703 -- use of external names which are string literals, even though
3704 -- technically these are not static in Ada 83.
3706 elsif Ada_Version = Ada_83
3707 and then Nkind (Argx) = N_String_Literal
3711 -- Static expression that raises Constraint_Error. This has
3712 -- already been flagged, so just exit from pragma processing.
3714 elsif Is_Static_Expression (Argx) then
3717 -- Here we have a real error (non-static expression)
3720 Error_Msg_Name_1 := Pname;
3724 "argument for pragma% must be a identifier or "
3725 & "static string expression!";
3728 Flag_Non_Static_Expr (Msg, Argx);
3733 end Check_Arg_Is_External_Name;
3735 -----------------------------
3736 -- Check_Arg_Is_Identifier --
3737 -----------------------------
3739 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
3740 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3742 if Nkind (Argx) /= N_Identifier then
3744 ("argument for pragma% must be identifier", Argx);
3746 end Check_Arg_Is_Identifier;
3748 ----------------------------------
3749 -- Check_Arg_Is_Integer_Literal --
3750 ----------------------------------
3752 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
3753 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3755 if Nkind (Argx) /= N_Integer_Literal then
3757 ("argument for pragma% must be integer literal", Argx);
3759 end Check_Arg_Is_Integer_Literal;
3761 -------------------------------------------
3762 -- Check_Arg_Is_Library_Level_Local_Name --
3763 -------------------------------------------
3767 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3768 -- | library_unit_NAME
3770 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
3772 Check_Arg_Is_Local_Name (Arg);
3774 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
3775 and then Comes_From_Source (N)
3778 ("argument for pragma% must be library level entity", Arg);
3780 end Check_Arg_Is_Library_Level_Local_Name;
3782 -----------------------------
3783 -- Check_Arg_Is_Local_Name --
3784 -----------------------------
3788 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3789 -- | library_unit_NAME
3791 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
3792 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3797 if Nkind (Argx) not in N_Direct_Name
3798 and then (Nkind (Argx) /= N_Attribute_Reference
3799 or else Present (Expressions (Argx))
3800 or else Nkind (Prefix (Argx)) /= N_Identifier)
3801 and then (not Is_Entity_Name (Argx)
3802 or else not Is_Compilation_Unit (Entity (Argx)))
3804 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
3807 -- No further check required if not an entity name
3809 if not Is_Entity_Name (Argx) then
3815 Ent : constant Entity_Id := Entity (Argx);
3816 Scop : constant Entity_Id := Scope (Ent);
3819 -- Case of a pragma applied to a compilation unit: pragma must
3820 -- occur immediately after the program unit in the compilation.
3822 if Is_Compilation_Unit (Ent) then
3824 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
3827 -- Case of pragma placed immediately after spec
3829 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
3832 -- Case of pragma placed immediately after body
3834 elsif Nkind (Decl) = N_Subprogram_Declaration
3835 and then Present (Corresponding_Body (Decl))
3839 (Parent (Unit_Declaration_Node
3840 (Corresponding_Body (Decl))));
3842 -- All other cases are illegal
3849 -- Special restricted placement rule from 10.2.1(11.8/2)
3851 elsif Is_Generic_Formal (Ent)
3852 and then Prag_Id = Pragma_Preelaborable_Initialization
3854 OK := List_Containing (N) =
3855 Generic_Formal_Declarations
3856 (Unit_Declaration_Node (Scop));
3858 -- If this is an aspect applied to a subprogram body, the
3859 -- pragma is inserted in its declarative part.
3861 elsif From_Aspect_Specification (N)
3863 Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body
3864 and then Ent = Current_Scope
3868 -- If the aspect is a predicate (possibly others ???) and the
3869 -- context is a record type, this is a discriminant expression
3870 -- within a type declaration, that freezes the predicated
3873 elsif From_Aspect_Specification (N)
3874 and then Prag_Id = Pragma_Predicate
3875 and then Ekind (Current_Scope) = E_Record_Type
3876 and then Scop = Scope (Current_Scope)
3880 -- Default case, just check that the pragma occurs in the scope
3881 -- of the entity denoted by the name.
3884 OK := Current_Scope = Scop;
3889 ("pragma% argument must be in same declarative part", Arg);
3893 end Check_Arg_Is_Local_Name;
3895 ---------------------------------
3896 -- Check_Arg_Is_Locking_Policy --
3897 ---------------------------------
3899 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
3900 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3903 Check_Arg_Is_Identifier (Argx);
3905 if not Is_Locking_Policy_Name (Chars (Argx)) then
3906 Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
3908 end Check_Arg_Is_Locking_Policy;
3910 -----------------------------------------------
3911 -- Check_Arg_Is_Partition_Elaboration_Policy --
3912 -----------------------------------------------
3914 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
3915 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3918 Check_Arg_Is_Identifier (Argx);
3920 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
3922 ("& is not a valid partition elaboration policy name", Argx);
3924 end Check_Arg_Is_Partition_Elaboration_Policy;
3926 -------------------------
3927 -- Check_Arg_Is_One_Of --
3928 -------------------------
3930 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
3931 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3934 Check_Arg_Is_Identifier (Argx);
3936 if not Nam_In (Chars (Argx), N1, N2) then
3937 Error_Msg_Name_2 := N1;
3938 Error_Msg_Name_3 := N2;
3939 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
3941 end Check_Arg_Is_One_Of;
3943 procedure Check_Arg_Is_One_Of
3945 N1, N2, N3 : Name_Id)
3947 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3950 Check_Arg_Is_Identifier (Argx);
3952 if not Nam_In (Chars (Argx), N1, N2, N3) then
3953 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
3955 end Check_Arg_Is_One_Of;
3957 procedure Check_Arg_Is_One_Of
3959 N1, N2, N3, N4 : Name_Id)
3961 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3964 Check_Arg_Is_Identifier (Argx);
3966 if not Nam_In (Chars (Argx), N1, N2, N3, N4) then
3967 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
3969 end Check_Arg_Is_One_Of;
3971 procedure Check_Arg_Is_One_Of
3973 N1, N2, N3, N4, N5 : Name_Id)
3975 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3978 Check_Arg_Is_Identifier (Argx);
3980 if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then
3981 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
3983 end Check_Arg_Is_One_Of;
3985 ---------------------------------
3986 -- Check_Arg_Is_Queuing_Policy --
3987 ---------------------------------
3989 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
3990 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3993 Check_Arg_Is_Identifier (Argx);
3995 if not Is_Queuing_Policy_Name (Chars (Argx)) then
3996 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
3998 end Check_Arg_Is_Queuing_Policy;
4000 ------------------------------------
4001 -- Check_Arg_Is_Static_Expression --
4002 ------------------------------------
4004 procedure Check_Arg_Is_Static_Expression
4006 Typ : Entity_Id := Empty)
4009 Check_Expr_Is_Static_Expression (Get_Pragma_Arg (Arg), Typ);
4010 end Check_Arg_Is_Static_Expression;
4012 ------------------------------------------
4013 -- Check_Arg_Is_Task_Dispatching_Policy --
4014 ------------------------------------------
4016 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
4017 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4020 Check_Arg_Is_Identifier (Argx);
4022 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
4024 ("& is not a valid task dispatching policy name", Argx);
4026 end Check_Arg_Is_Task_Dispatching_Policy;
4028 ---------------------
4029 -- Check_Arg_Order --
4030 ---------------------
4032 procedure Check_Arg_Order (Names : Name_List) is
4035 Highest_So_Far : Natural := 0;
4036 -- Highest index in Names seen do far
4040 for J in 1 .. Arg_Count loop
4041 if Chars (Arg) /= No_Name then
4042 for K in Names'Range loop
4043 if Chars (Arg) = Names (K) then
4044 if K < Highest_So_Far then
4045 Error_Msg_Name_1 := Pname;
4047 ("parameters out of order for pragma%", Arg);
4048 Error_Msg_Name_1 := Names (K);
4049 Error_Msg_Name_2 := Names (Highest_So_Far);
4050 Error_Msg_N ("\% must appear before %", Arg);
4054 Highest_So_Far := K;
4062 end Check_Arg_Order;
4064 --------------------------------
4065 -- Check_At_Least_N_Arguments --
4066 --------------------------------
4068 procedure Check_At_Least_N_Arguments (N : Nat) is
4070 if Arg_Count < N then
4071 Error_Pragma ("too few arguments for pragma%");
4073 end Check_At_Least_N_Arguments;
4075 -------------------------------
4076 -- Check_At_Most_N_Arguments --
4077 -------------------------------
4079 procedure Check_At_Most_N_Arguments (N : Nat) is
4082 if Arg_Count > N then
4084 for J in 1 .. N loop
4086 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
4089 end Check_At_Most_N_Arguments;
4091 ---------------------
4092 -- Check_Component --
4093 ---------------------
4095 procedure Check_Component
4098 In_Variant_Part : Boolean := False)
4100 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
4101 Sindic : constant Node_Id :=
4102 Subtype_Indication (Component_Definition (Comp));
4103 Typ : constant Entity_Id := Etype (Comp_Id);
4106 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
4107 -- object constraint, then the component type shall be an Unchecked_
4110 if Nkind (Sindic) = N_Subtype_Indication
4111 and then Has_Per_Object_Constraint (Comp_Id)
4112 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
4115 ("component subtype subject to per-object constraint "
4116 & "must be an Unchecked_Union", Comp);
4118 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
4119 -- the body of a generic unit, or within the body of any of its
4120 -- descendant library units, no part of the type of a component
4121 -- declared in a variant_part of the unchecked union type shall be of
4122 -- a formal private type or formal private extension declared within
4123 -- the formal part of the generic unit.
4125 elsif Ada_Version >= Ada_2012
4126 and then In_Generic_Body (UU_Typ)
4127 and then In_Variant_Part
4128 and then Is_Private_Type (Typ)
4129 and then Is_Generic_Type (Typ)
4132 ("component of unchecked union cannot be of generic type", Comp);
4134 elsif Needs_Finalization (Typ) then
4136 ("component of unchecked union cannot be controlled", Comp);
4138 elsif Has_Task (Typ) then
4140 ("component of unchecked union cannot have tasks", Comp);
4142 end Check_Component;
4144 -----------------------------
4145 -- Check_Declaration_Order --
4146 -----------------------------
4148 procedure Check_Declaration_Order (First : Node_Id; Second : Node_Id) is
4149 procedure Check_Aspect_Specification_Order;
4150 -- Inspect the aspect specifications of the context to determine the
4153 --------------------------------------
4154 -- Check_Aspect_Specification_Order --
4155 --------------------------------------
4157 procedure Check_Aspect_Specification_Order is
4158 Asp_First : constant Node_Id := Corresponding_Aspect (First);
4159 Asp_Second : constant Node_Id := Corresponding_Aspect (Second);
4163 -- Both aspects must be part of the same aspect specification list
4166 (List_Containing (Asp_First) = List_Containing (Asp_Second));
4168 -- Try to reach Second starting from First in a left to right
4169 -- traversal of the aspect specifications.
4171 Asp := Next (Asp_First);
4172 while Present (Asp) loop
4174 -- The order is ok, First is followed by Second
4176 if Asp = Asp_Second then
4183 -- If we get here, then the aspects are out of order
4185 Error_Msg_N ("aspect % cannot come after aspect %", First);
4186 end Check_Aspect_Specification_Order;
4192 -- Start of processing for Check_Declaration_Order
4195 -- Cannot check the order if one of the pragmas is missing
4197 if No (First) or else No (Second) then
4201 -- Set up the error names in case the order is incorrect
4203 Error_Msg_Name_1 := Pragma_Name (First);
4204 Error_Msg_Name_2 := Pragma_Name (Second);
4206 if From_Aspect_Specification (First) then
4208 -- Both pragmas are actually aspects, check their declaration
4209 -- order in the associated aspect specification list. Otherwise
4210 -- First is an aspect and Second a source pragma.
4212 if From_Aspect_Specification (Second) then
4213 Check_Aspect_Specification_Order;
4216 -- Abstract_States is a source pragma
4219 if From_Aspect_Specification (Second) then
4220 Error_Msg_N ("pragma % cannot come after aspect %", First);
4222 -- Both pragmas are source constructs. Try to reach First from
4223 -- Second by traversing the declarations backwards.
4226 Stmt := Prev (Second);
4227 while Present (Stmt) loop
4229 -- The order is ok, First is followed by Second
4231 if Stmt = First then
4238 -- If we get here, then the pragmas are out of order
4240 Error_Msg_N ("pragma % cannot come after pragma %", First);
4243 end Check_Declaration_Order;
4245 ----------------------------
4246 -- Check_Duplicate_Pragma --
4247 ----------------------------
4249 procedure Check_Duplicate_Pragma (E : Entity_Id) is
4250 Id : Entity_Id := E;
4254 -- Nothing to do if this pragma comes from an aspect specification,
4255 -- since we could not be duplicating a pragma, and we dealt with the
4256 -- case of duplicated aspects in Analyze_Aspect_Specifications.
4258 if From_Aspect_Specification (N) then
4262 -- Otherwise current pragma may duplicate previous pragma or a
4263 -- previously given aspect specification or attribute definition
4264 -- clause for the same pragma.
4266 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
4270 -- If the entity is a type, then we have to make sure that the
4271 -- ostensible duplicate is not for a parent type from which this
4275 if Nkind (P) = N_Pragma then
4277 Args : constant List_Id :=
4278 Pragma_Argument_Associations (P);
4281 and then Is_Entity_Name (Expression (First (Args)))
4282 and then Is_Type (Entity (Expression (First (Args))))
4283 and then Entity (Expression (First (Args))) /= E
4289 elsif Nkind (P) = N_Aspect_Specification
4290 and then Is_Type (Entity (P))
4291 and then Entity (P) /= E
4297 -- Here we have a definite duplicate
4299 Error_Msg_Name_1 := Pragma_Name (N);
4300 Error_Msg_Sloc := Sloc (P);
4302 -- For a single protected or a single task object, the error is
4303 -- issued on the original entity.
4305 if Ekind_In (Id, E_Task_Type, E_Protected_Type) then
4306 Id := Defining_Identifier (Original_Node (Parent (Id)));
4309 if Nkind (P) = N_Aspect_Specification
4310 or else From_Aspect_Specification (P)
4312 Error_Msg_NE ("aspect% for & previously given#", N, Id);
4314 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
4319 end Check_Duplicate_Pragma;
4321 ----------------------------------
4322 -- Check_Duplicated_Export_Name --
4323 ----------------------------------
4325 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
4326 String_Val : constant String_Id := Strval (Nam);
4329 -- We are only interested in the export case, and in the case of
4330 -- generics, it is the instance, not the template, that is the
4331 -- problem (the template will generate a warning in any case).
4333 if not Inside_A_Generic
4334 and then (Prag_Id = Pragma_Export
4336 Prag_Id = Pragma_Export_Procedure
4338 Prag_Id = Pragma_Export_Valued_Procedure
4340 Prag_Id = Pragma_Export_Function)
4342 for J in Externals.First .. Externals.Last loop
4343 if String_Equal (String_Val, Strval (Externals.Table (J))) then
4344 Error_Msg_Sloc := Sloc (Externals.Table (J));
4345 Error_Msg_N ("external name duplicates name given#", Nam);
4350 Externals.Append (Nam);
4352 end Check_Duplicated_Export_Name;
4354 -------------------------------------
4355 -- Check_Expr_Is_Static_Expression --
4356 -------------------------------------
4358 procedure Check_Expr_Is_Static_Expression
4360 Typ : Entity_Id := Empty)
4363 if Present (Typ) then
4364 Analyze_And_Resolve (Expr, Typ);
4366 Analyze_And_Resolve (Expr);
4369 if Is_OK_Static_Expression (Expr) then
4372 elsif Etype (Expr) = Any_Type then
4375 -- An interesting special case, if we have a string literal and we
4376 -- are in Ada 83 mode, then we allow it even though it will not be
4377 -- flagged as static. This allows the use of Ada 95 pragmas like
4378 -- Import in Ada 83 mode. They will of course be flagged with
4379 -- warnings as usual, but will not cause errors.
4381 elsif Ada_Version = Ada_83
4382 and then Nkind (Expr) = N_String_Literal
4386 -- Static expression that raises Constraint_Error. This has already
4387 -- been flagged, so just exit from pragma processing.
4389 elsif Is_Static_Expression (Expr) then
4392 -- Finally, we have a real error
4395 Error_Msg_Name_1 := Pname;
4399 "argument for pragma% must be a static expression!";
4402 Flag_Non_Static_Expr (Msg, Expr);
4407 end Check_Expr_Is_Static_Expression;
4409 -------------------------
4410 -- Check_First_Subtype --
4411 -------------------------
4413 procedure Check_First_Subtype (Arg : Node_Id) is
4414 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4415 Ent : constant Entity_Id := Entity (Argx);
4418 if Is_First_Subtype (Ent) then
4421 elsif Is_Type (Ent) then
4423 ("pragma% cannot apply to subtype", Argx);
4425 elsif Is_Object (Ent) then
4427 ("pragma% cannot apply to object, requires a type", Argx);
4431 ("pragma% cannot apply to&, requires a type", Argx);
4433 end Check_First_Subtype;
4435 ----------------------
4436 -- Check_Identifier --
4437 ----------------------
4439 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
4442 and then Nkind (Arg) = N_Pragma_Argument_Association
4444 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
4445 Error_Msg_Name_1 := Pname;
4446 Error_Msg_Name_2 := Id;
4447 Error_Msg_N ("pragma% argument expects identifier%", Arg);
4451 end Check_Identifier;
4453 --------------------------------
4454 -- Check_Identifier_Is_One_Of --
4455 --------------------------------
4457 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
4460 and then Nkind (Arg) = N_Pragma_Argument_Association
4462 if Chars (Arg) = No_Name then
4463 Error_Msg_Name_1 := Pname;
4464 Error_Msg_N ("pragma% argument expects an identifier", Arg);
4467 elsif Chars (Arg) /= N1
4468 and then Chars (Arg) /= N2
4470 Error_Msg_Name_1 := Pname;
4471 Error_Msg_N ("invalid identifier for pragma% argument", Arg);
4475 end Check_Identifier_Is_One_Of;
4477 ---------------------------
4478 -- Check_In_Main_Program --
4479 ---------------------------
4481 procedure Check_In_Main_Program is
4482 P : constant Node_Id := Parent (N);
4485 -- Must be at in subprogram body
4487 if Nkind (P) /= N_Subprogram_Body then
4488 Error_Pragma ("% pragma allowed only in subprogram");
4490 -- Otherwise warn if obviously not main program
4492 elsif Present (Parameter_Specifications (Specification (P)))
4493 or else not Is_Compilation_Unit (Defining_Entity (P))
4495 Error_Msg_Name_1 := Pname;
4497 ("??pragma% is only effective in main program", N);
4499 end Check_In_Main_Program;
4501 ---------------------------------------
4502 -- Check_Interrupt_Or_Attach_Handler --
4503 ---------------------------------------
4505 procedure Check_Interrupt_Or_Attach_Handler is
4506 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
4507 Handler_Proc, Proc_Scope : Entity_Id;
4512 if Prag_Id = Pragma_Interrupt_Handler then
4513 Check_Restriction (No_Dynamic_Attachment, N);
4516 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
4517 Proc_Scope := Scope (Handler_Proc);
4519 -- On AAMP only, a pragma Interrupt_Handler is supported for
4520 -- nonprotected parameterless procedures.
4522 if not AAMP_On_Target
4523 or else Prag_Id = Pragma_Attach_Handler
4525 if Ekind (Proc_Scope) /= E_Protected_Type then
4527 ("argument of pragma% must be protected procedure", Arg1);
4530 -- For pragma case (as opposed to access case), check placement.
4531 -- We don't need to do that for aspects, because we have the
4532 -- check that they are apply an appropriate procedure.
4534 if not From_Aspect_Specification (N)
4535 and then Parent (N) /= Protected_Definition (Parent (Proc_Scope))
4537 Error_Pragma ("pragma% must be in protected definition");
4541 if not Is_Library_Level_Entity (Proc_Scope)
4542 or else (AAMP_On_Target
4543 and then not Is_Library_Level_Entity (Handler_Proc))
4546 ("argument for pragma% must be library level entity", Arg1);
4549 -- AI05-0033: A pragma cannot appear within a generic body, because
4550 -- instance can be in a nested scope. The check that protected type
4551 -- is itself a library-level declaration is done elsewhere.
4553 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
4554 -- handle code prior to AI-0033. Analysis tools typically are not
4555 -- interested in this pragma in any case, so no need to worry too
4556 -- much about its placement.
4558 if Inside_A_Generic then
4559 if Ekind (Scope (Current_Scope)) = E_Generic_Package
4560 and then In_Package_Body (Scope (Current_Scope))
4561 and then not Relaxed_RM_Semantics
4563 Error_Pragma ("pragma% cannot be used inside a generic");
4566 end Check_Interrupt_Or_Attach_Handler;
4568 ---------------------------------
4569 -- Check_Loop_Pragma_Placement --
4570 ---------------------------------
4572 procedure Check_Loop_Pragma_Placement is
4573 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id);
4574 -- Verify whether the current pragma is properly grouped with other
4575 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
4576 -- related loop where the pragma appears.
4578 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean;
4579 -- Determine whether an arbitrary statement Stmt denotes pragma
4580 -- Loop_Invariant or Loop_Variant.
4582 procedure Placement_Error (Constr : Node_Id);
4583 pragma No_Return (Placement_Error);
4584 -- Node Constr denotes the last loop restricted construct before we
4585 -- encountered an illegal relation between enclosing constructs. Emit
4586 -- an error depending on what Constr was.
4588 --------------------------------
4589 -- Check_Loop_Pragma_Grouping --
4590 --------------------------------
4592 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is
4593 Stop_Search : exception;
4594 -- This exception is used to terminate the recursive descent of
4595 -- routine Check_Grouping.
4597 procedure Check_Grouping (L : List_Id);
4598 -- Find the first group of pragmas in list L and if successful,
4599 -- ensure that the current pragma is part of that group. The
4600 -- routine raises Stop_Search once such a check is performed to
4601 -- halt the recursive descent.
4603 procedure Grouping_Error (Prag : Node_Id);
4604 pragma No_Return (Grouping_Error);
4605 -- Emit an error concerning the current pragma indicating that it
4606 -- should be placed after pragma Prag.
4608 --------------------
4609 -- Check_Grouping --
4610 --------------------
4612 procedure Check_Grouping (L : List_Id) is
4618 -- Inspect the list of declarations or statements looking for
4619 -- the first grouping of pragmas:
4622 -- pragma Loop_Invariant ...;
4623 -- pragma Loop_Variant ...;
4625 -- pragma Loop_Variant ...; -- current pragma
4627 -- If the current pragma is not in the grouping, then it must
4628 -- either appear in a different declarative or statement list
4629 -- or the construct at (1) is separating the pragma from the
4633 while Present (Stmt) loop
4635 -- Pragmas Loop_Invariant and Loop_Variant may only appear
4636 -- inside a loop or a block housed inside a loop. Inspect
4637 -- the declarations and statements of the block as they may
4638 -- contain the first grouping.
4640 if Nkind (Stmt) = N_Block_Statement then
4641 HSS := Handled_Statement_Sequence (Stmt);
4643 Check_Grouping (Declarations (Stmt));
4645 if Present (HSS) then
4646 Check_Grouping (Statements (HSS));
4649 -- First pragma of the first topmost grouping has been found
4651 elsif Is_Loop_Pragma (Stmt) then
4653 -- The group and the current pragma are not in the same
4654 -- declarative or statement list.
4656 if List_Containing (Stmt) /= List_Containing (N) then
4657 Grouping_Error (Stmt);
4659 -- Try to reach the current pragma from the first pragma
4660 -- of the grouping while skipping other members:
4662 -- pragma Loop_Invariant ...; -- first pragma
4663 -- pragma Loop_Variant ...; -- member
4665 -- pragma Loop_Variant ...; -- current pragma
4668 while Present (Stmt) loop
4670 -- The current pragma is either the first pragma
4671 -- of the group or is a member of the group. Stop
4672 -- the search as the placement is legal.
4677 -- Skip group members, but keep track of the last
4678 -- pragma in the group.
4680 elsif Is_Loop_Pragma (Stmt) then
4683 -- A non-pragma is separating the group from the
4684 -- current pragma, the placement is erroneous.
4687 Grouping_Error (Prag);
4693 -- If the traversal did not reach the current pragma,
4694 -- then the list must be malformed.
4696 raise Program_Error;
4704 --------------------
4705 -- Grouping_Error --
4706 --------------------
4708 procedure Grouping_Error (Prag : Node_Id) is
4710 Error_Msg_Sloc := Sloc (Prag);
4711 Error_Pragma ("pragma% must appear next to pragma#");
4714 -- Start of processing for Check_Loop_Pragma_Grouping
4717 -- Inspect the statements of the loop or nested blocks housed
4718 -- within to determine whether the current pragma is part of the
4719 -- first topmost grouping of Loop_Invariant and Loop_Variant.
4721 Check_Grouping (Statements (Loop_Stmt));
4724 when Stop_Search => null;
4725 end Check_Loop_Pragma_Grouping;
4727 --------------------
4728 -- Is_Loop_Pragma --
4729 --------------------
4731 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean is
4733 -- Inspect the original node as Loop_Invariant and Loop_Variant
4734 -- pragmas are rewritten to null when assertions are disabled.
4736 if Nkind (Original_Node (Stmt)) = N_Pragma then
4738 Nam_In (Pragma_Name (Original_Node (Stmt)),
4739 Name_Loop_Invariant,
4746 ---------------------
4747 -- Placement_Error --
4748 ---------------------
4750 procedure Placement_Error (Constr : Node_Id) is
4751 LA : constant String := " with Loop_Entry";
4754 if Prag_Id = Pragma_Assert then
4755 Error_Msg_String (1 .. LA'Length) := LA;
4756 Error_Msg_Strlen := LA'Length;
4758 Error_Msg_Strlen := 0;
4761 if Nkind (Constr) = N_Pragma then
4763 ("pragma %~ must appear immediately within the statements "
4767 ("block containing pragma %~ must appear immediately within "
4768 & "the statements of a loop", Constr);
4770 end Placement_Error;
4772 -- Local declarations
4777 -- Start of processing for Check_Loop_Pragma_Placement
4780 -- Check that pragma appears immediately within a loop statement,
4781 -- ignoring intervening block statements.
4785 while Present (Stmt) loop
4787 -- The pragma or previous block must appear immediately within the
4788 -- current block's declarative or statement part.
4790 if Nkind (Stmt) = N_Block_Statement then
4791 if (No (Declarations (Stmt))
4792 or else List_Containing (Prev) /= Declarations (Stmt))
4794 List_Containing (Prev) /=
4795 Statements (Handled_Statement_Sequence (Stmt))
4797 Placement_Error (Prev);
4800 -- Keep inspecting the parents because we are now within a
4801 -- chain of nested blocks.
4805 Stmt := Parent (Stmt);
4808 -- The pragma or previous block must appear immediately within the
4809 -- statements of the loop.
4811 elsif Nkind (Stmt) = N_Loop_Statement then
4812 if List_Containing (Prev) /= Statements (Stmt) then
4813 Placement_Error (Prev);
4816 -- Stop the traversal because we reached the innermost loop
4817 -- regardless of whether we encountered an error or not.
4821 -- Ignore a handled statement sequence. Note that this node may
4822 -- be related to a subprogram body in which case we will emit an
4823 -- error on the next iteration of the search.
4825 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then
4826 Stmt := Parent (Stmt);
4828 -- Any other statement breaks the chain from the pragma to the
4832 Placement_Error (Prev);
4837 -- Check that the current pragma Loop_Invariant or Loop_Variant is
4838 -- grouped together with other such pragmas.
4840 if Is_Loop_Pragma (N) then
4842 -- The previous check should have located the related loop
4844 pragma Assert (Nkind (Stmt) = N_Loop_Statement);
4845 Check_Loop_Pragma_Grouping (Stmt);
4847 end Check_Loop_Pragma_Placement;
4849 -------------------------------------------
4850 -- Check_Is_In_Decl_Part_Or_Package_Spec --
4851 -------------------------------------------
4853 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
4862 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
4865 elsif Nkind_In (P, N_Package_Specification,
4870 -- Note: the following tests seem a little peculiar, because
4871 -- they test for bodies, but if we were in the statement part
4872 -- of the body, we would already have hit the handled statement
4873 -- sequence, so the only way we get here is by being in the
4874 -- declarative part of the body.
4876 elsif Nkind_In (P, N_Subprogram_Body,
4887 Error_Pragma ("pragma% is not in declarative part or package spec");
4888 end Check_Is_In_Decl_Part_Or_Package_Spec;
4890 -------------------------
4891 -- Check_No_Identifier --
4892 -------------------------
4894 procedure Check_No_Identifier (Arg : Node_Id) is
4896 if Nkind (Arg) = N_Pragma_Argument_Association
4897 and then Chars (Arg) /= No_Name
4899 Error_Pragma_Arg_Ident
4900 ("pragma% does not permit identifier& here", Arg);
4902 end Check_No_Identifier;
4904 --------------------------
4905 -- Check_No_Identifiers --
4906 --------------------------
4908 procedure Check_No_Identifiers is
4912 for J in 1 .. Arg_Count loop
4913 Check_No_Identifier (Arg_Node);
4916 end Check_No_Identifiers;
4918 ------------------------
4919 -- Check_No_Link_Name --
4920 ------------------------
4922 procedure Check_No_Link_Name is
4924 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then
4928 if Present (Arg4) then
4930 ("Link_Name argument not allowed for Import Intrinsic", Arg4);
4932 end Check_No_Link_Name;
4934 -------------------------------
4935 -- Check_Optional_Identifier --
4936 -------------------------------
4938 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
4941 and then Nkind (Arg) = N_Pragma_Argument_Association
4942 and then Chars (Arg) /= No_Name
4944 if Chars (Arg) /= Id then
4945 Error_Msg_Name_1 := Pname;
4946 Error_Msg_Name_2 := Id;
4947 Error_Msg_N ("pragma% argument expects identifier%", Arg);
4951 end Check_Optional_Identifier;
4953 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
4955 Name_Buffer (1 .. Id'Length) := Id;
4956 Name_Len := Id'Length;
4957 Check_Optional_Identifier (Arg, Name_Find);
4958 end Check_Optional_Identifier;
4960 --------------------
4961 -- Check_Pre_Post --
4962 --------------------
4964 procedure Check_Pre_Post is
4969 if not Is_List_Member (N) then
4973 -- If we are within an inlined body, the legality of the pragma
4974 -- has been checked already.
4976 if In_Inlined_Body then
4980 -- Search prior declarations
4983 while Present (Prev (P)) loop
4986 -- If the previous node is a generic subprogram, do not go to to
4987 -- the original node, which is the unanalyzed tree: we need to
4988 -- attach the pre/postconditions to the analyzed version at this
4989 -- point. They get propagated to the original tree when analyzing
4990 -- the corresponding body.
4992 if Nkind (P) not in N_Generic_Declaration then
4993 PO := Original_Node (P);
4998 -- Skip past prior pragma
5000 if Nkind (PO) = N_Pragma then
5003 -- Skip stuff not coming from source
5005 elsif not Comes_From_Source (PO) then
5007 -- The condition may apply to a subprogram instantiation
5009 if Nkind (PO) = N_Subprogram_Declaration
5010 and then Present (Generic_Parent (Specification (PO)))
5014 elsif Nkind (PO) = N_Subprogram_Declaration
5015 and then In_Instance
5019 -- For all other cases of non source code, do nothing
5025 -- Only remaining possibility is subprogram declaration
5032 -- If we fall through loop, pragma is at start of list, so see if it
5033 -- is at the start of declarations of a subprogram body.
5037 if Nkind (PO) = N_Subprogram_Body
5038 and then List_Containing (N) = Declarations (PO)
5040 -- This is only allowed if there is no separate specification
5042 if Present (Corresponding_Spec (PO)) then
5044 ("pragma% must apply to subprogram specification");
5051 --------------------------------------
5052 -- Check_Precondition_Postcondition --
5053 --------------------------------------
5055 procedure Check_Precondition_Postcondition (In_Body : out Boolean) is
5059 procedure Chain_PPC (PO : Node_Id);
5060 -- If PO is an entry or a [generic] subprogram declaration node, then
5061 -- the precondition/postcondition applies to this subprogram and the
5062 -- processing for the pragma is completed. Otherwise the pragma is
5069 procedure Chain_PPC (PO : Node_Id) is
5073 if Nkind (PO) = N_Abstract_Subprogram_Declaration then
5074 if not From_Aspect_Specification (N) then
5076 ("pragma% cannot be applied to abstract subprogram");
5078 elsif Class_Present (N) then
5083 ("aspect % requires ''Class for abstract subprogram");
5086 -- AI05-0230: The same restriction applies to null procedures. For
5087 -- compatibility with earlier uses of the Ada pragma, apply this
5088 -- rule only to aspect specifications.
5090 -- The above discrepency needs documentation. Robert is dubious
5091 -- about whether it is a good idea ???
5093 elsif Nkind (PO) = N_Subprogram_Declaration
5094 and then Nkind (Specification (PO)) = N_Procedure_Specification
5095 and then Null_Present (Specification (PO))
5096 and then From_Aspect_Specification (N)
5097 and then not Class_Present (N)
5100 ("aspect % requires ''Class for null procedure");
5102 -- Pre/postconditions are legal on a subprogram body if it is not
5103 -- a completion of a declaration. They are also legal on a stub
5104 -- with no previous declarations (this is checked when processing
5105 -- the corresponding aspects).
5107 elsif Nkind (PO) = N_Subprogram_Body
5108 and then Acts_As_Spec (PO)
5112 elsif Nkind (PO) = N_Subprogram_Body_Stub then
5115 elsif not Nkind_In (PO, N_Subprogram_Declaration,
5116 N_Expression_Function,
5117 N_Generic_Subprogram_Declaration,
5118 N_Entry_Declaration)
5123 -- Here if we have [generic] subprogram or entry declaration
5125 if Nkind (PO) = N_Entry_Declaration then
5126 S := Defining_Entity (PO);
5128 S := Defining_Unit_Name (Specification (PO));
5130 if Nkind (S) = N_Defining_Program_Unit_Name then
5131 S := Defining_Identifier (S);
5135 -- Note: we do not analyze the pragma at this point. Instead we
5136 -- delay this analysis until the end of the declarative part in
5137 -- which the pragma appears. This implements the required delay
5138 -- in this analysis, allowing forward references. The analysis
5139 -- happens at the end of Analyze_Declarations.
5141 -- Chain spec PPC pragma to list for subprogram
5143 Add_Contract_Item (N, S);
5145 -- Return indicating spec case
5151 -- Start of processing for Check_Precondition_Postcondition
5154 if not Is_List_Member (N) then
5158 -- Preanalyze message argument if present. Visibility in this
5159 -- argument is established at the point of pragma occurrence.
5161 if Arg_Count = 2 then
5162 Check_Optional_Identifier (Arg2, Name_Message);
5163 Preanalyze_Spec_Expression
5164 (Get_Pragma_Arg (Arg2), Standard_String);
5167 -- For a pragma PPC in the extended main source unit, record enabled
5170 if Is_Checked (N) and then not Split_PPC (N) then
5171 Set_SCO_Pragma_Enabled (Loc);
5174 -- If we are within an inlined body, the legality of the pragma
5175 -- has been checked already.
5177 if In_Inlined_Body then
5182 -- Search prior declarations
5185 while Present (Prev (P)) loop
5188 -- If the previous node is a generic subprogram, do not go to to
5189 -- the original node, which is the unanalyzed tree: we need to
5190 -- attach the pre/postconditions to the analyzed version at this
5191 -- point. They get propagated to the original tree when analyzing
5192 -- the corresponding body.
5194 if Nkind (P) not in N_Generic_Declaration then
5195 PO := Original_Node (P);
5200 -- Skip past prior pragma
5202 if Nkind (PO) = N_Pragma then
5205 -- Skip stuff not coming from source
5207 elsif not Comes_From_Source (PO) then
5209 -- The condition may apply to a subprogram instantiation
5211 if Nkind (PO) = N_Subprogram_Declaration
5212 and then Present (Generic_Parent (Specification (PO)))
5217 elsif Nkind (PO) = N_Subprogram_Declaration
5218 and then In_Instance
5223 -- For all other cases of non source code, do nothing
5229 -- Only remaining possibility is subprogram declaration
5237 -- If we fall through loop, pragma is at start of list, so see if it
5238 -- is at the start of declarations of a subprogram body.
5242 if Nkind (PO) = N_Subprogram_Body
5243 and then List_Containing (N) = Declarations (PO)
5245 if Operating_Mode /= Generate_Code or else Inside_A_Generic then
5247 -- Analyze pragma expression for correctness and for ASIS use
5249 Preanalyze_Assert_Expression
5250 (Get_Pragma_Arg (Arg1), Standard_Boolean);
5252 -- In ASIS mode, for a pragma generated from a source aspect,
5253 -- also analyze the original aspect expression.
5255 if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
5256 Preanalyze_Assert_Expression
5257 (Expression (Corresponding_Aspect (N)), Standard_Boolean);
5261 -- Retain copy of the pre/postcondition pragma in GNATprove mode.
5262 -- The copy is needed because the pragma is expanded into other
5263 -- constructs which are not acceptable in the N_Contract node.
5265 if Acts_As_Spec (PO)
5266 and then GNATprove_Mode
5269 Prag : constant Node_Id := New_Copy_Tree (N);
5272 -- Preanalyze the pragma
5274 Preanalyze_Assert_Expression
5276 (First (Pragma_Argument_Associations (Prag))),
5279 -- Preanalyze the corresponding aspect (if any)
5281 if Present (Corresponding_Aspect (Prag)) then
5282 Preanalyze_Assert_Expression
5283 (Expression (Corresponding_Aspect (Prag)),
5287 -- Chain the copy on the contract of the body
5290 (Prag, Defining_Unit_Name (Specification (PO)));
5297 -- See if it is in the pragmas after a library level subprogram
5299 elsif Nkind (PO) = N_Compilation_Unit_Aux then
5301 -- In GNATprove mode, analyze pragma expression for correctness,
5302 -- as it is not expanded later. Ditto in ASIS_Mode where there is
5303 -- no later point at which the aspect will be analyzed.
5305 if GNATprove_Mode or ASIS_Mode then
5306 Analyze_Pre_Post_Condition_In_Decl_Part
5307 (N, Defining_Entity (Unit (Parent (PO))));
5310 Chain_PPC (Unit (Parent (PO)));
5314 -- If we fall through, pragma was misplaced
5317 end Check_Precondition_Postcondition;
5319 -----------------------------
5320 -- Check_Static_Constraint --
5321 -----------------------------
5323 -- Note: for convenience in writing this procedure, in addition to
5324 -- the officially (i.e. by spec) allowed argument which is always a
5325 -- constraint, it also allows ranges and discriminant associations.
5326 -- Above is not clear ???
5328 procedure Check_Static_Constraint (Constr : Node_Id) is
5330 procedure Require_Static (E : Node_Id);
5331 -- Require given expression to be static expression
5333 --------------------
5334 -- Require_Static --
5335 --------------------
5337 procedure Require_Static (E : Node_Id) is
5339 if not Is_OK_Static_Expression (E) then
5340 Flag_Non_Static_Expr
5341 ("non-static constraint not allowed in Unchecked_Union!", E);
5346 -- Start of processing for Check_Static_Constraint
5349 case Nkind (Constr) is
5350 when N_Discriminant_Association =>
5351 Require_Static (Expression (Constr));
5354 Require_Static (Low_Bound (Constr));
5355 Require_Static (High_Bound (Constr));
5357 when N_Attribute_Reference =>
5358 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
5359 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
5361 when N_Range_Constraint =>
5362 Check_Static_Constraint (Range_Expression (Constr));
5364 when N_Index_Or_Discriminant_Constraint =>
5368 IDC := First (Constraints (Constr));
5369 while Present (IDC) loop
5370 Check_Static_Constraint (IDC);
5378 end Check_Static_Constraint;
5380 ---------------------
5381 -- Check_Test_Case --
5382 ---------------------
5384 procedure Check_Test_Case is
5388 procedure Chain_CTC (PO : Node_Id);
5389 -- If PO is a [generic] subprogram declaration node, then the
5390 -- test-case applies to this subprogram and the processing for
5391 -- the pragma is completed. Otherwise the pragma is misplaced.
5397 procedure Chain_CTC (PO : Node_Id) is
5401 if Nkind (PO) = N_Abstract_Subprogram_Declaration then
5403 ("pragma% cannot be applied to abstract subprogram");
5405 elsif Nkind (PO) = N_Entry_Declaration then
5406 Error_Pragma ("pragma% cannot be applied to entry");
5408 elsif not Nkind_In (PO, N_Subprogram_Declaration,
5409 N_Generic_Subprogram_Declaration)
5414 -- Here if we have [generic] subprogram declaration
5416 S := Defining_Unit_Name (Specification (PO));
5418 -- Note: we do not analyze the pragma at this point. Instead we
5419 -- delay this analysis until the end of the declarative part in
5420 -- which the pragma appears. This implements the required delay
5421 -- in this analysis, allowing forward references. The analysis
5422 -- happens at the end of Analyze_Declarations.
5424 -- There should not be another test-case with the same name
5425 -- associated to this subprogram.
5428 Name : constant String_Id := Get_Name_From_CTC_Pragma (N);
5432 CTC := Contract_Test_Cases (Contract (S));
5433 while Present (CTC) loop
5435 -- Omit pragma Contract_Cases because it does not introduce
5436 -- a unique case name and it does not follow the syntax of
5439 if Pragma_Name (CTC) = Name_Contract_Cases then
5443 (Name, Get_Name_From_CTC_Pragma (CTC))
5445 Error_Msg_Sloc := Sloc (CTC);
5446 Error_Pragma ("name for pragma% is already used#");
5449 CTC := Next_Pragma (CTC);
5453 -- Chain spec CTC pragma to list for subprogram
5455 Add_Contract_Item (N, S);
5458 -- Start of processing for Check_Test_Case
5461 -- First check pragma arguments
5463 Check_At_Least_N_Arguments (2);
5464 Check_At_Most_N_Arguments (4);
5466 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
5468 Check_Optional_Identifier (Arg1, Name_Name);
5469 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
5471 -- In ASIS mode, for a pragma generated from a source aspect, also
5472 -- analyze the original aspect expression.
5474 if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
5475 Check_Expr_Is_Static_Expression
5476 (Original_Node (Get_Pragma_Arg (Arg1)), Standard_String);
5479 Check_Optional_Identifier (Arg2, Name_Mode);
5480 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
5482 if Arg_Count = 4 then
5483 Check_Identifier (Arg3, Name_Requires);
5484 Check_Identifier (Arg4, Name_Ensures);
5486 elsif Arg_Count = 3 then
5487 Check_Identifier_Is_One_Of (Arg3, Name_Requires, Name_Ensures);
5490 -- Check pragma placement
5492 if not Is_List_Member (N) then
5496 -- Test-case should only appear in package spec unit
5498 if Get_Source_Unit (N) = No_Unit
5499 or else not Nkind_In (Sinfo.Unit (Cunit (Get_Source_Unit (N))),
5500 N_Package_Declaration,
5501 N_Generic_Package_Declaration)
5506 -- Search prior declarations
5509 while Present (Prev (P)) loop
5512 -- If the previous node is a generic subprogram, do not go to to
5513 -- the original node, which is the unanalyzed tree: we need to
5514 -- attach the test-case to the analyzed version at this point.
5515 -- They get propagated to the original tree when analyzing the
5516 -- corresponding body.
5518 if Nkind (P) not in N_Generic_Declaration then
5519 PO := Original_Node (P);
5524 -- Skip past prior pragma
5526 if Nkind (PO) = N_Pragma then
5529 -- Skip stuff not coming from source
5531 elsif not Comes_From_Source (PO) then
5534 -- Only remaining possibility is subprogram declaration. First
5535 -- check that it is declared directly in a package declaration.
5536 -- This may be either the package declaration for the current unit
5537 -- being defined or a local package declaration.
5539 elsif not Present (Parent (Parent (PO)))
5540 or else not Present (Parent (Parent (Parent (PO))))
5541 or else not Nkind_In (Parent (Parent (PO)),
5542 N_Package_Declaration,
5543 N_Generic_Package_Declaration)
5553 -- If we fall through, pragma was misplaced
5556 end Check_Test_Case;
5558 --------------------------------------
5559 -- Check_Valid_Configuration_Pragma --
5560 --------------------------------------
5562 -- A configuration pragma must appear in the context clause of a
5563 -- compilation unit, and only other pragmas may precede it. Note that
5564 -- the test also allows use in a configuration pragma file.
5566 procedure Check_Valid_Configuration_Pragma is
5568 if not Is_Configuration_Pragma then
5569 Error_Pragma ("incorrect placement for configuration pragma%");
5571 end Check_Valid_Configuration_Pragma;
5573 -------------------------------------
5574 -- Check_Valid_Library_Unit_Pragma --
5575 -------------------------------------
5577 procedure Check_Valid_Library_Unit_Pragma is
5579 Parent_Node : Node_Id;
5580 Unit_Name : Entity_Id;
5581 Unit_Kind : Node_Kind;
5582 Unit_Node : Node_Id;
5583 Sindex : Source_File_Index;
5586 if not Is_List_Member (N) then
5590 Plist := List_Containing (N);
5591 Parent_Node := Parent (Plist);
5593 if Parent_Node = Empty then
5596 -- Case of pragma appearing after a compilation unit. In this case
5597 -- it must have an argument with the corresponding name and must
5598 -- be part of the following pragmas of its parent.
5600 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
5601 if Plist /= Pragmas_After (Parent_Node) then
5604 elsif Arg_Count = 0 then
5606 ("argument required if outside compilation unit");
5609 Check_No_Identifiers;
5610 Check_Arg_Count (1);
5611 Unit_Node := Unit (Parent (Parent_Node));
5612 Unit_Kind := Nkind (Unit_Node);
5614 Analyze (Get_Pragma_Arg (Arg1));
5616 if Unit_Kind = N_Generic_Subprogram_Declaration
5617 or else Unit_Kind = N_Subprogram_Declaration
5619 Unit_Name := Defining_Entity (Unit_Node);
5621 elsif Unit_Kind in N_Generic_Instantiation then
5622 Unit_Name := Defining_Entity (Unit_Node);
5625 Unit_Name := Cunit_Entity (Current_Sem_Unit);
5628 if Chars (Unit_Name) /=
5629 Chars (Entity (Get_Pragma_Arg (Arg1)))
5632 ("pragma% argument is not current unit name", Arg1);
5635 if Ekind (Unit_Name) = E_Package
5636 and then Present (Renamed_Entity (Unit_Name))
5638 Error_Pragma ("pragma% not allowed for renamed package");
5642 -- Pragma appears other than after a compilation unit
5645 -- Here we check for the generic instantiation case and also
5646 -- for the case of processing a generic formal package. We
5647 -- detect these cases by noting that the Sloc on the node
5648 -- does not belong to the current compilation unit.
5650 Sindex := Source_Index (Current_Sem_Unit);
5652 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
5653 Rewrite (N, Make_Null_Statement (Loc));
5656 -- If before first declaration, the pragma applies to the
5657 -- enclosing unit, and the name if present must be this name.
5659 elsif Is_Before_First_Decl (N, Plist) then
5660 Unit_Node := Unit_Declaration_Node (Current_Scope);
5661 Unit_Kind := Nkind (Unit_Node);
5663 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
5666 elsif Unit_Kind = N_Subprogram_Body
5667 and then not Acts_As_Spec (Unit_Node)
5671 elsif Nkind (Parent_Node) = N_Package_Body then
5674 elsif Nkind (Parent_Node) = N_Package_Specification
5675 and then Plist = Private_Declarations (Parent_Node)
5679 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
5680 or else Nkind (Parent_Node) =
5681 N_Generic_Subprogram_Declaration)
5682 and then Plist = Generic_Formal_Declarations (Parent_Node)
5686 elsif Arg_Count > 0 then
5687 Analyze (Get_Pragma_Arg (Arg1));
5689 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
5691 ("name in pragma% must be enclosing unit", Arg1);
5694 -- It is legal to have no argument in this context
5700 -- Error if not before first declaration. This is because a
5701 -- library unit pragma argument must be the name of a library
5702 -- unit (RM 10.1.5(7)), but the only names permitted in this
5703 -- context are (RM 10.1.5(6)) names of subprogram declarations,
5704 -- generic subprogram declarations or generic instantiations.
5708 ("pragma% misplaced, must be before first declaration");
5712 end Check_Valid_Library_Unit_Pragma;
5718 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
5719 Clist : constant Node_Id := Component_List (Variant);
5723 Comp := First (Component_Items (Clist));
5724 while Present (Comp) loop
5725 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
5730 ---------------------------
5731 -- Ensure_Aggregate_Form --
5732 ---------------------------
5734 procedure Ensure_Aggregate_Form (Arg : Node_Id) is
5735 Expr : constant Node_Id := Get_Pragma_Arg (Arg);
5736 Loc : constant Source_Ptr := Sloc (Arg);
5737 Nam : constant Name_Id := Chars (Arg);
5738 Comps : List_Id := No_List;
5739 Exprs : List_Id := No_List;
5742 -- The argument is already in aggregate form, but the presence of a
5743 -- name causes this to be interpreted as a named association which in
5744 -- turn must be converted into an aggregate.
5746 -- pragma Global (In_Out => (A, B, C))
5750 -- pragma Global ((In_Out => (A, B, C)))
5752 -- aggregate aggregate
5754 if Nkind (Expr) = N_Aggregate then
5755 if Nam = No_Name then
5759 -- Do not transform a null argument into an aggregate as N_Null has
5760 -- special meaning in formal verification pragmas.
5762 elsif Nkind (Expr) = N_Null then
5766 -- Positional argument is transformed into an aggregate with an
5767 -- Expressions list.
5769 if Nam = No_Name then
5770 Exprs := New_List (Relocate_Node (Expr));
5772 -- An associative argument is transformed into an aggregate with
5773 -- Component_Associations.
5777 Make_Component_Association (Loc,
5778 Choices => New_List (Make_Identifier (Loc, Chars (Arg))),
5779 Expression => Relocate_Node (Expr)));
5783 -- Remove the pragma argument name as this information has been
5784 -- captured in the aggregate.
5786 Set_Chars (Arg, No_Name);
5788 Set_Expression (Arg,
5789 Make_Aggregate (Loc,
5790 Component_Associations => Comps,
5791 Expressions => Exprs));
5792 end Ensure_Aggregate_Form;
5798 procedure Error_Pragma (Msg : String) is
5799 MsgF : String := Msg;
5801 Error_Msg_Name_1 := Pname;
5803 Error_Msg_N (MsgF, N);
5807 ----------------------
5808 -- Error_Pragma_Arg --
5809 ----------------------
5811 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
5812 MsgF : String := Msg;
5814 Error_Msg_Name_1 := Pname;
5816 Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
5818 end Error_Pragma_Arg;
5820 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
5821 MsgF : String := Msg1;
5823 Error_Msg_Name_1 := Pname;
5825 Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
5826 Error_Pragma_Arg (Msg2, Arg);
5827 end Error_Pragma_Arg;
5829 ----------------------------
5830 -- Error_Pragma_Arg_Ident --
5831 ----------------------------
5833 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
5834 MsgF : String := Msg;
5836 Error_Msg_Name_1 := Pname;
5838 Error_Msg_N (MsgF, Arg);
5840 end Error_Pragma_Arg_Ident;
5842 ----------------------
5843 -- Error_Pragma_Ref --
5844 ----------------------
5846 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
5847 MsgF : String := Msg;
5849 Error_Msg_Name_1 := Pname;
5851 Error_Msg_Sloc := Sloc (Ref);
5852 Error_Msg_NE (MsgF, N, Ref);
5854 end Error_Pragma_Ref;
5856 ------------------------
5857 -- Find_Lib_Unit_Name --
5858 ------------------------
5860 function Find_Lib_Unit_Name return Entity_Id is
5862 -- Return inner compilation unit entity, for case of nested
5863 -- categorization pragmas. This happens in generic unit.
5865 if Nkind (Parent (N)) = N_Package_Specification
5866 and then Defining_Entity (Parent (N)) /= Current_Scope
5868 return Defining_Entity (Parent (N));
5870 return Current_Scope;
5872 end Find_Lib_Unit_Name;
5874 ----------------------------
5875 -- Find_Program_Unit_Name --
5876 ----------------------------
5878 procedure Find_Program_Unit_Name (Id : Node_Id) is
5879 Unit_Name : Entity_Id;
5880 Unit_Kind : Node_Kind;
5881 P : constant Node_Id := Parent (N);
5884 if Nkind (P) = N_Compilation_Unit then
5885 Unit_Kind := Nkind (Unit (P));
5887 if Unit_Kind = N_Subprogram_Declaration
5888 or else Unit_Kind = N_Package_Declaration
5889 or else Unit_Kind in N_Generic_Declaration
5891 Unit_Name := Defining_Entity (Unit (P));
5893 if Chars (Id) = Chars (Unit_Name) then
5894 Set_Entity (Id, Unit_Name);
5895 Set_Etype (Id, Etype (Unit_Name));
5897 Set_Etype (Id, Any_Type);
5899 ("cannot find program unit referenced by pragma%");
5903 Set_Etype (Id, Any_Type);
5904 Error_Pragma ("pragma% inapplicable to this unit");
5910 end Find_Program_Unit_Name;
5912 -----------------------------------------
5913 -- Find_Unique_Parameterless_Procedure --
5914 -----------------------------------------
5916 function Find_Unique_Parameterless_Procedure
5918 Arg : Node_Id) return Entity_Id
5920 Proc : Entity_Id := Empty;
5923 -- The body of this procedure needs some comments ???
5925 if not Is_Entity_Name (Name) then
5927 ("argument of pragma% must be entity name", Arg);
5929 elsif not Is_Overloaded (Name) then
5930 Proc := Entity (Name);
5932 if Ekind (Proc) /= E_Procedure
5933 or else Present (First_Formal (Proc))
5936 ("argument of pragma% must be parameterless procedure", Arg);
5941 Found : Boolean := False;
5943 Index : Interp_Index;
5946 Get_First_Interp (Name, Index, It);
5947 while Present (It.Nam) loop
5950 if Ekind (Proc) = E_Procedure
5951 and then No (First_Formal (Proc))
5955 Set_Entity (Name, Proc);
5956 Set_Is_Overloaded (Name, False);
5959 ("ambiguous handler name for pragma% ", Arg);
5963 Get_Next_Interp (Index, It);
5968 ("argument of pragma% must be parameterless procedure",
5971 Proc := Entity (Name);
5977 end Find_Unique_Parameterless_Procedure;
5983 procedure Fix_Error (Msg : in out String) is
5985 -- If we have a rewriting of another pragma, go to that pragma
5987 if Is_Rewrite_Substitution (N)
5988 and then Nkind (Original_Node (N)) = N_Pragma
5990 Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
5993 -- Case where pragma comes from an aspect specification
5995 if From_Aspect_Specification (N) then
5997 -- Change appearence of "pragma" in message to "aspect"
5999 for J in Msg'First .. Msg'Last - 5 loop
6000 if Msg (J .. J + 5) = "pragma" then
6001 Msg (J .. J + 5) := "aspect";
6005 -- Get name from corresponding aspect
6007 Error_Msg_Name_1 := Original_Aspect_Name (N);
6011 -------------------------
6012 -- Gather_Associations --
6013 -------------------------
6015 procedure Gather_Associations
6017 Args : out Args_List)
6022 -- Initialize all parameters to Empty
6024 for J in Args'Range loop
6028 -- That's all we have to do if there are no argument associations
6030 if No (Pragma_Argument_Associations (N)) then
6034 -- Otherwise first deal with any positional parameters present
6036 Arg := First (Pragma_Argument_Associations (N));
6037 for Index in Args'Range loop
6038 exit when No (Arg) or else Chars (Arg) /= No_Name;
6039 Args (Index) := Get_Pragma_Arg (Arg);
6043 -- Positional parameters all processed, if any left, then we
6044 -- have too many positional parameters.
6046 if Present (Arg) and then Chars (Arg) = No_Name then
6048 ("too many positional associations for pragma%", Arg);
6051 -- Process named parameters if any are present
6053 while Present (Arg) loop
6054 if Chars (Arg) = No_Name then
6056 ("positional association cannot follow named association",
6060 for Index in Names'Range loop
6061 if Names (Index) = Chars (Arg) then
6062 if Present (Args (Index)) then
6064 ("duplicate argument association for pragma%", Arg);
6066 Args (Index) := Get_Pragma_Arg (Arg);
6071 if Index = Names'Last then
6072 Error_Msg_Name_1 := Pname;
6073 Error_Msg_N ("pragma% does not allow & argument", Arg);
6075 -- Check for possible misspelling
6077 for Index1 in Names'Range loop
6078 if Is_Bad_Spelling_Of
6079 (Chars (Arg), Names (Index1))
6081 Error_Msg_Name_1 := Names (Index1);
6082 Error_Msg_N -- CODEFIX
6083 ("\possible misspelling of%", Arg);
6095 end Gather_Associations;
6101 procedure GNAT_Pragma is
6103 -- We need to check the No_Implementation_Pragmas restriction for
6104 -- the case of a pragma from source. Note that the case of aspects
6105 -- generating corresponding pragmas marks these pragmas as not being
6106 -- from source, so this test also catches that case.
6108 if Comes_From_Source (N) then
6109 Check_Restriction (No_Implementation_Pragmas, N);
6113 --------------------------
6114 -- Is_Before_First_Decl --
6115 --------------------------
6117 function Is_Before_First_Decl
6118 (Pragma_Node : Node_Id;
6119 Decls : List_Id) return Boolean
6121 Item : Node_Id := First (Decls);
6124 -- Only other pragmas can come before this pragma
6127 if No (Item) or else Nkind (Item) /= N_Pragma then
6130 elsif Item = Pragma_Node then
6136 end Is_Before_First_Decl;
6138 -----------------------------
6139 -- Is_Configuration_Pragma --
6140 -----------------------------
6142 -- A configuration pragma must appear in the context clause of a
6143 -- compilation unit, and only other pragmas may precede it. Note that
6144 -- the test below also permits use in a configuration pragma file.
6146 function Is_Configuration_Pragma return Boolean is
6147 Lis : constant List_Id := List_Containing (N);
6148 Par : constant Node_Id := Parent (N);
6152 -- If no parent, then we are in the configuration pragma file,
6153 -- so the placement is definitely appropriate.
6158 -- Otherwise we must be in the context clause of a compilation unit
6159 -- and the only thing allowed before us in the context list is more
6160 -- configuration pragmas.
6162 elsif Nkind (Par) = N_Compilation_Unit
6163 and then Context_Items (Par) = Lis
6170 elsif Nkind (Prg) /= N_Pragma then
6180 end Is_Configuration_Pragma;
6182 --------------------------
6183 -- Is_In_Context_Clause --
6184 --------------------------
6186 function Is_In_Context_Clause return Boolean is
6188 Parent_Node : Node_Id;
6191 if not Is_List_Member (N) then
6195 Plist := List_Containing (N);
6196 Parent_Node := Parent (Plist);
6198 if Parent_Node = Empty
6199 or else Nkind (Parent_Node) /= N_Compilation_Unit
6200 or else Context_Items (Parent_Node) /= Plist
6207 end Is_In_Context_Clause;
6209 ---------------------------------
6210 -- Is_Static_String_Expression --
6211 ---------------------------------
6213 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
6214 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
6217 Analyze_And_Resolve (Argx);
6218 return Is_OK_Static_Expression (Argx)
6219 and then Nkind (Argx) = N_String_Literal;
6220 end Is_Static_String_Expression;
6222 ----------------------
6223 -- Pragma_Misplaced --
6224 ----------------------
6226 procedure Pragma_Misplaced is
6228 Error_Pragma ("incorrect placement of pragma%");
6229 end Pragma_Misplaced;
6231 ------------------------------------
6232 -- Process_Atomic_Shared_Volatile --
6233 ------------------------------------
6235 procedure Process_Atomic_Shared_Volatile is
6242 procedure Set_Atomic (E : Entity_Id);
6243 -- Set given type as atomic, and if no explicit alignment was given,
6244 -- set alignment to unknown, since back end knows what the alignment
6245 -- requirements are for atomic arrays. Note: this step is necessary
6246 -- for derived types.
6252 procedure Set_Atomic (E : Entity_Id) is
6256 if not Has_Alignment_Clause (E) then
6257 Set_Alignment (E, Uint_0);
6261 -- Start of processing for Process_Atomic_Shared_Volatile
6264 Check_Ada_83_Warning;
6265 Check_No_Identifiers;
6266 Check_Arg_Count (1);
6267 Check_Arg_Is_Local_Name (Arg1);
6268 E_Id := Get_Pragma_Arg (Arg1);
6270 if Etype (E_Id) = Any_Type then
6275 D := Declaration_Node (E);
6278 -- Check duplicate before we chain ourselves
6280 Check_Duplicate_Pragma (E);
6282 -- Now check appropriateness of the entity
6285 if Rep_Item_Too_Early (E, N)
6287 Rep_Item_Too_Late (E, N)
6291 Check_First_Subtype (Arg1);
6294 if Prag_Id /= Pragma_Volatile then
6296 Set_Atomic (Underlying_Type (E));
6297 Set_Atomic (Base_Type (E));
6300 -- Attribute belongs on the base type. If the view of the type is
6301 -- currently private, it also belongs on the underlying type.
6303 Set_Is_Volatile (Base_Type (E));
6304 Set_Is_Volatile (Underlying_Type (E));
6306 Set_Treat_As_Volatile (E);
6307 Set_Treat_As_Volatile (Underlying_Type (E));
6309 elsif K = N_Object_Declaration
6310 or else (K = N_Component_Declaration
6311 and then Original_Record_Component (E) = E)
6313 if Rep_Item_Too_Late (E, N) then
6317 if Prag_Id /= Pragma_Volatile then
6320 -- If the object declaration has an explicit initialization, a
6321 -- temporary may have to be created to hold the expression, to
6322 -- ensure that access to the object remain atomic.
6324 if Nkind (Parent (E)) = N_Object_Declaration
6325 and then Present (Expression (Parent (E)))
6327 Set_Has_Delayed_Freeze (E);
6330 -- An interesting improvement here. If an object of composite
6331 -- type X is declared atomic, and the type X isn't, that's a
6332 -- pity, since it may not have appropriate alignment etc. We
6333 -- can rescue this in the special case where the object and
6334 -- type are in the same unit by just setting the type as
6335 -- atomic, so that the back end will process it as atomic.
6337 -- Note: we used to do this for elementary types as well,
6338 -- but that turns out to be a bad idea and can have unwanted
6339 -- effects, most notably if the type is elementary, the object
6340 -- a simple component within a record, and both are in a spec:
6341 -- every object of this type in the entire program will be
6342 -- treated as atomic, thus incurring a potentially costly
6343 -- synchronization operation for every access.
6345 -- Of course it would be best if the back end could just adjust
6346 -- the alignment etc for the specific object, but that's not
6347 -- something we are capable of doing at this point.
6349 Utyp := Underlying_Type (Etype (E));
6352 and then Is_Composite_Type (Utyp)
6353 and then Sloc (E) > No_Location
6354 and then Sloc (Utyp) > No_Location
6356 Get_Source_File_Index (Sloc (E)) =
6357 Get_Source_File_Index (Sloc (Underlying_Type (Etype (E))))
6359 Set_Is_Atomic (Underlying_Type (Etype (E)));
6363 Set_Is_Volatile (E);
6364 Set_Treat_As_Volatile (E);
6368 ("inappropriate entity for pragma%", Arg1);
6370 end Process_Atomic_Shared_Volatile;
6372 -------------------------------------------
6373 -- Process_Compile_Time_Warning_Or_Error --
6374 -------------------------------------------
6376 procedure Process_Compile_Time_Warning_Or_Error is
6377 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
6380 Check_Arg_Count (2);
6381 Check_No_Identifiers;
6382 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
6383 Analyze_And_Resolve (Arg1x, Standard_Boolean);
6385 if Compile_Time_Known_Value (Arg1x) then
6386 if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
6388 Str : constant String_Id :=
6389 Strval (Get_Pragma_Arg (Arg2));
6390 Len : constant Int := String_Length (Str);
6395 Cent : constant Entity_Id :=
6396 Cunit_Entity (Current_Sem_Unit);
6398 Force : constant Boolean :=
6399 Prag_Id = Pragma_Compile_Time_Warning
6401 Is_Spec_Name (Unit_Name (Current_Sem_Unit))
6402 and then (Ekind (Cent) /= E_Package
6403 or else not In_Private_Part (Cent));
6404 -- Set True if this is the warning case, and we are in the
6405 -- visible part of a package spec, or in a subprogram spec,
6406 -- in which case we want to force the client to see the
6407 -- warning, even though it is not in the main unit.
6410 -- Loop through segments of message separated by line feeds.
6411 -- We output these segments as separate messages with
6412 -- continuation marks for all but the first.
6417 Error_Msg_Strlen := 0;
6419 -- Loop to copy characters from argument to error message
6423 exit when Ptr > Len;
6424 CC := Get_String_Char (Str, Ptr);
6427 -- Ignore wide chars ??? else store character
6429 if In_Character_Range (CC) then
6430 C := Get_Character (CC);
6431 exit when C = ASCII.LF;
6432 Error_Msg_Strlen := Error_Msg_Strlen + 1;
6433 Error_Msg_String (Error_Msg_Strlen) := C;
6437 -- Here with one line ready to go
6439 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
6441 -- If this is a warning in a spec, then we want clients
6442 -- to see the warning, so mark the message with the
6443 -- special sequence !! to force the warning. In the case
6444 -- of a package spec, we do not force this if we are in
6445 -- the private part of the spec.
6448 if Cont = False then
6449 Error_Msg_N ("<~!!", Arg1);
6452 Error_Msg_N ("\<~!!", Arg1);
6455 -- Error, rather than warning, or in a body, so we do not
6456 -- need to force visibility for client (error will be
6457 -- output in any case, and this is the situation in which
6458 -- we do not want a client to get a warning, since the
6459 -- warning is in the body or the spec private part).
6462 if Cont = False then
6463 Error_Msg_N ("<~", Arg1);
6466 Error_Msg_N ("\<~", Arg1);
6470 exit when Ptr > Len;
6475 end Process_Compile_Time_Warning_Or_Error;
6477 ------------------------
6478 -- Process_Convention --
6479 ------------------------
6481 procedure Process_Convention
6482 (C : out Convention_Id;
6483 Ent : out Entity_Id)
6489 Comp_Unit : Unit_Number_Type;
6491 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
6492 -- Called if we have more than one Export/Import/Convention pragma.
6493 -- This is generally illegal, but we have a special case of allowing
6494 -- Import and Interface to coexist if they specify the convention in
6495 -- a consistent manner. We are allowed to do this, since Interface is
6496 -- an implementation defined pragma, and we choose to do it since we
6497 -- know Rational allows this combination. S is the entity id of the
6498 -- subprogram in question. This procedure also sets the special flag
6499 -- Import_Interface_Present in both pragmas in the case where we do
6500 -- have matching Import and Interface pragmas.
6502 procedure Set_Convention_From_Pragma (E : Entity_Id);
6503 -- Set convention in entity E, and also flag that the entity has a
6504 -- convention pragma. If entity is for a private or incomplete type,
6505 -- also set convention and flag on underlying type. This procedure
6506 -- also deals with the special case of C_Pass_By_Copy convention,
6507 -- and error checks for inappropriate convention specification.
6509 -------------------------------
6510 -- Diagnose_Multiple_Pragmas --
6511 -------------------------------
6513 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
6514 Pdec : constant Node_Id := Declaration_Node (S);
6518 function Same_Convention (Decl : Node_Id) return Boolean;
6519 -- Decl is a pragma node. This function returns True if this
6520 -- pragma has a first argument that is an identifier with a
6521 -- Chars field corresponding to the Convention_Id C.
6523 function Same_Name (Decl : Node_Id) return Boolean;
6524 -- Decl is a pragma node. This function returns True if this
6525 -- pragma has a second argument that is an identifier with a
6526 -- Chars field that matches the Chars of the current subprogram.
6528 ---------------------
6529 -- Same_Convention --
6530 ---------------------
6532 function Same_Convention (Decl : Node_Id) return Boolean is
6533 Arg1 : constant Node_Id :=
6534 First (Pragma_Argument_Associations (Decl));
6537 if Present (Arg1) then
6539 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
6541 if Nkind (Arg) = N_Identifier
6542 and then Is_Convention_Name (Chars (Arg))
6543 and then Get_Convention_Id (Chars (Arg)) = C
6551 end Same_Convention;
6557 function Same_Name (Decl : Node_Id) return Boolean is
6558 Arg1 : constant Node_Id :=
6559 First (Pragma_Argument_Associations (Decl));
6567 Arg2 := Next (Arg1);
6574 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
6576 if Nkind (Arg) = N_Identifier
6577 and then Chars (Arg) = Chars (S)
6586 -- Start of processing for Diagnose_Multiple_Pragmas
6591 -- Definitely give message if we have Convention/Export here
6593 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
6596 -- If we have an Import or Export, scan back from pragma to
6597 -- find any previous pragma applying to the same procedure.
6598 -- The scan will be terminated by the start of the list, or
6599 -- hitting the subprogram declaration. This won't allow one
6600 -- pragma to appear in the public part and one in the private
6601 -- part, but that seems very unlikely in practice.
6605 while Present (Decl) and then Decl /= Pdec loop
6607 -- Look for pragma with same name as us
6609 if Nkind (Decl) = N_Pragma
6610 and then Same_Name (Decl)
6612 -- Give error if same as our pragma or Export/Convention
6614 if Nam_In (Pragma_Name (Decl), Name_Export,
6620 -- Case of Import/Interface or the other way round
6622 elsif Nam_In (Pragma_Name (Decl), Name_Interface,
6625 -- Here we know that we have Import and Interface. It
6626 -- doesn't matter which way round they are. See if
6627 -- they specify the same convention. If so, all OK,
6628 -- and set special flags to stop other messages
6630 if Same_Convention (Decl) then
6631 Set_Import_Interface_Present (N);
6632 Set_Import_Interface_Present (Decl);
6635 -- If different conventions, special message
6638 Error_Msg_Sloc := Sloc (Decl);
6640 ("convention differs from that given#", Arg1);
6650 -- Give message if needed if we fall through those tests
6651 -- except on Relaxed_RM_Semantics where we let go: either this
6652 -- is a case accepted/ignored by other Ada compilers (e.g.
6653 -- a mix of Convention and Import), or another error will be
6654 -- generated later (e.g. using both Import and Export).
6656 if Err and not Relaxed_RM_Semantics then
6658 ("at most one Convention/Export/Import pragma is allowed",
6661 end Diagnose_Multiple_Pragmas;
6663 --------------------------------
6664 -- Set_Convention_From_Pragma --
6665 --------------------------------
6667 procedure Set_Convention_From_Pragma (E : Entity_Id) is
6669 -- Ghost convention is allowed only for functions
6671 if Ekind (E) /= E_Function and then C = Convention_Ghost then
6673 ("& may not have Ghost convention", E);
6675 ("\only functions are permitted to have Ghost convention",
6680 -- Ada 2005 (AI-430): Check invalid attempt to change convention
6681 -- for an overridden dispatching operation. Technically this is
6682 -- an amendment and should only be done in Ada 2005 mode. However,
6683 -- this is clearly a mistake, since the problem that is addressed
6684 -- by this AI is that there is a clear gap in the RM.
6686 if Is_Dispatching_Operation (E)
6687 and then Present (Overridden_Operation (E))
6688 and then C /= Convention (Overridden_Operation (E))
6690 -- An attempt to override a function with a ghost function
6691 -- appears as a mismatch in conventions.
6693 if C = Convention_Ghost then
6694 Error_Msg_N ("ghost function & cannot be overriding", E);
6697 ("cannot change convention for overridden dispatching "
6698 & "operation", Arg1);
6702 -- Special checks for Convention_Stdcall
6704 if C = Convention_Stdcall then
6706 -- A dispatching call is not allowed. A dispatching subprogram
6707 -- cannot be used to interface to the Win32 API, so in fact
6708 -- this check does not impose any effective restriction.
6710 if Is_Dispatching_Operation (E) then
6711 Error_Msg_Sloc := Sloc (E);
6713 -- Note: make this unconditional so that if there is more
6714 -- than one call to which the pragma applies, we get a
6715 -- message for each call. Also don't use Error_Pragma,
6716 -- so that we get multiple messages.
6719 ("dispatching subprogram# cannot use Stdcall convention!",
6722 -- Subprogram is allowed, but not a generic subprogram
6724 elsif not Is_Subprogram (E)
6725 and then not Is_Generic_Subprogram (E)
6729 and then Ekind (E) /= E_Variable
6731 -- An access to subprogram is also allowed
6735 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
6737 -- Allow internal call to set convention of subprogram type
6739 and then not (Ekind (E) = E_Subprogram_Type)
6742 ("second argument of pragma% must be subprogram (type)",
6747 -- Set the convention
6749 Set_Convention (E, C);
6750 Set_Has_Convention_Pragma (E);
6752 -- For the case of a record base type, also set the convention of
6753 -- any anonymous access types declared in the record which do not
6754 -- currently have a specified convention.
6756 if Is_Record_Type (E) and then Is_Base_Type (E) then
6761 Comp := First_Component (E);
6762 while Present (Comp) loop
6763 if Present (Etype (Comp))
6764 and then Ekind_In (Etype (Comp),
6765 E_Anonymous_Access_Type,
6766 E_Anonymous_Access_Subprogram_Type)
6767 and then not Has_Convention_Pragma (Comp)
6769 Set_Convention (Comp, C);
6772 Next_Component (Comp);
6777 -- Deal with incomplete/private type case, where underlying type
6778 -- is available, so set convention of that underlying type.
6780 if Is_Incomplete_Or_Private_Type (E)
6781 and then Present (Underlying_Type (E))
6783 Set_Convention (Underlying_Type (E), C);
6784 Set_Has_Convention_Pragma (Underlying_Type (E), True);
6787 -- A class-wide type should inherit the convention of the specific
6788 -- root type (although this isn't specified clearly by the RM).
6790 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
6791 Set_Convention (Class_Wide_Type (E), C);
6794 -- If the entity is a record type, then check for special case of
6795 -- C_Pass_By_Copy, which is treated the same as C except that the
6796 -- special record flag is set. This convention is only permitted
6797 -- on record types (see AI95-00131).
6799 if Cname = Name_C_Pass_By_Copy then
6800 if Is_Record_Type (E) then
6801 Set_C_Pass_By_Copy (Base_Type (E));
6802 elsif Is_Incomplete_Or_Private_Type (E)
6803 and then Is_Record_Type (Underlying_Type (E))
6805 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
6808 ("C_Pass_By_Copy convention allowed only for record type",
6813 -- If the entity is a derived boolean type, check for the special
6814 -- case of convention C, C++, or Fortran, where we consider any
6815 -- nonzero value to represent true.
6817 if Is_Discrete_Type (E)
6818 and then Root_Type (Etype (E)) = Standard_Boolean
6824 C = Convention_Fortran)
6826 Set_Nonzero_Is_True (Base_Type (E));
6828 end Set_Convention_From_Pragma;
6830 -- Start of processing for Process_Convention
6833 Check_At_Least_N_Arguments (2);
6834 Check_Optional_Identifier (Arg1, Name_Convention);
6835 Check_Arg_Is_Identifier (Arg1);
6836 Cname := Chars (Get_Pragma_Arg (Arg1));
6838 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
6839 -- tested again below to set the critical flag).
6841 if Cname = Name_C_Pass_By_Copy then
6844 -- Otherwise we must have something in the standard convention list
6846 elsif Is_Convention_Name (Cname) then
6847 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
6849 -- In DEC VMS, it seems that there is an undocumented feature that
6850 -- any unrecognized convention is treated as the default, which for
6851 -- us is convention C. It does not seem so terrible to do this
6852 -- unconditionally, silently in the VMS case, and with a warning
6853 -- in the non-VMS case.
6856 if Warn_On_Export_Import and not OpenVMS_On_Target then
6858 ("??unrecognized convention name, C assumed",
6859 Get_Pragma_Arg (Arg1));
6865 Check_Optional_Identifier (Arg2, Name_Entity);
6866 Check_Arg_Is_Local_Name (Arg2);
6868 Id := Get_Pragma_Arg (Arg2);
6871 if not Is_Entity_Name (Id) then
6872 Error_Pragma_Arg ("entity name required", Arg2);
6877 -- Set entity to return
6881 -- Ada_Pass_By_Copy special checking
6883 if C = Convention_Ada_Pass_By_Copy then
6884 if not Is_First_Subtype (E) then
6886 ("convention `Ada_Pass_By_Copy` only allowed for types",
6890 if Is_By_Reference_Type (E) then
6892 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
6897 -- Ada_Pass_By_Reference special checking
6899 if C = Convention_Ada_Pass_By_Reference then
6900 if not Is_First_Subtype (E) then
6902 ("convention `Ada_Pass_By_Reference` only allowed for types",
6906 if Is_By_Copy_Type (E) then
6908 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
6913 -- Ghost special checking
6915 if Is_Ghost_Subprogram (E)
6916 and then Present (Overridden_Operation (E))
6918 Error_Msg_N ("ghost function & cannot be overriding", E);
6921 -- Go to renamed subprogram if present, since convention applies to
6922 -- the actual renamed entity, not to the renaming entity. If the
6923 -- subprogram is inherited, go to parent subprogram.
6925 if Is_Subprogram (E)
6926 and then Present (Alias (E))
6928 if Nkind (Parent (Declaration_Node (E))) =
6929 N_Subprogram_Renaming_Declaration
6931 if Scope (E) /= Scope (Alias (E)) then
6933 ("cannot apply pragma% to non-local entity&#", E);
6938 elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
6939 N_Private_Extension_Declaration)
6940 and then Scope (E) = Scope (Alias (E))
6944 -- Return the parent subprogram the entity was inherited from
6950 -- Check that we are not applying this to a specless body
6951 -- Relax this check if Relaxed_RM_Semantics to accomodate other Ada
6954 if Is_Subprogram (E)
6955 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
6956 and then not Relaxed_RM_Semantics
6959 ("pragma% requires separate spec and must come before body");
6962 -- Check that we are not applying this to a named constant
6964 if Ekind_In (E, E_Named_Integer, E_Named_Real) then
6965 Error_Msg_Name_1 := Pname;
6967 ("cannot apply pragma% to named constant!",
6968 Get_Pragma_Arg (Arg2));
6970 ("\supply appropriate type for&!", Arg2);
6973 if Ekind (E) = E_Enumeration_Literal then
6974 Error_Pragma ("enumeration literal not allowed for pragma%");
6977 -- Check for rep item appearing too early or too late
6979 if Etype (E) = Any_Type
6980 or else Rep_Item_Too_Early (E, N)
6984 elsif Present (Underlying_Type (E)) then
6985 E := Underlying_Type (E);
6988 if Rep_Item_Too_Late (E, N) then
6992 if Has_Convention_Pragma (E) then
6993 Diagnose_Multiple_Pragmas (E);
6995 elsif Convention (E) = Convention_Protected
6996 or else Ekind (Scope (E)) = E_Protected_Type
6999 ("a protected operation cannot be given a different convention",
7003 -- For Intrinsic, a subprogram is required
7005 if C = Convention_Intrinsic
7006 and then not Is_Subprogram (E)
7007 and then not Is_Generic_Subprogram (E)
7010 ("second argument of pragma% must be a subprogram", Arg2);
7013 -- Deal with non-subprogram cases
7015 if not Is_Subprogram (E)
7016 and then not Is_Generic_Subprogram (E)
7018 Set_Convention_From_Pragma (E);
7021 Check_First_Subtype (Arg2);
7022 Set_Convention_From_Pragma (Base_Type (E));
7024 -- For access subprograms, we must set the convention on the
7025 -- internally generated directly designated type as well.
7027 if Ekind (E) = E_Access_Subprogram_Type then
7028 Set_Convention_From_Pragma (Directly_Designated_Type (E));
7032 -- For the subprogram case, set proper convention for all homonyms
7033 -- in same scope and the same declarative part, i.e. the same
7034 -- compilation unit.
7037 Comp_Unit := Get_Source_Unit (E);
7038 Set_Convention_From_Pragma (E);
7040 -- Treat a pragma Import as an implicit body, and pragma import
7041 -- as implicit reference (for navigation in GPS).
7043 if Prag_Id = Pragma_Import then
7044 Generate_Reference (E, Id, 'b');
7046 -- For exported entities we restrict the generation of references
7047 -- to entities exported to foreign languages since entities
7048 -- exported to Ada do not provide further information to GPS and
7049 -- add undesired references to the output of the gnatxref tool.
7051 elsif Prag_Id = Pragma_Export
7052 and then Convention (E) /= Convention_Ada
7054 Generate_Reference (E, Id, 'i');
7057 -- If the pragma comes from from an aspect, it only applies to the
7058 -- given entity, not its homonyms.
7060 if From_Aspect_Specification (N) then
7064 -- Otherwise Loop through the homonyms of the pragma argument's
7065 -- entity, an apply convention to those in the current scope.
7071 exit when No (E1) or else Scope (E1) /= Current_Scope;
7073 -- Ignore entry for which convention is already set
7075 if Has_Convention_Pragma (E1) then
7079 -- Do not set the pragma on inherited operations or on formal
7082 if Comes_From_Source (E1)
7083 and then Comp_Unit = Get_Source_Unit (E1)
7084 and then not Is_Formal_Subprogram (E1)
7085 and then Nkind (Original_Node (Parent (E1))) /=
7086 N_Full_Type_Declaration
7088 if Present (Alias (E1))
7089 and then Scope (E1) /= Scope (Alias (E1))
7092 ("cannot apply pragma% to non-local entity& declared#",
7096 Set_Convention_From_Pragma (E1);
7098 if Prag_Id = Pragma_Import then
7099 Generate_Reference (E1, Id, 'b');
7107 end Process_Convention;
7109 ----------------------------------------
7110 -- Process_Disable_Enable_Atomic_Sync --
7111 ----------------------------------------
7113 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
7115 Check_No_Identifiers;
7116 Check_At_Most_N_Arguments (1);
7118 -- Modeled internally as
7119 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
7123 Pragma_Identifier =>
7124 Make_Identifier (Loc, Nam),
7125 Pragma_Argument_Associations => New_List (
7126 Make_Pragma_Argument_Association (Loc,
7128 Make_Identifier (Loc, Name_Atomic_Synchronization)))));
7130 if Present (Arg1) then
7131 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
7135 end Process_Disable_Enable_Atomic_Sync;
7137 -----------------------------------------------------
7138 -- Process_Extended_Import_Export_Exception_Pragma --
7139 -----------------------------------------------------
7141 procedure Process_Extended_Import_Export_Exception_Pragma
7142 (Arg_Internal : Node_Id;
7143 Arg_External : Node_Id;
7151 if not OpenVMS_On_Target then
7153 ("??pragma% ignored (applies only to Open'V'M'S)");
7156 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
7157 Def_Id := Entity (Arg_Internal);
7159 if Ekind (Def_Id) /= E_Exception then
7161 ("pragma% must refer to declared exception", Arg_Internal);
7164 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
7166 if Present (Arg_Form) then
7167 Check_Arg_Is_One_Of (Arg_Form, Name_Ada, Name_VMS);
7170 if Present (Arg_Form)
7171 and then Chars (Arg_Form) = Name_Ada
7175 Set_Is_VMS_Exception (Def_Id);
7176 Set_Exception_Code (Def_Id, No_Uint);
7179 if Present (Arg_Code) then
7180 if not Is_VMS_Exception (Def_Id) then
7182 ("Code option for pragma% not allowed for Ada case",
7186 Check_Arg_Is_Static_Expression (Arg_Code, Any_Integer);
7187 Code_Val := Expr_Value (Arg_Code);
7189 if not UI_Is_In_Int_Range (Code_Val) then
7191 ("Code option for pragma% must be in 32-bit range",
7195 Set_Exception_Code (Def_Id, Code_Val);
7198 end Process_Extended_Import_Export_Exception_Pragma;
7200 -------------------------------------------------
7201 -- Process_Extended_Import_Export_Internal_Arg --
7202 -------------------------------------------------
7204 procedure Process_Extended_Import_Export_Internal_Arg
7205 (Arg_Internal : Node_Id := Empty)
7208 if No (Arg_Internal) then
7209 Error_Pragma ("Internal parameter required for pragma%");
7212 if Nkind (Arg_Internal) = N_Identifier then
7215 elsif Nkind (Arg_Internal) = N_Operator_Symbol
7216 and then (Prag_Id = Pragma_Import_Function
7218 Prag_Id = Pragma_Export_Function)
7224 ("wrong form for Internal parameter for pragma%", Arg_Internal);
7227 Check_Arg_Is_Local_Name (Arg_Internal);
7228 end Process_Extended_Import_Export_Internal_Arg;
7230 --------------------------------------------------
7231 -- Process_Extended_Import_Export_Object_Pragma --
7232 --------------------------------------------------
7234 procedure Process_Extended_Import_Export_Object_Pragma
7235 (Arg_Internal : Node_Id;
7236 Arg_External : Node_Id;
7242 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
7243 Def_Id := Entity (Arg_Internal);
7245 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
7247 ("pragma% must designate an object", Arg_Internal);
7250 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
7252 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
7255 ("previous Common/Psect_Object applies, pragma % not permitted",
7259 if Rep_Item_Too_Late (Def_Id, N) then
7263 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
7265 if Present (Arg_Size) then
7266 Check_Arg_Is_External_Name (Arg_Size);
7269 -- Export_Object case
7271 if Prag_Id = Pragma_Export_Object then
7272 if not Is_Library_Level_Entity (Def_Id) then
7274 ("argument for pragma% must be library level entity",
7278 if Ekind (Current_Scope) = E_Generic_Package then
7279 Error_Pragma ("pragma& cannot appear in a generic unit");
7282 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
7284 ("exported object must have compile time known size",
7288 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
7289 Error_Msg_N ("??duplicate Export_Object pragma", N);
7291 Set_Exported (Def_Id, Arg_Internal);
7294 -- Import_Object case
7297 if Is_Concurrent_Type (Etype (Def_Id)) then
7299 ("cannot use pragma% for task/protected object",
7303 if Ekind (Def_Id) = E_Constant then
7305 ("cannot import a constant", Arg_Internal);
7308 if Warn_On_Export_Import
7309 and then Has_Discriminants (Etype (Def_Id))
7312 ("imported value must be initialized??", Arg_Internal);
7315 if Warn_On_Export_Import
7316 and then Is_Access_Type (Etype (Def_Id))
7319 ("cannot import object of an access type??", Arg_Internal);
7322 if Warn_On_Export_Import
7323 and then Is_Imported (Def_Id)
7325 Error_Msg_N ("??duplicate Import_Object pragma", N);
7327 -- Check for explicit initialization present. Note that an
7328 -- initialization generated by the code generator, e.g. for an
7329 -- access type, does not count here.
7331 elsif Present (Expression (Parent (Def_Id)))
7334 (Original_Node (Expression (Parent (Def_Id))))
7336 Error_Msg_Sloc := Sloc (Def_Id);
7338 ("imported entities cannot be initialized (RM B.1(24))",
7339 "\no initialization allowed for & declared#", Arg1);
7341 Set_Imported (Def_Id);
7342 Note_Possible_Modification (Arg_Internal, Sure => False);
7345 end Process_Extended_Import_Export_Object_Pragma;
7347 ------------------------------------------------------
7348 -- Process_Extended_Import_Export_Subprogram_Pragma --
7349 ------------------------------------------------------
7351 procedure Process_Extended_Import_Export_Subprogram_Pragma
7352 (Arg_Internal : Node_Id;
7353 Arg_External : Node_Id;
7354 Arg_Parameter_Types : Node_Id;
7355 Arg_Result_Type : Node_Id := Empty;
7356 Arg_Mechanism : Node_Id;
7357 Arg_Result_Mechanism : Node_Id := Empty;
7358 Arg_First_Optional_Parameter : Node_Id := Empty)
7364 Ambiguous : Boolean;
7368 function Same_Base_Type
7370 Formal : Entity_Id) return Boolean;
7371 -- Determines if Ptype references the type of Formal. Note that only
7372 -- the base types need to match according to the spec. Ptype here is
7373 -- the argument from the pragma, which is either a type name, or an
7374 -- access attribute.
7376 --------------------
7377 -- Same_Base_Type --
7378 --------------------
7380 function Same_Base_Type
7382 Formal : Entity_Id) return Boolean
7384 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
7388 -- Case where pragma argument is typ'Access
7390 if Nkind (Ptype) = N_Attribute_Reference
7391 and then Attribute_Name (Ptype) = Name_Access
7393 Pref := Prefix (Ptype);
7396 if not Is_Entity_Name (Pref)
7397 or else Entity (Pref) = Any_Type
7402 -- We have a match if the corresponding argument is of an
7403 -- anonymous access type, and its designated type matches the
7404 -- type of the prefix of the access attribute
7406 return Ekind (Ftyp) = E_Anonymous_Access_Type
7407 and then Base_Type (Entity (Pref)) =
7408 Base_Type (Etype (Designated_Type (Ftyp)));
7410 -- Case where pragma argument is a type name
7415 if not Is_Entity_Name (Ptype)
7416 or else Entity (Ptype) = Any_Type
7421 -- We have a match if the corresponding argument is of the type
7422 -- given in the pragma (comparing base types)
7424 return Base_Type (Entity (Ptype)) = Ftyp;
7428 -- Start of processing for
7429 -- Process_Extended_Import_Export_Subprogram_Pragma
7432 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
7436 -- Loop through homonyms (overloadings) of the entity
7438 Hom_Id := Entity (Arg_Internal);
7439 while Present (Hom_Id) loop
7440 Def_Id := Get_Base_Subprogram (Hom_Id);
7442 -- We need a subprogram in the current scope
7444 if not Is_Subprogram (Def_Id)
7445 or else Scope (Def_Id) /= Current_Scope
7452 -- Pragma cannot apply to subprogram body
7454 if Is_Subprogram (Def_Id)
7455 and then Nkind (Parent (Declaration_Node (Def_Id))) =
7459 ("pragma% requires separate spec"
7460 & " and must come before body");
7463 -- Test result type if given, note that the result type
7464 -- parameter can only be present for the function cases.
7466 if Present (Arg_Result_Type)
7467 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
7471 elsif Etype (Def_Id) /= Standard_Void_Type
7473 Nam_In (Pname, Name_Export_Procedure, Name_Import_Procedure)
7477 -- Test parameter types if given. Note that this parameter
7478 -- has not been analyzed (and must not be, since it is
7479 -- semantic nonsense), so we get it as the parser left it.
7481 elsif Present (Arg_Parameter_Types) then
7482 Check_Matching_Types : declare
7487 Formal := First_Formal (Def_Id);
7489 if Nkind (Arg_Parameter_Types) = N_Null then
7490 if Present (Formal) then
7494 -- A list of one type, e.g. (List) is parsed as
7495 -- a parenthesized expression.
7497 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
7498 and then Paren_Count (Arg_Parameter_Types) = 1
7501 or else Present (Next_Formal (Formal))
7506 Same_Base_Type (Arg_Parameter_Types, Formal);
7509 -- A list of more than one type is parsed as a aggregate
7511 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
7512 and then Paren_Count (Arg_Parameter_Types) = 0
7514 Ptype := First (Expressions (Arg_Parameter_Types));
7515 while Present (Ptype) or else Present (Formal) loop
7518 or else not Same_Base_Type (Ptype, Formal)
7523 Next_Formal (Formal);
7528 -- Anything else is of the wrong form
7532 ("wrong form for Parameter_Types parameter",
7533 Arg_Parameter_Types);
7535 end Check_Matching_Types;
7538 -- Match is now False if the entry we found did not match
7539 -- either a supplied Parameter_Types or Result_Types argument
7545 -- Ambiguous case, the flag Ambiguous shows if we already
7546 -- detected this and output the initial messages.
7549 if not Ambiguous then
7551 Error_Msg_Name_1 := Pname;
7553 ("pragma% does not uniquely identify subprogram!",
7555 Error_Msg_Sloc := Sloc (Ent);
7556 Error_Msg_N ("matching subprogram #!", N);
7560 Error_Msg_Sloc := Sloc (Def_Id);
7561 Error_Msg_N ("matching subprogram #!", N);
7566 Hom_Id := Homonym (Hom_Id);
7569 -- See if we found an entry
7572 if not Ambiguous then
7573 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
7575 ("pragma% cannot be given for generic subprogram");
7578 ("pragma% does not identify local subprogram");
7585 -- Import pragmas must be for imported entities
7587 if Prag_Id = Pragma_Import_Function
7589 Prag_Id = Pragma_Import_Procedure
7591 Prag_Id = Pragma_Import_Valued_Procedure
7593 if not Is_Imported (Ent) then
7595 ("pragma Import or Interface must precede pragma%");
7598 -- Here we have the Export case which can set the entity as exported
7600 -- But does not do so if the specified external name is null, since
7601 -- that is taken as a signal in DEC Ada 83 (with which we want to be
7602 -- compatible) to request no external name.
7604 elsif Nkind (Arg_External) = N_String_Literal
7605 and then String_Length (Strval (Arg_External)) = 0
7609 -- In all other cases, set entity as exported
7612 Set_Exported (Ent, Arg_Internal);
7615 -- Special processing for Valued_Procedure cases
7617 if Prag_Id = Pragma_Import_Valued_Procedure
7619 Prag_Id = Pragma_Export_Valued_Procedure
7621 Formal := First_Formal (Ent);
7624 Error_Pragma ("at least one parameter required for pragma%");
7626 elsif Ekind (Formal) /= E_Out_Parameter then
7627 Error_Pragma ("first parameter must have mode out for pragma%");
7630 Set_Is_Valued_Procedure (Ent);
7634 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
7636 -- Process Result_Mechanism argument if present. We have already
7637 -- checked that this is only allowed for the function case.
7639 if Present (Arg_Result_Mechanism) then
7640 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
7643 -- Process Mechanism parameter if present. Note that this parameter
7644 -- is not analyzed, and must not be analyzed since it is semantic
7645 -- nonsense, so we get it in exactly as the parser left it.
7647 if Present (Arg_Mechanism) then
7655 -- A single mechanism association without a formal parameter
7656 -- name is parsed as a parenthesized expression. All other
7657 -- cases are parsed as aggregates, so we rewrite the single
7658 -- parameter case as an aggregate for consistency.
7660 if Nkind (Arg_Mechanism) /= N_Aggregate
7661 and then Paren_Count (Arg_Mechanism) = 1
7663 Rewrite (Arg_Mechanism,
7664 Make_Aggregate (Sloc (Arg_Mechanism),
7665 Expressions => New_List (
7666 Relocate_Node (Arg_Mechanism))));
7669 -- Case of only mechanism name given, applies to all formals
7671 if Nkind (Arg_Mechanism) /= N_Aggregate then
7672 Formal := First_Formal (Ent);
7673 while Present (Formal) loop
7674 Set_Mechanism_Value (Formal, Arg_Mechanism);
7675 Next_Formal (Formal);
7678 -- Case of list of mechanism associations given
7681 if Null_Record_Present (Arg_Mechanism) then
7683 ("inappropriate form for Mechanism parameter",
7687 -- Deal with positional ones first
7689 Formal := First_Formal (Ent);
7691 if Present (Expressions (Arg_Mechanism)) then
7692 Mname := First (Expressions (Arg_Mechanism));
7693 while Present (Mname) loop
7696 ("too many mechanism associations", Mname);
7699 Set_Mechanism_Value (Formal, Mname);
7700 Next_Formal (Formal);
7705 -- Deal with named entries
7707 if Present (Component_Associations (Arg_Mechanism)) then
7708 Massoc := First (Component_Associations (Arg_Mechanism));
7709 while Present (Massoc) loop
7710 Choice := First (Choices (Massoc));
7712 if Nkind (Choice) /= N_Identifier
7713 or else Present (Next (Choice))
7716 ("incorrect form for mechanism association",
7720 Formal := First_Formal (Ent);
7724 ("parameter name & not present", Choice);
7727 if Chars (Choice) = Chars (Formal) then
7729 (Formal, Expression (Massoc));
7731 -- Set entity on identifier (needed by ASIS)
7733 Set_Entity (Choice, Formal);
7738 Next_Formal (Formal);
7748 -- Process First_Optional_Parameter argument if present. We have
7749 -- already checked that this is only allowed for the Import case.
7751 if Present (Arg_First_Optional_Parameter) then
7752 if Nkind (Arg_First_Optional_Parameter) /= N_Identifier then
7754 ("first optional parameter must be formal parameter name",
7755 Arg_First_Optional_Parameter);
7758 Formal := First_Formal (Ent);
7762 ("specified formal parameter& not found",
7763 Arg_First_Optional_Parameter);
7766 exit when Chars (Formal) =
7767 Chars (Arg_First_Optional_Parameter);
7769 Next_Formal (Formal);
7772 Set_First_Optional_Parameter (Ent, Formal);
7774 -- Check specified and all remaining formals have right form
7776 while Present (Formal) loop
7777 if Ekind (Formal) /= E_In_Parameter then
7779 ("optional formal& is not of mode in!",
7780 Arg_First_Optional_Parameter, Formal);
7783 Dval := Default_Value (Formal);
7787 ("optional formal& does not have default value!",
7788 Arg_First_Optional_Parameter, Formal);
7790 elsif Compile_Time_Known_Value_Or_Aggr (Dval) then
7795 ("default value for optional formal& is non-static!",
7796 Arg_First_Optional_Parameter, Formal);
7800 Set_Is_Optional_Parameter (Formal);
7801 Next_Formal (Formal);
7804 end Process_Extended_Import_Export_Subprogram_Pragma;
7806 --------------------------
7807 -- Process_Generic_List --
7808 --------------------------
7810 procedure Process_Generic_List is
7815 Check_No_Identifiers;
7816 Check_At_Least_N_Arguments (1);
7818 -- Check all arguments are names of generic units or instances
7821 while Present (Arg) loop
7822 Exp := Get_Pragma_Arg (Arg);
7825 if not Is_Entity_Name (Exp)
7827 (not Is_Generic_Instance (Entity (Exp))
7829 not Is_Generic_Unit (Entity (Exp)))
7832 ("pragma% argument must be name of generic unit/instance",
7838 end Process_Generic_List;
7840 ------------------------------------
7841 -- Process_Import_Predefined_Type --
7842 ------------------------------------
7844 procedure Process_Import_Predefined_Type is
7845 Loc : constant Source_Ptr := Sloc (N);
7847 Ftyp : Node_Id := Empty;
7853 String_To_Name_Buffer (Strval (Expression (Arg3)));
7856 Elmt := First_Elmt (Predefined_Float_Types);
7857 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
7861 Ftyp := Node (Elmt);
7863 if Present (Ftyp) then
7865 -- Don't build a derived type declaration, because predefined C
7866 -- types have no declaration anywhere, so cannot really be named.
7867 -- Instead build a full type declaration, starting with an
7868 -- appropriate type definition is built
7870 if Is_Floating_Point_Type (Ftyp) then
7871 Def := Make_Floating_Point_Definition (Loc,
7872 Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
7873 Make_Real_Range_Specification (Loc,
7874 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
7875 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
7877 -- Should never have a predefined type we cannot handle
7880 raise Program_Error;
7883 -- Build and insert a Full_Type_Declaration, which will be
7884 -- analyzed as soon as this list entry has been analyzed.
7886 Decl := Make_Full_Type_Declaration (Loc,
7887 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
7888 Type_Definition => Def);
7890 Insert_After (N, Decl);
7891 Mark_Rewrite_Insertion (Decl);
7894 Error_Pragma_Arg ("no matching type found for pragma%",
7897 end Process_Import_Predefined_Type;
7899 ---------------------------------
7900 -- Process_Import_Or_Interface --
7901 ---------------------------------
7903 procedure Process_Import_Or_Interface is
7909 -- In Relaxed_RM_Semantics, support old Ada 83 style:
7910 -- pragma Import (Entity, "external name");
7912 if Relaxed_RM_Semantics
7913 and then Arg_Count = 2
7914 and then Prag_Id = Pragma_Import
7915 and then Nkind (Expression (Arg2)) = N_String_Literal
7918 Def_Id := Get_Pragma_Arg (Arg1);
7921 if not Is_Entity_Name (Def_Id) then
7922 Error_Pragma_Arg ("entity name required", Arg1);
7925 Def_Id := Entity (Def_Id);
7926 Kill_Size_Check_Code (Def_Id);
7927 Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False);
7930 Process_Convention (C, Def_Id);
7931 Kill_Size_Check_Code (Def_Id);
7932 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
7935 if Ekind_In (Def_Id, E_Variable, E_Constant) then
7937 -- We do not permit Import to apply to a renaming declaration
7939 if Present (Renamed_Object (Def_Id)) then
7941 ("pragma% not allowed for object renaming", Arg2);
7943 -- User initialization is not allowed for imported object, but
7944 -- the object declaration may contain a default initialization,
7945 -- that will be discarded. Note that an explicit initialization
7946 -- only counts if it comes from source, otherwise it is simply
7947 -- the code generator making an implicit initialization explicit.
7949 elsif Present (Expression (Parent (Def_Id)))
7950 and then Comes_From_Source (Expression (Parent (Def_Id)))
7952 Error_Msg_Sloc := Sloc (Def_Id);
7954 ("no initialization allowed for declaration of& #",
7955 "\imported entities cannot be initialized (RM B.1(24))",
7959 Set_Imported (Def_Id);
7960 Process_Interface_Name (Def_Id, Arg3, Arg4);
7962 -- Note that we do not set Is_Public here. That's because we
7963 -- only want to set it if there is no address clause, and we
7964 -- don't know that yet, so we delay that processing till
7967 -- pragma Import completes deferred constants
7969 if Ekind (Def_Id) = E_Constant then
7970 Set_Has_Completion (Def_Id);
7973 -- It is not possible to import a constant of an unconstrained
7974 -- array type (e.g. string) because there is no simple way to
7975 -- write a meaningful subtype for it.
7977 if Is_Array_Type (Etype (Def_Id))
7978 and then not Is_Constrained (Etype (Def_Id))
7981 ("imported constant& must have a constrained subtype",
7986 elsif Is_Subprogram (Def_Id)
7987 or else Is_Generic_Subprogram (Def_Id)
7989 -- If the name is overloaded, pragma applies to all of the denoted
7990 -- entities in the same declarative part, unless the pragma comes
7991 -- from an aspect specification.
7994 while Present (Hom_Id) loop
7996 Def_Id := Get_Base_Subprogram (Hom_Id);
7998 -- Ignore inherited subprograms because the pragma will apply
7999 -- to the parent operation, which is the one called.
8001 if Is_Overloadable (Def_Id)
8002 and then Present (Alias (Def_Id))
8006 -- If it is not a subprogram, it must be in an outer scope and
8007 -- pragma does not apply.
8009 elsif not Is_Subprogram (Def_Id)
8010 and then not Is_Generic_Subprogram (Def_Id)
8014 -- The pragma does not apply to primitives of interfaces
8016 elsif Is_Dispatching_Operation (Def_Id)
8017 and then Present (Find_Dispatching_Type (Def_Id))
8018 and then Is_Interface (Find_Dispatching_Type (Def_Id))
8022 -- Verify that the homonym is in the same declarative part (not
8023 -- just the same scope). If the pragma comes from an aspect
8024 -- specification we know that it is part of the declaration.
8026 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
8027 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
8028 and then not From_Aspect_Specification (N)
8033 Set_Imported (Def_Id);
8035 -- Reject an Import applied to an abstract subprogram
8037 if Is_Subprogram (Def_Id)
8038 and then Is_Abstract_Subprogram (Def_Id)
8040 Error_Msg_Sloc := Sloc (Def_Id);
8042 ("cannot import abstract subprogram& declared#",
8046 -- Special processing for Convention_Intrinsic
8048 if C = Convention_Intrinsic then
8050 -- Link_Name argument not allowed for intrinsic
8054 Set_Is_Intrinsic_Subprogram (Def_Id);
8056 -- If no external name is present, then check that this
8057 -- is a valid intrinsic subprogram. If an external name
8058 -- is present, then this is handled by the back end.
8061 Check_Intrinsic_Subprogram
8062 (Def_Id, Get_Pragma_Arg (Arg2));
8066 -- Verify that the subprogram does not have a completion
8067 -- through a renaming declaration. For other completions the
8068 -- pragma appears as a too late representation.
8071 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
8075 and then Nkind (Decl) = N_Subprogram_Declaration
8076 and then Present (Corresponding_Body (Decl))
8077 and then Nkind (Unit_Declaration_Node
8078 (Corresponding_Body (Decl))) =
8079 N_Subprogram_Renaming_Declaration
8081 Error_Msg_Sloc := Sloc (Def_Id);
8083 ("cannot import&, renaming already provided for "
8084 & "declaration #", N, Def_Id);
8088 Set_Has_Completion (Def_Id);
8089 Process_Interface_Name (Def_Id, Arg3, Arg4);
8092 if Is_Compilation_Unit (Hom_Id) then
8094 -- Its possible homonyms are not affected by the pragma.
8095 -- Such homonyms might be present in the context of other
8096 -- units being compiled.
8100 elsif From_Aspect_Specification (N) then
8104 Hom_Id := Homonym (Hom_Id);
8108 -- When the convention is Java or CIL, we also allow Import to
8109 -- be given for packages, generic packages, exceptions, record
8110 -- components, and access to subprograms.
8112 elsif (C = Convention_Java or else C = Convention_CIL)
8114 (Is_Package_Or_Generic_Package (Def_Id)
8115 or else Ekind (Def_Id) = E_Exception
8116 or else Ekind (Def_Id) = E_Access_Subprogram_Type
8117 or else Nkind (Parent (Def_Id)) = N_Component_Declaration)
8119 Set_Imported (Def_Id);
8120 Set_Is_Public (Def_Id);
8121 Process_Interface_Name (Def_Id, Arg3, Arg4);
8123 -- Import a CPP class
8125 elsif C = Convention_CPP
8126 and then (Is_Record_Type (Def_Id)
8127 or else Ekind (Def_Id) = E_Incomplete_Type)
8129 if Ekind (Def_Id) = E_Incomplete_Type then
8130 if Present (Full_View (Def_Id)) then
8131 Def_Id := Full_View (Def_Id);
8135 ("cannot import 'C'P'P type before full declaration seen",
8136 Get_Pragma_Arg (Arg2));
8138 -- Although we have reported the error we decorate it as
8139 -- CPP_Class to avoid reporting spurious errors
8141 Set_Is_CPP_Class (Def_Id);
8146 -- Types treated as CPP classes must be declared limited (note:
8147 -- this used to be a warning but there is no real benefit to it
8148 -- since we did effectively intend to treat the type as limited
8151 if not Is_Limited_Type (Def_Id) then
8153 ("imported 'C'P'P type must be limited",
8154 Get_Pragma_Arg (Arg2));
8157 if Etype (Def_Id) /= Def_Id
8158 and then not Is_CPP_Class (Root_Type (Def_Id))
8160 Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
8163 Set_Is_CPP_Class (Def_Id);
8165 -- Imported CPP types must not have discriminants (because C++
8166 -- classes do not have discriminants).
8168 if Has_Discriminants (Def_Id) then
8170 ("imported 'C'P'P type cannot have discriminants",
8171 First (Discriminant_Specifications
8172 (Declaration_Node (Def_Id))));
8175 -- Check that components of imported CPP types do not have default
8176 -- expressions. For private types this check is performed when the
8177 -- full view is analyzed (see Process_Full_View).
8179 if not Is_Private_Type (Def_Id) then
8180 Check_CPP_Type_Has_No_Defaults (Def_Id);
8183 -- Import a CPP exception
8185 elsif C = Convention_CPP
8186 and then Ekind (Def_Id) = E_Exception
8190 ("'External_'Name arguments is required for 'Cpp exception",
8193 -- As only a string is allowed, Check_Arg_Is_External_Name
8195 Check_Arg_Is_Static_Expression (Arg3, Standard_String);
8198 if Present (Arg4) then
8200 ("Link_Name argument not allowed for imported Cpp exception",
8204 -- Do not call Set_Interface_Name as the name of the exception
8205 -- shouldn't be modified (and in particular it shouldn't be
8206 -- the External_Name). For exceptions, the External_Name is the
8207 -- name of the RTTI structure.
8209 -- ??? Emit an error if pragma Import/Export_Exception is present
8211 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
8213 Check_Arg_Count (3);
8214 Check_Arg_Is_Static_Expression (Arg3, Standard_String);
8216 Process_Import_Predefined_Type;
8220 ("second argument of pragma% must be object, subprogram "
8221 & "or incomplete type",
8225 -- If this pragma applies to a compilation unit, then the unit, which
8226 -- is a subprogram, does not require (or allow) a body. We also do
8227 -- not need to elaborate imported procedures.
8229 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
8231 Cunit : constant Node_Id := Parent (Parent (N));
8233 Set_Body_Required (Cunit, False);
8236 end Process_Import_Or_Interface;
8238 --------------------
8239 -- Process_Inline --
8240 --------------------
8242 procedure Process_Inline (Status : Inline_Status) is
8249 Effective : Boolean := False;
8250 -- Set True if inline has some effect, i.e. if there is at least one
8251 -- subprogram set as inlined as a result of the use of the pragma.
8253 procedure Make_Inline (Subp : Entity_Id);
8254 -- Subp is the defining unit name of the subprogram declaration. Set
8255 -- the flag, as well as the flag in the corresponding body, if there
8258 procedure Set_Inline_Flags (Subp : Entity_Id);
8259 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
8260 -- Has_Pragma_Inline_Always for the Inline_Always case.
8262 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
8263 -- Returns True if it can be determined at this stage that inlining
8264 -- is not possible, for example if the body is available and contains
8265 -- exception handlers, we prevent inlining, since otherwise we can
8266 -- get undefined symbols at link time. This function also emits a
8267 -- warning if front-end inlining is enabled and the pragma appears
8270 -- ??? is business with link symbols still valid, or does it relate
8271 -- to front end ZCX which is being phased out ???
8273 ---------------------------
8274 -- Inlining_Not_Possible --
8275 ---------------------------
8277 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
8278 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
8282 if Nkind (Decl) = N_Subprogram_Body then
8283 Stats := Handled_Statement_Sequence (Decl);
8284 return Present (Exception_Handlers (Stats))
8285 or else Present (At_End_Proc (Stats));
8287 elsif Nkind (Decl) = N_Subprogram_Declaration
8288 and then Present (Corresponding_Body (Decl))
8290 if Front_End_Inlining
8291 and then Analyzed (Corresponding_Body (Decl))
8293 Error_Msg_N ("pragma appears too late, ignored??", N);
8296 -- If the subprogram is a renaming as body, the body is just a
8297 -- call to the renamed subprogram, and inlining is trivially
8301 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
8302 N_Subprogram_Renaming_Declaration
8308 Handled_Statement_Sequence
8309 (Unit_Declaration_Node (Corresponding_Body (Decl)));
8312 Present (Exception_Handlers (Stats))
8313 or else Present (At_End_Proc (Stats));
8317 -- If body is not available, assume the best, the check is
8318 -- performed again when compiling enclosing package bodies.
8322 end Inlining_Not_Possible;
8328 procedure Make_Inline (Subp : Entity_Id) is
8329 Kind : constant Entity_Kind := Ekind (Subp);
8330 Inner_Subp : Entity_Id := Subp;
8333 -- Ignore if bad type, avoid cascaded error
8335 if Etype (Subp) = Any_Type then
8339 -- Ignore if all inlining is suppressed
8341 elsif Suppress_All_Inlining then
8345 -- If inlining is not possible, for now do not treat as an error
8347 elsif Status /= Suppressed
8348 and then Inlining_Not_Possible (Subp)
8353 -- Here we have a candidate for inlining, but we must exclude
8354 -- derived operations. Otherwise we would end up trying to inline
8355 -- a phantom declaration, and the result would be to drag in a
8356 -- body which has no direct inlining associated with it. That
8357 -- would not only be inefficient but would also result in the
8358 -- backend doing cross-unit inlining in cases where it was
8359 -- definitely inappropriate to do so.
8361 -- However, a simple Comes_From_Source test is insufficient, since
8362 -- we do want to allow inlining of generic instances which also do
8363 -- not come from source. We also need to recognize specs generated
8364 -- by the front-end for bodies that carry the pragma. Finally,
8365 -- predefined operators do not come from source but are not
8366 -- inlineable either.
8368 elsif Is_Generic_Instance (Subp)
8369 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
8373 elsif not Comes_From_Source (Subp)
8374 and then Scope (Subp) /= Standard_Standard
8380 -- The referenced entity must either be the enclosing entity, or
8381 -- an entity declared within the current open scope.
8383 if Present (Scope (Subp))
8384 and then Scope (Subp) /= Current_Scope
8385 and then Subp /= Current_Scope
8388 ("argument of% must be entity in current scope", Assoc);
8392 -- Processing for procedure, operator or function. If subprogram
8393 -- is aliased (as for an instance) indicate that the renamed
8394 -- entity (if declared in the same unit) is inlined.
8396 if Is_Subprogram (Subp) then
8397 Inner_Subp := Ultimate_Alias (Inner_Subp);
8399 if In_Same_Source_Unit (Subp, Inner_Subp) then
8400 Set_Inline_Flags (Inner_Subp);
8402 Decl := Parent (Parent (Inner_Subp));
8404 if Nkind (Decl) = N_Subprogram_Declaration
8405 and then Present (Corresponding_Body (Decl))
8407 Set_Inline_Flags (Corresponding_Body (Decl));
8409 elsif Is_Generic_Instance (Subp) then
8411 -- Indicate that the body needs to be created for
8412 -- inlining subsequent calls. The instantiation node
8413 -- follows the declaration of the wrapper package
8416 if Scope (Subp) /= Standard_Standard
8418 Need_Subprogram_Instance_Body
8419 (Next (Unit_Declaration_Node (Scope (Alias (Subp)))),
8425 -- Inline is a program unit pragma (RM 10.1.5) and cannot
8426 -- appear in a formal part to apply to a formal subprogram.
8427 -- Do not apply check within an instance or a formal package
8428 -- the test will have been applied to the original generic.
8430 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
8431 and then List_Containing (Decl) = List_Containing (N)
8432 and then not In_Instance
8435 ("Inline cannot apply to a formal subprogram", N);
8437 -- If Subp is a renaming, it is the renamed entity that
8438 -- will appear in any call, and be inlined. However, for
8439 -- ASIS uses it is convenient to indicate that the renaming
8440 -- itself is an inlined subprogram, so that some gnatcheck
8441 -- rules can be applied in the absence of expansion.
8443 elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then
8444 Set_Inline_Flags (Subp);
8450 -- For a generic subprogram set flag as well, for use at the point
8451 -- of instantiation, to determine whether the body should be
8454 elsif Is_Generic_Subprogram (Subp) then
8455 Set_Inline_Flags (Subp);
8458 -- Literals are by definition inlined
8460 elsif Kind = E_Enumeration_Literal then
8463 -- Anything else is an error
8467 ("expect subprogram name for pragma%", Assoc);
8471 ----------------------
8472 -- Set_Inline_Flags --
8473 ----------------------
8475 procedure Set_Inline_Flags (Subp : Entity_Id) is
8477 -- First set the Has_Pragma_XXX flags and issue the appropriate
8478 -- errors and warnings for suspicious combinations.
8480 if Prag_Id = Pragma_No_Inline then
8481 if Has_Pragma_Inline_Always (Subp) then
8483 ("Inline_Always and No_Inline are mutually exclusive", N);
8484 elsif Has_Pragma_Inline (Subp) then
8486 ("Inline and No_Inline both specified for& ??",
8487 N, Entity (Subp_Id));
8490 Set_Has_Pragma_No_Inline (Subp);
8492 if Prag_Id = Pragma_Inline_Always then
8493 if Has_Pragma_No_Inline (Subp) then
8495 ("Inline_Always and No_Inline are mutually exclusive",
8499 Set_Has_Pragma_Inline_Always (Subp);
8501 if Has_Pragma_No_Inline (Subp) then
8503 ("Inline and No_Inline both specified for& ??",
8504 N, Entity (Subp_Id));
8508 if not Has_Pragma_Inline (Subp) then
8509 Set_Has_Pragma_Inline (Subp);
8514 -- Then adjust the Is_Inlined flag. It can never be set if the
8515 -- subprogram is subject to pragma No_Inline.
8519 Set_Is_Inlined (Subp, False);
8523 if not Has_Pragma_No_Inline (Subp) then
8524 Set_Is_Inlined (Subp, True);
8527 end Set_Inline_Flags;
8529 -- Start of processing for Process_Inline
8532 Check_No_Identifiers;
8533 Check_At_Least_N_Arguments (1);
8535 if Status = Enabled then
8536 Inline_Processing_Required := True;
8540 while Present (Assoc) loop
8541 Subp_Id := Get_Pragma_Arg (Assoc);
8545 if Is_Entity_Name (Subp_Id) then
8546 Subp := Entity (Subp_Id);
8548 if Subp = Any_Id then
8550 -- If previous error, avoid cascaded errors
8552 Check_Error_Detected;
8559 -- For the pragma case, climb homonym chain. This is
8560 -- what implements allowing the pragma in the renaming
8561 -- case, with the result applying to the ancestors, and
8562 -- also allows Inline to apply to all previous homonyms.
8564 if not From_Aspect_Specification (N) then
8565 while Present (Homonym (Subp))
8566 and then Scope (Homonym (Subp)) = Current_Scope
8568 Make_Inline (Homonym (Subp));
8569 Subp := Homonym (Subp);
8577 ("inappropriate argument for pragma%", Assoc);
8580 and then Warn_On_Redundant_Constructs
8581 and then not (Status = Suppressed or else Suppress_All_Inlining)
8583 if Inlining_Not_Possible (Subp) then
8585 ("pragma Inline for& is ignored?r?",
8586 N, Entity (Subp_Id));
8589 ("pragma Inline for& is redundant?r?",
8590 N, Entity (Subp_Id));
8598 ----------------------------
8599 -- Process_Interface_Name --
8600 ----------------------------
8602 procedure Process_Interface_Name
8603 (Subprogram_Def : Entity_Id;
8609 String_Val : String_Id;
8611 procedure Check_Form_Of_Interface_Name
8613 Ext_Name_Case : Boolean);
8614 -- SN is a string literal node for an interface name. This routine
8615 -- performs some minimal checks that the name is reasonable. In
8616 -- particular that no spaces or other obviously incorrect characters
8617 -- appear. This is only a warning, since any characters are allowed.
8618 -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
8620 ----------------------------------
8621 -- Check_Form_Of_Interface_Name --
8622 ----------------------------------
8624 procedure Check_Form_Of_Interface_Name
8626 Ext_Name_Case : Boolean)
8628 S : constant String_Id := Strval (Expr_Value_S (SN));
8629 SL : constant Nat := String_Length (S);
8634 Error_Msg_N ("interface name cannot be null string", SN);
8637 for J in 1 .. SL loop
8638 C := Get_String_Char (S, J);
8640 -- Look for dubious character and issue unconditional warning.
8641 -- Definitely dubious if not in character range.
8643 if not In_Character_Range (C)
8645 -- For all cases except CLI target,
8646 -- commas, spaces and slashes are dubious (in CLI, we use
8647 -- commas and backslashes in external names to specify
8648 -- assembly version and public key, while slashes and spaces
8649 -- can be used in names to mark nested classes and
8652 or else ((not Ext_Name_Case or else VM_Target /= CLI_Target)
8653 and then (Get_Character (C) = ','
8655 Get_Character (C) = '\'))
8656 or else (VM_Target /= CLI_Target
8657 and then (Get_Character (C) = ' '
8659 Get_Character (C) = '/'))
8662 ("??interface name contains illegal character",
8663 Sloc (SN) + Source_Ptr (J));
8666 end Check_Form_Of_Interface_Name;
8668 -- Start of processing for Process_Interface_Name
8671 if No (Link_Arg) then
8672 if No (Ext_Arg) then
8673 if VM_Target = CLI_Target
8674 and then Ekind (Subprogram_Def) = E_Package
8675 and then Nkind (Parent (Subprogram_Def)) =
8676 N_Package_Specification
8677 and then Present (Generic_Parent (Parent (Subprogram_Def)))
8682 (Generic_Parent (Parent (Subprogram_Def))));
8687 elsif Chars (Ext_Arg) = Name_Link_Name then
8689 Link_Nam := Expression (Ext_Arg);
8692 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
8693 Ext_Nam := Expression (Ext_Arg);
8698 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
8699 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
8700 Ext_Nam := Expression (Ext_Arg);
8701 Link_Nam := Expression (Link_Arg);
8704 -- Check expressions for external name and link name are static
8706 if Present (Ext_Nam) then
8707 Check_Arg_Is_Static_Expression (Ext_Nam, Standard_String);
8708 Check_Form_Of_Interface_Name (Ext_Nam, Ext_Name_Case => True);
8710 -- Verify that external name is not the name of a local entity,
8711 -- which would hide the imported one and could lead to run-time
8712 -- surprises. The problem can only arise for entities declared in
8713 -- a package body (otherwise the external name is fully qualified
8714 -- and will not conflict).
8722 if Prag_Id = Pragma_Import then
8723 String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam)));
8725 E := Entity_Id (Get_Name_Table_Info (Nam));
8727 if Nam /= Chars (Subprogram_Def)
8728 and then Present (E)
8729 and then not Is_Overloadable (E)
8730 and then Is_Immediately_Visible (E)
8731 and then not Is_Imported (E)
8732 and then Ekind (Scope (E)) = E_Package
8735 while Present (Par) loop
8736 if Nkind (Par) = N_Package_Body then
8737 Error_Msg_Sloc := Sloc (E);
8739 ("imported entity is hidden by & declared#",
8744 Par := Parent (Par);
8751 if Present (Link_Nam) then
8752 Check_Arg_Is_Static_Expression (Link_Nam, Standard_String);
8753 Check_Form_Of_Interface_Name (Link_Nam, Ext_Name_Case => False);
8756 -- If there is no link name, just set the external name
8758 if No (Link_Nam) then
8759 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
8761 -- For the Link_Name case, the given literal is preceded by an
8762 -- asterisk, which indicates to GCC that the given name should be
8763 -- taken literally, and in particular that no prepending of
8764 -- underlines should occur, even in systems where this is the
8770 if VM_Target = No_VM then
8771 Store_String_Char (Get_Char_Code ('*'));
8774 String_Val := Strval (Expr_Value_S (Link_Nam));
8775 Store_String_Chars (String_Val);
8777 Make_String_Literal (Sloc (Link_Nam),
8778 Strval => End_String);
8781 -- Set the interface name. If the entity is a generic instance, use
8782 -- its alias, which is the callable entity.
8784 if Is_Generic_Instance (Subprogram_Def) then
8785 Set_Encoded_Interface_Name
8786 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
8788 Set_Encoded_Interface_Name
8789 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
8792 -- We allow duplicated export names in CIL/Java, as they are always
8793 -- enclosed in a namespace that differentiates them, and overloaded
8794 -- entities are supported by the VM.
8796 if Convention (Subprogram_Def) /= Convention_CIL
8798 Convention (Subprogram_Def) /= Convention_Java
8800 Check_Duplicated_Export_Name (Link_Nam);
8802 end Process_Interface_Name;
8804 -----------------------------------------
8805 -- Process_Interrupt_Or_Attach_Handler --
8806 -----------------------------------------
8808 procedure Process_Interrupt_Or_Attach_Handler is
8809 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
8810 Handler_Proc : constant Entity_Id := Entity (Arg1_X);
8811 Proc_Scope : constant Entity_Id := Scope (Handler_Proc);
8814 Set_Is_Interrupt_Handler (Handler_Proc);
8816 -- If the pragma is not associated with a handler procedure within a
8817 -- protected type, then it must be for a nonprotected procedure for
8818 -- the AAMP target, in which case we don't associate a representation
8819 -- item with the procedure's scope.
8821 if Ekind (Proc_Scope) = E_Protected_Type then
8822 if Prag_Id = Pragma_Interrupt_Handler
8824 Prag_Id = Pragma_Attach_Handler
8826 Record_Rep_Item (Proc_Scope, N);
8829 end Process_Interrupt_Or_Attach_Handler;
8831 --------------------------------------------------
8832 -- Process_Restrictions_Or_Restriction_Warnings --
8833 --------------------------------------------------
8835 -- Note: some of the simple identifier cases were handled in par-prag,
8836 -- but it is harmless (and more straightforward) to simply handle all
8837 -- cases here, even if it means we repeat a bit of work in some cases.
8839 procedure Process_Restrictions_Or_Restriction_Warnings
8843 R_Id : Restriction_Id;
8849 -- Ignore all Restrictions pragmas in CodePeer mode
8851 if CodePeer_Mode then
8855 Check_Ada_83_Warning;
8856 Check_At_Least_N_Arguments (1);
8857 Check_Valid_Configuration_Pragma;
8860 while Present (Arg) loop
8862 Expr := Get_Pragma_Arg (Arg);
8864 -- Case of no restriction identifier present
8866 if Id = No_Name then
8867 if Nkind (Expr) /= N_Identifier then
8869 ("invalid form for restriction", Arg);
8874 (Process_Restriction_Synonyms (Expr));
8876 if R_Id not in All_Boolean_Restrictions then
8877 Error_Msg_Name_1 := Pname;
8879 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
8881 -- Check for possible misspelling
8883 for J in Restriction_Id loop
8885 Rnm : constant String := Restriction_Id'Image (J);
8888 Name_Buffer (1 .. Rnm'Length) := Rnm;
8889 Name_Len := Rnm'Length;
8890 Set_Casing (All_Lower_Case);
8892 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
8894 (Identifier_Casing (Current_Source_File));
8895 Error_Msg_String (1 .. Rnm'Length) :=
8896 Name_Buffer (1 .. Name_Len);
8897 Error_Msg_Strlen := Rnm'Length;
8898 Error_Msg_N -- CODEFIX
8899 ("\possible misspelling of ""~""",
8900 Get_Pragma_Arg (Arg));
8909 if Implementation_Restriction (R_Id) then
8910 Check_Restriction (No_Implementation_Restrictions, Arg);
8913 -- Special processing for No_Elaboration_Code restriction
8915 if R_Id = No_Elaboration_Code then
8917 -- Restriction is only recognized within a configuration
8918 -- pragma file, or within a unit of the main extended
8919 -- program. Note: the test for Main_Unit is needed to
8920 -- properly include the case of configuration pragma files.
8922 if not (Current_Sem_Unit = Main_Unit
8923 or else In_Extended_Main_Source_Unit (N))
8927 -- Don't allow in a subunit unless already specified in
8930 elsif Nkind (Parent (N)) = N_Compilation_Unit
8931 and then Nkind (Unit (Parent (N))) = N_Subunit
8932 and then not Restriction_Active (No_Elaboration_Code)
8935 ("invalid specification of ""No_Elaboration_Code""",
8938 ("\restriction cannot be specified in a subunit", N);
8940 ("\unless also specified in body or spec", N);
8943 -- If we have a No_Elaboration_Code pragma that we
8944 -- accept, then it needs to be added to the configuration
8945 -- restrcition set so that we get proper application to
8946 -- other units in the main extended source as required.
8949 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
8953 -- If this is a warning, then set the warning unless we already
8954 -- have a real restriction active (we never want a warning to
8955 -- override a real restriction).
8958 if not Restriction_Active (R_Id) then
8959 Set_Restriction (R_Id, N);
8960 Restriction_Warnings (R_Id) := True;
8963 -- If real restriction case, then set it and make sure that the
8964 -- restriction warning flag is off, since a real restriction
8965 -- always overrides a warning.
8968 Set_Restriction (R_Id, N);
8969 Restriction_Warnings (R_Id) := False;
8972 -- Check for obsolescent restrictions in Ada 2005 mode
8975 and then Ada_Version >= Ada_2005
8976 and then (R_Id = No_Asynchronous_Control
8978 R_Id = No_Unchecked_Deallocation
8980 R_Id = No_Unchecked_Conversion)
8982 Check_Restriction (No_Obsolescent_Features, N);
8985 -- A very special case that must be processed here: pragma
8986 -- Restrictions (No_Exceptions) turns off all run-time
8987 -- checking. This is a bit dubious in terms of the formal
8988 -- language definition, but it is what is intended by RM
8989 -- H.4(12). Restriction_Warnings never affects generated code
8990 -- so this is done only in the real restriction case.
8992 -- Atomic_Synchronization is not a real check, so it is not
8993 -- affected by this processing).
8995 if R_Id = No_Exceptions and then not Warn then
8996 for J in Scope_Suppress.Suppress'Range loop
8997 if J /= Atomic_Synchronization then
8998 Scope_Suppress.Suppress (J) := True;
9003 -- Case of No_Dependence => unit-name. Note that the parser
9004 -- already made the necessary entry in the No_Dependence table.
9006 elsif Id = Name_No_Dependence then
9007 if not OK_No_Dependence_Unit_Name (Expr) then
9011 -- Case of No_Specification_Of_Aspect => Identifier.
9013 elsif Id = Name_No_Specification_Of_Aspect then
9018 if Nkind (Expr) /= N_Identifier then
9021 A_Id := Get_Aspect_Id (Chars (Expr));
9024 if A_Id = No_Aspect then
9025 Error_Pragma_Arg ("invalid restriction name", Arg);
9027 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
9031 elsif Id = Name_No_Use_Of_Attribute then
9032 if Nkind (Expr) /= N_Identifier
9033 or else not Is_Attribute_Name (Chars (Expr))
9035 Error_Msg_N ("unknown attribute name?", Expr);
9038 Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
9041 elsif Id = Name_No_Use_Of_Pragma then
9042 if Nkind (Expr) /= N_Identifier
9043 or else not Is_Pragma_Name (Chars (Expr))
9045 Error_Msg_N ("unknown pragma name?", Expr);
9048 Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
9051 -- All other cases of restriction identifier present
9054 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
9055 Analyze_And_Resolve (Expr, Any_Integer);
9057 if R_Id not in All_Parameter_Restrictions then
9059 ("invalid restriction parameter identifier", Arg);
9061 elsif not Is_OK_Static_Expression (Expr) then
9062 Flag_Non_Static_Expr
9063 ("value must be static expression!", Expr);
9066 elsif not Is_Integer_Type (Etype (Expr))
9067 or else Expr_Value (Expr) < 0
9070 ("value must be non-negative integer", Arg);
9073 -- Restriction pragma is active
9075 Val := Expr_Value (Expr);
9077 if not UI_Is_In_Int_Range (Val) then
9079 ("pragma ignored, value too large??", Arg);
9082 -- Warning case. If the real restriction is active, then we
9083 -- ignore the request, since warning never overrides a real
9084 -- restriction. Otherwise we set the proper warning. Note that
9085 -- this circuit sets the warning again if it is already set,
9086 -- which is what we want, since the constant may have changed.
9089 if not Restriction_Active (R_Id) then
9091 (R_Id, N, Integer (UI_To_Int (Val)));
9092 Restriction_Warnings (R_Id) := True;
9095 -- Real restriction case, set restriction and make sure warning
9096 -- flag is off since real restriction always overrides warning.
9099 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
9100 Restriction_Warnings (R_Id) := False;
9106 end Process_Restrictions_Or_Restriction_Warnings;
9108 ---------------------------------
9109 -- Process_Suppress_Unsuppress --
9110 ---------------------------------
9112 -- Note: this procedure makes entries in the check suppress data
9113 -- structures managed by Sem. See spec of package Sem for full
9114 -- details on how we handle recording of check suppression.
9116 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
9121 In_Package_Spec : constant Boolean :=
9122 Is_Package_Or_Generic_Package (Current_Scope)
9123 and then not In_Package_Body (Current_Scope);
9125 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
9126 -- Used to suppress a single check on the given entity
9128 --------------------------------
9129 -- Suppress_Unsuppress_Echeck --
9130 --------------------------------
9132 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
9134 -- Check for error of trying to set atomic synchronization for
9135 -- a non-atomic variable.
9137 if C = Atomic_Synchronization
9138 and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
9141 ("pragma & requires atomic type or variable",
9142 Pragma_Identifier (Original_Node (N)));
9145 Set_Checks_May_Be_Suppressed (E);
9147 if In_Package_Spec then
9148 Push_Global_Suppress_Stack_Entry
9151 Suppress => Suppress_Case);
9153 Push_Local_Suppress_Stack_Entry
9156 Suppress => Suppress_Case);
9159 -- If this is a first subtype, and the base type is distinct,
9160 -- then also set the suppress flags on the base type.
9162 if Is_First_Subtype (E) and then Etype (E) /= E then
9163 Suppress_Unsuppress_Echeck (Etype (E), C);
9165 end Suppress_Unsuppress_Echeck;
9167 -- Start of processing for Process_Suppress_Unsuppress
9170 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
9171 -- on user code: we want to generate checks for analysis purposes, as
9172 -- set respectively by -gnatC and -gnatd.F
9174 if (CodePeer_Mode or GNATprove_Mode)
9175 and then Comes_From_Source (N)
9180 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
9181 -- declarative part or a package spec (RM 11.5(5)).
9183 if not Is_Configuration_Pragma then
9184 Check_Is_In_Decl_Part_Or_Package_Spec;
9187 Check_At_Least_N_Arguments (1);
9188 Check_At_Most_N_Arguments (2);
9189 Check_No_Identifier (Arg1);
9190 Check_Arg_Is_Identifier (Arg1);
9192 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
9194 if C = No_Check_Id then
9196 ("argument of pragma% is not valid check name", Arg1);
9199 if Arg_Count = 1 then
9201 -- Make an entry in the local scope suppress table. This is the
9202 -- table that directly shows the current value of the scope
9203 -- suppress check for any check id value.
9205 if C = All_Checks then
9207 -- For All_Checks, we set all specific predefined checks with
9208 -- the exception of Elaboration_Check, which is handled
9209 -- specially because of not wanting All_Checks to have the
9210 -- effect of deactivating static elaboration order processing.
9211 -- Atomic_Synchronization is also not affected, since this is
9212 -- not a real check.
9214 for J in Scope_Suppress.Suppress'Range loop
9215 if J /= Elaboration_Check
9217 J /= Atomic_Synchronization
9219 Scope_Suppress.Suppress (J) := Suppress_Case;
9223 -- If not All_Checks, and predefined check, then set appropriate
9224 -- scope entry. Note that we will set Elaboration_Check if this
9225 -- is explicitly specified. Atomic_Synchronization is allowed
9226 -- only if internally generated and entity is atomic.
9228 elsif C in Predefined_Check_Id
9229 and then (not Comes_From_Source (N)
9230 or else C /= Atomic_Synchronization)
9232 Scope_Suppress.Suppress (C) := Suppress_Case;
9235 -- Also make an entry in the Local_Entity_Suppress table
9237 Push_Local_Suppress_Stack_Entry
9240 Suppress => Suppress_Case);
9242 -- Case of two arguments present, where the check is suppressed for
9243 -- a specified entity (given as the second argument of the pragma)
9246 -- This is obsolescent in Ada 2005 mode
9248 if Ada_Version >= Ada_2005 then
9249 Check_Restriction (No_Obsolescent_Features, Arg2);
9252 Check_Optional_Identifier (Arg2, Name_On);
9253 E_Id := Get_Pragma_Arg (Arg2);
9256 if not Is_Entity_Name (E_Id) then
9258 ("second argument of pragma% must be entity name", Arg2);
9267 -- Enforce RM 11.5(7) which requires that for a pragma that
9268 -- appears within a package spec, the named entity must be
9269 -- within the package spec. We allow the package name itself
9270 -- to be mentioned since that makes sense, although it is not
9271 -- strictly allowed by 11.5(7).
9274 and then E /= Current_Scope
9275 and then Scope (E) /= Current_Scope
9278 ("entity in pragma% is not in package spec (RM 11.5(7))",
9282 -- Loop through homonyms. As noted below, in the case of a package
9283 -- spec, only homonyms within the package spec are considered.
9286 Suppress_Unsuppress_Echeck (E, C);
9288 if Is_Generic_Instance (E)
9289 and then Is_Subprogram (E)
9290 and then Present (Alias (E))
9292 Suppress_Unsuppress_Echeck (Alias (E), C);
9295 -- Move to next homonym if not aspect spec case
9297 exit when From_Aspect_Specification (N);
9301 -- If we are within a package specification, the pragma only
9302 -- applies to homonyms in the same scope.
9304 exit when In_Package_Spec
9305 and then Scope (E) /= Current_Scope;
9308 end Process_Suppress_Unsuppress;
9314 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
9316 if Is_Imported (E) then
9318 ("cannot export entity& that was previously imported", Arg);
9320 elsif Present (Address_Clause (E))
9321 and then not Relaxed_RM_Semantics
9324 ("cannot export entity& that has an address clause", Arg);
9327 Set_Is_Exported (E);
9329 -- Generate a reference for entity explicitly, because the
9330 -- identifier may be overloaded and name resolution will not
9333 Generate_Reference (E, Arg);
9335 -- Deal with exporting non-library level entity
9337 if not Is_Library_Level_Entity (E) then
9339 -- Not allowed at all for subprograms
9341 if Is_Subprogram (E) then
9342 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
9344 -- Otherwise set public and statically allocated
9348 Set_Is_Statically_Allocated (E);
9350 -- Warn if the corresponding W flag is set and the pragma comes
9351 -- from source. The latter may not be true e.g. on VMS where we
9352 -- expand export pragmas for exception codes associated with
9353 -- imported or exported exceptions. We do not want to generate
9354 -- a warning for something that the user did not write.
9356 if Warn_On_Export_Import
9357 and then Comes_From_Source (Arg)
9360 ("?x?& has been made static as a result of Export",
9363 ("\?x?this usage is non-standard and non-portable",
9369 if Warn_On_Export_Import and then Is_Type (E) then
9370 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
9373 if Warn_On_Export_Import and Inside_A_Generic then
9375 ("all instances of& will have the same external name?x?",
9380 ----------------------------------------------
9381 -- Set_Extended_Import_Export_External_Name --
9382 ----------------------------------------------
9384 procedure Set_Extended_Import_Export_External_Name
9385 (Internal_Ent : Entity_Id;
9386 Arg_External : Node_Id)
9388 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
9392 if No (Arg_External) then
9396 Check_Arg_Is_External_Name (Arg_External);
9398 if Nkind (Arg_External) = N_String_Literal then
9399 if String_Length (Strval (Arg_External)) = 0 then
9402 New_Name := Adjust_External_Name_Case (Arg_External);
9405 elsif Nkind (Arg_External) = N_Identifier then
9406 New_Name := Get_Default_External_Name (Arg_External);
9408 -- Check_Arg_Is_External_Name should let through only identifiers and
9409 -- string literals or static string expressions (which are folded to
9410 -- string literals).
9413 raise Program_Error;
9416 -- If we already have an external name set (by a prior normal Import
9417 -- or Export pragma), then the external names must match
9419 if Present (Interface_Name (Internal_Ent)) then
9421 -- Ignore mismatching names in CodePeer mode, to support some
9422 -- old compilers which would export the same procedure under
9423 -- different names, e.g:
9425 -- pragma Export_Procedure (P, "a");
9426 -- pragma Export_Procedure (P, "b");
9428 if CodePeer_Mode then
9432 Check_Matching_Internal_Names : declare
9433 S1 : constant String_Id := Strval (Old_Name);
9434 S2 : constant String_Id := Strval (New_Name);
9437 pragma No_Return (Mismatch);
9438 -- Called if names do not match
9444 procedure Mismatch is
9446 Error_Msg_Sloc := Sloc (Old_Name);
9448 ("external name does not match that given #",
9452 -- Start of processing for Check_Matching_Internal_Names
9455 if String_Length (S1) /= String_Length (S2) then
9459 for J in 1 .. String_Length (S1) loop
9460 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
9465 end Check_Matching_Internal_Names;
9467 -- Otherwise set the given name
9470 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
9471 Check_Duplicated_Export_Name (New_Name);
9473 end Set_Extended_Import_Export_External_Name;
9479 procedure Set_Imported (E : Entity_Id) is
9481 -- Error message if already imported or exported
9483 if Is_Exported (E) or else Is_Imported (E) then
9485 -- Error if being set Exported twice
9487 if Is_Exported (E) then
9488 Error_Msg_NE ("entity& was previously exported", N, E);
9490 -- Ignore error in CodePeer mode where we treat all imported
9491 -- subprograms as unknown.
9493 elsif CodePeer_Mode then
9496 -- OK if Import/Interface case
9498 elsif Import_Interface_Present (N) then
9501 -- Error if being set Imported twice
9504 Error_Msg_NE ("entity& was previously imported", N, E);
9507 Error_Msg_Name_1 := Pname;
9509 ("\(pragma% applies to all previous entities)", N);
9511 Error_Msg_Sloc := Sloc (E);
9512 Error_Msg_NE ("\import not allowed for& declared#", N, E);
9514 -- Here if not previously imported or exported, OK to import
9517 Set_Is_Imported (E);
9519 -- For subprogram, set Import_Pragma field
9521 if Is_Subprogram (E) then
9522 Set_Import_Pragma (E, N);
9525 -- If the entity is an object that is not at the library level,
9526 -- then it is statically allocated. We do not worry about objects
9527 -- with address clauses in this context since they are not really
9528 -- imported in the linker sense.
9531 and then not Is_Library_Level_Entity (E)
9532 and then No (Address_Clause (E))
9534 Set_Is_Statically_Allocated (E);
9541 -------------------------
9542 -- Set_Mechanism_Value --
9543 -------------------------
9545 -- Note: the mechanism name has not been analyzed (and cannot indeed be
9546 -- analyzed, since it is semantic nonsense), so we get it in the exact
9547 -- form created by the parser.
9549 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
9552 Mech_Name_Id : Name_Id;
9554 procedure Bad_Class;
9555 pragma No_Return (Bad_Class);
9556 -- Signal bad descriptor class name
9558 procedure Bad_Mechanism;
9559 pragma No_Return (Bad_Mechanism);
9560 -- Signal bad mechanism name
9566 procedure Bad_Class is
9568 Error_Pragma_Arg ("unrecognized descriptor class name", Class);
9571 -------------------------
9572 -- Bad_Mechanism_Value --
9573 -------------------------
9575 procedure Bad_Mechanism is
9577 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
9580 -- Start of processing for Set_Mechanism_Value
9583 if Mechanism (Ent) /= Default_Mechanism then
9585 ("mechanism for & has already been set", Mech_Name, Ent);
9588 -- MECHANISM_NAME ::= value | reference | descriptor |
9591 if Nkind (Mech_Name) = N_Identifier then
9592 if Chars (Mech_Name) = Name_Value then
9593 Set_Mechanism (Ent, By_Copy);
9596 elsif Chars (Mech_Name) = Name_Reference then
9597 Set_Mechanism (Ent, By_Reference);
9600 elsif Chars (Mech_Name) = Name_Descriptor then
9601 Check_VMS (Mech_Name);
9603 -- Descriptor => Short_Descriptor if pragma was given
9605 if Short_Descriptors then
9606 Set_Mechanism (Ent, By_Short_Descriptor);
9608 Set_Mechanism (Ent, By_Descriptor);
9613 elsif Chars (Mech_Name) = Name_Short_Descriptor then
9614 Check_VMS (Mech_Name);
9615 Set_Mechanism (Ent, By_Short_Descriptor);
9618 elsif Chars (Mech_Name) = Name_Copy then
9620 ("bad mechanism name, Value assumed", Mech_Name);
9626 -- MECHANISM_NAME ::= descriptor (CLASS_NAME) |
9627 -- short_descriptor (CLASS_NAME)
9628 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
9630 -- Note: this form is parsed as an indexed component
9632 elsif Nkind (Mech_Name) = N_Indexed_Component then
9633 Class := First (Expressions (Mech_Name));
9635 if Nkind (Prefix (Mech_Name)) /= N_Identifier
9637 not Nam_In (Chars (Prefix (Mech_Name)), Name_Descriptor,
9638 Name_Short_Descriptor)
9639 or else Present (Next (Class))
9643 Mech_Name_Id := Chars (Prefix (Mech_Name));
9645 -- Change Descriptor => Short_Descriptor if pragma was given
9647 if Mech_Name_Id = Name_Descriptor
9648 and then Short_Descriptors
9650 Mech_Name_Id := Name_Short_Descriptor;
9654 -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) |
9655 -- short_descriptor (Class => CLASS_NAME)
9656 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
9658 -- Note: this form is parsed as a function call
9660 elsif Nkind (Mech_Name) = N_Function_Call then
9661 Param := First (Parameter_Associations (Mech_Name));
9663 if Nkind (Name (Mech_Name)) /= N_Identifier
9665 not Nam_In (Chars (Name (Mech_Name)), Name_Descriptor,
9666 Name_Short_Descriptor)
9667 or else Present (Next (Param))
9668 or else No (Selector_Name (Param))
9669 or else Chars (Selector_Name (Param)) /= Name_Class
9673 Class := Explicit_Actual_Parameter (Param);
9674 Mech_Name_Id := Chars (Name (Mech_Name));
9681 -- Fall through here with Class set to descriptor class name
9683 Check_VMS (Mech_Name);
9685 if Nkind (Class) /= N_Identifier then
9688 elsif Mech_Name_Id = Name_Descriptor
9689 and then Chars (Class) = Name_UBS
9691 Set_Mechanism (Ent, By_Descriptor_UBS);
9693 elsif Mech_Name_Id = Name_Descriptor
9694 and then Chars (Class) = Name_UBSB
9696 Set_Mechanism (Ent, By_Descriptor_UBSB);
9698 elsif Mech_Name_Id = Name_Descriptor
9699 and then Chars (Class) = Name_UBA
9701 Set_Mechanism (Ent, By_Descriptor_UBA);
9703 elsif Mech_Name_Id = Name_Descriptor
9704 and then Chars (Class) = Name_S
9706 Set_Mechanism (Ent, By_Descriptor_S);
9708 elsif Mech_Name_Id = Name_Descriptor
9709 and then Chars (Class) = Name_SB
9711 Set_Mechanism (Ent, By_Descriptor_SB);
9713 elsif Mech_Name_Id = Name_Descriptor
9714 and then Chars (Class) = Name_A
9716 Set_Mechanism (Ent, By_Descriptor_A);
9718 elsif Mech_Name_Id = Name_Descriptor
9719 and then Chars (Class) = Name_NCA
9721 Set_Mechanism (Ent, By_Descriptor_NCA);
9723 elsif Mech_Name_Id = Name_Short_Descriptor
9724 and then Chars (Class) = Name_UBS
9726 Set_Mechanism (Ent, By_Short_Descriptor_UBS);
9728 elsif Mech_Name_Id = Name_Short_Descriptor
9729 and then Chars (Class) = Name_UBSB
9731 Set_Mechanism (Ent, By_Short_Descriptor_UBSB);
9733 elsif Mech_Name_Id = Name_Short_Descriptor
9734 and then Chars (Class) = Name_UBA
9736 Set_Mechanism (Ent, By_Short_Descriptor_UBA);
9738 elsif Mech_Name_Id = Name_Short_Descriptor
9739 and then Chars (Class) = Name_S
9741 Set_Mechanism (Ent, By_Short_Descriptor_S);
9743 elsif Mech_Name_Id = Name_Short_Descriptor
9744 and then Chars (Class) = Name_SB
9746 Set_Mechanism (Ent, By_Short_Descriptor_SB);
9748 elsif Mech_Name_Id = Name_Short_Descriptor
9749 and then Chars (Class) = Name_A
9751 Set_Mechanism (Ent, By_Short_Descriptor_A);
9753 elsif Mech_Name_Id = Name_Short_Descriptor
9754 and then Chars (Class) = Name_NCA
9756 Set_Mechanism (Ent, By_Short_Descriptor_NCA);
9761 end Set_Mechanism_Value;
9763 --------------------------
9764 -- Set_Rational_Profile --
9765 --------------------------
9767 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
9768 -- and extension to the semantics of renaming declarations.
9770 procedure Set_Rational_Profile is
9772 Implicit_Packing := True;
9773 Overriding_Renamings := True;
9774 Use_VADS_Size := True;
9775 end Set_Rational_Profile;
9777 ---------------------------
9778 -- Set_Ravenscar_Profile --
9779 ---------------------------
9781 -- The tasks to be done here are
9783 -- Set required policies
9785 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9786 -- pragma Locking_Policy (Ceiling_Locking)
9788 -- Set Detect_Blocking mode
9790 -- Set required restrictions (see System.Rident for detailed list)
9792 -- Set the No_Dependence rules
9793 -- No_Dependence => Ada.Asynchronous_Task_Control
9794 -- No_Dependence => Ada.Calendar
9795 -- No_Dependence => Ada.Execution_Time.Group_Budget
9796 -- No_Dependence => Ada.Execution_Time.Timers
9797 -- No_Dependence => Ada.Task_Attributes
9798 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9800 procedure Set_Ravenscar_Profile (N : Node_Id) is
9801 Prefix_Entity : Entity_Id;
9802 Selector_Entity : Entity_Id;
9803 Prefix_Node : Node_Id;
9807 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9809 if Task_Dispatching_Policy /= ' '
9810 and then Task_Dispatching_Policy /= 'F'
9812 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
9813 Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
9815 -- Set the FIFO_Within_Priorities policy, but always preserve
9816 -- System_Location since we like the error message with the run time
9820 Task_Dispatching_Policy := 'F';
9822 if Task_Dispatching_Policy_Sloc /= System_Location then
9823 Task_Dispatching_Policy_Sloc := Loc;
9827 -- pragma Locking_Policy (Ceiling_Locking)
9829 if Locking_Policy /= ' '
9830 and then Locking_Policy /= 'C'
9832 Error_Msg_Sloc := Locking_Policy_Sloc;
9833 Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
9835 -- Set the Ceiling_Locking policy, but preserve System_Location since
9836 -- we like the error message with the run time name.
9839 Locking_Policy := 'C';
9841 if Locking_Policy_Sloc /= System_Location then
9842 Locking_Policy_Sloc := Loc;
9846 -- pragma Detect_Blocking
9848 Detect_Blocking := True;
9850 -- Set the corresponding restrictions
9852 Set_Profile_Restrictions
9853 (Ravenscar, N, Warn => Treat_Restrictions_As_Warnings);
9855 -- Set the No_Dependence restrictions
9857 -- The following No_Dependence restrictions:
9858 -- No_Dependence => Ada.Asynchronous_Task_Control
9859 -- No_Dependence => Ada.Calendar
9860 -- No_Dependence => Ada.Task_Attributes
9861 -- are already set by previous call to Set_Profile_Restrictions.
9863 -- Set the following restrictions which were added to Ada 2005:
9864 -- No_Dependence => Ada.Execution_Time.Group_Budget
9865 -- No_Dependence => Ada.Execution_Time.Timers
9867 if Ada_Version >= Ada_2005 then
9868 Name_Buffer (1 .. 3) := "ada";
9871 Prefix_Entity := Make_Identifier (Loc, Name_Find);
9873 Name_Buffer (1 .. 14) := "execution_time";
9876 Selector_Entity := Make_Identifier (Loc, Name_Find);
9879 Make_Selected_Component
9881 Prefix => Prefix_Entity,
9882 Selector_Name => Selector_Entity);
9884 Name_Buffer (1 .. 13) := "group_budgets";
9887 Selector_Entity := Make_Identifier (Loc, Name_Find);
9890 Make_Selected_Component
9892 Prefix => Prefix_Node,
9893 Selector_Name => Selector_Entity);
9895 Set_Restriction_No_Dependence
9897 Warn => Treat_Restrictions_As_Warnings,
9898 Profile => Ravenscar);
9900 Name_Buffer (1 .. 6) := "timers";
9903 Selector_Entity := Make_Identifier (Loc, Name_Find);
9906 Make_Selected_Component
9908 Prefix => Prefix_Node,
9909 Selector_Name => Selector_Entity);
9911 Set_Restriction_No_Dependence
9913 Warn => Treat_Restrictions_As_Warnings,
9914 Profile => Ravenscar);
9917 -- Set the following restrictions which was added to Ada 2012 (see
9919 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9921 if Ada_Version >= Ada_2012 then
9922 Name_Buffer (1 .. 6) := "system";
9925 Prefix_Entity := Make_Identifier (Loc, Name_Find);
9927 Name_Buffer (1 .. 15) := "multiprocessors";
9930 Selector_Entity := Make_Identifier (Loc, Name_Find);
9933 Make_Selected_Component
9935 Prefix => Prefix_Entity,
9936 Selector_Name => Selector_Entity);
9938 Name_Buffer (1 .. 19) := "dispatching_domains";
9941 Selector_Entity := Make_Identifier (Loc, Name_Find);
9944 Make_Selected_Component
9946 Prefix => Prefix_Node,
9947 Selector_Name => Selector_Entity);
9949 Set_Restriction_No_Dependence
9951 Warn => Treat_Restrictions_As_Warnings,
9952 Profile => Ravenscar);
9954 end Set_Ravenscar_Profile;
9956 -- Start of processing for Analyze_Pragma
9959 -- The following code is a defense against recursion. Not clear that
9960 -- this can happen legitimately, but perhaps some error situations
9961 -- can cause it, and we did see this recursion during testing.
9963 if Analyzed (N) then
9966 Set_Analyzed (N, True);
9969 -- Deal with unrecognized pragma
9971 Pname := Pragma_Name (N);
9973 if not Is_Pragma_Name (Pname) then
9974 if Warn_On_Unrecognized_Pragma then
9975 Error_Msg_Name_1 := Pname;
9976 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
9978 for PN in First_Pragma_Name .. Last_Pragma_Name loop
9979 if Is_Bad_Spelling_Of (Pname, PN) then
9980 Error_Msg_Name_1 := PN;
9981 Error_Msg_N -- CODEFIX
9982 ("\?g?possible misspelling of %!", Pragma_Identifier (N));
9991 -- Here to start processing for recognized pragma
9993 Prag_Id := Get_Pragma_Id (Pname);
9994 Pname := Original_Aspect_Name (N);
9996 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
9997 -- is already set, indicating that we have already checked the policy
9998 -- at the right point. This happens for example in the case of a pragma
9999 -- that is derived from an Aspect.
10001 if Is_Ignored (N) or else Is_Checked (N) then
10004 -- For a pragma that is a rewriting of another pragma, copy the
10005 -- Is_Checked/Is_Ignored status from the rewritten pragma.
10007 elsif Is_Rewrite_Substitution (N)
10008 and then Nkind (Original_Node (N)) = N_Pragma
10009 and then Original_Node (N) /= N
10011 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
10012 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
10014 -- Otherwise query the applicable policy at this point
10017 Check_Applicable_Policy (N);
10019 -- If pragma is disabled, rewrite as NULL and skip analysis
10021 if Is_Disabled (N) then
10022 Rewrite (N, Make_Null_Statement (Loc));
10028 -- Preset arguments
10036 if Present (Pragma_Argument_Associations (N)) then
10037 Arg_Count := List_Length (Pragma_Argument_Associations (N));
10038 Arg1 := First (Pragma_Argument_Associations (N));
10040 if Present (Arg1) then
10041 Arg2 := Next (Arg1);
10043 if Present (Arg2) then
10044 Arg3 := Next (Arg2);
10046 if Present (Arg3) then
10047 Arg4 := Next (Arg3);
10053 Check_Restriction_No_Use_Of_Pragma (N);
10055 -- An enumeration type defines the pragmas that are supported by the
10056 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
10057 -- into the corresponding enumeration value for the following case.
10065 -- pragma Abort_Defer;
10067 when Pragma_Abort_Defer =>
10069 Check_Arg_Count (0);
10071 -- The only required semantic processing is to check the
10072 -- placement. This pragma must appear at the start of the
10073 -- statement sequence of a handled sequence of statements.
10075 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
10076 or else N /= First (Statements (Parent (N)))
10081 --------------------
10082 -- Abstract_State --
10083 --------------------
10085 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
10087 -- ABSTRACT_STATE_LIST ::=
10089 -- | STATE_NAME_WITH_OPTIONS
10090 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS} )
10092 -- STATE_NAME_WITH_OPTIONS ::=
10094 -- | (STATE_NAME with OPTION_LIST)
10096 -- OPTION_LIST ::= OPTION {, OPTION}
10100 -- | NAME_VALUE_OPTION
10102 -- SIMPLE_OPTION ::= identifier
10104 -- NAME_VALUE_OPTION ::=
10105 -- Part_Of => ABSTRACT_STATE
10106 -- | External [=> EXTERNAL_PROPERTY_LIST]
10108 -- EXTERNAL_PROPERTY_LIST ::=
10109 -- EXTERNAL_PROPERTY
10110 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY} )
10112 -- EXTERNAL_PROPERTY ::=
10113 -- Async_Readers [=> boolean_EXPRESSION]
10114 -- | Async_Writers [=> boolean_EXPRESSION]
10115 -- | Effective_Reads [=> boolean_EXPRESSION]
10116 -- | Effective_Writes [=> boolean_EXPRESSION]
10117 -- others => boolean_EXPRESSION
10119 -- STATE_NAME ::= defining_identifier
10121 -- ABSTRACT_STATE ::= name
10123 when Pragma_Abstract_State => Abstract_State : declare
10125 -- Flags used to verify the consistency of states
10127 Non_Null_Seen : Boolean := False;
10128 Null_Seen : Boolean := False;
10130 Pack_Id : Entity_Id;
10131 -- Entity of related package when pragma Abstract_State appears
10133 procedure Analyze_Abstract_State (State : Node_Id);
10134 -- Verify the legality of a single state declaration. Create and
10135 -- decorate a state abstraction entity and introduce it into the
10136 -- visibility chain.
10138 procedure Check_State_Declaration_Syntax (State : Node_Id);
10139 -- Verify the syntex of state declaration State
10141 ----------------------------
10142 -- Analyze_Abstract_State --
10143 ----------------------------
10145 procedure Analyze_Abstract_State (State : Node_Id) is
10147 -- Flags used to verify the consistency of options
10149 AR_Seen : Boolean := False;
10150 AW_Seen : Boolean := False;
10151 ER_Seen : Boolean := False;
10152 EW_Seen : Boolean := False;
10153 External_Seen : Boolean := False;
10154 Others_Seen : Boolean := False;
10155 Part_Of_Seen : Boolean := False;
10157 -- Flags used to store the static value of all external states'
10160 AR_Val : Boolean := False;
10161 AW_Val : Boolean := False;
10162 ER_Val : Boolean := False;
10163 EW_Val : Boolean := False;
10165 State_Id : Entity_Id := Empty;
10166 -- The entity to be generated for the current state declaration
10168 procedure Analyze_External_Option (Opt : Node_Id);
10169 -- Verify the legality of option External
10171 procedure Analyze_External_Property
10173 Expr : Node_Id := Empty);
10174 -- Verify the legailty of a single external property. Prop
10175 -- denotes the external property. Expr is the expression used
10176 -- to set the property.
10178 procedure Analyze_Part_Of_Option (Opt : Node_Id);
10179 -- Verify the legality of option Part_Of
10181 procedure Check_Duplicate_Option
10183 Status : in out Boolean);
10184 -- Flag Status denotes whether a particular option has been
10185 -- seen while processing a state. This routine verifies that
10186 -- Opt is not a duplicate option and sets the flag Status
10187 -- (SPARK RM 7.1.4(1)).
10189 procedure Check_Duplicate_Property
10191 Status : in out Boolean);
10192 -- Flag Status denotes whether a particular property has been
10193 -- seen while processing option External. This routine verifies
10194 -- that Prop is not a duplicate property and sets flag Status.
10195 -- Opt is not a duplicate property and sets the flag Status.
10196 -- (SPARK RM 7.1.4(2))
10198 procedure Create_Abstract_State
10202 Is_Null : Boolean);
10203 -- Generate an abstract state entity with name Nam and enter it
10204 -- into visibility. Decl is the "declaration" of the state as
10205 -- it appears in pragma Abstract_State. Loc is the location of
10206 -- the related state "declaration". Flag Is_Null should be set
10207 -- when the associated Abstract_State pragma defines a null
10210 -----------------------------
10211 -- Analyze_External_Option --
10212 -----------------------------
10214 procedure Analyze_External_Option (Opt : Node_Id) is
10215 Errors : constant Nat := Serious_Errors_Detected;
10217 Props : Node_Id := Empty;
10220 Check_Duplicate_Option (Opt, External_Seen);
10222 if Nkind (Opt) = N_Component_Association then
10223 Props := Expression (Opt);
10226 -- External state with properties
10228 if Present (Props) then
10230 -- Multiple properties appear as an aggregate
10232 if Nkind (Props) = N_Aggregate then
10234 -- Simple property form
10236 Prop := First (Expressions (Props));
10237 while Present (Prop) loop
10238 Analyze_External_Property (Prop);
10242 -- Property with expression form
10244 Prop := First (Component_Associations (Props));
10245 while Present (Prop) loop
10246 Analyze_External_Property
10247 (Prop => First (Choices (Prop)),
10248 Expr => Expression (Prop));
10256 Analyze_External_Property (Props);
10259 -- An external state defined without any properties defaults
10260 -- all properties to True.
10269 -- Once all external properties have been processed, verify
10270 -- their mutual interaction. Do not perform the check when
10271 -- at least one of the properties is illegal as this will
10272 -- produce a bogus error.
10274 if Errors = Serious_Errors_Detected then
10275 Check_External_Properties
10276 (State, AR_Val, AW_Val, ER_Val, EW_Val);
10278 end Analyze_External_Option;
10280 -------------------------------
10281 -- Analyze_External_Property --
10282 -------------------------------
10284 procedure Analyze_External_Property
10286 Expr : Node_Id := Empty)
10288 Expr_Val : Boolean;
10291 -- Check the placement of "others" (if available)
10293 if Nkind (Prop) = N_Others_Choice then
10294 if Others_Seen then
10296 ("only one others choice allowed in option External",
10299 Others_Seen := True;
10302 elsif Others_Seen then
10304 ("others must be the last property in option External",
10307 -- The only remaining legal options are the four predefined
10308 -- external properties.
10310 elsif Nkind (Prop) = N_Identifier
10311 and then Nam_In (Chars (Prop), Name_Async_Readers,
10312 Name_Async_Writers,
10313 Name_Effective_Reads,
10314 Name_Effective_Writes)
10318 -- Otherwise the construct is not a valid property
10321 Error_Msg_N ("invalid external state property", Prop);
10325 -- Ensure that the expression of the external state property
10326 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
10328 if Present (Expr) then
10329 Analyze_And_Resolve (Expr, Standard_Boolean);
10331 if Is_Static_Expression (Expr) then
10332 Expr_Val := Is_True (Expr_Value (Expr));
10335 ("expression of external state property must be "
10339 -- The lack of expression defaults the property to True
10345 -- Named properties
10347 if Nkind (Prop) = N_Identifier then
10348 if Chars (Prop) = Name_Async_Readers then
10349 Check_Duplicate_Property (Prop, AR_Seen);
10350 AR_Val := Expr_Val;
10352 elsif Chars (Prop) = Name_Async_Writers then
10353 Check_Duplicate_Property (Prop, AW_Seen);
10354 AW_Val := Expr_Val;
10356 elsif Chars (Prop) = Name_Effective_Reads then
10357 Check_Duplicate_Property (Prop, ER_Seen);
10358 ER_Val := Expr_Val;
10361 Check_Duplicate_Property (Prop, EW_Seen);
10362 EW_Val := Expr_Val;
10365 -- The handling of property "others" must take into account
10366 -- all other named properties that have been encountered so
10367 -- far. Only those that have not been seen are affected by
10371 if not AR_Seen then
10372 AR_Val := Expr_Val;
10375 if not AW_Seen then
10376 AW_Val := Expr_Val;
10379 if not ER_Seen then
10380 ER_Val := Expr_Val;
10383 if not EW_Seen then
10384 EW_Val := Expr_Val;
10387 end Analyze_External_Property;
10389 ----------------------------
10390 -- Analyze_Part_Of_Option --
10391 ----------------------------
10393 procedure Analyze_Part_Of_Option (Opt : Node_Id) is
10394 Encaps : constant Node_Id := Expression (Opt);
10395 Encaps_Id : Entity_Id;
10399 Check_Duplicate_Option (Opt, Part_Of_Seen);
10402 (Item_Id => State_Id,
10404 Indic => First (Choices (Opt)),
10407 -- The Part_Of indicator turns an abstract state into a
10408 -- constituent of the encapsulating state.
10411 Encaps_Id := Entity (Encaps);
10413 Append_Elmt (State_Id, Part_Of_Constituents (Encaps_Id));
10414 Set_Encapsulating_State (State_Id, Encaps_Id);
10416 end Analyze_Part_Of_Option;
10418 ----------------------------
10419 -- Check_Duplicate_Option --
10420 ----------------------------
10422 procedure Check_Duplicate_Option
10424 Status : in out Boolean)
10428 Error_Msg_N ("duplicate state option", Opt);
10432 end Check_Duplicate_Option;
10434 ------------------------------
10435 -- Check_Duplicate_Property --
10436 ------------------------------
10438 procedure Check_Duplicate_Property
10440 Status : in out Boolean)
10444 Error_Msg_N ("duplicate external property", Prop);
10448 end Check_Duplicate_Property;
10450 ---------------------------
10451 -- Create_Abstract_State --
10452 ---------------------------
10454 procedure Create_Abstract_State
10461 -- The generated state abstraction reuses the same chars
10462 -- from the original state declaration. Decorate the entity.
10464 State_Id := Make_Defining_Identifier (Loc, Nam);
10466 -- Null states never come from source
10468 Set_Comes_From_Source (State_Id, not Is_Null);
10469 Set_Parent (State_Id, State);
10470 Set_Ekind (State_Id, E_Abstract_State);
10471 Set_Etype (State_Id, Standard_Void_Type);
10472 Set_Encapsulating_State (State_Id, Empty);
10473 Set_Refinement_Constituents (State_Id, New_Elmt_List);
10474 Set_Part_Of_Constituents (State_Id, New_Elmt_List);
10476 -- Establish a link between the state declaration and the
10477 -- abstract state entity. Note that a null state remains as
10478 -- N_Null and does not carry any linkages.
10480 if not Is_Null then
10481 if Present (Decl) then
10482 Set_Entity (Decl, State_Id);
10483 Set_Etype (Decl, Standard_Void_Type);
10486 -- Every non-null state must be defined, nameable and
10489 Push_Scope (Pack_Id);
10490 Generate_Definition (State_Id);
10491 Enter_Name (State_Id);
10494 end Create_Abstract_State;
10501 -- Start of processing for Analyze_Abstract_State
10504 -- A package with a null abstract state is not allowed to
10505 -- declare additional states.
10509 ("package & has null abstract state", State, Pack_Id);
10511 -- Null states appear as internally generated entities
10513 elsif Nkind (State) = N_Null then
10514 Create_Abstract_State
10515 (Nam => New_Internal_Name ('S'),
10517 Loc => Sloc (State),
10521 -- Catch a case where a null state appears in a list of
10522 -- non-null states.
10524 if Non_Null_Seen then
10526 ("package & has non-null abstract state",
10530 -- Simple state declaration
10532 elsif Nkind (State) = N_Identifier then
10533 Create_Abstract_State
10534 (Nam => Chars (State),
10536 Loc => Sloc (State),
10538 Non_Null_Seen := True;
10540 -- State declaration with various options. This construct
10541 -- appears as an extension aggregate in the tree.
10543 elsif Nkind (State) = N_Extension_Aggregate then
10544 if Nkind (Ancestor_Part (State)) = N_Identifier then
10545 Create_Abstract_State
10546 (Nam => Chars (Ancestor_Part (State)),
10547 Decl => Ancestor_Part (State),
10548 Loc => Sloc (Ancestor_Part (State)),
10550 Non_Null_Seen := True;
10553 ("state name must be an identifier",
10554 Ancestor_Part (State));
10557 -- Catch an attempt to introduce a simple option which is
10558 -- currently not allowed. An exception to this is External
10559 -- defined without any properties.
10561 Opt := First (Expressions (State));
10562 while Present (Opt) loop
10563 if Nkind (Opt) = N_Identifier
10564 and then Chars (Opt) = Name_External
10566 Analyze_External_Option (Opt);
10568 -- When an erroneous option Part_Of is without a parent
10569 -- state, it appears in the list of expression of the
10570 -- aggregate rather than the component associations
10571 -- (SPARK RM 7.1.4(9)).
10573 elsif Chars (Opt) = Name_Part_Of then
10575 ("indicator Part_Of must denote an abstract state",
10580 ("simple option not allowed in state declaration",
10587 -- Options External and Part_Of appear as component
10590 Opt := First (Component_Associations (State));
10591 while Present (Opt) loop
10592 Opt_Nam := First (Choices (Opt));
10594 if Nkind (Opt_Nam) = N_Identifier then
10595 if Chars (Opt_Nam) = Name_External then
10596 Analyze_External_Option (Opt);
10598 elsif Chars (Opt_Nam) = Name_Part_Of then
10599 Analyze_Part_Of_Option (Opt);
10602 Error_Msg_N ("invalid state option", Opt);
10605 Error_Msg_N ("invalid state option", Opt);
10611 -- Any other attempt to declare a state is erroneous
10614 Error_Msg_N ("malformed abstract state declaration", State);
10617 -- Guard against a junk state. In such cases no entity is
10618 -- generated and the subsequent checks cannot be applied.
10620 if Present (State_Id) then
10622 -- Verify whether the state does not introduce an illegal
10623 -- hidden state within a package subject to a null abstract
10626 Check_No_Hidden_State (State_Id);
10628 -- Check whether the lack of option Part_Of agrees with the
10629 -- placement of the abstract state with respect to the state
10632 if not Part_Of_Seen then
10633 Check_Missing_Part_Of (State_Id);
10636 -- Associate the state with its related package
10638 if No (Abstract_States (Pack_Id)) then
10639 Set_Abstract_States (Pack_Id, New_Elmt_List);
10642 Append_Elmt (State_Id, Abstract_States (Pack_Id));
10644 end Analyze_Abstract_State;
10646 ------------------------------------
10647 -- Check_State_Declaration_Syntax --
10648 ------------------------------------
10650 procedure Check_State_Declaration_Syntax (State : Node_Id) is
10654 -- Null abstract state
10656 if Nkind (State) = N_Null then
10661 elsif Nkind (State) = N_Identifier then
10664 -- State with various options
10666 elsif Nkind (State) = N_Extension_Aggregate then
10667 if Nkind (Ancestor_Part (State)) /= N_Identifier then
10669 ("state name must be an identifier",
10670 Ancestor_Part (State));
10675 elsif Nkind (State) = N_Aggregate
10676 and then Present (Expressions (State))
10678 Decl := First (Expressions (State));
10679 while Present (Decl) loop
10680 Check_State_Declaration_Syntax (Decl);
10685 Error_Msg_N ("malformed abstract state", State);
10687 end Check_State_Declaration_Syntax;
10691 Context : constant Node_Id := Parent (Parent (N));
10694 -- Start of processing for Abstract_State
10698 Check_Arg_Count (1);
10699 Ensure_Aggregate_Form (Arg1);
10701 -- Ensure the proper placement of the pragma. Abstract states must
10702 -- be associated with a package declaration.
10704 if not Nkind_In (Context, N_Generic_Package_Declaration,
10705 N_Package_Declaration)
10711 State := Expression (Arg1);
10713 -- Verify the syntax of pragma Abstract_State when SPARK checks
10714 -- are suppressed. Semantic analysis is disabled in this mode.
10716 if SPARK_Mode = Off then
10717 Check_State_Declaration_Syntax (State);
10721 Pack_Id := Defining_Entity (Context);
10723 -- Multiple non-null abstract states appear as an aggregate
10725 if Nkind (State) = N_Aggregate then
10726 State := First (Expressions (State));
10727 while Present (State) loop
10728 Analyze_Abstract_State (State);
10732 -- Various forms of a single abstract state. Note that these may
10733 -- include malformed state declarations.
10736 Analyze_Abstract_State (State);
10739 -- Save the pragma for retrieval by other tools
10741 Add_Contract_Item (N, Pack_Id);
10743 -- Verify the declaration order of pragmas Abstract_State and
10746 Check_Declaration_Order
10748 Second => Get_Pragma (Pack_Id, Pragma_Initializes));
10749 end Abstract_State;
10757 -- Note: this pragma also has some specific processing in Par.Prag
10758 -- because we want to set the Ada version mode during parsing.
10760 when Pragma_Ada_83 =>
10762 Check_Arg_Count (0);
10764 -- We really should check unconditionally for proper configuration
10765 -- pragma placement, since we really don't want mixed Ada modes
10766 -- within a single unit, and the GNAT reference manual has always
10767 -- said this was a configuration pragma, but we did not check and
10768 -- are hesitant to add the check now.
10770 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
10771 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
10772 -- or Ada 2012 mode.
10774 if Ada_Version >= Ada_2005 then
10775 Check_Valid_Configuration_Pragma;
10778 -- Now set Ada 83 mode
10780 Ada_Version := Ada_83;
10781 Ada_Version_Explicit := Ada_83;
10782 Ada_Version_Pragma := N;
10790 -- Note: this pragma also has some specific processing in Par.Prag
10791 -- because we want to set the Ada 83 version mode during parsing.
10793 when Pragma_Ada_95 =>
10795 Check_Arg_Count (0);
10797 -- We really should check unconditionally for proper configuration
10798 -- pragma placement, since we really don't want mixed Ada modes
10799 -- within a single unit, and the GNAT reference manual has always
10800 -- said this was a configuration pragma, but we did not check and
10801 -- are hesitant to add the check now.
10803 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
10804 -- or Ada 95, so we must check if we are in Ada 2005 mode.
10806 if Ada_Version >= Ada_2005 then
10807 Check_Valid_Configuration_Pragma;
10810 -- Now set Ada 95 mode
10812 Ada_Version := Ada_95;
10813 Ada_Version_Explicit := Ada_95;
10814 Ada_Version_Pragma := N;
10816 ---------------------
10817 -- Ada_05/Ada_2005 --
10818 ---------------------
10821 -- pragma Ada_05 (LOCAL_NAME);
10823 -- pragma Ada_2005;
10824 -- pragma Ada_2005 (LOCAL_NAME):
10826 -- Note: these pragmas also have some specific processing in Par.Prag
10827 -- because we want to set the Ada 2005 version mode during parsing.
10829 -- The one argument form is used for managing the transition from
10830 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
10831 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
10832 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
10833 -- mode, a preference rule is established which does not choose
10834 -- such an entity unless it is unambiguously specified. This avoids
10835 -- extra subprograms marked this way from generating ambiguities in
10836 -- otherwise legal pre-Ada_2005 programs. The one argument form is
10837 -- intended for exclusive use in the GNAT run-time library.
10839 when Pragma_Ada_05 | Pragma_Ada_2005 => declare
10845 if Arg_Count = 1 then
10846 Check_Arg_Is_Local_Name (Arg1);
10847 E_Id := Get_Pragma_Arg (Arg1);
10849 if Etype (E_Id) = Any_Type then
10853 Set_Is_Ada_2005_Only (Entity (E_Id));
10854 Record_Rep_Item (Entity (E_Id), N);
10857 Check_Arg_Count (0);
10859 -- For Ada_2005 we unconditionally enforce the documented
10860 -- configuration pragma placement, since we do not want to
10861 -- tolerate mixed modes in a unit involving Ada 2005. That
10862 -- would cause real difficulties for those cases where there
10863 -- are incompatibilities between Ada 95 and Ada 2005.
10865 Check_Valid_Configuration_Pragma;
10867 -- Now set appropriate Ada mode
10869 Ada_Version := Ada_2005;
10870 Ada_Version_Explicit := Ada_2005;
10871 Ada_Version_Pragma := N;
10875 ---------------------
10876 -- Ada_12/Ada_2012 --
10877 ---------------------
10880 -- pragma Ada_12 (LOCAL_NAME);
10882 -- pragma Ada_2012;
10883 -- pragma Ada_2012 (LOCAL_NAME):
10885 -- Note: these pragmas also have some specific processing in Par.Prag
10886 -- because we want to set the Ada 2012 version mode during parsing.
10888 -- The one argument form is used for managing the transition from Ada
10889 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
10890 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
10891 -- mode will generate a warning. In addition, in any pre-Ada_2012
10892 -- mode, a preference rule is established which does not choose
10893 -- such an entity unless it is unambiguously specified. This avoids
10894 -- extra subprograms marked this way from generating ambiguities in
10895 -- otherwise legal pre-Ada_2012 programs. The one argument form is
10896 -- intended for exclusive use in the GNAT run-time library.
10898 when Pragma_Ada_12 | Pragma_Ada_2012 => declare
10904 if Arg_Count = 1 then
10905 Check_Arg_Is_Local_Name (Arg1);
10906 E_Id := Get_Pragma_Arg (Arg1);
10908 if Etype (E_Id) = Any_Type then
10912 Set_Is_Ada_2012_Only (Entity (E_Id));
10913 Record_Rep_Item (Entity (E_Id), N);
10916 Check_Arg_Count (0);
10918 -- For Ada_2012 we unconditionally enforce the documented
10919 -- configuration pragma placement, since we do not want to
10920 -- tolerate mixed modes in a unit involving Ada 2012. That
10921 -- would cause real difficulties for those cases where there
10922 -- are incompatibilities between Ada 95 and Ada 2012. We could
10923 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
10925 Check_Valid_Configuration_Pragma;
10927 -- Now set appropriate Ada mode
10929 Ada_Version := Ada_2012;
10930 Ada_Version_Explicit := Ada_2012;
10931 Ada_Version_Pragma := N;
10935 ----------------------
10936 -- All_Calls_Remote --
10937 ----------------------
10939 -- pragma All_Calls_Remote [(library_package_NAME)];
10941 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
10942 Lib_Entity : Entity_Id;
10945 Check_Ada_83_Warning;
10946 Check_Valid_Library_Unit_Pragma;
10948 if Nkind (N) = N_Null_Statement then
10952 Lib_Entity := Find_Lib_Unit_Name;
10954 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
10956 if Present (Lib_Entity)
10957 and then not Debug_Flag_U
10959 if not Is_Remote_Call_Interface (Lib_Entity) then
10960 Error_Pragma ("pragma% only apply to rci unit");
10962 -- Set flag for entity of the library unit
10965 Set_Has_All_Calls_Remote (Lib_Entity);
10969 end All_Calls_Remote;
10971 ---------------------------
10972 -- Allow_Integer_Address --
10973 ---------------------------
10975 -- pragma Allow_Integer_Address;
10977 when Pragma_Allow_Integer_Address =>
10979 Check_Valid_Configuration_Pragma;
10980 Check_Arg_Count (0);
10982 -- If Address is a private type, then set the flag to allow
10983 -- integer address values. If Address is not private (e.g. on
10984 -- VMS, where it is an integer type), then this pragma has no
10985 -- purpose, so it is simply ignored.
10987 if Is_Private_Type (RTE (RE_Address)) then
10988 Opt.Allow_Integer_Address := True;
10995 -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]);
10996 -- ARG ::= NAME | EXPRESSION
10998 -- The first two arguments are by convention intended to refer to an
10999 -- external tool and a tool-specific function. These arguments are
11002 when Pragma_Annotate => Annotate : declare
11008 Check_At_Least_N_Arguments (1);
11009 Check_Arg_Is_Identifier (Arg1);
11010 Check_No_Identifiers;
11013 -- Second parameter is optional, it is never analyzed
11018 -- Here if we have a second parameter
11021 -- Second parameter must be identifier
11023 Check_Arg_Is_Identifier (Arg2);
11025 -- Process remaining parameters if any
11027 Arg := Next (Arg2);
11028 while Present (Arg) loop
11029 Exp := Get_Pragma_Arg (Arg);
11032 if Is_Entity_Name (Exp) then
11035 -- For string literals, we assume Standard_String as the
11036 -- type, unless the string contains wide or wide_wide
11039 elsif Nkind (Exp) = N_String_Literal then
11040 if Has_Wide_Wide_Character (Exp) then
11041 Resolve (Exp, Standard_Wide_Wide_String);
11042 elsif Has_Wide_Character (Exp) then
11043 Resolve (Exp, Standard_Wide_String);
11045 Resolve (Exp, Standard_String);
11048 elsif Is_Overloaded (Exp) then
11050 ("ambiguous argument for pragma%", Exp);
11061 -------------------------------------------------
11062 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
11063 -------------------------------------------------
11066 -- ( [Check => ] Boolean_EXPRESSION
11067 -- [, [Message =>] Static_String_EXPRESSION]);
11069 -- pragma Assert_And_Cut
11070 -- ( [Check => ] Boolean_EXPRESSION
11071 -- [, [Message =>] Static_String_EXPRESSION]);
11074 -- ( [Check => ] Boolean_EXPRESSION
11075 -- [, [Message =>] Static_String_EXPRESSION]);
11077 -- pragma Loop_Invariant
11078 -- ( [Check => ] Boolean_EXPRESSION
11079 -- [, [Message =>] Static_String_EXPRESSION]);
11081 when Pragma_Assert |
11082 Pragma_Assert_And_Cut |
11084 Pragma_Loop_Invariant =>
11089 Has_Loop_Entry : Boolean;
11092 function Contains_Loop_Entry return Boolean;
11093 -- Tests if Expr contains a Loop_Entry attribute reference
11095 -------------------------
11096 -- Contains_Loop_Entry --
11097 -------------------------
11099 function Contains_Loop_Entry return Boolean is
11100 function Process (N : Node_Id) return Traverse_Result;
11101 -- Process function for traversal to look for Loop_Entry
11107 function Process (N : Node_Id) return Traverse_Result is
11109 if Nkind (N) = N_Attribute_Reference
11110 and then Attribute_Name (N) = Name_Loop_Entry
11112 Has_Loop_Entry := True;
11119 procedure Traverse is new Traverse_Proc (Process);
11121 -- Start of processing for Contains_Loop_Entry
11124 Has_Loop_Entry := False;
11126 return Has_Loop_Entry;
11127 end Contains_Loop_Entry;
11129 -- Start of processing for Assert
11132 -- Assert is an Ada 2005 RM-defined pragma
11134 if Prag_Id = Pragma_Assert then
11137 -- The remaining ones are GNAT pragmas
11143 Check_At_Least_N_Arguments (1);
11144 Check_At_Most_N_Arguments (2);
11145 Check_Arg_Order ((Name_Check, Name_Message));
11146 Check_Optional_Identifier (Arg1, Name_Check);
11147 Expr := Get_Pragma_Arg (Arg1);
11149 -- Special processing for Loop_Invariant or for other cases if
11150 -- a Loop_Entry attribute is present.
11152 if Prag_Id = Pragma_Loop_Invariant
11153 or else Contains_Loop_Entry
11155 -- Check restricted placement, must be within a loop
11157 Check_Loop_Pragma_Placement;
11159 -- Do preanalyze to deal with embedded Loop_Entry attribute
11161 Preanalyze_Assert_Expression (Expression (Arg1), Any_Boolean);
11164 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
11165 -- a corresponding Check pragma:
11167 -- pragma Check (name, condition [, msg]);
11169 -- Where name is the identifier matching the pragma name. So
11170 -- rewrite pragma in this manner, transfer the message argument
11171 -- if present, and analyze the result
11173 -- Note: When dealing with a semantically analyzed tree, the
11174 -- information that a Check node N corresponds to a source Assert,
11175 -- Assume, or Assert_And_Cut pragma can be retrieved from the
11176 -- pragma kind of Original_Node(N).
11179 Make_Pragma_Argument_Association (Loc,
11180 Expression => Make_Identifier (Loc, Pname)),
11181 Make_Pragma_Argument_Association (Sloc (Expr),
11182 Expression => Expr));
11184 if Arg_Count > 1 then
11185 Check_Optional_Identifier (Arg2, Name_Message);
11186 Append_To (Newa, New_Copy_Tree (Arg2));
11189 -- Rewrite as Check pragma
11193 Chars => Name_Check,
11194 Pragma_Argument_Associations => Newa));
11198 ----------------------
11199 -- Assertion_Policy --
11200 ----------------------
11202 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
11204 -- The following form is Ada 2012 only, but we allow it in all modes
11206 -- Pragma Assertion_Policy (
11207 -- ASSERTION_KIND => POLICY_IDENTIFIER
11208 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
11210 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
11212 -- RM_ASSERTION_KIND ::= Assert |
11213 -- Static_Predicate |
11214 -- Dynamic_Predicate |
11219 -- Type_Invariant |
11220 -- Type_Invariant'Class
11222 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
11224 -- Contract_Cases |
11226 -- Initial_Condition |
11227 -- Loop_Invariant |
11233 -- Statement_Assertions
11235 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
11236 -- ID_ASSERTION_KIND list contains implementation-defined additions
11237 -- recognized by GNAT. The effect is to control the behavior of
11238 -- identically named aspects and pragmas, depending on the specified
11239 -- policy identifier:
11241 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
11243 -- Note: Check and Ignore are language-defined. Disable is a GNAT
11244 -- implementation defined addition that results in totally ignoring
11245 -- the corresponding assertion. If Disable is specified, then the
11246 -- argument of the assertion is not even analyzed. This is useful
11247 -- when the aspect/pragma argument references entities in a with'ed
11248 -- package that is replaced by a dummy package in the final build.
11250 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
11251 -- and Type_Invariant'Class were recognized by the parser and
11252 -- transformed into references to the special internal identifiers
11253 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
11254 -- processing is required here.
11256 when Pragma_Assertion_Policy => Assertion_Policy : declare
11265 -- This can always appear as a configuration pragma
11267 if Is_Configuration_Pragma then
11270 -- It can also appear in a declarative part or package spec in Ada
11271 -- 2012 mode. We allow this in other modes, but in that case we
11272 -- consider that we have an Ada 2012 pragma on our hands.
11275 Check_Is_In_Decl_Part_Or_Package_Spec;
11279 -- One argument case with no identifier (first form above)
11282 and then (Nkind (Arg1) /= N_Pragma_Argument_Association
11283 or else Chars (Arg1) = No_Name)
11285 Check_Arg_Is_One_Of
11286 (Arg1, Name_Check, Name_Disable, Name_Ignore);
11288 -- Treat one argument Assertion_Policy as equivalent to:
11290 -- pragma Check_Policy (Assertion, policy)
11292 -- So rewrite pragma in that manner and link on to the chain
11293 -- of Check_Policy pragmas, marking the pragma as analyzed.
11295 Policy := Get_Pragma_Arg (Arg1);
11299 Chars => Name_Check_Policy,
11300 Pragma_Argument_Associations => New_List (
11301 Make_Pragma_Argument_Association (Loc,
11302 Expression => Make_Identifier (Loc, Name_Assertion)),
11304 Make_Pragma_Argument_Association (Loc,
11306 Make_Identifier (Sloc (Policy), Chars (Policy))))));
11309 -- Here if we have two or more arguments
11312 Check_At_Least_N_Arguments (1);
11315 -- Loop through arguments
11318 while Present (Arg) loop
11319 LocP := Sloc (Arg);
11321 -- Kind must be specified
11323 if Nkind (Arg) /= N_Pragma_Argument_Association
11324 or else Chars (Arg) = No_Name
11327 ("missing assertion kind for pragma%", Arg);
11330 -- Check Kind and Policy have allowed forms
11332 Kind := Chars (Arg);
11334 if not Is_Valid_Assertion_Kind (Kind) then
11336 ("invalid assertion kind for pragma%", Arg);
11339 Check_Arg_Is_One_Of
11340 (Arg, Name_Check, Name_Disable, Name_Ignore);
11342 -- We rewrite the Assertion_Policy pragma as a series of
11343 -- Check_Policy pragmas:
11345 -- Check_Policy (Kind, Policy);
11349 Chars => Name_Check_Policy,
11350 Pragma_Argument_Associations => New_List (
11351 Make_Pragma_Argument_Association (LocP,
11352 Expression => Make_Identifier (LocP, Kind)),
11353 Make_Pragma_Argument_Association (LocP,
11354 Expression => Get_Pragma_Arg (Arg)))));
11359 -- Rewrite the Assertion_Policy pragma as null since we have
11360 -- now inserted all the equivalent Check pragmas.
11362 Rewrite (N, Make_Null_Statement (Loc));
11365 end Assertion_Policy;
11367 ------------------------------
11368 -- Assume_No_Invalid_Values --
11369 ------------------------------
11371 -- pragma Assume_No_Invalid_Values (On | Off);
11373 when Pragma_Assume_No_Invalid_Values =>
11375 Check_Valid_Configuration_Pragma;
11376 Check_Arg_Count (1);
11377 Check_No_Identifiers;
11378 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
11380 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
11381 Assume_No_Invalid_Values := True;
11383 Assume_No_Invalid_Values := False;
11386 --------------------------
11387 -- Attribute_Definition --
11388 --------------------------
11390 -- pragma Attribute_Definition
11391 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
11392 -- [Entity =>] LOCAL_NAME,
11393 -- [Expression =>] EXPRESSION | NAME);
11395 when Pragma_Attribute_Definition => Attribute_Definition : declare
11396 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
11401 Check_Arg_Count (3);
11402 Check_Optional_Identifier (Arg1, "attribute");
11403 Check_Optional_Identifier (Arg2, "entity");
11404 Check_Optional_Identifier (Arg3, "expression");
11406 if Nkind (Attribute_Designator) /= N_Identifier then
11407 Error_Msg_N ("attribute name expected", Attribute_Designator);
11411 Check_Arg_Is_Local_Name (Arg2);
11413 -- If the attribute is not recognized, then issue a warning (not
11414 -- an error), and ignore the pragma.
11416 Aname := Chars (Attribute_Designator);
11418 if not Is_Attribute_Name (Aname) then
11419 Bad_Attribute (Attribute_Designator, Aname, Warn => True);
11423 -- Otherwise, rewrite the pragma as an attribute definition clause
11426 Make_Attribute_Definition_Clause (Loc,
11427 Name => Get_Pragma_Arg (Arg2),
11429 Expression => Get_Pragma_Arg (Arg3)));
11431 end Attribute_Definition;
11437 -- pragma AST_Entry (entry_IDENTIFIER);
11439 when Pragma_AST_Entry => AST_Entry : declare
11445 Check_Arg_Count (1);
11446 Check_No_Identifiers;
11447 Check_Arg_Is_Local_Name (Arg1);
11448 Ent := Entity (Get_Pragma_Arg (Arg1));
11450 -- Note: the implementation of the AST_Entry pragma could handle
11451 -- the entry family case fine, but for now we are consistent with
11452 -- the DEC rules, and do not allow the pragma, which of course
11453 -- has the effect of also forbidding the attribute.
11455 if Ekind (Ent) /= E_Entry then
11457 ("pragma% argument must be simple entry name", Arg1);
11459 elsif Is_AST_Entry (Ent) then
11461 ("duplicate % pragma for entry", Arg1);
11463 elsif Has_Homonym (Ent) then
11465 ("pragma% argument cannot specify overloaded entry", Arg1);
11469 FF : constant Entity_Id := First_Formal (Ent);
11472 if Present (FF) then
11473 if Present (Next_Formal (FF)) then
11475 ("entry for pragma% can have only one argument",
11478 elsif Parameter_Mode (FF) /= E_In_Parameter then
11480 ("entry parameter for pragma% must have mode IN",
11486 Set_Is_AST_Entry (Ent);
11490 ------------------------------------------------------------------
11491 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
11492 ------------------------------------------------------------------
11494 -- pragma Asynch_Readers ( identifier [, boolean_EXPRESSION] );
11495 -- pragma Asynch_Writers ( identifier [, boolean_EXPRESSION] );
11496 -- pragma Effective_Reads ( identifier [, boolean_EXPRESSION] );
11497 -- pragma Effective_Writes ( identifier [, boolean_EXPRESSION] );
11499 when Pragma_Async_Readers |
11500 Pragma_Async_Writers |
11501 Pragma_Effective_Reads |
11502 Pragma_Effective_Writes =>
11503 Async_Effective : declare
11505 Obj_Id : Entity_Id;
11509 Check_No_Identifiers;
11510 Check_At_Least_N_Arguments (1);
11511 Check_At_Most_N_Arguments (2);
11512 Check_Arg_Is_Local_Name (Arg1);
11514 Arg1 := Get_Pragma_Arg (Arg1);
11516 -- Perform minimal verification to ensure that the argument is at
11517 -- least a variable. Subsequent finer grained checks will be done
11518 -- at the end of the declarative region the contains the pragma.
11520 if Is_Entity_Name (Arg1) and then Present (Entity (Arg1)) then
11521 Obj_Id := Entity (Get_Pragma_Arg (Arg1));
11523 -- It is not efficient to examine preceding statements in order
11524 -- to detect duplicate pragmas as Boolean aspects may appear
11525 -- anywhere between the related object declaration and its
11526 -- freeze point. As an alternative, inspect the contents of the
11527 -- variable contract.
11529 if Ekind (Obj_Id) = E_Variable then
11530 Duplic := Get_Pragma (Obj_Id, Prag_Id);
11532 if Present (Duplic) then
11533 Error_Msg_Name_1 := Pname;
11534 Error_Msg_Sloc := Sloc (Duplic);
11535 Error_Msg_N ("pragma % duplicates pragma declared #", N);
11537 -- Chain the pragma on the contract for further processing.
11538 -- This also aids in detecting duplicates.
11541 Add_Contract_Item (N, Obj_Id);
11544 -- The minimum legality requirements have been met, do not
11545 -- fall through to the error message.
11551 -- If we get here, then the pragma applies to a non-object
11552 -- construct, issue a generic error (SPARK RM 7.1.3(2)).
11554 Error_Pragma ("pragma % must apply to a volatile object");
11555 end Async_Effective;
11561 -- pragma Asynchronous (LOCAL_NAME);
11563 when Pragma_Asynchronous => Asynchronous : declare
11569 Formal : Entity_Id;
11571 procedure Process_Async_Pragma;
11572 -- Common processing for procedure and access-to-procedure case
11574 --------------------------
11575 -- Process_Async_Pragma --
11576 --------------------------
11578 procedure Process_Async_Pragma is
11581 Set_Is_Asynchronous (Nm);
11585 -- The formals should be of mode IN (RM E.4.1(6))
11588 while Present (S) loop
11589 Formal := Defining_Identifier (S);
11591 if Nkind (Formal) = N_Defining_Identifier
11592 and then Ekind (Formal) /= E_In_Parameter
11595 ("pragma% procedure can only have IN parameter",
11602 Set_Is_Asynchronous (Nm);
11603 end Process_Async_Pragma;
11605 -- Start of processing for pragma Asynchronous
11608 Check_Ada_83_Warning;
11609 Check_No_Identifiers;
11610 Check_Arg_Count (1);
11611 Check_Arg_Is_Local_Name (Arg1);
11613 if Debug_Flag_U then
11617 C_Ent := Cunit_Entity (Current_Sem_Unit);
11618 Analyze (Get_Pragma_Arg (Arg1));
11619 Nm := Entity (Get_Pragma_Arg (Arg1));
11621 if not Is_Remote_Call_Interface (C_Ent)
11622 and then not Is_Remote_Types (C_Ent)
11624 -- This pragma should only appear in an RCI or Remote Types
11625 -- unit (RM E.4.1(4)).
11628 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
11631 if Ekind (Nm) = E_Procedure
11632 and then Nkind (Parent (Nm)) = N_Procedure_Specification
11634 if not Is_Remote_Call_Interface (Nm) then
11636 ("pragma% cannot be applied on non-remote procedure",
11640 L := Parameter_Specifications (Parent (Nm));
11641 Process_Async_Pragma;
11644 elsif Ekind (Nm) = E_Function then
11646 ("pragma% cannot be applied to function", Arg1);
11648 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
11649 if Is_Record_Type (Nm) then
11651 -- A record type that is the Equivalent_Type for a remote
11652 -- access-to-subprogram type.
11654 N := Declaration_Node (Corresponding_Remote_Type (Nm));
11657 -- A non-expanded RAS type (distribution is not enabled)
11659 N := Declaration_Node (Nm);
11662 if Nkind (N) = N_Full_Type_Declaration
11663 and then Nkind (Type_Definition (N)) =
11664 N_Access_Procedure_Definition
11666 L := Parameter_Specifications (Type_Definition (N));
11667 Process_Async_Pragma;
11669 if Is_Asynchronous (Nm)
11670 and then Expander_Active
11671 and then Get_PCS_Name /= Name_No_DSA
11673 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
11678 ("pragma% cannot reference access-to-function type",
11682 -- Only other possibility is Access-to-class-wide type
11684 elsif Is_Access_Type (Nm)
11685 and then Is_Class_Wide_Type (Designated_Type (Nm))
11687 Check_First_Subtype (Arg1);
11688 Set_Is_Asynchronous (Nm);
11689 if Expander_Active then
11690 RACW_Type_Is_Asynchronous (Nm);
11694 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
11702 -- pragma Atomic (LOCAL_NAME);
11704 when Pragma_Atomic =>
11705 Process_Atomic_Shared_Volatile;
11707 -----------------------
11708 -- Atomic_Components --
11709 -----------------------
11711 -- pragma Atomic_Components (array_LOCAL_NAME);
11713 -- This processing is shared by Volatile_Components
11715 when Pragma_Atomic_Components |
11716 Pragma_Volatile_Components =>
11718 Atomic_Components : declare
11725 Check_Ada_83_Warning;
11726 Check_No_Identifiers;
11727 Check_Arg_Count (1);
11728 Check_Arg_Is_Local_Name (Arg1);
11729 E_Id := Get_Pragma_Arg (Arg1);
11731 if Etype (E_Id) = Any_Type then
11735 E := Entity (E_Id);
11737 Check_Duplicate_Pragma (E);
11739 if Rep_Item_Too_Early (E, N)
11741 Rep_Item_Too_Late (E, N)
11746 D := Declaration_Node (E);
11749 if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
11751 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
11752 and then Nkind (D) = N_Object_Declaration
11753 and then Nkind (Object_Definition (D)) =
11754 N_Constrained_Array_Definition)
11756 -- The flag is set on the object, or on the base type
11758 if Nkind (D) /= N_Object_Declaration then
11759 E := Base_Type (E);
11762 Set_Has_Volatile_Components (E);
11764 if Prag_Id = Pragma_Atomic_Components then
11765 Set_Has_Atomic_Components (E);
11769 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
11771 end Atomic_Components;
11773 --------------------
11774 -- Attach_Handler --
11775 --------------------
11777 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
11779 when Pragma_Attach_Handler =>
11780 Check_Ada_83_Warning;
11781 Check_No_Identifiers;
11782 Check_Arg_Count (2);
11784 if No_Run_Time_Mode then
11785 Error_Msg_CRT ("Attach_Handler pragma", N);
11787 Check_Interrupt_Or_Attach_Handler;
11789 -- The expression that designates the attribute may depend on a
11790 -- discriminant, and is therefore a per-object expression, to
11791 -- be expanded in the init proc. If expansion is enabled, then
11792 -- perform semantic checks on a copy only.
11797 Parg2 : constant Node_Id := Get_Pragma_Arg (Arg2);
11800 -- In Relaxed_RM_Semantics mode, we allow any static
11801 -- integer value, for compatibility with other compilers.
11803 if Relaxed_RM_Semantics
11804 and then Nkind (Parg2) = N_Integer_Literal
11806 Typ := Standard_Integer;
11808 Typ := RTE (RE_Interrupt_ID);
11811 if Expander_Active then
11812 Temp := New_Copy_Tree (Parg2);
11813 Set_Parent (Temp, N);
11814 Preanalyze_And_Resolve (Temp, Typ);
11817 Resolve (Parg2, Typ);
11821 Process_Interrupt_Or_Attach_Handler;
11824 --------------------
11825 -- C_Pass_By_Copy --
11826 --------------------
11828 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
11830 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
11836 Check_Valid_Configuration_Pragma;
11837 Check_Arg_Count (1);
11838 Check_Optional_Identifier (Arg1, "max_size");
11840 Arg := Get_Pragma_Arg (Arg1);
11841 Check_Arg_Is_Static_Expression (Arg, Any_Integer);
11843 Val := Expr_Value (Arg);
11847 ("maximum size for pragma% must be positive", Arg1);
11849 elsif UI_Is_In_Int_Range (Val) then
11850 Default_C_Record_Mechanism := UI_To_Int (Val);
11852 -- If a giant value is given, Int'Last will do well enough.
11853 -- If sometime someone complains that a record larger than
11854 -- two gigabytes is not copied, we will worry about it then.
11857 Default_C_Record_Mechanism := Mechanism_Type'Last;
11859 end C_Pass_By_Copy;
11865 -- pragma Check ([Name =>] CHECK_KIND,
11866 -- [Check =>] Boolean_EXPRESSION
11867 -- [,[Message =>] String_EXPRESSION]);
11869 -- CHECK_KIND ::= IDENTIFIER |
11872 -- Invariant'Class |
11873 -- Type_Invariant'Class
11875 -- The identifiers Assertions and Statement_Assertions are not
11876 -- allowed, since they have special meaning for Check_Policy.
11878 when Pragma_Check => Check : declare
11886 Check_At_Least_N_Arguments (2);
11887 Check_At_Most_N_Arguments (3);
11888 Check_Optional_Identifier (Arg1, Name_Name);
11889 Check_Optional_Identifier (Arg2, Name_Check);
11891 if Arg_Count = 3 then
11892 Check_Optional_Identifier (Arg3, Name_Message);
11893 Str := Get_Pragma_Arg (Arg3);
11896 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
11897 Check_Arg_Is_Identifier (Arg1);
11898 Cname := Chars (Get_Pragma_Arg (Arg1));
11900 -- Check forbidden name Assertions or Statement_Assertions
11903 when Name_Assertions =>
11905 ("""Assertions"" is not allowed as a check kind "
11906 & "for pragma%", Arg1);
11908 when Name_Statement_Assertions =>
11910 ("""Statement_Assertions"" is not allowed as a check kind "
11911 & "for pragma%", Arg1);
11917 -- Check applicable policy. We skip this if Checked/Ignored status
11918 -- is already set (e.g. in the casse of a pragma from an aspect).
11920 if Is_Checked (N) or else Is_Ignored (N) then
11923 -- For a non-source pragma that is a rewriting of another pragma,
11924 -- copy the Is_Checked/Ignored status from the rewritten pragma.
11926 elsif Is_Rewrite_Substitution (N)
11927 and then Nkind (Original_Node (N)) = N_Pragma
11928 and then Original_Node (N) /= N
11930 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
11931 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
11933 -- Otherwise query the applicable policy at this point
11936 case Check_Kind (Cname) is
11937 when Name_Ignore =>
11938 Set_Is_Ignored (N, True);
11939 Set_Is_Checked (N, False);
11942 Set_Is_Ignored (N, False);
11943 Set_Is_Checked (N, True);
11945 -- For disable, rewrite pragma as null statement and skip
11946 -- rest of the analysis of the pragma.
11948 when Name_Disable =>
11949 Rewrite (N, Make_Null_Statement (Loc));
11953 -- No other possibilities
11956 raise Program_Error;
11960 -- If check kind was not Disable, then continue pragma analysis
11962 Expr := Get_Pragma_Arg (Arg2);
11964 -- Deal with SCO generation
11967 when Name_Predicate |
11970 -- Nothing to do: since checks occur in client units,
11971 -- the SCO for the aspect in the declaration unit is
11972 -- conservatively always enabled.
11978 if Is_Checked (N) and then not Split_PPC (N) then
11980 -- Mark aspect/pragma SCO as enabled
11982 Set_SCO_Pragma_Enabled (Loc);
11986 -- Deal with analyzing the string argument.
11988 if Arg_Count = 3 then
11990 -- If checks are not on we don't want any expansion (since
11991 -- such expansion would not get properly deleted) but
11992 -- we do want to analyze (to get proper references).
11993 -- The Preanalyze_And_Resolve routine does just what we want
11995 if Is_Ignored (N) then
11996 Preanalyze_And_Resolve (Str, Standard_String);
11998 -- Otherwise we need a proper analysis and expansion
12001 Analyze_And_Resolve (Str, Standard_String);
12005 -- Now you might think we could just do the same with the Boolean
12006 -- expression if checks are off (and expansion is on) and then
12007 -- rewrite the check as a null statement. This would work but we
12008 -- would lose the useful warnings about an assertion being bound
12009 -- to fail even if assertions are turned off.
12011 -- So instead we wrap the boolean expression in an if statement
12012 -- that looks like:
12014 -- if False and then condition then
12018 -- The reason we do this rewriting during semantic analysis rather
12019 -- than as part of normal expansion is that we cannot analyze and
12020 -- expand the code for the boolean expression directly, or it may
12021 -- cause insertion of actions that would escape the attempt to
12022 -- suppress the check code.
12024 -- Note that the Sloc for the if statement corresponds to the
12025 -- argument condition, not the pragma itself. The reason for
12026 -- this is that we may generate a warning if the condition is
12027 -- False at compile time, and we do not want to delete this
12028 -- warning when we delete the if statement.
12030 if Expander_Active and Is_Ignored (N) then
12031 Eloc := Sloc (Expr);
12034 Make_If_Statement (Eloc,
12036 Make_And_Then (Eloc,
12037 Left_Opnd => New_Occurrence_Of (Standard_False, Eloc),
12038 Right_Opnd => Expr),
12039 Then_Statements => New_List (
12040 Make_Null_Statement (Eloc))));
12042 In_Assertion_Expr := In_Assertion_Expr + 1;
12044 In_Assertion_Expr := In_Assertion_Expr - 1;
12046 -- Check is active or expansion not active. In these cases we can
12047 -- just go ahead and analyze the boolean with no worries.
12050 In_Assertion_Expr := In_Assertion_Expr + 1;
12051 Analyze_And_Resolve (Expr, Any_Boolean);
12052 In_Assertion_Expr := In_Assertion_Expr - 1;
12056 --------------------------
12057 -- Check_Float_Overflow --
12058 --------------------------
12060 -- pragma Check_Float_Overflow;
12062 when Pragma_Check_Float_Overflow =>
12064 Check_Valid_Configuration_Pragma;
12065 Check_Arg_Count (0);
12066 Check_Float_Overflow := True;
12072 -- pragma Check_Name (check_IDENTIFIER);
12074 when Pragma_Check_Name =>
12076 Check_No_Identifiers;
12077 Check_Valid_Configuration_Pragma;
12078 Check_Arg_Count (1);
12079 Check_Arg_Is_Identifier (Arg1);
12082 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
12085 for J in Check_Names.First .. Check_Names.Last loop
12086 if Check_Names.Table (J) = Nam then
12091 Check_Names.Append (Nam);
12098 -- This is the old style syntax, which is still allowed in all modes:
12100 -- pragma Check_Policy ([Name =>] CHECK_KIND
12101 -- [Policy =>] POLICY_IDENTIFIER);
12103 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
12105 -- CHECK_KIND ::= IDENTIFIER |
12108 -- Type_Invariant'Class |
12111 -- This is the new style syntax, compatible with Assertion_Policy
12112 -- and also allowed in all modes.
12114 -- Pragma Check_Policy (
12115 -- CHECK_KIND => POLICY_IDENTIFIER
12116 -- {, CHECK_KIND => POLICY_IDENTIFIER});
12118 -- Note: the identifiers Name and Policy are not allowed as
12119 -- Check_Kind values. This avoids ambiguities between the old and
12120 -- new form syntax.
12122 when Pragma_Check_Policy => Check_Policy : declare
12127 Check_At_Least_N_Arguments (1);
12129 -- A Check_Policy pragma can appear either as a configuration
12130 -- pragma, or in a declarative part or a package spec (see RM
12131 -- 11.5(5) for rules for Suppress/Unsuppress which are also
12132 -- followed for Check_Policy).
12134 if not Is_Configuration_Pragma then
12135 Check_Is_In_Decl_Part_Or_Package_Spec;
12138 -- Figure out if we have the old or new syntax. We have the
12139 -- old syntax if the first argument has no identifier, or the
12140 -- identifier is Name.
12142 if Nkind (Arg1) /= N_Pragma_Argument_Association
12143 or else Nam_In (Chars (Arg1), No_Name, Name_Name)
12147 Check_Arg_Count (2);
12148 Check_Optional_Identifier (Arg1, Name_Name);
12149 Kind := Get_Pragma_Arg (Arg1);
12150 Rewrite_Assertion_Kind (Kind);
12151 Check_Arg_Is_Identifier (Arg1);
12153 -- Check forbidden check kind
12155 if Nam_In (Chars (Kind), Name_Name, Name_Policy) then
12156 Error_Msg_Name_2 := Chars (Kind);
12158 ("pragma% does not allow% as check name", Arg1);
12163 Check_Optional_Identifier (Arg2, Name_Policy);
12164 Check_Arg_Is_One_Of
12166 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
12168 -- And chain pragma on the Check_Policy_List for search
12170 Set_Next_Pragma (N, Opt.Check_Policy_List);
12171 Opt.Check_Policy_List := N;
12173 -- For the new syntax, what we do is to convert each argument to
12174 -- an old syntax equivalent. We do that because we want to chain
12175 -- old style Check_Policy pragmas for the search (we don't want
12176 -- to have to deal with multiple arguments in the search).
12186 while Present (Arg) loop
12187 LocP := Sloc (Arg);
12188 Argx := Get_Pragma_Arg (Arg);
12190 -- Kind must be specified
12192 if Nkind (Arg) /= N_Pragma_Argument_Association
12193 or else Chars (Arg) = No_Name
12196 ("missing assertion kind for pragma%", Arg);
12199 -- Construct equivalent old form syntax Check_Policy
12200 -- pragma and insert it to get remaining checks.
12204 Chars => Name_Check_Policy,
12205 Pragma_Argument_Associations => New_List (
12206 Make_Pragma_Argument_Association (LocP,
12208 Make_Identifier (LocP, Chars (Arg))),
12209 Make_Pragma_Argument_Association (Sloc (Argx),
12210 Expression => Argx))));
12215 -- Rewrite original Check_Policy pragma to null, since we
12216 -- have converted it into a series of old syntax pragmas.
12218 Rewrite (N, Make_Null_Statement (Loc));
12224 ---------------------
12225 -- CIL_Constructor --
12226 ---------------------
12228 -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
12230 -- Processing for this pragma is shared with Java_Constructor
12236 -- pragma Comment (static_string_EXPRESSION)
12238 -- Processing for pragma Comment shares the circuitry for pragma
12239 -- Ident. The only differences are that Ident enforces a limit of 31
12240 -- characters on its argument, and also enforces limitations on
12241 -- placement for DEC compatibility. Pragma Comment shares neither of
12242 -- these restrictions.
12244 -------------------
12245 -- Common_Object --
12246 -------------------
12248 -- pragma Common_Object (
12249 -- [Internal =>] LOCAL_NAME
12250 -- [, [External =>] EXTERNAL_SYMBOL]
12251 -- [, [Size =>] EXTERNAL_SYMBOL]);
12253 -- Processing for this pragma is shared with Psect_Object
12255 ------------------------
12256 -- Compile_Time_Error --
12257 ------------------------
12259 -- pragma Compile_Time_Error
12260 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12262 when Pragma_Compile_Time_Error =>
12264 Process_Compile_Time_Warning_Or_Error;
12266 --------------------------
12267 -- Compile_Time_Warning --
12268 --------------------------
12270 -- pragma Compile_Time_Warning
12271 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12273 when Pragma_Compile_Time_Warning =>
12275 Process_Compile_Time_Warning_Or_Error;
12277 ---------------------------
12278 -- Compiler_Unit_Warning --
12279 ---------------------------
12281 -- pragma Compiler_Unit_Warning;
12285 -- Originally, we had only pragma Compiler_Unit, and it resulted in
12286 -- errors not warnings. This means that we had introduced a big extra
12287 -- inertia to compiler changes, since even if we implemented a new
12288 -- feature, and even if all versions to be used for bootstrapping
12289 -- implemented this new feature, we could not use it, since old
12290 -- compilers would give errors for using this feature in units
12291 -- having Compiler_Unit pragmas.
12293 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
12294 -- problem. We no longer have any units mentioning Compiler_Unit,
12295 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
12296 -- and thus generates a warning which can be ignored. So that deals
12297 -- with the problem of old compilers not implementing the newer form
12300 -- Newer compilers recognize the new pragma, but generate warning
12301 -- messages instead of errors, which again can be ignored in the
12302 -- case of an old compiler which implements a wanted new feature
12303 -- but at the time felt like warning about it for older compilers.
12305 -- We retain Compiler_Unit so that new compilers can be used to build
12306 -- older run-times that use this pragma. That's an unusual case, but
12307 -- it's easy enough to handle, so why not?
12309 when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning =>
12311 Check_Arg_Count (0);
12312 Set_Is_Compiler_Unit (Get_Source_Unit (N));
12314 -----------------------------
12315 -- Complete_Representation --
12316 -----------------------------
12318 -- pragma Complete_Representation;
12320 when Pragma_Complete_Representation =>
12322 Check_Arg_Count (0);
12324 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
12326 ("pragma & must appear within record representation clause");
12329 ----------------------------
12330 -- Complex_Representation --
12331 ----------------------------
12333 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
12335 when Pragma_Complex_Representation => Complex_Representation : declare
12342 Check_Arg_Count (1);
12343 Check_Optional_Identifier (Arg1, Name_Entity);
12344 Check_Arg_Is_Local_Name (Arg1);
12345 E_Id := Get_Pragma_Arg (Arg1);
12347 if Etype (E_Id) = Any_Type then
12351 E := Entity (E_Id);
12353 if not Is_Record_Type (E) then
12355 ("argument for pragma% must be record type", Arg1);
12358 Ent := First_Entity (E);
12361 or else No (Next_Entity (Ent))
12362 or else Present (Next_Entity (Next_Entity (Ent)))
12363 or else not Is_Floating_Point_Type (Etype (Ent))
12364 or else Etype (Ent) /= Etype (Next_Entity (Ent))
12367 ("record for pragma% must have two fields of the same "
12368 & "floating-point type", Arg1);
12371 Set_Has_Complex_Representation (Base_Type (E));
12373 -- We need to treat the type has having a non-standard
12374 -- representation, for back-end purposes, even though in
12375 -- general a complex will have the default representation
12376 -- of a record with two real components.
12378 Set_Has_Non_Standard_Rep (Base_Type (E));
12380 end Complex_Representation;
12382 -------------------------
12383 -- Component_Alignment --
12384 -------------------------
12386 -- pragma Component_Alignment (
12387 -- [Form =>] ALIGNMENT_CHOICE
12388 -- [, [Name =>] type_LOCAL_NAME]);
12390 -- ALIGNMENT_CHOICE ::=
12392 -- | Component_Size_4
12396 when Pragma_Component_Alignment => Component_AlignmentP : declare
12397 Args : Args_List (1 .. 2);
12398 Names : constant Name_List (1 .. 2) := (
12402 Form : Node_Id renames Args (1);
12403 Name : Node_Id renames Args (2);
12405 Atype : Component_Alignment_Kind;
12410 Gather_Associations (Names, Args);
12413 Error_Pragma ("missing Form argument for pragma%");
12416 Check_Arg_Is_Identifier (Form);
12418 -- Get proper alignment, note that Default = Component_Size on all
12419 -- machines we have so far, and we want to set this value rather
12420 -- than the default value to indicate that it has been explicitly
12421 -- set (and thus will not get overridden by the default component
12422 -- alignment for the current scope)
12424 if Chars (Form) = Name_Component_Size then
12425 Atype := Calign_Component_Size;
12427 elsif Chars (Form) = Name_Component_Size_4 then
12428 Atype := Calign_Component_Size_4;
12430 elsif Chars (Form) = Name_Default then
12431 Atype := Calign_Component_Size;
12433 elsif Chars (Form) = Name_Storage_Unit then
12434 Atype := Calign_Storage_Unit;
12438 ("invalid Form parameter for pragma%", Form);
12441 -- Case with no name, supplied, affects scope table entry
12445 (Scope_Stack.Last).Component_Alignment_Default := Atype;
12447 -- Case of name supplied
12450 Check_Arg_Is_Local_Name (Name);
12452 Typ := Entity (Name);
12455 or else Rep_Item_Too_Early (Typ, N)
12459 Typ := Underlying_Type (Typ);
12462 if not Is_Record_Type (Typ)
12463 and then not Is_Array_Type (Typ)
12466 ("Name parameter of pragma% must identify record or "
12467 & "array type", Name);
12470 -- An explicit Component_Alignment pragma overrides an
12471 -- implicit pragma Pack, but not an explicit one.
12473 if not Has_Pragma_Pack (Base_Type (Typ)) then
12474 Set_Is_Packed (Base_Type (Typ), False);
12475 Set_Component_Alignment (Base_Type (Typ), Atype);
12478 end Component_AlignmentP;
12480 --------------------
12481 -- Contract_Cases --
12482 --------------------
12484 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
12486 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
12488 -- CASE_GUARD ::= boolean_EXPRESSION | others
12490 -- CONSEQUENCE ::= boolean_EXPRESSION
12492 when Pragma_Contract_Cases => Contract_Cases : declare
12493 Subp_Decl : Node_Id;
12497 Check_Arg_Count (1);
12498 Ensure_Aggregate_Form (Arg1);
12500 -- The pragma is analyzed at the end of the declarative part which
12501 -- contains the related subprogram. Reset the analyzed flag.
12503 Set_Analyzed (N, False);
12505 -- Ensure the proper placement of the pragma. Contract_Cases must
12506 -- be associated with a subprogram declaration or a body that acts
12510 Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
12512 if Nkind (Subp_Decl) = N_Subprogram_Declaration then
12515 -- Body acts as spec
12517 elsif Nkind (Subp_Decl) = N_Subprogram_Body
12518 and then No (Corresponding_Spec (Subp_Decl))
12522 -- Body stub acts as spec
12524 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
12525 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
12534 -- When the pragma appears on a subprogram body, perform the full
12537 if Nkind (Subp_Decl) = N_Subprogram_Body then
12538 Analyze_Contract_Cases_In_Decl_Part (N);
12540 -- When Contract_Cases applies to a subprogram compilation unit,
12541 -- the corresponding pragma is placed after the unit's declaration
12542 -- node and needs to be analyzed immediately.
12544 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration
12545 and then Nkind (Parent (Subp_Decl)) = N_Compilation_Unit
12547 Analyze_Contract_Cases_In_Decl_Part (N);
12550 -- Chain the pragma on the contract for further processing
12552 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
12553 end Contract_Cases;
12559 -- pragma Controlled (first_subtype_LOCAL_NAME);
12561 when Pragma_Controlled => Controlled : declare
12565 Check_No_Identifiers;
12566 Check_Arg_Count (1);
12567 Check_Arg_Is_Local_Name (Arg1);
12568 Arg := Get_Pragma_Arg (Arg1);
12570 if not Is_Entity_Name (Arg)
12571 or else not Is_Access_Type (Entity (Arg))
12573 Error_Pragma_Arg ("pragma% requires access type", Arg1);
12575 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
12583 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
12584 -- [Entity =>] LOCAL_NAME);
12586 when Pragma_Convention => Convention : declare
12589 pragma Warnings (Off, C);
12590 pragma Warnings (Off, E);
12592 Check_Arg_Order ((Name_Convention, Name_Entity));
12593 Check_Ada_83_Warning;
12594 Check_Arg_Count (2);
12595 Process_Convention (C, E);
12598 ---------------------------
12599 -- Convention_Identifier --
12600 ---------------------------
12602 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
12603 -- [Convention =>] convention_IDENTIFIER);
12605 when Pragma_Convention_Identifier => Convention_Identifier : declare
12611 Check_Arg_Order ((Name_Name, Name_Convention));
12612 Check_Arg_Count (2);
12613 Check_Optional_Identifier (Arg1, Name_Name);
12614 Check_Optional_Identifier (Arg2, Name_Convention);
12615 Check_Arg_Is_Identifier (Arg1);
12616 Check_Arg_Is_Identifier (Arg2);
12617 Idnam := Chars (Get_Pragma_Arg (Arg1));
12618 Cname := Chars (Get_Pragma_Arg (Arg2));
12620 if Is_Convention_Name (Cname) then
12621 Record_Convention_Identifier
12622 (Idnam, Get_Convention_Id (Cname));
12625 ("second arg for % pragma must be convention", Arg2);
12627 end Convention_Identifier;
12633 -- pragma CPP_Class ([Entity =>] local_NAME)
12635 when Pragma_CPP_Class => CPP_Class : declare
12639 if Warn_On_Obsolescent_Feature then
12641 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
12642 & "effect; replace it by pragma import?j?", N);
12645 Check_Arg_Count (1);
12649 Chars => Name_Import,
12650 Pragma_Argument_Associations => New_List (
12651 Make_Pragma_Argument_Association (Loc,
12652 Expression => Make_Identifier (Loc, Name_CPP)),
12653 New_Copy (First (Pragma_Argument_Associations (N))))));
12657 ---------------------
12658 -- CPP_Constructor --
12659 ---------------------
12661 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
12662 -- [, [External_Name =>] static_string_EXPRESSION ]
12663 -- [, [Link_Name =>] static_string_EXPRESSION ]);
12665 when Pragma_CPP_Constructor => CPP_Constructor : declare
12668 Def_Id : Entity_Id;
12669 Tag_Typ : Entity_Id;
12673 Check_At_Least_N_Arguments (1);
12674 Check_At_Most_N_Arguments (3);
12675 Check_Optional_Identifier (Arg1, Name_Entity);
12676 Check_Arg_Is_Local_Name (Arg1);
12678 Id := Get_Pragma_Arg (Arg1);
12679 Find_Program_Unit_Name (Id);
12681 -- If we did not find the name, we are done
12683 if Etype (Id) = Any_Type then
12687 Def_Id := Entity (Id);
12689 -- Check if already defined as constructor
12691 if Is_Constructor (Def_Id) then
12693 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
12697 if Ekind (Def_Id) = E_Function
12698 and then (Is_CPP_Class (Etype (Def_Id))
12699 or else (Is_Class_Wide_Type (Etype (Def_Id))
12701 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
12703 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
12705 ("'C'P'P constructor must be defined in the scope of "
12706 & "its returned type", Arg1);
12709 if Arg_Count >= 2 then
12710 Set_Imported (Def_Id);
12711 Set_Is_Public (Def_Id);
12712 Process_Interface_Name (Def_Id, Arg2, Arg3);
12715 Set_Has_Completion (Def_Id);
12716 Set_Is_Constructor (Def_Id);
12717 Set_Convention (Def_Id, Convention_CPP);
12719 -- Imported C++ constructors are not dispatching primitives
12720 -- because in C++ they don't have a dispatch table slot.
12721 -- However, in Ada the constructor has the profile of a
12722 -- function that returns a tagged type and therefore it has
12723 -- been treated as a primitive operation during semantic
12724 -- analysis. We now remove it from the list of primitive
12725 -- operations of the type.
12727 if Is_Tagged_Type (Etype (Def_Id))
12728 and then not Is_Class_Wide_Type (Etype (Def_Id))
12729 and then Is_Dispatching_Operation (Def_Id)
12731 Tag_Typ := Etype (Def_Id);
12733 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
12734 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
12738 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
12739 Set_Is_Dispatching_Operation (Def_Id, False);
12742 -- For backward compatibility, if the constructor returns a
12743 -- class wide type, and we internally change the return type to
12744 -- the corresponding root type.
12746 if Is_Class_Wide_Type (Etype (Def_Id)) then
12747 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
12751 ("pragma% requires function returning a 'C'P'P_Class type",
12754 end CPP_Constructor;
12760 when Pragma_CPP_Virtual => CPP_Virtual : declare
12764 if Warn_On_Obsolescent_Feature then
12766 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
12775 when Pragma_CPP_Vtable => CPP_Vtable : declare
12779 if Warn_On_Obsolescent_Feature then
12781 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
12790 -- pragma CPU (EXPRESSION);
12792 when Pragma_CPU => CPU : declare
12793 P : constant Node_Id := Parent (N);
12799 Check_No_Identifiers;
12800 Check_Arg_Count (1);
12804 if Nkind (P) = N_Subprogram_Body then
12805 Check_In_Main_Program;
12807 Arg := Get_Pragma_Arg (Arg1);
12808 Analyze_And_Resolve (Arg, Any_Integer);
12810 Ent := Defining_Unit_Name (Specification (P));
12812 if Nkind (Ent) = N_Defining_Program_Unit_Name then
12813 Ent := Defining_Identifier (Ent);
12818 if not Is_Static_Expression (Arg) then
12819 Flag_Non_Static_Expr
12820 ("main subprogram affinity is not static!", Arg);
12823 -- If constraint error, then we already signalled an error
12825 elsif Raises_Constraint_Error (Arg) then
12828 -- Otherwise check in range
12832 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
12833 -- This is the entity System.Multiprocessors.CPU_Range;
12835 Val : constant Uint := Expr_Value (Arg);
12838 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
12840 Val > Expr_Value (Type_High_Bound (CPU_Id))
12843 ("main subprogram CPU is out of range", Arg1);
12849 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
12853 elsif Nkind (P) = N_Task_Definition then
12854 Arg := Get_Pragma_Arg (Arg1);
12855 Ent := Defining_Identifier (Parent (P));
12857 -- The expression must be analyzed in the special manner
12858 -- described in "Handling of Default and Per-Object
12859 -- Expressions" in sem.ads.
12861 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
12863 -- Anything else is incorrect
12869 -- Check duplicate pragma before we chain the pragma in the Rep
12870 -- Item chain of Ent.
12872 Check_Duplicate_Pragma (Ent);
12873 Record_Rep_Item (Ent, N);
12880 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
12882 when Pragma_Debug => Debug : declare
12889 -- The condition for executing the call is that the expander
12890 -- is active and that we are not ignoring this debug pragma.
12895 (Expander_Active and then not Is_Ignored (N)),
12898 if not Is_Ignored (N) then
12899 Set_SCO_Pragma_Enabled (Loc);
12902 if Arg_Count = 2 then
12904 Make_And_Then (Loc,
12905 Left_Opnd => Relocate_Node (Cond),
12906 Right_Opnd => Get_Pragma_Arg (Arg1));
12907 Call := Get_Pragma_Arg (Arg2);
12909 Call := Get_Pragma_Arg (Arg1);
12913 N_Indexed_Component,
12917 N_Selected_Component)
12919 -- If this pragma Debug comes from source, its argument was
12920 -- parsed as a name form (which is syntactically identical).
12921 -- In a generic context a parameterless call will be left as
12922 -- an expanded name (if global) or selected_component if local.
12923 -- Change it to a procedure call statement now.
12925 Change_Name_To_Procedure_Call_Statement (Call);
12927 elsif Nkind (Call) = N_Procedure_Call_Statement then
12929 -- Already in the form of a procedure call statement: nothing
12930 -- to do (could happen in case of an internally generated
12936 -- All other cases: diagnose error
12939 ("argument of pragma ""Debug"" is not procedure call",
12944 -- Rewrite into a conditional with an appropriate condition. We
12945 -- wrap the procedure call in a block so that overhead from e.g.
12946 -- use of the secondary stack does not generate execution overhead
12947 -- for suppressed conditions.
12949 -- Normally the analysis that follows will freeze the subprogram
12950 -- being called. However, if the call is to a null procedure,
12951 -- we want to freeze it before creating the block, because the
12952 -- analysis that follows may be done with expansion disabled, in
12953 -- which case the body will not be generated, leading to spurious
12956 if Nkind (Call) = N_Procedure_Call_Statement
12957 and then Is_Entity_Name (Name (Call))
12959 Analyze (Name (Call));
12960 Freeze_Before (N, Entity (Name (Call)));
12964 Make_Implicit_If_Statement (N,
12966 Then_Statements => New_List (
12967 Make_Block_Statement (Loc,
12968 Handled_Statement_Sequence =>
12969 Make_Handled_Sequence_Of_Statements (Loc,
12970 Statements => New_List (Relocate_Node (Call)))))));
12973 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
12974 -- after analysis of the normally rewritten node, to capture all
12975 -- references to entities, which avoids issuing wrong warnings
12976 -- about unused entities.
12978 if GNATprove_Mode then
12979 Rewrite (N, Make_Null_Statement (Loc));
12987 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
12989 when Pragma_Debug_Policy =>
12991 Check_Arg_Count (1);
12992 Check_No_Identifiers;
12993 Check_Arg_Is_Identifier (Arg1);
12995 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
12996 -- rewrite it that way, and let the rest of the checking come
12997 -- from analyzing the rewritten pragma.
13001 Chars => Name_Check_Policy,
13002 Pragma_Argument_Associations => New_List (
13003 Make_Pragma_Argument_Association (Loc,
13004 Expression => Make_Identifier (Loc, Name_Debug)),
13006 Make_Pragma_Argument_Association (Loc,
13007 Expression => Get_Pragma_Arg (Arg1)))));
13014 -- pragma Depends (DEPENDENCY_RELATION);
13016 -- DEPENDENCY_RELATION ::=
13018 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
13020 -- DEPENDENCY_CLAUSE ::=
13021 -- OUTPUT_LIST =>[+] INPUT_LIST
13022 -- | NULL_DEPENDENCY_CLAUSE
13024 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
13026 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
13028 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
13030 -- OUTPUT ::= NAME | FUNCTION_RESULT
13033 -- where FUNCTION_RESULT is a function Result attribute_reference
13035 when Pragma_Depends => Depends : declare
13036 Subp_Decl : Node_Id;
13040 Check_Arg_Count (1);
13041 Ensure_Aggregate_Form (Arg1);
13043 -- Ensure the proper placement of the pragma. Depends must be
13044 -- associated with a subprogram declaration or a body that acts
13048 Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
13050 if Nkind (Subp_Decl) = N_Subprogram_Declaration then
13053 -- Body acts as spec
13055 elsif Nkind (Subp_Decl) = N_Subprogram_Body
13056 and then No (Corresponding_Spec (Subp_Decl))
13060 -- Body stub acts as spec
13062 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
13063 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
13072 -- When the pragma appears on a subprogram body, perform the full
13075 if Nkind (Subp_Decl) = N_Subprogram_Body then
13076 Analyze_Depends_In_Decl_Part (N);
13078 -- When Depends applies to a subprogram compilation unit, the
13079 -- corresponding pragma is placed after the unit's declaration
13080 -- node and needs to be analyzed immediately.
13082 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration
13083 and then Nkind (Parent (Subp_Decl)) = N_Compilation_Unit
13085 Analyze_Depends_In_Decl_Part (N);
13088 -- Chain the pragma on the contract for further processing
13090 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
13093 ---------------------
13094 -- Detect_Blocking --
13095 ---------------------
13097 -- pragma Detect_Blocking;
13099 when Pragma_Detect_Blocking =>
13101 Check_Arg_Count (0);
13102 Check_Valid_Configuration_Pragma;
13103 Detect_Blocking := True;
13105 --------------------------
13106 -- Default_Storage_Pool --
13107 --------------------------
13109 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
13111 when Pragma_Default_Storage_Pool =>
13113 Check_Arg_Count (1);
13115 -- Default_Storage_Pool can appear as a configuration pragma, or
13116 -- in a declarative part or a package spec.
13118 if not Is_Configuration_Pragma then
13119 Check_Is_In_Decl_Part_Or_Package_Spec;
13122 -- Case of Default_Storage_Pool (null);
13124 if Nkind (Expression (Arg1)) = N_Null then
13125 Analyze (Expression (Arg1));
13127 -- This is an odd case, this is not really an expression, so
13128 -- we don't have a type for it. So just set the type to Empty.
13130 Set_Etype (Expression (Arg1), Empty);
13132 -- Case of Default_Storage_Pool (storage_pool_NAME);
13135 -- If it's a configuration pragma, then the only allowed
13136 -- argument is "null".
13138 if Is_Configuration_Pragma then
13139 Error_Pragma_Arg ("NULL expected", Arg1);
13142 -- The expected type for a non-"null" argument is
13143 -- Root_Storage_Pool'Class.
13145 Analyze_And_Resolve
13146 (Get_Pragma_Arg (Arg1),
13147 Typ => Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
13150 -- Finally, record the pool name (or null). Freeze.Freeze_Entity
13151 -- for an access type will use this information to set the
13152 -- appropriate attributes of the access type.
13154 Default_Pool := Expression (Arg1);
13156 ------------------------------------
13157 -- Disable_Atomic_Synchronization --
13158 ------------------------------------
13160 -- pragma Disable_Atomic_Synchronization [(Entity)];
13162 when Pragma_Disable_Atomic_Synchronization =>
13164 Process_Disable_Enable_Atomic_Sync (Name_Suppress);
13166 -------------------
13167 -- Discard_Names --
13168 -------------------
13170 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
13172 when Pragma_Discard_Names => Discard_Names : declare
13177 Check_Ada_83_Warning;
13179 -- Deal with configuration pragma case
13181 if Arg_Count = 0 and then Is_Configuration_Pragma then
13182 Global_Discard_Names := True;
13185 -- Otherwise, check correct appropriate context
13188 Check_Is_In_Decl_Part_Or_Package_Spec;
13190 if Arg_Count = 0 then
13192 -- If there is no parameter, then from now on this pragma
13193 -- applies to any enumeration, exception or tagged type
13194 -- defined in the current declarative part, and recursively
13195 -- to any nested scope.
13197 Set_Discard_Names (Current_Scope);
13201 Check_Arg_Count (1);
13202 Check_Optional_Identifier (Arg1, Name_On);
13203 Check_Arg_Is_Local_Name (Arg1);
13205 E_Id := Get_Pragma_Arg (Arg1);
13207 if Etype (E_Id) = Any_Type then
13210 E := Entity (E_Id);
13213 if (Is_First_Subtype (E)
13215 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
13216 or else Ekind (E) = E_Exception
13218 Set_Discard_Names (E);
13219 Record_Rep_Item (E, N);
13223 ("inappropriate entity for pragma%", Arg1);
13230 ------------------------
13231 -- Dispatching_Domain --
13232 ------------------------
13234 -- pragma Dispatching_Domain (EXPRESSION);
13236 when Pragma_Dispatching_Domain => Dispatching_Domain : declare
13237 P : constant Node_Id := Parent (N);
13243 Check_No_Identifiers;
13244 Check_Arg_Count (1);
13246 -- This pragma is born obsolete, but not the aspect
13248 if not From_Aspect_Specification (N) then
13250 (No_Obsolescent_Features, Pragma_Identifier (N));
13253 if Nkind (P) = N_Task_Definition then
13254 Arg := Get_Pragma_Arg (Arg1);
13255 Ent := Defining_Identifier (Parent (P));
13257 -- The expression must be analyzed in the special manner
13258 -- described in "Handling of Default and Per-Object
13259 -- Expressions" in sem.ads.
13261 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
13263 -- Check duplicate pragma before we chain the pragma in the Rep
13264 -- Item chain of Ent.
13266 Check_Duplicate_Pragma (Ent);
13267 Record_Rep_Item (Ent, N);
13269 -- Anything else is incorrect
13274 end Dispatching_Domain;
13280 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
13282 when Pragma_Elaborate => Elaborate : declare
13287 -- Pragma must be in context items list of a compilation unit
13289 if not Is_In_Context_Clause then
13293 -- Must be at least one argument
13295 if Arg_Count = 0 then
13296 Error_Pragma ("pragma% requires at least one argument");
13299 -- In Ada 83 mode, there can be no items following it in the
13300 -- context list except other pragmas and implicit with clauses
13301 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
13302 -- placement rule does not apply.
13304 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
13306 while Present (Citem) loop
13307 if Nkind (Citem) = N_Pragma
13308 or else (Nkind (Citem) = N_With_Clause
13309 and then Implicit_With (Citem))
13314 ("(Ada 83) pragma% must be at end of context clause");
13321 -- Finally, the arguments must all be units mentioned in a with
13322 -- clause in the same context clause. Note we already checked (in
13323 -- Par.Prag) that the arguments are all identifiers or selected
13327 Outer : while Present (Arg) loop
13328 Citem := First (List_Containing (N));
13329 Inner : while Citem /= N loop
13330 if Nkind (Citem) = N_With_Clause
13331 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
13333 Set_Elaborate_Present (Citem, True);
13334 Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
13335 Generate_Reference (Entity (Name (Citem)), Citem);
13337 -- With the pragma present, elaboration calls on
13338 -- subprograms from the named unit need no further
13339 -- checks, as long as the pragma appears in the current
13340 -- compilation unit. If the pragma appears in some unit
13341 -- in the context, there might still be a need for an
13342 -- Elaborate_All_Desirable from the current compilation
13343 -- to the named unit, so we keep the check enabled.
13345 if In_Extended_Main_Source_Unit (N) then
13346 Set_Suppress_Elaboration_Warnings
13347 (Entity (Name (Citem)));
13358 ("argument of pragma% is not withed unit", Arg);
13364 -- Give a warning if operating in static mode with one of the
13365 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
13367 if Elab_Warnings and not Dynamic_Elaboration_Checks then
13369 ("?l?use of pragma Elaborate may not be safe", N);
13371 ("?l?use pragma Elaborate_All instead if possible", N);
13375 -------------------
13376 -- Elaborate_All --
13377 -------------------
13379 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
13381 when Pragma_Elaborate_All => Elaborate_All : declare
13386 Check_Ada_83_Warning;
13388 -- Pragma must be in context items list of a compilation unit
13390 if not Is_In_Context_Clause then
13394 -- Must be at least one argument
13396 if Arg_Count = 0 then
13397 Error_Pragma ("pragma% requires at least one argument");
13400 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
13401 -- have to appear at the end of the context clause, but may
13402 -- appear mixed in with other items, even in Ada 83 mode.
13404 -- Final check: the arguments must all be units mentioned in
13405 -- a with clause in the same context clause. Note that we
13406 -- already checked (in Par.Prag) that all the arguments are
13407 -- either identifiers or selected components.
13410 Outr : while Present (Arg) loop
13411 Citem := First (List_Containing (N));
13412 Innr : while Citem /= N loop
13413 if Nkind (Citem) = N_With_Clause
13414 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
13416 Set_Elaborate_All_Present (Citem, True);
13417 Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
13419 -- Suppress warnings and elaboration checks on the named
13420 -- unit if the pragma is in the current compilation, as
13421 -- for pragma Elaborate.
13423 if In_Extended_Main_Source_Unit (N) then
13424 Set_Suppress_Elaboration_Warnings
13425 (Entity (Name (Citem)));
13434 Set_Error_Posted (N);
13436 ("argument of pragma% is not withed unit", Arg);
13443 --------------------
13444 -- Elaborate_Body --
13445 --------------------
13447 -- pragma Elaborate_Body [( library_unit_NAME )];
13449 when Pragma_Elaborate_Body => Elaborate_Body : declare
13450 Cunit_Node : Node_Id;
13451 Cunit_Ent : Entity_Id;
13454 Check_Ada_83_Warning;
13455 Check_Valid_Library_Unit_Pragma;
13457 if Nkind (N) = N_Null_Statement then
13461 Cunit_Node := Cunit (Current_Sem_Unit);
13462 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
13464 if Nkind_In (Unit (Cunit_Node), N_Package_Body,
13467 Error_Pragma ("pragma% must refer to a spec, not a body");
13469 Set_Body_Required (Cunit_Node, True);
13470 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
13472 -- If we are in dynamic elaboration mode, then we suppress
13473 -- elaboration warnings for the unit, since it is definitely
13474 -- fine NOT to do dynamic checks at the first level (and such
13475 -- checks will be suppressed because no elaboration boolean
13476 -- is created for Elaborate_Body packages).
13478 -- But in the static model of elaboration, Elaborate_Body is
13479 -- definitely NOT good enough to ensure elaboration safety on
13480 -- its own, since the body may WITH other units that are not
13481 -- safe from an elaboration point of view, so a client must
13482 -- still do an Elaborate_All on such units.
13484 -- Debug flag -gnatdD restores the old behavior of 3.13, where
13485 -- Elaborate_Body always suppressed elab warnings.
13487 if Dynamic_Elaboration_Checks or Debug_Flag_DD then
13488 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
13491 end Elaborate_Body;
13493 ------------------------
13494 -- Elaboration_Checks --
13495 ------------------------
13497 -- pragma Elaboration_Checks (Static | Dynamic);
13499 when Pragma_Elaboration_Checks =>
13501 Check_Arg_Count (1);
13502 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
13503 Dynamic_Elaboration_Checks :=
13504 (Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic);
13510 -- pragma Eliminate (
13511 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
13512 -- [,[Entity =>] IDENTIFIER |
13513 -- SELECTED_COMPONENT |
13515 -- [, OVERLOADING_RESOLUTION]);
13517 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
13520 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
13521 -- FUNCTION_PROFILE
13523 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
13525 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
13526 -- Result_Type => result_SUBTYPE_NAME]
13528 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
13529 -- SUBTYPE_NAME ::= STRING_LITERAL
13531 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
13532 -- SOURCE_TRACE ::= STRING_LITERAL
13534 when Pragma_Eliminate => Eliminate : declare
13535 Args : Args_List (1 .. 5);
13536 Names : constant Name_List (1 .. 5) := (
13539 Name_Parameter_Types,
13541 Name_Source_Location);
13543 Unit_Name : Node_Id renames Args (1);
13544 Entity : Node_Id renames Args (2);
13545 Parameter_Types : Node_Id renames Args (3);
13546 Result_Type : Node_Id renames Args (4);
13547 Source_Location : Node_Id renames Args (5);
13551 Check_Valid_Configuration_Pragma;
13552 Gather_Associations (Names, Args);
13554 if No (Unit_Name) then
13555 Error_Pragma ("missing Unit_Name argument for pragma%");
13559 and then (Present (Parameter_Types)
13561 Present (Result_Type)
13563 Present (Source_Location))
13565 Error_Pragma ("missing Entity argument for pragma%");
13568 if (Present (Parameter_Types)
13570 Present (Result_Type))
13572 Present (Source_Location)
13575 ("parameter profile and source location cannot be used "
13576 & "together in pragma%");
13579 Process_Eliminate_Pragma
13588 -----------------------------------
13589 -- Enable_Atomic_Synchronization --
13590 -----------------------------------
13592 -- pragma Enable_Atomic_Synchronization [(Entity)];
13594 when Pragma_Enable_Atomic_Synchronization =>
13596 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
13603 -- [ Convention =>] convention_IDENTIFIER,
13604 -- [ Entity =>] local_NAME
13605 -- [, [External_Name =>] static_string_EXPRESSION ]
13606 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13608 when Pragma_Export => Export : declare
13610 Def_Id : Entity_Id;
13612 pragma Warnings (Off, C);
13615 Check_Ada_83_Warning;
13619 Name_External_Name,
13622 Check_At_Least_N_Arguments (2);
13623 Check_At_Most_N_Arguments (4);
13625 -- In Relaxed_RM_Semantics, support old Ada 83 style:
13626 -- pragma Export (Entity, "external name");
13628 if Relaxed_RM_Semantics
13629 and then Arg_Count = 2
13630 and then Nkind (Expression (Arg2)) = N_String_Literal
13633 Def_Id := Get_Pragma_Arg (Arg1);
13636 if not Is_Entity_Name (Def_Id) then
13637 Error_Pragma_Arg ("entity name required", Arg1);
13640 Def_Id := Entity (Def_Id);
13641 Set_Exported (Def_Id, Arg1);
13644 Process_Convention (C, Def_Id);
13646 if Ekind (Def_Id) /= E_Constant then
13647 Note_Possible_Modification
13648 (Get_Pragma_Arg (Arg2), Sure => False);
13651 Process_Interface_Name (Def_Id, Arg3, Arg4);
13652 Set_Exported (Def_Id, Arg2);
13655 -- If the entity is a deferred constant, propagate the information
13656 -- to the full view, because gigi elaborates the full view only.
13658 if Ekind (Def_Id) = E_Constant
13659 and then Present (Full_View (Def_Id))
13662 Id2 : constant Entity_Id := Full_View (Def_Id);
13664 Set_Is_Exported (Id2, Is_Exported (Def_Id));
13665 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
13666 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
13671 ----------------------
13672 -- Export_Exception --
13673 ----------------------
13675 -- pragma Export_Exception (
13676 -- [Internal =>] LOCAL_NAME
13677 -- [, [External =>] EXTERNAL_SYMBOL]
13678 -- [, [Form =>] Ada | VMS]
13679 -- [, [Code =>] static_integer_EXPRESSION]);
13681 when Pragma_Export_Exception => Export_Exception : declare
13682 Args : Args_List (1 .. 4);
13683 Names : constant Name_List (1 .. 4) := (
13689 Internal : Node_Id renames Args (1);
13690 External : Node_Id renames Args (2);
13691 Form : Node_Id renames Args (3);
13692 Code : Node_Id renames Args (4);
13697 if Inside_A_Generic then
13698 Error_Pragma ("pragma% cannot be used for generic entities");
13701 Gather_Associations (Names, Args);
13702 Process_Extended_Import_Export_Exception_Pragma (
13703 Arg_Internal => Internal,
13704 Arg_External => External,
13708 if not Is_VMS_Exception (Entity (Internal)) then
13709 Set_Exported (Entity (Internal), Internal);
13711 end Export_Exception;
13713 ---------------------
13714 -- Export_Function --
13715 ---------------------
13717 -- pragma Export_Function (
13718 -- [Internal =>] LOCAL_NAME
13719 -- [, [External =>] EXTERNAL_SYMBOL]
13720 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13721 -- [, [Result_Type =>] TYPE_DESIGNATOR]
13722 -- [, [Mechanism =>] MECHANISM]
13723 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
13725 -- EXTERNAL_SYMBOL ::=
13727 -- | static_string_EXPRESSION
13729 -- PARAMETER_TYPES ::=
13731 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13733 -- TYPE_DESIGNATOR ::=
13735 -- | subtype_Name ' Access
13739 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13741 -- MECHANISM_ASSOCIATION ::=
13742 -- [formal_parameter_NAME =>] MECHANISM_NAME
13744 -- MECHANISM_NAME ::=
13747 -- | Descriptor [([Class =>] CLASS_NAME)]
13749 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
13751 when Pragma_Export_Function => Export_Function : declare
13752 Args : Args_List (1 .. 6);
13753 Names : constant Name_List (1 .. 6) := (
13756 Name_Parameter_Types,
13759 Name_Result_Mechanism);
13761 Internal : Node_Id renames Args (1);
13762 External : Node_Id renames Args (2);
13763 Parameter_Types : Node_Id renames Args (3);
13764 Result_Type : Node_Id renames Args (4);
13765 Mechanism : Node_Id renames Args (5);
13766 Result_Mechanism : Node_Id renames Args (6);
13770 Gather_Associations (Names, Args);
13771 Process_Extended_Import_Export_Subprogram_Pragma (
13772 Arg_Internal => Internal,
13773 Arg_External => External,
13774 Arg_Parameter_Types => Parameter_Types,
13775 Arg_Result_Type => Result_Type,
13776 Arg_Mechanism => Mechanism,
13777 Arg_Result_Mechanism => Result_Mechanism);
13778 end Export_Function;
13780 -------------------
13781 -- Export_Object --
13782 -------------------
13784 -- pragma Export_Object (
13785 -- [Internal =>] LOCAL_NAME
13786 -- [, [External =>] EXTERNAL_SYMBOL]
13787 -- [, [Size =>] EXTERNAL_SYMBOL]);
13789 -- EXTERNAL_SYMBOL ::=
13791 -- | static_string_EXPRESSION
13793 -- PARAMETER_TYPES ::=
13795 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13797 -- TYPE_DESIGNATOR ::=
13799 -- | subtype_Name ' Access
13803 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13805 -- MECHANISM_ASSOCIATION ::=
13806 -- [formal_parameter_NAME =>] MECHANISM_NAME
13808 -- MECHANISM_NAME ::=
13811 -- | Descriptor [([Class =>] CLASS_NAME)]
13813 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
13815 when Pragma_Export_Object => Export_Object : declare
13816 Args : Args_List (1 .. 3);
13817 Names : constant Name_List (1 .. 3) := (
13822 Internal : Node_Id renames Args (1);
13823 External : Node_Id renames Args (2);
13824 Size : Node_Id renames Args (3);
13828 Gather_Associations (Names, Args);
13829 Process_Extended_Import_Export_Object_Pragma (
13830 Arg_Internal => Internal,
13831 Arg_External => External,
13835 ----------------------
13836 -- Export_Procedure --
13837 ----------------------
13839 -- pragma Export_Procedure (
13840 -- [Internal =>] LOCAL_NAME
13841 -- [, [External =>] EXTERNAL_SYMBOL]
13842 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13843 -- [, [Mechanism =>] MECHANISM]);
13845 -- EXTERNAL_SYMBOL ::=
13847 -- | static_string_EXPRESSION
13849 -- PARAMETER_TYPES ::=
13851 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13853 -- TYPE_DESIGNATOR ::=
13855 -- | subtype_Name ' Access
13859 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13861 -- MECHANISM_ASSOCIATION ::=
13862 -- [formal_parameter_NAME =>] MECHANISM_NAME
13864 -- MECHANISM_NAME ::=
13867 -- | Descriptor [([Class =>] CLASS_NAME)]
13869 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
13871 when Pragma_Export_Procedure => Export_Procedure : declare
13872 Args : Args_List (1 .. 4);
13873 Names : constant Name_List (1 .. 4) := (
13876 Name_Parameter_Types,
13879 Internal : Node_Id renames Args (1);
13880 External : Node_Id renames Args (2);
13881 Parameter_Types : Node_Id renames Args (3);
13882 Mechanism : Node_Id renames Args (4);
13886 Gather_Associations (Names, Args);
13887 Process_Extended_Import_Export_Subprogram_Pragma (
13888 Arg_Internal => Internal,
13889 Arg_External => External,
13890 Arg_Parameter_Types => Parameter_Types,
13891 Arg_Mechanism => Mechanism);
13892 end Export_Procedure;
13898 -- pragma Export_Value (
13899 -- [Value =>] static_integer_EXPRESSION,
13900 -- [Link_Name =>] static_string_EXPRESSION);
13902 when Pragma_Export_Value =>
13904 Check_Arg_Order ((Name_Value, Name_Link_Name));
13905 Check_Arg_Count (2);
13907 Check_Optional_Identifier (Arg1, Name_Value);
13908 Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
13910 Check_Optional_Identifier (Arg2, Name_Link_Name);
13911 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
13913 -----------------------------
13914 -- Export_Valued_Procedure --
13915 -----------------------------
13917 -- pragma Export_Valued_Procedure (
13918 -- [Internal =>] LOCAL_NAME
13919 -- [, [External =>] EXTERNAL_SYMBOL,]
13920 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13921 -- [, [Mechanism =>] MECHANISM]);
13923 -- EXTERNAL_SYMBOL ::=
13925 -- | static_string_EXPRESSION
13927 -- PARAMETER_TYPES ::=
13929 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13931 -- TYPE_DESIGNATOR ::=
13933 -- | subtype_Name ' Access
13937 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13939 -- MECHANISM_ASSOCIATION ::=
13940 -- [formal_parameter_NAME =>] MECHANISM_NAME
13942 -- MECHANISM_NAME ::=
13945 -- | Descriptor [([Class =>] CLASS_NAME)]
13947 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
13949 when Pragma_Export_Valued_Procedure =>
13950 Export_Valued_Procedure : declare
13951 Args : Args_List (1 .. 4);
13952 Names : constant Name_List (1 .. 4) := (
13955 Name_Parameter_Types,
13958 Internal : Node_Id renames Args (1);
13959 External : Node_Id renames Args (2);
13960 Parameter_Types : Node_Id renames Args (3);
13961 Mechanism : Node_Id renames Args (4);
13965 Gather_Associations (Names, Args);
13966 Process_Extended_Import_Export_Subprogram_Pragma (
13967 Arg_Internal => Internal,
13968 Arg_External => External,
13969 Arg_Parameter_Types => Parameter_Types,
13970 Arg_Mechanism => Mechanism);
13971 end Export_Valued_Procedure;
13973 -------------------
13974 -- Extend_System --
13975 -------------------
13977 -- pragma Extend_System ([Name =>] Identifier);
13979 when Pragma_Extend_System => Extend_System : declare
13982 Check_Valid_Configuration_Pragma;
13983 Check_Arg_Count (1);
13984 Check_Optional_Identifier (Arg1, Name_Name);
13985 Check_Arg_Is_Identifier (Arg1);
13987 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
13990 and then Name_Buffer (1 .. 4) = "aux_"
13992 if Present (System_Extend_Pragma_Arg) then
13993 if Chars (Get_Pragma_Arg (Arg1)) =
13994 Chars (Expression (System_Extend_Pragma_Arg))
13998 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
13999 Error_Pragma ("pragma% conflicts with that #");
14003 System_Extend_Pragma_Arg := Arg1;
14005 if not GNAT_Mode then
14006 System_Extend_Unit := Arg1;
14010 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
14014 ------------------------
14015 -- Extensions_Allowed --
14016 ------------------------
14018 -- pragma Extensions_Allowed (ON | OFF);
14020 when Pragma_Extensions_Allowed =>
14022 Check_Arg_Count (1);
14023 Check_No_Identifiers;
14024 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
14026 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
14027 Extensions_Allowed := True;
14028 Ada_Version := Ada_Version_Type'Last;
14031 Extensions_Allowed := False;
14032 Ada_Version := Ada_Version_Explicit;
14033 Ada_Version_Pragma := Empty;
14040 -- pragma External (
14041 -- [ Convention =>] convention_IDENTIFIER,
14042 -- [ Entity =>] local_NAME
14043 -- [, [External_Name =>] static_string_EXPRESSION ]
14044 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14046 when Pragma_External => External : declare
14047 Def_Id : Entity_Id;
14050 pragma Warnings (Off, C);
14057 Name_External_Name,
14059 Check_At_Least_N_Arguments (2);
14060 Check_At_Most_N_Arguments (4);
14061 Process_Convention (C, Def_Id);
14062 Note_Possible_Modification
14063 (Get_Pragma_Arg (Arg2), Sure => False);
14064 Process_Interface_Name (Def_Id, Arg3, Arg4);
14065 Set_Exported (Def_Id, Arg2);
14068 --------------------------
14069 -- External_Name_Casing --
14070 --------------------------
14072 -- pragma External_Name_Casing (
14073 -- UPPERCASE | LOWERCASE
14074 -- [, AS_IS | UPPERCASE | LOWERCASE]);
14076 when Pragma_External_Name_Casing => External_Name_Casing : declare
14079 Check_No_Identifiers;
14081 if Arg_Count = 2 then
14082 Check_Arg_Is_One_Of
14083 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
14085 case Chars (Get_Pragma_Arg (Arg2)) is
14087 Opt.External_Name_Exp_Casing := As_Is;
14089 when Name_Uppercase =>
14090 Opt.External_Name_Exp_Casing := Uppercase;
14092 when Name_Lowercase =>
14093 Opt.External_Name_Exp_Casing := Lowercase;
14100 Check_Arg_Count (1);
14103 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
14105 case Chars (Get_Pragma_Arg (Arg1)) is
14106 when Name_Uppercase =>
14107 Opt.External_Name_Imp_Casing := Uppercase;
14109 when Name_Lowercase =>
14110 Opt.External_Name_Imp_Casing := Lowercase;
14115 end External_Name_Casing;
14121 -- pragma Fast_Math;
14123 when Pragma_Fast_Math =>
14125 Check_No_Identifiers;
14126 Check_Valid_Configuration_Pragma;
14129 --------------------------
14130 -- Favor_Top_Level --
14131 --------------------------
14133 -- pragma Favor_Top_Level (type_NAME);
14135 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
14136 Named_Entity : Entity_Id;
14140 Check_No_Identifiers;
14141 Check_Arg_Count (1);
14142 Check_Arg_Is_Local_Name (Arg1);
14143 Named_Entity := Entity (Get_Pragma_Arg (Arg1));
14145 -- If it's an access-to-subprogram type (in particular, not a
14146 -- subtype), set the flag on that type.
14148 if Is_Access_Subprogram_Type (Named_Entity) then
14149 Set_Can_Use_Internal_Rep (Named_Entity, False);
14151 -- Otherwise it's an error (name denotes the wrong sort of entity)
14155 ("access-to-subprogram type expected",
14156 Get_Pragma_Arg (Arg1));
14158 end Favor_Top_Level;
14160 ---------------------------
14161 -- Finalize_Storage_Only --
14162 ---------------------------
14164 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
14166 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
14167 Assoc : constant Node_Id := Arg1;
14168 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
14173 Check_No_Identifiers;
14174 Check_Arg_Count (1);
14175 Check_Arg_Is_Local_Name (Arg1);
14177 Find_Type (Type_Id);
14178 Typ := Entity (Type_Id);
14181 or else Rep_Item_Too_Early (Typ, N)
14185 Typ := Underlying_Type (Typ);
14188 if not Is_Controlled (Typ) then
14189 Error_Pragma ("pragma% must specify controlled type");
14192 Check_First_Subtype (Arg1);
14194 if Finalize_Storage_Only (Typ) then
14195 Error_Pragma ("duplicate pragma%, only one allowed");
14197 elsif not Rep_Item_Too_Late (Typ, N) then
14198 Set_Finalize_Storage_Only (Base_Type (Typ), True);
14200 end Finalize_Storage;
14202 --------------------------
14203 -- Float_Representation --
14204 --------------------------
14206 -- pragma Float_Representation (FLOAT_REP[, float_type_LOCAL_NAME]);
14208 -- FLOAT_REP ::= VAX_Float | IEEE_Float
14210 when Pragma_Float_Representation => Float_Representation : declare
14218 if Arg_Count = 1 then
14219 Check_Valid_Configuration_Pragma;
14221 Check_Arg_Count (2);
14222 Check_Optional_Identifier (Arg2, Name_Entity);
14223 Check_Arg_Is_Local_Name (Arg2);
14226 Check_No_Identifier (Arg1);
14227 Check_Arg_Is_One_Of (Arg1, Name_VAX_Float, Name_IEEE_Float);
14229 if not OpenVMS_On_Target then
14230 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
14232 ("??pragma% ignored (applies only to Open'V'M'S)");
14238 -- One argument case
14240 if Arg_Count = 1 then
14241 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
14242 if Opt.Float_Format = 'I' then
14243 Error_Pragma ("'I'E'E'E format previously specified");
14246 Opt.Float_Format := 'V';
14249 if Opt.Float_Format = 'V' then
14250 Error_Pragma ("'V'A'X format previously specified");
14253 Opt.Float_Format := 'I';
14256 Set_Standard_Fpt_Formats;
14258 -- Two argument case
14261 Argx := Get_Pragma_Arg (Arg2);
14263 if not Is_Entity_Name (Argx)
14264 or else not Is_Floating_Point_Type (Entity (Argx))
14267 ("second argument of% pragma must be floating-point type",
14271 Ent := Entity (Argx);
14272 Digs := UI_To_Int (Digits_Value (Ent));
14274 -- Two arguments, VAX_Float case
14276 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
14278 when 6 => Set_F_Float (Ent);
14279 when 9 => Set_D_Float (Ent);
14280 when 15 => Set_G_Float (Ent);
14284 ("wrong digits value, must be 6,9 or 15", Arg2);
14287 -- Two arguments, IEEE_Float case
14291 when 6 => Set_IEEE_Short (Ent);
14292 when 15 => Set_IEEE_Long (Ent);
14296 ("wrong digits value, must be 6 or 15", Arg2);
14300 end Float_Representation;
14306 -- pragma Global (GLOBAL_SPECIFICATION);
14308 -- GLOBAL_SPECIFICATION ::=
14311 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
14313 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
14315 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
14316 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
14317 -- GLOBAL_ITEM ::= NAME
14319 when Pragma_Global => Global : declare
14320 Subp_Decl : Node_Id;
14324 Check_Arg_Count (1);
14325 Ensure_Aggregate_Form (Arg1);
14327 -- Ensure the proper placement of the pragma. Global must be
14328 -- associated with a subprogram declaration or a body that acts
14332 Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
14334 if Nkind (Subp_Decl) = N_Subprogram_Declaration then
14337 -- Body acts as spec
14339 elsif Nkind (Subp_Decl) = N_Subprogram_Body
14340 and then No (Corresponding_Spec (Subp_Decl))
14344 -- Body stub acts as spec
14346 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
14347 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
14356 -- When the pragma appears on a subprogram body, perform the full
14359 if Nkind (Subp_Decl) = N_Subprogram_Body then
14360 Analyze_Global_In_Decl_Part (N);
14362 -- When Global applies to a subprogram compilation unit, the
14363 -- corresponding pragma is placed after the unit's declaration
14364 -- node and needs to be analyzed immediately.
14366 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration
14367 and then Nkind (Parent (Subp_Decl)) = N_Compilation_Unit
14369 Analyze_Global_In_Decl_Part (N);
14372 -- Chain the pragma on the contract for further processing
14374 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
14381 -- pragma Ident (static_string_EXPRESSION)
14383 -- Note: pragma Comment shares this processing. Pragma Comment is
14384 -- identical to Ident, except that the restriction of the argument to
14385 -- 31 characters and the placement restrictions are not enforced for
14388 when Pragma_Ident | Pragma_Comment => Ident : declare
14393 Check_Arg_Count (1);
14394 Check_No_Identifiers;
14395 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
14398 -- For pragma Ident, preserve DEC compatibility by requiring the
14399 -- pragma to appear in a declarative part or package spec.
14401 if Prag_Id = Pragma_Ident then
14402 Check_Is_In_Decl_Part_Or_Package_Spec;
14405 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
14412 GP := Parent (Parent (N));
14414 if Nkind_In (GP, N_Package_Declaration,
14415 N_Generic_Package_Declaration)
14420 -- If we have a compilation unit, then record the ident value,
14421 -- checking for improper duplication.
14423 if Nkind (GP) = N_Compilation_Unit then
14424 CS := Ident_String (Current_Sem_Unit);
14426 if Present (CS) then
14428 -- For Ident, we do not permit multiple instances
14430 if Prag_Id = Pragma_Ident then
14431 Error_Pragma ("duplicate% pragma not permitted");
14433 -- For Comment, we concatenate the string, unless we want
14434 -- to preserve the tree structure for ASIS.
14436 elsif not ASIS_Mode then
14437 Start_String (Strval (CS));
14438 Store_String_Char (' ');
14439 Store_String_Chars (Strval (Str));
14440 Set_Strval (CS, End_String);
14444 -- In VMS, the effect of IDENT is achieved by passing
14445 -- --identification=name as a --for-linker switch.
14447 if OpenVMS_On_Target then
14450 ("--for-linker=--identification=");
14451 String_To_Name_Buffer (Strval (Str));
14452 Store_String_Chars (Name_Buffer (1 .. Name_Len));
14454 -- Only the last processed IDENT is saved. The main
14455 -- purpose is so an IDENT associated with a main
14456 -- procedure will be used in preference to an IDENT
14457 -- associated with a with'd package.
14459 Replace_Linker_Option_String
14460 (End_String, "--for-linker=--identification=");
14463 Set_Ident_String (Current_Sem_Unit, Str);
14466 -- For subunits, we just ignore the Ident, since in GNAT these
14467 -- are not separate object files, and hence not separate units
14468 -- in the unit table.
14470 elsif Nkind (GP) = N_Subunit then
14473 -- Otherwise we have a misplaced pragma Ident, but we ignore
14474 -- this if we are in an instantiation, since it comes from
14475 -- a generic, and has no relevance to the instantiation.
14477 elsif Prag_Id = Pragma_Ident then
14478 if Instantiation_Location (Loc) = No_Location then
14479 Error_Pragma ("pragma% only allowed at outer level");
14485 ----------------------------
14486 -- Implementation_Defined --
14487 ----------------------------
14489 -- pragma Implementation_Defined (local_NAME);
14491 -- Marks previously declared entity as implementation defined. For
14492 -- an overloaded entity, applies to the most recent homonym.
14494 -- pragma Implementation_Defined;
14496 -- The form with no arguments appears anywhere within a scope, most
14497 -- typically a package spec, and indicates that all entities that are
14498 -- defined within the package spec are Implementation_Defined.
14500 when Pragma_Implementation_Defined => Implementation_Defined : declare
14505 Check_No_Identifiers;
14507 -- Form with no arguments
14509 if Arg_Count = 0 then
14510 Set_Is_Implementation_Defined (Current_Scope);
14512 -- Form with one argument
14515 Check_Arg_Count (1);
14516 Check_Arg_Is_Local_Name (Arg1);
14517 Ent := Entity (Get_Pragma_Arg (Arg1));
14518 Set_Is_Implementation_Defined (Ent);
14520 end Implementation_Defined;
14526 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
14528 -- IMPLEMENTATION_KIND ::=
14529 -- By_Entry | By_Protected_Procedure | By_Any | Optional
14531 -- "By_Any" and "Optional" are treated as synonyms in order to
14532 -- support Ada 2012 aspect Synchronization.
14534 when Pragma_Implemented => Implemented : declare
14535 Proc_Id : Entity_Id;
14540 Check_Arg_Count (2);
14541 Check_No_Identifiers;
14542 Check_Arg_Is_Identifier (Arg1);
14543 Check_Arg_Is_Local_Name (Arg1);
14544 Check_Arg_Is_One_Of (Arg2,
14547 Name_By_Protected_Procedure,
14550 -- Extract the name of the local procedure
14552 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
14554 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
14555 -- primitive procedure of a synchronized tagged type.
14557 if Ekind (Proc_Id) = E_Procedure
14558 and then Is_Primitive (Proc_Id)
14559 and then Present (First_Formal (Proc_Id))
14561 Typ := Etype (First_Formal (Proc_Id));
14563 if Is_Tagged_Type (Typ)
14566 -- Check for a protected, a synchronized or a task interface
14568 ((Is_Interface (Typ)
14569 and then Is_Synchronized_Interface (Typ))
14571 -- Check for a protected type or a task type that implements
14575 (Is_Concurrent_Record_Type (Typ)
14576 and then Present (Interfaces (Typ)))
14578 -- Check for a private record extension with keyword
14582 (Ekind_In (Typ, E_Record_Type_With_Private,
14583 E_Record_Subtype_With_Private)
14584 and then Synchronized_Present (Parent (Typ))))
14589 ("controlling formal must be of synchronized tagged type",
14594 -- Procedures declared inside a protected type must be accepted
14596 elsif Ekind (Proc_Id) = E_Procedure
14597 and then Is_Protected_Type (Scope (Proc_Id))
14601 -- The first argument is not a primitive procedure
14605 ("pragma % must be applied to a primitive procedure", Arg1);
14609 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
14610 -- By_Protected_Procedure to the primitive procedure of a task
14613 if Chars (Arg2) = Name_By_Protected_Procedure
14614 and then Is_Interface (Typ)
14615 and then Is_Task_Interface (Typ)
14618 ("implementation kind By_Protected_Procedure cannot be "
14619 & "applied to a task interface primitive", Arg2);
14623 Record_Rep_Item (Proc_Id, N);
14626 ----------------------
14627 -- Implicit_Packing --
14628 ----------------------
14630 -- pragma Implicit_Packing;
14632 when Pragma_Implicit_Packing =>
14634 Check_Arg_Count (0);
14635 Implicit_Packing := True;
14642 -- [Convention =>] convention_IDENTIFIER,
14643 -- [Entity =>] local_NAME
14644 -- [, [External_Name =>] static_string_EXPRESSION ]
14645 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14647 when Pragma_Import =>
14648 Check_Ada_83_Warning;
14652 Name_External_Name,
14655 Check_At_Least_N_Arguments (2);
14656 Check_At_Most_N_Arguments (4);
14657 Process_Import_Or_Interface;
14659 ----------------------
14660 -- Import_Exception --
14661 ----------------------
14663 -- pragma Import_Exception (
14664 -- [Internal =>] LOCAL_NAME
14665 -- [, [External =>] EXTERNAL_SYMBOL]
14666 -- [, [Form =>] Ada | VMS]
14667 -- [, [Code =>] static_integer_EXPRESSION]);
14669 when Pragma_Import_Exception => Import_Exception : declare
14670 Args : Args_List (1 .. 4);
14671 Names : constant Name_List (1 .. 4) := (
14677 Internal : Node_Id renames Args (1);
14678 External : Node_Id renames Args (2);
14679 Form : Node_Id renames Args (3);
14680 Code : Node_Id renames Args (4);
14684 Gather_Associations (Names, Args);
14686 if Present (External) and then Present (Code) then
14688 ("cannot give both External and Code options for pragma%");
14691 Process_Extended_Import_Export_Exception_Pragma (
14692 Arg_Internal => Internal,
14693 Arg_External => External,
14697 if not Is_VMS_Exception (Entity (Internal)) then
14698 Set_Imported (Entity (Internal));
14700 end Import_Exception;
14702 ---------------------
14703 -- Import_Function --
14704 ---------------------
14706 -- pragma Import_Function (
14707 -- [Internal =>] LOCAL_NAME,
14708 -- [, [External =>] EXTERNAL_SYMBOL]
14709 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14710 -- [, [Result_Type =>] SUBTYPE_MARK]
14711 -- [, [Mechanism =>] MECHANISM]
14712 -- [, [Result_Mechanism =>] MECHANISM_NAME]
14713 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
14715 -- EXTERNAL_SYMBOL ::=
14717 -- | static_string_EXPRESSION
14719 -- PARAMETER_TYPES ::=
14721 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14723 -- TYPE_DESIGNATOR ::=
14725 -- | subtype_Name ' Access
14729 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14731 -- MECHANISM_ASSOCIATION ::=
14732 -- [formal_parameter_NAME =>] MECHANISM_NAME
14734 -- MECHANISM_NAME ::=
14737 -- | Descriptor [([Class =>] CLASS_NAME)]
14739 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
14741 when Pragma_Import_Function => Import_Function : declare
14742 Args : Args_List (1 .. 7);
14743 Names : constant Name_List (1 .. 7) := (
14746 Name_Parameter_Types,
14749 Name_Result_Mechanism,
14750 Name_First_Optional_Parameter);
14752 Internal : Node_Id renames Args (1);
14753 External : Node_Id renames Args (2);
14754 Parameter_Types : Node_Id renames Args (3);
14755 Result_Type : Node_Id renames Args (4);
14756 Mechanism : Node_Id renames Args (5);
14757 Result_Mechanism : Node_Id renames Args (6);
14758 First_Optional_Parameter : Node_Id renames Args (7);
14762 Gather_Associations (Names, Args);
14763 Process_Extended_Import_Export_Subprogram_Pragma (
14764 Arg_Internal => Internal,
14765 Arg_External => External,
14766 Arg_Parameter_Types => Parameter_Types,
14767 Arg_Result_Type => Result_Type,
14768 Arg_Mechanism => Mechanism,
14769 Arg_Result_Mechanism => Result_Mechanism,
14770 Arg_First_Optional_Parameter => First_Optional_Parameter);
14771 end Import_Function;
14773 -------------------
14774 -- Import_Object --
14775 -------------------
14777 -- pragma Import_Object (
14778 -- [Internal =>] LOCAL_NAME
14779 -- [, [External =>] EXTERNAL_SYMBOL]
14780 -- [, [Size =>] EXTERNAL_SYMBOL]);
14782 -- EXTERNAL_SYMBOL ::=
14784 -- | static_string_EXPRESSION
14786 when Pragma_Import_Object => Import_Object : declare
14787 Args : Args_List (1 .. 3);
14788 Names : constant Name_List (1 .. 3) := (
14793 Internal : Node_Id renames Args (1);
14794 External : Node_Id renames Args (2);
14795 Size : Node_Id renames Args (3);
14799 Gather_Associations (Names, Args);
14800 Process_Extended_Import_Export_Object_Pragma (
14801 Arg_Internal => Internal,
14802 Arg_External => External,
14806 ----------------------
14807 -- Import_Procedure --
14808 ----------------------
14810 -- pragma Import_Procedure (
14811 -- [Internal =>] LOCAL_NAME
14812 -- [, [External =>] EXTERNAL_SYMBOL]
14813 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14814 -- [, [Mechanism =>] MECHANISM]
14815 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
14817 -- EXTERNAL_SYMBOL ::=
14819 -- | static_string_EXPRESSION
14821 -- PARAMETER_TYPES ::=
14823 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14825 -- TYPE_DESIGNATOR ::=
14827 -- | subtype_Name ' Access
14831 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14833 -- MECHANISM_ASSOCIATION ::=
14834 -- [formal_parameter_NAME =>] MECHANISM_NAME
14836 -- MECHANISM_NAME ::=
14839 -- | Descriptor [([Class =>] CLASS_NAME)]
14841 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
14843 when Pragma_Import_Procedure => Import_Procedure : declare
14844 Args : Args_List (1 .. 5);
14845 Names : constant Name_List (1 .. 5) := (
14848 Name_Parameter_Types,
14850 Name_First_Optional_Parameter);
14852 Internal : Node_Id renames Args (1);
14853 External : Node_Id renames Args (2);
14854 Parameter_Types : Node_Id renames Args (3);
14855 Mechanism : Node_Id renames Args (4);
14856 First_Optional_Parameter : Node_Id renames Args (5);
14860 Gather_Associations (Names, Args);
14861 Process_Extended_Import_Export_Subprogram_Pragma (
14862 Arg_Internal => Internal,
14863 Arg_External => External,
14864 Arg_Parameter_Types => Parameter_Types,
14865 Arg_Mechanism => Mechanism,
14866 Arg_First_Optional_Parameter => First_Optional_Parameter);
14867 end Import_Procedure;
14869 -----------------------------
14870 -- Import_Valued_Procedure --
14871 -----------------------------
14873 -- pragma Import_Valued_Procedure (
14874 -- [Internal =>] LOCAL_NAME
14875 -- [, [External =>] EXTERNAL_SYMBOL]
14876 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14877 -- [, [Mechanism =>] MECHANISM]
14878 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
14880 -- EXTERNAL_SYMBOL ::=
14882 -- | static_string_EXPRESSION
14884 -- PARAMETER_TYPES ::=
14886 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14888 -- TYPE_DESIGNATOR ::=
14890 -- | subtype_Name ' Access
14894 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14896 -- MECHANISM_ASSOCIATION ::=
14897 -- [formal_parameter_NAME =>] MECHANISM_NAME
14899 -- MECHANISM_NAME ::=
14902 -- | Descriptor [([Class =>] CLASS_NAME)]
14904 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
14906 when Pragma_Import_Valued_Procedure =>
14907 Import_Valued_Procedure : declare
14908 Args : Args_List (1 .. 5);
14909 Names : constant Name_List (1 .. 5) := (
14912 Name_Parameter_Types,
14914 Name_First_Optional_Parameter);
14916 Internal : Node_Id renames Args (1);
14917 External : Node_Id renames Args (2);
14918 Parameter_Types : Node_Id renames Args (3);
14919 Mechanism : Node_Id renames Args (4);
14920 First_Optional_Parameter : Node_Id renames Args (5);
14924 Gather_Associations (Names, Args);
14925 Process_Extended_Import_Export_Subprogram_Pragma (
14926 Arg_Internal => Internal,
14927 Arg_External => External,
14928 Arg_Parameter_Types => Parameter_Types,
14929 Arg_Mechanism => Mechanism,
14930 Arg_First_Optional_Parameter => First_Optional_Parameter);
14931 end Import_Valued_Procedure;
14937 -- pragma Independent (LOCAL_NAME);
14939 when Pragma_Independent => Independent : declare
14946 Check_Ada_83_Warning;
14948 Check_No_Identifiers;
14949 Check_Arg_Count (1);
14950 Check_Arg_Is_Local_Name (Arg1);
14951 E_Id := Get_Pragma_Arg (Arg1);
14953 if Etype (E_Id) = Any_Type then
14957 E := Entity (E_Id);
14958 D := Declaration_Node (E);
14961 -- Check duplicate before we chain ourselves
14963 Check_Duplicate_Pragma (E);
14965 -- Check appropriate entity
14967 if Is_Type (E) then
14968 if Rep_Item_Too_Early (E, N)
14970 Rep_Item_Too_Late (E, N)
14974 Check_First_Subtype (Arg1);
14977 elsif K = N_Object_Declaration
14978 or else (K = N_Component_Declaration
14979 and then Original_Record_Component (E) = E)
14981 if Rep_Item_Too_Late (E, N) then
14987 ("inappropriate entity for pragma%", Arg1);
14990 Independence_Checks.Append ((N, E));
14993 ----------------------------
14994 -- Independent_Components --
14995 ----------------------------
14997 -- pragma Atomic_Components (array_LOCAL_NAME);
14999 -- This processing is shared by Volatile_Components
15001 when Pragma_Independent_Components => Independent_Components : declare
15008 Check_Ada_83_Warning;
15010 Check_No_Identifiers;
15011 Check_Arg_Count (1);
15012 Check_Arg_Is_Local_Name (Arg1);
15013 E_Id := Get_Pragma_Arg (Arg1);
15015 if Etype (E_Id) = Any_Type then
15019 E := Entity (E_Id);
15021 -- Check duplicate before we chain ourselves
15023 Check_Duplicate_Pragma (E);
15025 -- Check appropriate entity
15027 if Rep_Item_Too_Early (E, N)
15029 Rep_Item_Too_Late (E, N)
15034 D := Declaration_Node (E);
15037 if K = N_Full_Type_Declaration
15038 and then (Is_Array_Type (E) or else Is_Record_Type (E))
15040 Independence_Checks.Append ((N, E));
15041 Set_Has_Independent_Components (Base_Type (E));
15043 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
15044 and then Nkind (D) = N_Object_Declaration
15045 and then Nkind (Object_Definition (D)) =
15046 N_Constrained_Array_Definition
15048 Independence_Checks.Append ((N, E));
15049 Set_Has_Independent_Components (E);
15052 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
15054 end Independent_Components;
15056 -----------------------
15057 -- Initial_Condition --
15058 -----------------------
15060 -- pragma Initial_Condition (boolean_EXPRESSION);
15062 when Pragma_Initial_Condition => Initial_Condition : declare
15063 Context : constant Node_Id := Parent (Parent (N));
15064 Pack_Id : Entity_Id;
15069 Check_Arg_Count (1);
15071 -- Ensure the proper placement of the pragma. Initial_Condition
15072 -- must be associated with a package declaration.
15074 if not Nkind_In (Context, N_Generic_Package_Declaration,
15075 N_Package_Declaration)
15082 while Present (Stmt) loop
15084 -- Skip prior pragmas, but check for duplicates
15086 if Nkind (Stmt) = N_Pragma then
15087 if Pragma_Name (Stmt) = Pname then
15088 Error_Msg_Name_1 := Pname;
15089 Error_Msg_Sloc := Sloc (Stmt);
15090 Error_Msg_N ("pragma % duplicates pragma declared #", N);
15093 -- Skip internally generated code
15095 elsif not Comes_From_Source (Stmt) then
15098 -- The pragma does not apply to a legal construct, issue an
15099 -- error and stop the analysis.
15106 Stmt := Prev (Stmt);
15109 -- The pragma must be analyzed at the end of the visible
15110 -- declarations of the related package. Save the pragma for later
15111 -- (see Analyze_Initial_Condition_In_Decl_Part) by adding it to
15112 -- the contract of the package.
15114 Pack_Id := Defining_Entity (Context);
15115 Add_Contract_Item (N, Pack_Id);
15117 -- Verify the declaration order of pragma Initial_Condition with
15118 -- respect to pragmas Abstract_State and Initializes when SPARK
15119 -- checks are enabled.
15121 if SPARK_Mode /= Off then
15122 Check_Declaration_Order
15123 (First => Get_Pragma (Pack_Id, Pragma_Abstract_State),
15126 Check_Declaration_Order
15127 (First => Get_Pragma (Pack_Id, Pragma_Initializes),
15130 end Initial_Condition;
15132 ------------------------
15133 -- Initialize_Scalars --
15134 ------------------------
15136 -- pragma Initialize_Scalars;
15138 when Pragma_Initialize_Scalars =>
15140 Check_Arg_Count (0);
15141 Check_Valid_Configuration_Pragma;
15142 Check_Restriction (No_Initialize_Scalars, N);
15144 -- Initialize_Scalars creates false positives in CodePeer, and
15145 -- incorrect negative results in GNATprove mode, so ignore this
15146 -- pragma in these modes.
15148 if not Restriction_Active (No_Initialize_Scalars)
15149 and then not (CodePeer_Mode or GNATprove_Mode)
15151 Init_Or_Norm_Scalars := True;
15152 Initialize_Scalars := True;
15159 -- pragma Initializes (INITIALIZATION_SPEC);
15161 -- INITIALIZATION_SPEC ::= null | INITIALIZATION_LIST
15163 -- INITIALIZATION_LIST ::=
15164 -- INITIALIZATION_ITEM
15165 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
15167 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
15172 -- | (INPUT {, INPUT})
15176 when Pragma_Initializes => Initializes : declare
15177 Context : constant Node_Id := Parent (Parent (N));
15178 Pack_Id : Entity_Id;
15183 Check_Arg_Count (1);
15184 Ensure_Aggregate_Form (Arg1);
15186 -- Ensure the proper placement of the pragma. Initializes must be
15187 -- associated with a package declaration.
15189 if not Nkind_In (Context, N_Generic_Package_Declaration,
15190 N_Package_Declaration)
15197 while Present (Stmt) loop
15199 -- Skip prior pragmas, but check for duplicates
15201 if Nkind (Stmt) = N_Pragma then
15202 if Pragma_Name (Stmt) = Pname then
15203 Error_Msg_Name_1 := Pname;
15204 Error_Msg_Sloc := Sloc (Stmt);
15205 Error_Msg_N ("pragma % duplicates pragma declared #", N);
15208 -- Skip internally generated code
15210 elsif not Comes_From_Source (Stmt) then
15213 -- The pragma does not apply to a legal construct, issue an
15214 -- error and stop the analysis.
15221 Stmt := Prev (Stmt);
15224 -- The pragma must be analyzed at the end of the visible
15225 -- declarations of the related package. Save the pragma for later
15226 -- (see Analyze_Initializes_In_Decl_Part) by adding it to the
15227 -- contract of the package.
15229 Pack_Id := Defining_Entity (Context);
15230 Add_Contract_Item (N, Pack_Id);
15232 -- Verify the declaration order of pragmas Abstract_State and
15233 -- Initializes when SPARK checks are enabled.
15235 if SPARK_Mode /= Off then
15236 Check_Declaration_Order
15237 (First => Get_Pragma (Pack_Id, Pragma_Abstract_State),
15246 -- pragma Inline ( NAME {, NAME} );
15248 when Pragma_Inline =>
15250 -- Inline status is Enabled if inlining option is active
15252 if Inline_Active then
15253 Process_Inline (Enabled);
15255 Process_Inline (Disabled);
15258 -------------------
15259 -- Inline_Always --
15260 -------------------
15262 -- pragma Inline_Always ( NAME {, NAME} );
15264 when Pragma_Inline_Always =>
15267 -- Pragma always active unless in CodePeer or GNATprove mode,
15268 -- since this causes walk order issues.
15270 if not (CodePeer_Mode or GNATprove_Mode) then
15271 Process_Inline (Enabled);
15274 --------------------
15275 -- Inline_Generic --
15276 --------------------
15278 -- pragma Inline_Generic (NAME {, NAME});
15280 when Pragma_Inline_Generic =>
15282 Process_Generic_List;
15284 ----------------------
15285 -- Inspection_Point --
15286 ----------------------
15288 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
15290 when Pragma_Inspection_Point => Inspection_Point : declare
15295 if Arg_Count > 0 then
15298 Exp := Get_Pragma_Arg (Arg);
15301 if not Is_Entity_Name (Exp)
15302 or else not Is_Object (Entity (Exp))
15304 Error_Pragma_Arg ("object name required", Arg);
15308 exit when No (Arg);
15311 end Inspection_Point;
15317 -- pragma Interface (
15318 -- [ Convention =>] convention_IDENTIFIER,
15319 -- [ Entity =>] local_NAME
15320 -- [, [External_Name =>] static_string_EXPRESSION ]
15321 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15323 when Pragma_Interface =>
15328 Name_External_Name,
15330 Check_At_Least_N_Arguments (2);
15331 Check_At_Most_N_Arguments (4);
15332 Process_Import_Or_Interface;
15334 -- In Ada 2005, the permission to use Interface (a reserved word)
15335 -- as a pragma name is considered an obsolescent feature, and this
15336 -- pragma was already obsolescent in Ada 95.
15338 if Ada_Version >= Ada_95 then
15340 (No_Obsolescent_Features, Pragma_Identifier (N));
15342 if Warn_On_Obsolescent_Feature then
15344 ("pragma Interface is an obsolescent feature?j?", N);
15346 ("|use pragma Import instead?j?", N);
15350 --------------------
15351 -- Interface_Name --
15352 --------------------
15354 -- pragma Interface_Name (
15355 -- [ Entity =>] local_NAME
15356 -- [,[External_Name =>] static_string_EXPRESSION ]
15357 -- [,[Link_Name =>] static_string_EXPRESSION ]);
15359 when Pragma_Interface_Name => Interface_Name : declare
15361 Def_Id : Entity_Id;
15362 Hom_Id : Entity_Id;
15368 ((Name_Entity, Name_External_Name, Name_Link_Name));
15369 Check_At_Least_N_Arguments (2);
15370 Check_At_Most_N_Arguments (3);
15371 Id := Get_Pragma_Arg (Arg1);
15374 -- This is obsolete from Ada 95 on, but it is an implementation
15375 -- defined pragma, so we do not consider that it violates the
15376 -- restriction (No_Obsolescent_Features).
15378 if Ada_Version >= Ada_95 then
15379 if Warn_On_Obsolescent_Feature then
15381 ("pragma Interface_Name is an obsolescent feature?j?", N);
15383 ("|use pragma Import instead?j?", N);
15387 if not Is_Entity_Name (Id) then
15389 ("first argument for pragma% must be entity name", Arg1);
15390 elsif Etype (Id) = Any_Type then
15393 Def_Id := Entity (Id);
15396 -- Special DEC-compatible processing for the object case, forces
15397 -- object to be imported.
15399 if Ekind (Def_Id) = E_Variable then
15400 Kill_Size_Check_Code (Def_Id);
15401 Note_Possible_Modification (Id, Sure => False);
15403 -- Initialization is not allowed for imported variable
15405 if Present (Expression (Parent (Def_Id)))
15406 and then Comes_From_Source (Expression (Parent (Def_Id)))
15408 Error_Msg_Sloc := Sloc (Def_Id);
15410 ("no initialization allowed for declaration of& #",
15414 -- For compatibility, support VADS usage of providing both
15415 -- pragmas Interface and Interface_Name to obtain the effect
15416 -- of a single Import pragma.
15418 if Is_Imported (Def_Id)
15419 and then Present (First_Rep_Item (Def_Id))
15420 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
15422 Pragma_Name (First_Rep_Item (Def_Id)) = Name_Interface
15426 Set_Imported (Def_Id);
15429 Set_Is_Public (Def_Id);
15430 Process_Interface_Name (Def_Id, Arg2, Arg3);
15433 -- Otherwise must be subprogram
15435 elsif not Is_Subprogram (Def_Id) then
15437 ("argument of pragma% is not subprogram", Arg1);
15440 Check_At_Most_N_Arguments (3);
15444 -- Loop through homonyms
15447 Def_Id := Get_Base_Subprogram (Hom_Id);
15449 if Is_Imported (Def_Id) then
15450 Process_Interface_Name (Def_Id, Arg2, Arg3);
15454 exit when From_Aspect_Specification (N);
15455 Hom_Id := Homonym (Hom_Id);
15457 exit when No (Hom_Id)
15458 or else Scope (Hom_Id) /= Current_Scope;
15463 ("argument of pragma% is not imported subprogram",
15467 end Interface_Name;
15469 -----------------------
15470 -- Interrupt_Handler --
15471 -----------------------
15473 -- pragma Interrupt_Handler (handler_NAME);
15475 when Pragma_Interrupt_Handler =>
15476 Check_Ada_83_Warning;
15477 Check_Arg_Count (1);
15478 Check_No_Identifiers;
15480 if No_Run_Time_Mode then
15481 Error_Msg_CRT ("Interrupt_Handler pragma", N);
15483 Check_Interrupt_Or_Attach_Handler;
15484 Process_Interrupt_Or_Attach_Handler;
15487 ------------------------
15488 -- Interrupt_Priority --
15489 ------------------------
15491 -- pragma Interrupt_Priority [(EXPRESSION)];
15493 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
15494 P : constant Node_Id := Parent (N);
15499 Check_Ada_83_Warning;
15501 if Arg_Count /= 0 then
15502 Arg := Get_Pragma_Arg (Arg1);
15503 Check_Arg_Count (1);
15504 Check_No_Identifiers;
15506 -- The expression must be analyzed in the special manner
15507 -- described in "Handling of Default and Per-Object
15508 -- Expressions" in sem.ads.
15510 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
15513 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
15518 Ent := Defining_Identifier (Parent (P));
15520 -- Check duplicate pragma before we chain the pragma in the Rep
15521 -- Item chain of Ent.
15523 Check_Duplicate_Pragma (Ent);
15524 Record_Rep_Item (Ent, N);
15526 end Interrupt_Priority;
15528 ---------------------
15529 -- Interrupt_State --
15530 ---------------------
15532 -- pragma Interrupt_State (
15533 -- [Name =>] INTERRUPT_ID,
15534 -- [State =>] INTERRUPT_STATE);
15536 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
15537 -- INTERRUPT_STATE => System | Runtime | User
15539 -- Note: if the interrupt id is given as an identifier, then it must
15540 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
15541 -- given as a static integer expression which must be in the range of
15542 -- Ada.Interrupts.Interrupt_ID.
15544 when Pragma_Interrupt_State => Interrupt_State : declare
15545 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
15546 -- This is the entity Ada.Interrupts.Interrupt_ID;
15548 State_Type : Character;
15549 -- Set to 's'/'r'/'u' for System/Runtime/User
15552 -- Index to entry in Interrupt_States table
15555 -- Value of interrupt
15557 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
15558 -- The first argument to the pragma
15560 Int_Ent : Entity_Id;
15561 -- Interrupt entity in Ada.Interrupts.Names
15565 Check_Arg_Order ((Name_Name, Name_State));
15566 Check_Arg_Count (2);
15568 Check_Optional_Identifier (Arg1, Name_Name);
15569 Check_Optional_Identifier (Arg2, Name_State);
15570 Check_Arg_Is_Identifier (Arg2);
15572 -- First argument is identifier
15574 if Nkind (Arg1X) = N_Identifier then
15576 -- Search list of names in Ada.Interrupts.Names
15578 Int_Ent := First_Entity (RTE (RE_Names));
15580 if No (Int_Ent) then
15581 Error_Pragma_Arg ("invalid interrupt name", Arg1);
15583 elsif Chars (Int_Ent) = Chars (Arg1X) then
15584 Int_Val := Expr_Value (Constant_Value (Int_Ent));
15588 Next_Entity (Int_Ent);
15591 -- First argument is not an identifier, so it must be a static
15592 -- expression of type Ada.Interrupts.Interrupt_ID.
15595 Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
15596 Int_Val := Expr_Value (Arg1X);
15598 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
15600 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
15603 ("value not in range of type "
15604 & """Ada.Interrupts.Interrupt_'I'D""", Arg1);
15610 case Chars (Get_Pragma_Arg (Arg2)) is
15611 when Name_Runtime => State_Type := 'r';
15612 when Name_System => State_Type := 's';
15613 when Name_User => State_Type := 'u';
15616 Error_Pragma_Arg ("invalid interrupt state", Arg2);
15619 -- Check if entry is already stored
15621 IST_Num := Interrupt_States.First;
15623 -- If entry not found, add it
15625 if IST_Num > Interrupt_States.Last then
15626 Interrupt_States.Append
15627 ((Interrupt_Number => UI_To_Int (Int_Val),
15628 Interrupt_State => State_Type,
15629 Pragma_Loc => Loc));
15632 -- Case of entry for the same entry
15634 elsif Int_Val = Interrupt_States.Table (IST_Num).
15637 -- If state matches, done, no need to make redundant entry
15640 State_Type = Interrupt_States.Table (IST_Num).
15643 -- Otherwise if state does not match, error
15646 Interrupt_States.Table (IST_Num).Pragma_Loc;
15648 ("state conflicts with that given #", Arg2);
15652 IST_Num := IST_Num + 1;
15654 end Interrupt_State;
15660 -- pragma Invariant
15661 -- ([Entity =>] type_LOCAL_NAME,
15662 -- [Check =>] EXPRESSION
15663 -- [,[Message =>] String_Expression]);
15665 when Pragma_Invariant => Invariant : declare
15671 pragma Unreferenced (Discard);
15675 Check_At_Least_N_Arguments (2);
15676 Check_At_Most_N_Arguments (3);
15677 Check_Optional_Identifier (Arg1, Name_Entity);
15678 Check_Optional_Identifier (Arg2, Name_Check);
15680 if Arg_Count = 3 then
15681 Check_Optional_Identifier (Arg3, Name_Message);
15682 Check_Arg_Is_Static_Expression (Arg3, Standard_String);
15685 Check_Arg_Is_Local_Name (Arg1);
15687 Type_Id := Get_Pragma_Arg (Arg1);
15688 Find_Type (Type_Id);
15689 Typ := Entity (Type_Id);
15691 if Typ = Any_Type then
15694 -- An invariant must apply to a private type, or appear in the
15695 -- private part of a package spec and apply to a completion.
15696 -- a class-wide invariant can only appear on a private declaration
15697 -- or private extension, not a completion.
15699 elsif Ekind_In (Typ, E_Private_Type,
15700 E_Record_Type_With_Private,
15701 E_Limited_Private_Type)
15705 elsif In_Private_Part (Current_Scope)
15706 and then Has_Private_Declaration (Typ)
15707 and then not Class_Present (N)
15711 elsif In_Private_Part (Current_Scope) then
15713 ("pragma% only allowed for private type declared in "
15714 & "visible part", Arg1);
15718 ("pragma% only allowed for private type", Arg1);
15721 -- Note that the type has at least one invariant, and also that
15722 -- it has inheritable invariants if we have Invariant'Class
15723 -- or Type_Invariant'Class. Build the corresponding invariant
15724 -- procedure declaration, so that calls to it can be generated
15725 -- before the body is built (e.g. within an expression function).
15727 PDecl := Build_Invariant_Procedure_Declaration (Typ);
15729 Insert_After (N, PDecl);
15732 if Class_Present (N) then
15733 Set_Has_Inheritable_Invariants (Typ);
15736 -- The remaining processing is simply to link the pragma on to
15737 -- the rep item chain, for processing when the type is frozen.
15738 -- This is accomplished by a call to Rep_Item_Too_Late.
15740 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
15743 ----------------------
15744 -- Java_Constructor --
15745 ----------------------
15747 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
15749 -- Also handles pragma CIL_Constructor
15751 when Pragma_CIL_Constructor | Pragma_Java_Constructor =>
15752 Java_Constructor : declare
15753 Convention : Convention_Id;
15754 Def_Id : Entity_Id;
15755 Hom_Id : Entity_Id;
15757 This_Formal : Entity_Id;
15761 Check_Arg_Count (1);
15762 Check_Optional_Identifier (Arg1, Name_Entity);
15763 Check_Arg_Is_Local_Name (Arg1);
15765 Id := Get_Pragma_Arg (Arg1);
15766 Find_Program_Unit_Name (Id);
15768 -- If we did not find the name, we are done
15770 if Etype (Id) = Any_Type then
15774 -- Check wrong use of pragma in wrong VM target
15776 if VM_Target = No_VM then
15779 elsif VM_Target = CLI_Target
15780 and then Prag_Id = Pragma_Java_Constructor
15782 Error_Pragma ("must use pragma 'C'I'L_'Constructor");
15784 elsif VM_Target = JVM_Target
15785 and then Prag_Id = Pragma_CIL_Constructor
15787 Error_Pragma ("must use pragma 'Java_'Constructor");
15791 when Pragma_CIL_Constructor => Convention := Convention_CIL;
15792 when Pragma_Java_Constructor => Convention := Convention_Java;
15793 when others => null;
15796 Hom_Id := Entity (Id);
15798 -- Loop through homonyms
15801 Def_Id := Get_Base_Subprogram (Hom_Id);
15803 -- The constructor is required to be a function
15805 if Ekind (Def_Id) /= E_Function then
15806 if VM_Target = JVM_Target then
15808 ("pragma% requires function returning a 'Java access "
15812 ("pragma% requires function returning a 'C'I'L access "
15817 -- Check arguments: For tagged type the first formal must be
15818 -- named "this" and its type must be a named access type
15819 -- designating a class-wide tagged type that has convention
15820 -- CIL/Java. The first formal must also have a null default
15821 -- value. For example:
15823 -- type Typ is tagged ...
15824 -- type Ref is access all Typ;
15825 -- pragma Convention (CIL, Typ);
15827 -- function New_Typ (This : Ref) return Ref;
15828 -- function New_Typ (This : Ref; I : Integer) return Ref;
15829 -- pragma Cil_Constructor (New_Typ);
15831 -- Reason: The first formal must NOT be a primitive of the
15834 -- This rule also applies to constructors of delegates used
15835 -- to interface with standard target libraries. For example:
15837 -- type Delegate is access procedure ...
15838 -- pragma Import (CIL, Delegate, ...);
15840 -- function new_Delegate
15841 -- (This : Delegate := null; ... ) return Delegate;
15843 -- For value-types this rule does not apply.
15845 if not Is_Value_Type (Etype (Def_Id)) then
15846 if No (First_Formal (Def_Id)) then
15847 Error_Msg_Name_1 := Pname;
15848 Error_Msg_N ("% function must have parameters", Def_Id);
15852 -- In the JRE library we have several occurrences in which
15853 -- the "this" parameter is not the first formal.
15855 This_Formal := First_Formal (Def_Id);
15857 -- In the JRE library we have several occurrences in which
15858 -- the "this" parameter is not the first formal. Search for
15861 if VM_Target = JVM_Target then
15862 while Present (This_Formal)
15863 and then Get_Name_String (Chars (This_Formal)) /= "this"
15865 Next_Formal (This_Formal);
15868 if No (This_Formal) then
15869 This_Formal := First_Formal (Def_Id);
15873 -- Warning: The first parameter should be named "this".
15874 -- We temporarily allow it because we have the following
15875 -- case in the Java runtime (file s-osinte.ads) ???
15877 -- function new_Thread
15878 -- (Self_Id : System.Address) return Thread_Id;
15879 -- pragma Java_Constructor (new_Thread);
15881 if VM_Target = JVM_Target
15882 and then Get_Name_String (Chars (First_Formal (Def_Id)))
15884 and then Etype (First_Formal (Def_Id)) = RTE (RE_Address)
15888 elsif Get_Name_String (Chars (This_Formal)) /= "this" then
15889 Error_Msg_Name_1 := Pname;
15891 ("first formal of % function must be named `this`",
15892 Parent (This_Formal));
15894 elsif not Is_Access_Type (Etype (This_Formal)) then
15895 Error_Msg_Name_1 := Pname;
15897 ("first formal of % function must be an access type",
15898 Parameter_Type (Parent (This_Formal)));
15900 -- For delegates the type of the first formal must be a
15901 -- named access-to-subprogram type (see previous example)
15903 elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type
15904 and then Ekind (Etype (This_Formal))
15905 /= E_Access_Subprogram_Type
15907 Error_Msg_Name_1 := Pname;
15909 ("first formal of % function must be a named access "
15910 & "to subprogram type",
15911 Parameter_Type (Parent (This_Formal)));
15913 -- Warning: We should reject anonymous access types because
15914 -- the constructor must not be handled as a primitive of the
15915 -- tagged type. We temporarily allow it because this profile
15916 -- is currently generated by cil2ada???
15918 elsif Ekind (Etype (Def_Id)) /= E_Access_Subprogram_Type
15919 and then not Ekind_In (Etype (This_Formal),
15921 E_General_Access_Type,
15922 E_Anonymous_Access_Type)
15924 Error_Msg_Name_1 := Pname;
15926 ("first formal of % function must be a named access "
15927 & "type", Parameter_Type (Parent (This_Formal)));
15929 elsif Atree.Convention
15930 (Designated_Type (Etype (This_Formal))) /= Convention
15932 Error_Msg_Name_1 := Pname;
15934 if Convention = Convention_Java then
15936 ("pragma% requires convention 'Cil in designated "
15937 & "type", Parameter_Type (Parent (This_Formal)));
15940 ("pragma% requires convention 'Java in designated "
15941 & "type", Parameter_Type (Parent (This_Formal)));
15944 elsif No (Expression (Parent (This_Formal)))
15945 or else Nkind (Expression (Parent (This_Formal))) /= N_Null
15947 Error_Msg_Name_1 := Pname;
15949 ("pragma% requires first formal with default `null`",
15950 Parameter_Type (Parent (This_Formal)));
15954 -- Check result type: the constructor must be a function
15956 -- * a value type (only allowed in the CIL compiler)
15957 -- * an access-to-subprogram type with convention Java/CIL
15958 -- * an access-type designating a type that has convention
15961 if Is_Value_Type (Etype (Def_Id)) then
15964 -- Access-to-subprogram type with convention Java/CIL
15966 elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type then
15967 if Atree.Convention (Etype (Def_Id)) /= Convention then
15968 if Convention = Convention_Java then
15970 ("pragma% requires function returning a 'Java "
15971 & "access type", Arg1);
15973 pragma Assert (Convention = Convention_CIL);
15975 ("pragma% requires function returning a 'C'I'L "
15976 & "access type", Arg1);
15980 elsif Ekind (Etype (Def_Id)) in Access_Kind then
15981 if not Ekind_In (Etype (Def_Id), E_Access_Type,
15982 E_General_Access_Type)
15985 (Designated_Type (Etype (Def_Id))) /= Convention
15987 Error_Msg_Name_1 := Pname;
15989 if Convention = Convention_Java then
15991 ("pragma% requires function returning a named "
15992 & "'Java access type", Arg1);
15995 ("pragma% requires function returning a named "
15996 & "'C'I'L access type", Arg1);
16001 Set_Is_Constructor (Def_Id);
16002 Set_Convention (Def_Id, Convention);
16003 Set_Is_Imported (Def_Id);
16005 exit when From_Aspect_Specification (N);
16006 Hom_Id := Homonym (Hom_Id);
16008 exit when No (Hom_Id) or else Scope (Hom_Id) /= Current_Scope;
16010 end Java_Constructor;
16012 ----------------------
16013 -- Java_Interface --
16014 ----------------------
16016 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
16018 when Pragma_Java_Interface => Java_Interface : declare
16024 Check_Arg_Count (1);
16025 Check_Optional_Identifier (Arg1, Name_Entity);
16026 Check_Arg_Is_Local_Name (Arg1);
16028 Arg := Get_Pragma_Arg (Arg1);
16031 if Etype (Arg) = Any_Type then
16035 if not Is_Entity_Name (Arg)
16036 or else not Is_Type (Entity (Arg))
16038 Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
16041 Typ := Underlying_Type (Entity (Arg));
16043 -- For now simply check some of the semantic constraints on the
16044 -- type. This currently leaves out some restrictions on interface
16045 -- types, namely that the parent type must be java.lang.Object.Typ
16046 -- and that all primitives of the type should be declared
16049 if not Is_Tagged_Type (Typ) or else not Is_Abstract_Type (Typ) then
16051 ("pragma% requires an abstract tagged type", Arg1);
16053 elsif not Has_Discriminants (Typ)
16054 or else Ekind (Etype (First_Discriminant (Typ)))
16055 /= E_Anonymous_Access_Type
16057 not Is_Class_Wide_Type
16058 (Designated_Type (Etype (First_Discriminant (Typ))))
16061 ("type must have a class-wide access discriminant", Arg1);
16063 end Java_Interface;
16069 -- pragma Keep_Names ([On => ] local_NAME);
16071 when Pragma_Keep_Names => Keep_Names : declare
16076 Check_Arg_Count (1);
16077 Check_Optional_Identifier (Arg1, Name_On);
16078 Check_Arg_Is_Local_Name (Arg1);
16080 Arg := Get_Pragma_Arg (Arg1);
16083 if Etype (Arg) = Any_Type then
16087 if not Is_Entity_Name (Arg)
16088 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
16091 ("pragma% requires a local enumeration type", Arg1);
16094 Set_Discard_Names (Entity (Arg), False);
16101 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
16103 when Pragma_License =>
16105 Check_Arg_Count (1);
16106 Check_No_Identifiers;
16107 Check_Valid_Configuration_Pragma;
16108 Check_Arg_Is_Identifier (Arg1);
16111 Sind : constant Source_File_Index :=
16112 Source_Index (Current_Sem_Unit);
16115 case Chars (Get_Pragma_Arg (Arg1)) is
16117 Set_License (Sind, GPL);
16119 when Name_Modified_GPL =>
16120 Set_License (Sind, Modified_GPL);
16122 when Name_Restricted =>
16123 Set_License (Sind, Restricted);
16125 when Name_Unrestricted =>
16126 Set_License (Sind, Unrestricted);
16129 Error_Pragma_Arg ("invalid license name", Arg1);
16137 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
16139 when Pragma_Link_With => Link_With : declare
16145 if Operating_Mode = Generate_Code
16146 and then In_Extended_Main_Source_Unit (N)
16148 Check_At_Least_N_Arguments (1);
16149 Check_No_Identifiers;
16150 Check_Is_In_Decl_Part_Or_Package_Spec;
16151 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
16155 while Present (Arg) loop
16156 Check_Arg_Is_Static_Expression (Arg, Standard_String);
16158 -- Store argument, converting sequences of spaces to a
16159 -- single null character (this is one of the differences
16160 -- in processing between Link_With and Linker_Options).
16162 Arg_Store : declare
16163 C : constant Char_Code := Get_Char_Code (' ');
16164 S : constant String_Id :=
16165 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
16166 L : constant Nat := String_Length (S);
16169 procedure Skip_Spaces;
16170 -- Advance F past any spaces
16176 procedure Skip_Spaces is
16178 while F <= L and then Get_String_Char (S, F) = C loop
16183 -- Start of processing for Arg_Store
16186 Skip_Spaces; -- skip leading spaces
16188 -- Loop through characters, changing any embedded
16189 -- sequence of spaces to a single null character (this
16190 -- is how Link_With/Linker_Options differ)
16193 if Get_String_Char (S, F) = C then
16196 Store_String_Char (ASCII.NUL);
16199 Store_String_Char (Get_String_Char (S, F));
16207 if Present (Arg) then
16208 Store_String_Char (ASCII.NUL);
16212 Store_Linker_Option_String (End_String);
16220 -- pragma Linker_Alias (
16221 -- [Entity =>] LOCAL_NAME
16222 -- [Target =>] static_string_EXPRESSION);
16224 when Pragma_Linker_Alias =>
16226 Check_Arg_Order ((Name_Entity, Name_Target));
16227 Check_Arg_Count (2);
16228 Check_Optional_Identifier (Arg1, Name_Entity);
16229 Check_Optional_Identifier (Arg2, Name_Target);
16230 Check_Arg_Is_Library_Level_Local_Name (Arg1);
16231 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
16233 -- The only processing required is to link this item on to the
16234 -- list of rep items for the given entity. This is accomplished
16235 -- by the call to Rep_Item_Too_Late (when no error is detected
16236 -- and False is returned).
16238 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
16241 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
16244 ------------------------
16245 -- Linker_Constructor --
16246 ------------------------
16248 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
16250 -- Code is shared with Linker_Destructor
16252 -----------------------
16253 -- Linker_Destructor --
16254 -----------------------
16256 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
16258 when Pragma_Linker_Constructor |
16259 Pragma_Linker_Destructor =>
16260 Linker_Constructor : declare
16266 Check_Arg_Count (1);
16267 Check_No_Identifiers;
16268 Check_Arg_Is_Local_Name (Arg1);
16269 Arg1_X := Get_Pragma_Arg (Arg1);
16271 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
16273 if not Is_Library_Level_Entity (Proc) then
16275 ("argument for pragma% must be library level entity", Arg1);
16278 -- The only processing required is to link this item on to the
16279 -- list of rep items for the given entity. This is accomplished
16280 -- by the call to Rep_Item_Too_Late (when no error is detected
16281 -- and False is returned).
16283 if Rep_Item_Too_Late (Proc, N) then
16286 Set_Has_Gigi_Rep_Item (Proc);
16288 end Linker_Constructor;
16290 --------------------
16291 -- Linker_Options --
16292 --------------------
16294 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
16296 when Pragma_Linker_Options => Linker_Options : declare
16300 Check_Ada_83_Warning;
16301 Check_No_Identifiers;
16302 Check_Arg_Count (1);
16303 Check_Is_In_Decl_Part_Or_Package_Spec;
16304 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
16305 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
16308 while Present (Arg) loop
16309 Check_Arg_Is_Static_Expression (Arg, Standard_String);
16310 Store_String_Char (ASCII.NUL);
16312 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
16316 if Operating_Mode = Generate_Code
16317 and then In_Extended_Main_Source_Unit (N)
16319 Store_Linker_Option_String (End_String);
16321 end Linker_Options;
16323 --------------------
16324 -- Linker_Section --
16325 --------------------
16327 -- pragma Linker_Section (
16328 -- [Entity =>] LOCAL_NAME
16329 -- [Section =>] static_string_EXPRESSION);
16331 when Pragma_Linker_Section => Linker_Section : declare
16337 Check_Arg_Order ((Name_Entity, Name_Section));
16338 Check_Arg_Count (2);
16339 Check_Optional_Identifier (Arg1, Name_Entity);
16340 Check_Optional_Identifier (Arg2, Name_Section);
16341 Check_Arg_Is_Library_Level_Local_Name (Arg1);
16342 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
16344 -- Check kind of entity
16346 Arg := Get_Pragma_Arg (Arg1);
16347 Ent := Entity (Arg);
16349 case Ekind (Ent) is
16351 -- Objects (constants and variables) and types. For these cases
16352 -- all we need to do is to set the Linker_Section_pragma field.
16354 when E_Constant | E_Variable | Type_Kind =>
16355 Set_Linker_Section_Pragma (Ent, N);
16359 when Subprogram_Kind =>
16361 -- Aspect case, entity already set
16363 if From_Aspect_Specification (N) then
16364 Set_Linker_Section_Pragma
16365 (Entity (Corresponding_Aspect (N)), N);
16367 -- Pragma case, we must climb the homonym chain, but skip
16368 -- any for which the linker section is already set.
16372 if No (Linker_Section_Pragma (Ent)) then
16373 Set_Linker_Section_Pragma (Ent, N);
16376 Ent := Homonym (Ent);
16378 or else Scope (Ent) /= Current_Scope;
16382 -- All other cases are illegal
16386 ("pragma% applies only to objects, subprograms, and types",
16389 end Linker_Section;
16395 -- pragma List (On | Off)
16397 -- There is nothing to do here, since we did all the processing for
16398 -- this pragma in Par.Prag (so that it works properly even in syntax
16401 when Pragma_List =>
16408 -- pragma Lock_Free [(Boolean_EXPRESSION)];
16410 when Pragma_Lock_Free => Lock_Free : declare
16411 P : constant Node_Id := Parent (N);
16417 Check_No_Identifiers;
16418 Check_At_Most_N_Arguments (1);
16420 -- Protected definition case
16422 if Nkind (P) = N_Protected_Definition then
16423 Ent := Defining_Identifier (Parent (P));
16427 if Arg_Count = 1 then
16428 Arg := Get_Pragma_Arg (Arg1);
16429 Val := Is_True (Static_Boolean (Arg));
16431 -- No arguments (expression is considered to be True)
16437 -- Check duplicate pragma before we chain the pragma in the Rep
16438 -- Item chain of Ent.
16440 Check_Duplicate_Pragma (Ent);
16441 Record_Rep_Item (Ent, N);
16442 Set_Uses_Lock_Free (Ent, Val);
16444 -- Anything else is incorrect placement
16451 --------------------
16452 -- Locking_Policy --
16453 --------------------
16455 -- pragma Locking_Policy (policy_IDENTIFIER);
16457 when Pragma_Locking_Policy => declare
16458 subtype LP_Range is Name_Id
16459 range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
16464 Check_Ada_83_Warning;
16465 Check_Arg_Count (1);
16466 Check_No_Identifiers;
16467 Check_Arg_Is_Locking_Policy (Arg1);
16468 Check_Valid_Configuration_Pragma;
16469 LP_Val := Chars (Get_Pragma_Arg (Arg1));
16472 when Name_Ceiling_Locking =>
16474 when Name_Inheritance_Locking =>
16476 when Name_Concurrent_Readers_Locking =>
16480 if Locking_Policy /= ' '
16481 and then Locking_Policy /= LP
16483 Error_Msg_Sloc := Locking_Policy_Sloc;
16484 Error_Pragma ("locking policy incompatible with policy#");
16486 -- Set new policy, but always preserve System_Location since we
16487 -- like the error message with the run time name.
16490 Locking_Policy := LP;
16492 if Locking_Policy_Sloc /= System_Location then
16493 Locking_Policy_Sloc := Loc;
16502 -- pragma Long_Float (D_Float | G_Float);
16504 when Pragma_Long_Float => Long_Float : declare
16507 Check_Valid_Configuration_Pragma;
16508 Check_Arg_Count (1);
16509 Check_No_Identifier (Arg1);
16510 Check_Arg_Is_One_Of (Arg1, Name_D_Float, Name_G_Float);
16512 if not OpenVMS_On_Target then
16513 Error_Pragma ("??pragma% ignored (applies only to Open'V'M'S)");
16518 if Chars (Get_Pragma_Arg (Arg1)) = Name_D_Float then
16519 if Opt.Float_Format_Long = 'G' then
16521 ("G_Float previously specified", Arg1);
16523 elsif Current_Sem_Unit /= Main_Unit
16524 and then Opt.Float_Format_Long /= 'D'
16527 ("main unit not compiled with pragma Long_Float (D_Float)",
16528 "\pragma% must be used consistently for whole partition",
16532 Opt.Float_Format_Long := 'D';
16535 -- G_Float case (this is the default, does not need overriding)
16538 if Opt.Float_Format_Long = 'D' then
16539 Error_Pragma ("D_Float previously specified");
16541 elsif Current_Sem_Unit /= Main_Unit
16542 and then Opt.Float_Format_Long /= 'G'
16545 ("main unit not compiled with pragma Long_Float (G_Float)",
16546 "\pragma% must be used consistently for whole partition",
16550 Opt.Float_Format_Long := 'G';
16554 Set_Standard_Fpt_Formats;
16557 -------------------
16558 -- Loop_Optimize --
16559 -------------------
16561 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
16563 -- OPTIMIZATION_HINT ::= No_Unroll | Unroll | No_Vector | Vector
16565 when Pragma_Loop_Optimize => Loop_Optimize : declare
16570 Check_At_Least_N_Arguments (1);
16571 Check_No_Identifiers;
16573 Hint := First (Pragma_Argument_Associations (N));
16574 while Present (Hint) loop
16575 Check_Arg_Is_One_Of (Hint,
16576 Name_No_Unroll, Name_Unroll, Name_No_Vector, Name_Vector);
16580 Check_Loop_Pragma_Placement;
16587 -- pragma Loop_Variant
16588 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
16590 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
16592 -- CHANGE_DIRECTION ::= Increases | Decreases
16594 when Pragma_Loop_Variant => Loop_Variant : declare
16599 Check_At_Least_N_Arguments (1);
16600 Check_Loop_Pragma_Placement;
16602 -- Process all increasing / decreasing expressions
16604 Variant := First (Pragma_Argument_Associations (N));
16605 while Present (Variant) loop
16606 if not Nam_In (Chars (Variant), Name_Decreases,
16609 Error_Pragma_Arg ("wrong change modifier", Variant);
16612 Preanalyze_Assert_Expression
16613 (Expression (Variant), Any_Discrete);
16619 -----------------------
16620 -- Machine_Attribute --
16621 -----------------------
16623 -- pragma Machine_Attribute (
16624 -- [Entity =>] LOCAL_NAME,
16625 -- [Attribute_Name =>] static_string_EXPRESSION
16626 -- [, [Info =>] static_EXPRESSION] );
16628 when Pragma_Machine_Attribute => Machine_Attribute : declare
16629 Def_Id : Entity_Id;
16633 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
16635 if Arg_Count = 3 then
16636 Check_Optional_Identifier (Arg3, Name_Info);
16637 Check_Arg_Is_Static_Expression (Arg3);
16639 Check_Arg_Count (2);
16642 Check_Optional_Identifier (Arg1, Name_Entity);
16643 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
16644 Check_Arg_Is_Local_Name (Arg1);
16645 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
16646 Def_Id := Entity (Get_Pragma_Arg (Arg1));
16648 if Is_Access_Type (Def_Id) then
16649 Def_Id := Designated_Type (Def_Id);
16652 if Rep_Item_Too_Early (Def_Id, N) then
16656 Def_Id := Underlying_Type (Def_Id);
16658 -- The only processing required is to link this item on to the
16659 -- list of rep items for the given entity. This is accomplished
16660 -- by the call to Rep_Item_Too_Late (when no error is detected
16661 -- and False is returned).
16663 if Rep_Item_Too_Late (Def_Id, N) then
16666 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
16668 end Machine_Attribute;
16675 -- (MAIN_OPTION [, MAIN_OPTION]);
16678 -- [STACK_SIZE =>] static_integer_EXPRESSION
16679 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
16680 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
16682 when Pragma_Main => Main : declare
16683 Args : Args_List (1 .. 3);
16684 Names : constant Name_List (1 .. 3) := (
16686 Name_Task_Stack_Size_Default,
16687 Name_Time_Slicing_Enabled);
16693 Gather_Associations (Names, Args);
16695 for J in 1 .. 2 loop
16696 if Present (Args (J)) then
16697 Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
16701 if Present (Args (3)) then
16702 Check_Arg_Is_Static_Expression (Args (3), Standard_Boolean);
16706 while Present (Nod) loop
16707 if Nkind (Nod) = N_Pragma
16708 and then Pragma_Name (Nod) = Name_Main
16710 Error_Msg_Name_1 := Pname;
16711 Error_Msg_N ("duplicate pragma% not permitted", Nod);
16722 -- pragma Main_Storage
16723 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
16725 -- MAIN_STORAGE_OPTION ::=
16726 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
16727 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
16729 when Pragma_Main_Storage => Main_Storage : declare
16730 Args : Args_List (1 .. 2);
16731 Names : constant Name_List (1 .. 2) := (
16732 Name_Working_Storage,
16739 Gather_Associations (Names, Args);
16741 for J in 1 .. 2 loop
16742 if Present (Args (J)) then
16743 Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
16747 Check_In_Main_Program;
16750 while Present (Nod) loop
16751 if Nkind (Nod) = N_Pragma
16752 and then Pragma_Name (Nod) = Name_Main_Storage
16754 Error_Msg_Name_1 := Pname;
16755 Error_Msg_N ("duplicate pragma% not permitted", Nod);
16766 -- pragma Memory_Size (NUMERIC_LITERAL)
16768 when Pragma_Memory_Size =>
16771 -- Memory size is simply ignored
16773 Check_No_Identifiers;
16774 Check_Arg_Count (1);
16775 Check_Arg_Is_Integer_Literal (Arg1);
16783 -- The only correct use of this pragma is on its own in a file, in
16784 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
16785 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
16786 -- check for a file containing nothing but a No_Body pragma). If we
16787 -- attempt to process it during normal semantics processing, it means
16788 -- it was misplaced.
16790 when Pragma_No_Body =>
16798 -- pragma No_Inline ( NAME {, NAME} );
16800 when Pragma_No_Inline =>
16802 Process_Inline (Suppressed);
16808 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
16810 when Pragma_No_Return => No_Return : declare
16818 Check_At_Least_N_Arguments (1);
16820 -- Loop through arguments of pragma
16823 while Present (Arg) loop
16824 Check_Arg_Is_Local_Name (Arg);
16825 Id := Get_Pragma_Arg (Arg);
16828 if not Is_Entity_Name (Id) then
16829 Error_Pragma_Arg ("entity name required", Arg);
16832 if Etype (Id) = Any_Type then
16836 -- Loop to find matching procedures
16841 and then Scope (E) = Current_Scope
16843 if Ekind_In (E, E_Procedure, E_Generic_Procedure) then
16846 -- Set flag on any alias as well
16848 if Is_Overloadable (E) and then Present (Alias (E)) then
16849 Set_No_Return (Alias (E));
16855 exit when From_Aspect_Specification (N);
16859 -- If entity in not in current scope it may be the enclosing
16860 -- suprogram body to which the aspect applies.
16863 if Entity (Id) = Current_Scope
16864 and then From_Aspect_Specification (N)
16866 Set_No_Return (Entity (Id));
16868 Error_Pragma_Arg ("no procedure& found for pragma%", Arg);
16880 -- pragma No_Run_Time;
16882 -- Note: this pragma is retained for backwards compatibility. See
16883 -- body of Rtsfind for full details on its handling.
16885 when Pragma_No_Run_Time =>
16887 Check_Valid_Configuration_Pragma;
16888 Check_Arg_Count (0);
16890 No_Run_Time_Mode := True;
16891 Configurable_Run_Time_Mode := True;
16893 -- Set Duration to 32 bits if word size is 32
16895 if Ttypes.System_Word_Size = 32 then
16896 Duration_32_Bits_On_Target := True;
16899 -- Set appropriate restrictions
16901 Set_Restriction (No_Finalization, N);
16902 Set_Restriction (No_Exception_Handlers, N);
16903 Set_Restriction (Max_Tasks, N, 0);
16904 Set_Restriction (No_Tasking, N);
16906 ------------------------
16907 -- No_Strict_Aliasing --
16908 ------------------------
16910 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
16912 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
16917 Check_At_Most_N_Arguments (1);
16919 if Arg_Count = 0 then
16920 Check_Valid_Configuration_Pragma;
16921 Opt.No_Strict_Aliasing := True;
16924 Check_Optional_Identifier (Arg2, Name_Entity);
16925 Check_Arg_Is_Local_Name (Arg1);
16926 E_Id := Entity (Get_Pragma_Arg (Arg1));
16928 if E_Id = Any_Type then
16930 elsif No (E_Id) or else not Is_Access_Type (E_Id) then
16931 Error_Pragma_Arg ("pragma% requires access type", Arg1);
16934 Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id));
16936 end No_Strict_Aliasing;
16938 -----------------------
16939 -- Normalize_Scalars --
16940 -----------------------
16942 -- pragma Normalize_Scalars;
16944 when Pragma_Normalize_Scalars =>
16945 Check_Ada_83_Warning;
16946 Check_Arg_Count (0);
16947 Check_Valid_Configuration_Pragma;
16949 -- Normalize_Scalars creates false positives in CodePeer, and
16950 -- incorrect negative results in GNATprove mode, so ignore this
16951 -- pragma in these modes.
16953 if not (CodePeer_Mode or GNATprove_Mode) then
16954 Normalize_Scalars := True;
16955 Init_Or_Norm_Scalars := True;
16962 -- pragma Obsolescent;
16964 -- pragma Obsolescent (
16965 -- [Message =>] static_string_EXPRESSION
16966 -- [,[Version =>] Ada_05]]);
16968 -- pragma Obsolescent (
16969 -- [Entity =>] NAME
16970 -- [,[Message =>] static_string_EXPRESSION
16971 -- [,[Version =>] Ada_05]] );
16973 when Pragma_Obsolescent => Obsolescent : declare
16977 procedure Set_Obsolescent (E : Entity_Id);
16978 -- Given an entity Ent, mark it as obsolescent if appropriate
16980 ---------------------
16981 -- Set_Obsolescent --
16982 ---------------------
16984 procedure Set_Obsolescent (E : Entity_Id) is
16993 -- Entity name was given
16995 if Present (Ename) then
16997 -- If entity name matches, we are fine. Save entity in
16998 -- pragma argument, for ASIS use.
17000 if Chars (Ename) = Chars (Ent) then
17001 Set_Entity (Ename, Ent);
17002 Generate_Reference (Ent, Ename);
17004 -- If entity name does not match, only possibility is an
17005 -- enumeration literal from an enumeration type declaration.
17007 elsif Ekind (Ent) /= E_Enumeration_Type then
17009 ("pragma % entity name does not match declaration");
17012 Ent := First_Literal (E);
17016 ("pragma % entity name does not match any "
17017 & "enumeration literal");
17019 elsif Chars (Ent) = Chars (Ename) then
17020 Set_Entity (Ename, Ent);
17021 Generate_Reference (Ent, Ename);
17025 Ent := Next_Literal (Ent);
17031 -- Ent points to entity to be marked
17033 if Arg_Count >= 1 then
17035 -- Deal with static string argument
17037 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
17038 S := Strval (Get_Pragma_Arg (Arg1));
17040 for J in 1 .. String_Length (S) loop
17041 if not In_Character_Range (Get_String_Char (S, J)) then
17043 ("pragma% argument does not allow wide characters",
17048 Obsolescent_Warnings.Append
17049 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
17051 -- Check for Ada_05 parameter
17053 if Arg_Count /= 1 then
17054 Check_Arg_Count (2);
17057 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
17060 Check_Arg_Is_Identifier (Argx);
17062 if Chars (Argx) /= Name_Ada_05 then
17063 Error_Msg_Name_2 := Name_Ada_05;
17065 ("only allowed argument for pragma% is %", Argx);
17068 if Ada_Version_Explicit < Ada_2005
17069 or else not Warn_On_Ada_2005_Compatibility
17077 -- Set flag if pragma active
17080 Set_Is_Obsolescent (Ent);
17084 end Set_Obsolescent;
17086 -- Start of processing for pragma Obsolescent
17091 Check_At_Most_N_Arguments (3);
17093 -- See if first argument specifies an entity name
17097 (Chars (Arg1) = Name_Entity
17099 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
17101 N_Operator_Symbol))
17103 Ename := Get_Pragma_Arg (Arg1);
17105 -- Eliminate first argument, so we can share processing
17109 Arg_Count := Arg_Count - 1;
17111 -- No Entity name argument given
17117 if Arg_Count >= 1 then
17118 Check_Optional_Identifier (Arg1, Name_Message);
17120 if Arg_Count = 2 then
17121 Check_Optional_Identifier (Arg2, Name_Version);
17125 -- Get immediately preceding declaration
17128 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
17132 -- Cases where we do not follow anything other than another pragma
17136 -- First case: library level compilation unit declaration with
17137 -- the pragma immediately following the declaration.
17139 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
17141 (Defining_Entity (Unit (Parent (Parent (N)))));
17144 -- Case 2: library unit placement for package
17148 Ent : constant Entity_Id := Find_Lib_Unit_Name;
17150 if Is_Package_Or_Generic_Package (Ent) then
17151 Set_Obsolescent (Ent);
17157 -- Cases where we must follow a declaration
17160 if Nkind (Decl) not in N_Declaration
17161 and then Nkind (Decl) not in N_Later_Decl_Item
17162 and then Nkind (Decl) not in N_Generic_Declaration
17163 and then Nkind (Decl) not in N_Renaming_Declaration
17166 ("pragma% misplaced, "
17167 & "must immediately follow a declaration");
17170 Set_Obsolescent (Defining_Entity (Decl));
17180 -- pragma Optimize (Time | Space | Off);
17182 -- The actual check for optimize is done in Gigi. Note that this
17183 -- pragma does not actually change the optimization setting, it
17184 -- simply checks that it is consistent with the pragma.
17186 when Pragma_Optimize =>
17187 Check_No_Identifiers;
17188 Check_Arg_Count (1);
17189 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
17191 ------------------------
17192 -- Optimize_Alignment --
17193 ------------------------
17195 -- pragma Optimize_Alignment (Time | Space | Off);
17197 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
17199 Check_No_Identifiers;
17200 Check_Arg_Count (1);
17201 Check_Valid_Configuration_Pragma;
17204 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
17208 Opt.Optimize_Alignment := 'T';
17210 Opt.Optimize_Alignment := 'S';
17212 Opt.Optimize_Alignment := 'O';
17214 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
17218 -- Set indication that mode is set locally. If we are in fact in a
17219 -- configuration pragma file, this setting is harmless since the
17220 -- switch will get reset anyway at the start of each unit.
17222 Optimize_Alignment_Local := True;
17223 end Optimize_Alignment;
17229 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
17231 when Pragma_Ordered => Ordered : declare
17232 Assoc : constant Node_Id := Arg1;
17238 Check_No_Identifiers;
17239 Check_Arg_Count (1);
17240 Check_Arg_Is_Local_Name (Arg1);
17242 Type_Id := Get_Pragma_Arg (Assoc);
17243 Find_Type (Type_Id);
17244 Typ := Entity (Type_Id);
17246 if Typ = Any_Type then
17249 Typ := Underlying_Type (Typ);
17252 if not Is_Enumeration_Type (Typ) then
17253 Error_Pragma ("pragma% must specify enumeration type");
17256 Check_First_Subtype (Arg1);
17257 Set_Has_Pragma_Ordered (Base_Type (Typ));
17260 -------------------
17261 -- Overflow_Mode --
17262 -------------------
17264 -- pragma Overflow_Mode
17265 -- ([General => ] MODE [, [Assertions => ] MODE]);
17267 -- MODE := STRICT | MINIMIZED | ELIMINATED
17269 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
17270 -- since System.Bignums makes this assumption. This is true of nearly
17271 -- all (all?) targets.
17273 when Pragma_Overflow_Mode => Overflow_Mode : declare
17274 function Get_Overflow_Mode
17276 Arg : Node_Id) return Overflow_Mode_Type;
17277 -- Function to process one pragma argument, Arg. If an identifier
17278 -- is present, it must be Name. Mode type is returned if a valid
17279 -- argument exists, otherwise an error is signalled.
17281 -----------------------
17282 -- Get_Overflow_Mode --
17283 -----------------------
17285 function Get_Overflow_Mode
17287 Arg : Node_Id) return Overflow_Mode_Type
17289 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
17292 Check_Optional_Identifier (Arg, Name);
17293 Check_Arg_Is_Identifier (Argx);
17295 if Chars (Argx) = Name_Strict then
17298 elsif Chars (Argx) = Name_Minimized then
17301 elsif Chars (Argx) = Name_Eliminated then
17302 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then
17304 ("Eliminated not implemented on this target", Argx);
17310 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
17312 end Get_Overflow_Mode;
17314 -- Start of processing for Overflow_Mode
17318 Check_At_Least_N_Arguments (1);
17319 Check_At_Most_N_Arguments (2);
17321 -- Process first argument
17323 Scope_Suppress.Overflow_Mode_General :=
17324 Get_Overflow_Mode (Name_General, Arg1);
17326 -- Case of only one argument
17328 if Arg_Count = 1 then
17329 Scope_Suppress.Overflow_Mode_Assertions :=
17330 Scope_Suppress.Overflow_Mode_General;
17332 -- Case of two arguments present
17335 Scope_Suppress.Overflow_Mode_Assertions :=
17336 Get_Overflow_Mode (Name_Assertions, Arg2);
17340 --------------------------
17341 -- Overriding Renamings --
17342 --------------------------
17344 -- pragma Overriding_Renamings;
17346 when Pragma_Overriding_Renamings =>
17348 Check_Arg_Count (0);
17349 Check_Valid_Configuration_Pragma;
17350 Overriding_Renamings := True;
17356 -- pragma Pack (first_subtype_LOCAL_NAME);
17358 when Pragma_Pack => Pack : declare
17359 Assoc : constant Node_Id := Arg1;
17363 Ignore : Boolean := False;
17366 Check_No_Identifiers;
17367 Check_Arg_Count (1);
17368 Check_Arg_Is_Local_Name (Arg1);
17370 Type_Id := Get_Pragma_Arg (Assoc);
17371 Find_Type (Type_Id);
17372 Typ := Entity (Type_Id);
17375 or else Rep_Item_Too_Early (Typ, N)
17379 Typ := Underlying_Type (Typ);
17382 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
17383 Error_Pragma ("pragma% must specify array or record type");
17386 Check_First_Subtype (Arg1);
17387 Check_Duplicate_Pragma (Typ);
17391 if Is_Array_Type (Typ) then
17392 Ctyp := Component_Type (Typ);
17394 -- Ignore pack that does nothing
17396 if Known_Static_Esize (Ctyp)
17397 and then Known_Static_RM_Size (Ctyp)
17398 and then Esize (Ctyp) = RM_Size (Ctyp)
17399 and then Addressable (Esize (Ctyp))
17404 -- Process OK pragma Pack. Note that if there is a separate
17405 -- component clause present, the Pack will be cancelled. This
17406 -- processing is in Freeze.
17408 if not Rep_Item_Too_Late (Typ, N) then
17410 -- In CodePeer mode, we do not need complex front-end
17411 -- expansions related to pragma Pack, so disable handling
17414 if CodePeer_Mode then
17417 -- Don't attempt any packing for VM targets. We possibly
17418 -- could deal with some cases of array bit-packing, but we
17419 -- don't bother, since this is not a typical kind of
17420 -- representation in the VM context anyway (and would not
17421 -- for example work nicely with the debugger).
17423 elsif VM_Target /= No_VM then
17424 if not GNAT_Mode then
17426 ("??pragma% ignored in this configuration");
17429 -- Normal case where we do the pack action
17433 Set_Is_Packed (Base_Type (Typ));
17434 Set_Has_Non_Standard_Rep (Base_Type (Typ));
17437 Set_Has_Pragma_Pack (Base_Type (Typ));
17441 -- For record types, the pack is always effective
17443 else pragma Assert (Is_Record_Type (Typ));
17444 if not Rep_Item_Too_Late (Typ, N) then
17446 -- Ignore pack request with warning in VM mode (skip warning
17447 -- if we are compiling GNAT run time library).
17449 if VM_Target /= No_VM then
17450 if not GNAT_Mode then
17452 ("??pragma% ignored in this configuration");
17455 -- Normal case of pack request active
17458 Set_Is_Packed (Base_Type (Typ));
17459 Set_Has_Pragma_Pack (Base_Type (Typ));
17460 Set_Has_Non_Standard_Rep (Base_Type (Typ));
17472 -- There is nothing to do here, since we did all the processing for
17473 -- this pragma in Par.Prag (so that it works properly even in syntax
17476 when Pragma_Page =>
17483 -- pragma Part_Of (ABSTRACT_STATE);
17485 -- ABSTRACT_STATE ::= name
17487 when Pragma_Part_Of => Part_Of : declare
17488 procedure Propagate_Part_Of
17489 (Pack_Id : Entity_Id;
17490 State_Id : Entity_Id;
17491 Instance : Node_Id);
17492 -- Propagate the Part_Of indicator to all abstract states and
17493 -- variables declared in the visible state space of a package
17494 -- denoted by Pack_Id. State_Id is the encapsulating state.
17495 -- Instance is the package instantiation node.
17497 -----------------------
17498 -- Propagate_Part_Of --
17499 -----------------------
17501 procedure Propagate_Part_Of
17502 (Pack_Id : Entity_Id;
17503 State_Id : Entity_Id;
17504 Instance : Node_Id)
17506 Has_Item : Boolean := False;
17507 -- Flag set when the visible state space contains at least one
17508 -- abstract state or variable.
17510 procedure Propagate_Part_Of (Pack_Id : Entity_Id);
17511 -- Propagate the Part_Of indicator to all abstract states and
17512 -- variables declared in the visible state space of a package
17513 -- denoted by Pack_Id.
17515 -----------------------
17516 -- Propagate_Part_Of --
17517 -----------------------
17519 procedure Propagate_Part_Of (Pack_Id : Entity_Id) is
17520 Item_Id : Entity_Id;
17523 -- Traverse the entity chain of the package and set relevant
17524 -- attributes of abstract states and variables declared in
17525 -- the visible state space of the package.
17527 Item_Id := First_Entity (Pack_Id);
17528 while Present (Item_Id)
17529 and then not In_Private_Part (Item_Id)
17531 -- Do not consider internally generated items
17533 if not Comes_From_Source (Item_Id) then
17536 -- The Part_Of indicator turns an abstract state or
17537 -- variable into a constituent of the encapsulating
17540 elsif Ekind_In (Item_Id, E_Abstract_State,
17545 Append_Elmt (Item_Id, Part_Of_Constituents (State_Id));
17546 Set_Encapsulating_State (Item_Id, State_Id);
17548 -- Recursively handle nested packages and instantiations
17550 elsif Ekind (Item_Id) = E_Package then
17551 Propagate_Part_Of (Item_Id);
17554 Next_Entity (Item_Id);
17556 end Propagate_Part_Of;
17558 -- Start of processing for Propagate_Part_Of
17561 Propagate_Part_Of (Pack_Id);
17563 -- Detect a package instantiation that is subject to a Part_Of
17564 -- indicator, but has no visible state.
17566 if not Has_Item then
17568 ("package instantiation & has Part_Of indicator but "
17569 & "lacks visible state", Instance, Pack_Id);
17571 end Propagate_Part_Of;
17575 Item_Id : Entity_Id;
17578 State_Id : Entity_Id;
17581 -- Start of processing for Part_Of
17585 Check_Arg_Count (1);
17587 -- Ensure the proper placement of the pragma. Part_Of must appear
17588 -- on a variable declaration or a package instantiation.
17591 while Present (Stmt) loop
17593 -- Skip prior pragmas, but check for duplicates
17595 if Nkind (Stmt) = N_Pragma then
17596 if Pragma_Name (Stmt) = Pname then
17597 Error_Msg_Name_1 := Pname;
17598 Error_Msg_Sloc := Sloc (Stmt);
17599 Error_Msg_N ("pragma% duplicates pragma declared#", N);
17602 -- Skip internally generated code
17604 elsif not Comes_From_Source (Stmt) then
17607 -- The pragma applies to an object declaration (possibly a
17608 -- variable) or a package instantiation. Stop the traversal
17609 -- and continue the analysis.
17611 elsif Nkind_In (Stmt, N_Object_Declaration,
17612 N_Package_Instantiation)
17616 -- The pragma does not apply to a legal construct, issue an
17617 -- error and stop the analysis.
17624 Stmt := Prev (Stmt);
17627 -- When the context is an object declaration, ensure that we are
17628 -- dealing with a variable.
17630 if Nkind (Stmt) = N_Object_Declaration
17631 and then Ekind (Defining_Entity (Stmt)) /= E_Variable
17633 Error_Msg_N ("indicator Part_Of must apply to a variable", N);
17637 -- Extract the entity of the related object declaration or package
17638 -- instantiation. In the case of the instantiation, use the entity
17639 -- of the instance spec.
17641 if Nkind (Stmt) = N_Package_Instantiation then
17642 Stmt := Instance_Spec (Stmt);
17645 Item_Id := Defining_Entity (Stmt);
17646 State := Get_Pragma_Arg (Arg1);
17648 -- Detect any discrepancies between the placement of the object
17649 -- or package instantiation with respect to state space and the
17650 -- encapsulating state.
17653 (Item_Id => Item_Id,
17659 State_Id := Entity (State);
17661 -- Add the pragma to the contract of the item. This aids with
17662 -- the detection of a missing but required Part_Of indicator.
17664 Add_Contract_Item (N, Item_Id);
17666 -- The Part_Of indicator turns a variable into a constituent
17667 -- of the encapsulating state.
17669 if Ekind (Item_Id) = E_Variable then
17670 Append_Elmt (Item_Id, Part_Of_Constituents (State_Id));
17671 Set_Encapsulating_State (Item_Id, State_Id);
17673 -- Propagate the Part_Of indicator to the visible state space
17674 -- of the package instantiation.
17678 (Pack_Id => Item_Id,
17679 State_Id => State_Id,
17685 ----------------------------------
17686 -- Partition_Elaboration_Policy --
17687 ----------------------------------
17689 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
17691 when Pragma_Partition_Elaboration_Policy => declare
17692 subtype PEP_Range is Name_Id
17693 range First_Partition_Elaboration_Policy_Name
17694 .. Last_Partition_Elaboration_Policy_Name;
17695 PEP_Val : PEP_Range;
17700 Check_Arg_Count (1);
17701 Check_No_Identifiers;
17702 Check_Arg_Is_Partition_Elaboration_Policy (Arg1);
17703 Check_Valid_Configuration_Pragma;
17704 PEP_Val := Chars (Get_Pragma_Arg (Arg1));
17707 when Name_Concurrent =>
17709 when Name_Sequential =>
17713 if Partition_Elaboration_Policy /= ' '
17714 and then Partition_Elaboration_Policy /= PEP
17716 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc;
17718 ("partition elaboration policy incompatible with policy#");
17720 -- Set new policy, but always preserve System_Location since we
17721 -- like the error message with the run time name.
17724 Partition_Elaboration_Policy := PEP;
17726 if Partition_Elaboration_Policy_Sloc /= System_Location then
17727 Partition_Elaboration_Policy_Sloc := Loc;
17736 -- pragma Passive [(PASSIVE_FORM)];
17738 -- PASSIVE_FORM ::= Semaphore | No
17740 when Pragma_Passive =>
17743 if Nkind (Parent (N)) /= N_Task_Definition then
17744 Error_Pragma ("pragma% must be within task definition");
17747 if Arg_Count /= 0 then
17748 Check_Arg_Count (1);
17749 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
17752 ----------------------------------
17753 -- Preelaborable_Initialization --
17754 ----------------------------------
17756 -- pragma Preelaborable_Initialization (DIRECT_NAME);
17758 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
17763 Check_Arg_Count (1);
17764 Check_No_Identifiers;
17765 Check_Arg_Is_Identifier (Arg1);
17766 Check_Arg_Is_Local_Name (Arg1);
17767 Check_First_Subtype (Arg1);
17768 Ent := Entity (Get_Pragma_Arg (Arg1));
17770 -- The pragma may come from an aspect on a private declaration,
17771 -- even if the freeze point at which this is analyzed in the
17772 -- private part after the full view.
17774 if Has_Private_Declaration (Ent)
17775 and then From_Aspect_Specification (N)
17779 elsif Is_Private_Type (Ent)
17780 or else Is_Protected_Type (Ent)
17781 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))
17787 ("pragma % can only be applied to private, formal derived or "
17788 & "protected type",
17792 -- Give an error if the pragma is applied to a protected type that
17793 -- does not qualify (due to having entries, or due to components
17794 -- that do not qualify).
17796 if Is_Protected_Type (Ent)
17797 and then not Has_Preelaborable_Initialization (Ent)
17800 ("protected type & does not have preelaborable "
17801 & "initialization", Ent);
17803 -- Otherwise mark the type as definitely having preelaborable
17807 Set_Known_To_Have_Preelab_Init (Ent);
17810 if Has_Pragma_Preelab_Init (Ent)
17811 and then Warn_On_Redundant_Constructs
17813 Error_Pragma ("?r?duplicate pragma%!");
17815 Set_Has_Pragma_Preelab_Init (Ent);
17819 --------------------
17820 -- Persistent_BSS --
17821 --------------------
17823 -- pragma Persistent_BSS [(object_NAME)];
17825 when Pragma_Persistent_BSS => Persistent_BSS : declare
17832 Check_At_Most_N_Arguments (1);
17834 -- Case of application to specific object (one argument)
17836 if Arg_Count = 1 then
17837 Check_Arg_Is_Library_Level_Local_Name (Arg1);
17839 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
17841 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
17844 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
17847 Ent := Entity (Get_Pragma_Arg (Arg1));
17848 Decl := Parent (Ent);
17850 -- Check for duplication before inserting in list of
17851 -- representation items.
17853 Check_Duplicate_Pragma (Ent);
17855 if Rep_Item_Too_Late (Ent, N) then
17859 if Present (Expression (Decl)) then
17861 ("object for pragma% cannot have initialization", Arg1);
17864 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
17866 ("object type for pragma% is not potentially persistent",
17871 Make_Linker_Section_Pragma
17872 (Ent, Sloc (N), ".persistent.bss");
17873 Insert_After (N, Prag);
17876 -- Case of use as configuration pragma with no arguments
17879 Check_Valid_Configuration_Pragma;
17880 Persistent_BSS_Mode := True;
17882 end Persistent_BSS;
17888 -- pragma Polling (ON | OFF);
17890 when Pragma_Polling =>
17892 Check_Arg_Count (1);
17893 Check_No_Identifiers;
17894 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
17895 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
17901 -- pragma Post (Boolean_EXPRESSION);
17902 -- pragma Post_Class (Boolean_EXPRESSION);
17904 when Pragma_Post | Pragma_Post_Class => Post : declare
17905 PC_Pragma : Node_Id;
17909 Check_Arg_Count (1);
17910 Check_No_Identifiers;
17913 -- Rewrite Post[_Class] pragma as Precondition pragma setting the
17914 -- flag Class_Present to True for the Post_Class case.
17916 Set_Class_Present (N, Prag_Id = Pragma_Pre_Class);
17917 PC_Pragma := New_Copy (N);
17918 Set_Pragma_Identifier
17919 (PC_Pragma, Make_Identifier (Loc, Name_Postcondition));
17920 Rewrite (N, PC_Pragma);
17921 Set_Analyzed (N, False);
17925 -------------------
17926 -- Postcondition --
17927 -------------------
17929 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
17930 -- [,[Message =>] String_EXPRESSION]);
17932 when Pragma_Postcondition => Postcondition : declare
17937 Check_At_Least_N_Arguments (1);
17938 Check_At_Most_N_Arguments (2);
17939 Check_Optional_Identifier (Arg1, Name_Check);
17941 -- Verify the proper placement of the pragma. The remainder of the
17942 -- processing is found in Sem_Ch6/Sem_Ch7.
17944 Check_Precondition_Postcondition (In_Body);
17946 -- When the pragma is a source construct appearing inside a body,
17947 -- preanalyze the boolean_expression to detect illegal forward
17951 -- pragma Postcondition (X'Old ...);
17954 if Comes_From_Source (N) and then In_Body then
17955 Preanalyze_Spec_Expression (Expression (Arg1), Any_Boolean);
17963 -- pragma Pre (Boolean_EXPRESSION);
17964 -- pragma Pre_Class (Boolean_EXPRESSION);
17966 when Pragma_Pre | Pragma_Pre_Class => Pre : declare
17967 PC_Pragma : Node_Id;
17971 Check_Arg_Count (1);
17972 Check_No_Identifiers;
17975 -- Rewrite Pre[_Class] pragma as Precondition pragma setting the
17976 -- flag Class_Present to True for the Pre_Class case.
17978 Set_Class_Present (N, Prag_Id = Pragma_Pre_Class);
17979 PC_Pragma := New_Copy (N);
17980 Set_Pragma_Identifier
17981 (PC_Pragma, Make_Identifier (Loc, Name_Precondition));
17982 Rewrite (N, PC_Pragma);
17983 Set_Analyzed (N, False);
17991 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
17992 -- [,[Message =>] String_EXPRESSION]);
17994 when Pragma_Precondition => Precondition : declare
17999 Check_At_Least_N_Arguments (1);
18000 Check_At_Most_N_Arguments (2);
18001 Check_Optional_Identifier (Arg1, Name_Check);
18002 Check_Precondition_Postcondition (In_Body);
18004 -- If in spec, nothing more to do. If in body, then we convert
18005 -- the pragma to an equivalent pragma Check. That works fine since
18006 -- pragma Check will analyze the condition in the proper context.
18008 -- The form of the pragma Check is either:
18010 -- pragma Check (Precondition, cond [, msg])
18012 -- pragma Check (Pre, cond [, msg])
18014 -- We use the Pre form if this pragma derived from a Pre aspect.
18015 -- This is needed to make sure that the right set of Policy
18016 -- pragmas are checked.
18020 -- Rewrite as Check pragma
18024 Chars => Name_Check,
18025 Pragma_Argument_Associations => New_List (
18026 Make_Pragma_Argument_Association (Loc,
18027 Expression => Make_Identifier (Loc, Pname)),
18029 Make_Pragma_Argument_Association (Sloc (Arg1),
18031 Relocate_Node (Get_Pragma_Arg (Arg1))))));
18033 if Arg_Count = 2 then
18034 Append_To (Pragma_Argument_Associations (N),
18035 Make_Pragma_Argument_Association (Sloc (Arg2),
18037 Relocate_Node (Get_Pragma_Arg (Arg2))));
18048 -- pragma Predicate
18049 -- ([Entity =>] type_LOCAL_NAME,
18050 -- [Check =>] boolean_EXPRESSION);
18052 when Pragma_Predicate => Predicate : declare
18057 pragma Unreferenced (Discard);
18061 Check_Arg_Count (2);
18062 Check_Optional_Identifier (Arg1, Name_Entity);
18063 Check_Optional_Identifier (Arg2, Name_Check);
18065 Check_Arg_Is_Local_Name (Arg1);
18067 Type_Id := Get_Pragma_Arg (Arg1);
18068 Find_Type (Type_Id);
18069 Typ := Entity (Type_Id);
18071 if Typ = Any_Type then
18075 -- The remaining processing is simply to link the pragma on to
18076 -- the rep item chain, for processing when the type is frozen.
18077 -- This is accomplished by a call to Rep_Item_Too_Late. We also
18078 -- mark the type as having predicates.
18080 Set_Has_Predicates (Typ);
18081 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
18088 -- pragma Preelaborate [(library_unit_NAME)];
18090 -- Set the flag Is_Preelaborated of program unit name entity
18092 when Pragma_Preelaborate => Preelaborate : declare
18093 Pa : constant Node_Id := Parent (N);
18094 Pk : constant Node_Kind := Nkind (Pa);
18098 Check_Ada_83_Warning;
18099 Check_Valid_Library_Unit_Pragma;
18101 if Nkind (N) = N_Null_Statement then
18105 Ent := Find_Lib_Unit_Name;
18106 Check_Duplicate_Pragma (Ent);
18108 -- This filters out pragmas inside generic parents that show up
18109 -- inside instantiations. Pragmas that come from aspects in the
18110 -- unit are not ignored.
18112 if Present (Ent) then
18113 if Pk = N_Package_Specification
18114 and then Present (Generic_Parent (Pa))
18115 and then not From_Aspect_Specification (N)
18120 if not Debug_Flag_U then
18121 Set_Is_Preelaborated (Ent);
18122 Set_Suppress_Elaboration_Warnings (Ent);
18128 ---------------------
18129 -- Preelaborate_05 --
18130 ---------------------
18132 -- pragma Preelaborate_05 [(library_unit_NAME)];
18134 -- This pragma is useable only in GNAT_Mode, where it is used like
18135 -- pragma Preelaborate but it is only effective in Ada 2005 mode
18136 -- (otherwise it is ignored). This is used to implement AI-362 which
18137 -- recategorizes some run-time packages in Ada 2005 mode.
18139 when Pragma_Preelaborate_05 => Preelaborate_05 : declare
18144 Check_Valid_Library_Unit_Pragma;
18146 if not GNAT_Mode then
18147 Error_Pragma ("pragma% only available in GNAT mode");
18150 if Nkind (N) = N_Null_Statement then
18154 -- This is one of the few cases where we need to test the value of
18155 -- Ada_Version_Explicit rather than Ada_Version (which is always
18156 -- set to Ada_2012 in a predefined unit), we need to know the
18157 -- explicit version set to know if this pragma is active.
18159 if Ada_Version_Explicit >= Ada_2005 then
18160 Ent := Find_Lib_Unit_Name;
18161 Set_Is_Preelaborated (Ent);
18162 Set_Suppress_Elaboration_Warnings (Ent);
18164 end Preelaborate_05;
18170 -- pragma Priority (EXPRESSION);
18172 when Pragma_Priority => Priority : declare
18173 P : constant Node_Id := Parent (N);
18178 Check_No_Identifiers;
18179 Check_Arg_Count (1);
18183 if Nkind (P) = N_Subprogram_Body then
18184 Check_In_Main_Program;
18186 Ent := Defining_Unit_Name (Specification (P));
18188 if Nkind (Ent) = N_Defining_Program_Unit_Name then
18189 Ent := Defining_Identifier (Ent);
18192 Arg := Get_Pragma_Arg (Arg1);
18193 Analyze_And_Resolve (Arg, Standard_Integer);
18197 if not Is_Static_Expression (Arg) then
18198 Flag_Non_Static_Expr
18199 ("main subprogram priority is not static!", Arg);
18202 -- If constraint error, then we already signalled an error
18204 elsif Raises_Constraint_Error (Arg) then
18207 -- Otherwise check in range except if Relaxed_RM_Semantics
18208 -- where we ignore the value if out of range.
18212 Val : constant Uint := Expr_Value (Arg);
18214 if not Relaxed_RM_Semantics
18217 or else Val > Expr_Value (Expression
18218 (Parent (RTE (RE_Max_Priority)))))
18221 ("main subprogram priority is out of range", Arg1);
18224 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
18229 -- Load an arbitrary entity from System.Tasking.Stages or
18230 -- System.Tasking.Restricted.Stages (depending on the
18231 -- supported profile) to make sure that one of these packages
18232 -- is implicitly with'ed, since we need to have the tasking
18233 -- run time active for the pragma Priority to have any effect.
18234 -- Previously with with'ed the package System.Tasking, but
18235 -- this package does not trigger the required initialization
18236 -- of the run-time library.
18239 Discard : Entity_Id;
18240 pragma Warnings (Off, Discard);
18242 if Restricted_Profile then
18243 Discard := RTE (RE_Activate_Restricted_Tasks);
18245 Discard := RTE (RE_Activate_Tasks);
18249 -- Task or Protected, must be of type Integer
18251 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
18252 Arg := Get_Pragma_Arg (Arg1);
18253 Ent := Defining_Identifier (Parent (P));
18255 -- The expression must be analyzed in the special manner
18256 -- described in "Handling of Default and Per-Object
18257 -- Expressions" in sem.ads.
18259 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority));
18261 if not Is_Static_Expression (Arg) then
18262 Check_Restriction (Static_Priorities, Arg);
18265 -- Anything else is incorrect
18271 -- Check duplicate pragma before we chain the pragma in the Rep
18272 -- Item chain of Ent.
18274 Check_Duplicate_Pragma (Ent);
18275 Record_Rep_Item (Ent, N);
18278 -----------------------------------
18279 -- Priority_Specific_Dispatching --
18280 -----------------------------------
18282 -- pragma Priority_Specific_Dispatching (
18283 -- policy_IDENTIFIER,
18284 -- first_priority_EXPRESSION,
18285 -- last_priority_EXPRESSION);
18287 when Pragma_Priority_Specific_Dispatching =>
18288 Priority_Specific_Dispatching : declare
18289 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
18290 -- This is the entity System.Any_Priority;
18293 Lower_Bound : Node_Id;
18294 Upper_Bound : Node_Id;
18300 Check_Arg_Count (3);
18301 Check_No_Identifiers;
18302 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
18303 Check_Valid_Configuration_Pragma;
18304 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
18305 DP := Fold_Upper (Name_Buffer (1));
18307 Lower_Bound := Get_Pragma_Arg (Arg2);
18308 Check_Arg_Is_Static_Expression (Lower_Bound, Standard_Integer);
18309 Lower_Val := Expr_Value (Lower_Bound);
18311 Upper_Bound := Get_Pragma_Arg (Arg3);
18312 Check_Arg_Is_Static_Expression (Upper_Bound, Standard_Integer);
18313 Upper_Val := Expr_Value (Upper_Bound);
18315 -- It is not allowed to use Task_Dispatching_Policy and
18316 -- Priority_Specific_Dispatching in the same partition.
18318 if Task_Dispatching_Policy /= ' ' then
18319 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
18321 ("pragma% incompatible with Task_Dispatching_Policy#");
18323 -- Check lower bound in range
18325 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
18327 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
18330 ("first_priority is out of range", Arg2);
18332 -- Check upper bound in range
18334 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
18336 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
18339 ("last_priority is out of range", Arg3);
18341 -- Check that the priority range is valid
18343 elsif Lower_Val > Upper_Val then
18345 ("last_priority_expression must be greater than or equal to "
18346 & "first_priority_expression");
18348 -- Store the new policy, but always preserve System_Location since
18349 -- we like the error message with the run-time name.
18352 -- Check overlapping in the priority ranges specified in other
18353 -- Priority_Specific_Dispatching pragmas within the same
18354 -- partition. We can only check those we know about.
18357 Specific_Dispatching.First .. Specific_Dispatching.Last
18359 if Specific_Dispatching.Table (J).First_Priority in
18360 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
18361 or else Specific_Dispatching.Table (J).Last_Priority in
18362 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
18365 Specific_Dispatching.Table (J).Pragma_Loc;
18367 ("priority range overlaps with "
18368 & "Priority_Specific_Dispatching#");
18372 -- The use of Priority_Specific_Dispatching is incompatible
18373 -- with Task_Dispatching_Policy.
18375 if Task_Dispatching_Policy /= ' ' then
18376 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
18378 ("Priority_Specific_Dispatching incompatible "
18379 & "with Task_Dispatching_Policy#");
18382 -- The use of Priority_Specific_Dispatching forces ceiling
18385 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
18386 Error_Msg_Sloc := Locking_Policy_Sloc;
18388 ("Priority_Specific_Dispatching incompatible "
18389 & "with Locking_Policy#");
18391 -- Set the Ceiling_Locking policy, but preserve System_Location
18392 -- since we like the error message with the run time name.
18395 Locking_Policy := 'C';
18397 if Locking_Policy_Sloc /= System_Location then
18398 Locking_Policy_Sloc := Loc;
18402 -- Add entry in the table
18404 Specific_Dispatching.Append
18405 ((Dispatching_Policy => DP,
18406 First_Priority => UI_To_Int (Lower_Val),
18407 Last_Priority => UI_To_Int (Upper_Val),
18408 Pragma_Loc => Loc));
18410 end Priority_Specific_Dispatching;
18416 -- pragma Profile (profile_IDENTIFIER);
18418 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
18420 when Pragma_Profile =>
18422 Check_Arg_Count (1);
18423 Check_Valid_Configuration_Pragma;
18424 Check_No_Identifiers;
18427 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
18430 if Chars (Argx) = Name_Ravenscar then
18431 Set_Ravenscar_Profile (N);
18433 elsif Chars (Argx) = Name_Restricted then
18434 Set_Profile_Restrictions
18436 N, Warn => Treat_Restrictions_As_Warnings);
18438 elsif Chars (Argx) = Name_Rational then
18439 Set_Rational_Profile;
18441 elsif Chars (Argx) = Name_No_Implementation_Extensions then
18442 Set_Profile_Restrictions
18443 (No_Implementation_Extensions,
18444 N, Warn => Treat_Restrictions_As_Warnings);
18447 Error_Pragma_Arg ("& is not a valid profile", Argx);
18451 ----------------------
18452 -- Profile_Warnings --
18453 ----------------------
18455 -- pragma Profile_Warnings (profile_IDENTIFIER);
18457 -- profile_IDENTIFIER => Restricted | Ravenscar
18459 when Pragma_Profile_Warnings =>
18461 Check_Arg_Count (1);
18462 Check_Valid_Configuration_Pragma;
18463 Check_No_Identifiers;
18466 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
18469 if Chars (Argx) = Name_Ravenscar then
18470 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
18472 elsif Chars (Argx) = Name_Restricted then
18473 Set_Profile_Restrictions (Restricted, N, Warn => True);
18475 elsif Chars (Argx) = Name_No_Implementation_Extensions then
18476 Set_Profile_Restrictions
18477 (No_Implementation_Extensions, N, Warn => True);
18480 Error_Pragma_Arg ("& is not a valid profile", Argx);
18484 --------------------------
18485 -- Propagate_Exceptions --
18486 --------------------------
18488 -- pragma Propagate_Exceptions;
18490 -- Note: this pragma is obsolete and has no effect
18492 when Pragma_Propagate_Exceptions =>
18494 Check_Arg_Count (0);
18496 if Warn_On_Obsolescent_Feature then
18498 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
18499 "and has no effect?j?", N);
18502 -----------------------------
18503 -- Provide_Shift_Operators --
18504 -----------------------------
18506 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
18508 when Pragma_Provide_Shift_Operators =>
18509 Provide_Shift_Operators : declare
18512 procedure Declare_Shift_Operator (Nam : Name_Id);
18513 -- Insert declaration and pragma Instrinsic for named shift op
18515 ----------------------------
18516 -- Declare_Shift_Operator --
18517 ----------------------------
18519 procedure Declare_Shift_Operator (Nam : Name_Id) is
18525 Make_Subprogram_Declaration (Loc,
18526 Make_Function_Specification (Loc,
18527 Defining_Unit_Name =>
18528 Make_Defining_Identifier (Loc, Chars => Nam),
18530 Result_Definition =>
18531 Make_Identifier (Loc, Chars => Chars (Ent)),
18533 Parameter_Specifications => New_List (
18534 Make_Parameter_Specification (Loc,
18535 Defining_Identifier =>
18536 Make_Defining_Identifier (Loc, Name_Value),
18538 Make_Identifier (Loc, Chars => Chars (Ent))),
18540 Make_Parameter_Specification (Loc,
18541 Defining_Identifier =>
18542 Make_Defining_Identifier (Loc, Name_Amount),
18544 New_Occurrence_Of (Standard_Natural, Loc)))));
18548 Pragma_Identifier => Make_Identifier (Loc, Name_Import),
18549 Pragma_Argument_Associations => New_List (
18550 Make_Pragma_Argument_Association (Loc,
18551 Expression => Make_Identifier (Loc, Name_Intrinsic)),
18552 Make_Pragma_Argument_Association (Loc,
18553 Expression => Make_Identifier (Loc, Nam))));
18555 Insert_After (N, Import);
18556 Insert_After (N, Func);
18557 end Declare_Shift_Operator;
18559 -- Start of processing for Provide_Shift_Operators
18563 Check_Arg_Count (1);
18564 Check_Arg_Is_Local_Name (Arg1);
18566 Arg1 := Get_Pragma_Arg (Arg1);
18568 -- We must have an entity name
18570 if not Is_Entity_Name (Arg1) then
18572 ("pragma % must apply to integer first subtype", Arg1);
18575 -- If no Entity, means there was a prior error so ignore
18577 if Present (Entity (Arg1)) then
18578 Ent := Entity (Arg1);
18580 -- Apply error checks
18582 if not Is_First_Subtype (Ent) then
18584 ("cannot apply pragma %",
18585 "\& is not a first subtype",
18588 elsif not Is_Integer_Type (Ent) then
18590 ("cannot apply pragma %",
18591 "\& is not an integer type",
18594 elsif Has_Shift_Operator (Ent) then
18596 ("cannot apply pragma %",
18597 "\& already has declared shift operators",
18600 elsif Is_Frozen (Ent) then
18602 ("pragma % appears too late",
18603 "\& is already frozen",
18607 -- Now declare the operators. We do this during analysis rather
18608 -- than expansion, since we want the operators available if we
18609 -- are operating in -gnatc or ASIS mode.
18611 Declare_Shift_Operator (Name_Rotate_Left);
18612 Declare_Shift_Operator (Name_Rotate_Right);
18613 Declare_Shift_Operator (Name_Shift_Left);
18614 Declare_Shift_Operator (Name_Shift_Right);
18615 Declare_Shift_Operator (Name_Shift_Right_Arithmetic);
18617 end Provide_Shift_Operators;
18623 -- pragma Psect_Object (
18624 -- [Internal =>] LOCAL_NAME,
18625 -- [, [External =>] EXTERNAL_SYMBOL]
18626 -- [, [Size =>] EXTERNAL_SYMBOL]);
18628 when Pragma_Psect_Object | Pragma_Common_Object =>
18629 Psect_Object : declare
18630 Args : Args_List (1 .. 3);
18631 Names : constant Name_List (1 .. 3) := (
18636 Internal : Node_Id renames Args (1);
18637 External : Node_Id renames Args (2);
18638 Size : Node_Id renames Args (3);
18640 Def_Id : Entity_Id;
18642 procedure Check_Too_Long (Arg : Node_Id);
18643 -- Posts message if the argument is an identifier with more
18644 -- than 31 characters, or a string literal with more than
18645 -- 31 characters, and we are operating under VMS
18647 --------------------
18648 -- Check_Too_Long --
18649 --------------------
18651 procedure Check_Too_Long (Arg : Node_Id) is
18652 X : constant Node_Id := Original_Node (Arg);
18655 if not Nkind_In (X, N_String_Literal, N_Identifier) then
18657 ("inappropriate argument for pragma %", Arg);
18660 if OpenVMS_On_Target then
18661 if (Nkind (X) = N_String_Literal
18662 and then String_Length (Strval (X)) > 31)
18664 (Nkind (X) = N_Identifier
18665 and then Length_Of_Name (Chars (X)) > 31)
18668 ("argument for pragma % is longer than 31 characters",
18672 end Check_Too_Long;
18674 -- Start of processing for Common_Object/Psect_Object
18678 Gather_Associations (Names, Args);
18679 Process_Extended_Import_Export_Internal_Arg (Internal);
18681 Def_Id := Entity (Internal);
18683 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
18685 ("pragma% must designate an object", Internal);
18688 Check_Too_Long (Internal);
18690 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
18692 ("cannot use pragma% for imported/exported object",
18696 if Is_Concurrent_Type (Etype (Internal)) then
18698 ("cannot specify pragma % for task/protected object",
18702 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
18704 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
18706 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N);
18709 if Ekind (Def_Id) = E_Constant then
18711 ("cannot specify pragma % for a constant", Internal);
18714 if Is_Record_Type (Etype (Internal)) then
18720 Ent := First_Entity (Etype (Internal));
18721 while Present (Ent) loop
18722 Decl := Declaration_Node (Ent);
18724 if Ekind (Ent) = E_Component
18725 and then Nkind (Decl) = N_Component_Declaration
18726 and then Present (Expression (Decl))
18727 and then Warn_On_Export_Import
18730 ("?x?object for pragma % has defaults", Internal);
18740 if Present (Size) then
18741 Check_Too_Long (Size);
18744 if Present (External) then
18745 Check_Arg_Is_External_Name (External);
18746 Check_Too_Long (External);
18749 -- If all error tests pass, link pragma on to the rep item chain
18751 Record_Rep_Item (Def_Id, N);
18758 -- pragma Pure [(library_unit_NAME)];
18760 when Pragma_Pure => Pure : declare
18764 Check_Ada_83_Warning;
18765 Check_Valid_Library_Unit_Pragma;
18767 if Nkind (N) = N_Null_Statement then
18771 Ent := Find_Lib_Unit_Name;
18773 Set_Has_Pragma_Pure (Ent);
18774 Set_Suppress_Elaboration_Warnings (Ent);
18781 -- pragma Pure_05 [(library_unit_NAME)];
18783 -- This pragma is useable only in GNAT_Mode, where it is used like
18784 -- pragma Pure but it is only effective in Ada 2005 mode (otherwise
18785 -- it is ignored). It may be used after a pragma Preelaborate, in
18786 -- which case it overrides the effect of the pragma Preelaborate.
18787 -- This is used to implement AI-362 which recategorizes some run-time
18788 -- packages in Ada 2005 mode.
18790 when Pragma_Pure_05 => Pure_05 : declare
18795 Check_Valid_Library_Unit_Pragma;
18797 if not GNAT_Mode then
18798 Error_Pragma ("pragma% only available in GNAT mode");
18801 if Nkind (N) = N_Null_Statement then
18805 -- This is one of the few cases where we need to test the value of
18806 -- Ada_Version_Explicit rather than Ada_Version (which is always
18807 -- set to Ada_2012 in a predefined unit), we need to know the
18808 -- explicit version set to know if this pragma is active.
18810 if Ada_Version_Explicit >= Ada_2005 then
18811 Ent := Find_Lib_Unit_Name;
18812 Set_Is_Preelaborated (Ent, False);
18814 Set_Suppress_Elaboration_Warnings (Ent);
18822 -- pragma Pure_12 [(library_unit_NAME)];
18824 -- This pragma is useable only in GNAT_Mode, where it is used like
18825 -- pragma Pure but it is only effective in Ada 2012 mode (otherwise
18826 -- it is ignored). It may be used after a pragma Preelaborate, in
18827 -- which case it overrides the effect of the pragma Preelaborate.
18828 -- This is used to implement AI05-0212 which recategorizes some
18829 -- run-time packages in Ada 2012 mode.
18831 when Pragma_Pure_12 => Pure_12 : declare
18836 Check_Valid_Library_Unit_Pragma;
18838 if not GNAT_Mode then
18839 Error_Pragma ("pragma% only available in GNAT mode");
18842 if Nkind (N) = N_Null_Statement then
18846 -- This is one of the few cases where we need to test the value of
18847 -- Ada_Version_Explicit rather than Ada_Version (which is always
18848 -- set to Ada_2012 in a predefined unit), we need to know the
18849 -- explicit version set to know if this pragma is active.
18851 if Ada_Version_Explicit >= Ada_2012 then
18852 Ent := Find_Lib_Unit_Name;
18853 Set_Is_Preelaborated (Ent, False);
18855 Set_Suppress_Elaboration_Warnings (Ent);
18859 -------------------
18860 -- Pure_Function --
18861 -------------------
18863 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
18865 when Pragma_Pure_Function => Pure_Function : declare
18868 Def_Id : Entity_Id;
18869 Effective : Boolean := False;
18873 Check_Arg_Count (1);
18874 Check_Optional_Identifier (Arg1, Name_Entity);
18875 Check_Arg_Is_Local_Name (Arg1);
18876 E_Id := Get_Pragma_Arg (Arg1);
18878 if Error_Posted (E_Id) then
18882 -- Loop through homonyms (overloadings) of referenced entity
18884 E := Entity (E_Id);
18886 if Present (E) then
18888 Def_Id := Get_Base_Subprogram (E);
18890 if not Ekind_In (Def_Id, E_Function,
18891 E_Generic_Function,
18895 ("pragma% requires a function name", Arg1);
18898 Set_Is_Pure (Def_Id);
18900 if not Has_Pragma_Pure_Function (Def_Id) then
18901 Set_Has_Pragma_Pure_Function (Def_Id);
18905 exit when From_Aspect_Specification (N);
18907 exit when No (E) or else Scope (E) /= Current_Scope;
18911 and then Warn_On_Redundant_Constructs
18914 ("pragma Pure_Function on& is redundant?r?",
18920 --------------------
18921 -- Queuing_Policy --
18922 --------------------
18924 -- pragma Queuing_Policy (policy_IDENTIFIER);
18926 when Pragma_Queuing_Policy => declare
18930 Check_Ada_83_Warning;
18931 Check_Arg_Count (1);
18932 Check_No_Identifiers;
18933 Check_Arg_Is_Queuing_Policy (Arg1);
18934 Check_Valid_Configuration_Pragma;
18935 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
18936 QP := Fold_Upper (Name_Buffer (1));
18938 if Queuing_Policy /= ' '
18939 and then Queuing_Policy /= QP
18941 Error_Msg_Sloc := Queuing_Policy_Sloc;
18942 Error_Pragma ("queuing policy incompatible with policy#");
18944 -- Set new policy, but always preserve System_Location since we
18945 -- like the error message with the run time name.
18948 Queuing_Policy := QP;
18950 if Queuing_Policy_Sloc /= System_Location then
18951 Queuing_Policy_Sloc := Loc;
18960 -- pragma Rational, for compatibility with foreign compiler
18962 when Pragma_Rational =>
18963 Set_Rational_Profile;
18965 ------------------------------------
18966 -- Refined_Depends/Refined_Global --
18967 ------------------------------------
18969 -- pragma Refined_Depends (DEPENDENCY_RELATION);
18971 -- DEPENDENCY_RELATION ::=
18973 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
18975 -- DEPENDENCY_CLAUSE ::=
18976 -- OUTPUT_LIST =>[+] INPUT_LIST
18977 -- | NULL_DEPENDENCY_CLAUSE
18979 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
18981 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
18983 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
18985 -- OUTPUT ::= NAME | FUNCTION_RESULT
18988 -- where FUNCTION_RESULT is a function Result attribute_reference
18990 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
18992 -- GLOBAL_SPECIFICATION ::=
18995 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
18997 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
18999 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
19000 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
19001 -- GLOBAL_ITEM ::= NAME
19003 when Pragma_Refined_Depends |
19004 Pragma_Refined_Global => Refined_Depends_Global :
19006 Body_Id : Entity_Id;
19008 Spec_Id : Entity_Id;
19011 Analyze_Refined_Pragma (Spec_Id, Body_Id, Legal);
19013 -- Save the pragma in the contract of the subprogram body. The
19014 -- remaining analysis is performed at the end of the enclosing
19018 Add_Contract_Item (N, Body_Id);
19020 end Refined_Depends_Global;
19026 -- pragma Refined_Post (boolean_EXPRESSION);
19028 when Pragma_Refined_Post => Refined_Post : declare
19029 Body_Id : Entity_Id;
19031 Result_Seen : Boolean := False;
19032 Spec_Id : Entity_Id;
19035 Analyze_Refined_Pragma (Spec_Id, Body_Id, Legal);
19037 -- Analyze the boolean expression as a "spec expression"
19040 Analyze_Pre_Post_Condition_In_Decl_Part (N, Spec_Id);
19042 -- Verify that the refined postcondition mentions attribute
19043 -- 'Result and its expression introduces a post-state.
19045 if Warn_On_Suspicious_Contract
19046 and then Ekind_In (Spec_Id, E_Function, E_Generic_Function)
19048 Check_Result_And_Post_State (N, Result_Seen);
19050 if not Result_Seen then
19052 ("pragma % does not mention function result?T?");
19056 -- Chain the pragma on the contract for easy retrieval
19058 Add_Contract_Item (N, Body_Id);
19062 -------------------
19063 -- Refined_State --
19064 -------------------
19066 -- pragma Refined_State (REFINEMENT_LIST);
19068 -- REFINEMENT_LIST ::=
19069 -- REFINEMENT_CLAUSE
19070 -- | (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
19072 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
19074 -- CONSTITUENT_LIST ::=
19077 -- | (CONSTITUENT {, CONSTITUENT})
19079 -- CONSTITUENT ::= object_NAME | state_NAME
19081 when Pragma_Refined_State => Refined_State : declare
19082 Context : constant Node_Id := Parent (N);
19083 Spec_Id : Entity_Id;
19088 Check_Arg_Count (1);
19090 -- Ensure the proper placement of the pragma. Refined states must
19091 -- be associated with a package body.
19093 if Nkind (Context) /= N_Package_Body then
19099 while Present (Stmt) loop
19101 -- Skip prior pragmas, but check for duplicates
19103 if Nkind (Stmt) = N_Pragma then
19104 if Pragma_Name (Stmt) = Pname then
19105 Error_Msg_Name_1 := Pname;
19106 Error_Msg_Sloc := Sloc (Stmt);
19107 Error_Msg_N ("pragma % duplicates pragma declared #", N);
19110 -- Skip internally generated code
19112 elsif not Comes_From_Source (Stmt) then
19115 -- The pragma does not apply to a legal construct, issue an
19116 -- error and stop the analysis.
19123 Stmt := Prev (Stmt);
19126 Spec_Id := Corresponding_Spec (Context);
19128 -- State refinement is allowed only when the corresponding package
19129 -- declaration has non-null pragma Abstract_State. Refinement not
19130 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
19132 if SPARK_Mode /= Off
19134 (No (Abstract_States (Spec_Id))
19135 or else Has_Null_Abstract_State (Spec_Id))
19138 ("useless refinement, package & does not define abstract "
19139 & "states", N, Spec_Id);
19143 -- The pragma must be analyzed at the end of the declarations as
19144 -- it has visibility over the whole declarative region. Save the
19145 -- pragma for later (see Analyze_Refined_Depends_In_Decl_Part) by
19146 -- adding it to the contract of the package body.
19148 Add_Contract_Item (N, Defining_Entity (Context));
19151 -----------------------
19152 -- Relative_Deadline --
19153 -----------------------
19155 -- pragma Relative_Deadline (time_span_EXPRESSION);
19157 when Pragma_Relative_Deadline => Relative_Deadline : declare
19158 P : constant Node_Id := Parent (N);
19163 Check_No_Identifiers;
19164 Check_Arg_Count (1);
19166 Arg := Get_Pragma_Arg (Arg1);
19168 -- The expression must be analyzed in the special manner described
19169 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
19171 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
19175 if Nkind (P) = N_Subprogram_Body then
19176 Check_In_Main_Program;
19178 -- Only Task and subprogram cases allowed
19180 elsif Nkind (P) /= N_Task_Definition then
19184 -- Check duplicate pragma before we set the corresponding flag
19186 if Has_Relative_Deadline_Pragma (P) then
19187 Error_Pragma ("duplicate pragma% not allowed");
19190 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
19191 -- Relative_Deadline pragma node cannot be inserted in the Rep
19192 -- Item chain of Ent since it is rewritten by the expander as a
19193 -- procedure call statement that will break the chain.
19195 Set_Has_Relative_Deadline_Pragma (P, True);
19196 end Relative_Deadline;
19198 ------------------------
19199 -- Remote_Access_Type --
19200 ------------------------
19202 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
19204 when Pragma_Remote_Access_Type => Remote_Access_Type : declare
19209 Check_Arg_Count (1);
19210 Check_Optional_Identifier (Arg1, Name_Entity);
19211 Check_Arg_Is_Local_Name (Arg1);
19213 E := Entity (Get_Pragma_Arg (Arg1));
19215 if Nkind (Parent (E)) = N_Formal_Type_Declaration
19216 and then Ekind (E) = E_General_Access_Type
19217 and then Is_Class_Wide_Type (Directly_Designated_Type (E))
19218 and then Scope (Root_Type (Directly_Designated_Type (E)))
19220 and then Is_Valid_Remote_Object_Type
19221 (Root_Type (Directly_Designated_Type (E)))
19223 Set_Is_Remote_Types (E);
19227 ("pragma% applies only to formal access to classwide types",
19230 end Remote_Access_Type;
19232 ---------------------------
19233 -- Remote_Call_Interface --
19234 ---------------------------
19236 -- pragma Remote_Call_Interface [(library_unit_NAME)];
19238 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
19239 Cunit_Node : Node_Id;
19240 Cunit_Ent : Entity_Id;
19244 Check_Ada_83_Warning;
19245 Check_Valid_Library_Unit_Pragma;
19247 if Nkind (N) = N_Null_Statement then
19251 Cunit_Node := Cunit (Current_Sem_Unit);
19252 K := Nkind (Unit (Cunit_Node));
19253 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
19255 if K = N_Package_Declaration
19256 or else K = N_Generic_Package_Declaration
19257 or else K = N_Subprogram_Declaration
19258 or else K = N_Generic_Subprogram_Declaration
19259 or else (K = N_Subprogram_Body
19260 and then Acts_As_Spec (Unit (Cunit_Node)))
19265 "pragma% must apply to package or subprogram declaration");
19268 Set_Is_Remote_Call_Interface (Cunit_Ent);
19269 end Remote_Call_Interface;
19275 -- pragma Remote_Types [(library_unit_NAME)];
19277 when Pragma_Remote_Types => Remote_Types : declare
19278 Cunit_Node : Node_Id;
19279 Cunit_Ent : Entity_Id;
19282 Check_Ada_83_Warning;
19283 Check_Valid_Library_Unit_Pragma;
19285 if Nkind (N) = N_Null_Statement then
19289 Cunit_Node := Cunit (Current_Sem_Unit);
19290 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
19292 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
19293 N_Generic_Package_Declaration)
19296 ("pragma% can only apply to a package declaration");
19299 Set_Is_Remote_Types (Cunit_Ent);
19306 -- pragma Ravenscar;
19308 when Pragma_Ravenscar =>
19310 Check_Arg_Count (0);
19311 Check_Valid_Configuration_Pragma;
19312 Set_Ravenscar_Profile (N);
19314 if Warn_On_Obsolescent_Feature then
19316 ("pragma Ravenscar is an obsolescent feature?j?", N);
19318 ("|use pragma Profile (Ravenscar) instead?j?", N);
19321 -------------------------
19322 -- Restricted_Run_Time --
19323 -------------------------
19325 -- pragma Restricted_Run_Time;
19327 when Pragma_Restricted_Run_Time =>
19329 Check_Arg_Count (0);
19330 Check_Valid_Configuration_Pragma;
19331 Set_Profile_Restrictions
19332 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
19334 if Warn_On_Obsolescent_Feature then
19336 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
19339 ("|use pragma Profile (Restricted) instead?j?", N);
19346 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
19349 -- restriction_IDENTIFIER
19350 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19352 when Pragma_Restrictions =>
19353 Process_Restrictions_Or_Restriction_Warnings
19354 (Warn => Treat_Restrictions_As_Warnings);
19356 --------------------------
19357 -- Restriction_Warnings --
19358 --------------------------
19360 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
19363 -- restriction_IDENTIFIER
19364 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19366 when Pragma_Restriction_Warnings =>
19368 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
19374 -- pragma Reviewable;
19376 when Pragma_Reviewable =>
19377 Check_Ada_83_Warning;
19378 Check_Arg_Count (0);
19380 -- Call dummy debugging function rv. This is done to assist front
19381 -- end debugging. By placing a Reviewable pragma in the source
19382 -- program, a breakpoint on rv catches this place in the source,
19383 -- allowing convenient stepping to the point of interest.
19387 --------------------------
19388 -- Short_Circuit_And_Or --
19389 --------------------------
19391 -- pragma Short_Circuit_And_Or;
19393 when Pragma_Short_Circuit_And_Or =>
19395 Check_Arg_Count (0);
19396 Check_Valid_Configuration_Pragma;
19397 Short_Circuit_And_Or := True;
19399 -------------------
19400 -- Share_Generic --
19401 -------------------
19403 -- pragma Share_Generic (GNAME {, GNAME});
19405 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
19407 when Pragma_Share_Generic =>
19409 Process_Generic_List;
19415 -- pragma Shared (LOCAL_NAME);
19417 when Pragma_Shared =>
19419 Process_Atomic_Shared_Volatile;
19421 --------------------
19422 -- Shared_Passive --
19423 --------------------
19425 -- pragma Shared_Passive [(library_unit_NAME)];
19427 -- Set the flag Is_Shared_Passive of program unit name entity
19429 when Pragma_Shared_Passive => Shared_Passive : declare
19430 Cunit_Node : Node_Id;
19431 Cunit_Ent : Entity_Id;
19434 Check_Ada_83_Warning;
19435 Check_Valid_Library_Unit_Pragma;
19437 if Nkind (N) = N_Null_Statement then
19441 Cunit_Node := Cunit (Current_Sem_Unit);
19442 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
19444 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
19445 N_Generic_Package_Declaration)
19448 ("pragma% can only apply to a package declaration");
19451 Set_Is_Shared_Passive (Cunit_Ent);
19452 end Shared_Passive;
19454 -----------------------
19455 -- Short_Descriptors --
19456 -----------------------
19458 -- pragma Short_Descriptors;
19460 when Pragma_Short_Descriptors =>
19462 Check_Arg_Count (0);
19463 Check_Valid_Configuration_Pragma;
19464 Short_Descriptors := True;
19466 ------------------------------
19467 -- Simple_Storage_Pool_Type --
19468 ------------------------------
19470 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
19472 when Pragma_Simple_Storage_Pool_Type =>
19473 Simple_Storage_Pool_Type : declare
19479 Check_Arg_Count (1);
19480 Check_Arg_Is_Library_Level_Local_Name (Arg1);
19482 Type_Id := Get_Pragma_Arg (Arg1);
19483 Find_Type (Type_Id);
19484 Typ := Entity (Type_Id);
19486 if Typ = Any_Type then
19490 -- We require the pragma to apply to a type declared in a package
19491 -- declaration, but not (immediately) within a package body.
19493 if Ekind (Current_Scope) /= E_Package
19494 or else In_Package_Body (Current_Scope)
19497 ("pragma% can only apply to type declared immediately "
19498 & "within a package declaration");
19501 -- A simple storage pool type must be an immutably limited record
19502 -- or private type. If the pragma is given for a private type,
19503 -- the full type is similarly restricted (which is checked later
19504 -- in Freeze_Entity).
19506 if Is_Record_Type (Typ)
19507 and then not Is_Limited_View (Typ)
19510 ("pragma% can only apply to explicitly limited record type");
19512 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
19514 ("pragma% can only apply to a private type that is limited");
19516 elsif not Is_Record_Type (Typ)
19517 and then not Is_Private_Type (Typ)
19520 ("pragma% can only apply to limited record or private type");
19523 Record_Rep_Item (Typ, N);
19524 end Simple_Storage_Pool_Type;
19526 ----------------------
19527 -- Source_File_Name --
19528 ----------------------
19530 -- There are five forms for this pragma:
19532 -- pragma Source_File_Name (
19533 -- [UNIT_NAME =>] unit_NAME,
19534 -- BODY_FILE_NAME => STRING_LITERAL
19535 -- [, [INDEX =>] INTEGER_LITERAL]);
19537 -- pragma Source_File_Name (
19538 -- [UNIT_NAME =>] unit_NAME,
19539 -- SPEC_FILE_NAME => STRING_LITERAL
19540 -- [, [INDEX =>] INTEGER_LITERAL]);
19542 -- pragma Source_File_Name (
19543 -- BODY_FILE_NAME => STRING_LITERAL
19544 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19545 -- [, CASING => CASING_SPEC]);
19547 -- pragma Source_File_Name (
19548 -- SPEC_FILE_NAME => STRING_LITERAL
19549 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19550 -- [, CASING => CASING_SPEC]);
19552 -- pragma Source_File_Name (
19553 -- SUBUNIT_FILE_NAME => STRING_LITERAL
19554 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19555 -- [, CASING => CASING_SPEC]);
19557 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
19559 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
19560 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
19561 -- only be used when no project file is used, while SFNP can only be
19562 -- used when a project file is used.
19564 -- No processing here. Processing was completed during parsing, since
19565 -- we need to have file names set as early as possible. Units are
19566 -- loaded well before semantic processing starts.
19568 -- The only processing we defer to this point is the check for
19569 -- correct placement.
19571 when Pragma_Source_File_Name =>
19573 Check_Valid_Configuration_Pragma;
19575 ------------------------------
19576 -- Source_File_Name_Project --
19577 ------------------------------
19579 -- See Source_File_Name for syntax
19581 -- No processing here. Processing was completed during parsing, since
19582 -- we need to have file names set as early as possible. Units are
19583 -- loaded well before semantic processing starts.
19585 -- The only processing we defer to this point is the check for
19586 -- correct placement.
19588 when Pragma_Source_File_Name_Project =>
19590 Check_Valid_Configuration_Pragma;
19592 -- Check that a pragma Source_File_Name_Project is used only in a
19593 -- configuration pragmas file.
19595 -- Pragmas Source_File_Name_Project should only be generated by
19596 -- the Project Manager in configuration pragmas files.
19598 -- This is really an ugly test. It seems to depend on some
19599 -- accidental and undocumented property. At the very least it
19600 -- needs to be documented, but it would be better to have a
19601 -- clean way of testing if we are in a configuration file???
19603 if Present (Parent (N)) then
19605 ("pragma% can only appear in a configuration pragmas file");
19608 ----------------------
19609 -- Source_Reference --
19610 ----------------------
19612 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
19614 -- Nothing to do, all processing completed in Par.Prag, since we need
19615 -- the information for possible parser messages that are output.
19617 when Pragma_Source_Reference =>
19624 -- pragma SPARK_Mode [(On | Off)];
19626 when Pragma_SPARK_Mode => Do_SPARK_Mode : declare
19627 Body_Id : Entity_Id;
19630 Mode_Id : SPARK_Mode_Type;
19631 Spec_Id : Entity_Id;
19634 procedure Check_Pragma_Conformance
19635 (Context_Pragma : Node_Id;
19636 Entity_Pragma : Node_Id;
19637 Entity : Entity_Id);
19638 -- If Context_Pragma is not Empty, verify that the new pragma N
19639 -- is compatible with the pragma Context_Pragma that was inherited
19640 -- from the context:
19641 -- . if Context_Pragma is ON, then the new mode can be anything
19642 -- . if Context_Pragma is OFF, then the only allowed new mode is
19645 -- If Entity is not Empty, verify that the new pragma N is
19646 -- compatible with Entity_Pragma, the SPARK_Mode previously set
19647 -- for Entity (which may be Empty):
19648 -- . if Entity_Pragma is ON, then the new mode can be anything
19649 -- . if Entity_Pragma is OFF, then the only allowed new mode is
19651 -- . if Entity_Pragma is Empty, we always issue an error, as this
19652 -- corresponds to a case where a previous section of Entity
19653 -- had no SPARK_Mode set.
19655 procedure Check_Library_Level_Entity (E : Entity_Id);
19656 -- Verify that pragma is applied to library-level entity E
19658 ------------------------------
19659 -- Check_Pragma_Conformance --
19660 ------------------------------
19662 procedure Check_Pragma_Conformance
19663 (Context_Pragma : Node_Id;
19664 Entity_Pragma : Node_Id;
19665 Entity : Entity_Id)
19668 if Present (Context_Pragma) then
19669 pragma Assert (Nkind (Context_Pragma) = N_Pragma);
19671 -- New mode less restrictive than the established mode
19673 if Get_SPARK_Mode_From_Pragma (Context_Pragma) = Off
19674 and then Mode_Id = On
19677 ("cannot change SPARK_Mode from Off to On", Arg1);
19678 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
19679 Error_Msg_N ("\SPARK_Mode was set to Off#", Arg1);
19684 if Present (Entity) then
19685 if Present (Entity_Pragma) then
19686 if Get_SPARK_Mode_From_Pragma (Entity_Pragma) = Off
19687 and then Mode_Id = On
19689 Error_Msg_N ("incorrect use of SPARK_Mode", Arg1);
19690 Error_Msg_Sloc := Sloc (Entity_Pragma);
19692 ("\value Off was set for SPARK_Mode on&#",
19698 Error_Msg_N ("incorrect use of SPARK_Mode", Arg1);
19699 Error_Msg_Sloc := Sloc (Entity);
19701 ("\no value was set for SPARK_Mode on&#",
19706 end Check_Pragma_Conformance;
19708 --------------------------------
19709 -- Check_Library_Level_Entity --
19710 --------------------------------
19712 procedure Check_Library_Level_Entity (E : Entity_Id) is
19713 MsgF : String := "incorrect placement of pragma%";
19716 if not Is_Library_Level_Entity (E) then
19717 Error_Msg_Name_1 := Pname;
19719 Error_Msg_N (MsgF, N);
19721 if Ekind_In (E, E_Generic_Package,
19726 ("\& is not a library-level package", N, E);
19729 ("\& is not a library-level subprogram", N, E);
19734 end Check_Library_Level_Entity;
19736 -- Start of processing for Do_SPARK_Mode
19740 Check_No_Identifiers;
19741 Check_At_Most_N_Arguments (1);
19743 -- Check the legality of the mode (no argument = ON)
19745 if Arg_Count = 1 then
19746 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
19747 Mode := Chars (Get_Pragma_Arg (Arg1));
19752 Mode_Id := Get_SPARK_Mode_Type (Mode);
19753 Context := Parent (N);
19755 -- Packages and subprograms declared in a generic unit cannot be
19756 -- subject to the pragma.
19758 if Inside_A_Generic then
19759 Error_Pragma ("incorrect placement of pragma% in a generic");
19761 -- The pragma appears in a configuration pragmas file
19763 elsif No (Context) then
19764 Check_Valid_Configuration_Pragma;
19766 if Present (SPARK_Mode_Pragma) then
19767 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
19768 Error_Msg_N ("pragma% duplicates pragma declared#", N);
19772 SPARK_Mode_Pragma := N;
19773 SPARK_Mode := Mode_Id;
19775 -- When the pragma is placed before the declaration of a unit, it
19776 -- configures the whole unit.
19778 elsif Nkind (Context) = N_Compilation_Unit then
19779 Check_Valid_Configuration_Pragma;
19781 if Nkind (Unit (Context)) in N_Generic_Declaration
19782 or else (Present (Library_Unit (Context))
19783 and then Nkind (Unit (Library_Unit (Context))) in
19784 N_Generic_Declaration)
19786 Error_Pragma ("incorrect placement of pragma% in a generic");
19789 SPARK_Mode_Pragma := N;
19790 SPARK_Mode := Mode_Id;
19792 -- The pragma applies to a [library unit] subprogram or package
19795 -- Verify the placement of the pragma with respect to package
19796 -- or subprogram declarations and detect duplicates.
19799 while Present (Stmt) loop
19801 -- Skip prior pragmas, but check for duplicates
19803 if Nkind (Stmt) = N_Pragma then
19804 if Pragma_Name (Stmt) = Pname then
19805 Error_Msg_Name_1 := Pname;
19806 Error_Msg_Sloc := Sloc (Stmt);
19807 Error_Msg_N ("pragma% duplicates pragma declared#", N);
19811 -- Skip internally generated code
19813 elsif not Comes_From_Source (Stmt) then
19816 elsif Nkind (Stmt) in N_Generic_Declaration then
19818 ("incorrect placement of pragma% on a generic");
19820 -- The pragma applies to a package declaration
19822 elsif Nkind (Stmt) = N_Package_Declaration then
19823 Spec_Id := Defining_Entity (Stmt);
19824 Check_Library_Level_Entity (Spec_Id);
19825 Check_Pragma_Conformance
19826 (Context_Pragma => SPARK_Pragma (Spec_Id),
19827 Entity_Pragma => Empty,
19830 Set_SPARK_Pragma (Spec_Id, N);
19831 Set_SPARK_Pragma_Inherited (Spec_Id, False);
19832 Set_SPARK_Aux_Pragma (Spec_Id, N);
19833 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True);
19836 -- The pragma applies to a subprogram declaration
19838 elsif Nkind (Stmt) = N_Subprogram_Declaration then
19839 Spec_Id := Defining_Entity (Stmt);
19840 Check_Library_Level_Entity (Spec_Id);
19841 Check_Pragma_Conformance
19842 (Context_Pragma => SPARK_Pragma (Spec_Id),
19843 Entity_Pragma => Empty,
19846 Set_SPARK_Pragma (Spec_Id, N);
19847 Set_SPARK_Pragma_Inherited (Spec_Id, False);
19850 -- The pragma does not apply to a legal construct, issue an
19851 -- error and stop the analysis.
19858 Stmt := Prev (Stmt);
19861 -- Handle all cases where the pragma is actually an aspect and
19862 -- applies to a library-level package spec, body or subprogram.
19864 -- function F ... with SPARK_Mode => ...;
19865 -- package P with SPARK_Mode => ...;
19866 -- package body P with SPARK_Mode => ... is
19868 -- The following circuitry simply prepares the proper context
19869 -- for the general pragma processing mechanism below.
19871 if Nkind (Context) = N_Compilation_Unit_Aux then
19872 Context := Unit (Parent (Context));
19874 if Nkind_In (Context, N_Package_Declaration,
19875 N_Subprogram_Declaration)
19877 Context := Specification (Context);
19881 -- The pragma is at the top level of a package spec
19884 -- pragma SPARK_Mode;
19891 -- pragma SPARK_Mode;
19893 if Nkind (Context) = N_Package_Specification then
19894 Spec_Id := Defining_Entity (Context);
19896 -- Pragma applies to private part
19898 if List_Containing (N) = Private_Declarations (Context) then
19899 Check_Library_Level_Entity (Spec_Id);
19900 Check_Pragma_Conformance
19901 (Context_Pragma => Empty,
19902 Entity_Pragma => SPARK_Pragma (Spec_Id),
19903 Entity => Spec_Id);
19904 SPARK_Mode_Pragma := N;
19905 SPARK_Mode := Mode_Id;
19907 Set_SPARK_Aux_Pragma (Spec_Id, N);
19908 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False);
19910 -- Pragma applies to public part
19913 Check_Library_Level_Entity (Spec_Id);
19914 Check_Pragma_Conformance
19915 (Context_Pragma => SPARK_Pragma (Spec_Id),
19916 Entity_Pragma => Empty,
19918 SPARK_Mode_Pragma := N;
19919 SPARK_Mode := Mode_Id;
19921 Set_SPARK_Pragma (Spec_Id, N);
19922 Set_SPARK_Pragma_Inherited (Spec_Id, False);
19923 Set_SPARK_Aux_Pragma (Spec_Id, N);
19924 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True);
19927 -- The pragma appears as an aspect on a subprogram.
19929 -- function F ... with SPARK_Mode => ...;
19931 elsif Nkind_In (Context, N_Function_Specification,
19932 N_Procedure_Specification)
19934 Spec_Id := Defining_Entity (Context);
19935 Check_Library_Level_Entity (Spec_Id);
19936 Check_Pragma_Conformance
19937 (Context_Pragma => SPARK_Pragma (Spec_Id),
19938 Entity_Pragma => Empty,
19940 Set_SPARK_Pragma (Spec_Id, N);
19941 Set_SPARK_Pragma_Inherited (Spec_Id, False);
19943 -- Pragma is immediately within a package body
19945 -- package body P is
19946 -- pragma SPARK_Mode;
19948 elsif Nkind (Context) = N_Package_Body then
19949 Spec_Id := Corresponding_Spec (Context);
19950 Body_Id := Defining_Entity (Context);
19951 Check_Library_Level_Entity (Body_Id);
19952 Check_Pragma_Conformance
19953 (Context_Pragma => SPARK_Pragma (Body_Id),
19954 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id),
19955 Entity => Spec_Id);
19956 SPARK_Mode_Pragma := N;
19957 SPARK_Mode := Mode_Id;
19959 Set_SPARK_Pragma (Body_Id, N);
19960 Set_SPARK_Pragma_Inherited (Body_Id, False);
19961 Set_SPARK_Aux_Pragma (Body_Id, N);
19962 Set_SPARK_Aux_Pragma_Inherited (Body_Id, True);
19964 -- Pragma is immediately within a subprogram body
19966 -- function F ... is
19967 -- pragma SPARK_Mode;
19969 elsif Nkind (Context) = N_Subprogram_Body then
19970 Spec_Id := Corresponding_Spec (Context);
19971 Context := Specification (Context);
19972 Body_Id := Defining_Entity (Context);
19973 Check_Library_Level_Entity (Body_Id);
19975 if Present (Spec_Id) then
19976 Check_Pragma_Conformance
19977 (Context_Pragma => SPARK_Pragma (Body_Id),
19978 Entity_Pragma => SPARK_Pragma (Spec_Id),
19979 Entity => Spec_Id);
19981 Check_Pragma_Conformance
19982 (Context_Pragma => SPARK_Pragma (Body_Id),
19983 Entity_Pragma => Empty,
19987 SPARK_Mode_Pragma := N;
19988 SPARK_Mode := Mode_Id;
19990 Set_SPARK_Pragma (Body_Id, N);
19991 Set_SPARK_Pragma_Inherited (Body_Id, False);
19993 -- The pragma applies to the statements of a package body
19995 -- package body P is
19997 -- pragma SPARK_Mode;
19999 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
20000 and then Nkind (Parent (Context)) = N_Package_Body
20002 Context := Parent (Context);
20003 Spec_Id := Corresponding_Spec (Context);
20004 Body_Id := Defining_Entity (Context);
20005 Check_Library_Level_Entity (Body_Id);
20006 Check_Pragma_Conformance
20007 (Context_Pragma => Empty,
20008 Entity_Pragma => SPARK_Pragma (Body_Id),
20009 Entity => Body_Id);
20010 SPARK_Mode_Pragma := N;
20011 SPARK_Mode := Mode_Id;
20013 Set_SPARK_Aux_Pragma (Body_Id, N);
20014 Set_SPARK_Aux_Pragma_Inherited (Body_Id, False);
20016 -- The pragma does not apply to a legal construct, issue error
20024 --------------------------------
20025 -- Static_Elaboration_Desired --
20026 --------------------------------
20028 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
20030 when Pragma_Static_Elaboration_Desired =>
20032 Check_At_Most_N_Arguments (1);
20034 if Is_Compilation_Unit (Current_Scope)
20035 and then Ekind (Current_Scope) = E_Package
20037 Set_Static_Elaboration_Desired (Current_Scope, True);
20039 Error_Pragma ("pragma% must apply to a library-level package");
20046 -- pragma Storage_Size (EXPRESSION);
20048 when Pragma_Storage_Size => Storage_Size : declare
20049 P : constant Node_Id := Parent (N);
20053 Check_No_Identifiers;
20054 Check_Arg_Count (1);
20056 -- The expression must be analyzed in the special manner described
20057 -- in "Handling of Default Expressions" in sem.ads.
20059 Arg := Get_Pragma_Arg (Arg1);
20060 Preanalyze_Spec_Expression (Arg, Any_Integer);
20062 if not Is_Static_Expression (Arg) then
20063 Check_Restriction (Static_Storage_Size, Arg);
20066 if Nkind (P) /= N_Task_Definition then
20071 if Has_Storage_Size_Pragma (P) then
20072 Error_Pragma ("duplicate pragma% not allowed");
20074 Set_Has_Storage_Size_Pragma (P, True);
20077 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
20085 -- pragma Storage_Unit (NUMERIC_LITERAL);
20087 -- Only permitted argument is System'Storage_Unit value
20089 when Pragma_Storage_Unit =>
20090 Check_No_Identifiers;
20091 Check_Arg_Count (1);
20092 Check_Arg_Is_Integer_Literal (Arg1);
20094 if Intval (Get_Pragma_Arg (Arg1)) /=
20095 UI_From_Int (Ttypes.System_Storage_Unit)
20097 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
20099 ("the only allowed argument for pragma% is ^", Arg1);
20102 --------------------
20103 -- Stream_Convert --
20104 --------------------
20106 -- pragma Stream_Convert (
20107 -- [Entity =>] type_LOCAL_NAME,
20108 -- [Read =>] function_NAME,
20109 -- [Write =>] function NAME);
20111 when Pragma_Stream_Convert => Stream_Convert : declare
20113 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
20114 -- Check that the given argument is the name of a local function
20115 -- of one argument that is not overloaded earlier in the current
20116 -- local scope. A check is also made that the argument is a
20117 -- function with one parameter.
20119 --------------------------------------
20120 -- Check_OK_Stream_Convert_Function --
20121 --------------------------------------
20123 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
20127 Check_Arg_Is_Local_Name (Arg);
20128 Ent := Entity (Get_Pragma_Arg (Arg));
20130 if Has_Homonym (Ent) then
20132 ("argument for pragma% may not be overloaded", Arg);
20135 if Ekind (Ent) /= E_Function
20136 or else No (First_Formal (Ent))
20137 or else Present (Next_Formal (First_Formal (Ent)))
20140 ("argument for pragma% must be function of one argument",
20143 end Check_OK_Stream_Convert_Function;
20145 -- Start of processing for Stream_Convert
20149 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
20150 Check_Arg_Count (3);
20151 Check_Optional_Identifier (Arg1, Name_Entity);
20152 Check_Optional_Identifier (Arg2, Name_Read);
20153 Check_Optional_Identifier (Arg3, Name_Write);
20154 Check_Arg_Is_Local_Name (Arg1);
20155 Check_OK_Stream_Convert_Function (Arg2);
20156 Check_OK_Stream_Convert_Function (Arg3);
20159 Typ : constant Entity_Id :=
20160 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
20161 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
20162 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
20165 Check_First_Subtype (Arg1);
20167 -- Check for too early or too late. Note that we don't enforce
20168 -- the rule about primitive operations in this case, since, as
20169 -- is the case for explicit stream attributes themselves, these
20170 -- restrictions are not appropriate. Note that the chaining of
20171 -- the pragma by Rep_Item_Too_Late is actually the critical
20172 -- processing done for this pragma.
20174 if Rep_Item_Too_Early (Typ, N)
20176 Rep_Item_Too_Late (Typ, N, FOnly => True)
20181 -- Return if previous error
20183 if Etype (Typ) = Any_Type
20185 Etype (Read) = Any_Type
20187 Etype (Write) = Any_Type
20194 if Underlying_Type (Etype (Read)) /= Typ then
20196 ("incorrect return type for function&", Arg2);
20199 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
20201 ("incorrect parameter type for function&", Arg3);
20204 if Underlying_Type (Etype (First_Formal (Read))) /=
20205 Underlying_Type (Etype (Write))
20208 ("result type of & does not match Read parameter type",
20212 end Stream_Convert;
20218 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
20220 -- This is processed by the parser since some of the style checks
20221 -- take place during source scanning and parsing. This means that
20222 -- we don't need to issue error messages here.
20224 when Pragma_Style_Checks => Style_Checks : declare
20225 A : constant Node_Id := Get_Pragma_Arg (Arg1);
20231 Check_No_Identifiers;
20233 -- Two argument form
20235 if Arg_Count = 2 then
20236 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
20243 E_Id := Get_Pragma_Arg (Arg2);
20246 if not Is_Entity_Name (E_Id) then
20248 ("second argument of pragma% must be entity name",
20252 E := Entity (E_Id);
20254 if not Ignore_Style_Checks_Pragmas then
20259 Set_Suppress_Style_Checks
20260 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off);
20261 exit when No (Homonym (E));
20268 -- One argument form
20271 Check_Arg_Count (1);
20273 if Nkind (A) = N_String_Literal then
20277 Slen : constant Natural := Natural (String_Length (S));
20278 Options : String (1 .. Slen);
20284 C := Get_String_Char (S, Int (J));
20285 exit when not In_Character_Range (C);
20286 Options (J) := Get_Character (C);
20288 -- If at end of string, set options. As per discussion
20289 -- above, no need to check for errors, since we issued
20290 -- them in the parser.
20293 if not Ignore_Style_Checks_Pragmas then
20294 Set_Style_Check_Options (Options);
20304 elsif Nkind (A) = N_Identifier then
20305 if Chars (A) = Name_All_Checks then
20306 if not Ignore_Style_Checks_Pragmas then
20308 Set_GNAT_Style_Check_Options;
20310 Set_Default_Style_Check_Options;
20314 elsif Chars (A) = Name_On then
20315 if not Ignore_Style_Checks_Pragmas then
20316 Style_Check := True;
20319 elsif Chars (A) = Name_Off then
20320 if not Ignore_Style_Checks_Pragmas then
20321 Style_Check := False;
20332 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
20334 when Pragma_Subtitle =>
20336 Check_Arg_Count (1);
20337 Check_Optional_Identifier (Arg1, Name_Subtitle);
20338 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
20345 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
20347 when Pragma_Suppress =>
20348 Process_Suppress_Unsuppress (True);
20354 -- pragma Suppress_All;
20356 -- The only check made here is that the pragma has no arguments.
20357 -- There are no placement rules, and the processing required (setting
20358 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
20359 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
20360 -- then creates and inserts a pragma Suppress (All_Checks).
20362 when Pragma_Suppress_All =>
20364 Check_Arg_Count (0);
20366 -------------------------
20367 -- Suppress_Debug_Info --
20368 -------------------------
20370 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
20372 when Pragma_Suppress_Debug_Info =>
20374 Check_Arg_Count (1);
20375 Check_Optional_Identifier (Arg1, Name_Entity);
20376 Check_Arg_Is_Local_Name (Arg1);
20377 Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1)));
20379 ----------------------------------
20380 -- Suppress_Exception_Locations --
20381 ----------------------------------
20383 -- pragma Suppress_Exception_Locations;
20385 when Pragma_Suppress_Exception_Locations =>
20387 Check_Arg_Count (0);
20388 Check_Valid_Configuration_Pragma;
20389 Exception_Locations_Suppressed := True;
20391 -----------------------------
20392 -- Suppress_Initialization --
20393 -----------------------------
20395 -- pragma Suppress_Initialization ([Entity =>] type_Name);
20397 when Pragma_Suppress_Initialization => Suppress_Init : declare
20403 Check_Arg_Count (1);
20404 Check_Optional_Identifier (Arg1, Name_Entity);
20405 Check_Arg_Is_Local_Name (Arg1);
20407 E_Id := Get_Pragma_Arg (Arg1);
20409 if Etype (E_Id) = Any_Type then
20413 E := Entity (E_Id);
20415 if not Is_Type (E) then
20416 Error_Pragma_Arg ("pragma% requires type or subtype", Arg1);
20419 if Rep_Item_Too_Early (E, N)
20421 Rep_Item_Too_Late (E, N, FOnly => True)
20426 -- For incomplete/private type, set flag on full view
20428 if Is_Incomplete_Or_Private_Type (E) then
20429 if No (Full_View (Base_Type (E))) then
20431 ("argument of pragma% cannot be an incomplete type", Arg1);
20433 Set_Suppress_Initialization (Full_View (Base_Type (E)));
20436 -- For first subtype, set flag on base type
20438 elsif Is_First_Subtype (E) then
20439 Set_Suppress_Initialization (Base_Type (E));
20441 -- For other than first subtype, set flag on subtype itself
20444 Set_Suppress_Initialization (E);
20452 -- pragma System_Name (DIRECT_NAME);
20454 -- Syntax check: one argument, which must be the identifier GNAT or
20455 -- the identifier GCC, no other identifiers are acceptable.
20457 when Pragma_System_Name =>
20459 Check_No_Identifiers;
20460 Check_Arg_Count (1);
20461 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
20463 -----------------------------
20464 -- Task_Dispatching_Policy --
20465 -----------------------------
20467 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
20469 when Pragma_Task_Dispatching_Policy => declare
20473 Check_Ada_83_Warning;
20474 Check_Arg_Count (1);
20475 Check_No_Identifiers;
20476 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
20477 Check_Valid_Configuration_Pragma;
20478 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
20479 DP := Fold_Upper (Name_Buffer (1));
20481 if Task_Dispatching_Policy /= ' '
20482 and then Task_Dispatching_Policy /= DP
20484 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
20486 ("task dispatching policy incompatible with policy#");
20488 -- Set new policy, but always preserve System_Location since we
20489 -- like the error message with the run time name.
20492 Task_Dispatching_Policy := DP;
20494 if Task_Dispatching_Policy_Sloc /= System_Location then
20495 Task_Dispatching_Policy_Sloc := Loc;
20504 -- pragma Task_Info (EXPRESSION);
20506 when Pragma_Task_Info => Task_Info : declare
20507 P : constant Node_Id := Parent (N);
20513 if Nkind (P) /= N_Task_Definition then
20514 Error_Pragma ("pragma% must appear in task definition");
20517 Check_No_Identifiers;
20518 Check_Arg_Count (1);
20520 Analyze_And_Resolve
20521 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
20523 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
20527 Ent := Defining_Identifier (Parent (P));
20529 -- Check duplicate pragma before we chain the pragma in the Rep
20530 -- Item chain of Ent.
20533 (Ent, Name_Task_Info, Check_Parents => False)
20535 Error_Pragma ("duplicate pragma% not allowed");
20538 Record_Rep_Item (Ent, N);
20545 -- pragma Task_Name (string_EXPRESSION);
20547 when Pragma_Task_Name => Task_Name : declare
20548 P : constant Node_Id := Parent (N);
20553 Check_No_Identifiers;
20554 Check_Arg_Count (1);
20556 Arg := Get_Pragma_Arg (Arg1);
20558 -- The expression is used in the call to Create_Task, and must be
20559 -- expanded there, not in the context of the current spec. It must
20560 -- however be analyzed to capture global references, in case it
20561 -- appears in a generic context.
20563 Preanalyze_And_Resolve (Arg, Standard_String);
20565 if Nkind (P) /= N_Task_Definition then
20569 Ent := Defining_Identifier (Parent (P));
20571 -- Check duplicate pragma before we chain the pragma in the Rep
20572 -- Item chain of Ent.
20575 (Ent, Name_Task_Name, Check_Parents => False)
20577 Error_Pragma ("duplicate pragma% not allowed");
20580 Record_Rep_Item (Ent, N);
20587 -- pragma Task_Storage (
20588 -- [Task_Type =>] LOCAL_NAME,
20589 -- [Top_Guard =>] static_integer_EXPRESSION);
20591 when Pragma_Task_Storage => Task_Storage : declare
20592 Args : Args_List (1 .. 2);
20593 Names : constant Name_List (1 .. 2) := (
20597 Task_Type : Node_Id renames Args (1);
20598 Top_Guard : Node_Id renames Args (2);
20604 Gather_Associations (Names, Args);
20606 if No (Task_Type) then
20608 ("missing task_type argument for pragma%");
20611 Check_Arg_Is_Local_Name (Task_Type);
20613 Ent := Entity (Task_Type);
20615 if not Is_Task_Type (Ent) then
20617 ("argument for pragma% must be task type", Task_Type);
20620 if No (Top_Guard) then
20622 ("pragma% takes two arguments", Task_Type);
20624 Check_Arg_Is_Static_Expression (Top_Guard, Any_Integer);
20627 Check_First_Subtype (Task_Type);
20629 if Rep_Item_Too_Late (Ent, N) then
20638 -- pragma Test_Case
20639 -- ([Name =>] Static_String_EXPRESSION
20640 -- ,[Mode =>] MODE_TYPE
20641 -- [, Requires => Boolean_EXPRESSION]
20642 -- [, Ensures => Boolean_EXPRESSION]);
20644 -- MODE_TYPE ::= Nominal | Robustness
20646 when Pragma_Test_Case =>
20650 --------------------------
20651 -- Thread_Local_Storage --
20652 --------------------------
20654 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
20656 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
20662 Check_Arg_Count (1);
20663 Check_Optional_Identifier (Arg1, Name_Entity);
20664 Check_Arg_Is_Library_Level_Local_Name (Arg1);
20666 Id := Get_Pragma_Arg (Arg1);
20669 if not Is_Entity_Name (Id)
20670 or else Ekind (Entity (Id)) /= E_Variable
20672 Error_Pragma_Arg ("local variable name required", Arg1);
20677 if Rep_Item_Too_Early (E, N)
20678 or else Rep_Item_Too_Late (E, N)
20683 Set_Has_Pragma_Thread_Local_Storage (E);
20684 Set_Has_Gigi_Rep_Item (E);
20685 end Thread_Local_Storage;
20691 -- pragma Time_Slice (static_duration_EXPRESSION);
20693 when Pragma_Time_Slice => Time_Slice : declare
20699 Check_Arg_Count (1);
20700 Check_No_Identifiers;
20701 Check_In_Main_Program;
20702 Check_Arg_Is_Static_Expression (Arg1, Standard_Duration);
20704 if not Error_Posted (Arg1) then
20706 while Present (Nod) loop
20707 if Nkind (Nod) = N_Pragma
20708 and then Pragma_Name (Nod) = Name_Time_Slice
20710 Error_Msg_Name_1 := Pname;
20711 Error_Msg_N ("duplicate pragma% not permitted", Nod);
20718 -- Process only if in main unit
20720 if Get_Source_Unit (Loc) = Main_Unit then
20721 Opt.Time_Slice_Set := True;
20722 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
20724 if Val <= Ureal_0 then
20725 Opt.Time_Slice_Value := 0;
20727 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
20728 Opt.Time_Slice_Value := 1_000_000_000;
20731 Opt.Time_Slice_Value :=
20732 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
20741 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
20743 -- TITLING_OPTION ::=
20744 -- [Title =>] STRING_LITERAL
20745 -- | [Subtitle =>] STRING_LITERAL
20747 when Pragma_Title => Title : declare
20748 Args : Args_List (1 .. 2);
20749 Names : constant Name_List (1 .. 2) := (
20755 Gather_Associations (Names, Args);
20758 for J in 1 .. 2 loop
20759 if Present (Args (J)) then
20760 Check_Arg_Is_Static_Expression (Args (J), Standard_String);
20765 ----------------------------
20766 -- Type_Invariant[_Class] --
20767 ----------------------------
20769 -- pragma Type_Invariant[_Class]
20770 -- ([Entity =>] type_LOCAL_NAME,
20771 -- [Check =>] EXPRESSION);
20773 when Pragma_Type_Invariant |
20774 Pragma_Type_Invariant_Class =>
20775 Type_Invariant : declare
20776 I_Pragma : Node_Id;
20779 Check_Arg_Count (2);
20781 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
20782 -- setting Class_Present for the Type_Invariant_Class case.
20784 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class);
20785 I_Pragma := New_Copy (N);
20786 Set_Pragma_Identifier
20787 (I_Pragma, Make_Identifier (Loc, Name_Invariant));
20788 Rewrite (N, I_Pragma);
20789 Set_Analyzed (N, False);
20791 end Type_Invariant;
20793 ---------------------
20794 -- Unchecked_Union --
20795 ---------------------
20797 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
20799 when Pragma_Unchecked_Union => Unchecked_Union : declare
20800 Assoc : constant Node_Id := Arg1;
20801 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
20811 Check_No_Identifiers;
20812 Check_Arg_Count (1);
20813 Check_Arg_Is_Local_Name (Arg1);
20815 Find_Type (Type_Id);
20817 Typ := Entity (Type_Id);
20820 or else Rep_Item_Too_Early (Typ, N)
20824 Typ := Underlying_Type (Typ);
20827 if Rep_Item_Too_Late (Typ, N) then
20831 Check_First_Subtype (Arg1);
20833 -- Note remaining cases are references to a type in the current
20834 -- declarative part. If we find an error, we post the error on
20835 -- the relevant type declaration at an appropriate point.
20837 if not Is_Record_Type (Typ) then
20838 Error_Msg_N ("unchecked union must be record type", Typ);
20841 elsif Is_Tagged_Type (Typ) then
20842 Error_Msg_N ("unchecked union must not be tagged", Typ);
20845 elsif not Has_Discriminants (Typ) then
20847 ("unchecked union must have one discriminant", Typ);
20850 -- Note: in previous versions of GNAT we used to check for limited
20851 -- types and give an error, but in fact the standard does allow
20852 -- Unchecked_Union on limited types, so this check was removed.
20854 -- Similarly, GNAT used to require that all discriminants have
20855 -- default values, but this is not mandated by the RM.
20857 -- Proceed with basic error checks completed
20860 Tdef := Type_Definition (Declaration_Node (Typ));
20861 Clist := Component_List (Tdef);
20863 -- Check presence of component list and variant part
20865 if No (Clist) or else No (Variant_Part (Clist)) then
20867 ("unchecked union must have variant part", Tdef);
20871 -- Check components
20873 Comp := First (Component_Items (Clist));
20874 while Present (Comp) loop
20875 Check_Component (Comp, Typ);
20879 -- Check variant part
20881 Vpart := Variant_Part (Clist);
20883 Variant := First (Variants (Vpart));
20884 while Present (Variant) loop
20885 Check_Variant (Variant, Typ);
20890 Set_Is_Unchecked_Union (Typ);
20891 Set_Convention (Typ, Convention_C);
20892 Set_Has_Unchecked_Union (Base_Type (Typ));
20893 Set_Is_Unchecked_Union (Base_Type (Typ));
20894 end Unchecked_Union;
20896 ------------------------
20897 -- Unimplemented_Unit --
20898 ------------------------
20900 -- pragma Unimplemented_Unit;
20902 -- Note: this only gives an error if we are generating code, or if
20903 -- we are in a generic library unit (where the pragma appears in the
20904 -- body, not in the spec).
20906 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
20907 Cunitent : constant Entity_Id :=
20908 Cunit_Entity (Get_Source_Unit (Loc));
20909 Ent_Kind : constant Entity_Kind :=
20914 Check_Arg_Count (0);
20916 if Operating_Mode = Generate_Code
20917 or else Ent_Kind = E_Generic_Function
20918 or else Ent_Kind = E_Generic_Procedure
20919 or else Ent_Kind = E_Generic_Package
20921 Get_Name_String (Chars (Cunitent));
20922 Set_Casing (Mixed_Case);
20923 Write_Str (Name_Buffer (1 .. Name_Len));
20924 Write_Str (" is not supported in this configuration");
20926 raise Unrecoverable_Error;
20928 end Unimplemented_Unit;
20930 ------------------------
20931 -- Universal_Aliasing --
20932 ------------------------
20934 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
20936 when Pragma_Universal_Aliasing => Universal_Alias : declare
20941 Check_Arg_Count (1);
20942 Check_Optional_Identifier (Arg2, Name_Entity);
20943 Check_Arg_Is_Local_Name (Arg1);
20944 E_Id := Entity (Get_Pragma_Arg (Arg1));
20946 if E_Id = Any_Type then
20948 elsif No (E_Id) or else not Is_Type (E_Id) then
20949 Error_Pragma_Arg ("pragma% requires type", Arg1);
20952 Set_Universal_Aliasing (Implementation_Base_Type (E_Id));
20953 Record_Rep_Item (E_Id, N);
20954 end Universal_Alias;
20956 --------------------
20957 -- Universal_Data --
20958 --------------------
20960 -- pragma Universal_Data [(library_unit_NAME)];
20962 when Pragma_Universal_Data =>
20965 -- If this is a configuration pragma, then set the universal
20966 -- addressing option, otherwise confirm that the pragma satisfies
20967 -- the requirements of library unit pragma placement and leave it
20968 -- to the GNAAMP back end to detect the pragma (avoids transitive
20969 -- setting of the option due to withed units).
20971 if Is_Configuration_Pragma then
20972 Universal_Addressing_On_AAMP := True;
20974 Check_Valid_Library_Unit_Pragma;
20977 if not AAMP_On_Target then
20978 Error_Pragma ("??pragma% ignored (applies only to AAMP)");
20985 -- pragma Unmodified (local_Name {, local_Name});
20987 when Pragma_Unmodified => Unmodified : declare
20988 Arg_Node : Node_Id;
20989 Arg_Expr : Node_Id;
20990 Arg_Ent : Entity_Id;
20994 Check_At_Least_N_Arguments (1);
20996 -- Loop through arguments
20999 while Present (Arg_Node) loop
21000 Check_No_Identifier (Arg_Node);
21002 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
21003 -- in fact generate reference, so that the entity will have a
21004 -- reference, which will inhibit any warnings about it not
21005 -- being referenced, and also properly show up in the ali file
21006 -- as a reference. But this reference is recorded before the
21007 -- Has_Pragma_Unreferenced flag is set, so that no warning is
21008 -- generated for this reference.
21010 Check_Arg_Is_Local_Name (Arg_Node);
21011 Arg_Expr := Get_Pragma_Arg (Arg_Node);
21013 if Is_Entity_Name (Arg_Expr) then
21014 Arg_Ent := Entity (Arg_Expr);
21016 if not Is_Assignable (Arg_Ent) then
21018 ("pragma% can only be applied to a variable",
21021 Set_Has_Pragma_Unmodified (Arg_Ent);
21033 -- pragma Unreferenced (local_Name {, local_Name});
21035 -- or when used in a context clause:
21037 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
21039 when Pragma_Unreferenced => Unreferenced : declare
21040 Arg_Node : Node_Id;
21041 Arg_Expr : Node_Id;
21042 Arg_Ent : Entity_Id;
21047 Check_At_Least_N_Arguments (1);
21049 -- Check case of appearing within context clause
21051 if Is_In_Context_Clause then
21053 -- The arguments must all be units mentioned in a with clause
21054 -- in the same context clause. Note we already checked (in
21055 -- Par.Prag) that the arguments are either identifiers or
21056 -- selected components.
21059 while Present (Arg_Node) loop
21060 Citem := First (List_Containing (N));
21061 while Citem /= N loop
21062 if Nkind (Citem) = N_With_Clause
21064 Same_Name (Name (Citem), Get_Pragma_Arg (Arg_Node))
21066 Set_Has_Pragma_Unreferenced
21069 (Library_Unit (Citem))));
21071 (Get_Pragma_Arg (Arg_Node), Name (Citem));
21080 ("argument of pragma% is not withed unit", Arg_Node);
21086 -- Case of not in list of context items
21090 while Present (Arg_Node) loop
21091 Check_No_Identifier (Arg_Node);
21093 -- Note: the analyze call done by Check_Arg_Is_Local_Name
21094 -- will in fact generate reference, so that the entity will
21095 -- have a reference, which will inhibit any warnings about
21096 -- it not being referenced, and also properly show up in the
21097 -- ali file as a reference. But this reference is recorded
21098 -- before the Has_Pragma_Unreferenced flag is set, so that
21099 -- no warning is generated for this reference.
21101 Check_Arg_Is_Local_Name (Arg_Node);
21102 Arg_Expr := Get_Pragma_Arg (Arg_Node);
21104 if Is_Entity_Name (Arg_Expr) then
21105 Arg_Ent := Entity (Arg_Expr);
21107 -- If the entity is overloaded, the pragma applies to the
21108 -- most recent overloading, as documented. In this case,
21109 -- name resolution does not generate a reference, so it
21110 -- must be done here explicitly.
21112 if Is_Overloaded (Arg_Expr) then
21113 Generate_Reference (Arg_Ent, N);
21116 Set_Has_Pragma_Unreferenced (Arg_Ent);
21124 --------------------------
21125 -- Unreferenced_Objects --
21126 --------------------------
21128 -- pragma Unreferenced_Objects (local_Name {, local_Name});
21130 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
21131 Arg_Node : Node_Id;
21132 Arg_Expr : Node_Id;
21136 Check_At_Least_N_Arguments (1);
21139 while Present (Arg_Node) loop
21140 Check_No_Identifier (Arg_Node);
21141 Check_Arg_Is_Local_Name (Arg_Node);
21142 Arg_Expr := Get_Pragma_Arg (Arg_Node);
21144 if not Is_Entity_Name (Arg_Expr)
21145 or else not Is_Type (Entity (Arg_Expr))
21148 ("argument for pragma% must be type or subtype", Arg_Node);
21151 Set_Has_Pragma_Unreferenced_Objects (Entity (Arg_Expr));
21154 end Unreferenced_Objects;
21156 ------------------------------
21157 -- Unreserve_All_Interrupts --
21158 ------------------------------
21160 -- pragma Unreserve_All_Interrupts;
21162 when Pragma_Unreserve_All_Interrupts =>
21164 Check_Arg_Count (0);
21166 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
21167 Unreserve_All_Interrupts := True;
21174 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
21176 when Pragma_Unsuppress =>
21178 Process_Suppress_Unsuppress (False);
21180 -------------------
21181 -- Use_VADS_Size --
21182 -------------------
21184 -- pragma Use_VADS_Size;
21186 when Pragma_Use_VADS_Size =>
21188 Check_Arg_Count (0);
21189 Check_Valid_Configuration_Pragma;
21190 Use_VADS_Size := True;
21192 ---------------------
21193 -- Validity_Checks --
21194 ---------------------
21196 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
21198 when Pragma_Validity_Checks => Validity_Checks : declare
21199 A : constant Node_Id := Get_Pragma_Arg (Arg1);
21205 Check_Arg_Count (1);
21206 Check_No_Identifiers;
21208 -- Pragma always active unless in CodePeer or GNATprove modes,
21209 -- which use a fixed configuration of validity checks.
21211 if not (CodePeer_Mode or GNATprove_Mode) then
21212 if Nkind (A) = N_String_Literal then
21216 Slen : constant Natural := Natural (String_Length (S));
21217 Options : String (1 .. Slen);
21221 -- Couldn't we use a for loop here over Options'Range???
21225 C := Get_String_Char (S, Int (J));
21227 -- This is a weird test, it skips setting validity
21228 -- checks entirely if any element of S is out of
21229 -- range of Character, what is that about ???
21231 exit when not In_Character_Range (C);
21232 Options (J) := Get_Character (C);
21235 Set_Validity_Check_Options (Options);
21243 elsif Nkind (A) = N_Identifier then
21244 if Chars (A) = Name_All_Checks then
21245 Set_Validity_Check_Options ("a");
21246 elsif Chars (A) = Name_On then
21247 Validity_Checks_On := True;
21248 elsif Chars (A) = Name_Off then
21249 Validity_Checks_On := False;
21253 end Validity_Checks;
21259 -- pragma Volatile (LOCAL_NAME);
21261 when Pragma_Volatile =>
21262 Process_Atomic_Shared_Volatile;
21264 -------------------------
21265 -- Volatile_Components --
21266 -------------------------
21268 -- pragma Volatile_Components (array_LOCAL_NAME);
21270 -- Volatile is handled by the same circuit as Atomic_Components
21272 ----------------------
21273 -- Warning_As_Error --
21274 ----------------------
21276 when Pragma_Warning_As_Error =>
21278 Check_Arg_Count (1);
21279 Check_No_Identifiers;
21280 Check_Valid_Configuration_Pragma;
21282 if not Is_Static_String_Expression (Arg1) then
21284 ("argument of pragma% must be static string expression",
21287 -- OK static string expression
21290 String_To_Name_Buffer
21291 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
21292 Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1;
21293 Warnings_As_Errors (Warnings_As_Errors_Count) :=
21294 new String'(Name_Buffer (1 .. Name_Len));
21301 -- pragma Warnings (On | Off [,REASON]);
21302 -- pragma Warnings (On | Off, LOCAL_NAME [,REASON]);
21303 -- pragma Warnings (static_string_EXPRESSION [,REASON]);
21304 -- pragma Warnings (On | Off, STRING_LITERAL [,REASON]);
21306 -- REASON ::= Reason => Static_String_Expression
21308 when Pragma_Warnings => Warnings : declare
21309 Reason : String_Id;
21313 Check_At_Least_N_Arguments (1);
21315 -- See if last argument is labeled Reason. If so, make sure we
21316 -- have a static string expression, and acquire the REASON string.
21317 -- Then remove the REASON argument by decreasing Num_Args by one;
21318 -- Remaining processing looks only at first Num_Args arguments).
21321 Last_Arg : constant Node_Id :=
21322 Last (Pragma_Argument_Associations (N));
21324 if Nkind (Last_Arg) = N_Pragma_Argument_Association
21325 and then Chars (Last_Arg) = Name_Reason
21328 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
21329 Reason := End_String;
21330 Arg_Count := Arg_Count - 1;
21332 -- Not allowed in compiler units (bootstrap issues)
21334 Check_Compiler_Unit (N);
21336 -- No REASON string, set null string as reason
21339 Reason := Null_String_Id;
21343 -- Now proceed with REASON taken care of and eliminated
21345 Check_No_Identifiers;
21347 -- If debug flag -gnatd.i is set, pragma is ignored
21349 if Debug_Flag_Dot_I then
21353 -- Process various forms of the pragma
21356 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21359 -- One argument case
21361 if Arg_Count = 1 then
21363 -- On/Off one argument case was processed by parser
21365 if Nkind (Argx) = N_Identifier
21366 and then Nam_In (Chars (Argx), Name_On, Name_Off)
21370 -- One argument case must be ON/OFF or static string expr
21372 elsif not Is_Static_String_Expression (Arg1) then
21374 ("argument of pragma% must be On/Off or static string "
21375 & "expression", Arg1);
21377 -- One argument string expression case
21381 Lit : constant Node_Id := Expr_Value_S (Argx);
21382 Str : constant String_Id := Strval (Lit);
21383 Len : constant Nat := String_Length (Str);
21391 while J <= Len loop
21392 C := Get_String_Char (Str, J);
21393 OK := In_Character_Range (C);
21396 Chr := Get_Character (C);
21398 -- Dash case: only -Wxxx is accepted
21405 C := Get_String_Char (Str, J);
21406 Chr := Get_Character (C);
21407 exit when Chr = 'W';
21412 elsif J < Len and then Chr = '.' then
21414 C := Get_String_Char (Str, J);
21415 Chr := Get_Character (C);
21417 if not Set_Dot_Warning_Switch (Chr) then
21419 ("invalid warning switch character "
21420 & '.' & Chr, Arg1);
21426 OK := Set_Warning_Switch (Chr);
21432 ("invalid warning switch character " & Chr,
21441 -- Two or more arguments (must be two)
21444 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
21445 Check_At_Most_N_Arguments (2);
21453 E_Id := Get_Pragma_Arg (Arg2);
21456 -- In the expansion of an inlined body, a reference to
21457 -- the formal may be wrapped in a conversion if the
21458 -- actual is a conversion. Retrieve the real entity name.
21460 if (In_Instance_Body or In_Inlined_Body)
21461 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
21463 E_Id := Expression (E_Id);
21466 -- Entity name case
21468 if Is_Entity_Name (E_Id) then
21469 E := Entity (E_Id);
21476 (E, (Chars (Get_Pragma_Arg (Arg1)) =
21479 -- For OFF case, make entry in warnings off
21480 -- pragma table for later processing. But we do
21481 -- not do that within an instance, since these
21482 -- warnings are about what is needed in the
21483 -- template, not an instance of it.
21485 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
21486 and then Warn_On_Warnings_Off
21487 and then not In_Instance
21489 Warnings_Off_Pragmas.Append ((N, E, Reason));
21492 if Is_Enumeration_Type (E) then
21496 Lit := First_Literal (E);
21497 while Present (Lit) loop
21498 Set_Warnings_Off (Lit);
21499 Next_Literal (Lit);
21504 exit when No (Homonym (E));
21509 -- Error if not entity or static string expression case
21511 elsif not Is_Static_String_Expression (Arg2) then
21513 ("second argument of pragma% must be entity name "
21514 & "or static string expression", Arg2);
21516 -- Static string expression case
21519 String_To_Name_Buffer
21520 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg2))));
21522 -- Note on configuration pragma case: If this is a
21523 -- configuration pragma, then for an OFF pragma, we
21524 -- just set Config True in the call, which is all
21525 -- that needs to be done. For the case of ON, this
21526 -- is normally an error, unless it is canceling the
21527 -- effect of a previous OFF pragma in the same file.
21528 -- In any other case, an error will be signalled (ON
21529 -- with no matching OFF).
21531 -- Note: We set Used if we are inside a generic to
21532 -- disable the test that the non-config case actually
21533 -- cancels a warning. That's because we can't be sure
21534 -- there isn't an instantiation in some other unit
21535 -- where a warning is suppressed.
21537 -- We could do a little better here by checking if the
21538 -- generic unit we are inside is public, but for now
21539 -- we don't bother with that refinement.
21541 if Chars (Argx) = Name_Off then
21542 Set_Specific_Warning_Off
21543 (Loc, Name_Buffer (1 .. Name_Len), Reason,
21544 Config => Is_Configuration_Pragma,
21545 Used => Inside_A_Generic or else In_Instance);
21547 elsif Chars (Argx) = Name_On then
21548 Set_Specific_Warning_On
21549 (Loc, Name_Buffer (1 .. Name_Len), Err);
21553 ("??pragma Warnings On with no matching "
21554 & "Warnings Off", Loc);
21563 -------------------
21564 -- Weak_External --
21565 -------------------
21567 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
21569 when Pragma_Weak_External => Weak_External : declare
21574 Check_Arg_Count (1);
21575 Check_Optional_Identifier (Arg1, Name_Entity);
21576 Check_Arg_Is_Library_Level_Local_Name (Arg1);
21577 Ent := Entity (Get_Pragma_Arg (Arg1));
21579 if Rep_Item_Too_Early (Ent, N) then
21582 Ent := Underlying_Type (Ent);
21585 -- The only processing required is to link this item on to the
21586 -- list of rep items for the given entity. This is accomplished
21587 -- by the call to Rep_Item_Too_Late (when no error is detected
21588 -- and False is returned).
21590 if Rep_Item_Too_Late (Ent, N) then
21593 Set_Has_Gigi_Rep_Item (Ent);
21597 -----------------------------
21598 -- Wide_Character_Encoding --
21599 -----------------------------
21601 -- pragma Wide_Character_Encoding (IDENTIFIER);
21603 when Pragma_Wide_Character_Encoding =>
21606 -- Nothing to do, handled in parser. Note that we do not enforce
21607 -- configuration pragma placement, this pragma can appear at any
21608 -- place in the source, allowing mixed encodings within a single
21613 --------------------
21614 -- Unknown_Pragma --
21615 --------------------
21617 -- Should be impossible, since the case of an unknown pragma is
21618 -- separately processed before the case statement is entered.
21620 when Unknown_Pragma =>
21621 raise Program_Error;
21624 -- AI05-0144: detect dangerous order dependence. Disabled for now,
21625 -- until AI is formally approved.
21627 -- Check_Order_Dependence;
21630 when Pragma_Exit => null;
21631 end Analyze_Pragma;
21633 ---------------------------------------------
21634 -- Analyze_Pre_Post_Condition_In_Decl_Part --
21635 ---------------------------------------------
21637 procedure Analyze_Pre_Post_Condition_In_Decl_Part
21639 Subp_Id : Entity_Id)
21641 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (Prag));
21642 Nam : constant Name_Id := Original_Aspect_Name (Prag);
21645 Restore_Scope : Boolean := False;
21646 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
21649 -- Ensure that the subprogram and its formals are visible when analyzing
21650 -- the expression of the pragma.
21652 if not In_Open_Scopes (Subp_Id) then
21653 Restore_Scope := True;
21654 Push_Scope (Subp_Id);
21655 Install_Formals (Subp_Id);
21658 -- Preanalyze the boolean expression, we treat this as a spec expression
21659 -- (i.e. similar to a default expression).
21661 Expr := Get_Pragma_Arg (Arg1);
21663 -- In ASIS mode, for a pragma generated from a source aspect, analyze
21664 -- the original aspect expression, which is shared with the generated
21667 if ASIS_Mode and then Present (Corresponding_Aspect (Prag)) then
21668 Expr := Expression (Corresponding_Aspect (Prag));
21671 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
21673 -- For a class-wide condition, a reference to a controlling formal must
21674 -- be interpreted as having the class-wide type (or an access to such)
21675 -- so that the inherited condition can be properly applied to any
21676 -- overriding operation (see ARM12 6.6.1 (7)).
21678 if Class_Present (Prag) then
21679 Class_Wide_Condition : declare
21680 T : constant Entity_Id := Find_Dispatching_Type (Subp_Id);
21682 ACW : Entity_Id := Empty;
21683 -- Access to T'class, created if there is a controlling formal
21684 -- that is an access parameter.
21686 function Get_ACW return Entity_Id;
21687 -- If the expression has a reference to an controlling access
21688 -- parameter, create an access to T'class for the necessary
21689 -- conversions if one does not exist.
21691 function Process (N : Node_Id) return Traverse_Result;
21692 -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
21693 -- aspect for a primitive subprogram of a tagged type T, a name
21694 -- that denotes a formal parameter of type T is interpreted as
21695 -- having type T'Class. Similarly, a name that denotes a formal
21696 -- accessparameter of type access-to-T is interpreted as having
21697 -- type access-to-T'Class. This ensures the expression is well-
21698 -- defined for a primitive subprogram of a type descended from T.
21699 -- Note that this replacement is not done for selector names in
21700 -- parameter associations. These carry an entity for reference
21701 -- purposes, but semantically they are just identifiers.
21707 function Get_ACW return Entity_Id is
21708 Loc : constant Source_Ptr := Sloc (Prag);
21714 Make_Full_Type_Declaration (Loc,
21715 Defining_Identifier => Make_Temporary (Loc, 'T'),
21717 Make_Access_To_Object_Definition (Loc,
21718 Subtype_Indication =>
21719 New_Occurrence_Of (Class_Wide_Type (T), Loc),
21720 All_Present => True));
21722 Insert_Before (Unit_Declaration_Node (Subp_Id), Decl);
21724 ACW := Defining_Identifier (Decl);
21725 Freeze_Before (Unit_Declaration_Node (Subp_Id), ACW);
21735 function Process (N : Node_Id) return Traverse_Result is
21736 Loc : constant Source_Ptr := Sloc (N);
21740 if Is_Entity_Name (N)
21741 and then Present (Entity (N))
21742 and then Is_Formal (Entity (N))
21743 and then Nkind (Parent (N)) /= N_Type_Conversion
21745 (Nkind (Parent (N)) /= N_Parameter_Association
21746 or else N /= Selector_Name (Parent (N)))
21748 if Etype (Entity (N)) = T then
21749 Typ := Class_Wide_Type (T);
21751 elsif Is_Access_Type (Etype (Entity (N)))
21752 and then Designated_Type (Etype (Entity (N))) = T
21759 if Present (Typ) then
21761 Make_Type_Conversion (Loc,
21763 New_Occurrence_Of (Typ, Loc),
21764 Expression => New_Occurrence_Of (Entity (N), Loc)));
21765 Set_Etype (N, Typ);
21772 procedure Replace_Type is new Traverse_Proc (Process);
21774 -- Start of processing for Class_Wide_Condition
21777 if not Present (T) then
21779 -- Pre'Class/Post'Class aspect cases
21781 if From_Aspect_Specification (Prag) then
21782 if Nam = Name_uPre then
21783 Error_Msg_Name_1 := Name_Pre;
21785 Error_Msg_Name_1 := Name_Post;
21788 Error_Msg_Name_2 := Name_Class;
21791 ("aspect `%''%` can only be specified for a primitive "
21792 & "operation of a tagged type",
21793 Corresponding_Aspect (Prag));
21795 -- Pre_Class, Post_Class pragma cases
21798 if Nam = Name_uPre then
21799 Error_Msg_Name_1 := Name_Pre_Class;
21801 Error_Msg_Name_1 := Name_Post_Class;
21805 ("pragma% can only be specified for a primitive "
21806 & "operation of a tagged type",
21807 Corresponding_Aspect (Prag));
21811 Replace_Type (Get_Pragma_Arg (Arg1));
21812 end Class_Wide_Condition;
21815 -- Remove the subprogram from the scope stack now that the pre-analysis
21816 -- of the precondition/postcondition is done.
21818 if Restore_Scope then
21821 end Analyze_Pre_Post_Condition_In_Decl_Part;
21823 ------------------------------------------
21824 -- Analyze_Refined_Depends_In_Decl_Part --
21825 ------------------------------------------
21827 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
21828 Dependencies : List_Id := No_List;
21830 -- The corresponding Depends pragma along with its clauses
21832 Refinements : List_Id := No_List;
21833 -- The clauses of pragma Refined_Depends
21835 Spec_Id : Entity_Id;
21836 -- The entity of the subprogram subject to pragma Refined_Depends
21838 procedure Check_Dependency_Clause (Dep_Clause : Node_Id);
21839 -- Verify the legality of a single clause
21841 function Input_Match
21842 (Dep_Input : Node_Id;
21843 Ref_Inputs : List_Id;
21844 Post_Errors : Boolean) return Boolean;
21845 -- Determine whether input Dep_Input matches one of inputs found in list
21846 -- Ref_Inputs. If flag Post_Errors is set, the routine reports missed or
21847 -- extra input items.
21849 function Inputs_Match
21850 (Dep_Clause : Node_Id;
21851 Ref_Clause : Node_Id;
21852 Post_Errors : Boolean) return Boolean;
21853 -- Determine whether the inputs of Depends clause Dep_Clause match those
21854 -- of refinement clause Ref_Clause. If flag Post_Errors is set, then the
21855 -- routine reports missed or extra input items.
21857 function Is_Self_Referential (Item_Id : Entity_Id) return Boolean;
21858 -- Determine whether a formal parameter, variable or state denoted by
21859 -- Item_Id appears both as input and an output in a single clause of
21862 procedure Report_Extra_Clauses;
21863 -- Emit an error for each extra clause the appears in Refined_Depends
21865 -----------------------------
21866 -- Check_Dependency_Clause --
21867 -----------------------------
21869 procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is
21870 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
21871 Dep_Id : Entity_Id;
21872 Matching_Clause : Node_Id := Empty;
21873 Next_Ref_Clause : Node_Id;
21874 Ref_Clause : Node_Id;
21875 Ref_Id : Entity_Id;
21876 Ref_Output : Node_Id;
21878 Has_Constituent : Boolean := False;
21879 -- Flag set when the refinement output list contains at least one
21880 -- constituent of the state denoted by Dep_Id.
21882 Has_Null_State : Boolean := False;
21883 -- Flag set when the output of clause Dep_Clause is a state with a
21884 -- null refinement.
21886 Has_Refined_State : Boolean := False;
21887 -- Flag set when the output of clause Dep_Clause is a state with
21888 -- visible refinement.
21891 -- The analysis of pragma Depends should produce normalized clauses
21892 -- with exactly one output. This is important because output items
21893 -- are unique in the whole dependence relation and can be used as
21896 pragma Assert (No (Next (Dep_Output)));
21898 -- Inspect all clauses of Refined_Depends and attempt to match the
21899 -- output of Dep_Clause against an output from the refinement clauses
21902 Ref_Clause := First (Refinements);
21903 while Present (Ref_Clause) loop
21904 Matching_Clause := Empty;
21906 -- Store the next clause now because a match will trim the list of
21907 -- refinement clauses and this side effect should not be visible
21908 -- in pragma Refined_Depends.
21910 Next_Ref_Clause := Next (Ref_Clause);
21912 -- The analysis of pragma Refined_Depends should produce
21913 -- normalized clauses with exactly one output.
21915 Ref_Output := First (Choices (Ref_Clause));
21916 pragma Assert (No (Next (Ref_Output)));
21918 -- Two null output lists match if their inputs match
21920 if Nkind (Dep_Output) = N_Null
21921 and then Nkind (Ref_Output) = N_Null
21923 Matching_Clause := Ref_Clause;
21926 -- Two function 'Result attributes match if their inputs match.
21927 -- Note that there is no need to compare the two prefixes because
21928 -- the attributes cannot denote anything but the related function.
21930 elsif Is_Attribute_Result (Dep_Output)
21931 and then Is_Attribute_Result (Ref_Output)
21933 Matching_Clause := Ref_Clause;
21936 -- The remaining cases are formal parameters, variables and states
21938 elsif Is_Entity_Name (Dep_Output) then
21940 -- Handle abstract views of states and variables generated for
21941 -- limited with clauses.
21943 Dep_Id := Available_View (Entity_Of (Dep_Output));
21945 if Ekind (Dep_Id) = E_Abstract_State then
21947 -- A state with a null refinement matches either a null
21948 -- output list or nothing at all (no clause):
21950 -- Refined_State => (State => null)
21954 -- Depends => (State => null)
21955 -- Refined_Depends => null -- OK
21957 -- Null output list
21959 -- Depends => (State => <input>)
21960 -- Refined_Depends => (null => <input>) -- OK
21962 if Has_Null_Refinement (Dep_Id) then
21963 Has_Null_State := True;
21965 -- When a state with null refinement matches a null
21966 -- output, compare their inputs.
21968 if Nkind (Ref_Output) = N_Null then
21969 Matching_Clause := Ref_Clause;
21974 -- The state has a non-null refinement in which case the
21975 -- match is based on constituents and inputs. A state with
21976 -- multiple output constituents may match multiple clauses:
21978 -- Refined_State => (State => (C1, C2))
21979 -- Depends => (State => <input>)
21980 -- Refined_Depends => ((C1, C2) => <input>)
21982 -- When normalized, the above becomes:
21984 -- Refined_Depends => (C1 => <input>,
21987 elsif Has_Non_Null_Refinement (Dep_Id) then
21988 Has_Refined_State := True;
21990 -- Account for the case where a state with a non-null
21991 -- refinement matches a null output list:
21993 -- Refined_State => (State_1 => (C1, C2),
21994 -- State_2 => (C3, C4))
21995 -- Depends => (State_1 => State_2)
21996 -- Refined_Depends => (null => C3)
21998 if Nkind (Ref_Output) = N_Null
21999 and then Inputs_Match
22000 (Dep_Clause => Dep_Clause,
22001 Ref_Clause => Ref_Clause,
22002 Post_Errors => False)
22004 Has_Constituent := True;
22006 -- Note that the search continues after the clause is
22007 -- removed from the pool of candidates because it may
22008 -- have been normalized into multiple simple clauses.
22010 Remove (Ref_Clause);
22012 -- Otherwise the output of the refinement clause must be
22013 -- a valid constituent of the state:
22015 -- Refined_State => (State => (C1, C2))
22016 -- Depends => (State => <input>)
22017 -- Refined_Depends => (C1 => <input>)
22019 elsif Is_Entity_Name (Ref_Output) then
22020 Ref_Id := Entity_Of (Ref_Output);
22022 if Ekind_In (Ref_Id, E_Abstract_State, E_Variable)
22023 and then Present (Encapsulating_State (Ref_Id))
22024 and then Encapsulating_State (Ref_Id) = Dep_Id
22025 and then Inputs_Match
22026 (Dep_Clause => Dep_Clause,
22027 Ref_Clause => Ref_Clause,
22028 Post_Errors => False)
22030 Has_Constituent := True;
22032 -- Note that the search continues after the clause
22033 -- is removed from the pool of candidates because
22034 -- it may have been normalized into multiple simple
22037 Remove (Ref_Clause);
22041 -- The abstract view of a state matches is corresponding
22042 -- non-abstract view:
22044 -- Depends => (Lim_Pack.State => <input>)
22045 -- Refined_Depends => (State => <input>)
22047 elsif Is_Entity_Name (Ref_Output)
22048 and then Entity_Of (Ref_Output) = Dep_Id
22050 Matching_Clause := Ref_Clause;
22054 -- Formal parameters and variables match if their inputs match
22056 elsif Is_Entity_Name (Ref_Output)
22057 and then Entity_Of (Ref_Output) = Dep_Id
22059 Matching_Clause := Ref_Clause;
22064 Ref_Clause := Next_Ref_Clause;
22067 -- Handle the case where pragma Depends contains one or more clauses
22068 -- that only mention states with null refinements. In that case the
22069 -- corresponding pragma Refined_Depends may have a null relation.
22071 -- Refined_State => (State => null)
22072 -- Depends => (State => null)
22073 -- Refined_Depends => null -- OK
22075 -- Another instance of the same scenario occurs when the list of
22076 -- refinements has been depleted while processing previous clauses.
22078 if Is_Entity_Name (Dep_Output)
22079 and then (No (Refinements) or else Is_Empty_List (Refinements))
22081 Dep_Id := Entity_Of (Dep_Output);
22083 if Ekind (Dep_Id) = E_Abstract_State
22084 and then Has_Null_Refinement (Dep_Id)
22086 Has_Null_State := True;
22090 -- The above search produced a match based on unique output. Ensure
22091 -- that the inputs match as well and if they do, remove the clause
22092 -- from the pool of candidates.
22094 if Present (Matching_Clause) then
22096 (Ref_Clause => Ref_Clause,
22097 Dep_Clause => Matching_Clause,
22098 Post_Errors => True)
22100 Remove (Matching_Clause);
22103 -- A state with a visible refinement was matched against one or
22104 -- more clauses containing appropriate constituents.
22106 elsif Has_Constituent then
22109 -- A state with a null refinement did not warrant a clause
22111 elsif Has_Null_State then
22114 -- The dependence relation of pragma Refined_Depends does not contain
22115 -- a matching clause, emit an error.
22119 ("dependence clause of subprogram & has no matching refinement "
22120 & "in body", Ref_Clause, Spec_Id);
22122 if Has_Refined_State then
22124 ("\check the use of constituents in dependence refinement",
22128 end Check_Dependency_Clause;
22134 function Input_Match
22135 (Dep_Input : Node_Id;
22136 Ref_Inputs : List_Id;
22137 Post_Errors : Boolean) return Boolean
22139 procedure Match_Error (Msg : String; N : Node_Id);
22140 -- Emit a matching error if flag Post_Errors is set
22146 procedure Match_Error (Msg : String; N : Node_Id) is
22148 if Post_Errors then
22149 Error_Msg_N (Msg, N);
22156 Next_Ref_Input : Node_Id;
22157 Ref_Id : Entity_Id;
22158 Ref_Input : Node_Id;
22160 Has_Constituent : Boolean := False;
22161 -- Flag set when the refinement input list contains at least one
22162 -- constituent of the state denoted by Dep_Id.
22164 Has_Null_State : Boolean := False;
22165 -- Flag set when the dependency input is a state with a visible null
22168 Has_Refined_State : Boolean := False;
22169 -- Flag set when the dependency input is a state with visible non-
22170 -- null refinement.
22172 -- Start of processing for Input_Match
22175 -- Match a null input with another null input
22177 if Nkind (Dep_Input) = N_Null then
22178 Ref_Input := First (Ref_Inputs);
22180 -- Remove the matching null from the pool of candidates
22182 if Nkind (Ref_Input) = N_Null then
22183 Remove (Ref_Input);
22188 ("null input cannot be matched in corresponding refinement "
22189 & "clause", Dep_Input);
22192 -- Remaining cases are formal parameters, variables, and states
22195 -- Handle abstract views of states and variables generated for
22196 -- limited with clauses.
22198 Dep_Id := Available_View (Entity_Of (Dep_Input));
22200 -- Inspect all inputs of the refinement clause and attempt to
22201 -- match against the inputs of the dependence clause.
22203 Ref_Input := First (Ref_Inputs);
22204 while Present (Ref_Input) loop
22206 -- Store the next input now because a match will remove it from
22209 Next_Ref_Input := Next (Ref_Input);
22211 if Ekind (Dep_Id) = E_Abstract_State then
22213 -- A state with a null refinement matches either a null
22214 -- input list or nothing at all (no input):
22216 -- Refined_State => (State => null)
22220 -- Depends => (<output> => (State, Input))
22221 -- Refined_Depends => (<output> => Input) -- OK
22225 -- Depends => (<output> => State)
22226 -- Refined_Depends => (<output> => null) -- OK
22228 if Has_Null_Refinement (Dep_Id) then
22229 Has_Null_State := True;
22231 -- Remove the matching null from the pool of candidates
22233 if Nkind (Ref_Input) = N_Null then
22234 Remove (Ref_Input);
22239 -- The state has a non-null refinement in which case remove
22240 -- all the matching constituents of the state:
22242 -- Refined_State => (State => (C1, C2))
22243 -- Depends => (<output> => State)
22244 -- Refined_Depends => (<output> => (C1, C2))
22246 elsif Has_Non_Null_Refinement (Dep_Id) then
22247 Has_Refined_State := True;
22249 -- A state with a visible non-null refinement may have a
22250 -- null input_list only when it is self referential.
22252 -- Refined_State => (State => (C1, C2))
22253 -- Depends => (State => State)
22254 -- Refined_Depends => (C2 => null) -- OK
22256 if Nkind (Ref_Input) = N_Null
22257 and then Is_Self_Referential (Dep_Id)
22259 -- Remove the null from the pool of candidates. Note
22260 -- that the search continues because the state may be
22261 -- represented by multiple constituents.
22263 Has_Constituent := True;
22264 Remove (Ref_Input);
22266 -- Ref_Input is an entity name
22268 elsif Is_Entity_Name (Ref_Input) then
22269 Ref_Id := Entity_Of (Ref_Input);
22271 -- The input of the refinement clause is a valid
22272 -- constituent of the state. Remove the input from the
22273 -- pool of candidates. Note that the search continues
22274 -- because the state may be represented by multiple
22277 if Ekind_In (Ref_Id, E_Abstract_State,
22279 and then Present (Encapsulating_State (Ref_Id))
22280 and then Encapsulating_State (Ref_Id) = Dep_Id
22282 Has_Constituent := True;
22283 Remove (Ref_Input);
22287 -- The abstract view of a state matches its corresponding
22288 -- non-abstract view:
22290 -- Depends => (<output> => Lim_Pack.State)
22291 -- Refined_Depends => (<output> => State)
22293 elsif Is_Entity_Name (Ref_Input)
22294 and then Entity_Of (Ref_Input) = Dep_Id
22296 Remove (Ref_Input);
22300 -- Formal parameters and variables are matched on entities. If
22301 -- this is the case, remove the input from the candidate list.
22303 elsif Is_Entity_Name (Ref_Input)
22304 and then Entity_Of (Ref_Input) = Dep_Id
22306 Remove (Ref_Input);
22310 Ref_Input := Next_Ref_Input;
22313 -- When a state with a null refinement appears as the last input,
22314 -- it matches nothing:
22316 -- Refined_State => (State => null)
22317 -- Depends => (<output> => (Input, State))
22318 -- Refined_Depends => (<output> => Input) -- OK
22320 if Ekind (Dep_Id) = E_Abstract_State
22321 and then Has_Null_Refinement (Dep_Id)
22322 and then No (Ref_Input)
22324 Has_Null_State := True;
22328 -- A state with visible refinement was matched against one or more of
22329 -- its constituents.
22331 if Has_Constituent then
22334 -- A state with a null refinement matched null or nothing
22336 elsif Has_Null_State then
22339 -- The input of a dependence clause does not have a matching input in
22340 -- the refinement clause, emit an error.
22344 ("input cannot be matched in corresponding refinement clause",
22347 if Has_Refined_State then
22349 ("\check the use of constituents in dependence refinement",
22361 function Inputs_Match
22362 (Dep_Clause : Node_Id;
22363 Ref_Clause : Node_Id;
22364 Post_Errors : Boolean) return Boolean
22366 Ref_Inputs : List_Id;
22367 -- The input list of the refinement clause
22369 procedure Report_Extra_Inputs;
22370 -- Emit errors for all extra inputs that appear in Ref_Inputs
22372 -------------------------
22373 -- Report_Extra_Inputs --
22374 -------------------------
22376 procedure Report_Extra_Inputs is
22380 if Present (Ref_Inputs) and then Post_Errors then
22381 Input := First (Ref_Inputs);
22382 while Present (Input) loop
22384 ("unmatched or extra input in refinement clause", Input);
22389 end Report_Extra_Inputs;
22393 Dep_Inputs : constant Node_Id := Expression (Dep_Clause);
22394 Inputs : constant Node_Id := Expression (Ref_Clause);
22395 Dep_Input : Node_Id;
22398 -- Start of processing for Inputs_Match
22401 -- Construct a list of all refinement inputs. Note that the input
22402 -- list is copied because the algorithm modifies its contents and
22403 -- this should not be visible in Refined_Depends. The same applies
22404 -- for a solitary input.
22406 if Nkind (Inputs) = N_Aggregate then
22407 Ref_Inputs := New_Copy_List (Expressions (Inputs));
22409 Ref_Inputs := New_List (New_Copy (Inputs));
22412 -- Depending on whether the original dependency clause mentions
22413 -- states with visible refinement, the corresponding refinement
22414 -- clause may differ greatly in structure and contents:
22416 -- State with null refinement
22418 -- Refined_State => (State => null)
22419 -- Depends => (<output> => State)
22420 -- Refined_Depends => (<output> => null)
22422 -- Depends => (<output> => (State, Input))
22423 -- Refined_Depends => (<output> => Input)
22425 -- Depends => (<output> => (Input_1, State, Input_2))
22426 -- Refined_Depends => (<output> => (Input_1, Input_2))
22428 -- State with non-null refinement
22430 -- Refined_State => (State_1 => (C1, C2))
22431 -- Depends => (<output> => State)
22432 -- Refined_Depends => (<output> => C1)
22434 -- Refined_Depends => (<output> => (C1, C2))
22436 if Nkind (Dep_Inputs) = N_Aggregate then
22437 Dep_Input := First (Expressions (Dep_Inputs));
22438 while Present (Dep_Input) loop
22440 (Dep_Input => Dep_Input,
22441 Ref_Inputs => Ref_Inputs,
22442 Post_Errors => Post_Errors)
22457 (Dep_Input => Dep_Inputs,
22458 Ref_Inputs => Ref_Inputs,
22459 Post_Errors => Post_Errors);
22462 -- List all inputs that appear as extras
22464 Report_Extra_Inputs;
22469 -------------------------
22470 -- Is_Self_Referential --
22471 -------------------------
22473 function Is_Self_Referential (Item_Id : Entity_Id) return Boolean is
22474 function Denotes_Item (N : Node_Id) return Boolean;
22475 -- Determine whether an arbitrary node N denotes item Item_Id
22481 function Denotes_Item (N : Node_Id) return Boolean is
22485 and then Present (Entity (N))
22486 and then Entity (N) = Item_Id;
22491 Clauses : constant Node_Id :=
22493 (First (Pragma_Argument_Associations (Depends)));
22498 -- Start of processing for Is_Self_Referential
22501 Clause := First (Component_Associations (Clauses));
22502 while Present (Clause) loop
22504 -- Due to normalization, a dependence clause has exactly one
22505 -- output even if the original clause had multiple outputs.
22507 Output := First (Choices (Clause));
22509 -- Detect the following scenario:
22511 -- Item_Id => [(...,] Item_Id [, ...)]
22513 if Denotes_Item (Output) then
22514 Input := Expression (Clause);
22516 -- Multiple inputs appear as an aggregate
22518 if Nkind (Input) = N_Aggregate then
22519 Input := First (Expressions (Input));
22521 if Denotes_Item (Input) then
22529 elsif Denotes_Item (Input) then
22538 end Is_Self_Referential;
22540 --------------------------
22541 -- Report_Extra_Clauses --
22542 --------------------------
22544 procedure Report_Extra_Clauses is
22548 if Present (Refinements) then
22549 Clause := First (Refinements);
22550 while Present (Clause) loop
22552 -- Do not complain about a null input refinement, since a null
22553 -- input legitimately matches anything.
22555 if Nkind (Clause) /= N_Component_Association
22556 or else Nkind (Expression (Clause)) /= N_Null
22559 ("unmatched or extra clause in dependence refinement",
22566 end Report_Extra_Clauses;
22570 Body_Decl : constant Node_Id := Parent (N);
22571 Errors : constant Nat := Serious_Errors_Detected;
22572 Refs : constant Node_Id :=
22573 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
22577 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
22580 -- Verify the syntax of pragma Refined_Depends when SPARK checks are
22581 -- suppressed. Semantic analysis is disabled in this mode.
22583 if SPARK_Mode = Off then
22584 Check_Dependence_List_Syntax (Refs);
22588 Spec_Id := Corresponding_Spec (Body_Decl);
22589 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
22591 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
22592 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
22594 if No (Depends) then
22596 ("useless refinement, declaration of subprogram & lacks aspect or "
22597 & "pragma Depends", N, Spec_Id);
22601 Deps := Get_Pragma_Arg (First (Pragma_Argument_Associations (Depends)));
22603 -- A null dependency relation renders the refinement useless because it
22604 -- cannot possibly mention abstract states with visible refinement. Note
22605 -- that the inverse is not true as states may be refined to null
22606 -- (SPARK RM 7.2.5(2)).
22608 if Nkind (Deps) = N_Null then
22610 ("useless refinement, subprogram & does not depend on abstract "
22611 & "state with visible refinement",
22616 -- Multiple dependency clauses appear as component associations of an
22619 pragma Assert (Nkind (Deps) = N_Aggregate);
22620 Dependencies := Component_Associations (Deps);
22622 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
22623 -- This ensures that the categorization of all refined dependency items
22624 -- is consistent with their role.
22626 Analyze_Depends_In_Decl_Part (N);
22628 if Serious_Errors_Detected = Errors then
22629 if Nkind (Refs) = N_Null then
22630 Refinements := No_List;
22632 -- Multiple dependency clauses appear as component associations of an
22633 -- aggregate. Note that the clauses are copied because the algorithm
22634 -- modifies them and this should not be visible in Refined_Depends.
22636 else pragma Assert (Nkind (Refs) = N_Aggregate);
22637 Refinements := New_Copy_List (Component_Associations (Refs));
22640 -- Inspect all the clauses of pragma Depends looking for a matching
22641 -- clause in pragma Refined_Depends. The approach is to use the
22642 -- sole output of a clause as a key. Output items are unique in a
22643 -- dependence relation. Clause normalization also ensured that all
22644 -- clauses have exactly one output. Depending on what the key is, one
22645 -- or more refinement clauses may satisfy the dependency clause. Each
22646 -- time a dependency clause is matched, its related refinement clause
22647 -- is consumed. In the end, two things may happen:
22649 -- 1) A clause of pragma Depends was not matched in which case
22650 -- Check_Dependency_Clause reports the error.
22652 -- 2) Refined_Depends has an extra clause in which case the error
22653 -- is reported by Report_Extra_Clauses.
22655 Clause := First (Dependencies);
22656 while Present (Clause) loop
22657 Check_Dependency_Clause (Clause);
22662 if Serious_Errors_Detected = Errors then
22663 Report_Extra_Clauses;
22665 end Analyze_Refined_Depends_In_Decl_Part;
22667 -----------------------------------------
22668 -- Analyze_Refined_Global_In_Decl_Part --
22669 -----------------------------------------
22671 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is
22673 -- The corresponding Global pragma
22675 Has_In_State : Boolean := False;
22676 Has_In_Out_State : Boolean := False;
22677 Has_Out_State : Boolean := False;
22678 Has_Proof_In_State : Boolean := False;
22679 -- These flags are set when the corresponding Global pragma has a state
22680 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
22683 Has_Null_State : Boolean := False;
22684 -- This flag is set when the corresponding Global pragma has at least
22685 -- one state with a null refinement.
22687 In_Constits : Elist_Id := No_Elist;
22688 In_Out_Constits : Elist_Id := No_Elist;
22689 Out_Constits : Elist_Id := No_Elist;
22690 Proof_In_Constits : Elist_Id := No_Elist;
22691 -- These lists contain the entities of all Input, In_Out, Output and
22692 -- Proof_In constituents that appear in Refined_Global and participate
22693 -- in state refinement.
22695 In_Items : Elist_Id := No_Elist;
22696 In_Out_Items : Elist_Id := No_Elist;
22697 Out_Items : Elist_Id := No_Elist;
22698 Proof_In_Items : Elist_Id := No_Elist;
22699 -- These list contain the entities of all Input, In_Out, Output and
22700 -- Proof_In items defined in the corresponding Global pragma.
22702 procedure Check_In_Out_States;
22703 -- Determine whether the corresponding Global pragma mentions In_Out
22704 -- states with visible refinement and if so, ensure that one of the
22705 -- following completions apply to the constituents of the state:
22706 -- 1) there is at least one constituent of mode In_Out
22707 -- 2) there is at least one Input and one Output constituent
22708 -- 3) not all constituents are present and one of them is of mode
22710 -- This routine may remove elements from In_Constits, In_Out_Constits,
22711 -- Out_Constits and Proof_In_Constits.
22713 procedure Check_Input_States;
22714 -- Determine whether the corresponding Global pragma mentions Input
22715 -- states with visible refinement and if so, ensure that at least one of
22716 -- its constituents appears as an Input item in Refined_Global.
22717 -- This routine may remove elements from In_Constits, In_Out_Constits,
22718 -- Out_Constits and Proof_In_Constits.
22720 procedure Check_Output_States;
22721 -- Determine whether the corresponding Global pragma mentions Output
22722 -- states with visible refinement and if so, ensure that all of its
22723 -- constituents appear as Output items in Refined_Global.
22724 -- This routine may remove elements from In_Constits, In_Out_Constits,
22725 -- Out_Constits and Proof_In_Constits.
22727 procedure Check_Proof_In_States;
22728 -- Determine whether the corresponding Global pragma mentions Proof_In
22729 -- states with visible refinement and if so, ensure that at least one of
22730 -- its constituents appears as a Proof_In item in Refined_Global.
22731 -- This routine may remove elements from In_Constits, In_Out_Constits,
22732 -- Out_Constits and Proof_In_Constits.
22734 procedure Check_Refined_Global_List
22736 Global_Mode : Name_Id := Name_Input);
22737 -- Verify the legality of a single global list declaration. Global_Mode
22738 -- denotes the current mode in effect.
22740 function Present_Then_Remove
22742 Item : Entity_Id) return Boolean;
22743 -- Search List for a particular entity Item. If Item has been found,
22744 -- remove it from List. This routine is used to strip lists In_Constits,
22745 -- In_Out_Constits and Out_Constits of valid constituents.
22747 procedure Report_Extra_Constituents;
22748 -- Emit an error for each constituent found in lists In_Constits,
22749 -- In_Out_Constits and Out_Constits.
22751 -------------------------
22752 -- Check_In_Out_States --
22753 -------------------------
22755 procedure Check_In_Out_States is
22756 procedure Check_Constituent_Usage (State_Id : Entity_Id);
22757 -- Determine whether one of the following coverage scenarios is in
22759 -- 1) there is at least one constituent of mode In_Out
22760 -- 2) there is at least one Input and one Output constituent
22761 -- 3) not all constituents are present and one of them is of mode
22763 -- If this is not the case, emit an error.
22765 -----------------------------
22766 -- Check_Constituent_Usage --
22767 -----------------------------
22769 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
22770 Constit_Elmt : Elmt_Id;
22771 Constit_Id : Entity_Id;
22772 Has_Missing : Boolean := False;
22773 In_Out_Seen : Boolean := False;
22774 In_Seen : Boolean := False;
22775 Out_Seen : Boolean := False;
22778 -- Process all the constituents of the state and note their modes
22779 -- within the global refinement.
22781 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
22782 while Present (Constit_Elmt) loop
22783 Constit_Id := Node (Constit_Elmt);
22785 if Present_Then_Remove (In_Constits, Constit_Id) then
22788 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then
22789 In_Out_Seen := True;
22791 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
22794 -- A Proof_In constituent cannot participate in the completion
22795 -- of an Output state (SPARK RM 7.2.4(5)).
22797 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id) then
22798 Error_Msg_Name_1 := Chars (State_Id);
22800 ("constituent & of state % must have mode Input, In_Out "
22801 & "or Output in global refinement",
22805 Has_Missing := True;
22808 Next_Elmt (Constit_Elmt);
22811 -- A single In_Out constituent is a valid completion
22813 if In_Out_Seen then
22816 -- A pair of one Input and one Output constituent is a valid
22819 elsif In_Seen and then Out_Seen then
22822 -- A single Output constituent is a valid completion only when
22823 -- some of the other constituents are missing (SPARK RM 7.2.4(5)).
22825 elsif Has_Missing and then Out_Seen then
22830 ("global refinement of state & redefines the mode of its "
22831 & "constituents", N, State_Id);
22833 end Check_Constituent_Usage;
22837 Item_Elmt : Elmt_Id;
22838 Item_Id : Entity_Id;
22840 -- Start of processing for Check_In_Out_States
22843 -- Inspect the In_Out items of the corresponding Global pragma
22844 -- looking for a state with a visible refinement.
22846 if Has_In_Out_State and then Present (In_Out_Items) then
22847 Item_Elmt := First_Elmt (In_Out_Items);
22848 while Present (Item_Elmt) loop
22849 Item_Id := Node (Item_Elmt);
22851 -- Ensure that one of the three coverage variants is satisfied
22853 if Ekind (Item_Id) = E_Abstract_State
22854 and then Has_Non_Null_Refinement (Item_Id)
22856 Check_Constituent_Usage (Item_Id);
22859 Next_Elmt (Item_Elmt);
22862 end Check_In_Out_States;
22864 ------------------------
22865 -- Check_Input_States --
22866 ------------------------
22868 procedure Check_Input_States is
22869 procedure Check_Constituent_Usage (State_Id : Entity_Id);
22870 -- Determine whether at least one constituent of state State_Id with
22871 -- visible refinement is used and has mode Input. Ensure that the
22872 -- remaining constituents do not have In_Out, Output or Proof_In
22875 -----------------------------
22876 -- Check_Constituent_Usage --
22877 -----------------------------
22879 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
22880 Constit_Elmt : Elmt_Id;
22881 Constit_Id : Entity_Id;
22882 In_Seen : Boolean := False;
22885 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
22886 while Present (Constit_Elmt) loop
22887 Constit_Id := Node (Constit_Elmt);
22889 -- At least one of the constituents appears as an Input
22891 if Present_Then_Remove (In_Constits, Constit_Id) then
22894 -- The constituent appears in the global refinement, but has
22895 -- mode In_Out, Output or Proof_In (SPARK RM 7.2.4(5)).
22897 elsif Present_Then_Remove (In_Out_Constits, Constit_Id)
22898 or else Present_Then_Remove (Out_Constits, Constit_Id)
22899 or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
22901 Error_Msg_Name_1 := Chars (State_Id);
22903 ("constituent & of state % must have mode Input in global "
22904 & "refinement", N, Constit_Id);
22907 Next_Elmt (Constit_Elmt);
22910 -- Not one of the constituents appeared as Input
22912 if not In_Seen then
22914 ("global refinement of state & must include at least one "
22915 & "constituent of mode Input", N, State_Id);
22917 end Check_Constituent_Usage;
22921 Item_Elmt : Elmt_Id;
22922 Item_Id : Entity_Id;
22924 -- Start of processing for Check_Input_States
22927 -- Inspect the Input items of the corresponding Global pragma
22928 -- looking for a state with a visible refinement.
22930 if Has_In_State and then Present (In_Items) then
22931 Item_Elmt := First_Elmt (In_Items);
22932 while Present (Item_Elmt) loop
22933 Item_Id := Node (Item_Elmt);
22935 -- Ensure that at least one of the constituents is utilized and
22936 -- is of mode Input.
22938 if Ekind (Item_Id) = E_Abstract_State
22939 and then Has_Non_Null_Refinement (Item_Id)
22941 Check_Constituent_Usage (Item_Id);
22944 Next_Elmt (Item_Elmt);
22947 end Check_Input_States;
22949 -------------------------
22950 -- Check_Output_States --
22951 -------------------------
22953 procedure Check_Output_States is
22954 procedure Check_Constituent_Usage (State_Id : Entity_Id);
22955 -- Determine whether all constituents of state State_Id with visible
22956 -- refinement are used and have mode Output. Emit an error if this is
22959 -----------------------------
22960 -- Check_Constituent_Usage --
22961 -----------------------------
22963 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
22964 Constit_Elmt : Elmt_Id;
22965 Constit_Id : Entity_Id;
22966 Posted : Boolean := False;
22969 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
22970 while Present (Constit_Elmt) loop
22971 Constit_Id := Node (Constit_Elmt);
22973 if Present_Then_Remove (Out_Constits, Constit_Id) then
22976 -- The constituent appears in the global refinement, but has
22977 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
22979 elsif Present_Then_Remove (In_Constits, Constit_Id)
22980 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
22981 or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
22983 Error_Msg_Name_1 := Chars (State_Id);
22985 ("constituent & of state % must have mode Output in "
22986 & "global refinement", N, Constit_Id);
22988 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
22994 ("output state & must be replaced by all its "
22995 & "constituents in global refinement", N, State_Id);
22999 ("\constituent & is missing in output list",
23003 Next_Elmt (Constit_Elmt);
23005 end Check_Constituent_Usage;
23009 Item_Elmt : Elmt_Id;
23010 Item_Id : Entity_Id;
23012 -- Start of processing for Check_Output_States
23015 -- Inspect the Output items of the corresponding Global pragma
23016 -- looking for a state with a visible refinement.
23018 if Has_Out_State and then Present (Out_Items) then
23019 Item_Elmt := First_Elmt (Out_Items);
23020 while Present (Item_Elmt) loop
23021 Item_Id := Node (Item_Elmt);
23023 -- Ensure that all of the constituents are utilized and they
23024 -- have mode Output.
23026 if Ekind (Item_Id) = E_Abstract_State
23027 and then Has_Non_Null_Refinement (Item_Id)
23029 Check_Constituent_Usage (Item_Id);
23032 Next_Elmt (Item_Elmt);
23035 end Check_Output_States;
23037 ---------------------------
23038 -- Check_Proof_In_States --
23039 ---------------------------
23041 procedure Check_Proof_In_States is
23042 procedure Check_Constituent_Usage (State_Id : Entity_Id);
23043 -- Determine whether at least one constituent of state State_Id with
23044 -- visible refinement is used and has mode Proof_In. Ensure that the
23045 -- remaining constituents do not have Input, In_Out or Output modes.
23047 -----------------------------
23048 -- Check_Constituent_Usage --
23049 -----------------------------
23051 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
23052 Constit_Elmt : Elmt_Id;
23053 Constit_Id : Entity_Id;
23054 Proof_In_Seen : Boolean := False;
23057 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
23058 while Present (Constit_Elmt) loop
23059 Constit_Id := Node (Constit_Elmt);
23061 -- At least one of the constituents appears as Proof_In
23063 if Present_Then_Remove (Proof_In_Constits, Constit_Id) then
23064 Proof_In_Seen := True;
23066 -- The constituent appears in the global refinement, but has
23067 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
23069 elsif Present_Then_Remove (In_Constits, Constit_Id)
23070 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
23071 or else Present_Then_Remove (Out_Constits, Constit_Id)
23073 Error_Msg_Name_1 := Chars (State_Id);
23075 ("constituent & of state % must have mode Proof_In in "
23076 & "global refinement", N, Constit_Id);
23079 Next_Elmt (Constit_Elmt);
23082 -- Not one of the constituents appeared as Proof_In
23084 if not Proof_In_Seen then
23086 ("global refinement of state & must include at least one "
23087 & "constituent of mode Proof_In", N, State_Id);
23089 end Check_Constituent_Usage;
23093 Item_Elmt : Elmt_Id;
23094 Item_Id : Entity_Id;
23096 -- Start of processing for Check_Proof_In_States
23099 -- Inspect the Proof_In items of the corresponding Global pragma
23100 -- looking for a state with a visible refinement.
23102 if Has_Proof_In_State and then Present (Proof_In_Items) then
23103 Item_Elmt := First_Elmt (Proof_In_Items);
23104 while Present (Item_Elmt) loop
23105 Item_Id := Node (Item_Elmt);
23107 -- Ensure that at least one of the constituents is utilized and
23108 -- is of mode Proof_In
23110 if Ekind (Item_Id) = E_Abstract_State
23111 and then Has_Non_Null_Refinement (Item_Id)
23113 Check_Constituent_Usage (Item_Id);
23116 Next_Elmt (Item_Elmt);
23119 end Check_Proof_In_States;
23121 -------------------------------
23122 -- Check_Refined_Global_List --
23123 -------------------------------
23125 procedure Check_Refined_Global_List
23127 Global_Mode : Name_Id := Name_Input)
23129 procedure Check_Refined_Global_Item
23131 Global_Mode : Name_Id);
23132 -- Verify the legality of a single global item declaration. Parameter
23133 -- Global_Mode denotes the current mode in effect.
23135 -------------------------------
23136 -- Check_Refined_Global_Item --
23137 -------------------------------
23139 procedure Check_Refined_Global_Item
23141 Global_Mode : Name_Id)
23143 Item_Id : constant Entity_Id := Entity_Of (Item);
23145 procedure Inconsistent_Mode_Error (Expect : Name_Id);
23146 -- Issue a common error message for all mode mismatches. Expect
23147 -- denotes the expected mode.
23149 -----------------------------
23150 -- Inconsistent_Mode_Error --
23151 -----------------------------
23153 procedure Inconsistent_Mode_Error (Expect : Name_Id) is
23156 ("global item & has inconsistent modes", Item, Item_Id);
23158 Error_Msg_Name_1 := Global_Mode;
23159 Error_Msg_Name_2 := Expect;
23160 Error_Msg_N ("\expected mode %, found mode %", Item);
23161 end Inconsistent_Mode_Error;
23163 -- Start of processing for Check_Refined_Global_Item
23166 -- When the state or variable acts as a constituent of another
23167 -- state with a visible refinement, collect it for the state
23168 -- completeness checks performed later on.
23170 if Present (Encapsulating_State (Item_Id))
23171 and then Has_Visible_Refinement (Encapsulating_State (Item_Id))
23173 if Global_Mode = Name_Input then
23174 Add_Item (Item_Id, In_Constits);
23176 elsif Global_Mode = Name_In_Out then
23177 Add_Item (Item_Id, In_Out_Constits);
23179 elsif Global_Mode = Name_Output then
23180 Add_Item (Item_Id, Out_Constits);
23182 elsif Global_Mode = Name_Proof_In then
23183 Add_Item (Item_Id, Proof_In_Constits);
23186 -- When not a constituent, ensure that both occurrences of the
23187 -- item in pragmas Global and Refined_Global match.
23189 elsif Contains (In_Items, Item_Id) then
23190 if Global_Mode /= Name_Input then
23191 Inconsistent_Mode_Error (Name_Input);
23194 elsif Contains (In_Out_Items, Item_Id) then
23195 if Global_Mode /= Name_In_Out then
23196 Inconsistent_Mode_Error (Name_In_Out);
23199 elsif Contains (Out_Items, Item_Id) then
23200 if Global_Mode /= Name_Output then
23201 Inconsistent_Mode_Error (Name_Output);
23204 elsif Contains (Proof_In_Items, Item_Id) then
23207 -- The item does not appear in the corresponding Global pragma,
23208 -- it must be an extra (SPARK RM 7.2.4(3)).
23211 Error_Msg_NE ("extra global item &", Item, Item_Id);
23213 end Check_Refined_Global_Item;
23219 -- Start of processing for Check_Refined_Global_List
23222 if Nkind (List) = N_Null then
23225 -- Single global item declaration
23227 elsif Nkind_In (List, N_Expanded_Name,
23229 N_Selected_Component)
23231 Check_Refined_Global_Item (List, Global_Mode);
23233 -- Simple global list or moded global list declaration
23235 elsif Nkind (List) = N_Aggregate then
23237 -- The declaration of a simple global list appear as a collection
23240 if Present (Expressions (List)) then
23241 Item := First (Expressions (List));
23242 while Present (Item) loop
23243 Check_Refined_Global_Item (Item, Global_Mode);
23248 -- The declaration of a moded global list appears as a collection
23249 -- of component associations where individual choices denote
23252 elsif Present (Component_Associations (List)) then
23253 Item := First (Component_Associations (List));
23254 while Present (Item) loop
23255 Check_Refined_Global_List
23256 (List => Expression (Item),
23257 Global_Mode => Chars (First (Choices (Item))));
23265 raise Program_Error;
23271 raise Program_Error;
23273 end Check_Refined_Global_List;
23275 -------------------------
23276 -- Present_Then_Remove --
23277 -------------------------
23279 function Present_Then_Remove
23281 Item : Entity_Id) return Boolean
23286 if Present (List) then
23287 Elmt := First_Elmt (List);
23288 while Present (Elmt) loop
23289 if Node (Elmt) = Item then
23290 Remove_Elmt (List, Elmt);
23299 end Present_Then_Remove;
23301 -------------------------------
23302 -- Report_Extra_Constituents --
23303 -------------------------------
23305 procedure Report_Extra_Constituents is
23306 procedure Report_Extra_Constituents_In_List (List : Elist_Id);
23307 -- Emit an error for every element of List
23309 ---------------------------------------
23310 -- Report_Extra_Constituents_In_List --
23311 ---------------------------------------
23313 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is
23314 Constit_Elmt : Elmt_Id;
23317 if Present (List) then
23318 Constit_Elmt := First_Elmt (List);
23319 while Present (Constit_Elmt) loop
23320 Error_Msg_NE ("extra constituent &", N, Node (Constit_Elmt));
23321 Next_Elmt (Constit_Elmt);
23324 end Report_Extra_Constituents_In_List;
23326 -- Start of processing for Report_Extra_Constituents
23329 Report_Extra_Constituents_In_List (In_Constits);
23330 Report_Extra_Constituents_In_List (In_Out_Constits);
23331 Report_Extra_Constituents_In_List (Out_Constits);
23332 Report_Extra_Constituents_In_List (Proof_In_Constits);
23333 end Report_Extra_Constituents;
23337 Body_Decl : constant Node_Id := Parent (N);
23338 Errors : constant Nat := Serious_Errors_Detected;
23339 Items : constant Node_Id :=
23340 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
23341 Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl);
23343 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
23346 -- Verify the syntax of pragma Refined_Global when SPARK checks are
23347 -- suppressed. Semantic analysis is disabled in this mode.
23349 if SPARK_Mode = Off then
23350 Check_Global_List_Syntax (Items);
23354 Global := Get_Pragma (Spec_Id, Pragma_Global);
23356 -- The subprogram declaration lacks pragma Global. This renders
23357 -- Refined_Global useless as there is nothing to refine.
23359 if No (Global) then
23361 ("useless refinement, declaration of subprogram & lacks aspect or "
23362 & "pragma Global", N, Spec_Id);
23366 -- Extract all relevant items from the corresponding Global pragma
23368 Collect_Global_Items
23370 In_Items => In_Items,
23371 In_Out_Items => In_Out_Items,
23372 Out_Items => Out_Items,
23373 Proof_In_Items => Proof_In_Items,
23374 Has_In_State => Has_In_State,
23375 Has_In_Out_State => Has_In_Out_State,
23376 Has_Out_State => Has_Out_State,
23377 Has_Proof_In_State => Has_Proof_In_State,
23378 Has_Null_State => Has_Null_State);
23380 -- Corresponding Global pragma must mention at least one state witha
23381 -- visible refinement at the point Refined_Global is processed. States
23382 -- with null refinements need Refined_Global pragma (SPARK RM 7.2.4(2)).
23384 if not Has_In_State
23385 and then not Has_In_Out_State
23386 and then not Has_Out_State
23387 and then not Has_Proof_In_State
23388 and then not Has_Null_State
23391 ("useless refinement, subprogram & does not depend on abstract "
23392 & "state with visible refinement", N, Spec_Id);
23396 -- The global refinement of inputs and outputs cannot be null when the
23397 -- corresponding Global pragma contains at least one item except in the
23398 -- case where we have states with null refinements.
23400 if Nkind (Items) = N_Null
23402 (Present (In_Items)
23403 or else Present (In_Out_Items)
23404 or else Present (Out_Items)
23405 or else Present (Proof_In_Items))
23406 and then not Has_Null_State
23409 ("refinement cannot be null, subprogram & has global items",
23414 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
23415 -- This ensures that the categorization of all refined global items is
23416 -- consistent with their role.
23418 Analyze_Global_In_Decl_Part (N);
23420 -- Perform all refinement checks with respect to completeness and mode
23423 if Serious_Errors_Detected = Errors then
23424 Check_Refined_Global_List (Items);
23427 -- For Input states with visible refinement, at least one constituent
23428 -- must be used as an Input in the global refinement.
23430 if Serious_Errors_Detected = Errors then
23431 Check_Input_States;
23434 -- Verify all possible completion variants for In_Out states with
23435 -- visible refinement.
23437 if Serious_Errors_Detected = Errors then
23438 Check_In_Out_States;
23441 -- For Output states with visible refinement, all constituents must be
23442 -- used as Outputs in the global refinement.
23444 if Serious_Errors_Detected = Errors then
23445 Check_Output_States;
23448 -- For Proof_In states with visible refinement, at least one constituent
23449 -- must be used as Proof_In in the global refinement.
23451 if Serious_Errors_Detected = Errors then
23452 Check_Proof_In_States;
23455 -- Emit errors for all constituents that belong to other states with
23456 -- visible refinement that do not appear in Global.
23458 if Serious_Errors_Detected = Errors then
23459 Report_Extra_Constituents;
23461 end Analyze_Refined_Global_In_Decl_Part;
23463 ----------------------------------------
23464 -- Analyze_Refined_State_In_Decl_Part --
23465 ----------------------------------------
23467 procedure Analyze_Refined_State_In_Decl_Part (N : Node_Id) is
23468 Available_States : Elist_Id := No_Elist;
23469 -- A list of all abstract states defined in the package declaration that
23470 -- are available for refinement. The list is used to report unrefined
23473 Body_Id : Entity_Id;
23474 -- The body entity of the package subject to pragma Refined_State
23476 Body_States : Elist_Id := No_Elist;
23477 -- A list of all hidden states that appear in the body of the related
23478 -- package. The list is used to report unused hidden states.
23480 Constituents_Seen : Elist_Id := No_Elist;
23481 -- A list that contains all constituents processed so far. The list is
23482 -- used to detect multiple uses of the same constituent.
23484 Refined_States_Seen : Elist_Id := No_Elist;
23485 -- A list that contains all refined states processed so far. The list is
23486 -- used to detect duplicate refinements.
23488 Spec_Id : Entity_Id;
23489 -- The spec entity of the package subject to pragma Refined_State
23491 procedure Analyze_Refinement_Clause (Clause : Node_Id);
23492 -- Perform full analysis of a single refinement clause
23494 procedure Check_Refinement_List_Syntax (List : Node_Id);
23495 -- Verify the syntax of refinement clause list List
23497 function Collect_Body_States (Pack_Id : Entity_Id) return Elist_Id;
23498 -- Gather the entities of all abstract states and variables declared in
23499 -- the body state space of package Pack_Id.
23501 procedure Report_Unrefined_States (States : Elist_Id);
23502 -- Emit errors for all unrefined abstract states found in list States
23504 procedure Report_Unused_States (States : Elist_Id);
23505 -- Emit errors for all unused states found in list States
23507 -------------------------------
23508 -- Analyze_Refinement_Clause --
23509 -------------------------------
23511 procedure Analyze_Refinement_Clause (Clause : Node_Id) is
23512 AR_Constit : Entity_Id := Empty;
23513 AW_Constit : Entity_Id := Empty;
23514 ER_Constit : Entity_Id := Empty;
23515 EW_Constit : Entity_Id := Empty;
23516 -- The entities of external constituents that contain one of the
23517 -- following enabled properties: Async_Readers, Async_Writers,
23518 -- Effective_Reads and Effective_Writes.
23520 External_Constit_Seen : Boolean := False;
23521 -- Flag used to mark when at least one external constituent is part
23522 -- of the state refinement.
23524 Non_Null_Seen : Boolean := False;
23525 Null_Seen : Boolean := False;
23526 -- Flags used to detect multiple uses of null in a single clause or a
23527 -- mixture of null and non-null constituents.
23529 Part_Of_Constits : Elist_Id := No_Elist;
23530 -- A list of all candidate constituents subject to indicator Part_Of
23531 -- where the encapsulating state is the current state.
23534 State_Id : Entity_Id;
23535 -- The current state being refined
23537 procedure Analyze_Constituent (Constit : Node_Id);
23538 -- Perform full analysis of a single constituent
23540 procedure Check_External_Property
23541 (Prop_Nam : Name_Id;
23543 Constit : Entity_Id);
23544 -- Determine whether a property denoted by name Prop_Nam is present
23545 -- in both the refined state and constituent Constit. Flag Enabled
23546 -- should be set when the property applies to the refined state. If
23547 -- this is not the case, emit an error message.
23549 procedure Check_Matching_State;
23550 -- Determine whether the state being refined appears in list
23551 -- Available_States. Emit an error when attempting to re-refine the
23552 -- state or when the state is not defined in the package declaration,
23553 -- otherwise remove the state from Available_States.
23555 procedure Report_Unused_Constituents (Constits : Elist_Id);
23556 -- Emit errors for all unused Part_Of constituents in list Constits
23558 -------------------------
23559 -- Analyze_Constituent --
23560 -------------------------
23562 procedure Analyze_Constituent (Constit : Node_Id) is
23563 procedure Check_Matching_Constituent (Constit_Id : Entity_Id);
23564 -- Determine whether constituent Constit denoted by its entity
23565 -- Constit_Id appears in Hidden_States. Emit an error when the
23566 -- constituent is not a valid hidden state of the related package
23567 -- or when it is used more than once. Otherwise remove the
23568 -- constituent from Hidden_States.
23570 --------------------------------
23571 -- Check_Matching_Constituent --
23572 --------------------------------
23574 procedure Check_Matching_Constituent (Constit_Id : Entity_Id) is
23575 procedure Collect_Constituent;
23576 -- Add constituent Constit_Id to the refinements of State_Id
23578 -------------------------
23579 -- Collect_Constituent --
23580 -------------------------
23582 procedure Collect_Constituent is
23584 -- Add the constituent to the list of processed items to aid
23585 -- with the detection of duplicates.
23587 Add_Item (Constit_Id, Constituents_Seen);
23589 -- Collect the constituent in the list of refinement items
23590 -- and establish a relation between the refined state and
23593 Append_Elmt (Constit_Id, Refinement_Constituents (State_Id));
23594 Set_Encapsulating_State (Constit_Id, State_Id);
23596 -- The state has at least one legal constituent, mark the
23597 -- start of the refinement region. The region ends when the
23598 -- body declarations end (see routine Analyze_Declarations).
23600 Set_Has_Visible_Refinement (State_Id);
23602 -- When the constituent is external, save its relevant
23603 -- property for further checks.
23605 if Async_Readers_Enabled (Constit_Id) then
23606 AR_Constit := Constit_Id;
23607 External_Constit_Seen := True;
23610 if Async_Writers_Enabled (Constit_Id) then
23611 AW_Constit := Constit_Id;
23612 External_Constit_Seen := True;
23615 if Effective_Reads_Enabled (Constit_Id) then
23616 ER_Constit := Constit_Id;
23617 External_Constit_Seen := True;
23620 if Effective_Writes_Enabled (Constit_Id) then
23621 EW_Constit := Constit_Id;
23622 External_Constit_Seen := True;
23624 end Collect_Constituent;
23628 State_Elmt : Elmt_Id;
23630 -- Start of processing for Check_Matching_Constituent
23633 -- Detect a duplicate use of a constituent
23635 if Contains (Constituents_Seen, Constit_Id) then
23637 ("duplicate use of constituent &", Constit, Constit_Id);
23641 -- The constituent is subject to a Part_Of indicator
23643 if Present (Encapsulating_State (Constit_Id)) then
23644 if Encapsulating_State (Constit_Id) = State_Id then
23645 Remove (Part_Of_Constits, Constit_Id);
23646 Collect_Constituent;
23648 -- The constituent is part of another state and is used
23649 -- incorrectly in the refinement of the current state.
23652 Error_Msg_Name_1 := Chars (State_Id);
23654 ("& cannot act as constituent of state %",
23655 Constit, Constit_Id);
23657 ("\Part_Of indicator specifies & as encapsulating "
23658 & "state", Constit, Encapsulating_State (Constit_Id));
23661 -- The only other source of legal constituents is the body
23662 -- state space of the related package.
23665 if Present (Body_States) then
23666 State_Elmt := First_Elmt (Body_States);
23667 while Present (State_Elmt) loop
23669 -- Consume a valid constituent to signal that it has
23670 -- been encountered.
23672 if Node (State_Elmt) = Constit_Id then
23673 Remove_Elmt (Body_States, State_Elmt);
23674 Collect_Constituent;
23678 Next_Elmt (State_Elmt);
23682 -- If we get here, then the constituent is not a hidden
23683 -- state of the related package and may not be used in a
23684 -- refinement (SPARK RM 7.2.2(9)).
23686 Error_Msg_Name_1 := Chars (Spec_Id);
23688 ("cannot use & in refinement, constituent is not a hidden "
23689 & "state of package %", Constit, Constit_Id);
23691 end Check_Matching_Constituent;
23695 Constit_Id : Entity_Id;
23697 -- Start of processing for Analyze_Constituent
23700 -- Detect multiple uses of null in a single refinement clause or a
23701 -- mixture of null and non-null constituents.
23703 if Nkind (Constit) = N_Null then
23706 ("multiple null constituents not allowed", Constit);
23708 elsif Non_Null_Seen then
23710 ("cannot mix null and non-null constituents", Constit);
23715 -- Collect the constituent in the list of refinement items
23717 Append_Elmt (Constit, Refinement_Constituents (State_Id));
23719 -- The state has at least one legal constituent, mark the
23720 -- start of the refinement region. The region ends when the
23721 -- body declarations end (see Analyze_Declarations).
23723 Set_Has_Visible_Refinement (State_Id);
23726 -- Non-null constituents
23729 Non_Null_Seen := True;
23733 ("cannot mix null and non-null constituents", Constit);
23737 Resolve_State (Constit);
23739 -- Ensure that the constituent denotes a valid state or a
23742 if Is_Entity_Name (Constit) then
23743 Constit_Id := Entity_Of (Constit);
23745 if Ekind_In (Constit_Id, E_Abstract_State, E_Variable) then
23746 Check_Matching_Constituent (Constit_Id);
23750 ("constituent & must denote a variable or state (SPARK "
23751 & "RM 7.2.2(5))", Constit, Constit_Id);
23754 -- The constituent is illegal
23757 Error_Msg_N ("malformed constituent", Constit);
23760 end Analyze_Constituent;
23762 -----------------------------
23763 -- Check_External_Property --
23764 -----------------------------
23766 procedure Check_External_Property
23767 (Prop_Nam : Name_Id;
23769 Constit : Entity_Id)
23772 Error_Msg_Name_1 := Prop_Nam;
23774 -- The property is enabled in the related Abstract_State pragma
23775 -- that defines the state (SPARK RM 7.2.8(3)).
23778 if No (Constit) then
23780 ("external state & requires at least one constituent with "
23781 & "property %", State, State_Id);
23784 -- The property is missing in the declaration of the state, but
23785 -- a constituent is introducing it in the state refinement
23786 -- (SPARK RM 7.2.8(3)).
23788 elsif Present (Constit) then
23789 Error_Msg_Name_2 := Chars (Constit);
23791 ("external state & lacks property % set by constituent %",
23794 end Check_External_Property;
23796 --------------------------
23797 -- Check_Matching_State --
23798 --------------------------
23800 procedure Check_Matching_State is
23801 State_Elmt : Elmt_Id;
23804 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
23806 if Contains (Refined_States_Seen, State_Id) then
23808 ("duplicate refinement of state &", State, State_Id);
23812 -- Inspect the abstract states defined in the package declaration
23813 -- looking for a match.
23815 State_Elmt := First_Elmt (Available_States);
23816 while Present (State_Elmt) loop
23818 -- A valid abstract state is being refined in the body. Add
23819 -- the state to the list of processed refined states to aid
23820 -- with the detection of duplicate refinements. Remove the
23821 -- state from Available_States to signal that it has already
23824 if Node (State_Elmt) = State_Id then
23825 Add_Item (State_Id, Refined_States_Seen);
23826 Remove_Elmt (Available_States, State_Elmt);
23830 Next_Elmt (State_Elmt);
23833 -- If we get here, we are refining a state that is not defined in
23834 -- the package declaration.
23836 Error_Msg_Name_1 := Chars (Spec_Id);
23838 ("cannot refine state, & is not defined in package %",
23840 end Check_Matching_State;
23842 --------------------------------
23843 -- Report_Unused_Constituents --
23844 --------------------------------
23846 procedure Report_Unused_Constituents (Constits : Elist_Id) is
23847 Constit_Elmt : Elmt_Id;
23848 Constit_Id : Entity_Id;
23849 Posted : Boolean := False;
23852 if Present (Constits) then
23853 Constit_Elmt := First_Elmt (Constits);
23854 while Present (Constit_Elmt) loop
23855 Constit_Id := Node (Constit_Elmt);
23857 -- Generate an error message of the form:
23859 -- state ... has unused Part_Of constituents
23860 -- abstract state ... defined at ...
23861 -- variable ... defined at ...
23866 ("state & has unused Part_Of constituents",
23870 Error_Msg_Sloc := Sloc (Constit_Id);
23872 if Ekind (Constit_Id) = E_Abstract_State then
23874 ("\abstract state & defined #", State, Constit_Id);
23877 ("\variable & defined #", State, Constit_Id);
23880 Next_Elmt (Constit_Elmt);
23883 end Report_Unused_Constituents;
23885 -- Local declarations
23887 Body_Ref : Node_Id;
23888 Body_Ref_Elmt : Elmt_Id;
23890 Extra_State : Node_Id;
23892 -- Start of processing for Analyze_Refinement_Clause
23895 -- A refinement clause appears as a component association where the
23896 -- sole choice is the state and the expressions are the constituents.
23898 if Nkind (Clause) /= N_Component_Association then
23899 Error_Msg_N ("malformed state refinement clause", Clause);
23903 -- Analyze the state name of a refinement clause
23905 State := First (Choices (Clause));
23908 Resolve_State (State);
23910 -- Ensure that the state name denotes a valid abstract state that is
23911 -- defined in the spec of the related package.
23913 if Is_Entity_Name (State) then
23914 State_Id := Entity_Of (State);
23916 -- Catch any attempts to re-refine a state or refine a state that
23917 -- is not defined in the package declaration.
23919 if Ekind (State_Id) = E_Abstract_State then
23920 Check_Matching_State;
23923 ("& must denote an abstract state", State, State_Id);
23927 -- References to a state with visible refinement are illegal.
23928 -- When nested packages are involved, detecting such references is
23929 -- tricky because pragma Refined_State is analyzed later than the
23930 -- offending pragma Depends or Global. References that occur in
23931 -- such nested context are stored in a list. Emit errors for all
23932 -- references found in Body_References (SPARK RM 6.1.4(8)).
23934 if Present (Body_References (State_Id)) then
23935 Body_Ref_Elmt := First_Elmt (Body_References (State_Id));
23936 while Present (Body_Ref_Elmt) loop
23937 Body_Ref := Node (Body_Ref_Elmt);
23939 Error_Msg_N ("reference to & not allowed", Body_Ref);
23940 Error_Msg_Sloc := Sloc (State);
23941 Error_Msg_N ("\refinement of & is visible#", Body_Ref);
23943 Next_Elmt (Body_Ref_Elmt);
23947 -- The state name is illegal
23950 Error_Msg_N ("malformed state name in refinement clause", State);
23954 -- A refinement clause may only refine one state at a time
23956 Extra_State := Next (State);
23958 if Present (Extra_State) then
23960 ("refinement clause cannot cover multiple states", Extra_State);
23963 -- Replicate the Part_Of constituents of the refined state because
23964 -- the algorithm will consume items.
23966 Part_Of_Constits := New_Copy_Elist (Part_Of_Constituents (State_Id));
23968 -- Analyze all constituents of the refinement. Multiple constituents
23969 -- appear as an aggregate.
23971 Constit := Expression (Clause);
23973 if Nkind (Constit) = N_Aggregate then
23974 if Present (Component_Associations (Constit)) then
23976 ("constituents of refinement clause must appear in "
23977 & "positional form", Constit);
23979 else pragma Assert (Present (Expressions (Constit)));
23980 Constit := First (Expressions (Constit));
23981 while Present (Constit) loop
23982 Analyze_Constituent (Constit);
23988 -- Various forms of a single constituent. Note that these may include
23989 -- malformed constituents.
23992 Analyze_Constituent (Constit);
23995 -- A refined external state is subject to special rules with respect
23996 -- to its properties and constituents.
23998 if Is_External_State (State_Id) then
24000 -- The set of properties that all external constituents yield must
24001 -- match that of the refined state. There are two cases to detect:
24002 -- the refined state lacks a property or has an extra property.
24004 if External_Constit_Seen then
24005 Check_External_Property
24006 (Prop_Nam => Name_Async_Readers,
24007 Enabled => Async_Readers_Enabled (State_Id),
24008 Constit => AR_Constit);
24010 Check_External_Property
24011 (Prop_Nam => Name_Async_Writers,
24012 Enabled => Async_Writers_Enabled (State_Id),
24013 Constit => AW_Constit);
24015 Check_External_Property
24016 (Prop_Nam => Name_Effective_Reads,
24017 Enabled => Effective_Reads_Enabled (State_Id),
24018 Constit => ER_Constit);
24020 Check_External_Property
24021 (Prop_Nam => Name_Effective_Writes,
24022 Enabled => Effective_Writes_Enabled (State_Id),
24023 Constit => EW_Constit);
24025 -- An external state may be refined to null (SPARK RM 7.2.8(2))
24027 elsif Null_Seen then
24030 -- The external state has constituents, but none of them are
24031 -- external (SPARK RM 7.2.8(2)).
24035 ("external state & requires at least one external "
24036 & "constituent or null refinement", State, State_Id);
24039 -- When a refined state is not external, it should not have external
24040 -- constituents (SPARK RM 7.2.8(1)).
24042 elsif External_Constit_Seen then
24044 ("non-external state & cannot contain external constituents in "
24045 & "refinement", State, State_Id);
24048 -- Ensure that all Part_Of candidate constituents have been mentioned
24049 -- in the refinement clause.
24051 Report_Unused_Constituents (Part_Of_Constits);
24052 end Analyze_Refinement_Clause;
24054 ----------------------------------
24055 -- Check_Refinement_List_Syntax --
24056 ----------------------------------
24058 procedure Check_Refinement_List_Syntax (List : Node_Id) is
24059 procedure Check_Clause_Syntax (Clause : Node_Id);
24060 -- Verify the syntax of state refinement clause Clause
24062 -------------------------
24063 -- Check_Clause_Syntax --
24064 -------------------------
24066 procedure Check_Clause_Syntax (Clause : Node_Id) is
24067 Constits : constant Node_Id := Expression (Clause);
24071 -- State to be refined
24073 Check_Item_Syntax (First (Choices (Clause)));
24075 -- Multiple constituents
24077 if Nkind (Constits) = N_Aggregate
24078 and then Present (Expressions (Constits))
24080 Constit := First (Expressions (Constits));
24081 while Present (Constit) loop
24082 Check_Item_Syntax (Constit);
24086 -- Single constituent
24089 Check_Item_Syntax (Constits);
24091 end Check_Clause_Syntax;
24097 -- Start of processing for Check_Refinement_List_Syntax
24100 -- Multiple state refinement clauses
24102 if Nkind (List) = N_Aggregate
24103 and then Present (Component_Associations (List))
24105 Clause := First (Component_Associations (List));
24106 while Present (Clause) loop
24107 Check_Clause_Syntax (Clause);
24111 -- Single state refinement clause
24114 Check_Clause_Syntax (List);
24116 end Check_Refinement_List_Syntax;
24118 -------------------------
24119 -- Collect_Body_States --
24120 -------------------------
24122 function Collect_Body_States (Pack_Id : Entity_Id) return Elist_Id is
24123 Result : Elist_Id := No_Elist;
24124 -- A list containing all body states of Pack_Id
24126 procedure Collect_Visible_States (Pack_Id : Entity_Id);
24127 -- Gather the entities of all abstract states and variables declared
24128 -- in the visible state space of package Pack_Id.
24130 ----------------------------
24131 -- Collect_Visible_States --
24132 ----------------------------
24134 procedure Collect_Visible_States (Pack_Id : Entity_Id) is
24135 Item_Id : Entity_Id;
24138 -- Traverse the entity chain of the package and inspect all
24141 Item_Id := First_Entity (Pack_Id);
24142 while Present (Item_Id) and then not In_Private_Part (Item_Id) loop
24144 -- Do not consider internally generated items as those cannot
24145 -- be named and participate in refinement.
24147 if not Comes_From_Source (Item_Id) then
24150 elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
24151 Add_Item (Item_Id, Result);
24153 -- Recursively gather the visible states of a nested package
24155 elsif Ekind (Item_Id) = E_Package then
24156 Collect_Visible_States (Item_Id);
24159 Next_Entity (Item_Id);
24161 end Collect_Visible_States;
24165 Pack_Body : constant Node_Id :=
24166 Declaration_Node (Body_Entity (Pack_Id));
24168 Item_Id : Entity_Id;
24170 -- Start of processing for Collect_Body_States
24173 -- Inspect the declarations of the body looking for source variables,
24174 -- packages and package instantiations.
24176 Decl := First (Declarations (Pack_Body));
24177 while Present (Decl) loop
24178 if Nkind (Decl) = N_Object_Declaration then
24179 Item_Id := Defining_Entity (Decl);
24181 -- Capture source variables only as internally generated
24182 -- temporaries cannot be named and participate in refinement.
24184 if Ekind (Item_Id) = E_Variable
24185 and then Comes_From_Source (Item_Id)
24187 Add_Item (Item_Id, Result);
24190 elsif Nkind (Decl) = N_Package_Declaration then
24191 Item_Id := Defining_Entity (Decl);
24193 -- Capture the visible abstract states and variables of a
24194 -- source package [instantiation].
24196 if Comes_From_Source (Item_Id) then
24197 Collect_Visible_States (Item_Id);
24205 end Collect_Body_States;
24207 -----------------------------
24208 -- Report_Unrefined_States --
24209 -----------------------------
24211 procedure Report_Unrefined_States (States : Elist_Id) is
24212 State_Elmt : Elmt_Id;
24215 if Present (States) then
24216 State_Elmt := First_Elmt (States);
24217 while Present (State_Elmt) loop
24219 ("abstract state & must be refined", Node (State_Elmt));
24221 Next_Elmt (State_Elmt);
24224 end Report_Unrefined_States;
24226 --------------------------
24227 -- Report_Unused_States --
24228 --------------------------
24230 procedure Report_Unused_States (States : Elist_Id) is
24231 Posted : Boolean := False;
24232 State_Elmt : Elmt_Id;
24233 State_Id : Entity_Id;
24236 if Present (States) then
24237 State_Elmt := First_Elmt (States);
24238 while Present (State_Elmt) loop
24239 State_Id := Node (State_Elmt);
24241 -- Generate an error message of the form:
24243 -- body of package ... has unused hidden states
24244 -- abstract state ... defined at ...
24245 -- variable ... defined at ...
24250 ("body of package & has unused hidden states", Body_Id);
24253 Error_Msg_Sloc := Sloc (State_Id);
24255 if Ekind (State_Id) = E_Abstract_State then
24257 ("\abstract state & defined #", Body_Id, State_Id);
24260 ("\variable & defined #", Body_Id, State_Id);
24263 Next_Elmt (State_Elmt);
24266 end Report_Unused_States;
24268 -- Local declarations
24270 Body_Decl : constant Node_Id := Parent (N);
24271 Clauses : constant Node_Id :=
24272 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
24275 -- Start of processing for Analyze_Refined_State_In_Decl_Part
24280 -- Verify the syntax of pragma Refined_State when SPARK checks are
24281 -- suppressed. Semantic analysis is disabled in this mode.
24283 if SPARK_Mode = Off then
24284 Check_Refinement_List_Syntax (Clauses);
24288 Body_Id := Defining_Entity (Body_Decl);
24289 Spec_Id := Corresponding_Spec (Body_Decl);
24291 -- Replicate the abstract states declared by the package because the
24292 -- matching algorithm will consume states.
24294 Available_States := New_Copy_Elist (Abstract_States (Spec_Id));
24296 -- Gather all abstract states and variables declared in the visible
24297 -- state space of the package body. These items must be utilized as
24298 -- constituents in a state refinement.
24300 Body_States := Collect_Body_States (Spec_Id);
24302 -- Multiple non-null state refinements appear as an aggregate
24304 if Nkind (Clauses) = N_Aggregate then
24305 if Present (Expressions (Clauses)) then
24307 ("state refinements must appear as component associations",
24310 else pragma Assert (Present (Component_Associations (Clauses)));
24311 Clause := First (Component_Associations (Clauses));
24312 while Present (Clause) loop
24313 Analyze_Refinement_Clause (Clause);
24319 -- Various forms of a single state refinement. Note that these may
24320 -- include malformed refinements.
24323 Analyze_Refinement_Clause (Clauses);
24326 -- List all abstract states that were left unrefined
24328 Report_Unrefined_States (Available_States);
24330 -- Ensure that all abstract states and variables declared in the body
24331 -- state space of the related package are utilized as constituents.
24333 Report_Unused_States (Body_States);
24334 end Analyze_Refined_State_In_Decl_Part;
24336 ------------------------------------
24337 -- Analyze_Test_Case_In_Decl_Part --
24338 ------------------------------------
24340 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id; S : Entity_Id) is
24342 -- Install formals and push subprogram spec onto scope stack so that we
24343 -- can see the formals from the pragma.
24346 Install_Formals (S);
24348 -- Preanalyze the boolean expressions, we treat these as spec
24349 -- expressions (i.e. similar to a default expression).
24351 if Pragma_Name (N) = Name_Test_Case then
24352 Preanalyze_CTC_Args
24354 Get_Requires_From_CTC_Pragma (N),
24355 Get_Ensures_From_CTC_Pragma (N));
24358 -- Remove the subprogram from the scope stack now that the pre-analysis
24359 -- of the expressions in the contract case or test case is done.
24362 end Analyze_Test_Case_In_Decl_Part;
24368 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is
24373 if Present (List) then
24374 Elmt := First_Elmt (List);
24375 while Present (Elmt) loop
24376 if Nkind (Node (Elmt)) = N_Defining_Identifier then
24379 Id := Entity_Of (Node (Elmt));
24382 if Id = Item_Id then
24393 -----------------------------
24394 -- Check_Applicable_Policy --
24395 -----------------------------
24397 procedure Check_Applicable_Policy (N : Node_Id) is
24401 Ename : constant Name_Id := Original_Aspect_Name (N);
24404 -- No effect if not valid assertion kind name
24406 if not Is_Valid_Assertion_Kind (Ename) then
24410 -- Loop through entries in check policy list
24412 PP := Opt.Check_Policy_List;
24413 while Present (PP) loop
24415 PPA : constant List_Id := Pragma_Argument_Associations (PP);
24416 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
24420 or else Pnm = Name_Assertion
24421 or else (Pnm = Name_Statement_Assertions
24422 and then Nam_In (Ename, Name_Assert,
24423 Name_Assert_And_Cut,
24425 Name_Loop_Invariant,
24426 Name_Loop_Variant))
24428 Policy := Chars (Get_Pragma_Arg (Last (PPA)));
24431 when Name_Off | Name_Ignore =>
24432 Set_Is_Ignored (N, True);
24433 Set_Is_Checked (N, False);
24435 when Name_On | Name_Check =>
24436 Set_Is_Checked (N, True);
24437 Set_Is_Ignored (N, False);
24439 when Name_Disable =>
24440 Set_Is_Ignored (N, True);
24441 Set_Is_Checked (N, False);
24442 Set_Is_Disabled (N, True);
24444 -- That should be exhaustive, the null here is a defence
24445 -- against a malformed tree from previous errors.
24454 PP := Next_Pragma (PP);
24458 -- If there are no specific entries that matched, then we let the
24459 -- setting of assertions govern. Note that this provides the needed
24460 -- compatibility with the RM for the cases of assertion, invariant,
24461 -- precondition, predicate, and postcondition.
24463 if Assertions_Enabled then
24464 Set_Is_Checked (N, True);
24465 Set_Is_Ignored (N, False);
24467 Set_Is_Checked (N, False);
24468 Set_Is_Ignored (N, True);
24470 end Check_Applicable_Policy;
24472 ----------------------------------
24473 -- Check_Dependence_List_Syntax --
24474 ----------------------------------
24476 procedure Check_Dependence_List_Syntax (List : Node_Id) is
24477 procedure Check_Clause_Syntax (Clause : Node_Id);
24478 -- Verify the syntax of a dependency clause Clause
24480 -------------------------
24481 -- Check_Clause_Syntax --
24482 -------------------------
24484 procedure Check_Clause_Syntax (Clause : Node_Id) is
24492 Output := First (Choices (Clause));
24493 while Present (Output) loop
24494 Check_Item_Syntax (Output);
24498 Inputs := Expression (Clause);
24500 -- A self-dependency appears as operator "+"
24502 if Nkind (Inputs) = N_Op_Plus then
24503 Inputs := Right_Opnd (Inputs);
24508 if Nkind (Inputs) = N_Aggregate then
24509 if Present (Expressions (Inputs)) then
24510 Input := First (Expressions (Inputs));
24511 while Present (Input) loop
24512 Check_Item_Syntax (Input);
24517 Error_Msg_N ("malformed input dependency list", Inputs);
24520 -- Single input item
24523 Check_Item_Syntax (Inputs);
24525 end Check_Clause_Syntax;
24531 -- Start of processing for Check_Dependence_List_Syntax
24534 -- Null dependency relation
24536 if Nkind (List) = N_Null then
24539 -- Verify the syntax of a single or multiple dependency clauses
24541 elsif Nkind (List) = N_Aggregate
24542 and then Present (Component_Associations (List))
24544 Clause := First (Component_Associations (List));
24545 while Present (Clause) loop
24546 if Has_Extra_Parentheses (Clause) then
24549 Check_Clause_Syntax (Clause);
24556 Error_Msg_N ("malformed dependency relation", List);
24558 end Check_Dependence_List_Syntax;
24560 -------------------------------
24561 -- Check_External_Properties --
24562 -------------------------------
24564 procedure Check_External_Properties
24572 -- All properties enabled
24574 if AR and AW and ER and EW then
24577 -- Async_Readers + Effective_Writes
24578 -- Async_Readers + Async_Writers + Effective_Writes
24580 elsif AR and EW and not ER then
24583 -- Async_Writers + Effective_Reads
24584 -- Async_Readers + Async_Writers + Effective_Reads
24586 elsif AW and ER and not EW then
24589 -- Async_Readers + Async_Writers
24591 elsif AR and AW and not ER and not EW then
24596 elsif AR and not AW and not ER and not EW then
24601 elsif AW and not AR and not ER and not EW then
24606 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
24609 end Check_External_Properties;
24611 ------------------------------
24612 -- Check_Global_List_Syntax --
24613 ------------------------------
24615 procedure Check_Global_List_Syntax (List : Node_Id) is
24620 -- Null global list
24622 if Nkind (List) = N_Null then
24625 -- Single global item
24627 elsif Nkind_In (List, N_Expanded_Name,
24629 N_Selected_Component)
24633 elsif Nkind (List) = N_Aggregate then
24635 -- Items in a simple global list
24637 if Present (Expressions (List)) then
24638 Item := First (Expressions (List));
24639 while Present (Item) loop
24640 Check_Item_Syntax (Item);
24644 -- Items in a moded global list
24646 elsif Present (Component_Associations (List)) then
24647 Assoc := First (Component_Associations (List));
24648 while Present (Assoc) loop
24649 Check_Item_Syntax (First (Choices (Assoc)));
24650 Check_Global_List_Syntax (Expression (Assoc));
24656 -- Anything else is an error
24659 Error_Msg_N ("malformed global list", List);
24661 end Check_Global_List_Syntax;
24663 -----------------------
24664 -- Check_Item_Syntax --
24665 -----------------------
24667 procedure Check_Item_Syntax (Item : Node_Id) is
24669 -- Null can appear in various annotation lists to denote a missing or
24670 -- optional relation.
24672 if Nkind (Item) = N_Null then
24675 -- Formal parameter, state or variable nodes
24677 elsif Nkind_In (Item, N_Expanded_Name,
24679 N_Selected_Component)
24683 -- Attribute 'Result can appear in annotations to denote the outcome of
24684 -- a function call.
24686 elsif Is_Attribute_Result (Item) then
24689 -- Any other node cannot possibly denote a legal SPARK item
24692 Error_Msg_N ("malformed item", Item);
24694 end Check_Item_Syntax;
24700 function Check_Kind (Nam : Name_Id) return Name_Id is
24704 -- Loop through entries in check policy list
24706 PP := Opt.Check_Policy_List;
24707 while Present (PP) loop
24709 PPA : constant List_Id := Pragma_Argument_Associations (PP);
24710 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
24714 or else (Pnm = Name_Assertion
24715 and then Is_Valid_Assertion_Kind (Nam))
24716 or else (Pnm = Name_Statement_Assertions
24717 and then Nam_In (Nam, Name_Assert,
24718 Name_Assert_And_Cut,
24720 Name_Loop_Invariant,
24721 Name_Loop_Variant))
24723 case (Chars (Get_Pragma_Arg (Last (PPA)))) is
24724 when Name_On | Name_Check =>
24726 when Name_Off | Name_Ignore =>
24727 return Name_Ignore;
24728 when Name_Disable =>
24729 return Name_Disable;
24731 raise Program_Error;
24735 PP := Next_Pragma (PP);
24740 -- If there are no specific entries that matched, then we let the
24741 -- setting of assertions govern. Note that this provides the needed
24742 -- compatibility with the RM for the cases of assertion, invariant,
24743 -- precondition, predicate, and postcondition.
24745 if Assertions_Enabled then
24748 return Name_Ignore;
24752 ---------------------------
24753 -- Check_Missing_Part_Of --
24754 ---------------------------
24756 procedure Check_Missing_Part_Of (Item_Id : Entity_Id) is
24757 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean;
24758 -- Determine whether a package denoted by Pack_Id declares at least one
24761 -----------------------
24762 -- Has_Visible_State --
24763 -----------------------
24765 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean is
24766 Item_Id : Entity_Id;
24769 -- Traverse the entity chain of the package trying to find at least
24770 -- one visible abstract state, variable or a package [instantiation]
24771 -- that declares a visible state.
24773 Item_Id := First_Entity (Pack_Id);
24774 while Present (Item_Id)
24775 and then not In_Private_Part (Item_Id)
24777 -- Do not consider internally generated items
24779 if not Comes_From_Source (Item_Id) then
24782 -- A visible state has been found
24784 elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
24787 -- Recursively peek into nested packages and instantiations
24789 elsif Ekind (Item_Id) = E_Package
24790 and then Has_Visible_State (Item_Id)
24795 Next_Entity (Item_Id);
24799 end Has_Visible_State;
24803 Pack_Id : Entity_Id;
24804 Placement : State_Space_Kind;
24806 -- Start of processing for Check_Missing_Part_Of
24809 -- Do not consider internally generated entities as these can never
24810 -- have a Part_Of indicator.
24812 if not Comes_From_Source (Item_Id) then
24815 -- Perform these checks only when SPARK_Mode is enabled as they will
24816 -- interfere with standard Ada rules and produce false positives.
24818 elsif SPARK_Mode /= On then
24822 -- Find where the abstract state, variable or package instantiation
24823 -- lives with respect to the state space.
24825 Find_Placement_In_State_Space
24826 (Item_Id => Item_Id,
24827 Placement => Placement,
24828 Pack_Id => Pack_Id);
24830 -- Items that appear in a non-package construct (subprogram, block, etc)
24831 -- do not require a Part_Of indicator because they can never act as a
24834 if Placement = Not_In_Package then
24837 -- An item declared in the body state space of a package always act as a
24838 -- constituent and does not need explicit Part_Of indicator.
24840 elsif Placement = Body_State_Space then
24843 -- In general an item declared in the visible state space of a package
24844 -- does not require a Part_Of indicator. The only exception is when the
24845 -- related package is a private child unit in which case Part_Of must
24846 -- denote a state in the parent unit or in one of its descendants.
24848 elsif Placement = Visible_State_Space then
24849 if Is_Child_Unit (Pack_Id)
24850 and then Is_Private_Descendant (Pack_Id)
24852 -- A package instantiation does not need a Part_Of indicator when
24853 -- the related generic template has no visible state.
24855 if Ekind (Item_Id) = E_Package
24856 and then Is_Generic_Instance (Item_Id)
24857 and then not Has_Visible_State (Item_Id)
24861 -- All other cases require Part_Of
24865 ("indicator Part_Of is required in this context "
24866 & "(SPARK RM 7.2.6(3))", Item_Id);
24867 Error_Msg_Name_1 := Chars (Pack_Id);
24869 ("\& is declared in the visible part of private child "
24870 & "unit %", Item_Id);
24874 -- When the item appears in the private state space of a packge, it must
24875 -- be a part of some state declared by the said package.
24877 else pragma Assert (Placement = Private_State_Space);
24879 -- The related package does not declare a state, the item cannot act
24880 -- as a Part_Of constituent.
24882 if No (Get_Pragma (Pack_Id, Pragma_Abstract_State)) then
24885 -- A package instantiation does not need a Part_Of indicator when the
24886 -- related generic template has no visible state.
24888 elsif Ekind (Pack_Id) = E_Package
24889 and then Is_Generic_Instance (Pack_Id)
24890 and then not Has_Visible_State (Pack_Id)
24894 -- All other cases require Part_Of
24898 ("indicator Part_Of is required in this context "
24899 & "(SPARK RM 7.2.6(2))", Item_Id);
24900 Error_Msg_Name_1 := Chars (Pack_Id);
24902 ("\& is declared in the private part of package %", Item_Id);
24905 end Check_Missing_Part_Of;
24907 ---------------------------------
24908 -- Check_SPARK_Aspect_For_ASIS --
24909 ---------------------------------
24911 procedure Check_SPARK_Aspect_For_ASIS (N : Node_Id) is
24915 if ASIS_Mode and then From_Aspect_Specification (N) then
24916 Expr := Expression (Corresponding_Aspect (N));
24917 if Nkind (Expr) /= N_Aggregate then
24918 Preanalyze_And_Resolve (Expr);
24922 Comps : constant List_Id := Component_Associations (Expr);
24923 Exprs : constant List_Id := Expressions (Expr);
24928 E := First (Exprs);
24929 while Present (E) loop
24934 C := First (Comps);
24935 while Present (C) loop
24936 Analyze (Expression (C));
24942 end Check_SPARK_Aspect_For_ASIS;
24944 -------------------------------------
24945 -- Check_State_And_Constituent_Use --
24946 -------------------------------------
24948 procedure Check_State_And_Constituent_Use
24949 (States : Elist_Id;
24950 Constits : Elist_Id;
24953 function Find_Encapsulating_State
24954 (Constit_Id : Entity_Id) return Entity_Id;
24955 -- Given the entity of a constituent, try to find a corresponding
24956 -- encapsulating state that appears in the same context. The routine
24957 -- returns Empty is no such state is found.
24959 ------------------------------
24960 -- Find_Encapsulating_State --
24961 ------------------------------
24963 function Find_Encapsulating_State
24964 (Constit_Id : Entity_Id) return Entity_Id
24966 State_Id : Entity_Id;
24969 -- Since a constituent may be part of a larger constituent set, climb
24970 -- the encapsulated state chain looking for a state that appears in
24971 -- the same context.
24973 State_Id := Encapsulating_State (Constit_Id);
24974 while Present (State_Id) loop
24975 if Contains (States, State_Id) then
24979 State_Id := Encapsulating_State (State_Id);
24983 end Find_Encapsulating_State;
24987 Constit_Elmt : Elmt_Id;
24988 Constit_Id : Entity_Id;
24989 State_Id : Entity_Id;
24991 -- Start of processing for Check_State_And_Constituent_Use
24994 -- Nothing to do if there are no states or constituents
24996 if No (States) or else No (Constits) then
25000 -- Inspect the list of constituents and try to determine whether its
25001 -- encapsulating state is in list States.
25003 Constit_Elmt := First_Elmt (Constits);
25004 while Present (Constit_Elmt) loop
25005 Constit_Id := Node (Constit_Elmt);
25007 -- Determine whether the constituent is part of an encapsulating
25008 -- state that appears in the same context and if this is the case,
25009 -- emit an error (SPARK RM 7.2.6(7)).
25011 State_Id := Find_Encapsulating_State (Constit_Id);
25013 if Present (State_Id) then
25014 Error_Msg_Name_1 := Chars (Constit_Id);
25016 ("cannot mention state & and its constituent % in the same "
25017 & "context", Context, State_Id);
25021 Next_Elmt (Constit_Elmt);
25023 end Check_State_And_Constituent_Use;
25025 --------------------------
25026 -- Collect_Global_Items --
25027 --------------------------
25029 procedure Collect_Global_Items
25031 In_Items : in out Elist_Id;
25032 In_Out_Items : in out Elist_Id;
25033 Out_Items : in out Elist_Id;
25034 Proof_In_Items : in out Elist_Id;
25035 Has_In_State : out Boolean;
25036 Has_In_Out_State : out Boolean;
25037 Has_Out_State : out Boolean;
25038 Has_Proof_In_State : out Boolean;
25039 Has_Null_State : out Boolean)
25041 procedure Process_Global_List
25043 Mode : Name_Id := Name_Input);
25044 -- Collect all items housed in a global list. Formal Mode denotes the
25045 -- current mode in effect.
25047 -------------------------
25048 -- Process_Global_List --
25049 -------------------------
25051 procedure Process_Global_List
25053 Mode : Name_Id := Name_Input)
25055 procedure Process_Global_Item (Item : Node_Id; Mode : Name_Id);
25056 -- Add a single item to the appropriate list. Formal Mode denotes the
25057 -- current mode in effect.
25059 -------------------------
25060 -- Process_Global_Item --
25061 -------------------------
25063 procedure Process_Global_Item (Item : Node_Id; Mode : Name_Id) is
25064 Item_Id : constant Entity_Id := Available_View (Entity_Of (Item));
25065 -- The above handles abstract views of variables and states built
25066 -- for limited with clauses.
25069 -- Signal that the global list contains at least one abstract
25070 -- state with a visible refinement. Note that the refinement may
25071 -- be null in which case there are no constituents.
25073 if Ekind (Item_Id) = E_Abstract_State then
25074 if Has_Null_Refinement (Item_Id) then
25075 Has_Null_State := True;
25077 elsif Has_Non_Null_Refinement (Item_Id) then
25078 if Mode = Name_Input then
25079 Has_In_State := True;
25080 elsif Mode = Name_In_Out then
25081 Has_In_Out_State := True;
25082 elsif Mode = Name_Output then
25083 Has_Out_State := True;
25084 elsif Mode = Name_Proof_In then
25085 Has_Proof_In_State := True;
25090 -- Add the item to the proper list
25092 if Mode = Name_Input then
25093 Add_Item (Item_Id, In_Items);
25094 elsif Mode = Name_In_Out then
25095 Add_Item (Item_Id, In_Out_Items);
25096 elsif Mode = Name_Output then
25097 Add_Item (Item_Id, Out_Items);
25098 elsif Mode = Name_Proof_In then
25099 Add_Item (Item_Id, Proof_In_Items);
25101 end Process_Global_Item;
25107 -- Start of processing for Process_Global_List
25110 if Nkind (List) = N_Null then
25113 -- Single global item declaration
25115 elsif Nkind_In (List, N_Expanded_Name,
25117 N_Selected_Component)
25119 Process_Global_Item (List, Mode);
25121 -- Single global list or moded global list declaration
25123 elsif Nkind (List) = N_Aggregate then
25125 -- The declaration of a simple global list appear as a collection
25128 if Present (Expressions (List)) then
25129 Item := First (Expressions (List));
25130 while Present (Item) loop
25131 Process_Global_Item (Item, Mode);
25136 -- The declaration of a moded global list appears as a collection
25137 -- of component associations where individual choices denote mode.
25139 elsif Present (Component_Associations (List)) then
25140 Item := First (Component_Associations (List));
25141 while Present (Item) loop
25142 Process_Global_List
25143 (List => Expression (Item),
25144 Mode => Chars (First (Choices (Item))));
25152 raise Program_Error;
25158 raise Program_Error;
25160 end Process_Global_List;
25164 Items : constant Node_Id :=
25165 Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
25167 -- Start of processing for Collect_Global_Items
25170 -- Assume that no states have been encountered
25172 Has_In_State := False;
25173 Has_In_Out_State := False;
25174 Has_Out_State := False;
25175 Has_Proof_In_State := False;
25176 Has_Null_State := False;
25178 Process_Global_List (Items);
25179 end Collect_Global_Items;
25181 ---------------------------------------
25182 -- Collect_Subprogram_Inputs_Outputs --
25183 ---------------------------------------
25185 procedure Collect_Subprogram_Inputs_Outputs
25186 (Subp_Id : Entity_Id;
25187 Subp_Inputs : in out Elist_Id;
25188 Subp_Outputs : in out Elist_Id;
25189 Global_Seen : out Boolean)
25191 procedure Collect_Global_List
25193 Mode : Name_Id := Name_Input);
25194 -- Collect all relevant items from a global list
25196 -------------------------
25197 -- Collect_Global_List --
25198 -------------------------
25200 procedure Collect_Global_List
25202 Mode : Name_Id := Name_Input)
25204 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id);
25205 -- Add an item to the proper subprogram input or output collection
25207 -------------------------
25208 -- Collect_Global_Item --
25209 -------------------------
25211 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is
25213 if Nam_In (Mode, Name_In_Out, Name_Input) then
25214 Add_Item (Item, Subp_Inputs);
25217 if Nam_In (Mode, Name_In_Out, Name_Output) then
25218 Add_Item (Item, Subp_Outputs);
25220 end Collect_Global_Item;
25227 -- Start of processing for Collect_Global_List
25230 if Nkind (List) = N_Null then
25233 -- Single global item declaration
25235 elsif Nkind_In (List, N_Expanded_Name,
25237 N_Selected_Component)
25239 Collect_Global_Item (List, Mode);
25241 -- Simple global list or moded global list declaration
25243 elsif Nkind (List) = N_Aggregate then
25244 if Present (Expressions (List)) then
25245 Item := First (Expressions (List));
25246 while Present (Item) loop
25247 Collect_Global_Item (Item, Mode);
25252 Assoc := First (Component_Associations (List));
25253 while Present (Assoc) loop
25254 Collect_Global_List
25255 (List => Expression (Assoc),
25256 Mode => Chars (First (Choices (Assoc))));
25264 raise Program_Error;
25266 end Collect_Global_List;
25270 Formal : Entity_Id;
25273 Spec_Id : Entity_Id;
25275 -- Start of processing for Collect_Subprogram_Inputs_Outputs
25278 Global_Seen := False;
25280 -- Find the entity of the corresponding spec when processing a body
25282 if Ekind (Subp_Id) = E_Subprogram_Body then
25283 Spec_Id := Corresponding_Spec (Parent (Parent (Subp_Id)));
25285 Spec_Id := Subp_Id;
25288 -- Process all formal parameters
25290 Formal := First_Formal (Spec_Id);
25291 while Present (Formal) loop
25292 if Ekind_In (Formal, E_In_Out_Parameter, E_In_Parameter) then
25293 Add_Item (Formal, Subp_Inputs);
25296 if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then
25297 Add_Item (Formal, Subp_Outputs);
25299 -- Out parameters can act as inputs when the related type is
25300 -- tagged, unconstrained array, unconstrained record or record
25301 -- with unconstrained components.
25303 if Ekind (Formal) = E_Out_Parameter
25304 and then Is_Unconstrained_Or_Tagged_Item (Formal)
25306 Add_Item (Formal, Subp_Inputs);
25310 Next_Formal (Formal);
25313 -- When processing a subprogram body, look for pragma Refined_Global as
25314 -- it provides finer granularity of inputs and outputs.
25316 if Ekind (Subp_Id) = E_Subprogram_Body then
25317 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global);
25319 -- Subprogram declaration case, look for pragma Global
25322 Global := Get_Pragma (Spec_Id, Pragma_Global);
25325 if Present (Global) then
25326 Global_Seen := True;
25327 List := Expression (First (Pragma_Argument_Associations (Global)));
25329 -- The pragma may not have been analyzed because of the arbitrary
25330 -- declaration order of aspects. Make sure that it is analyzed for
25331 -- the purposes of item extraction.
25333 if not Analyzed (List) then
25334 if Pragma_Name (Global) = Name_Refined_Global then
25335 Analyze_Refined_Global_In_Decl_Part (Global);
25337 Analyze_Global_In_Decl_Part (Global);
25341 -- Nothing to be done for a null global list
25343 if Nkind (List) /= N_Null then
25344 Collect_Global_List (List);
25347 end Collect_Subprogram_Inputs_Outputs;
25349 ---------------------------------
25350 -- Delay_Config_Pragma_Analyze --
25351 ---------------------------------
25353 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
25355 return Nam_In (Pragma_Name (N), Name_Interrupt_State,
25356 Name_Priority_Specific_Dispatching);
25357 end Delay_Config_Pragma_Analyze;
25359 -------------------------------------
25360 -- Find_Related_Subprogram_Or_Body --
25361 -------------------------------------
25363 function Find_Related_Subprogram_Or_Body
25365 Do_Checks : Boolean := False) return Node_Id
25367 Context : constant Node_Id := Parent (Prag);
25368 Nam : constant Name_Id := Pragma_Name (Prag);
25371 Look_For_Body : constant Boolean :=
25372 Nam_In (Nam, Name_Refined_Depends,
25373 Name_Refined_Global,
25374 Name_Refined_Post);
25375 -- Refinement pragmas must be associated with a subprogram body [stub]
25378 pragma Assert (Nkind (Prag) = N_Pragma);
25380 -- If the pragma is a byproduct of aspect expansion, return the related
25381 -- context of the original aspect.
25383 if Present (Corresponding_Aspect (Prag)) then
25384 return Parent (Corresponding_Aspect (Prag));
25387 -- Otherwise the pragma is a source construct, most likely part of a
25388 -- declarative list. Skip preceding declarations while looking for a
25389 -- proper subprogram declaration.
25391 pragma Assert (Is_List_Member (Prag));
25393 Stmt := Prev (Prag);
25394 while Present (Stmt) loop
25396 -- Skip prior pragmas, but check for duplicates
25398 if Nkind (Stmt) = N_Pragma then
25399 if Do_Checks and then Pragma_Name (Stmt) = Nam then
25400 Error_Msg_Name_1 := Nam;
25401 Error_Msg_Sloc := Sloc (Stmt);
25402 Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
25405 -- Emit an error when a refinement pragma appears on an expression
25406 -- function without a completion.
25409 and then Look_For_Body
25410 and then Nkind (Stmt) = N_Subprogram_Declaration
25411 and then Nkind (Original_Node (Stmt)) = N_Expression_Function
25412 and then not Has_Completion (Defining_Entity (Stmt))
25414 Error_Msg_Name_1 := Nam;
25416 ("pragma % cannot apply to a stand alone expression function",
25421 -- The refinement pragma applies to a subprogram body stub
25423 elsif Look_For_Body
25424 and then Nkind (Stmt) = N_Subprogram_Body_Stub
25428 -- Skip internally generated code
25430 elsif not Comes_From_Source (Stmt) then
25433 -- Return the current construct which is either a subprogram body,
25434 -- a subprogram declaration or is illegal.
25443 -- If we fall through, then the pragma was either the first declaration
25444 -- or it was preceded by other pragmas and no source constructs.
25446 -- The pragma is associated with a library-level subprogram
25448 if Nkind (Context) = N_Compilation_Unit_Aux then
25449 return Unit (Parent (Context));
25451 -- The pragma appears inside the declarative part of a subprogram body
25453 elsif Nkind (Context) = N_Subprogram_Body then
25456 -- No candidate subprogram [body] found
25461 end Find_Related_Subprogram_Or_Body;
25463 -------------------------
25464 -- Get_Base_Subprogram --
25465 -------------------------
25467 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
25468 Result : Entity_Id;
25471 -- Follow subprogram renaming chain
25475 if Is_Subprogram (Result)
25477 Nkind (Parent (Declaration_Node (Result))) =
25478 N_Subprogram_Renaming_Declaration
25479 and then Present (Alias (Result))
25481 Result := Alias (Result);
25485 end Get_Base_Subprogram;
25487 -----------------------
25488 -- Get_SPARK_Mode_Type --
25489 -----------------------
25491 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is
25493 if N = Name_On then
25495 elsif N = Name_Off then
25498 -- Any other argument is erroneous
25501 raise Program_Error;
25503 end Get_SPARK_Mode_Type;
25505 --------------------------------
25506 -- Get_SPARK_Mode_From_Pragma --
25507 --------------------------------
25509 function Get_SPARK_Mode_From_Pragma (N : Node_Id) return SPARK_Mode_Type is
25514 pragma Assert (Nkind (N) = N_Pragma);
25515 Args := Pragma_Argument_Associations (N);
25517 -- Extract the mode from the argument list
25519 if Present (Args) then
25520 Mode := First (Pragma_Argument_Associations (N));
25521 return Get_SPARK_Mode_Type (Chars (Get_Pragma_Arg (Mode)));
25523 -- If SPARK_Mode pragma has no argument, default is ON
25528 end Get_SPARK_Mode_From_Pragma;
25530 ---------------------------
25531 -- Has_Extra_Parentheses --
25532 ---------------------------
25534 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean is
25538 -- The aggregate should not have an expression list because a clause
25539 -- is always interpreted as a component association. The only way an
25540 -- expression list can sneak in is by adding extra parentheses around
25541 -- the individual clauses:
25543 -- Depends (Output => Input) -- proper form
25544 -- Depends ((Output => Input)) -- extra parentheses
25546 -- Since the extra parentheses are not allowed by the syntax of the
25547 -- pragma, flag them now to avoid emitting misleading errors down the
25550 if Nkind (Clause) = N_Aggregate
25551 and then Present (Expressions (Clause))
25553 Expr := First (Expressions (Clause));
25554 while Present (Expr) loop
25556 -- A dependency clause surrounded by extra parentheses appears
25557 -- as an aggregate of component associations with an optional
25558 -- Paren_Count set.
25560 if Nkind (Expr) = N_Aggregate
25561 and then Present (Component_Associations (Expr))
25564 ("dependency clause contains extra parentheses", Expr);
25566 -- Otherwise the expression is a malformed construct
25569 Error_Msg_N ("malformed dependency clause", Expr);
25579 end Has_Extra_Parentheses;
25585 procedure Initialize is
25590 -----------------------------
25591 -- Is_Config_Static_String --
25592 -----------------------------
25594 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
25596 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
25597 -- This is an internal recursive function that is just like the outer
25598 -- function except that it adds the string to the name buffer rather
25599 -- than placing the string in the name buffer.
25601 ------------------------------
25602 -- Add_Config_Static_String --
25603 ------------------------------
25605 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
25612 if Nkind (N) = N_Op_Concat then
25613 if Add_Config_Static_String (Left_Opnd (N)) then
25614 N := Right_Opnd (N);
25620 if Nkind (N) /= N_String_Literal then
25621 Error_Msg_N ("string literal expected for pragma argument", N);
25625 for J in 1 .. String_Length (Strval (N)) loop
25626 C := Get_String_Char (Strval (N), J);
25628 if not In_Character_Range (C) then
25630 ("string literal contains invalid wide character",
25631 Sloc (N) + 1 + Source_Ptr (J));
25635 Add_Char_To_Name_Buffer (Get_Character (C));
25640 end Add_Config_Static_String;
25642 -- Start of processing for Is_Config_Static_String
25647 return Add_Config_Static_String (Arg);
25648 end Is_Config_Static_String;
25650 -------------------------------
25651 -- Is_Elaboration_SPARK_Mode --
25652 -------------------------------
25654 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is
25657 (Nkind (N) = N_Pragma
25658 and then Pragma_Name (N) = Name_SPARK_Mode
25659 and then Is_List_Member (N));
25661 -- Pragma SPARK_Mode affects the elaboration of a package body when it
25662 -- appears in the statement part of the body.
25665 Present (Parent (N))
25666 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
25667 and then List_Containing (N) = Statements (Parent (N))
25668 and then Present (Parent (Parent (N)))
25669 and then Nkind (Parent (Parent (N))) = N_Package_Body;
25670 end Is_Elaboration_SPARK_Mode;
25672 -----------------------------------------
25673 -- Is_Non_Significant_Pragma_Reference --
25674 -----------------------------------------
25676 -- This function makes use of the following static table which indicates
25677 -- whether appearance of some name in a given pragma is to be considered
25678 -- as a reference for the purposes of warnings about unreferenced objects.
25680 -- -1 indicates that references in any argument position are significant
25681 -- 0 indicates that appearance in any argument is not significant
25682 -- +n indicates that appearance as argument n is significant, but all
25683 -- other arguments are not significant
25684 -- 99 special processing required (e.g. for pragma Check)
25686 Sig_Flags : constant array (Pragma_Id) of Int :=
25687 (Pragma_AST_Entry => -1,
25688 Pragma_Abort_Defer => -1,
25689 Pragma_Abstract_State => -1,
25690 Pragma_Ada_83 => -1,
25691 Pragma_Ada_95 => -1,
25692 Pragma_Ada_05 => -1,
25693 Pragma_Ada_2005 => -1,
25694 Pragma_Ada_12 => -1,
25695 Pragma_Ada_2012 => -1,
25696 Pragma_All_Calls_Remote => -1,
25697 Pragma_Allow_Integer_Address => 0,
25698 Pragma_Annotate => -1,
25699 Pragma_Assert => -1,
25700 Pragma_Assert_And_Cut => -1,
25701 Pragma_Assertion_Policy => 0,
25702 Pragma_Assume => -1,
25703 Pragma_Assume_No_Invalid_Values => 0,
25704 Pragma_Async_Readers => 0,
25705 Pragma_Async_Writers => 0,
25706 Pragma_Asynchronous => -1,
25707 Pragma_Atomic => 0,
25708 Pragma_Atomic_Components => 0,
25709 Pragma_Attach_Handler => -1,
25710 Pragma_Attribute_Definition => +3,
25711 Pragma_Check => 99,
25712 Pragma_Check_Float_Overflow => 0,
25713 Pragma_Check_Name => 0,
25714 Pragma_Check_Policy => 0,
25715 Pragma_CIL_Constructor => -1,
25716 Pragma_CPP_Class => 0,
25717 Pragma_CPP_Constructor => 0,
25718 Pragma_CPP_Virtual => 0,
25719 Pragma_CPP_Vtable => 0,
25721 Pragma_C_Pass_By_Copy => 0,
25722 Pragma_Comment => 0,
25723 Pragma_Common_Object => -1,
25724 Pragma_Compile_Time_Error => -1,
25725 Pragma_Compile_Time_Warning => -1,
25726 Pragma_Compiler_Unit => 0,
25727 Pragma_Compiler_Unit_Warning => 0,
25728 Pragma_Complete_Representation => 0,
25729 Pragma_Complex_Representation => 0,
25730 Pragma_Component_Alignment => -1,
25731 Pragma_Contract_Cases => -1,
25732 Pragma_Controlled => 0,
25733 Pragma_Convention => 0,
25734 Pragma_Convention_Identifier => 0,
25735 Pragma_Debug => -1,
25736 Pragma_Debug_Policy => 0,
25737 Pragma_Detect_Blocking => -1,
25738 Pragma_Default_Storage_Pool => -1,
25739 Pragma_Depends => -1,
25740 Pragma_Disable_Atomic_Synchronization => -1,
25741 Pragma_Discard_Names => 0,
25742 Pragma_Dispatching_Domain => -1,
25743 Pragma_Effective_Reads => 0,
25744 Pragma_Effective_Writes => 0,
25745 Pragma_Elaborate => -1,
25746 Pragma_Elaborate_All => -1,
25747 Pragma_Elaborate_Body => -1,
25748 Pragma_Elaboration_Checks => -1,
25749 Pragma_Eliminate => -1,
25750 Pragma_Enable_Atomic_Synchronization => -1,
25751 Pragma_Export => -1,
25752 Pragma_Export_Exception => -1,
25753 Pragma_Export_Function => -1,
25754 Pragma_Export_Object => -1,
25755 Pragma_Export_Procedure => -1,
25756 Pragma_Export_Value => -1,
25757 Pragma_Export_Valued_Procedure => -1,
25758 Pragma_Extend_System => -1,
25759 Pragma_Extensions_Allowed => -1,
25760 Pragma_External => -1,
25761 Pragma_Favor_Top_Level => -1,
25762 Pragma_External_Name_Casing => -1,
25763 Pragma_Fast_Math => -1,
25764 Pragma_Finalize_Storage_Only => 0,
25765 Pragma_Float_Representation => 0,
25766 Pragma_Global => -1,
25767 Pragma_Ident => -1,
25768 Pragma_Implementation_Defined => -1,
25769 Pragma_Implemented => -1,
25770 Pragma_Implicit_Packing => 0,
25771 Pragma_Import => +2,
25772 Pragma_Import_Exception => 0,
25773 Pragma_Import_Function => 0,
25774 Pragma_Import_Object => 0,
25775 Pragma_Import_Procedure => 0,
25776 Pragma_Import_Valued_Procedure => 0,
25777 Pragma_Independent => 0,
25778 Pragma_Independent_Components => 0,
25779 Pragma_Initial_Condition => -1,
25780 Pragma_Initialize_Scalars => -1,
25781 Pragma_Initializes => -1,
25782 Pragma_Inline => 0,
25783 Pragma_Inline_Always => 0,
25784 Pragma_Inline_Generic => 0,
25785 Pragma_Inspection_Point => -1,
25786 Pragma_Interface => +2,
25787 Pragma_Interface_Name => +2,
25788 Pragma_Interrupt_Handler => -1,
25789 Pragma_Interrupt_Priority => -1,
25790 Pragma_Interrupt_State => -1,
25791 Pragma_Invariant => -1,
25792 Pragma_Java_Constructor => -1,
25793 Pragma_Java_Interface => -1,
25794 Pragma_Keep_Names => 0,
25795 Pragma_License => -1,
25796 Pragma_Link_With => -1,
25797 Pragma_Linker_Alias => -1,
25798 Pragma_Linker_Constructor => -1,
25799 Pragma_Linker_Destructor => -1,
25800 Pragma_Linker_Options => -1,
25801 Pragma_Linker_Section => -1,
25803 Pragma_Lock_Free => -1,
25804 Pragma_Locking_Policy => -1,
25805 Pragma_Long_Float => -1,
25806 Pragma_Loop_Invariant => -1,
25807 Pragma_Loop_Optimize => -1,
25808 Pragma_Loop_Variant => -1,
25809 Pragma_Machine_Attribute => -1,
25811 Pragma_Main_Storage => -1,
25812 Pragma_Memory_Size => -1,
25813 Pragma_No_Return => 0,
25814 Pragma_No_Body => 0,
25815 Pragma_No_Inline => 0,
25816 Pragma_No_Run_Time => -1,
25817 Pragma_No_Strict_Aliasing => -1,
25818 Pragma_Normalize_Scalars => -1,
25819 Pragma_Obsolescent => 0,
25820 Pragma_Optimize => -1,
25821 Pragma_Optimize_Alignment => -1,
25822 Pragma_Overflow_Mode => 0,
25823 Pragma_Overriding_Renamings => 0,
25824 Pragma_Ordered => 0,
25827 Pragma_Part_Of => -1,
25828 Pragma_Partition_Elaboration_Policy => -1,
25829 Pragma_Passive => -1,
25830 Pragma_Persistent_BSS => 0,
25831 Pragma_Polling => -1,
25833 Pragma_Postcondition => -1,
25834 Pragma_Post_Class => -1,
25836 Pragma_Precondition => -1,
25837 Pragma_Predicate => -1,
25838 Pragma_Preelaborable_Initialization => -1,
25839 Pragma_Preelaborate => -1,
25840 Pragma_Preelaborate_05 => -1,
25841 Pragma_Pre_Class => -1,
25842 Pragma_Priority => -1,
25843 Pragma_Priority_Specific_Dispatching => -1,
25844 Pragma_Profile => 0,
25845 Pragma_Profile_Warnings => 0,
25846 Pragma_Propagate_Exceptions => -1,
25847 Pragma_Provide_Shift_Operators => -1,
25848 Pragma_Psect_Object => -1,
25850 Pragma_Pure_05 => -1,
25851 Pragma_Pure_12 => -1,
25852 Pragma_Pure_Function => -1,
25853 Pragma_Queuing_Policy => -1,
25854 Pragma_Rational => -1,
25855 Pragma_Ravenscar => -1,
25856 Pragma_Refined_Depends => -1,
25857 Pragma_Refined_Global => -1,
25858 Pragma_Refined_Post => -1,
25859 Pragma_Refined_State => -1,
25860 Pragma_Relative_Deadline => -1,
25861 Pragma_Remote_Access_Type => -1,
25862 Pragma_Remote_Call_Interface => -1,
25863 Pragma_Remote_Types => -1,
25864 Pragma_Restricted_Run_Time => -1,
25865 Pragma_Restriction_Warnings => -1,
25866 Pragma_Restrictions => -1,
25867 Pragma_Reviewable => -1,
25868 Pragma_Short_Circuit_And_Or => -1,
25869 Pragma_Share_Generic => -1,
25870 Pragma_Shared => -1,
25871 Pragma_Shared_Passive => -1,
25872 Pragma_Short_Descriptors => 0,
25873 Pragma_Simple_Storage_Pool_Type => 0,
25874 Pragma_Source_File_Name => -1,
25875 Pragma_Source_File_Name_Project => -1,
25876 Pragma_Source_Reference => -1,
25877 Pragma_SPARK_Mode => 0,
25878 Pragma_Storage_Size => -1,
25879 Pragma_Storage_Unit => -1,
25880 Pragma_Static_Elaboration_Desired => -1,
25881 Pragma_Stream_Convert => -1,
25882 Pragma_Style_Checks => -1,
25883 Pragma_Subtitle => -1,
25884 Pragma_Suppress => 0,
25885 Pragma_Suppress_Exception_Locations => 0,
25886 Pragma_Suppress_All => -1,
25887 Pragma_Suppress_Debug_Info => 0,
25888 Pragma_Suppress_Initialization => 0,
25889 Pragma_System_Name => -1,
25890 Pragma_Task_Dispatching_Policy => -1,
25891 Pragma_Task_Info => -1,
25892 Pragma_Task_Name => -1,
25893 Pragma_Task_Storage => 0,
25894 Pragma_Test_Case => -1,
25895 Pragma_Thread_Local_Storage => 0,
25896 Pragma_Time_Slice => -1,
25897 Pragma_Title => -1,
25898 Pragma_Type_Invariant => -1,
25899 Pragma_Type_Invariant_Class => -1,
25900 Pragma_Unchecked_Union => 0,
25901 Pragma_Unimplemented_Unit => -1,
25902 Pragma_Universal_Aliasing => -1,
25903 Pragma_Universal_Data => -1,
25904 Pragma_Unmodified => -1,
25905 Pragma_Unreferenced => -1,
25906 Pragma_Unreferenced_Objects => -1,
25907 Pragma_Unreserve_All_Interrupts => -1,
25908 Pragma_Unsuppress => 0,
25909 Pragma_Use_VADS_Size => -1,
25910 Pragma_Validity_Checks => -1,
25911 Pragma_Volatile => 0,
25912 Pragma_Volatile_Components => 0,
25913 Pragma_Warning_As_Error => -1,
25914 Pragma_Warnings => -1,
25915 Pragma_Weak_External => -1,
25916 Pragma_Wide_Character_Encoding => 0,
25917 Unknown_Pragma => 0);
25919 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
25928 if Nkind (P) /= N_Pragma_Argument_Association then
25932 Id := Get_Pragma_Id (Parent (P));
25933 C := Sig_Flags (Id);
25945 -- For pragma Check, the first argument is not significant,
25946 -- the second and the third (if present) arguments are
25949 when Pragma_Check =>
25951 P = First (Pragma_Argument_Associations (Parent (P)));
25954 raise Program_Error;
25958 A := First (Pragma_Argument_Associations (Parent (P)));
25959 for J in 1 .. C - 1 loop
25967 return A = P; -- is this wrong way round ???
25970 end Is_Non_Significant_Pragma_Reference;
25972 ------------------------------
25973 -- Is_Pragma_String_Literal --
25974 ------------------------------
25976 -- This function returns true if the corresponding pragma argument is a
25977 -- static string expression. These are the only cases in which string
25978 -- literals can appear as pragma arguments. We also allow a string literal
25979 -- as the first argument to pragma Assert (although it will of course
25980 -- always generate a type error).
25982 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
25983 Pragn : constant Node_Id := Parent (Par);
25984 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
25985 Pname : constant Name_Id := Pragma_Name (Pragn);
25991 N := First (Assoc);
25998 if Pname = Name_Assert then
26001 elsif Pname = Name_Export then
26004 elsif Pname = Name_Ident then
26007 elsif Pname = Name_Import then
26010 elsif Pname = Name_Interface_Name then
26013 elsif Pname = Name_Linker_Alias then
26016 elsif Pname = Name_Linker_Section then
26019 elsif Pname = Name_Machine_Attribute then
26022 elsif Pname = Name_Source_File_Name then
26025 elsif Pname = Name_Source_Reference then
26028 elsif Pname = Name_Title then
26031 elsif Pname = Name_Subtitle then
26037 end Is_Pragma_String_Literal;
26039 ---------------------------
26040 -- Is_Private_SPARK_Mode --
26041 ---------------------------
26043 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is
26046 (Nkind (N) = N_Pragma
26047 and then Pragma_Name (N) = Name_SPARK_Mode
26048 and then Is_List_Member (N));
26050 -- For pragma SPARK_Mode to be private, it has to appear in the private
26051 -- declarations of a package.
26054 Present (Parent (N))
26055 and then Nkind (Parent (N)) = N_Package_Specification
26056 and then List_Containing (N) = Private_Declarations (Parent (N));
26057 end Is_Private_SPARK_Mode;
26059 -------------------------------------
26060 -- Is_Unconstrained_Or_Tagged_Item --
26061 -------------------------------------
26063 function Is_Unconstrained_Or_Tagged_Item
26064 (Item : Entity_Id) return Boolean
26066 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean;
26067 -- Determine whether record type Typ has at least one unconstrained
26070 ---------------------------------
26071 -- Has_Unconstrained_Component --
26072 ---------------------------------
26074 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is
26078 Comp := First_Component (Typ);
26079 while Present (Comp) loop
26080 if Is_Unconstrained_Or_Tagged_Item (Comp) then
26084 Next_Component (Comp);
26088 end Has_Unconstrained_Component;
26092 Typ : constant Entity_Id := Etype (Item);
26094 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
26097 if Is_Tagged_Type (Typ) then
26100 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
26103 elsif Is_Record_Type (Typ) then
26104 if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then
26107 return Has_Unconstrained_Component (Typ);
26113 end Is_Unconstrained_Or_Tagged_Item;
26115 -----------------------------
26116 -- Is_Valid_Assertion_Kind --
26117 -----------------------------
26119 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is
26126 Name_Static_Predicate |
26127 Name_Dynamic_Predicate |
26132 Name_Type_Invariant |
26133 Name_uType_Invariant |
26137 Name_Assert_And_Cut |
26139 Name_Contract_Cases |
26141 Name_Initial_Condition |
26144 Name_Loop_Invariant |
26145 Name_Loop_Variant |
26146 Name_Postcondition |
26147 Name_Precondition |
26149 Name_Refined_Post |
26150 Name_Statement_Assertions => return True;
26152 when others => return False;
26154 end Is_Valid_Assertion_Kind;
26156 -----------------------------------------
26157 -- Make_Aspect_For_PPC_In_Gen_Sub_Decl --
26158 -----------------------------------------
26160 procedure Make_Aspect_For_PPC_In_Gen_Sub_Decl (Decl : Node_Id) is
26161 Aspects : constant List_Id := New_List;
26162 Loc : constant Source_Ptr := Sloc (Decl);
26163 Or_Decl : constant Node_Id := Original_Node (Decl);
26165 Original_Aspects : List_Id;
26166 -- To capture global references, a copy of the created aspects must be
26167 -- inserted in the original tree.
26170 Prag_Arg_Ass : Node_Id;
26171 Prag_Id : Pragma_Id;
26174 -- Check for any PPC pragmas that appear within Decl
26176 Prag := Next (Decl);
26177 while Nkind (Prag) = N_Pragma loop
26178 Prag_Id := Get_Pragma_Id (Chars (Pragma_Identifier (Prag)));
26181 when Pragma_Postcondition | Pragma_Precondition =>
26182 Prag_Arg_Ass := First (Pragma_Argument_Associations (Prag));
26184 -- Make an aspect from any PPC pragma
26186 Append_To (Aspects,
26187 Make_Aspect_Specification (Loc,
26189 Make_Identifier (Loc, Chars (Pragma_Identifier (Prag))),
26191 Copy_Separate_Tree (Expression (Prag_Arg_Ass))));
26193 -- Generate the analysis information in the pragma expression
26194 -- and then set the pragma node analyzed to avoid any further
26197 Analyze (Expression (Prag_Arg_Ass));
26198 Set_Analyzed (Prag, True);
26200 when others => null;
26206 -- Set all new aspects into the generic declaration node
26208 if Is_Non_Empty_List (Aspects) then
26210 -- Create the list of aspects to be inserted in the original tree
26212 Original_Aspects := Copy_Separate_List (Aspects);
26214 -- Check if Decl already has aspects
26216 -- Attach the new lists of aspects to both the generic copy and the
26219 if Has_Aspects (Decl) then
26220 Append_List (Aspects, Aspect_Specifications (Decl));
26221 Append_List (Original_Aspects, Aspect_Specifications (Or_Decl));
26224 Set_Parent (Aspects, Decl);
26225 Set_Aspect_Specifications (Decl, Aspects);
26226 Set_Parent (Original_Aspects, Or_Decl);
26227 Set_Aspect_Specifications (Or_Decl, Original_Aspects);
26230 end Make_Aspect_For_PPC_In_Gen_Sub_Decl;
26232 -------------------------
26233 -- Preanalyze_CTC_Args --
26234 -------------------------
26236 procedure Preanalyze_CTC_Args (N, Arg_Req, Arg_Ens : Node_Id) is
26238 -- Preanalyze the boolean expressions, we treat these as spec
26239 -- expressions (i.e. similar to a default expression).
26241 if Present (Arg_Req) then
26242 Preanalyze_Assert_Expression
26243 (Get_Pragma_Arg (Arg_Req), Standard_Boolean);
26245 -- In ASIS mode, for a pragma generated from a source aspect, also
26246 -- analyze the original aspect expression.
26248 if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
26249 Preanalyze_Assert_Expression
26250 (Original_Node (Get_Pragma_Arg (Arg_Req)), Standard_Boolean);
26254 if Present (Arg_Ens) then
26255 Preanalyze_Assert_Expression
26256 (Get_Pragma_Arg (Arg_Ens), Standard_Boolean);
26258 -- In ASIS mode, for a pragma generated from a source aspect, also
26259 -- analyze the original aspect expression.
26261 if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
26262 Preanalyze_Assert_Expression
26263 (Original_Node (Get_Pragma_Arg (Arg_Ens)), Standard_Boolean);
26266 end Preanalyze_CTC_Args;
26268 --------------------------------------
26269 -- Process_Compilation_Unit_Pragmas --
26270 --------------------------------------
26272 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
26274 -- A special check for pragma Suppress_All, a very strange DEC pragma,
26275 -- strange because it comes at the end of the unit. Rational has the
26276 -- same name for a pragma, but treats it as a program unit pragma, In
26277 -- GNAT we just decide to allow it anywhere at all. If it appeared then
26278 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
26279 -- node, and we insert a pragma Suppress (All_Checks) at the start of
26280 -- the context clause to ensure the correct processing.
26282 if Has_Pragma_Suppress_All (N) then
26283 Prepend_To (Context_Items (N),
26284 Make_Pragma (Sloc (N),
26285 Chars => Name_Suppress,
26286 Pragma_Argument_Associations => New_List (
26287 Make_Pragma_Argument_Association (Sloc (N),
26288 Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
26291 -- Nothing else to do at the current time
26293 end Process_Compilation_Unit_Pragmas;
26295 ------------------------------------
26296 -- Record_Possible_Body_Reference --
26297 ------------------------------------
26299 procedure Record_Possible_Body_Reference
26300 (State_Id : Entity_Id;
26304 Spec_Id : Entity_Id;
26307 -- Ensure that we are dealing with a reference to a state
26309 pragma Assert (Ekind (State_Id) = E_Abstract_State);
26311 -- Climb the tree starting from the reference looking for a package body
26312 -- whose spec declares the referenced state. This criteria automatically
26313 -- excludes references in package specs which are legal. Note that it is
26314 -- not wise to emit an error now as the package body may lack pragma
26315 -- Refined_State or the referenced state may not be mentioned in the
26316 -- refinement. This approach avoids the generation of misleading errors.
26319 while Present (Context) loop
26320 if Nkind (Context) = N_Package_Body then
26321 Spec_Id := Corresponding_Spec (Context);
26323 if Present (Abstract_States (Spec_Id))
26324 and then Contains (Abstract_States (Spec_Id), State_Id)
26326 if No (Body_References (State_Id)) then
26327 Set_Body_References (State_Id, New_Elmt_List);
26330 Append_Elmt (Ref, Body_References (State_Id));
26335 Context := Parent (Context);
26337 end Record_Possible_Body_Reference;
26339 ------------------------------
26340 -- Relocate_Pragmas_To_Body --
26341 ------------------------------
26343 procedure Relocate_Pragmas_To_Body
26344 (Subp_Body : Node_Id;
26345 Target_Body : Node_Id := Empty)
26347 procedure Relocate_Pragma (Prag : Node_Id);
26348 -- Remove a single pragma from its current list and add it to the
26349 -- declarations of the proper body (either Subp_Body or Target_Body).
26351 ---------------------
26352 -- Relocate_Pragma --
26353 ---------------------
26355 procedure Relocate_Pragma (Prag : Node_Id) is
26360 -- When subprogram stubs or expression functions are involves, the
26361 -- destination declaration list belongs to the proper body.
26363 if Present (Target_Body) then
26364 Target := Target_Body;
26366 Target := Subp_Body;
26369 Decls := Declarations (Target);
26373 Set_Declarations (Target, Decls);
26376 -- Unhook the pragma from its current list
26379 Prepend (Prag, Decls);
26380 end Relocate_Pragma;
26384 Body_Id : constant Entity_Id :=
26385 Defining_Unit_Name (Specification (Subp_Body));
26386 Next_Stmt : Node_Id;
26389 -- Start of processing for Relocate_Pragmas_To_Body
26392 -- Do not process a body that comes from a separate unit as no construct
26393 -- can possibly follow it.
26395 if not Is_List_Member (Subp_Body) then
26398 -- Do not relocate pragmas that follow a stub if the stub does not have
26401 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub
26402 and then No (Target_Body)
26406 -- Do not process internally generated routine _Postconditions
26408 elsif Ekind (Body_Id) = E_Procedure
26409 and then Chars (Body_Id) = Name_uPostconditions
26414 -- Look at what is following the body. We are interested in certain kind
26415 -- of pragmas (either from source or byproducts of expansion) that can
26416 -- apply to a body [stub].
26418 Stmt := Next (Subp_Body);
26419 while Present (Stmt) loop
26421 -- Preserve the following statement for iteration purposes due to a
26422 -- possible relocation of a pragma.
26424 Next_Stmt := Next (Stmt);
26426 -- Move a candidate pragma following the body to the declarations of
26429 if Nkind (Stmt) = N_Pragma
26430 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt))
26432 Relocate_Pragma (Stmt);
26434 -- Skip internally generated code
26436 elsif not Comes_From_Source (Stmt) then
26439 -- No candidate pragmas are available for relocation
26447 end Relocate_Pragmas_To_Body;
26449 -------------------
26450 -- Resolve_State --
26451 -------------------
26453 procedure Resolve_State (N : Node_Id) is
26458 if Is_Entity_Name (N) and then Present (Entity (N)) then
26459 Func := Entity (N);
26461 -- Handle overloading of state names by functions. Traverse the
26462 -- homonym chain looking for an abstract state.
26464 if Ekind (Func) = E_Function and then Has_Homonym (Func) then
26465 State := Homonym (Func);
26466 while Present (State) loop
26468 -- Resolve the overloading by setting the proper entity of the
26469 -- reference to that of the state.
26471 if Ekind (State) = E_Abstract_State then
26472 Set_Etype (N, Standard_Void_Type);
26473 Set_Entity (N, State);
26474 Set_Associated_Node (N, State);
26478 State := Homonym (State);
26481 -- A function can never act as a state. If the homonym chain does
26482 -- not contain a corresponding state, then something went wrong in
26483 -- the overloading mechanism.
26485 raise Program_Error;
26490 ----------------------------
26491 -- Rewrite_Assertion_Kind --
26492 ----------------------------
26494 procedure Rewrite_Assertion_Kind (N : Node_Id) is
26498 if Nkind (N) = N_Attribute_Reference
26499 and then Attribute_Name (N) = Name_Class
26500 and then Nkind (Prefix (N)) = N_Identifier
26502 case Chars (Prefix (N)) is
26507 when Name_Type_Invariant =>
26508 Nam := Name_uType_Invariant;
26509 when Name_Invariant =>
26510 Nam := Name_uInvariant;
26515 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam));
26517 end Rewrite_Assertion_Kind;
26528 --------------------------------
26529 -- Set_Encoded_Interface_Name --
26530 --------------------------------
26532 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
26533 Str : constant String_Id := Strval (S);
26534 Len : constant Int := String_Length (Str);
26539 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
26542 -- Stores encoded value of character code CC. The encoding we use an
26543 -- underscore followed by four lower case hex digits.
26549 procedure Encode is
26551 Store_String_Char (Get_Char_Code ('_'));
26553 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
26555 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
26557 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
26559 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
26562 -- Start of processing for Set_Encoded_Interface_Name
26565 -- If first character is asterisk, this is a link name, and we leave it
26566 -- completely unmodified. We also ignore null strings (the latter case
26567 -- happens only in error cases) and no encoding should occur for Java or
26568 -- AAMP interface names.
26571 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
26572 or else VM_Target /= No_VM
26573 or else AAMP_On_Target
26575 Set_Interface_Name (E, S);
26580 CC := Get_String_Char (Str, J);
26582 exit when not In_Character_Range (CC);
26584 C := Get_Character (CC);
26586 exit when C /= '_' and then C /= '$'
26587 and then C not in '0' .. '9'
26588 and then C not in 'a' .. 'z'
26589 and then C not in 'A' .. 'Z';
26592 Set_Interface_Name (E, S);
26600 -- Here we need to encode. The encoding we use as follows:
26601 -- three underscores + four hex digits (lower case)
26605 for J in 1 .. String_Length (Str) loop
26606 CC := Get_String_Char (Str, J);
26608 if not In_Character_Range (CC) then
26611 C := Get_Character (CC);
26613 if C = '_' or else C = '$'
26614 or else C in '0' .. '9'
26615 or else C in 'a' .. 'z'
26616 or else C in 'A' .. 'Z'
26618 Store_String_Char (CC);
26625 Set_Interface_Name (E,
26626 Make_String_Literal (Sloc (S),
26627 Strval => End_String));
26629 end Set_Encoded_Interface_Name;
26631 -------------------
26632 -- Set_Unit_Name --
26633 -------------------
26635 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id) is
26640 if Nkind (N) = N_Identifier
26641 and then Nkind (With_Item) = N_Identifier
26643 Set_Entity (N, Entity (With_Item));
26645 elsif Nkind (N) = N_Selected_Component then
26646 Change_Selected_Component_To_Expanded_Name (N);
26647 Set_Entity (N, Entity (With_Item));
26648 Set_Entity (Selector_Name (N), Entity (N));
26650 Pref := Prefix (N);
26651 Scop := Scope (Entity (N));
26652 while Nkind (Pref) = N_Selected_Component loop
26653 Change_Selected_Component_To_Expanded_Name (Pref);
26654 Set_Entity (Selector_Name (Pref), Scop);
26655 Set_Entity (Pref, Scop);
26656 Pref := Prefix (Pref);
26657 Scop := Scope (Scop);
26660 Set_Entity (Pref, Scop);