1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2020, 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 Contracts; use Contracts;
37 with Csets; use Csets;
38 with Debug; use Debug;
39 with Einfo; use Einfo;
40 with Elists; use Elists;
41 with Errout; use Errout;
42 with Exp_Dist; use Exp_Dist;
43 with Exp_Util; use Exp_Util;
44 with Expander; use Expander;
45 with Freeze; use Freeze;
46 with Ghost; use Ghost;
47 with Gnatvsn; use Gnatvsn;
49 with Lib.Writ; use Lib.Writ;
50 with Lib.Xref; use Lib.Xref;
51 with Namet.Sp; use Namet.Sp;
52 with Nlists; use Nlists;
53 with Nmake; use Nmake;
54 with Output; use Output;
55 with Par_SCO; use Par_SCO;
56 with Restrict; use Restrict;
57 with Rident; use Rident;
58 with Rtsfind; use Rtsfind;
60 with Sem_Aux; use Sem_Aux;
61 with Sem_Ch3; use Sem_Ch3;
62 with Sem_Ch6; use Sem_Ch6;
63 with Sem_Ch8; use Sem_Ch8;
64 with Sem_Ch12; use Sem_Ch12;
65 with Sem_Ch13; use Sem_Ch13;
66 with Sem_Disp; use Sem_Disp;
67 with Sem_Dist; use Sem_Dist;
68 with Sem_Elab; use Sem_Elab;
69 with Sem_Elim; use Sem_Elim;
70 with Sem_Eval; use Sem_Eval;
71 with Sem_Intr; use Sem_Intr;
72 with Sem_Mech; use Sem_Mech;
73 with Sem_Res; use Sem_Res;
74 with Sem_Type; use Sem_Type;
75 with Sem_Util; use Sem_Util;
76 with Sem_Warn; use Sem_Warn;
77 with Stand; use Stand;
78 with Sinfo; use Sinfo;
79 with Sinfo.CN; use Sinfo.CN;
80 with Sinput; use Sinput;
81 with Stringt; use Stringt;
82 with Stylesw; use Stylesw;
84 with Targparm; use Targparm;
85 with Tbuild; use Tbuild;
87 with Uintp; use Uintp;
88 with Uname; use Uname;
89 with Urealp; use Urealp;
90 with Validsw; use Validsw;
91 with Warnsw; use Warnsw;
93 with System.Case_Util;
95 package body Sem_Prag is
97 ----------------------------------------------
98 -- Common Handling of Import-Export Pragmas --
99 ----------------------------------------------
101 -- In the following section, a number of Import_xxx and Export_xxx pragmas
102 -- are defined by GNAT. These are compatible with the DEC pragmas of the
103 -- same name, and all have the following common form and processing:
106 -- [Internal =>] LOCAL_NAME
107 -- [, [External =>] EXTERNAL_SYMBOL]
108 -- [, other optional parameters ]);
111 -- [Internal =>] LOCAL_NAME
112 -- [, [External =>] EXTERNAL_SYMBOL]
113 -- [, other optional parameters ]);
115 -- EXTERNAL_SYMBOL ::=
117 -- | static_string_EXPRESSION
119 -- The internal LOCAL_NAME designates the entity that is imported or
120 -- exported, and must refer to an entity in the current declarative
121 -- part (as required by the rules for LOCAL_NAME).
123 -- The external linker name is designated by the External parameter if
124 -- given, or the Internal parameter if not (if there is no External
125 -- parameter, the External parameter is a copy of the Internal name).
127 -- If the External parameter is given as a string, then this string is
128 -- treated as an external name (exactly as though it had been given as an
129 -- External_Name parameter for a normal Import pragma).
131 -- If the External parameter is given as an identifier (or there is no
132 -- External parameter, so that the Internal identifier is used), then
133 -- the external name is the characters of the identifier, translated
134 -- to all lower case letters.
136 -- Note: the external name specified or implied by any of these special
137 -- Import_xxx or Export_xxx pragmas override an external or link name
138 -- specified in a previous Import or Export pragma.
140 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
141 -- named notation, following the standard rules for subprogram calls, i.e.
142 -- parameters can be given in any order if named notation is used, and
143 -- positional and named notation can be mixed, subject to the rule that all
144 -- positional parameters must appear first.
146 -- Note: All these pragmas are implemented exactly following the DEC design
147 -- and implementation and are intended to be fully compatible with the use
148 -- of these pragmas in the DEC Ada compiler.
150 --------------------------------------------
151 -- Checking for Duplicated External Names --
152 --------------------------------------------
154 -- It is suspicious if two separate Export pragmas use the same external
155 -- name. The following table is used to diagnose this situation so that
156 -- an appropriate warning can be issued.
158 -- The Node_Id stored is for the N_String_Literal node created to hold
159 -- the value of the external name. The Sloc of this node is used to
160 -- cross-reference the location of the duplication.
162 package Externals is new Table.Table (
163 Table_Component_Type => Node_Id,
164 Table_Index_Type => Int,
165 Table_Low_Bound => 0,
166 Table_Initial => 100,
167 Table_Increment => 100,
168 Table_Name => "Name_Externals");
170 -------------------------------------
171 -- Local Subprograms and Variables --
172 -------------------------------------
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 procedure Analyze_Part_Of
186 Encap_Id : out Entity_Id;
187 Legal : out Boolean);
188 -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and
189 -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the
190 -- Part_Of indicator. Item_Id is the entity of an abstract state, object or
191 -- package instantiation. Encap denotes the encapsulating state or single
192 -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when
193 -- the indicator is legal.
195 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean;
196 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
197 -- Query whether a particular item appears in a mixed list of nodes and
198 -- entities. It is assumed that all nodes in the list have entities.
200 procedure Check_Postcondition_Use_In_Inlined_Subprogram
202 Spec_Id : Entity_Id);
203 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
204 -- Precondition, Refined_Post, and Test_Case. Emit a warning when pragma
205 -- Prag is associated with subprogram Spec_Id subject to Inline_Always,
206 -- and assertions are enabled.
208 procedure Check_State_And_Constituent_Use
212 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
213 -- Global and Initializes. Determine whether a state from list States and a
214 -- corresponding constituent from list Constits (if any) appear in the same
215 -- context denoted by Context. If this is the case, emit an error.
217 procedure Contract_Freeze_Error
218 (Contract_Id : Entity_Id;
219 Freeze_Id : Entity_Id);
220 -- Subsidiary to the analysis of pragmas Contract_Cases, Part_Of, Post, and
221 -- Pre. Emit a freezing-related error message where Freeze_Id is the entity
222 -- of a body which caused contract freezing and Contract_Id denotes the
223 -- entity of the affected contstruct.
225 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id);
226 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
227 -- Prag that duplicates previous pragma Prev.
229 function Find_Encapsulating_State
231 Constit_Id : Entity_Id) return Entity_Id;
232 -- Given the entity of a constituent Constit_Id, find the corresponding
233 -- encapsulating state which appears in States. The routine returns Empty
234 -- if no such state is found.
236 function Find_Related_Context
238 Do_Checks : Boolean := False) return Node_Id;
239 -- Subsidiary to the analysis of pragmas
242 -- Constant_After_Elaboration
246 -- Find the first source declaration or statement found while traversing
247 -- the previous node chain starting from pragma Prag. If flag Do_Checks is
248 -- set, the routine reports duplicate pragmas. The routine returns Empty
249 -- when reaching the start of the node chain.
251 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
252 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
253 -- original one, following the renaming chain) is returned. Otherwise the
254 -- entity is returned unchanged. Should be in Einfo???
256 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type;
257 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
258 -- Get_SPARK_Mode_From_Annotation. Convert a name into a corresponding
259 -- value of type SPARK_Mode_Type.
261 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean;
262 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
263 -- Determine whether dependency clause Clause is surrounded by extra
264 -- parentheses. If this is the case, issue an error message.
266 function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean;
267 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
268 -- pragma Depends. Determine whether the type of dependency item Item is
269 -- tagged, unconstrained array, unconstrained record or a record with at
270 -- least one unconstrained component.
272 procedure Record_Possible_Body_Reference
273 (State_Id : Entity_Id;
275 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
276 -- Global. Given an abstract state denoted by State_Id and a reference Ref
277 -- to it, determine whether the reference appears in a package body that
278 -- will eventually refine the state. If this is the case, record the
279 -- reference for future checks (see Analyze_Refined_State_In_Decls).
281 procedure Resolve_State (N : Node_Id);
282 -- Handle the overloading of state names by functions. When N denotes a
283 -- function, this routine finds the corresponding state and sets the entity
284 -- of N to that of the state.
286 procedure Rewrite_Assertion_Kind
288 From_Policy : Boolean := False);
289 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
290 -- then it is rewritten as an identifier with the corresponding special
291 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
292 -- and Check_Policy. If the names are Precondition or Postcondition, this
293 -- combination is deprecated in favor of Assertion_Policy and Ada2012
294 -- Aspect names. The parameter From_Policy indicates that the pragma
295 -- is the old non-standard Check_Policy and not a rewritten pragma.
297 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id);
298 -- Place semantic information on the argument of an Elaborate/Elaborate_All
299 -- pragma. Entity name for unit and its parents is taken from item in
300 -- previous with_clause that mentions the unit.
302 procedure Validate_Compile_Time_Warning_Or_Error
305 -- Common processing for Compile_Time_Error and Compile_Time_Warning of
306 -- pragma N. Called when the pragma is processed as part of its regular
307 -- analysis but also called after calling the back end to validate these
308 -- pragmas for size and alignment appropriateness.
310 procedure Defer_Compile_Time_Warning_Error_To_BE (N : Node_Id);
311 -- N is a pragma Compile_Time_Error or Compile_Warning_Error whose boolean
312 -- expression is not known at compile time during the front end. This
313 -- procedure makes an entry in a table. The actual checking is performed by
314 -- Validate_Compile_Time_Warning_Errors, which is invoked after calling the
317 Dummy : Integer := 0;
318 pragma Volatile (Dummy);
319 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
322 pragma No_Inline (ip);
323 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
324 -- is just to help debugging the front end. If a pragma Inspection_Point
325 -- is added to a source program, then breaking on ip will get you to that
326 -- point in the program.
329 pragma No_Inline (rv);
330 -- This is a dummy function called by the processing for pragma Reviewable.
331 -- It is there for assisting front end debugging. By placing a Reviewable
332 -- pragma in the source program, a breakpoint on rv catches this place in
333 -- the source, allowing convenient stepping to the point of interest.
335 ------------------------------------------------------
336 -- Table for Defer_Compile_Time_Warning_Error_To_BE --
337 ------------------------------------------------------
339 -- The following table collects pragmas Compile_Time_Error and Compile_
340 -- Time_Warning for validation. Entries are made by calls to subprogram
341 -- Defer_Compile_Time_Warning_Error_To_BE, and the call to the procedure
342 -- Validate_Compile_Time_Warning_Errors does the actual error checking
343 -- and posting of warning and error messages. The reason for this delayed
344 -- processing is to take advantage of back-annotations of attributes size
345 -- and alignment values performed by the back end.
347 -- Note: the reason we store a Source_Ptr value instead of a Node_Id is
348 -- that by the time Validate_Compile_Time_Warning_Errors is called, Sprint
349 -- will already have modified all Sloc values if the -gnatD option is set.
351 type CTWE_Entry is record
353 -- Source location used in warnings and error messages
356 -- Pragma Compile_Time_Error or Compile_Time_Warning
359 -- The scope which encloses the pragma
362 package Compile_Time_Warnings_Errors is new Table.Table (
363 Table_Component_Type => CTWE_Entry,
364 Table_Index_Type => Int,
365 Table_Low_Bound => 1,
367 Table_Increment => 200,
368 Table_Name => "Compile_Time_Warnings_Errors");
370 -------------------------------
371 -- Adjust_External_Name_Case --
372 -------------------------------
374 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
378 -- Adjust case of literal if required
380 if Opt.External_Name_Exp_Casing = As_Is then
384 -- Copy existing string
390 for J in 1 .. String_Length (Strval (N)) loop
391 CC := Get_String_Char (Strval (N), J);
393 if Opt.External_Name_Exp_Casing = Uppercase
394 and then CC >= Get_Char_Code ('a')
395 and then CC <= Get_Char_Code ('z')
397 Store_String_Char (CC - 32);
399 elsif Opt.External_Name_Exp_Casing = Lowercase
400 and then CC >= Get_Char_Code ('A')
401 and then CC <= Get_Char_Code ('Z')
403 Store_String_Char (CC + 32);
406 Store_String_Char (CC);
411 Make_String_Literal (Sloc (N),
412 Strval => End_String);
414 end Adjust_External_Name_Case;
416 -----------------------------------------
417 -- Analyze_Contract_Cases_In_Decl_Part --
418 -----------------------------------------
420 -- WARNING: This routine manages Ghost regions. Return statements must be
421 -- replaced by gotos which jump to the end of the routine and restore the
424 procedure Analyze_Contract_Cases_In_Decl_Part
426 Freeze_Id : Entity_Id := Empty)
428 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
429 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
431 Others_Seen : Boolean := False;
432 -- This flag is set when an "others" choice is encountered. It is used
433 -- to detect multiple illegal occurrences of "others".
435 procedure Analyze_Contract_Case (CCase : Node_Id);
436 -- Verify the legality of a single contract case
438 ---------------------------
439 -- Analyze_Contract_Case --
440 ---------------------------
442 procedure Analyze_Contract_Case (CCase : Node_Id) is
443 Case_Guard : Node_Id;
446 Extra_Guard : Node_Id;
449 if Nkind (CCase) = N_Component_Association then
450 Case_Guard := First (Choices (CCase));
451 Conseq := Expression (CCase);
453 -- Each contract case must have exactly one case guard
455 Extra_Guard := Next (Case_Guard);
457 if Present (Extra_Guard) then
459 ("contract case must have exactly one case guard",
463 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
465 if Nkind (Case_Guard) = N_Others_Choice then
468 ("only one others choice allowed in contract cases",
474 elsif Others_Seen then
476 ("others must be the last choice in contract cases", N);
479 -- Preanalyze the case guard and consequence
481 if Nkind (Case_Guard) /= N_Others_Choice then
482 Errors := Serious_Errors_Detected;
483 Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean);
485 -- Emit a clarification message when the case guard contains
486 -- at least one undefined reference, possibly due to contract
489 if Errors /= Serious_Errors_Detected
490 and then Present (Freeze_Id)
491 and then Has_Undefined_Reference (Case_Guard)
493 Contract_Freeze_Error (Spec_Id, Freeze_Id);
497 Errors := Serious_Errors_Detected;
498 Preanalyze_Assert_Expression (Conseq, Standard_Boolean);
500 -- Emit a clarification message when the consequence contains
501 -- at least one undefined reference, possibly due to contract
504 if Errors /= Serious_Errors_Detected
505 and then Present (Freeze_Id)
506 and then Has_Undefined_Reference (Conseq)
508 Contract_Freeze_Error (Spec_Id, Freeze_Id);
511 -- The contract case is malformed
514 Error_Msg_N ("wrong syntax in contract case", CCase);
516 end Analyze_Contract_Case;
520 CCases : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
522 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
523 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
524 -- Save the Ghost-related attributes to restore on exit
527 Restore_Scope : Boolean := False;
529 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
532 -- Do not analyze the pragma multiple times
534 if Is_Analyzed_Pragma (N) then
538 -- Set the Ghost mode in effect from the pragma. Due to the delayed
539 -- analysis of the pragma, the Ghost mode at point of declaration and
540 -- point of analysis may not necessarily be the same. Use the mode in
541 -- effect at the point of declaration.
545 -- Single and multiple contract cases must appear in aggregate form. If
546 -- this is not the case, then either the parser of the analysis of the
547 -- pragma failed to produce an aggregate.
549 pragma Assert (Nkind (CCases) = N_Aggregate);
551 if Present (Component_Associations (CCases)) then
553 -- Ensure that the formal parameters are visible when analyzing all
554 -- clauses. This falls out of the general rule of aspects pertaining
555 -- to subprogram declarations.
557 if not In_Open_Scopes (Spec_Id) then
558 Restore_Scope := True;
559 Push_Scope (Spec_Id);
561 if Is_Generic_Subprogram (Spec_Id) then
562 Install_Generic_Formals (Spec_Id);
564 Install_Formals (Spec_Id);
568 CCase := First (Component_Associations (CCases));
569 while Present (CCase) loop
570 Analyze_Contract_Case (CCase);
574 if Restore_Scope then
578 -- Currently it is not possible to inline pre/postconditions on a
579 -- subprogram subject to pragma Inline_Always.
581 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
583 -- Otherwise the pragma is illegal
586 Error_Msg_N ("wrong syntax for constract cases", N);
589 Set_Is_Analyzed_Pragma (N);
591 Restore_Ghost_Region (Saved_GM, Saved_IGR);
592 end Analyze_Contract_Cases_In_Decl_Part;
594 ----------------------------------
595 -- Analyze_Depends_In_Decl_Part --
596 ----------------------------------
598 procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is
599 Loc : constant Source_Ptr := Sloc (N);
600 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
601 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
603 All_Inputs_Seen : Elist_Id := No_Elist;
604 -- A list containing the entities of all the inputs processed so far.
605 -- The list is populated with unique entities because the same input
606 -- may appear in multiple input lists.
608 All_Outputs_Seen : Elist_Id := No_Elist;
609 -- A list containing the entities of all the outputs processed so far.
610 -- The list is populated with unique entities because output items are
611 -- unique in a dependence relation.
613 Constits_Seen : Elist_Id := No_Elist;
614 -- A list containing the entities of all constituents processed so far.
615 -- It aids in detecting illegal usage of a state and a corresponding
616 -- constituent in pragma [Refinde_]Depends.
618 Global_Seen : Boolean := False;
619 -- A flag set when pragma Global has been processed
621 Null_Output_Seen : Boolean := False;
622 -- A flag used to track the legality of a null output
624 Result_Seen : Boolean := False;
625 -- A flag set when Spec_Id'Result is processed
627 States_Seen : Elist_Id := No_Elist;
628 -- A list containing the entities of all states processed so far. It
629 -- helps in detecting illegal usage of a state and a corresponding
630 -- constituent in pragma [Refined_]Depends.
632 Subp_Inputs : Elist_Id := No_Elist;
633 Subp_Outputs : Elist_Id := No_Elist;
634 -- Two lists containing the full set of inputs and output of the related
635 -- subprograms. Note that these lists contain both nodes and entities.
637 Task_Input_Seen : Boolean := False;
638 Task_Output_Seen : Boolean := False;
639 -- Flags used to track the implicit dependence of a task unit on itself
641 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id);
642 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
643 -- to the name buffer. The individual kinds are as follows:
644 -- E_Abstract_State - "state"
645 -- E_Constant - "constant"
646 -- E_Generic_In_Out_Parameter - "generic parameter"
647 -- E_Generic_In_Parameter - "generic parameter"
648 -- E_In_Parameter - "parameter"
649 -- E_In_Out_Parameter - "parameter"
650 -- E_Loop_Parameter - "loop parameter"
651 -- E_Out_Parameter - "parameter"
652 -- E_Protected_Type - "current instance of protected type"
653 -- E_Task_Type - "current instance of task type"
654 -- E_Variable - "global"
656 procedure Analyze_Dependency_Clause
659 -- Verify the legality of a single dependency clause. Flag Is_Last
660 -- denotes whether Clause is the last clause in the relation.
662 procedure Check_Function_Return;
663 -- Verify that Funtion'Result appears as one of the outputs
664 -- (SPARK RM 6.1.5(10)).
671 -- Ensure that an item fulfills its designated input and/or output role
672 -- as specified by pragma Global (if any) or the enclosing context. If
673 -- this is not the case, emit an error. Item and Item_Id denote the
674 -- attributes of an item. Flag Is_Input should be set when item comes
675 -- from an input list. Flag Self_Ref should be set when the item is an
676 -- output and the dependency clause has operator "+".
678 procedure Check_Usage
679 (Subp_Items : Elist_Id;
680 Used_Items : Elist_Id;
682 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
683 -- error if this is not the case.
685 procedure Normalize_Clause (Clause : Node_Id);
686 -- Remove a self-dependency "+" from the input list of a clause
688 -----------------------------
689 -- Add_Item_To_Name_Buffer --
690 -----------------------------
692 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id) is
694 if Ekind (Item_Id) = E_Abstract_State then
695 Add_Str_To_Name_Buffer ("state");
697 elsif Ekind (Item_Id) = E_Constant then
698 Add_Str_To_Name_Buffer ("constant");
700 elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
701 E_Generic_In_Parameter)
703 Add_Str_To_Name_Buffer ("generic parameter");
705 elsif Is_Formal (Item_Id) then
706 Add_Str_To_Name_Buffer ("parameter");
708 elsif Ekind (Item_Id) = E_Loop_Parameter then
709 Add_Str_To_Name_Buffer ("loop parameter");
711 elsif Ekind (Item_Id) = E_Protected_Type
712 or else Is_Single_Protected_Object (Item_Id)
714 Add_Str_To_Name_Buffer ("current instance of protected type");
716 elsif Ekind (Item_Id) = E_Task_Type
717 or else Is_Single_Task_Object (Item_Id)
719 Add_Str_To_Name_Buffer ("current instance of task type");
721 elsif Ekind (Item_Id) = E_Variable then
722 Add_Str_To_Name_Buffer ("global");
724 -- The routine should not be called with non-SPARK items
729 end Add_Item_To_Name_Buffer;
731 -------------------------------
732 -- Analyze_Dependency_Clause --
733 -------------------------------
735 procedure Analyze_Dependency_Clause
739 procedure Analyze_Input_List (Inputs : Node_Id);
740 -- Verify the legality of a single input list
742 procedure Analyze_Input_Output
747 Seen : in out Elist_Id;
748 Null_Seen : in out Boolean;
749 Non_Null_Seen : in out Boolean);
750 -- Verify the legality of a single input or output item. Flag
751 -- Is_Input should be set whenever Item is an input, False when it
752 -- denotes an output. Flag Self_Ref should be set when the item is an
753 -- output and the dependency clause has a "+". Flag Top_Level should
754 -- be set whenever Item appears immediately within an input or output
755 -- list. Seen is a collection of all abstract states, objects and
756 -- formals processed so far. Flag Null_Seen denotes whether a null
757 -- input or output has been encountered. Flag Non_Null_Seen denotes
758 -- whether a non-null input or output has been encountered.
760 ------------------------
761 -- Analyze_Input_List --
762 ------------------------
764 procedure Analyze_Input_List (Inputs : Node_Id) is
765 Inputs_Seen : Elist_Id := No_Elist;
766 -- A list containing the entities of all inputs that appear in the
767 -- current input list.
769 Non_Null_Input_Seen : Boolean := False;
770 Null_Input_Seen : Boolean := False;
771 -- Flags used to check the legality of an input list
776 -- Multiple inputs appear as an aggregate
778 if Nkind (Inputs) = N_Aggregate then
779 if Present (Component_Associations (Inputs)) then
781 ("nested dependency relations not allowed", Inputs);
783 elsif Present (Expressions (Inputs)) then
784 Input := First (Expressions (Inputs));
785 while Present (Input) loop
792 Null_Seen => Null_Input_Seen,
793 Non_Null_Seen => Non_Null_Input_Seen);
798 -- Syntax error, always report
801 Error_Msg_N ("malformed input dependency list", Inputs);
804 -- Process a solitary input
813 Null_Seen => Null_Input_Seen,
814 Non_Null_Seen => Non_Null_Input_Seen);
817 -- Detect an illegal dependency clause of the form
821 if Null_Output_Seen and then Null_Input_Seen then
823 ("null dependency clause cannot have a null input list",
826 end Analyze_Input_List;
828 --------------------------
829 -- Analyze_Input_Output --
830 --------------------------
832 procedure Analyze_Input_Output
837 Seen : in out Elist_Id;
838 Null_Seen : in out Boolean;
839 Non_Null_Seen : in out Boolean)
841 procedure Current_Task_Instance_Seen;
842 -- Set the appropriate global flag when the current instance of a
843 -- task unit is encountered.
845 --------------------------------
846 -- Current_Task_Instance_Seen --
847 --------------------------------
849 procedure Current_Task_Instance_Seen is
852 Task_Input_Seen := True;
854 Task_Output_Seen := True;
856 end Current_Task_Instance_Seen;
860 Is_Output : constant Boolean := not Is_Input;
864 -- Start of processing for Analyze_Input_Output
867 -- Multiple input or output items appear as an aggregate
869 if Nkind (Item) = N_Aggregate then
870 if not Top_Level then
871 SPARK_Msg_N ("nested grouping of items not allowed", Item);
873 elsif Present (Component_Associations (Item)) then
875 ("nested dependency relations not allowed", Item);
877 -- Recursively analyze the grouped items
879 elsif Present (Expressions (Item)) then
880 Grouped := First (Expressions (Item));
881 while Present (Grouped) loop
884 Is_Input => Is_Input,
885 Self_Ref => Self_Ref,
888 Null_Seen => Null_Seen,
889 Non_Null_Seen => Non_Null_Seen);
894 -- Syntax error, always report
897 Error_Msg_N ("malformed dependency list", Item);
900 -- Process attribute 'Result in the context of a dependency clause
902 elsif Is_Attribute_Result (Item) then
903 Non_Null_Seen := True;
907 -- Attribute 'Result is allowed to appear on the output side of
908 -- a dependency clause (SPARK RM 6.1.5(6)).
911 SPARK_Msg_N ("function result cannot act as input", Item);
915 ("cannot mix null and non-null dependency items", Item);
921 -- Detect multiple uses of null in a single dependency list or
922 -- throughout the whole relation. Verify the placement of a null
923 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
925 elsif Nkind (Item) = N_Null then
928 ("multiple null dependency relations not allowed", Item);
930 elsif Non_Null_Seen then
932 ("cannot mix null and non-null dependency items", Item);
940 ("null output list must be the last clause in a "
941 & "dependency relation", Item);
943 -- Catch a useless dependence of the form:
948 ("useless dependence, null depends on itself", Item);
956 Non_Null_Seen := True;
959 SPARK_Msg_N ("cannot mix null and non-null items", Item);
963 Resolve_State (Item);
965 -- Find the entity of the item. If this is a renaming, climb
966 -- the renaming chain to reach the root object. Renamings of
967 -- non-entire objects do not yield an entity (Empty).
969 Item_Id := Entity_Of (Item);
971 if Present (Item_Id) then
975 if Ekind_In (Item_Id, E_Constant, E_Loop_Parameter)
978 -- Current instances of concurrent types
980 Ekind_In (Item_Id, E_Protected_Type, E_Task_Type)
985 Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
986 E_Generic_In_Parameter,
994 Ekind_In (Item_Id, E_Abstract_State, E_Variable)
996 -- A [generic] function is not allowed to have Output
997 -- items in its dependency relations. Note that "null"
998 -- and attribute 'Result are still valid items.
1000 if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
1001 and then not Is_Input
1004 ("output item is not applicable to function", Item);
1007 -- The item denotes a concurrent type. Note that single
1008 -- protected/task types are not considered here because
1009 -- they behave as objects in the context of pragma
1010 -- [Refined_]Depends.
1012 if Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then
1014 -- This use is legal as long as the concurrent type is
1015 -- the current instance of an enclosing type.
1017 if Is_CCT_Instance (Item_Id, Spec_Id) then
1019 -- The dependence of a task unit on itself is
1020 -- implicit and may or may not be explicitly
1021 -- specified (SPARK RM 6.1.4).
1023 if Ekind (Item_Id) = E_Task_Type then
1024 Current_Task_Instance_Seen;
1027 -- Otherwise this is not the current instance
1031 ("invalid use of subtype mark in dependency "
1032 & "relation", Item);
1035 -- The dependency of a task unit on itself is implicit
1036 -- and may or may not be explicitly specified
1037 -- (SPARK RM 6.1.4).
1039 elsif Is_Single_Task_Object (Item_Id)
1040 and then Is_CCT_Instance (Etype (Item_Id), Spec_Id)
1042 Current_Task_Instance_Seen;
1045 -- Ensure that the item fulfills its role as input and/or
1046 -- output as specified by pragma Global or the enclosing
1049 Check_Role (Item, Item_Id, Is_Input, Self_Ref);
1051 -- Detect multiple uses of the same state, variable or
1052 -- formal parameter. If this is not the case, add the
1053 -- item to the list of processed relations.
1055 if Contains (Seen, Item_Id) then
1057 ("duplicate use of item &", Item, Item_Id);
1059 Append_New_Elmt (Item_Id, Seen);
1062 -- Detect illegal use of an input related to a null
1063 -- output. Such input items cannot appear in other
1064 -- input lists (SPARK RM 6.1.5(13)).
1067 and then Null_Output_Seen
1068 and then Contains (All_Inputs_Seen, Item_Id)
1071 ("input of a null output list cannot appear in "
1072 & "multiple input lists", Item);
1075 -- Add an input or a self-referential output to the list
1076 -- of all processed inputs.
1078 if Is_Input or else Self_Ref then
1079 Append_New_Elmt (Item_Id, All_Inputs_Seen);
1082 -- State related checks (SPARK RM 6.1.5(3))
1084 if Ekind (Item_Id) = E_Abstract_State then
1086 -- Package and subprogram bodies are instantiated
1087 -- individually in a separate compiler pass. Due to
1088 -- this mode of instantiation, the refinement of a
1089 -- state may no longer be visible when a subprogram
1090 -- body contract is instantiated. Since the generic
1091 -- template is legal, do not perform this check in
1092 -- the instance to circumvent this oddity.
1097 -- An abstract state with visible refinement cannot
1098 -- appear in pragma [Refined_]Depends as its place
1099 -- must be taken by some of its constituents
1100 -- (SPARK RM 6.1.4(7)).
1102 elsif Has_Visible_Refinement (Item_Id) then
1104 ("cannot mention state & in dependence relation",
1106 SPARK_Msg_N ("\use its constituents instead", Item);
1109 -- If the reference to the abstract state appears in
1110 -- an enclosing package body that will eventually
1111 -- refine the state, record the reference for future
1115 Record_Possible_Body_Reference
1116 (State_Id => Item_Id,
1121 -- When the item renames an entire object, replace the
1122 -- item with a reference to the object.
1124 if Entity (Item) /= Item_Id then
1126 New_Occurrence_Of (Item_Id, Sloc (Item)));
1130 -- Add the entity of the current item to the list of
1133 if Ekind (Item_Id) = E_Abstract_State then
1134 Append_New_Elmt (Item_Id, States_Seen);
1136 -- The variable may eventually become a constituent of a
1137 -- single protected/task type. Record the reference now
1138 -- and verify its legality when analyzing the contract of
1139 -- the variable (SPARK RM 9.3).
1141 elsif Ekind (Item_Id) = E_Variable then
1142 Record_Possible_Part_Of_Reference
1147 if Ekind_In (Item_Id, E_Abstract_State,
1150 and then Present (Encapsulating_State (Item_Id))
1152 Append_New_Elmt (Item_Id, Constits_Seen);
1155 -- All other input/output items are illegal
1156 -- (SPARK RM 6.1.5(1)).
1160 ("item must denote parameter, variable, state or "
1161 & "current instance of concurrent type", Item);
1164 -- All other input/output items are illegal
1165 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
1169 ("item must denote parameter, variable, state or current "
1170 & "instance of concurrent type", Item);
1173 end Analyze_Input_Output;
1181 Non_Null_Output_Seen : Boolean := False;
1182 -- Flag used to check the legality of an output list
1184 -- Start of processing for Analyze_Dependency_Clause
1187 Inputs := Expression (Clause);
1190 -- An input list with a self-dependency appears as operator "+" where
1191 -- the actuals inputs are the right operand.
1193 if Nkind (Inputs) = N_Op_Plus then
1194 Inputs := Right_Opnd (Inputs);
1198 -- Process the output_list of a dependency_clause
1200 Output := First (Choices (Clause));
1201 while Present (Output) loop
1202 Analyze_Input_Output
1205 Self_Ref => Self_Ref,
1207 Seen => All_Outputs_Seen,
1208 Null_Seen => Null_Output_Seen,
1209 Non_Null_Seen => Non_Null_Output_Seen);
1214 -- Process the input_list of a dependency_clause
1216 Analyze_Input_List (Inputs);
1217 end Analyze_Dependency_Clause;
1219 ---------------------------
1220 -- Check_Function_Return --
1221 ---------------------------
1223 procedure Check_Function_Return is
1225 if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
1226 and then not Result_Seen
1229 ("result of & must appear in exactly one output list",
1232 end Check_Function_Return;
1238 procedure Check_Role
1240 Item_Id : Entity_Id;
1245 (Item_Is_Input : out Boolean;
1246 Item_Is_Output : out Boolean);
1247 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1248 -- Item_Is_Output are set depending on the role.
1250 procedure Role_Error
1251 (Item_Is_Input : Boolean;
1252 Item_Is_Output : Boolean);
1253 -- Emit an error message concerning the incorrect use of Item in
1254 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1255 -- denote whether the item is an input and/or an output.
1262 (Item_Is_Input : out Boolean;
1263 Item_Is_Output : out Boolean)
1265 -- A constant or IN parameter of access type should be handled
1266 -- like a variable, as the underlying memory pointed-to can be
1267 -- modified. Use Adjusted_Kind to do this adjustment.
1269 Adjusted_Kind : Entity_Kind := Ekind (Item_Id);
1272 if Ekind_In (Item_Id, E_Constant,
1273 E_Generic_In_Parameter,
1275 and then Is_Access_Type (Etype (Item_Id))
1277 Adjusted_Kind := E_Variable;
1280 case Adjusted_Kind is
1284 when E_Abstract_State =>
1286 -- When pragma Global is present it determines the mode of
1287 -- the abstract state.
1290 Item_Is_Input := Appears_In (Subp_Inputs, Item_Id);
1291 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1293 -- Otherwise the state has a default IN OUT mode, because it
1294 -- behaves as a variable.
1297 Item_Is_Input := True;
1298 Item_Is_Output := True;
1301 -- Constants and IN parameters
1304 | E_Generic_In_Parameter
1308 -- When pragma Global is present it determines the mode
1309 -- of constant objects as inputs (and such objects cannot
1310 -- appear as outputs in the Global contract).
1313 Item_Is_Input := Appears_In (Subp_Inputs, Item_Id);
1315 Item_Is_Input := True;
1318 Item_Is_Output := False;
1320 -- Variables and IN OUT parameters, as well as constants and
1321 -- IN parameters of access type which are handled like
1324 when E_Generic_In_Out_Parameter
1325 | E_In_Out_Parameter
1328 -- When pragma Global is present it determines the mode of
1333 -- A variable has mode IN when its type is unconstrained
1334 -- or tagged because array bounds, discriminants or tags
1338 Appears_In (Subp_Inputs, Item_Id)
1339 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1341 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1343 -- Otherwise the variable has a default IN OUT mode
1346 Item_Is_Input := True;
1347 Item_Is_Output := True;
1350 when E_Out_Parameter =>
1352 -- An OUT parameter of the related subprogram; it cannot
1353 -- appear in Global.
1355 if Scope (Item_Id) = Spec_Id then
1357 -- The parameter has mode IN if its type is unconstrained
1358 -- or tagged because array bounds, discriminants or tags
1362 Is_Unconstrained_Or_Tagged_Item (Item_Id);
1364 Item_Is_Output := True;
1366 -- An OUT parameter of an enclosing subprogram; it can
1367 -- appear in Global and behaves as a read-write variable.
1370 -- When pragma Global is present it determines the mode
1375 -- A variable has mode IN when its type is
1376 -- unconstrained or tagged because array
1377 -- bounds, discriminants or tags can be read.
1380 Appears_In (Subp_Inputs, Item_Id)
1381 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1383 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1385 -- Otherwise the variable has a default IN OUT mode
1388 Item_Is_Input := True;
1389 Item_Is_Output := True;
1395 when E_Protected_Type =>
1398 -- A variable has mode IN when its type is unconstrained
1399 -- or tagged because array bounds, discriminants or tags
1403 Appears_In (Subp_Inputs, Item_Id)
1404 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1406 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1409 -- A protected type acts as a formal parameter of mode IN
1410 -- when it applies to a protected function.
1412 if Ekind (Spec_Id) = E_Function then
1413 Item_Is_Input := True;
1414 Item_Is_Output := False;
1416 -- Otherwise the protected type acts as a formal of mode
1420 Item_Is_Input := True;
1421 Item_Is_Output := True;
1429 -- When pragma Global is present it determines the mode of
1434 Appears_In (Subp_Inputs, Item_Id)
1435 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1437 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1439 -- Otherwise task types act as IN OUT parameters
1442 Item_Is_Input := True;
1443 Item_Is_Output := True;
1447 raise Program_Error;
1455 procedure Role_Error
1456 (Item_Is_Input : Boolean;
1457 Item_Is_Output : Boolean)
1459 Error_Msg : Name_Id;
1464 -- When the item is not part of the input and the output set of
1465 -- the related subprogram, then it appears as extra in pragma
1466 -- [Refined_]Depends.
1468 if not Item_Is_Input and then not Item_Is_Output then
1469 Add_Item_To_Name_Buffer (Item_Id);
1470 Add_Str_To_Name_Buffer
1471 (" & cannot appear in dependence relation");
1473 Error_Msg := Name_Find;
1474 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1476 Error_Msg_Name_1 := Chars (Spec_Id);
1478 (Fix_Msg (Spec_Id, "\& is not part of the input or output "
1479 & "set of subprogram %"), Item, Item_Id);
1481 -- The mode of the item and its role in pragma [Refined_]Depends
1482 -- are in conflict. Construct a detailed message explaining the
1483 -- illegality (SPARK RM 6.1.5(5-6)).
1486 if Item_Is_Input then
1487 Add_Str_To_Name_Buffer ("read-only");
1489 Add_Str_To_Name_Buffer ("write-only");
1492 Add_Char_To_Name_Buffer (' ');
1493 Add_Item_To_Name_Buffer (Item_Id);
1494 Add_Str_To_Name_Buffer (" & cannot appear as ");
1496 if Item_Is_Input then
1497 Add_Str_To_Name_Buffer ("output");
1499 Add_Str_To_Name_Buffer ("input");
1502 Add_Str_To_Name_Buffer (" in dependence relation");
1503 Error_Msg := Name_Find;
1504 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1510 Item_Is_Input : Boolean;
1511 Item_Is_Output : Boolean;
1513 -- Start of processing for Check_Role
1516 Find_Role (Item_Is_Input, Item_Is_Output);
1521 if not Item_Is_Input then
1522 Role_Error (Item_Is_Input, Item_Is_Output);
1525 -- Self-referential item
1528 if not Item_Is_Input or else not Item_Is_Output then
1529 Role_Error (Item_Is_Input, Item_Is_Output);
1534 elsif not Item_Is_Output then
1535 Role_Error (Item_Is_Input, Item_Is_Output);
1543 procedure Check_Usage
1544 (Subp_Items : Elist_Id;
1545 Used_Items : Elist_Id;
1548 procedure Usage_Error (Item_Id : Entity_Id);
1549 -- Emit an error concerning the illegal usage of an item
1555 procedure Usage_Error (Item_Id : Entity_Id) is
1556 Error_Msg : Name_Id;
1563 -- Unconstrained and tagged items are not part of the explicit
1564 -- input set of the related subprogram, they do not have to be
1565 -- present in a dependence relation and should not be flagged
1566 -- (SPARK RM 6.1.5(5)).
1568 if not Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1571 Add_Item_To_Name_Buffer (Item_Id);
1572 Add_Str_To_Name_Buffer
1573 (" & is missing from input dependence list");
1575 Error_Msg := Name_Find;
1576 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1578 ("\add `null ='> &` dependency to ignore this input",
1582 -- Output case (SPARK RM 6.1.5(10))
1587 Add_Item_To_Name_Buffer (Item_Id);
1588 Add_Str_To_Name_Buffer
1589 (" & is missing from output dependence list");
1591 Error_Msg := Name_Find;
1592 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1600 Item_Id : Entity_Id;
1602 -- Start of processing for Check_Usage
1605 if No (Subp_Items) then
1609 -- Each input or output of the subprogram must appear in a dependency
1612 Elmt := First_Elmt (Subp_Items);
1613 while Present (Elmt) loop
1614 Item := Node (Elmt);
1616 if Nkind (Item) = N_Defining_Identifier then
1619 Item_Id := Entity_Of (Item);
1622 -- The item does not appear in a dependency
1624 if Present (Item_Id)
1625 and then not Contains (Used_Items, Item_Id)
1627 if Is_Formal (Item_Id) then
1628 Usage_Error (Item_Id);
1630 -- The current instance of a protected type behaves as a formal
1631 -- parameter (SPARK RM 6.1.4).
1633 elsif Ekind (Item_Id) = E_Protected_Type
1634 or else Is_Single_Protected_Object (Item_Id)
1636 Usage_Error (Item_Id);
1638 -- The current instance of a task type behaves as a formal
1639 -- parameter (SPARK RM 6.1.4).
1641 elsif Ekind (Item_Id) = E_Task_Type
1642 or else Is_Single_Task_Object (Item_Id)
1644 -- The dependence of a task unit on itself is implicit and
1645 -- may or may not be explicitly specified (SPARK RM 6.1.4).
1646 -- Emit an error if only one input/output is present.
1648 if Task_Input_Seen /= Task_Output_Seen then
1649 Usage_Error (Item_Id);
1652 -- States and global objects are not used properly only when
1653 -- the subprogram is subject to pragma Global.
1655 elsif Global_Seen then
1656 Usage_Error (Item_Id);
1664 ----------------------
1665 -- Normalize_Clause --
1666 ----------------------
1668 procedure Normalize_Clause (Clause : Node_Id) is
1669 procedure Create_Or_Modify_Clause
1675 Multiple : Boolean);
1676 -- Create a brand new clause to represent the self-reference or
1677 -- modify the input and/or output lists of an existing clause. Output
1678 -- denotes a self-referencial output. Outputs is the output list of a
1679 -- clause. Inputs is the input list of a clause. After denotes the
1680 -- clause after which the new clause is to be inserted. Flag In_Place
1681 -- should be set when normalizing the last output of an output list.
1682 -- Flag Multiple should be set when Output comes from a list with
1685 -----------------------------
1686 -- Create_Or_Modify_Clause --
1687 -----------------------------
1689 procedure Create_Or_Modify_Clause
1697 procedure Propagate_Output
1700 -- Handle the various cases of output propagation to the input
1701 -- list. Output denotes a self-referencial output item. Inputs
1702 -- is the input list of a clause.
1704 ----------------------
1705 -- Propagate_Output --
1706 ----------------------
1708 procedure Propagate_Output
1712 function In_Input_List
1714 Inputs : List_Id) return Boolean;
1715 -- Determine whether a particulat item appears in the input
1716 -- list of a clause.
1722 function In_Input_List
1724 Inputs : List_Id) return Boolean
1729 Elmt := First (Inputs);
1730 while Present (Elmt) loop
1731 if Entity_Of (Elmt) = Item then
1743 Output_Id : constant Entity_Id := Entity_Of (Output);
1746 -- Start of processing for Propagate_Output
1749 -- The clause is of the form:
1751 -- (Output =>+ null)
1753 -- Remove null input and replace it with a copy of the output:
1755 -- (Output => Output)
1757 if Nkind (Inputs) = N_Null then
1758 Rewrite (Inputs, New_Copy_Tree (Output));
1760 -- The clause is of the form:
1762 -- (Output =>+ (Input1, ..., InputN))
1764 -- Determine whether the output is not already mentioned in the
1765 -- input list and if not, add it to the list of inputs:
1767 -- (Output => (Output, Input1, ..., InputN))
1769 elsif Nkind (Inputs) = N_Aggregate then
1770 Grouped := Expressions (Inputs);
1772 if not In_Input_List
1776 Prepend_To (Grouped, New_Copy_Tree (Output));
1779 -- The clause is of the form:
1781 -- (Output =>+ Input)
1783 -- If the input does not mention the output, group the two
1786 -- (Output => (Output, Input))
1788 elsif Entity_Of (Inputs) /= Output_Id then
1790 Make_Aggregate (Loc,
1791 Expressions => New_List (
1792 New_Copy_Tree (Output),
1793 New_Copy_Tree (Inputs))));
1795 end Propagate_Output;
1799 Loc : constant Source_Ptr := Sloc (Clause);
1800 New_Clause : Node_Id;
1802 -- Start of processing for Create_Or_Modify_Clause
1805 -- A null output depending on itself does not require any
1808 if Nkind (Output) = N_Null then
1811 -- A function result cannot depend on itself because it cannot
1812 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1814 elsif Is_Attribute_Result (Output) then
1815 SPARK_Msg_N ("function result cannot depend on itself", Output);
1819 -- When performing the transformation in place, simply add the
1820 -- output to the list of inputs (if not already there). This
1821 -- case arises when dealing with the last output of an output
1822 -- list. Perform the normalization in place to avoid generating
1823 -- a malformed tree.
1826 Propagate_Output (Output, Inputs);
1828 -- A list with multiple outputs is slowly trimmed until only
1829 -- one element remains. When this happens, replace aggregate
1830 -- with the element itself.
1834 Rewrite (Outputs, Output);
1840 -- Unchain the output from its output list as it will appear in
1841 -- a new clause. Note that we cannot simply rewrite the output
1842 -- as null because this will violate the semantics of pragma
1847 -- Generate a new clause of the form:
1848 -- (Output => Inputs)
1851 Make_Component_Association (Loc,
1852 Choices => New_List (Output),
1853 Expression => New_Copy_Tree (Inputs));
1855 -- The new clause contains replicated content that has already
1856 -- been analyzed. There is not need to reanalyze or renormalize
1859 Set_Analyzed (New_Clause);
1862 (Output => First (Choices (New_Clause)),
1863 Inputs => Expression (New_Clause));
1865 Insert_After (After, New_Clause);
1867 end Create_Or_Modify_Clause;
1871 Outputs : constant Node_Id := First (Choices (Clause));
1873 Last_Output : Node_Id;
1874 Next_Output : Node_Id;
1877 -- Start of processing for Normalize_Clause
1880 -- A self-dependency appears as operator "+". Remove the "+" from the
1881 -- tree by moving the real inputs to their proper place.
1883 if Nkind (Expression (Clause)) = N_Op_Plus then
1884 Rewrite (Expression (Clause), Right_Opnd (Expression (Clause)));
1885 Inputs := Expression (Clause);
1887 -- Multiple outputs appear as an aggregate
1889 if Nkind (Outputs) = N_Aggregate then
1890 Last_Output := Last (Expressions (Outputs));
1892 Output := First (Expressions (Outputs));
1893 while Present (Output) loop
1895 -- Normalization may remove an output from its list,
1896 -- preserve the subsequent output now.
1898 Next_Output := Next (Output);
1900 Create_Or_Modify_Clause
1905 In_Place => Output = Last_Output,
1908 Output := Next_Output;
1914 Create_Or_Modify_Clause
1923 end Normalize_Clause;
1927 Deps : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
1928 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
1932 Last_Clause : Node_Id;
1933 Restore_Scope : Boolean := False;
1935 -- Start of processing for Analyze_Depends_In_Decl_Part
1938 -- Do not analyze the pragma multiple times
1940 if Is_Analyzed_Pragma (N) then
1944 -- Empty dependency list
1946 if Nkind (Deps) = N_Null then
1948 -- Gather all states, objects and formal parameters that the
1949 -- subprogram may depend on. These items are obtained from the
1950 -- parameter profile or pragma [Refined_]Global (if available).
1952 Collect_Subprogram_Inputs_Outputs
1953 (Subp_Id => Subp_Id,
1954 Subp_Inputs => Subp_Inputs,
1955 Subp_Outputs => Subp_Outputs,
1956 Global_Seen => Global_Seen);
1958 -- Verify that every input or output of the subprogram appear in a
1961 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1962 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1963 Check_Function_Return;
1965 -- Dependency clauses appear as component associations of an aggregate
1967 elsif Nkind (Deps) = N_Aggregate then
1969 -- Do not attempt to perform analysis of a syntactically illegal
1970 -- clause as this will lead to misleading errors.
1972 if Has_Extra_Parentheses (Deps) then
1976 if Present (Component_Associations (Deps)) then
1977 Last_Clause := Last (Component_Associations (Deps));
1979 -- Gather all states, objects and formal parameters that the
1980 -- subprogram may depend on. These items are obtained from the
1981 -- parameter profile or pragma [Refined_]Global (if available).
1983 Collect_Subprogram_Inputs_Outputs
1984 (Subp_Id => Subp_Id,
1985 Subp_Inputs => Subp_Inputs,
1986 Subp_Outputs => Subp_Outputs,
1987 Global_Seen => Global_Seen);
1989 -- When pragma [Refined_]Depends appears on a single concurrent
1990 -- type, it is relocated to the anonymous object.
1992 if Is_Single_Concurrent_Object (Spec_Id) then
1995 -- Ensure that the formal parameters are visible when analyzing
1996 -- all clauses. This falls out of the general rule of aspects
1997 -- pertaining to subprogram declarations.
1999 elsif not In_Open_Scopes (Spec_Id) then
2000 Restore_Scope := True;
2001 Push_Scope (Spec_Id);
2003 if Ekind (Spec_Id) = E_Task_Type then
2004 if Has_Discriminants (Spec_Id) then
2005 Install_Discriminants (Spec_Id);
2008 elsif Is_Generic_Subprogram (Spec_Id) then
2009 Install_Generic_Formals (Spec_Id);
2012 Install_Formals (Spec_Id);
2016 Clause := First (Component_Associations (Deps));
2017 while Present (Clause) loop
2018 Errors := Serious_Errors_Detected;
2020 -- The normalization mechanism may create extra clauses that
2021 -- contain replicated input and output names. There is no need
2022 -- to reanalyze them.
2024 if not Analyzed (Clause) then
2025 Set_Analyzed (Clause);
2027 Analyze_Dependency_Clause
2029 Is_Last => Clause = Last_Clause);
2032 -- Do not normalize a clause if errors were detected (count
2033 -- of Serious_Errors has increased) because the inputs and/or
2034 -- outputs may denote illegal items.
2036 if Serious_Errors_Detected = Errors then
2037 Normalize_Clause (Clause);
2043 if Restore_Scope then
2047 -- Verify that every input or output of the subprogram appear in a
2050 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
2051 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
2052 Check_Function_Return;
2054 -- The dependency list is malformed. This is a syntax error, always
2058 Error_Msg_N ("malformed dependency relation", Deps);
2062 -- The top level dependency relation is malformed. This is a syntax
2063 -- error, always report.
2066 Error_Msg_N ("malformed dependency relation", Deps);
2070 -- Ensure that a state and a corresponding constituent do not appear
2071 -- together in pragma [Refined_]Depends.
2073 Check_State_And_Constituent_Use
2074 (States => States_Seen,
2075 Constits => Constits_Seen,
2079 Set_Is_Analyzed_Pragma (N);
2080 end Analyze_Depends_In_Decl_Part;
2082 --------------------------------------------
2083 -- Analyze_External_Property_In_Decl_Part --
2084 --------------------------------------------
2086 procedure Analyze_External_Property_In_Decl_Part
2088 Expr_Val : out Boolean)
2090 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pragma_Name (N));
2091 Arg1 : constant Node_Id :=
2092 First (Pragma_Argument_Associations (N));
2093 Obj_Decl : constant Node_Id := Find_Related_Context (N);
2094 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
2100 -- Do not analyze the pragma multiple times
2102 if Is_Analyzed_Pragma (N) then
2106 Error_Msg_Name_1 := Pragma_Name (N);
2108 -- An external property pragma must apply to an effectively volatile
2109 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
2110 -- The check is performed at the end of the declarative region due to a
2111 -- possible out-of-order arrangement of pragmas:
2114 -- pragma Async_Readers (Obj);
2115 -- pragma Volatile (Obj);
2117 if Prag_Id /= Pragma_No_Caching
2118 and then not Is_Effectively_Volatile (Obj_Id)
2120 if No_Caching_Enabled (Obj_Id) then
2122 ("illegal combination of external property % and property "
2123 & """No_Caching"" (SPARK RM 7.1.2(6))", N);
2126 ("external property % must apply to a volatile object", N);
2129 -- Pragma No_Caching should only apply to volatile variables of
2130 -- a non-effectively volatile type (SPARK RM 7.1.2).
2132 elsif Prag_Id = Pragma_No_Caching then
2133 if Is_Effectively_Volatile (Etype (Obj_Id)) then
2134 SPARK_Msg_N ("property % must not apply to an object of "
2135 & "an effectively volatile type", N);
2136 elsif not Is_Volatile (Obj_Id) then
2137 SPARK_Msg_N ("property % must apply to a volatile object", N);
2141 -- Ensure that the Boolean expression (if present) is static. A missing
2142 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
2146 if Present (Arg1) then
2147 Expr := Get_Pragma_Arg (Arg1);
2149 if Is_OK_Static_Expression (Expr) then
2150 Expr_Val := Is_True (Expr_Value (Expr));
2154 Set_Is_Analyzed_Pragma (N);
2155 end Analyze_External_Property_In_Decl_Part;
2157 ---------------------------------
2158 -- Analyze_Global_In_Decl_Part --
2159 ---------------------------------
2161 procedure Analyze_Global_In_Decl_Part (N : Node_Id) is
2162 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
2163 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
2164 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
2166 Constits_Seen : Elist_Id := No_Elist;
2167 -- A list containing the entities of all constituents processed so far.
2168 -- It aids in detecting illegal usage of a state and a corresponding
2169 -- constituent in pragma [Refinde_]Global.
2171 Seen : Elist_Id := No_Elist;
2172 -- A list containing the entities of all the items processed so far. It
2173 -- plays a role in detecting distinct entities.
2175 States_Seen : Elist_Id := No_Elist;
2176 -- A list containing the entities of all states processed so far. It
2177 -- helps in detecting illegal usage of a state and a corresponding
2178 -- constituent in pragma [Refined_]Global.
2180 In_Out_Seen : Boolean := False;
2181 Input_Seen : Boolean := False;
2182 Output_Seen : Boolean := False;
2183 Proof_Seen : Boolean := False;
2184 -- Flags used to verify the consistency of modes
2186 procedure Analyze_Global_List
2188 Global_Mode : Name_Id := Name_Input);
2189 -- Verify the legality of a single global list declaration. Global_Mode
2190 -- denotes the current mode in effect.
2192 -------------------------
2193 -- Analyze_Global_List --
2194 -------------------------
2196 procedure Analyze_Global_List
2198 Global_Mode : Name_Id := Name_Input)
2200 procedure Analyze_Global_Item
2202 Global_Mode : Name_Id);
2203 -- Verify the legality of a single global item declaration denoted by
2204 -- Item. Global_Mode denotes the current mode in effect.
2206 procedure Check_Duplicate_Mode
2208 Status : in out Boolean);
2209 -- Flag Status denotes whether a particular mode has been seen while
2210 -- processing a global list. This routine verifies that Mode is not a
2211 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2213 procedure Check_Mode_Restriction_In_Enclosing_Context
2215 Item_Id : Entity_Id);
2216 -- Verify that an item of mode In_Out or Output does not appear as
2217 -- an input in the Global aspect of an enclosing subprogram or task
2218 -- unit. If this is the case, emit an error. Item and Item_Id are
2219 -- respectively the item and its entity.
2221 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id);
2222 -- Mode denotes either In_Out or Output. Depending on the kind of the
2223 -- related subprogram, emit an error if those two modes apply to a
2224 -- function (SPARK RM 6.1.4(10)).
2226 -------------------------
2227 -- Analyze_Global_Item --
2228 -------------------------
2230 procedure Analyze_Global_Item
2232 Global_Mode : Name_Id)
2234 Item_Id : Entity_Id;
2237 -- Detect one of the following cases
2239 -- with Global => (null, Name)
2240 -- with Global => (Name_1, null, Name_2)
2241 -- with Global => (Name, null)
2243 if Nkind (Item) = N_Null then
2244 SPARK_Msg_N ("cannot mix null and non-null global items", Item);
2249 Resolve_State (Item);
2251 -- Find the entity of the item. If this is a renaming, climb the
2252 -- renaming chain to reach the root object. Renamings of non-
2253 -- entire objects do not yield an entity (Empty).
2255 Item_Id := Entity_Of (Item);
2257 if Present (Item_Id) then
2259 -- A global item may denote a formal parameter of an enclosing
2260 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2261 -- provide a better error diagnostic.
2263 if Is_Formal (Item_Id) then
2264 if Scope (Item_Id) = Spec_Id then
2266 (Fix_Msg (Spec_Id, "global item cannot reference "
2267 & "parameter of subprogram &"), Item, Spec_Id);
2271 -- A global item may denote a concurrent type as long as it is
2272 -- the current instance of an enclosing protected or task type
2273 -- (SPARK RM 6.1.4).
2275 elsif Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then
2276 if Is_CCT_Instance (Item_Id, Spec_Id) then
2278 -- Pragma [Refined_]Global associated with a protected
2279 -- subprogram cannot mention the current instance of a
2280 -- protected type because the instance behaves as a
2281 -- formal parameter.
2283 if Ekind (Item_Id) = E_Protected_Type then
2284 if Scope (Spec_Id) = Item_Id then
2285 Error_Msg_Name_1 := Chars (Item_Id);
2287 (Fix_Msg (Spec_Id, "global item of subprogram & "
2288 & "cannot reference current instance of "
2289 & "protected type %"), Item, Spec_Id);
2293 -- Pragma [Refined_]Global associated with a task type
2294 -- cannot mention the current instance of a task type
2295 -- because the instance behaves as a formal parameter.
2297 else pragma Assert (Ekind (Item_Id) = E_Task_Type);
2298 if Spec_Id = Item_Id then
2299 Error_Msg_Name_1 := Chars (Item_Id);
2301 (Fix_Msg (Spec_Id, "global item of subprogram & "
2302 & "cannot reference current instance of task "
2303 & "type %"), Item, Spec_Id);
2308 -- Otherwise the global item denotes a subtype mark that is
2309 -- not a current instance.
2313 ("invalid use of subtype mark in global list", Item);
2317 -- A global item may denote the anonymous object created for a
2318 -- single protected/task type as long as the current instance
2319 -- is the same single type (SPARK RM 6.1.4).
2321 elsif Is_Single_Concurrent_Object (Item_Id)
2322 and then Is_CCT_Instance (Etype (Item_Id), Spec_Id)
2324 -- Pragma [Refined_]Global associated with a protected
2325 -- subprogram cannot mention the current instance of a
2326 -- protected type because the instance behaves as a formal
2329 if Is_Single_Protected_Object (Item_Id) then
2330 if Scope (Spec_Id) = Etype (Item_Id) then
2331 Error_Msg_Name_1 := Chars (Item_Id);
2333 (Fix_Msg (Spec_Id, "global item of subprogram & "
2334 & "cannot reference current instance of protected "
2335 & "type %"), Item, Spec_Id);
2339 -- Pragma [Refined_]Global associated with a task type
2340 -- cannot mention the current instance of a task type
2341 -- because the instance behaves as a formal parameter.
2343 else pragma Assert (Is_Single_Task_Object (Item_Id));
2344 if Spec_Id = Item_Id then
2345 Error_Msg_Name_1 := Chars (Item_Id);
2347 (Fix_Msg (Spec_Id, "global item of subprogram & "
2348 & "cannot reference current instance of task "
2349 & "type %"), Item, Spec_Id);
2354 -- A formal object may act as a global item inside a generic
2356 elsif Is_Formal_Object (Item_Id) then
2359 -- The only legal references are those to abstract states,
2360 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2362 elsif not Ekind_In (Item_Id, E_Abstract_State,
2368 ("global item must denote object, state or current "
2369 & "instance of concurrent type", Item);
2371 if Ekind (Item_Id) in Named_Kind then
2373 ("\named number & is not an object", Item, Item);
2379 -- State related checks
2381 if Ekind (Item_Id) = E_Abstract_State then
2383 -- Package and subprogram bodies are instantiated
2384 -- individually in a separate compiler pass. Due to this
2385 -- mode of instantiation, the refinement of a state may
2386 -- no longer be visible when a subprogram body contract
2387 -- is instantiated. Since the generic template is legal,
2388 -- do not perform this check in the instance to circumvent
2394 -- An abstract state with visible refinement cannot appear
2395 -- in pragma [Refined_]Global as its place must be taken by
2396 -- some of its constituents (SPARK RM 6.1.4(7)).
2398 elsif Has_Visible_Refinement (Item_Id) then
2400 ("cannot mention state & in global refinement",
2402 SPARK_Msg_N ("\use its constituents instead", Item);
2405 -- An external state cannot appear as a global item of a
2406 -- nonvolatile function (SPARK RM 7.1.3(8)).
2408 elsif Is_External_State (Item_Id)
2409 and then Ekind_In (Spec_Id, E_Function, E_Generic_Function)
2410 and then not Is_Volatile_Function (Spec_Id)
2413 ("external state & cannot act as global item of "
2414 & "nonvolatile function", Item, Item_Id);
2417 -- If the reference to the abstract state appears in an
2418 -- enclosing package body that will eventually refine the
2419 -- state, record the reference for future checks.
2422 Record_Possible_Body_Reference
2423 (State_Id => Item_Id,
2427 -- Constant related checks
2429 elsif Ekind (Item_Id) = E_Constant
2430 and then not Is_Access_Type (Etype (Item_Id))
2433 -- Unless it is of an access type, a constant is a read-only
2434 -- item, therefore it cannot act as an output.
2436 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2438 ("constant & cannot act as output", Item, Item_Id);
2442 -- Loop parameter related checks
2444 elsif Ekind (Item_Id) = E_Loop_Parameter then
2446 -- A loop parameter is a read-only item, therefore it cannot
2447 -- act as an output.
2449 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2451 ("loop parameter & cannot act as output",
2456 -- Variable related checks. These are only relevant when
2457 -- SPARK_Mode is on as they are not standard Ada legality
2460 elsif SPARK_Mode = On
2461 and then Ekind (Item_Id) = E_Variable
2462 and then Is_Effectively_Volatile (Item_Id)
2464 -- An effectively volatile object cannot appear as a global
2465 -- item of a nonvolatile function (SPARK RM 7.1.3(8)).
2467 if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
2468 and then not Is_Volatile_Function (Spec_Id)
2471 ("volatile object & cannot act as global item of a "
2472 & "function", Item, Item_Id);
2475 -- An effectively volatile object with external property
2476 -- Effective_Reads set to True must have mode Output or
2477 -- In_Out (SPARK RM 7.1.3(10)).
2479 elsif Effective_Reads_Enabled (Item_Id)
2480 and then Global_Mode = Name_Input
2483 ("volatile object & with property Effective_Reads must "
2484 & "have mode In_Out or Output", Item, Item_Id);
2489 -- When the item renames an entire object, replace the item
2490 -- with a reference to the object.
2492 if Entity (Item) /= Item_Id then
2493 Rewrite (Item, New_Occurrence_Of (Item_Id, Sloc (Item)));
2497 -- Some form of illegal construct masquerading as a name
2498 -- (SPARK RM 6.1.4(4)).
2502 ("global item must denote object, state or current instance "
2503 & "of concurrent type", Item);
2507 -- Verify that an output does not appear as an input in an
2508 -- enclosing subprogram.
2510 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2511 Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id);
2514 -- The same entity might be referenced through various way.
2515 -- Check the entity of the item rather than the item itself
2516 -- (SPARK RM 6.1.4(10)).
2518 if Contains (Seen, Item_Id) then
2519 SPARK_Msg_N ("duplicate global item", Item);
2521 -- Add the entity of the current item to the list of processed
2525 Append_New_Elmt (Item_Id, Seen);
2527 if Ekind (Item_Id) = E_Abstract_State then
2528 Append_New_Elmt (Item_Id, States_Seen);
2530 -- The variable may eventually become a constituent of a single
2531 -- protected/task type. Record the reference now and verify its
2532 -- legality when analyzing the contract of the variable
2535 elsif Ekind (Item_Id) = E_Variable then
2536 Record_Possible_Part_Of_Reference
2541 if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable)
2542 and then Present (Encapsulating_State (Item_Id))
2544 Append_New_Elmt (Item_Id, Constits_Seen);
2547 end Analyze_Global_Item;
2549 --------------------------
2550 -- Check_Duplicate_Mode --
2551 --------------------------
2553 procedure Check_Duplicate_Mode
2555 Status : in out Boolean)
2559 SPARK_Msg_N ("duplicate global mode", Mode);
2563 end Check_Duplicate_Mode;
2565 -------------------------------------------------
2566 -- Check_Mode_Restriction_In_Enclosing_Context --
2567 -------------------------------------------------
2569 procedure Check_Mode_Restriction_In_Enclosing_Context
2571 Item_Id : Entity_Id)
2573 Context : Entity_Id;
2575 Inputs : Elist_Id := No_Elist;
2576 Outputs : Elist_Id := No_Elist;
2579 -- Traverse the scope stack looking for enclosing subprograms or
2580 -- tasks subject to pragma [Refined_]Global.
2582 Context := Scope (Subp_Id);
2583 while Present (Context) and then Context /= Standard_Standard loop
2585 -- For a single task type, retrieve the corresponding object to
2586 -- which pragma [Refined_]Global is attached.
2588 if Ekind (Context) = E_Task_Type
2589 and then Is_Single_Concurrent_Type (Context)
2591 Context := Anonymous_Object (Context);
2594 if (Is_Subprogram (Context)
2595 or else Ekind (Context) = E_Task_Type
2596 or else Is_Single_Task_Object (Context))
2598 (Present (Get_Pragma (Context, Pragma_Global))
2600 Present (Get_Pragma (Context, Pragma_Refined_Global)))
2602 Collect_Subprogram_Inputs_Outputs
2603 (Subp_Id => Context,
2604 Subp_Inputs => Inputs,
2605 Subp_Outputs => Outputs,
2606 Global_Seen => Dummy);
2608 -- The item is classified as In_Out or Output but appears as
2609 -- an Input in an enclosing subprogram or task unit (SPARK
2612 if Appears_In (Inputs, Item_Id)
2613 and then not Appears_In (Outputs, Item_Id)
2616 ("global item & cannot have mode In_Out or Output",
2619 if Is_Subprogram (Context) then
2621 (Fix_Msg (Subp_Id, "\item already appears as input "
2622 & "of subprogram &"), Item, Context);
2625 (Fix_Msg (Subp_Id, "\item already appears as input "
2626 & "of task &"), Item, Context);
2629 -- Stop the traversal once an error has been detected
2635 Context := Scope (Context);
2637 end Check_Mode_Restriction_In_Enclosing_Context;
2639 ----------------------------------------
2640 -- Check_Mode_Restriction_In_Function --
2641 ----------------------------------------
2643 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
2645 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
2647 ("global mode & is not applicable to functions", Mode);
2649 end Check_Mode_Restriction_In_Function;
2657 -- Start of processing for Analyze_Global_List
2660 if Nkind (List) = N_Null then
2661 Set_Analyzed (List);
2663 -- Single global item declaration
2665 elsif Nkind_In (List, N_Expanded_Name,
2667 N_Selected_Component)
2669 Analyze_Global_Item (List, Global_Mode);
2671 -- Simple global list or moded global list declaration
2673 elsif Nkind (List) = N_Aggregate then
2674 Set_Analyzed (List);
2676 -- The declaration of a simple global list appear as a collection
2679 if Present (Expressions (List)) then
2680 if Present (Component_Associations (List)) then
2682 ("cannot mix moded and non-moded global lists", List);
2685 Item := First (Expressions (List));
2686 while Present (Item) loop
2687 Analyze_Global_Item (Item, Global_Mode);
2691 -- The declaration of a moded global list appears as a collection
2692 -- of component associations where individual choices denote
2695 elsif Present (Component_Associations (List)) then
2696 if Present (Expressions (List)) then
2698 ("cannot mix moded and non-moded global lists", List);
2701 Assoc := First (Component_Associations (List));
2702 while Present (Assoc) loop
2703 Mode := First (Choices (Assoc));
2705 if Nkind (Mode) = N_Identifier then
2706 if Chars (Mode) = Name_In_Out then
2707 Check_Duplicate_Mode (Mode, In_Out_Seen);
2708 Check_Mode_Restriction_In_Function (Mode);
2710 elsif Chars (Mode) = Name_Input then
2711 Check_Duplicate_Mode (Mode, Input_Seen);
2713 elsif Chars (Mode) = Name_Output then
2714 Check_Duplicate_Mode (Mode, Output_Seen);
2715 Check_Mode_Restriction_In_Function (Mode);
2717 elsif Chars (Mode) = Name_Proof_In then
2718 Check_Duplicate_Mode (Mode, Proof_Seen);
2721 SPARK_Msg_N ("invalid mode selector", Mode);
2725 SPARK_Msg_N ("invalid mode selector", Mode);
2728 -- Items in a moded list appear as a collection of
2729 -- expressions. Reuse the existing machinery to analyze
2733 (List => Expression (Assoc),
2734 Global_Mode => Chars (Mode));
2742 raise Program_Error;
2745 -- Any other attempt to declare a global item is illegal. This is a
2746 -- syntax error, always report.
2749 Error_Msg_N ("malformed global list", List);
2751 end Analyze_Global_List;
2755 Items : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
2757 Restore_Scope : Boolean := False;
2759 -- Start of processing for Analyze_Global_In_Decl_Part
2762 -- Do not analyze the pragma multiple times
2764 if Is_Analyzed_Pragma (N) then
2768 -- There is nothing to be done for a null global list
2770 if Nkind (Items) = N_Null then
2771 Set_Analyzed (Items);
2773 -- Analyze the various forms of global lists and items. Note that some
2774 -- of these may be malformed in which case the analysis emits error
2778 -- When pragma [Refined_]Global appears on a single concurrent type,
2779 -- it is relocated to the anonymous object.
2781 if Is_Single_Concurrent_Object (Spec_Id) then
2784 -- Ensure that the formal parameters are visible when processing an
2785 -- item. This falls out of the general rule of aspects pertaining to
2786 -- subprogram declarations.
2788 elsif not In_Open_Scopes (Spec_Id) then
2789 Restore_Scope := True;
2790 Push_Scope (Spec_Id);
2792 if Ekind (Spec_Id) = E_Task_Type then
2793 if Has_Discriminants (Spec_Id) then
2794 Install_Discriminants (Spec_Id);
2797 elsif Is_Generic_Subprogram (Spec_Id) then
2798 Install_Generic_Formals (Spec_Id);
2801 Install_Formals (Spec_Id);
2805 Analyze_Global_List (Items);
2807 if Restore_Scope then
2812 -- Ensure that a state and a corresponding constituent do not appear
2813 -- together in pragma [Refined_]Global.
2815 Check_State_And_Constituent_Use
2816 (States => States_Seen,
2817 Constits => Constits_Seen,
2820 Set_Is_Analyzed_Pragma (N);
2821 end Analyze_Global_In_Decl_Part;
2823 --------------------------------------------
2824 -- Analyze_Initial_Condition_In_Decl_Part --
2825 --------------------------------------------
2827 -- WARNING: This routine manages Ghost regions. Return statements must be
2828 -- replaced by gotos which jump to the end of the routine and restore the
2831 procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is
2832 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2833 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2834 Expr : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
2836 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
2837 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
2838 -- Save the Ghost-related attributes to restore on exit
2841 -- Do not analyze the pragma multiple times
2843 if Is_Analyzed_Pragma (N) then
2847 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2848 -- analysis of the pragma, the Ghost mode at point of declaration and
2849 -- point of analysis may not necessarily be the same. Use the mode in
2850 -- effect at the point of declaration.
2854 -- The expression is preanalyzed because it has not been moved to its
2855 -- final place yet. A direct analysis may generate side effects and this
2856 -- is not desired at this point.
2858 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
2859 Set_Is_Analyzed_Pragma (N);
2861 Restore_Ghost_Region (Saved_GM, Saved_IGR);
2862 end Analyze_Initial_Condition_In_Decl_Part;
2864 --------------------------------------
2865 -- Analyze_Initializes_In_Decl_Part --
2866 --------------------------------------
2868 procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is
2869 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2870 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2872 Constits_Seen : Elist_Id := No_Elist;
2873 -- A list containing the entities of all constituents processed so far.
2874 -- It aids in detecting illegal usage of a state and a corresponding
2875 -- constituent in pragma Initializes.
2877 Items_Seen : Elist_Id := No_Elist;
2878 -- A list of all initialization items processed so far. This list is
2879 -- used to detect duplicate items.
2881 States_And_Objs : Elist_Id := No_Elist;
2882 -- A list of all abstract states and objects declared in the visible
2883 -- declarations of the related package. This list is used to detect the
2884 -- legality of initialization items.
2886 States_Seen : Elist_Id := No_Elist;
2887 -- A list containing the entities of all states processed so far. It
2888 -- helps in detecting illegal usage of a state and a corresponding
2889 -- constituent in pragma Initializes.
2891 procedure Analyze_Initialization_Item (Item : Node_Id);
2892 -- Verify the legality of a single initialization item
2894 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id);
2895 -- Verify the legality of a single initialization item followed by a
2896 -- list of input items.
2898 procedure Collect_States_And_Objects (Pack_Decl : Node_Id);
2899 -- Inspect the visible declarations of the related package and gather
2900 -- the entities of all abstract states and objects in States_And_Objs.
2902 ---------------------------------
2903 -- Analyze_Initialization_Item --
2904 ---------------------------------
2906 procedure Analyze_Initialization_Item (Item : Node_Id) is
2907 Item_Id : Entity_Id;
2911 Resolve_State (Item);
2913 if Is_Entity_Name (Item) then
2914 Item_Id := Entity_Of (Item);
2916 if Present (Item_Id)
2917 and then Ekind_In (Item_Id, E_Abstract_State,
2921 -- When the initialization item is undefined, it appears as
2922 -- Any_Id. Do not continue with the analysis of the item.
2924 if Item_Id = Any_Id then
2927 -- The state or variable must be declared in the visible
2928 -- declarations of the package (SPARK RM 7.1.5(7)).
2930 elsif not Contains (States_And_Objs, Item_Id) then
2931 Error_Msg_Name_1 := Chars (Pack_Id);
2933 ("initialization item & must appear in the visible "
2934 & "declarations of package %", Item, Item_Id);
2936 -- Detect a duplicate use of the same initialization item
2937 -- (SPARK RM 7.1.5(5)).
2939 elsif Contains (Items_Seen, Item_Id) then
2940 SPARK_Msg_N ("duplicate initialization item", Item);
2942 -- The item is legal, add it to the list of processed states
2946 Append_New_Elmt (Item_Id, Items_Seen);
2948 if Ekind (Item_Id) = E_Abstract_State then
2949 Append_New_Elmt (Item_Id, States_Seen);
2952 if Present (Encapsulating_State (Item_Id)) then
2953 Append_New_Elmt (Item_Id, Constits_Seen);
2957 -- The item references something that is not a state or object
2958 -- (SPARK RM 7.1.5(3)).
2962 ("initialization item must denote object or state", Item);
2965 -- Some form of illegal construct masquerading as a name
2966 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2970 ("initialization item must denote object or state", Item);
2972 end Analyze_Initialization_Item;
2974 ---------------------------------------------
2975 -- Analyze_Initialization_Item_With_Inputs --
2976 ---------------------------------------------
2978 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is
2979 Inputs_Seen : Elist_Id := No_Elist;
2980 -- A list of all inputs processed so far. This list is used to detect
2981 -- duplicate uses of an input.
2983 Non_Null_Seen : Boolean := False;
2984 Null_Seen : Boolean := False;
2985 -- Flags used to check the legality of an input list
2987 procedure Analyze_Input_Item (Input : Node_Id);
2988 -- Verify the legality of a single input item
2990 ------------------------
2991 -- Analyze_Input_Item --
2992 ------------------------
2994 procedure Analyze_Input_Item (Input : Node_Id) is
2995 Input_Id : Entity_Id;
3000 if Nkind (Input) = N_Null then
3003 ("multiple null initializations not allowed", Item);
3005 elsif Non_Null_Seen then
3007 ("cannot mix null and non-null initialization item", Item);
3015 Non_Null_Seen := True;
3019 ("cannot mix null and non-null initialization item", Item);
3023 Resolve_State (Input);
3025 if Is_Entity_Name (Input) then
3026 Input_Id := Entity_Of (Input);
3028 if Present (Input_Id)
3029 and then Ekind_In (Input_Id, E_Abstract_State,
3031 E_Generic_In_Out_Parameter,
3032 E_Generic_In_Parameter,
3040 -- The input cannot denote states or objects declared
3041 -- within the related package (SPARK RM 7.1.5(4)).
3043 if Within_Scope (Input_Id, Current_Scope) then
3045 -- Do not consider generic formal parameters or their
3046 -- respective mappings to generic formals. Even though
3047 -- the formals appear within the scope of the package,
3048 -- it is allowed for an initialization item to depend
3049 -- on an input item.
3051 if Ekind_In (Input_Id, E_Generic_In_Out_Parameter,
3052 E_Generic_In_Parameter)
3056 elsif Ekind_In (Input_Id, E_Constant, E_Variable)
3057 and then Present (Corresponding_Generic_Association
3058 (Declaration_Node (Input_Id)))
3063 Error_Msg_Name_1 := Chars (Pack_Id);
3065 ("input item & cannot denote a visible object or "
3066 & "state of package %", Input, Input_Id);
3071 -- Detect a duplicate use of the same input item
3072 -- (SPARK RM 7.1.5(5)).
3074 if Contains (Inputs_Seen, Input_Id) then
3075 SPARK_Msg_N ("duplicate input item", Input);
3079 -- At this point it is known that the input is legal. Add
3080 -- it to the list of processed inputs.
3082 Append_New_Elmt (Input_Id, Inputs_Seen);
3084 if Ekind (Input_Id) = E_Abstract_State then
3085 Append_New_Elmt (Input_Id, States_Seen);
3088 if Ekind_In (Input_Id, E_Abstract_State,
3091 and then Present (Encapsulating_State (Input_Id))
3093 Append_New_Elmt (Input_Id, Constits_Seen);
3096 -- The input references something that is not a state or an
3097 -- object (SPARK RM 7.1.5(3)).
3101 ("input item must denote object or state", Input);
3104 -- Some form of illegal construct masquerading as a name
3105 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
3109 ("input item must denote object or state", Input);
3112 end Analyze_Input_Item;
3116 Inputs : constant Node_Id := Expression (Item);
3120 Name_Seen : Boolean := False;
3121 -- A flag used to detect multiple item names
3123 -- Start of processing for Analyze_Initialization_Item_With_Inputs
3126 -- Inspect the name of an item with inputs
3128 Elmt := First (Choices (Item));
3129 while Present (Elmt) loop
3131 SPARK_Msg_N ("only one item allowed in initialization", Elmt);
3134 Analyze_Initialization_Item (Elmt);
3140 -- Multiple input items appear as an aggregate
3142 if Nkind (Inputs) = N_Aggregate then
3143 if Present (Expressions (Inputs)) then
3144 Input := First (Expressions (Inputs));
3145 while Present (Input) loop
3146 Analyze_Input_Item (Input);
3151 if Present (Component_Associations (Inputs)) then
3153 ("inputs must appear in named association form", Inputs);
3156 -- Single input item
3159 Analyze_Input_Item (Inputs);
3161 end Analyze_Initialization_Item_With_Inputs;
3163 --------------------------------
3164 -- Collect_States_And_Objects --
3165 --------------------------------
3167 procedure Collect_States_And_Objects (Pack_Decl : Node_Id) is
3168 Pack_Spec : constant Node_Id := Specification (Pack_Decl);
3169 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
3171 State_Elmt : Elmt_Id;
3174 -- Collect the abstract states defined in the package (if any)
3176 if Has_Non_Null_Abstract_State (Pack_Id) then
3177 State_Elmt := First_Elmt (Abstract_States (Pack_Id));
3178 while Present (State_Elmt) loop
3179 Append_New_Elmt (Node (State_Elmt), States_And_Objs);
3180 Next_Elmt (State_Elmt);
3184 -- Collect all objects that appear in the visible declarations of the
3187 if Present (Visible_Declarations (Pack_Spec)) then
3188 Decl := First (Visible_Declarations (Pack_Spec));
3189 while Present (Decl) loop
3190 if Comes_From_Source (Decl)
3191 and then Nkind_In (Decl, N_Object_Declaration,
3192 N_Object_Renaming_Declaration)
3194 Append_New_Elmt (Defining_Entity (Decl), States_And_Objs);
3196 elsif Nkind (Decl) = N_Package_Declaration then
3197 Collect_States_And_Objects (Decl);
3199 elsif Is_Single_Concurrent_Type_Declaration (Decl) then
3201 (Anonymous_Object (Defining_Entity (Decl)),
3208 end Collect_States_And_Objects;
3212 Inits : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
3215 -- Start of processing for Analyze_Initializes_In_Decl_Part
3218 -- Do not analyze the pragma multiple times
3220 if Is_Analyzed_Pragma (N) then
3224 -- Nothing to do when the initialization list is empty
3226 if Nkind (Inits) = N_Null then
3230 -- Single and multiple initialization clauses appear as an aggregate. If
3231 -- this is not the case, then either the parser or the analysis of the
3232 -- pragma failed to produce an aggregate.
3234 pragma Assert (Nkind (Inits) = N_Aggregate);
3236 -- Initialize the various lists used during analysis
3238 Collect_States_And_Objects (Pack_Decl);
3240 if Present (Expressions (Inits)) then
3241 Init := First (Expressions (Inits));
3242 while Present (Init) loop
3243 Analyze_Initialization_Item (Init);
3248 if Present (Component_Associations (Inits)) then
3249 Init := First (Component_Associations (Inits));
3250 while Present (Init) loop
3251 Analyze_Initialization_Item_With_Inputs (Init);
3256 -- Ensure that a state and a corresponding constituent do not appear
3257 -- together in pragma Initializes.
3259 Check_State_And_Constituent_Use
3260 (States => States_Seen,
3261 Constits => Constits_Seen,
3264 Set_Is_Analyzed_Pragma (N);
3265 end Analyze_Initializes_In_Decl_Part;
3267 ---------------------
3268 -- Analyze_Part_Of --
3269 ---------------------
3271 procedure Analyze_Part_Of
3273 Item_Id : Entity_Id;
3275 Encap_Id : out Entity_Id;
3276 Legal : out Boolean)
3278 procedure Check_Part_Of_Abstract_State;
3279 pragma Inline (Check_Part_Of_Abstract_State);
3280 -- Verify the legality of indicator Part_Of when the encapsulator is an
3283 procedure Check_Part_Of_Concurrent_Type;
3284 pragma Inline (Check_Part_Of_Concurrent_Type);
3285 -- Verify the legality of indicator Part_Of when the encapsulator is a
3286 -- single concurrent type.
3288 ----------------------------------
3289 -- Check_Part_Of_Abstract_State --
3290 ----------------------------------
3292 procedure Check_Part_Of_Abstract_State is
3293 Pack_Id : Entity_Id;
3294 Placement : State_Space_Kind;
3295 Parent_Unit : Entity_Id;
3298 -- Determine where the object, package instantiation or state lives
3299 -- with respect to the enclosing packages or package bodies.
3301 Find_Placement_In_State_Space
3302 (Item_Id => Item_Id,
3303 Placement => Placement,
3304 Pack_Id => Pack_Id);
3306 -- The item appears in a non-package construct with a declarative
3307 -- part (subprogram, block, etc). As such, the item is not allowed
3308 -- to be a part of an encapsulating state because the item is not
3311 if Placement = Not_In_Package then
3313 ("indicator Part_Of cannot appear in this context "
3314 & "(SPARK RM 7.2.6(5))", Indic);
3316 Error_Msg_Name_1 := Chars (Scope (Encap_Id));
3318 ("\& is not part of the hidden state of package %",
3322 -- The item appears in the visible state space of some package. In
3323 -- general this scenario does not warrant Part_Of except when the
3324 -- package is a nongeneric private child unit and the encapsulating
3325 -- state is declared in a parent unit or a public descendant of that
3328 elsif Placement = Visible_State_Space then
3329 if Is_Child_Unit (Pack_Id)
3330 and then not Is_Generic_Unit (Pack_Id)
3331 and then Is_Private_Descendant (Pack_Id)
3333 -- A variable or state abstraction which is part of the visible
3334 -- state of a nongeneric private child unit or its public
3335 -- descendants must have its Part_Of indicator specified. The
3336 -- Part_Of indicator must denote a state declared by either the
3337 -- parent unit of the private unit or by a public descendant of
3338 -- that parent unit.
3340 -- Find the nearest private ancestor (which can be the current
3343 Parent_Unit := Pack_Id;
3344 while Present (Parent_Unit) loop
3347 (Parent (Unit_Declaration_Node (Parent_Unit)));
3348 Parent_Unit := Scope (Parent_Unit);
3351 Parent_Unit := Scope (Parent_Unit);
3353 if not Is_Child_Or_Sibling (Pack_Id, Scope (Encap_Id)) then
3355 ("indicator Part_Of must denote abstract state of & or of "
3356 & "its public descendant (SPARK RM 7.2.6(3))",
3357 Indic, Parent_Unit);
3360 elsif Scope (Encap_Id) = Parent_Unit
3362 (Is_Ancestor_Package (Parent_Unit, Scope (Encap_Id))
3363 and then not Is_Private_Descendant (Scope (Encap_Id)))
3369 ("indicator Part_Of must denote abstract state of & or of "
3370 & "its public descendant (SPARK RM 7.2.6(3))",
3371 Indic, Parent_Unit);
3375 -- Indicator Part_Of is not needed when the related package is
3376 -- not a nongeneric private child unit or a public descendant
3381 ("indicator Part_Of cannot appear in this context "
3382 & "(SPARK RM 7.2.6(5))", Indic);
3384 Error_Msg_Name_1 := Chars (Pack_Id);
3386 ("\& is declared in the visible part of package %",
3391 -- When the item appears in the private state space of a package, the
3392 -- encapsulating state must be declared in the same package.
3394 elsif Placement = Private_State_Space then
3395 if Scope (Encap_Id) /= Pack_Id then
3397 ("indicator Part_Of must denote an abstract state of "
3398 & "package & (SPARK RM 7.2.6(2))", Indic, Pack_Id);
3400 Error_Msg_Name_1 := Chars (Pack_Id);
3402 ("\& is declared in the private part of package %",
3407 -- Items declared in the body state space of a package do not need
3408 -- Part_Of indicators as the refinement has already been seen.
3412 ("indicator Part_Of cannot appear in this context "
3413 & "(SPARK RM 7.2.6(5))", Indic);
3415 if Scope (Encap_Id) = Pack_Id then
3416 Error_Msg_Name_1 := Chars (Pack_Id);
3418 ("\& is declared in the body of package %", Indic, Item_Id);
3424 -- At this point it is known that the Part_Of indicator is legal
3427 end Check_Part_Of_Abstract_State;
3429 -----------------------------------
3430 -- Check_Part_Of_Concurrent_Type --
3431 -----------------------------------
3433 procedure Check_Part_Of_Concurrent_Type is
3434 function In_Proper_Order
3436 Second : Node_Id) return Boolean;
3437 pragma Inline (In_Proper_Order);
3438 -- Determine whether node First precedes node Second
3440 procedure Placement_Error;
3441 pragma Inline (Placement_Error);
3442 -- Emit an error concerning the illegal placement of the item with
3443 -- respect to the single concurrent type.
3445 ---------------------
3446 -- In_Proper_Order --
3447 ---------------------
3449 function In_Proper_Order
3451 Second : Node_Id) return Boolean
3456 if List_Containing (First) = List_Containing (Second) then
3458 while Present (N) loop
3468 end In_Proper_Order;
3470 ---------------------
3471 -- Placement_Error --
3472 ---------------------
3474 procedure Placement_Error is
3477 ("indicator Part_Of must denote a previously declared single "
3478 & "protected type or single task type", Encap);
3479 end Placement_Error;
3483 Conc_Typ : constant Entity_Id := Etype (Encap_Id);
3484 Encap_Decl : constant Node_Id := Declaration_Node (Encap_Id);
3485 Encap_Context : constant Node_Id := Parent (Encap_Decl);
3487 Item_Context : Node_Id;
3488 Item_Decl : Node_Id;
3489 Prv_Decls : List_Id;
3490 Vis_Decls : List_Id;
3492 -- Start of processing for Check_Part_Of_Concurrent_Type
3495 -- Only abstract states and variables can act as constituents of an
3496 -- encapsulating single concurrent type.
3498 if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
3501 -- The constituent is a constant
3503 elsif Ekind (Item_Id) = E_Constant then
3504 Error_Msg_Name_1 := Chars (Encap_Id);
3506 (Fix_Msg (Conc_Typ, "constant & cannot act as constituent of "
3507 & "single protected type %"), Indic, Item_Id);
3510 -- The constituent is a package instantiation
3513 Error_Msg_Name_1 := Chars (Encap_Id);
3515 (Fix_Msg (Conc_Typ, "package instantiation & cannot act as "
3516 & "constituent of single protected type %"), Indic, Item_Id);
3520 -- When the item denotes an abstract state of a nested package, use
3521 -- the declaration of the package to detect proper placement.
3526 -- with Abstract_State => (State with Part_Of => T)
3528 if Ekind (Item_Id) = E_Abstract_State then
3529 Item_Decl := Unit_Declaration_Node (Scope (Item_Id));
3531 Item_Decl := Declaration_Node (Item_Id);
3534 Item_Context := Parent (Item_Decl);
3536 -- The item and the single concurrent type must appear in the same
3537 -- declarative region, with the item following the declaration of
3538 -- the single concurrent type (SPARK RM 9(3)).
3540 if Item_Context = Encap_Context then
3541 if Nkind_In (Item_Context, N_Package_Specification,
3542 N_Protected_Definition,
3545 Prv_Decls := Private_Declarations (Item_Context);
3546 Vis_Decls := Visible_Declarations (Item_Context);
3548 -- The placement is OK when the single concurrent type appears
3549 -- within the visible declarations and the item in the private
3555 -- Constit : ... with Part_Of => PO;
3558 if List_Containing (Encap_Decl) = Vis_Decls
3559 and then List_Containing (Item_Decl) = Prv_Decls
3563 -- The placement is illegal when the item appears within the
3564 -- visible declarations and the single concurrent type is in
3565 -- the private declarations.
3568 -- Constit : ... with Part_Of => PO;
3573 elsif List_Containing (Item_Decl) = Vis_Decls
3574 and then List_Containing (Encap_Decl) = Prv_Decls
3579 -- Otherwise both the item and the single concurrent type are
3580 -- in the same list. Ensure that the declaration of the single
3581 -- concurrent type precedes that of the item.
3583 elsif not In_Proper_Order
3584 (First => Encap_Decl,
3585 Second => Item_Decl)
3591 -- Otherwise both the item and the single concurrent type are
3592 -- in the same list. Ensure that the declaration of the single
3593 -- concurrent type precedes that of the item.
3595 elsif not In_Proper_Order
3596 (First => Encap_Decl,
3597 Second => Item_Decl)
3603 -- Otherwise the item and the single concurrent type reside within
3604 -- unrelated regions.
3607 Error_Msg_Name_1 := Chars (Encap_Id);
3609 (Fix_Msg (Conc_Typ, "constituent & must be declared "
3610 & "immediately within the same region as single protected "
3611 & "type %"), Indic, Item_Id);
3615 -- At this point it is known that the Part_Of indicator is legal
3618 end Check_Part_Of_Concurrent_Type;
3620 -- Start of processing for Analyze_Part_Of
3623 -- Assume that the indicator is illegal
3628 if Nkind_In (Encap, N_Expanded_Name,
3630 N_Selected_Component)
3633 Resolve_State (Encap);
3635 Encap_Id := Entity (Encap);
3637 -- The encapsulator is an abstract state
3639 if Ekind (Encap_Id) = E_Abstract_State then
3642 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
3644 elsif Is_Single_Concurrent_Object (Encap_Id) then
3647 -- Otherwise the encapsulator is not a legal choice
3651 ("indicator Part_Of must denote abstract state, single "
3652 & "protected type or single task type", Encap);
3656 -- This is a syntax error, always report
3660 ("indicator Part_Of must denote abstract state, single protected "
3661 & "type or single task type", Encap);
3665 -- Catch a case where indicator Part_Of denotes the abstract view of a
3666 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3668 if From_Limited_With (Encap_Id)
3669 and then Present (Non_Limited_View (Encap_Id))
3670 and then Ekind (Non_Limited_View (Encap_Id)) = E_Variable
3672 SPARK_Msg_N ("indicator Part_Of must denote abstract state", Encap);
3673 SPARK_Msg_N ("\& denotes abstract view of object", Encap);
3677 -- The encapsulator is an abstract state
3679 if Ekind (Encap_Id) = E_Abstract_State then
3680 Check_Part_Of_Abstract_State;
3682 -- The encapsulator is a single concurrent type
3685 Check_Part_Of_Concurrent_Type;
3687 end Analyze_Part_Of;
3689 ----------------------------------
3690 -- Analyze_Part_Of_In_Decl_Part --
3691 ----------------------------------
3693 procedure Analyze_Part_Of_In_Decl_Part
3695 Freeze_Id : Entity_Id := Empty)
3697 Encap : constant Node_Id :=
3698 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
3699 Errors : constant Nat := Serious_Errors_Detected;
3700 Var_Decl : constant Node_Id := Find_Related_Context (N);
3701 Var_Id : constant Entity_Id := Defining_Entity (Var_Decl);
3702 Constits : Elist_Id;
3703 Encap_Id : Entity_Id;
3707 -- Detect any discrepancies between the placement of the variable with
3708 -- respect to general state space and the encapsulating state or single
3715 Encap_Id => Encap_Id,
3718 -- The Part_Of indicator turns the variable into a constituent of the
3719 -- encapsulating state or single concurrent type.
3722 pragma Assert (Present (Encap_Id));
3723 Constits := Part_Of_Constituents (Encap_Id);
3725 if No (Constits) then
3726 Constits := New_Elmt_List;
3727 Set_Part_Of_Constituents (Encap_Id, Constits);
3730 Append_Elmt (Var_Id, Constits);
3731 Set_Encapsulating_State (Var_Id, Encap_Id);
3733 -- A Part_Of constituent partially refines an abstract state. This
3734 -- property does not apply to protected or task units.
3736 if Ekind (Encap_Id) = E_Abstract_State then
3737 Set_Has_Partial_Visible_Refinement (Encap_Id);
3741 -- Emit a clarification message when the encapsulator is undefined,
3742 -- possibly due to contract freezing.
3744 if Errors /= Serious_Errors_Detected
3745 and then Present (Freeze_Id)
3746 and then Has_Undefined_Reference (Encap)
3748 Contract_Freeze_Error (Var_Id, Freeze_Id);
3750 end Analyze_Part_Of_In_Decl_Part;
3752 --------------------
3753 -- Analyze_Pragma --
3754 --------------------
3756 procedure Analyze_Pragma (N : Node_Id) is
3757 Loc : constant Source_Ptr := Sloc (N);
3759 Pname : Name_Id := Pragma_Name (N);
3760 -- Name of the source pragma, or name of the corresponding aspect for
3761 -- pragmas which originate in a source aspect. In the latter case, the
3762 -- name may be different from the pragma name.
3764 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
3766 Pragma_Exit : exception;
3767 -- This exception is used to exit pragma processing completely. It
3768 -- is used when an error is detected, and no further processing is
3769 -- required. It is also used if an earlier error has left the tree in
3770 -- a state where the pragma should not be processed.
3773 -- Number of pragma argument associations
3779 -- First four pragma arguments (pragma argument association nodes, or
3780 -- Empty if the corresponding argument does not exist).
3782 type Name_List is array (Natural range <>) of Name_Id;
3783 type Args_List is array (Natural range <>) of Node_Id;
3784 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3786 -----------------------
3787 -- Local Subprograms --
3788 -----------------------
3790 procedure Ada_2005_Pragma;
3791 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3792 -- Ada 95 mode, these are implementation defined pragmas, so should be
3793 -- caught by the No_Implementation_Pragmas restriction.
3795 procedure Ada_2012_Pragma;
3796 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3797 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3798 -- should be caught by the No_Implementation_Pragmas restriction.
3800 procedure Analyze_Depends_Global
3801 (Spec_Id : out Entity_Id;
3802 Subp_Decl : out Node_Id;
3803 Legal : out Boolean);
3804 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3805 -- legality of the placement and related context of the pragma. Spec_Id
3806 -- is the entity of the related subprogram. Subp_Decl is the declaration
3807 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3809 procedure Analyze_If_Present (Id : Pragma_Id);
3810 -- Inspect the remainder of the list containing pragma N and look for
3811 -- a pragma that matches Id. If found, analyze the pragma.
3813 procedure Analyze_Pre_Post_Condition;
3814 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3816 procedure Analyze_Refined_Depends_Global_Post
3817 (Spec_Id : out Entity_Id;
3818 Body_Id : out Entity_Id;
3819 Legal : out Boolean);
3820 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3821 -- Refined_Global and Refined_Post. Verify the legality of the placement
3822 -- and related context of the pragma. Spec_Id is the entity of the
3823 -- related subprogram. Body_Id is the entity of the subprogram body.
3824 -- Flag Legal is set when the pragma is legal.
3826 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False);
3827 -- Perform full analysis of pragma Unmodified and the write aspect of
3828 -- pragma Unused. Flag Is_Unused should be set when verifying the
3829 -- semantics of pragma Unused.
3831 procedure Analyze_Unreferenced_Or_Unused (Is_Unused : Boolean := False);
3832 -- Perform full analysis of pragma Unreferenced and the read aspect of
3833 -- pragma Unused. Flag Is_Unused should be set when verifying the
3834 -- semantics of pragma Unused.
3836 procedure Check_Ada_83_Warning;
3837 -- Issues a warning message for the current pragma if operating in Ada
3838 -- 83 mode (used for language pragmas that are not a standard part of
3839 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3842 procedure Check_Arg_Count (Required : Nat);
3843 -- Check argument count for pragma is equal to given parameter. If not,
3844 -- then issue an error message and raise Pragma_Exit.
3846 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3847 -- Arg which can either be a pragma argument association, in which case
3848 -- the check is applied to the expression of the association or an
3849 -- expression directly.
3851 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
3852 -- Check that an argument has the right form for an EXTERNAL_NAME
3853 -- parameter of an extended import/export pragma. The rule is that the
3854 -- name must be an identifier or string literal (in Ada 83 mode) or a
3855 -- static string expression (in Ada 95 mode).
3857 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
3858 -- Check the specified argument Arg to make sure that it is an
3859 -- identifier. If not give error and raise Pragma_Exit.
3861 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
3862 -- Check the specified argument Arg to make sure that it is an integer
3863 -- literal. If not give error and raise Pragma_Exit.
3865 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
3866 -- Check the specified argument Arg to make sure that it has the proper
3867 -- syntactic form for a local name and meets the semantic requirements
3868 -- for a local name. The local name is analyzed as part of the
3869 -- processing for this call. In addition, the local name is required
3870 -- to represent an entity at the library level.
3872 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
3873 -- Check the specified argument Arg to make sure that it has the proper
3874 -- syntactic form for a local name and meets the semantic requirements
3875 -- for a local name. The local name is analyzed as part of the
3876 -- processing for this call.
3878 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
3879 -- Check the specified argument Arg to make sure that it is a valid
3880 -- locking policy name. If not give error and raise Pragma_Exit.
3882 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
3883 -- Check the specified argument Arg to make sure that it is a valid
3884 -- elaboration policy name. If not give error and raise Pragma_Exit.
3886 procedure Check_Arg_Is_One_Of
3889 procedure Check_Arg_Is_One_Of
3891 N1, N2, N3 : Name_Id);
3892 procedure Check_Arg_Is_One_Of
3894 N1, N2, N3, N4 : Name_Id);
3895 procedure Check_Arg_Is_One_Of
3897 N1, N2, N3, N4, N5 : Name_Id);
3898 -- Check the specified argument Arg to make sure that it is an
3899 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3900 -- present). If not then give error and raise Pragma_Exit.
3902 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
3903 -- Check the specified argument Arg to make sure that it is a valid
3904 -- queuing policy name. If not give error and raise Pragma_Exit.
3906 procedure Check_Arg_Is_OK_Static_Expression
3908 Typ : Entity_Id := Empty);
3909 -- Check the specified argument Arg to make sure that it is a static
3910 -- expression of the given type (i.e. it will be analyzed and resolved
3911 -- using this type, which can be any valid argument to Resolve, e.g.
3912 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3913 -- Typ is left Empty, then any static expression is allowed. Includes
3914 -- checking that the argument does not raise Constraint_Error.
3916 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
3917 -- Check the specified argument Arg to make sure that it is a valid task
3918 -- dispatching policy name. If not give error and raise Pragma_Exit.
3920 procedure Check_Arg_Order (Names : Name_List);
3921 -- Checks for an instance of two arguments with identifiers for the
3922 -- current pragma which are not in the sequence indicated by Names,
3923 -- and if so, generates a fatal message about bad order of arguments.
3925 procedure Check_At_Least_N_Arguments (N : Nat);
3926 -- Check there are at least N arguments present
3928 procedure Check_At_Most_N_Arguments (N : Nat);
3929 -- Check there are no more than N arguments present
3931 procedure Check_Atomic_VFA (E : Entity_Id; VFA : Boolean);
3932 -- Apply legality checks to type or object E subject to an Atomic aspect
3933 -- in Ada 2020 (RM C.6(13)) or to a Volatile_Full_Access aspect.
3935 procedure Check_Component
3938 In_Variant_Part : Boolean := False);
3939 -- Examine an Unchecked_Union component for correct use of per-object
3940 -- constrained subtypes, and for restrictions on finalizable components.
3941 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3942 -- should be set when Comp comes from a record variant.
3944 procedure Check_Duplicate_Pragma (E : Entity_Id);
3945 -- Check if a rep item of the same name as the current pragma is already
3946 -- chained as a rep pragma to the given entity. If so give a message
3947 -- about the duplicate, and then raise Pragma_Exit so does not return.
3948 -- Note that if E is a type, then this routine avoids flagging a pragma
3949 -- which applies to a parent type from which E is derived.
3951 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
3952 -- Nam is an N_String_Literal node containing the external name set by
3953 -- an Import or Export pragma (or extended Import or Export pragma).
3954 -- This procedure checks for possible duplications if this is the export
3955 -- case, and if found, issues an appropriate error message.
3957 procedure Check_Expr_Is_OK_Static_Expression
3959 Typ : Entity_Id := Empty);
3960 -- Check the specified expression Expr to make sure that it is a static
3961 -- expression of the given type (i.e. it will be analyzed and resolved
3962 -- using this type, which can be any valid argument to Resolve, e.g.
3963 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3964 -- Typ is left Empty, then any static expression is allowed. Includes
3965 -- checking that the expression does not raise Constraint_Error.
3967 procedure Check_First_Subtype (Arg : Node_Id);
3968 -- Checks that Arg, whose expression is an entity name, references a
3971 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
3972 -- Checks that the given argument has an identifier, and if so, requires
3973 -- it to match the given identifier name. If there is no identifier, or
3974 -- a non-matching identifier, then an error message is given and
3975 -- Pragma_Exit is raised.
3977 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
3978 -- Checks that the given argument has an identifier, and if so, requires
3979 -- it to match one of the given identifier names. If there is no
3980 -- identifier, or a non-matching identifier, then an error message is
3981 -- given and Pragma_Exit is raised.
3983 procedure Check_In_Main_Program;
3984 -- Common checks for pragmas that appear within a main program
3985 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3987 procedure Check_Interrupt_Or_Attach_Handler;
3988 -- Common processing for first argument of pragma Interrupt_Handler or
3989 -- pragma Attach_Handler.
3991 procedure Check_Loop_Pragma_Placement;
3992 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3993 -- appear immediately within a construct restricted to loops, and that
3994 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
3996 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
3997 -- Check that pragma appears in a declarative part, or in a package
3998 -- specification, i.e. that it does not occur in a statement sequence
4001 procedure Check_No_Identifier (Arg : Node_Id);
4002 -- Checks that the given argument does not have an identifier. If
4003 -- an identifier is present, then an error message is issued, and
4004 -- Pragma_Exit is raised.
4006 procedure Check_No_Identifiers;
4007 -- Checks that none of the arguments to the pragma has an identifier.
4008 -- If any argument has an identifier, then an error message is issued,
4009 -- and Pragma_Exit is raised.
4011 procedure Check_No_Link_Name;
4012 -- Checks that no link name is specified
4014 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
4015 -- Checks if the given argument has an identifier, and if so, requires
4016 -- it to match the given identifier name. If there is a non-matching
4017 -- identifier, then an error message is given and Pragma_Exit is raised.
4019 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
4020 -- Checks if the given argument has an identifier, and if so, requires
4021 -- it to match the given identifier name. If there is a non-matching
4022 -- identifier, then an error message is given and Pragma_Exit is raised.
4023 -- In this version of the procedure, the identifier name is given as
4024 -- a string with lower case letters.
4026 procedure Check_Static_Boolean_Expression (Expr : Node_Id);
4027 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
4028 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
4029 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
4030 -- is an OK static boolean expression. Emit an error if this is not the
4033 procedure Check_Static_Constraint (Constr : Node_Id);
4034 -- Constr is a constraint from an N_Subtype_Indication node from a
4035 -- component constraint in an Unchecked_Union type. This routine checks
4036 -- that the constraint is static as required by the restrictions for
4039 procedure Check_Valid_Configuration_Pragma;
4040 -- Legality checks for placement of a configuration pragma
4042 procedure Check_Valid_Library_Unit_Pragma;
4043 -- Legality checks for library unit pragmas. A special case arises for
4044 -- pragmas in generic instances that come from copies of the original
4045 -- library unit pragmas in the generic templates. In the case of other
4046 -- than library level instantiations these can appear in contexts which
4047 -- would normally be invalid (they only apply to the original template
4048 -- and to library level instantiations), and they are simply ignored,
4049 -- which is implemented by rewriting them as null statements.
4051 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
4052 -- Check an Unchecked_Union variant for lack of nested variants and
4053 -- presence of at least one component. UU_Typ is the related Unchecked_
4056 procedure Ensure_Aggregate_Form (Arg : Node_Id);
4057 -- Subsidiary routine to the processing of pragmas Abstract_State,
4058 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
4059 -- Refined_Global and Refined_State. Transform argument Arg into
4060 -- an aggregate if not one already. N_Null is never transformed.
4061 -- Arg may denote an aspect specification or a pragma argument
4064 procedure Error_Pragma (Msg : String);
4065 pragma No_Return (Error_Pragma);
4066 -- Outputs error message for current pragma. The message contains a %
4067 -- that will be replaced with the pragma name, and the flag is placed
4068 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
4069 -- calls Fix_Error (see spec of that procedure for details).
4071 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
4072 pragma No_Return (Error_Pragma_Arg);
4073 -- Outputs error message for current pragma. The message may contain
4074 -- a % that will be replaced with the pragma name. The parameter Arg
4075 -- may either be a pragma argument association, in which case the flag
4076 -- is placed on the expression of this association, or an expression,
4077 -- in which case the flag is placed directly on the expression. The
4078 -- message is placed using Error_Msg_N, so the message may also contain
4079 -- an & insertion character which will reference the given Arg value.
4080 -- After placing the message, Pragma_Exit is raised. Note: this routine
4081 -- calls Fix_Error (see spec of that procedure for details).
4083 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
4084 pragma No_Return (Error_Pragma_Arg);
4085 -- Similar to above form of Error_Pragma_Arg except that two messages
4086 -- are provided, the second is a continuation comment starting with \.
4088 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
4089 pragma No_Return (Error_Pragma_Arg_Ident);
4090 -- Outputs error message for current pragma. The message may contain a %
4091 -- that will be replaced with the pragma name. The parameter Arg must be
4092 -- a pragma argument association with a non-empty identifier (i.e. its
4093 -- Chars field must be set), and the error message is placed on the
4094 -- identifier. The message is placed using Error_Msg_N so the message
4095 -- may also contain an & insertion character which will reference
4096 -- the identifier. After placing the message, Pragma_Exit is raised.
4097 -- Note: this routine calls Fix_Error (see spec of that procedure for
4100 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
4101 pragma No_Return (Error_Pragma_Ref);
4102 -- Outputs error message for current pragma. The message may contain
4103 -- a % that will be replaced with the pragma name. The parameter Ref
4104 -- must be an entity whose name can be referenced by & and sloc by #.
4105 -- After placing the message, Pragma_Exit is raised. Note: this routine
4106 -- calls Fix_Error (see spec of that procedure for details).
4108 function Find_Lib_Unit_Name return Entity_Id;
4109 -- Used for a library unit pragma to find the entity to which the
4110 -- library unit pragma applies, returns the entity found.
4112 procedure Find_Program_Unit_Name (Id : Node_Id);
4113 -- If the pragma is a compilation unit pragma, the id must denote the
4114 -- compilation unit in the same compilation, and the pragma must appear
4115 -- in the list of preceding or trailing pragmas. If it is a program
4116 -- unit pragma that is not a compilation unit pragma, then the
4117 -- identifier must be visible.
4119 function Find_Unique_Parameterless_Procedure
4121 Arg : Node_Id) return Entity_Id;
4122 -- Used for a procedure pragma to find the unique parameterless
4123 -- procedure identified by Name, returns it if it exists, otherwise
4124 -- errors out and uses Arg as the pragma argument for the message.
4126 function Fix_Error (Msg : String) return String;
4127 -- This is called prior to issuing an error message. Msg is the normal
4128 -- error message issued in the pragma case. This routine checks for the
4129 -- case of a pragma coming from an aspect in the source, and returns a
4130 -- message suitable for the aspect case as follows:
4132 -- Each substring "pragma" is replaced by "aspect"
4134 -- If "argument of" is at the start of the error message text, it is
4135 -- replaced by "entity for".
4137 -- If "argument" is at the start of the error message text, it is
4138 -- replaced by "entity".
4140 -- So for example, "argument of pragma X must be discrete type"
4141 -- returns "entity for aspect X must be a discrete type".
4143 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
4144 -- be different from the pragma name). If the current pragma results
4145 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
4146 -- original pragma name.
4148 procedure Gather_Associations
4150 Args : out Args_List);
4151 -- This procedure is used to gather the arguments for a pragma that
4152 -- permits arbitrary ordering of parameters using the normal rules
4153 -- for named and positional parameters. The Names argument is a list
4154 -- of Name_Id values that corresponds to the allowed pragma argument
4155 -- association identifiers in order. The result returned in Args is
4156 -- a list of corresponding expressions that are the pragma arguments.
4157 -- Note that this is a list of expressions, not of pragma argument
4158 -- associations (Gather_Associations has completely checked all the
4159 -- optional identifiers when it returns). An entry in Args is Empty
4160 -- on return if the corresponding argument is not present.
4162 procedure GNAT_Pragma;
4163 -- Called for all GNAT defined pragmas to check the relevant restriction
4164 -- (No_Implementation_Pragmas).
4166 function Is_Before_First_Decl
4167 (Pragma_Node : Node_Id;
4168 Decls : List_Id) return Boolean;
4169 -- Return True if Pragma_Node is before the first declarative item in
4170 -- Decls where Decls is the list of declarative items.
4172 function Is_Configuration_Pragma return Boolean;
4173 -- Determines if the placement of the current pragma is appropriate
4174 -- for a configuration pragma.
4176 function Is_In_Context_Clause return Boolean;
4177 -- Returns True if pragma appears within the context clause of a unit,
4178 -- and False for any other placement (does not generate any messages).
4180 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
4181 -- Analyzes the argument, and determines if it is a static string
4182 -- expression, returns True if so, False if non-static or not String.
4183 -- A special case is that a string literal returns True in Ada 83 mode
4184 -- (which has no such thing as static string expressions). Note that
4185 -- the call analyzes its argument, so this cannot be used for the case
4186 -- where an identifier might not be declared.
4188 procedure Pragma_Misplaced;
4189 pragma No_Return (Pragma_Misplaced);
4190 -- Issue fatal error message for misplaced pragma
4192 procedure Process_Atomic_Independent_Shared_Volatile;
4193 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
4194 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
4195 -- and treated as being identical in effect to pragma Atomic.
4197 procedure Process_Compile_Time_Warning_Or_Error;
4198 -- Common processing for Compile_Time_Error and Compile_Time_Warning
4200 procedure Process_Convention
4201 (C : out Convention_Id;
4202 Ent : out Entity_Id);
4203 -- Common processing for Convention, Interface, Import and Export.
4204 -- Checks first two arguments of pragma, and sets the appropriate
4205 -- convention value in the specified entity or entities. On return
4206 -- C is the convention, Ent is the referenced entity.
4208 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
4209 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
4210 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
4212 procedure Process_Extended_Import_Export_Object_Pragma
4213 (Arg_Internal : Node_Id;
4214 Arg_External : Node_Id;
4215 Arg_Size : Node_Id);
4216 -- Common processing for the pragmas Import/Export_Object. The three
4217 -- arguments correspond to the three named parameters of the pragmas. An
4218 -- argument is empty if the corresponding parameter is not present in
4221 procedure Process_Extended_Import_Export_Internal_Arg
4222 (Arg_Internal : Node_Id := Empty);
4223 -- Common processing for all extended Import and Export pragmas. The
4224 -- argument is the pragma parameter for the Internal argument. If
4225 -- Arg_Internal is empty or inappropriate, an error message is posted.
4226 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
4227 -- set to identify the referenced entity.
4229 procedure Process_Extended_Import_Export_Subprogram_Pragma
4230 (Arg_Internal : Node_Id;
4231 Arg_External : Node_Id;
4232 Arg_Parameter_Types : Node_Id;
4233 Arg_Result_Type : Node_Id := Empty;
4234 Arg_Mechanism : Node_Id;
4235 Arg_Result_Mechanism : Node_Id := Empty);
4236 -- Common processing for all extended Import and Export pragmas applying
4237 -- to subprograms. The caller omits any arguments that do not apply to
4238 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
4239 -- only in the Import_Function and Export_Function cases). The argument
4240 -- names correspond to the allowed pragma association identifiers.
4242 procedure Process_Generic_List;
4243 -- Common processing for Share_Generic and Inline_Generic
4245 procedure Process_Import_Or_Interface;
4246 -- Common processing for Import or Interface
4248 procedure Process_Import_Predefined_Type;
4249 -- Processing for completing a type with pragma Import. This is used
4250 -- to declare types that match predefined C types, especially for cases
4251 -- without corresponding Ada predefined type.
4253 type Inline_Status is (Suppressed, Disabled, Enabled);
4254 -- Inline status of a subprogram, indicated as follows:
4255 -- Suppressed: inlining is suppressed for the subprogram
4256 -- Disabled: no inlining is requested for the subprogram
4257 -- Enabled: inlining is requested/required for the subprogram
4259 procedure Process_Inline (Status : Inline_Status);
4260 -- Common processing for No_Inline, Inline and Inline_Always. Parameter
4261 -- indicates the inline status specified by the pragma.
4263 procedure Process_Interface_Name
4264 (Subprogram_Def : Entity_Id;
4268 -- Given the last two arguments of pragma Import, pragma Export, or
4269 -- pragma Interface_Name, performs validity checks and sets the
4270 -- Interface_Name field of the given subprogram entity to the
4271 -- appropriate external or link name, depending on the arguments given.
4272 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
4273 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
4274 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
4275 -- nor Link_Arg is present, the interface name is set to the default
4276 -- from the subprogram name. In addition, the pragma itself is passed
4277 -- to analyze any expressions in the case the pragma came from an aspect
4280 procedure Process_Interrupt_Or_Attach_Handler;
4281 -- Common processing for Interrupt and Attach_Handler pragmas
4283 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
4284 -- Common processing for Restrictions and Restriction_Warnings pragmas.
4285 -- Warn is True for Restriction_Warnings, or for Restrictions if the
4286 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
4287 -- is not set in the Restrictions case.
4289 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
4290 -- Common processing for Suppress and Unsuppress. The boolean parameter
4291 -- Suppress_Case is True for the Suppress case, and False for the
4294 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id);
4295 -- Subsidiary to the analysis of pragmas Independent[_Components].
4296 -- Record such a pragma N applied to entity E for future checks.
4298 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
4299 -- This procedure sets the Is_Exported flag for the given entity,
4300 -- checking that the entity was not previously imported. Arg is
4301 -- the argument that specified the entity. A check is also made
4302 -- for exporting inappropriate entities.
4304 procedure Set_Extended_Import_Export_External_Name
4305 (Internal_Ent : Entity_Id;
4306 Arg_External : Node_Id);
4307 -- Common processing for all extended import export pragmas. The first
4308 -- argument, Internal_Ent, is the internal entity, which has already
4309 -- been checked for validity by the caller. Arg_External is from the
4310 -- Import or Export pragma, and may be null if no External parameter
4311 -- was present. If Arg_External is present and is a non-null string
4312 -- (a null string is treated as the default), then the Interface_Name
4313 -- field of Internal_Ent is set appropriately.
4315 procedure Set_Imported (E : Entity_Id);
4316 -- This procedure sets the Is_Imported flag for the given entity,
4317 -- checking that it is not previously exported or imported.
4319 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
4320 -- Mech is a parameter passing mechanism (see Import_Function syntax
4321 -- for MECHANISM_NAME). This routine checks that the mechanism argument
4322 -- has the right form, and if not issues an error message. If the
4323 -- argument has the right form then the Mechanism field of Ent is
4324 -- set appropriately.
4326 procedure Set_Rational_Profile;
4327 -- Activate the set of configuration pragmas and permissions that make
4328 -- up the Rational profile.
4330 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id);
4331 -- Activate the set of configuration pragmas and restrictions that make
4332 -- up the Profile. Profile must be either GNAT_Extended_Ravenscar,
4333 -- GNAT_Ravenscar_EDF, Jorvik, or Ravenscar. N is the corresponding
4334 -- pragma node, which is used for error messages on any constructs
4335 -- violating the profile.
4337 ---------------------
4338 -- Ada_2005_Pragma --
4339 ---------------------
4341 procedure Ada_2005_Pragma is
4343 if Ada_Version <= Ada_95 then
4344 Check_Restriction (No_Implementation_Pragmas, N);
4346 end Ada_2005_Pragma;
4348 ---------------------
4349 -- Ada_2012_Pragma --
4350 ---------------------
4352 procedure Ada_2012_Pragma is
4354 if Ada_Version <= Ada_2005 then
4355 Check_Restriction (No_Implementation_Pragmas, N);
4357 end Ada_2012_Pragma;
4359 ----------------------------
4360 -- Analyze_Depends_Global --
4361 ----------------------------
4363 procedure Analyze_Depends_Global
4364 (Spec_Id : out Entity_Id;
4365 Subp_Decl : out Node_Id;
4366 Legal : out Boolean)
4369 -- Assume that the pragma is illegal
4376 Check_Arg_Count (1);
4378 -- Ensure the proper placement of the pragma. Depends/Global must be
4379 -- associated with a subprogram declaration or a body that acts as a
4382 Subp_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4386 if Nkind (Subp_Decl) = N_Entry_Declaration then
4389 -- Generic subprogram
4391 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4394 -- Object declaration of a single concurrent type
4396 elsif Nkind (Subp_Decl) = N_Object_Declaration
4397 and then Is_Single_Concurrent_Object
4398 (Unique_Defining_Entity (Subp_Decl))
4404 elsif Nkind (Subp_Decl) = N_Single_Task_Declaration then
4407 -- Subprogram body acts as spec
4409 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4410 and then No (Corresponding_Spec (Subp_Decl))
4414 -- Subprogram body stub acts as spec
4416 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4417 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
4421 -- Subprogram declaration
4423 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4428 elsif Nkind (Subp_Decl) = N_Task_Type_Declaration then
4436 -- If we get here, then the pragma is legal
4439 Spec_Id := Unique_Defining_Entity (Subp_Decl);
4441 -- When the related context is an entry, the entry must belong to a
4442 -- protected unit (SPARK RM 6.1.4(6)).
4444 if Is_Entry_Declaration (Spec_Id)
4445 and then Ekind (Scope (Spec_Id)) /= E_Protected_Type
4450 -- When the related context is an anonymous object created for a
4451 -- simple concurrent type, the type must be a task
4452 -- (SPARK RM 6.1.4(6)).
4454 elsif Is_Single_Concurrent_Object (Spec_Id)
4455 and then Ekind (Etype (Spec_Id)) /= E_Task_Type
4461 -- A pragma that applies to a Ghost entity becomes Ghost for the
4462 -- purposes of legality checks and removal of ignored Ghost code.
4464 Mark_Ghost_Pragma (N, Spec_Id);
4465 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4466 end Analyze_Depends_Global;
4468 ------------------------
4469 -- Analyze_If_Present --
4470 ------------------------
4472 procedure Analyze_If_Present (Id : Pragma_Id) is
4476 pragma Assert (Is_List_Member (N));
4478 -- Inspect the declarations or statements following pragma N looking
4479 -- for another pragma whose Id matches the caller's request. If it is
4480 -- available, analyze it.
4483 while Present (Stmt) loop
4484 if Nkind (Stmt) = N_Pragma and then Get_Pragma_Id (Stmt) = Id then
4485 Analyze_Pragma (Stmt);
4488 -- The first source declaration or statement immediately following
4489 -- N ends the region where a pragma may appear.
4491 elsif Comes_From_Source (Stmt) then
4497 end Analyze_If_Present;
4499 --------------------------------
4500 -- Analyze_Pre_Post_Condition --
4501 --------------------------------
4503 procedure Analyze_Pre_Post_Condition is
4504 Prag_Iden : constant Node_Id := Pragma_Identifier (N);
4505 Subp_Decl : Node_Id;
4506 Subp_Id : Entity_Id;
4508 Duplicates_OK : Boolean := False;
4509 -- Flag set when a pre/postcondition allows multiple pragmas of the
4512 In_Body_OK : Boolean := False;
4513 -- Flag set when a pre/postcondition is allowed to appear on a body
4514 -- even though the subprogram may have a spec.
4516 Is_Pre_Post : Boolean := False;
4517 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4520 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean;
4521 -- Implement rules in AI12-0131: an overriding operation can have
4522 -- a class-wide precondition only if one of its ancestors has an
4523 -- explicit class-wide precondition.
4525 -----------------------------
4526 -- Inherits_Class_Wide_Pre --
4527 -----------------------------
4529 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean is
4530 Typ : constant Entity_Id := Find_Dispatching_Type (E);
4533 Prev : Entity_Id := Overridden_Operation (E);
4536 -- Check ancestors on the overriding operation to examine the
4537 -- preconditions that may apply to them.
4539 while Present (Prev) loop
4540 Cont := Contract (Prev);
4541 if Present (Cont) then
4542 Prag := Pre_Post_Conditions (Cont);
4543 while Present (Prag) loop
4544 if Pragma_Name (Prag) = Name_Precondition
4545 and then Class_Present (Prag)
4550 Prag := Next_Pragma (Prag);
4554 -- For a type derived from a generic formal type, the operation
4555 -- inheriting the condition is a renaming, not an overriding of
4556 -- the operation of the formal. Ditto for an inherited
4557 -- operation which has no explicit contracts.
4559 if Is_Generic_Type (Find_Dispatching_Type (Prev))
4560 or else not Comes_From_Source (Prev)
4562 Prev := Alias (Prev);
4564 Prev := Overridden_Operation (Prev);
4568 -- If the controlling type of the subprogram has progenitors, an
4569 -- interface operation implemented by the current operation may
4570 -- have a class-wide precondition.
4572 if Has_Interfaces (Typ) then
4577 Prim_Elmt : Elmt_Id;
4578 Prim_List : Elist_Id;
4581 Collect_Interfaces (Typ, Ints);
4582 Elmt := First_Elmt (Ints);
4584 -- Iterate over the primitive operations of each interface
4586 while Present (Elmt) loop
4587 Prim_List := Direct_Primitive_Operations (Node (Elmt));
4588 Prim_Elmt := First_Elmt (Prim_List);
4589 while Present (Prim_Elmt) loop
4590 Prim := Node (Prim_Elmt);
4591 if Chars (Prim) = Chars (E)
4592 and then Present (Contract (Prim))
4593 and then Class_Present
4594 (Pre_Post_Conditions (Contract (Prim)))
4599 Next_Elmt (Prim_Elmt);
4608 end Inherits_Class_Wide_Pre;
4610 -- Start of processing for Analyze_Pre_Post_Condition
4613 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4614 -- offer uniformity among the various kinds of pre/postconditions by
4615 -- rewriting the pragma identifier. This allows the retrieval of the
4616 -- original pragma name by routine Original_Aspect_Pragma_Name.
4618 if Comes_From_Source (N) then
4619 if Nam_In (Pname, Name_Pre, Name_Pre_Class) then
4620 Is_Pre_Post := True;
4621 Set_Class_Present (N, Pname = Name_Pre_Class);
4622 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Precondition));
4624 elsif Nam_In (Pname, Name_Post, Name_Post_Class) then
4625 Is_Pre_Post := True;
4626 Set_Class_Present (N, Pname = Name_Post_Class);
4627 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Postcondition));
4631 -- Determine the semantics with respect to duplicates and placement
4632 -- in a body. Pragmas Precondition and Postcondition were introduced
4633 -- before aspects and are not subject to the same aspect-like rules.
4635 if Nam_In (Pname, Name_Precondition, Name_Postcondition) then
4636 Duplicates_OK := True;
4642 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4643 -- argument without an identifier.
4646 Check_Arg_Count (1);
4647 Check_No_Identifiers;
4649 -- Pragmas Precondition and Postcondition have complex argument
4653 Check_At_Least_N_Arguments (1);
4654 Check_At_Most_N_Arguments (2);
4655 Check_Optional_Identifier (Arg1, Name_Check);
4657 if Present (Arg2) then
4658 Check_Optional_Identifier (Arg2, Name_Message);
4659 Preanalyze_Spec_Expression
4660 (Get_Pragma_Arg (Arg2), Standard_String);
4664 -- For a pragma PPC in the extended main source unit, record enabled
4666 -- ??? nothing checks that the pragma is in the main source unit
4668 if Is_Checked (N) and then not Split_PPC (N) then
4669 Set_SCO_Pragma_Enabled (Loc);
4672 -- Ensure the proper placement of the pragma
4675 Find_Related_Declaration_Or_Body
4676 (N, Do_Checks => not Duplicates_OK);
4678 -- When a pre/postcondition pragma applies to an abstract subprogram,
4679 -- its original form must be an aspect with 'Class.
4681 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
4682 if not From_Aspect_Specification (N) then
4684 ("pragma % cannot be applied to abstract subprogram");
4686 elsif not Class_Present (N) then
4688 ("aspect % requires ''Class for abstract subprogram");
4691 -- Entry declaration
4693 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
4696 -- Generic subprogram declaration
4698 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4703 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4704 and then (No (Corresponding_Spec (Subp_Decl)) or In_Body_OK)
4708 -- Subprogram body stub
4710 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4711 and then (No (Corresponding_Spec_Of_Stub (Subp_Decl)) or In_Body_OK)
4715 -- Subprogram declaration
4717 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4719 -- AI05-0230: When a pre/postcondition pragma applies to a null
4720 -- procedure, its original form must be an aspect with 'Class.
4722 if Nkind (Specification (Subp_Decl)) = N_Procedure_Specification
4723 and then Null_Present (Specification (Subp_Decl))
4724 and then From_Aspect_Specification (N)
4725 and then not Class_Present (N)
4727 Error_Pragma ("aspect % requires ''Class for null procedure");
4730 -- Implement the legality checks mandated by AI12-0131:
4731 -- Pre'Class shall not be specified for an overriding primitive
4732 -- subprogram of a tagged type T unless the Pre'Class aspect is
4733 -- specified for the corresponding primitive subprogram of some
4737 E : constant Entity_Id := Defining_Entity (Subp_Decl);
4740 if Class_Present (N)
4741 and then Pragma_Name (N) = Name_Precondition
4742 and then Present (Overridden_Operation (E))
4743 and then not Inherits_Class_Wide_Pre (E)
4746 ("illegal class-wide precondition on overriding operation",
4747 Corresponding_Aspect (N));
4751 -- A renaming declaration may inherit a generated pragma, its
4752 -- placement comes from expansion, not from source.
4754 elsif Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration
4755 and then not Comes_From_Source (N)
4759 -- For Ada 2020, pre/postconditions can appear on formal subprograms
4761 elsif Nkind (Subp_Decl) = N_Formal_Concrete_Subprogram_Declaration
4762 and then Ada_Version >= Ada_2020
4766 -- Otherwise the placement is illegal
4773 Subp_Id := Defining_Entity (Subp_Decl);
4775 -- A pragma that applies to a Ghost entity becomes Ghost for the
4776 -- purposes of legality checks and removal of ignored Ghost code.
4778 Mark_Ghost_Pragma (N, Subp_Id);
4780 -- Chain the pragma on the contract for further processing by
4781 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4783 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
4785 -- Fully analyze the pragma when it appears inside an entry or
4786 -- subprogram body because it cannot benefit from forward references.
4788 if Nkind_In (Subp_Decl, N_Entry_Body,
4790 N_Subprogram_Body_Stub)
4792 -- The legality checks of pragmas Precondition and Postcondition
4793 -- are affected by the SPARK mode in effect and the volatility of
4794 -- the context. Analyze all pragmas in a specific order.
4796 Analyze_If_Present (Pragma_SPARK_Mode);
4797 Analyze_If_Present (Pragma_Volatile_Function);
4798 Analyze_Pre_Post_Condition_In_Decl_Part (N);
4800 end Analyze_Pre_Post_Condition;
4802 -----------------------------------------
4803 -- Analyze_Refined_Depends_Global_Post --
4804 -----------------------------------------
4806 procedure Analyze_Refined_Depends_Global_Post
4807 (Spec_Id : out Entity_Id;
4808 Body_Id : out Entity_Id;
4809 Legal : out Boolean)
4811 Body_Decl : Node_Id;
4812 Spec_Decl : Node_Id;
4815 -- Assume that the pragma is illegal
4822 Check_Arg_Count (1);
4823 Check_No_Identifiers;
4825 -- Verify the placement of the pragma and check for duplicates. The
4826 -- pragma must apply to a subprogram body [stub].
4828 Body_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4830 if not Nkind_In (Body_Decl, N_Entry_Body,
4832 N_Subprogram_Body_Stub,
4840 Body_Id := Defining_Entity (Body_Decl);
4841 Spec_Id := Unique_Defining_Entity (Body_Decl);
4843 -- The pragma must apply to the second declaration of a subprogram.
4844 -- In other words, the body [stub] cannot acts as a spec.
4846 if No (Spec_Id) then
4847 Error_Pragma ("pragma % cannot apply to a stand alone body");
4850 -- Catch the case where the subprogram body is a subunit and acts as
4851 -- the third declaration of the subprogram.
4853 elsif Nkind (Parent (Body_Decl)) = N_Subunit then
4854 Error_Pragma ("pragma % cannot apply to a subunit");
4858 -- A refined pragma can only apply to the body [stub] of a subprogram
4859 -- declared in the visible part of a package. Retrieve the context of
4860 -- the subprogram declaration.
4862 Spec_Decl := Unit_Declaration_Node (Spec_Id);
4864 -- When dealing with protected entries or protected subprograms, use
4865 -- the enclosing protected type as the proper context.
4867 if Ekind_In (Spec_Id, E_Entry,
4871 and then Ekind (Scope (Spec_Id)) = E_Protected_Type
4873 Spec_Decl := Declaration_Node (Scope (Spec_Id));
4876 if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then
4878 (Fix_Msg (Spec_Id, "pragma % must apply to the body of "
4879 & "subprogram declared in a package specification"));
4883 -- If we get here, then the pragma is legal
4887 -- A pragma that applies to a Ghost entity becomes Ghost for the
4888 -- purposes of legality checks and removal of ignored Ghost code.
4890 Mark_Ghost_Pragma (N, Spec_Id);
4892 if Nam_In (Pname, Name_Refined_Depends, Name_Refined_Global) then
4893 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4895 end Analyze_Refined_Depends_Global_Post;
4897 ----------------------------------
4898 -- Analyze_Unmodified_Or_Unused --
4899 ----------------------------------
4901 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False) is
4906 Ghost_Error_Posted : Boolean := False;
4907 -- Flag set when an error concerning the illegal mix of Ghost and
4908 -- non-Ghost variables is emitted.
4910 Ghost_Id : Entity_Id := Empty;
4911 -- The entity of the first Ghost variable encountered while
4912 -- processing the arguments of the pragma.
4916 Check_At_Least_N_Arguments (1);
4918 -- Loop through arguments
4921 while Present (Arg) loop
4922 Check_No_Identifier (Arg);
4924 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4925 -- in fact generate reference, so that the entity will have a
4926 -- reference, which will inhibit any warnings about it not
4927 -- being referenced, and also properly show up in the ali file
4928 -- as a reference. But this reference is recorded before the
4929 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4930 -- generated for this reference.
4932 Check_Arg_Is_Local_Name (Arg);
4933 Arg_Expr := Get_Pragma_Arg (Arg);
4935 if Is_Entity_Name (Arg_Expr) then
4936 Arg_Id := Entity (Arg_Expr);
4938 -- Skip processing the argument if already flagged
4940 if Is_Assignable (Arg_Id)
4941 and then not Has_Pragma_Unmodified (Arg_Id)
4942 and then not Has_Pragma_Unused (Arg_Id)
4944 Set_Has_Pragma_Unmodified (Arg_Id);
4947 Set_Has_Pragma_Unused (Arg_Id);
4950 -- A pragma that applies to a Ghost entity becomes Ghost for
4951 -- the purposes of legality checks and removal of ignored
4954 Mark_Ghost_Pragma (N, Arg_Id);
4956 -- Capture the entity of the first Ghost variable being
4957 -- processed for error detection purposes.
4959 if Is_Ghost_Entity (Arg_Id) then
4960 if No (Ghost_Id) then
4964 -- Otherwise the variable is non-Ghost. It is illegal to mix
4965 -- references to Ghost and non-Ghost entities
4968 elsif Present (Ghost_Id)
4969 and then not Ghost_Error_Posted
4971 Ghost_Error_Posted := True;
4973 Error_Msg_Name_1 := Pname;
4975 ("pragma % cannot mention ghost and non-ghost "
4978 Error_Msg_Sloc := Sloc (Ghost_Id);
4979 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
4981 Error_Msg_Sloc := Sloc (Arg_Id);
4982 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
4985 -- Warn if already flagged as Unused or Unmodified
4987 elsif Has_Pragma_Unmodified (Arg_Id) then
4988 if Has_Pragma_Unused (Arg_Id) then
4990 ("??pragma Unused already given for &!", Arg_Expr,
4994 ("??pragma Unmodified already given for &!", Arg_Expr,
4998 -- Otherwise the pragma referenced an illegal entity
5002 ("pragma% can only be applied to a variable", Arg_Expr);
5008 end Analyze_Unmodified_Or_Unused;
5010 ------------------------------------
5011 -- Analyze_Unreferenced_Or_Unused --
5012 ------------------------------------
5014 procedure Analyze_Unreferenced_Or_Unused
5015 (Is_Unused : Boolean := False)
5022 Ghost_Error_Posted : Boolean := False;
5023 -- Flag set when an error concerning the illegal mix of Ghost and
5024 -- non-Ghost names is emitted.
5026 Ghost_Id : Entity_Id := Empty;
5027 -- The entity of the first Ghost name encountered while processing
5028 -- the arguments of the pragma.
5032 Check_At_Least_N_Arguments (1);
5034 -- Check case of appearing within context clause
5036 if not Is_Unused and then Is_In_Context_Clause then
5038 -- The arguments must all be units mentioned in a with clause in
5039 -- the same context clause. Note that Par.Prag already checked
5040 -- that the arguments are either identifiers or selected
5044 while Present (Arg) loop
5045 Citem := First (List_Containing (N));
5046 while Citem /= N loop
5047 Arg_Expr := Get_Pragma_Arg (Arg);
5049 if Nkind (Citem) = N_With_Clause
5050 and then Same_Name (Name (Citem), Arg_Expr)
5052 Set_Has_Pragma_Unreferenced
5055 (Library_Unit (Citem))));
5056 Set_Elab_Unit_Name (Arg_Expr, Name (Citem));
5065 ("argument of pragma% is not withed unit", Arg);
5071 -- Case of not in list of context items
5075 while Present (Arg) loop
5076 Check_No_Identifier (Arg);
5078 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
5079 -- in fact generate reference, so that the entity will have a
5080 -- reference, which will inhibit any warnings about it not
5081 -- being referenced, and also properly show up in the ali file
5082 -- as a reference. But this reference is recorded before the
5083 -- Has_Pragma_Unreferenced flag is set, so that no warning is
5084 -- generated for this reference.
5086 Check_Arg_Is_Local_Name (Arg);
5087 Arg_Expr := Get_Pragma_Arg (Arg);
5089 if Is_Entity_Name (Arg_Expr) then
5090 Arg_Id := Entity (Arg_Expr);
5092 -- Warn if already flagged as Unused or Unreferenced and
5093 -- skip processing the argument.
5095 if Has_Pragma_Unreferenced (Arg_Id) then
5096 if Has_Pragma_Unused (Arg_Id) then
5098 ("??pragma Unused already given for &!", Arg_Expr,
5102 ("??pragma Unreferenced already given for &!",
5106 -- Apply Unreferenced to the entity
5109 -- If the entity is overloaded, the pragma applies to the
5110 -- most recent overloading, as documented. In this case,
5111 -- name resolution does not generate a reference, so it
5112 -- must be done here explicitly.
5114 if Is_Overloaded (Arg_Expr) then
5115 Generate_Reference (Arg_Id, N);
5118 Set_Has_Pragma_Unreferenced (Arg_Id);
5121 Set_Has_Pragma_Unused (Arg_Id);
5124 -- A pragma that applies to a Ghost entity becomes Ghost
5125 -- for the purposes of legality checks and removal of
5126 -- ignored Ghost code.
5128 Mark_Ghost_Pragma (N, Arg_Id);
5130 -- Capture the entity of the first Ghost name being
5131 -- processed for error detection purposes.
5133 if Is_Ghost_Entity (Arg_Id) then
5134 if No (Ghost_Id) then
5138 -- Otherwise the name is non-Ghost. It is illegal to mix
5139 -- references to Ghost and non-Ghost entities
5142 elsif Present (Ghost_Id)
5143 and then not Ghost_Error_Posted
5145 Ghost_Error_Posted := True;
5147 Error_Msg_Name_1 := Pname;
5149 ("pragma % cannot mention ghost and non-ghost "
5152 Error_Msg_Sloc := Sloc (Ghost_Id);
5154 ("\& # declared as ghost", N, Ghost_Id);
5156 Error_Msg_Sloc := Sloc (Arg_Id);
5158 ("\& # declared as non-ghost", N, Arg_Id);
5166 end Analyze_Unreferenced_Or_Unused;
5168 --------------------------
5169 -- Check_Ada_83_Warning --
5170 --------------------------
5172 procedure Check_Ada_83_Warning is
5174 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
5175 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
5177 end Check_Ada_83_Warning;
5179 ---------------------
5180 -- Check_Arg_Count --
5181 ---------------------
5183 procedure Check_Arg_Count (Required : Nat) is
5185 if Arg_Count /= Required then
5186 Error_Pragma ("wrong number of arguments for pragma%");
5188 end Check_Arg_Count;
5190 --------------------------------
5191 -- Check_Arg_Is_External_Name --
5192 --------------------------------
5194 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
5195 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5198 if Nkind (Argx) = N_Identifier then
5202 Analyze_And_Resolve (Argx, Standard_String);
5204 if Is_OK_Static_Expression (Argx) then
5207 elsif Etype (Argx) = Any_Type then
5210 -- An interesting special case, if we have a string literal and
5211 -- we are in Ada 83 mode, then we allow it even though it will
5212 -- not be flagged as static. This allows expected Ada 83 mode
5213 -- use of external names which are string literals, even though
5214 -- technically these are not static in Ada 83.
5216 elsif Ada_Version = Ada_83
5217 and then Nkind (Argx) = N_String_Literal
5221 -- Here we have a real error (non-static expression)
5224 Error_Msg_Name_1 := Pname;
5225 Flag_Non_Static_Expr
5226 (Fix_Error ("argument for pragma% must be a identifier or "
5227 & "static string expression!"), Argx);
5232 end Check_Arg_Is_External_Name;
5234 -----------------------------
5235 -- Check_Arg_Is_Identifier --
5236 -----------------------------
5238 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
5239 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5241 if Nkind (Argx) /= N_Identifier then
5242 Error_Pragma_Arg ("argument for pragma% must be identifier", Argx);
5244 end Check_Arg_Is_Identifier;
5246 ----------------------------------
5247 -- Check_Arg_Is_Integer_Literal --
5248 ----------------------------------
5250 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
5251 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5253 if Nkind (Argx) /= N_Integer_Literal then
5255 ("argument for pragma% must be integer literal", Argx);
5257 end Check_Arg_Is_Integer_Literal;
5259 -------------------------------------------
5260 -- Check_Arg_Is_Library_Level_Local_Name --
5261 -------------------------------------------
5265 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5266 -- | library_unit_NAME
5268 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
5270 Check_Arg_Is_Local_Name (Arg);
5272 -- If it came from an aspect, we want to give the error just as if it
5273 -- came from source.
5275 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
5276 and then (Comes_From_Source (N)
5277 or else Present (Corresponding_Aspect (Parent (Arg))))
5280 ("argument for pragma% must be library level entity", Arg);
5282 end Check_Arg_Is_Library_Level_Local_Name;
5284 -----------------------------
5285 -- Check_Arg_Is_Local_Name --
5286 -----------------------------
5290 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5291 -- | library_unit_NAME
5293 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
5294 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5297 -- If this pragma came from an aspect specification, we don't want to
5298 -- check for this error, because that would cause spurious errors, in
5299 -- case a type is frozen in a scope more nested than the type. The
5300 -- aspect itself of course can't be anywhere but on the declaration
5303 if Nkind (Arg) = N_Pragma_Argument_Association then
5304 if From_Aspect_Specification (Parent (Arg)) then
5308 -- Arg is the Expression of an N_Pragma_Argument_Association
5311 if From_Aspect_Specification (Parent (Parent (Arg))) then
5318 if Nkind (Argx) not in N_Direct_Name
5319 and then (Nkind (Argx) /= N_Attribute_Reference
5320 or else Present (Expressions (Argx))
5321 or else Nkind (Prefix (Argx)) /= N_Identifier)
5322 and then (not Is_Entity_Name (Argx)
5323 or else not Is_Compilation_Unit (Entity (Argx)))
5325 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
5328 -- No further check required if not an entity name
5330 if not Is_Entity_Name (Argx) then
5336 Ent : constant Entity_Id := Entity (Argx);
5337 Scop : constant Entity_Id := Scope (Ent);
5340 -- Case of a pragma applied to a compilation unit: pragma must
5341 -- occur immediately after the program unit in the compilation.
5343 if Is_Compilation_Unit (Ent) then
5345 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
5348 -- Case of pragma placed immediately after spec
5350 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
5353 -- Case of pragma placed immediately after body
5355 elsif Nkind (Decl) = N_Subprogram_Declaration
5356 and then Present (Corresponding_Body (Decl))
5360 (Parent (Unit_Declaration_Node
5361 (Corresponding_Body (Decl))));
5363 -- All other cases are illegal
5370 -- Special restricted placement rule from 10.2.1(11.8/2)
5372 elsif Is_Generic_Formal (Ent)
5373 and then Prag_Id = Pragma_Preelaborable_Initialization
5375 OK := List_Containing (N) =
5376 Generic_Formal_Declarations
5377 (Unit_Declaration_Node (Scop));
5379 -- If this is an aspect applied to a subprogram body, the
5380 -- pragma is inserted in its declarative part.
5382 elsif From_Aspect_Specification (N)
5383 and then Ent = Current_Scope
5385 Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body
5389 -- If the aspect is a predicate (possibly others ???) and the
5390 -- context is a record type, this is a discriminant expression
5391 -- within a type declaration, that freezes the predicated
5394 elsif From_Aspect_Specification (N)
5395 and then Prag_Id = Pragma_Predicate
5396 and then Ekind (Current_Scope) = E_Record_Type
5397 and then Scop = Scope (Current_Scope)
5401 -- Default case, just check that the pragma occurs in the scope
5402 -- of the entity denoted by the name.
5405 OK := Current_Scope = Scop;
5410 ("pragma% argument must be in same declarative part", Arg);
5414 end Check_Arg_Is_Local_Name;
5416 ---------------------------------
5417 -- Check_Arg_Is_Locking_Policy --
5418 ---------------------------------
5420 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
5421 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5424 Check_Arg_Is_Identifier (Argx);
5426 if not Is_Locking_Policy_Name (Chars (Argx)) then
5427 Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
5429 end Check_Arg_Is_Locking_Policy;
5431 -----------------------------------------------
5432 -- Check_Arg_Is_Partition_Elaboration_Policy --
5433 -----------------------------------------------
5435 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
5436 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5439 Check_Arg_Is_Identifier (Argx);
5441 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
5443 ("& is not a valid partition elaboration policy name", Argx);
5445 end Check_Arg_Is_Partition_Elaboration_Policy;
5447 -------------------------
5448 -- Check_Arg_Is_One_Of --
5449 -------------------------
5451 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5452 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5455 Check_Arg_Is_Identifier (Argx);
5457 if not Nam_In (Chars (Argx), N1, N2) then
5458 Error_Msg_Name_2 := N1;
5459 Error_Msg_Name_3 := N2;
5460 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
5462 end Check_Arg_Is_One_Of;
5464 procedure Check_Arg_Is_One_Of
5466 N1, N2, N3 : Name_Id)
5468 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5471 Check_Arg_Is_Identifier (Argx);
5473 if not Nam_In (Chars (Argx), N1, N2, N3) then
5474 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5476 end Check_Arg_Is_One_Of;
5478 procedure Check_Arg_Is_One_Of
5480 N1, N2, N3, N4 : Name_Id)
5482 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5485 Check_Arg_Is_Identifier (Argx);
5487 if not Nam_In (Chars (Argx), N1, N2, N3, N4) then
5488 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5490 end Check_Arg_Is_One_Of;
5492 procedure Check_Arg_Is_One_Of
5494 N1, N2, N3, N4, N5 : Name_Id)
5496 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5499 Check_Arg_Is_Identifier (Argx);
5501 if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then
5502 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5504 end Check_Arg_Is_One_Of;
5506 ---------------------------------
5507 -- Check_Arg_Is_Queuing_Policy --
5508 ---------------------------------
5510 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
5511 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5514 Check_Arg_Is_Identifier (Argx);
5516 if not Is_Queuing_Policy_Name (Chars (Argx)) then
5517 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
5519 end Check_Arg_Is_Queuing_Policy;
5521 ---------------------------------------
5522 -- Check_Arg_Is_OK_Static_Expression --
5523 ---------------------------------------
5525 procedure Check_Arg_Is_OK_Static_Expression
5527 Typ : Entity_Id := Empty)
5530 Check_Expr_Is_OK_Static_Expression (Get_Pragma_Arg (Arg), Typ);
5531 end Check_Arg_Is_OK_Static_Expression;
5533 ------------------------------------------
5534 -- Check_Arg_Is_Task_Dispatching_Policy --
5535 ------------------------------------------
5537 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
5538 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5541 Check_Arg_Is_Identifier (Argx);
5543 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
5545 ("& is not an allowed task dispatching policy name", Argx);
5547 end Check_Arg_Is_Task_Dispatching_Policy;
5549 ---------------------
5550 -- Check_Arg_Order --
5551 ---------------------
5553 procedure Check_Arg_Order (Names : Name_List) is
5556 Highest_So_Far : Natural := 0;
5557 -- Highest index in Names seen do far
5561 for J in 1 .. Arg_Count loop
5562 if Chars (Arg) /= No_Name then
5563 for K in Names'Range loop
5564 if Chars (Arg) = Names (K) then
5565 if K < Highest_So_Far then
5566 Error_Msg_Name_1 := Pname;
5568 ("parameters out of order for pragma%", Arg);
5569 Error_Msg_Name_1 := Names (K);
5570 Error_Msg_Name_2 := Names (Highest_So_Far);
5571 Error_Msg_N ("\% must appear before %", Arg);
5575 Highest_So_Far := K;
5583 end Check_Arg_Order;
5585 --------------------------------
5586 -- Check_At_Least_N_Arguments --
5587 --------------------------------
5589 procedure Check_At_Least_N_Arguments (N : Nat) is
5591 if Arg_Count < N then
5592 Error_Pragma ("too few arguments for pragma%");
5594 end Check_At_Least_N_Arguments;
5596 -------------------------------
5597 -- Check_At_Most_N_Arguments --
5598 -------------------------------
5600 procedure Check_At_Most_N_Arguments (N : Nat) is
5603 if Arg_Count > N then
5605 for J in 1 .. N loop
5607 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
5610 end Check_At_Most_N_Arguments;
5612 ------------------------
5613 -- Check_Atomic_VFA --
5614 ------------------------
5616 procedure Check_Atomic_VFA (E : Entity_Id; VFA : Boolean) is
5618 Aliased_Subcomponent : exception;
5619 -- Exception raised if an aliased subcomponent is found in E
5621 Independent_Subcomponent : exception;
5622 -- Exception raised if an independent subcomponent is found in E
5624 procedure Check_Subcomponents (Typ : Entity_Id);
5625 -- Apply checks to subcomponents for Atomic and Volatile_Full_Access
5627 -------------------------
5628 -- Check_Subcomponents --
5629 -------------------------
5631 procedure Check_Subcomponents (Typ : Entity_Id) is
5635 if Is_Array_Type (Typ) then
5636 Comp := Component_Type (Typ);
5638 -- For Atomic we accept any atomic subcomponents
5641 and then (Has_Atomic_Components (Typ)
5642 or else Is_Atomic (Comp))
5646 -- Give an error if the components are aliased
5648 elsif Has_Aliased_Components (Typ)
5649 or else Is_Aliased (Comp)
5651 raise Aliased_Subcomponent;
5653 -- For VFA we accept non-aliased VFA subcomponents
5656 and then Is_Volatile_Full_Access (Comp)
5660 -- Give an error if the components are independent
5662 elsif Has_Independent_Components (Typ)
5663 or else Is_Independent (Comp)
5665 raise Independent_Subcomponent;
5668 -- Recurse on the component type
5670 Check_Subcomponents (Comp);
5672 -- Note: Has_Aliased_Components, like Has_Atomic_Components,
5673 -- and Has_Independent_Components, applies only to arrays.
5674 -- However, this flag does not have a corresponding pragma, so
5675 -- perhaps it should be possible to apply it to record types as
5676 -- well. Should this be done ???
5678 elsif Is_Record_Type (Typ) then
5679 -- It is possible to have an aliased discriminant, so they
5680 -- must be checked along with normal components.
5682 Comp := First_Component_Or_Discriminant (Typ);
5683 while Present (Comp) loop
5685 -- For Atomic we accept any atomic subcomponents
5688 and then (Is_Atomic (Comp)
5689 or else Is_Atomic (Etype (Comp)))
5693 -- Give an error if the component is aliased
5695 elsif Is_Aliased (Comp)
5696 or else Is_Aliased (Etype (Comp))
5698 raise Aliased_Subcomponent;
5700 -- For VFA we accept non-aliased VFA subcomponents
5703 and then (Is_Volatile_Full_Access (Comp)
5704 or else Is_Volatile_Full_Access (Etype (Comp)))
5708 -- Give an error if the component is independent
5710 elsif Is_Independent (Comp)
5711 or else Is_Independent (Etype (Comp))
5713 raise Independent_Subcomponent;
5716 -- Recurse on the component type
5718 Check_Subcomponents (Etype (Comp));
5720 Next_Component_Or_Discriminant (Comp);
5723 end Check_Subcomponents;
5728 -- Fetch the type in case we are dealing with an object or component
5733 pragma Assert (Is_Object (E)
5735 Nkind (Declaration_Node (E)) = N_Component_Declaration);
5740 -- Check all the subcomponents of the type recursively, if any
5742 Check_Subcomponents (Typ);
5745 when Aliased_Subcomponent =>
5748 ("cannot apply Volatile_Full_Access with aliased "
5752 ("cannot apply Atomic with aliased subcomponent "
5756 when Independent_Subcomponent =>
5759 ("cannot apply Volatile_Full_Access with independent "
5763 ("cannot apply Atomic with independent subcomponent "
5768 raise Program_Error;
5769 end Check_Atomic_VFA;
5771 ---------------------
5772 -- Check_Component --
5773 ---------------------
5775 procedure Check_Component
5778 In_Variant_Part : Boolean := False)
5780 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
5781 Sindic : constant Node_Id :=
5782 Subtype_Indication (Component_Definition (Comp));
5783 Typ : constant Entity_Id := Etype (Comp_Id);
5786 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
5787 -- object constraint, then the component type shall be an Unchecked_
5790 if Nkind (Sindic) = N_Subtype_Indication
5791 and then Has_Per_Object_Constraint (Comp_Id)
5792 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
5795 ("component subtype subject to per-object constraint "
5796 & "must be an Unchecked_Union", Comp);
5798 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
5799 -- the body of a generic unit, or within the body of any of its
5800 -- descendant library units, no part of the type of a component
5801 -- declared in a variant_part of the unchecked union type shall be of
5802 -- a formal private type or formal private extension declared within
5803 -- the formal part of the generic unit.
5805 elsif Ada_Version >= Ada_2012
5806 and then In_Generic_Body (UU_Typ)
5807 and then In_Variant_Part
5808 and then Is_Private_Type (Typ)
5809 and then Is_Generic_Type (Typ)
5812 ("component of unchecked union cannot be of generic type", Comp);
5814 elsif Needs_Finalization (Typ) then
5816 ("component of unchecked union cannot be controlled", Comp);
5818 elsif Has_Task (Typ) then
5820 ("component of unchecked union cannot have tasks", Comp);
5822 end Check_Component;
5824 ----------------------------
5825 -- Check_Duplicate_Pragma --
5826 ----------------------------
5828 procedure Check_Duplicate_Pragma (E : Entity_Id) is
5829 Id : Entity_Id := E;
5833 -- Nothing to do if this pragma comes from an aspect specification,
5834 -- since we could not be duplicating a pragma, and we dealt with the
5835 -- case of duplicated aspects in Analyze_Aspect_Specifications.
5837 if From_Aspect_Specification (N) then
5841 -- Otherwise current pragma may duplicate previous pragma or a
5842 -- previously given aspect specification or attribute definition
5843 -- clause for the same pragma.
5845 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
5849 -- If the entity is a type, then we have to make sure that the
5850 -- ostensible duplicate is not for a parent type from which this
5854 if Nkind (P) = N_Pragma then
5856 Args : constant List_Id :=
5857 Pragma_Argument_Associations (P);
5860 and then Is_Entity_Name (Expression (First (Args)))
5861 and then Is_Type (Entity (Expression (First (Args))))
5862 and then Entity (Expression (First (Args))) /= E
5868 elsif Nkind (P) = N_Aspect_Specification
5869 and then Is_Type (Entity (P))
5870 and then Entity (P) /= E
5876 -- Here we have a definite duplicate
5878 Error_Msg_Name_1 := Pragma_Name (N);
5879 Error_Msg_Sloc := Sloc (P);
5881 -- For a single protected or a single task object, the error is
5882 -- issued on the original entity.
5884 if Ekind_In (Id, E_Task_Type, E_Protected_Type) then
5885 Id := Defining_Identifier (Original_Node (Parent (Id)));
5888 if Nkind (P) = N_Aspect_Specification
5889 or else From_Aspect_Specification (P)
5891 Error_Msg_NE ("aspect% for & previously given#", N, Id);
5893 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
5898 end Check_Duplicate_Pragma;
5900 ----------------------------------
5901 -- Check_Duplicated_Export_Name --
5902 ----------------------------------
5904 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
5905 String_Val : constant String_Id := Strval (Nam);
5908 -- We are only interested in the export case, and in the case of
5909 -- generics, it is the instance, not the template, that is the
5910 -- problem (the template will generate a warning in any case).
5912 if not Inside_A_Generic
5913 and then (Prag_Id = Pragma_Export
5915 Prag_Id = Pragma_Export_Procedure
5917 Prag_Id = Pragma_Export_Valued_Procedure
5919 Prag_Id = Pragma_Export_Function)
5921 for J in Externals.First .. Externals.Last loop
5922 if String_Equal (String_Val, Strval (Externals.Table (J))) then
5923 Error_Msg_Sloc := Sloc (Externals.Table (J));
5924 Error_Msg_N ("external name duplicates name given#", Nam);
5929 Externals.Append (Nam);
5931 end Check_Duplicated_Export_Name;
5933 ----------------------------------------
5934 -- Check_Expr_Is_OK_Static_Expression --
5935 ----------------------------------------
5937 procedure Check_Expr_Is_OK_Static_Expression
5939 Typ : Entity_Id := Empty)
5942 if Present (Typ) then
5943 Analyze_And_Resolve (Expr, Typ);
5945 Analyze_And_Resolve (Expr);
5948 -- An expression cannot be considered static if its resolution failed
5949 -- or if it's erroneous. Stop the analysis of the related pragma.
5951 if Etype (Expr) = Any_Type or else Error_Posted (Expr) then
5954 elsif Is_OK_Static_Expression (Expr) then
5957 -- An interesting special case, if we have a string literal and we
5958 -- are in Ada 83 mode, then we allow it even though it will not be
5959 -- flagged as static. This allows the use of Ada 95 pragmas like
5960 -- Import in Ada 83 mode. They will of course be flagged with
5961 -- warnings as usual, but will not cause errors.
5963 elsif Ada_Version = Ada_83
5964 and then Nkind (Expr) = N_String_Literal
5968 -- Finally, we have a real error
5971 Error_Msg_Name_1 := Pname;
5972 Flag_Non_Static_Expr
5973 (Fix_Error ("argument for pragma% must be a static expression!"),
5977 end Check_Expr_Is_OK_Static_Expression;
5979 -------------------------
5980 -- Check_First_Subtype --
5981 -------------------------
5983 procedure Check_First_Subtype (Arg : Node_Id) is
5984 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5985 Ent : constant Entity_Id := Entity (Argx);
5988 if Is_First_Subtype (Ent) then
5991 elsif Is_Type (Ent) then
5993 ("pragma% cannot apply to subtype", Argx);
5995 elsif Is_Object (Ent) then
5997 ("pragma% cannot apply to object, requires a type", Argx);
6001 ("pragma% cannot apply to&, requires a type", Argx);
6003 end Check_First_Subtype;
6005 ----------------------
6006 -- Check_Identifier --
6007 ----------------------
6009 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
6012 and then Nkind (Arg) = N_Pragma_Argument_Association
6014 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
6015 Error_Msg_Name_1 := Pname;
6016 Error_Msg_Name_2 := Id;
6017 Error_Msg_N ("pragma% argument expects identifier%", Arg);
6021 end Check_Identifier;
6023 --------------------------------
6024 -- Check_Identifier_Is_One_Of --
6025 --------------------------------
6027 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
6030 and then Nkind (Arg) = N_Pragma_Argument_Association
6032 if Chars (Arg) = No_Name then
6033 Error_Msg_Name_1 := Pname;
6034 Error_Msg_N ("pragma% argument expects an identifier", Arg);
6037 elsif Chars (Arg) /= N1
6038 and then Chars (Arg) /= N2
6040 Error_Msg_Name_1 := Pname;
6041 Error_Msg_N ("invalid identifier for pragma% argument", Arg);
6045 end Check_Identifier_Is_One_Of;
6047 ---------------------------
6048 -- Check_In_Main_Program --
6049 ---------------------------
6051 procedure Check_In_Main_Program is
6052 P : constant Node_Id := Parent (N);
6055 -- Must be in subprogram body
6057 if Nkind (P) /= N_Subprogram_Body then
6058 Error_Pragma ("% pragma allowed only in subprogram");
6060 -- Otherwise warn if obviously not main program
6062 elsif Present (Parameter_Specifications (Specification (P)))
6063 or else not Is_Compilation_Unit (Defining_Entity (P))
6065 Error_Msg_Name_1 := Pname;
6067 ("??pragma% is only effective in main program", N);
6069 end Check_In_Main_Program;
6071 ---------------------------------------
6072 -- Check_Interrupt_Or_Attach_Handler --
6073 ---------------------------------------
6075 procedure Check_Interrupt_Or_Attach_Handler is
6076 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
6077 Handler_Proc, Proc_Scope : Entity_Id;
6082 if Prag_Id = Pragma_Interrupt_Handler then
6083 Check_Restriction (No_Dynamic_Attachment, N);
6086 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
6087 Proc_Scope := Scope (Handler_Proc);
6089 if Ekind (Proc_Scope) /= E_Protected_Type then
6091 ("argument of pragma% must be protected procedure", Arg1);
6094 -- For pragma case (as opposed to access case), check placement.
6095 -- We don't need to do that for aspects, because we have the
6096 -- check that they aspect applies an appropriate procedure.
6098 if not From_Aspect_Specification (N)
6099 and then Parent (N) /= Protected_Definition (Parent (Proc_Scope))
6101 Error_Pragma ("pragma% must be in protected definition");
6104 if not Is_Library_Level_Entity (Proc_Scope) then
6106 ("argument for pragma% must be library level entity", Arg1);
6109 -- AI05-0033: A pragma cannot appear within a generic body, because
6110 -- instance can be in a nested scope. The check that protected type
6111 -- is itself a library-level declaration is done elsewhere.
6113 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
6114 -- handle code prior to AI-0033. Analysis tools typically are not
6115 -- interested in this pragma in any case, so no need to worry too
6116 -- much about its placement.
6118 if Inside_A_Generic then
6119 if Ekind (Scope (Current_Scope)) = E_Generic_Package
6120 and then In_Package_Body (Scope (Current_Scope))
6121 and then not Relaxed_RM_Semantics
6123 Error_Pragma ("pragma% cannot be used inside a generic");
6126 end Check_Interrupt_Or_Attach_Handler;
6128 ---------------------------------
6129 -- Check_Loop_Pragma_Placement --
6130 ---------------------------------
6132 procedure Check_Loop_Pragma_Placement is
6133 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id);
6134 -- Verify whether the current pragma is properly grouped with other
6135 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
6136 -- related loop where the pragma appears.
6138 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean;
6139 -- Determine whether an arbitrary statement Stmt denotes pragma
6140 -- Loop_Invariant or Loop_Variant.
6142 procedure Placement_Error (Constr : Node_Id);
6143 pragma No_Return (Placement_Error);
6144 -- Node Constr denotes the last loop restricted construct before we
6145 -- encountered an illegal relation between enclosing constructs. Emit
6146 -- an error depending on what Constr was.
6148 --------------------------------
6149 -- Check_Loop_Pragma_Grouping --
6150 --------------------------------
6152 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is
6153 Stop_Search : exception;
6154 -- This exception is used to terminate the recursive descent of
6155 -- routine Check_Grouping.
6157 procedure Check_Grouping (L : List_Id);
6158 -- Find the first group of pragmas in list L and if successful,
6159 -- ensure that the current pragma is part of that group. The
6160 -- routine raises Stop_Search once such a check is performed to
6161 -- halt the recursive descent.
6163 procedure Grouping_Error (Prag : Node_Id);
6164 pragma No_Return (Grouping_Error);
6165 -- Emit an error concerning the current pragma indicating that it
6166 -- should be placed after pragma Prag.
6168 --------------------
6169 -- Check_Grouping --
6170 --------------------
6172 procedure Check_Grouping (L : List_Id) is
6175 Prag : Node_Id := Empty; -- init to avoid warning
6178 -- Inspect the list of declarations or statements looking for
6179 -- the first grouping of pragmas:
6182 -- pragma Loop_Invariant ...;
6183 -- pragma Loop_Variant ...;
6185 -- pragma Loop_Variant ...; -- current pragma
6187 -- If the current pragma is not in the grouping, then it must
6188 -- either appear in a different declarative or statement list
6189 -- or the construct at (1) is separating the pragma from the
6193 while Present (Stmt) loop
6195 -- First pragma of the first topmost grouping has been found
6197 if Is_Loop_Pragma (Stmt) then
6199 -- The group and the current pragma are not in the same
6200 -- declarative or statement list.
6202 if List_Containing (Stmt) /= List_Containing (N) then
6203 Grouping_Error (Stmt);
6205 -- Try to reach the current pragma from the first pragma
6206 -- of the grouping while skipping other members:
6208 -- pragma Loop_Invariant ...; -- first pragma
6209 -- pragma Loop_Variant ...; -- member
6211 -- pragma Loop_Variant ...; -- current pragma
6214 while Present (Stmt) loop
6215 -- The current pragma is either the first pragma
6216 -- of the group or is a member of the group.
6217 -- Stop the search as the placement is legal.
6222 -- Skip group members, but keep track of the
6223 -- last pragma in the group.
6225 elsif Is_Loop_Pragma (Stmt) then
6228 -- Skip declarations and statements generated by
6229 -- the compiler during expansion. Note that some
6230 -- source statements (e.g. pragma Assert) may have
6231 -- been transformed so that they do not appear as
6232 -- coming from source anymore, so we instead look
6233 -- at their Original_Node.
6235 elsif not Comes_From_Source (Original_Node (Stmt))
6239 -- A non-pragma is separating the group from the
6240 -- current pragma, the placement is illegal.
6243 Grouping_Error (Prag);
6249 -- If the traversal did not reach the current pragma,
6250 -- then the list must be malformed.
6252 raise Program_Error;
6255 -- Pragmas Loop_Invariant and Loop_Variant may only appear
6256 -- inside a loop or a block housed inside a loop. Inspect
6257 -- the declarations and statements of the block as they may
6258 -- contain the first grouping. This case follows the one for
6259 -- loop pragmas, as block statements which originate in a
6260 -- loop pragma (and so Is_Loop_Pragma will return True on
6261 -- that block statement) should be treated in the previous
6264 elsif Nkind (Stmt) = N_Block_Statement then
6265 HSS := Handled_Statement_Sequence (Stmt);
6267 Check_Grouping (Declarations (Stmt));
6269 if Present (HSS) then
6270 Check_Grouping (Statements (HSS));
6278 --------------------
6279 -- Grouping_Error --
6280 --------------------
6282 procedure Grouping_Error (Prag : Node_Id) is
6284 Error_Msg_Sloc := Sloc (Prag);
6285 Error_Pragma ("pragma% must appear next to pragma#");
6288 -- Start of processing for Check_Loop_Pragma_Grouping
6291 -- Inspect the statements of the loop or nested blocks housed
6292 -- within to determine whether the current pragma is part of the
6293 -- first topmost grouping of Loop_Invariant and Loop_Variant.
6295 Check_Grouping (Statements (Loop_Stmt));
6298 when Stop_Search => null;
6299 end Check_Loop_Pragma_Grouping;
6301 --------------------
6302 -- Is_Loop_Pragma --
6303 --------------------
6305 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean is
6307 -- Inspect the original node as Loop_Invariant and Loop_Variant
6308 -- pragmas are rewritten to null when assertions are disabled.
6310 if Nkind (Original_Node (Stmt)) = N_Pragma then
6312 Nam_In (Pragma_Name_Unmapped (Original_Node (Stmt)),
6313 Name_Loop_Invariant,
6320 ---------------------
6321 -- Placement_Error --
6322 ---------------------
6324 procedure Placement_Error (Constr : Node_Id) is
6325 LA : constant String := " with Loop_Entry";
6328 if Prag_Id = Pragma_Assert then
6329 Error_Msg_String (1 .. LA'Length) := LA;
6330 Error_Msg_Strlen := LA'Length;
6332 Error_Msg_Strlen := 0;
6335 if Nkind (Constr) = N_Pragma then
6337 ("pragma %~ must appear immediately within the statements "
6341 ("block containing pragma %~ must appear immediately within "
6342 & "the statements of a loop", Constr);
6344 end Placement_Error;
6346 -- Local declarations
6351 -- Start of processing for Check_Loop_Pragma_Placement
6354 -- Check that pragma appears immediately within a loop statement,
6355 -- ignoring intervening block statements.
6359 while Present (Stmt) loop
6361 -- The pragma or previous block must appear immediately within the
6362 -- current block's declarative or statement part.
6364 if Nkind (Stmt) = N_Block_Statement then
6365 if (No (Declarations (Stmt))
6366 or else List_Containing (Prev) /= Declarations (Stmt))
6368 List_Containing (Prev) /=
6369 Statements (Handled_Statement_Sequence (Stmt))
6371 Placement_Error (Prev);
6374 -- Keep inspecting the parents because we are now within a
6375 -- chain of nested blocks.
6379 Stmt := Parent (Stmt);
6382 -- The pragma or previous block must appear immediately within the
6383 -- statements of the loop.
6385 elsif Nkind (Stmt) = N_Loop_Statement then
6386 if List_Containing (Prev) /= Statements (Stmt) then
6387 Placement_Error (Prev);
6390 -- Stop the traversal because we reached the innermost loop
6391 -- regardless of whether we encountered an error or not.
6395 -- Ignore a handled statement sequence. Note that this node may
6396 -- be related to a subprogram body in which case we will emit an
6397 -- error on the next iteration of the search.
6399 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then
6400 Stmt := Parent (Stmt);
6402 -- Any other statement breaks the chain from the pragma to the
6406 Placement_Error (Prev);
6411 -- Check that the current pragma Loop_Invariant or Loop_Variant is
6412 -- grouped together with other such pragmas.
6414 if Is_Loop_Pragma (N) then
6416 -- The previous check should have located the related loop
6418 pragma Assert (Nkind (Stmt) = N_Loop_Statement);
6419 Check_Loop_Pragma_Grouping (Stmt);
6421 end Check_Loop_Pragma_Placement;
6423 -------------------------------------------
6424 -- Check_Is_In_Decl_Part_Or_Package_Spec --
6425 -------------------------------------------
6427 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
6436 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
6439 elsif Nkind_In (P, N_Package_Specification,
6444 -- Note: the following tests seem a little peculiar, because
6445 -- they test for bodies, but if we were in the statement part
6446 -- of the body, we would already have hit the handled statement
6447 -- sequence, so the only way we get here is by being in the
6448 -- declarative part of the body.
6450 elsif Nkind_In (P, N_Subprogram_Body,
6461 Error_Pragma ("pragma% is not in declarative part or package spec");
6462 end Check_Is_In_Decl_Part_Or_Package_Spec;
6464 -------------------------
6465 -- Check_No_Identifier --
6466 -------------------------
6468 procedure Check_No_Identifier (Arg : Node_Id) is
6470 if Nkind (Arg) = N_Pragma_Argument_Association
6471 and then Chars (Arg) /= No_Name
6473 Error_Pragma_Arg_Ident
6474 ("pragma% does not permit identifier& here", Arg);
6476 end Check_No_Identifier;
6478 --------------------------
6479 -- Check_No_Identifiers --
6480 --------------------------
6482 procedure Check_No_Identifiers is
6486 for J in 1 .. Arg_Count loop
6487 Check_No_Identifier (Arg_Node);
6490 end Check_No_Identifiers;
6492 ------------------------
6493 -- Check_No_Link_Name --
6494 ------------------------
6496 procedure Check_No_Link_Name is
6498 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then
6502 if Present (Arg4) then
6504 ("Link_Name argument not allowed for Import Intrinsic", Arg4);
6506 end Check_No_Link_Name;
6508 -------------------------------
6509 -- Check_Optional_Identifier --
6510 -------------------------------
6512 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
6515 and then Nkind (Arg) = N_Pragma_Argument_Association
6516 and then Chars (Arg) /= No_Name
6518 if Chars (Arg) /= Id then
6519 Error_Msg_Name_1 := Pname;
6520 Error_Msg_Name_2 := Id;
6521 Error_Msg_N ("pragma% argument expects identifier%", Arg);
6525 end Check_Optional_Identifier;
6527 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
6529 Check_Optional_Identifier (Arg, Name_Find (Id));
6530 end Check_Optional_Identifier;
6532 -------------------------------------
6533 -- Check_Static_Boolean_Expression --
6534 -------------------------------------
6536 procedure Check_Static_Boolean_Expression (Expr : Node_Id) is
6538 if Present (Expr) then
6539 Analyze_And_Resolve (Expr, Standard_Boolean);
6541 if not Is_OK_Static_Expression (Expr) then
6543 ("expression of pragma % must be static", Expr);
6546 end Check_Static_Boolean_Expression;
6548 -----------------------------
6549 -- Check_Static_Constraint --
6550 -----------------------------
6552 -- Note: for convenience in writing this procedure, in addition to
6553 -- the officially (i.e. by spec) allowed argument which is always a
6554 -- constraint, it also allows ranges and discriminant associations.
6555 -- Above is not clear ???
6557 procedure Check_Static_Constraint (Constr : Node_Id) is
6559 procedure Require_Static (E : Node_Id);
6560 -- Require given expression to be static expression
6562 --------------------
6563 -- Require_Static --
6564 --------------------
6566 procedure Require_Static (E : Node_Id) is
6568 if not Is_OK_Static_Expression (E) then
6569 Flag_Non_Static_Expr
6570 ("non-static constraint not allowed in Unchecked_Union!", E);
6575 -- Start of processing for Check_Static_Constraint
6578 case Nkind (Constr) is
6579 when N_Discriminant_Association =>
6580 Require_Static (Expression (Constr));
6583 Require_Static (Low_Bound (Constr));
6584 Require_Static (High_Bound (Constr));
6586 when N_Attribute_Reference =>
6587 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
6588 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
6590 when N_Range_Constraint =>
6591 Check_Static_Constraint (Range_Expression (Constr));
6593 when N_Index_Or_Discriminant_Constraint =>
6597 IDC := First (Constraints (Constr));
6598 while Present (IDC) loop
6599 Check_Static_Constraint (IDC);
6607 end Check_Static_Constraint;
6609 --------------------------------------
6610 -- Check_Valid_Configuration_Pragma --
6611 --------------------------------------
6613 -- A configuration pragma must appear in the context clause of a
6614 -- compilation unit, and only other pragmas may precede it. Note that
6615 -- the test also allows use in a configuration pragma file.
6617 procedure Check_Valid_Configuration_Pragma is
6619 if not Is_Configuration_Pragma then
6620 Error_Pragma ("incorrect placement for configuration pragma%");
6622 end Check_Valid_Configuration_Pragma;
6624 -------------------------------------
6625 -- Check_Valid_Library_Unit_Pragma --
6626 -------------------------------------
6628 procedure Check_Valid_Library_Unit_Pragma is
6630 Parent_Node : Node_Id;
6631 Unit_Name : Entity_Id;
6632 Unit_Kind : Node_Kind;
6633 Unit_Node : Node_Id;
6634 Sindex : Source_File_Index;
6637 if not Is_List_Member (N) then
6641 Plist := List_Containing (N);
6642 Parent_Node := Parent (Plist);
6644 if Parent_Node = Empty then
6647 -- Case of pragma appearing after a compilation unit. In this case
6648 -- it must have an argument with the corresponding name and must
6649 -- be part of the following pragmas of its parent.
6651 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
6652 if Plist /= Pragmas_After (Parent_Node) then
6655 elsif Arg_Count = 0 then
6657 ("argument required if outside compilation unit");
6660 Check_No_Identifiers;
6661 Check_Arg_Count (1);
6662 Unit_Node := Unit (Parent (Parent_Node));
6663 Unit_Kind := Nkind (Unit_Node);
6665 Analyze (Get_Pragma_Arg (Arg1));
6667 if Unit_Kind = N_Generic_Subprogram_Declaration
6668 or else Unit_Kind = N_Subprogram_Declaration
6670 Unit_Name := Defining_Entity (Unit_Node);
6672 elsif Unit_Kind in N_Generic_Instantiation then
6673 Unit_Name := Defining_Entity (Unit_Node);
6676 Unit_Name := Cunit_Entity (Current_Sem_Unit);
6679 if Chars (Unit_Name) /=
6680 Chars (Entity (Get_Pragma_Arg (Arg1)))
6683 ("pragma% argument is not current unit name", Arg1);
6686 if Ekind (Unit_Name) = E_Package
6687 and then Present (Renamed_Entity (Unit_Name))
6689 Error_Pragma ("pragma% not allowed for renamed package");
6693 -- Pragma appears other than after a compilation unit
6696 -- Here we check for the generic instantiation case and also
6697 -- for the case of processing a generic formal package. We
6698 -- detect these cases by noting that the Sloc on the node
6699 -- does not belong to the current compilation unit.
6701 Sindex := Source_Index (Current_Sem_Unit);
6703 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
6704 Rewrite (N, Make_Null_Statement (Loc));
6707 -- If before first declaration, the pragma applies to the
6708 -- enclosing unit, and the name if present must be this name.
6710 elsif Is_Before_First_Decl (N, Plist) then
6711 Unit_Node := Unit_Declaration_Node (Current_Scope);
6712 Unit_Kind := Nkind (Unit_Node);
6714 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
6717 elsif Unit_Kind = N_Subprogram_Body
6718 and then not Acts_As_Spec (Unit_Node)
6722 elsif Nkind (Parent_Node) = N_Package_Body then
6725 elsif Nkind (Parent_Node) = N_Package_Specification
6726 and then Plist = Private_Declarations (Parent_Node)
6730 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
6731 or else Nkind (Parent_Node) =
6732 N_Generic_Subprogram_Declaration)
6733 and then Plist = Generic_Formal_Declarations (Parent_Node)
6737 elsif Arg_Count > 0 then
6738 Analyze (Get_Pragma_Arg (Arg1));
6740 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
6742 ("name in pragma% must be enclosing unit", Arg1);
6745 -- It is legal to have no argument in this context
6751 -- Error if not before first declaration. This is because a
6752 -- library unit pragma argument must be the name of a library
6753 -- unit (RM 10.1.5(7)), but the only names permitted in this
6754 -- context are (RM 10.1.5(6)) names of subprogram declarations,
6755 -- generic subprogram declarations or generic instantiations.
6759 ("pragma% misplaced, must be before first declaration");
6763 end Check_Valid_Library_Unit_Pragma;
6769 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
6770 Clist : constant Node_Id := Component_List (Variant);
6774 Comp := First_Non_Pragma (Component_Items (Clist));
6775 while Present (Comp) loop
6776 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
6777 Next_Non_Pragma (Comp);
6781 ---------------------------
6782 -- Ensure_Aggregate_Form --
6783 ---------------------------
6785 procedure Ensure_Aggregate_Form (Arg : Node_Id) is
6786 CFSD : constant Boolean := Get_Comes_From_Source_Default;
6787 Expr : constant Node_Id := Expression (Arg);
6788 Loc : constant Source_Ptr := Sloc (Expr);
6789 Comps : List_Id := No_List;
6790 Exprs : List_Id := No_List;
6791 Nam : Name_Id := No_Name;
6792 Nam_Loc : Source_Ptr;
6795 -- The pragma argument is in positional form:
6797 -- pragma Depends (Nam => ...)
6801 -- Note that the Sloc of the Chars field is the Sloc of the pragma
6802 -- argument association.
6804 if Nkind (Arg) = N_Pragma_Argument_Association then
6806 Nam_Loc := Sloc (Arg);
6808 -- Remove the pragma argument name as this will be captured in the
6811 Set_Chars (Arg, No_Name);
6814 -- The argument is already in aggregate form, but the presence of a
6815 -- name causes this to be interpreted as named association which in
6816 -- turn must be converted into an aggregate.
6818 -- pragma Global (In_Out => (A, B, C))
6822 -- pragma Global ((In_Out => (A, B, C)))
6824 -- aggregate aggregate
6826 if Nkind (Expr) = N_Aggregate then
6827 if Nam = No_Name then
6831 -- Do not transform a null argument into an aggregate as N_Null has
6832 -- special meaning in formal verification pragmas.
6834 elsif Nkind (Expr) = N_Null then
6838 -- Everything comes from source if the original comes from source
6840 Set_Comes_From_Source_Default (Comes_From_Source (Arg));
6842 -- Positional argument is transformed into an aggregate with an
6843 -- Expressions list.
6845 if Nam = No_Name then
6846 Exprs := New_List (Relocate_Node (Expr));
6848 -- An associative argument is transformed into an aggregate with
6849 -- Component_Associations.
6853 Make_Component_Association (Loc,
6854 Choices => New_List (Make_Identifier (Nam_Loc, Nam)),
6855 Expression => Relocate_Node (Expr)));
6858 Set_Expression (Arg,
6859 Make_Aggregate (Loc,
6860 Component_Associations => Comps,
6861 Expressions => Exprs));
6863 -- Restore Comes_From_Source default
6865 Set_Comes_From_Source_Default (CFSD);
6866 end Ensure_Aggregate_Form;
6872 procedure Error_Pragma (Msg : String) is
6874 Error_Msg_Name_1 := Pname;
6875 Error_Msg_N (Fix_Error (Msg), N);
6879 ----------------------
6880 -- Error_Pragma_Arg --
6881 ----------------------
6883 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
6885 Error_Msg_Name_1 := Pname;
6886 Error_Msg_N (Fix_Error (Msg), Get_Pragma_Arg (Arg));
6888 end Error_Pragma_Arg;
6890 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
6892 Error_Msg_Name_1 := Pname;
6893 Error_Msg_N (Fix_Error (Msg1), Get_Pragma_Arg (Arg));
6894 Error_Pragma_Arg (Msg2, Arg);
6895 end Error_Pragma_Arg;
6897 ----------------------------
6898 -- Error_Pragma_Arg_Ident --
6899 ----------------------------
6901 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
6903 Error_Msg_Name_1 := Pname;
6904 Error_Msg_N (Fix_Error (Msg), Arg);
6906 end Error_Pragma_Arg_Ident;
6908 ----------------------
6909 -- Error_Pragma_Ref --
6910 ----------------------
6912 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
6914 Error_Msg_Name_1 := Pname;
6915 Error_Msg_Sloc := Sloc (Ref);
6916 Error_Msg_NE (Fix_Error (Msg), N, Ref);
6918 end Error_Pragma_Ref;
6920 ------------------------
6921 -- Find_Lib_Unit_Name --
6922 ------------------------
6924 function Find_Lib_Unit_Name return Entity_Id is
6926 -- Return inner compilation unit entity, for case of nested
6927 -- categorization pragmas. This happens in generic unit.
6929 if Nkind (Parent (N)) = N_Package_Specification
6930 and then Defining_Entity (Parent (N)) /= Current_Scope
6932 return Defining_Entity (Parent (N));
6934 return Current_Scope;
6936 end Find_Lib_Unit_Name;
6938 ----------------------------
6939 -- Find_Program_Unit_Name --
6940 ----------------------------
6942 procedure Find_Program_Unit_Name (Id : Node_Id) is
6943 Unit_Name : Entity_Id;
6944 Unit_Kind : Node_Kind;
6945 P : constant Node_Id := Parent (N);
6948 if Nkind (P) = N_Compilation_Unit then
6949 Unit_Kind := Nkind (Unit (P));
6951 if Nkind_In (Unit_Kind, N_Subprogram_Declaration,
6952 N_Package_Declaration)
6953 or else Unit_Kind in N_Generic_Declaration
6955 Unit_Name := Defining_Entity (Unit (P));
6957 if Chars (Id) = Chars (Unit_Name) then
6958 Set_Entity (Id, Unit_Name);
6959 Set_Etype (Id, Etype (Unit_Name));
6961 Set_Etype (Id, Any_Type);
6963 ("cannot find program unit referenced by pragma%");
6967 Set_Etype (Id, Any_Type);
6968 Error_Pragma ("pragma% inapplicable to this unit");
6974 end Find_Program_Unit_Name;
6976 -----------------------------------------
6977 -- Find_Unique_Parameterless_Procedure --
6978 -----------------------------------------
6980 function Find_Unique_Parameterless_Procedure
6982 Arg : Node_Id) return Entity_Id
6984 Proc : Entity_Id := Empty;
6987 -- The body of this procedure needs some comments ???
6989 if not Is_Entity_Name (Name) then
6991 ("argument of pragma% must be entity name", Arg);
6993 elsif not Is_Overloaded (Name) then
6994 Proc := Entity (Name);
6996 if Ekind (Proc) /= E_Procedure
6997 or else Present (First_Formal (Proc))
7000 ("argument of pragma% must be parameterless procedure", Arg);
7005 Found : Boolean := False;
7007 Index : Interp_Index;
7010 Get_First_Interp (Name, Index, It);
7011 while Present (It.Nam) loop
7014 if Ekind (Proc) = E_Procedure
7015 and then No (First_Formal (Proc))
7019 Set_Entity (Name, Proc);
7020 Set_Is_Overloaded (Name, False);
7023 ("ambiguous handler name for pragma% ", Arg);
7027 Get_Next_Interp (Index, It);
7032 ("argument of pragma% must be parameterless procedure",
7035 Proc := Entity (Name);
7041 end Find_Unique_Parameterless_Procedure;
7047 function Fix_Error (Msg : String) return String is
7048 Res : String (Msg'Range) := Msg;
7049 Res_Last : Natural := Msg'Last;
7053 -- If we have a rewriting of another pragma, go to that pragma
7055 if Is_Rewrite_Substitution (N)
7056 and then Nkind (Original_Node (N)) = N_Pragma
7058 Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
7061 -- Case where pragma comes from an aspect specification
7063 if From_Aspect_Specification (N) then
7065 -- Change appearence of "pragma" in message to "aspect"
7068 while J <= Res_Last - 5 loop
7069 if Res (J .. J + 5) = "pragma" then
7070 Res (J .. J + 5) := "aspect";
7078 -- Change "argument of" at start of message to "entity for"
7081 and then Res (Res'First .. Res'First + 10) = "argument of"
7083 Res (Res'First .. Res'First + 9) := "entity for";
7084 Res (Res'First + 10 .. Res_Last - 1) :=
7085 Res (Res'First + 11 .. Res_Last);
7086 Res_Last := Res_Last - 1;
7089 -- Change "argument" at start of message to "entity"
7092 and then Res (Res'First .. Res'First + 7) = "argument"
7094 Res (Res'First .. Res'First + 5) := "entity";
7095 Res (Res'First + 6 .. Res_Last - 2) :=
7096 Res (Res'First + 8 .. Res_Last);
7097 Res_Last := Res_Last - 2;
7100 -- Get name from corresponding aspect
7102 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
7105 -- Return possibly modified message
7107 return Res (Res'First .. Res_Last);
7110 -------------------------
7111 -- Gather_Associations --
7112 -------------------------
7114 procedure Gather_Associations
7116 Args : out Args_List)
7121 -- Initialize all parameters to Empty
7123 for J in Args'Range loop
7127 -- That's all we have to do if there are no argument associations
7129 if No (Pragma_Argument_Associations (N)) then
7133 -- Otherwise first deal with any positional parameters present
7135 Arg := First (Pragma_Argument_Associations (N));
7136 for Index in Args'Range loop
7137 exit when No (Arg) or else Chars (Arg) /= No_Name;
7138 Args (Index) := Get_Pragma_Arg (Arg);
7142 -- Positional parameters all processed, if any left, then we
7143 -- have too many positional parameters.
7145 if Present (Arg) and then Chars (Arg) = No_Name then
7147 ("too many positional associations for pragma%", Arg);
7150 -- Process named parameters if any are present
7152 while Present (Arg) loop
7153 if Chars (Arg) = No_Name then
7155 ("positional association cannot follow named association",
7159 for Index in Names'Range loop
7160 if Names (Index) = Chars (Arg) then
7161 if Present (Args (Index)) then
7163 ("duplicate argument association for pragma%", Arg);
7165 Args (Index) := Get_Pragma_Arg (Arg);
7170 if Index = Names'Last then
7171 Error_Msg_Name_1 := Pname;
7172 Error_Msg_N ("pragma% does not allow & argument", Arg);
7174 -- Check for possible misspelling
7176 for Index1 in Names'Range loop
7177 if Is_Bad_Spelling_Of
7178 (Chars (Arg), Names (Index1))
7180 Error_Msg_Name_1 := Names (Index1);
7181 Error_Msg_N -- CODEFIX
7182 ("\possible misspelling of%", Arg);
7194 end Gather_Associations;
7200 procedure GNAT_Pragma is
7202 -- We need to check the No_Implementation_Pragmas restriction for
7203 -- the case of a pragma from source. Note that the case of aspects
7204 -- generating corresponding pragmas marks these pragmas as not being
7205 -- from source, so this test also catches that case.
7207 if Comes_From_Source (N) then
7208 Check_Restriction (No_Implementation_Pragmas, N);
7212 --------------------------
7213 -- Is_Before_First_Decl --
7214 --------------------------
7216 function Is_Before_First_Decl
7217 (Pragma_Node : Node_Id;
7218 Decls : List_Id) return Boolean
7220 Item : Node_Id := First (Decls);
7223 -- Only other pragmas can come before this pragma, but they might
7224 -- have been rewritten so check the original node.
7227 if No (Item) or else Nkind (Original_Node (Item)) /= N_Pragma then
7230 elsif Item = Pragma_Node then
7236 end Is_Before_First_Decl;
7238 -----------------------------
7239 -- Is_Configuration_Pragma --
7240 -----------------------------
7242 -- A configuration pragma must appear in the context clause of a
7243 -- compilation unit, and only other pragmas may precede it. Note that
7244 -- the test below also permits use in a configuration pragma file.
7246 function Is_Configuration_Pragma return Boolean is
7247 Lis : constant List_Id := List_Containing (N);
7248 Par : constant Node_Id := Parent (N);
7252 -- If no parent, then we are in the configuration pragma file,
7253 -- so the placement is definitely appropriate.
7258 -- Otherwise we must be in the context clause of a compilation unit
7259 -- and the only thing allowed before us in the context list is more
7260 -- configuration pragmas.
7262 elsif Nkind (Par) = N_Compilation_Unit
7263 and then Context_Items (Par) = Lis
7270 elsif Nkind (Prg) /= N_Pragma then
7280 end Is_Configuration_Pragma;
7282 --------------------------
7283 -- Is_In_Context_Clause --
7284 --------------------------
7286 function Is_In_Context_Clause return Boolean is
7288 Parent_Node : Node_Id;
7291 if not Is_List_Member (N) then
7295 Plist := List_Containing (N);
7296 Parent_Node := Parent (Plist);
7298 if Parent_Node = Empty
7299 or else Nkind (Parent_Node) /= N_Compilation_Unit
7300 or else Context_Items (Parent_Node) /= Plist
7307 end Is_In_Context_Clause;
7309 ---------------------------------
7310 -- Is_Static_String_Expression --
7311 ---------------------------------
7313 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
7314 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
7315 Lit : constant Boolean := Nkind (Argx) = N_String_Literal;
7318 Analyze_And_Resolve (Argx);
7320 -- Special case Ada 83, where the expression will never be static,
7321 -- but we will return true if we had a string literal to start with.
7323 if Ada_Version = Ada_83 then
7326 -- Normal case, true only if we end up with a string literal that
7327 -- is marked as being the result of evaluating a static expression.
7330 return Is_OK_Static_Expression (Argx)
7331 and then Nkind (Argx) = N_String_Literal;
7334 end Is_Static_String_Expression;
7336 ----------------------
7337 -- Pragma_Misplaced --
7338 ----------------------
7340 procedure Pragma_Misplaced is
7342 Error_Pragma ("incorrect placement of pragma%");
7343 end Pragma_Misplaced;
7345 ------------------------------------------------
7346 -- Process_Atomic_Independent_Shared_Volatile --
7347 ------------------------------------------------
7349 procedure Process_Atomic_Independent_Shared_Volatile is
7350 procedure Check_VFA_Conflicts (Ent : Entity_Id);
7351 -- Check that Volatile_Full_Access and VFA do not conflict
7353 procedure Mark_Component_Or_Object (Ent : Entity_Id);
7354 -- Appropriately set flags on the given entity, either an array or
7355 -- record component, or an object declaration) according to the
7358 procedure Mark_Type (Ent : Entity_Id);
7359 -- Appropriately set flags on the given entity, a type
7361 procedure Set_Atomic_VFA (Ent : Entity_Id);
7362 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
7363 -- no explicit alignment was given, set alignment to unknown, since
7364 -- back end knows what the alignment requirements are for atomic and
7365 -- full access arrays. Note: this is necessary for derived types.
7367 -------------------------
7368 -- Check_VFA_Conflicts --
7369 -------------------------
7371 procedure Check_VFA_Conflicts (Ent : Entity_Id) is
7375 VFA_And_Atomic : Boolean := False;
7376 -- Set True if both VFA and Atomic present
7379 -- Fetch the type in case we are dealing with an object or
7382 if Is_Type (Ent) then
7385 pragma Assert (Is_Object (Ent)
7387 Nkind (Declaration_Node (Ent)) = N_Component_Declaration);
7392 -- Check Atomic and VFA used together
7394 if Prag_Id = Pragma_Volatile_Full_Access
7395 or else Is_Volatile_Full_Access (Ent)
7397 if Prag_Id = Pragma_Atomic
7398 or else Prag_Id = Pragma_Shared
7399 or else Is_Atomic (Ent)
7401 VFA_And_Atomic := True;
7403 elsif Is_Array_Type (Typ) then
7404 VFA_And_Atomic := Has_Atomic_Components (Typ);
7406 -- Note: Has_Atomic_Components is not used below, as this flag
7407 -- represents the pragma of the same name, Atomic_Components,
7408 -- which only applies to arrays.
7410 elsif Is_Record_Type (Typ) then
7411 -- Attributes cannot be applied to discriminants, only
7412 -- regular record components.
7414 Comp := First_Component (Typ);
7415 while Present (Comp) loop
7417 or else Is_Atomic (Typ)
7419 VFA_And_Atomic := True;
7424 Next_Component (Comp);
7428 if VFA_And_Atomic then
7430 ("cannot have Volatile_Full_Access and Atomic for same "
7434 end Check_VFA_Conflicts;
7436 ------------------------------
7437 -- Mark_Component_Or_Object --
7438 ------------------------------
7440 procedure Mark_Component_Or_Object (Ent : Entity_Id) is
7442 if Prag_Id = Pragma_Atomic
7443 or else Prag_Id = Pragma_Shared
7444 or else Prag_Id = Pragma_Volatile_Full_Access
7446 if Prag_Id = Pragma_Volatile_Full_Access then
7447 Set_Is_Volatile_Full_Access (Ent);
7449 Set_Is_Atomic (Ent);
7452 -- If the object declaration has an explicit initialization, a
7453 -- temporary may have to be created to hold the expression, to
7454 -- ensure that access to the object remains atomic.
7456 if Nkind (Parent (Ent)) = N_Object_Declaration
7457 and then Present (Expression (Parent (Ent)))
7459 Set_Has_Delayed_Freeze (Ent);
7463 -- Atomic/Shared/Volatile_Full_Access imply Independent
7465 if Prag_Id /= Pragma_Volatile then
7466 Set_Is_Independent (Ent);
7468 if Prag_Id = Pragma_Independent then
7469 Record_Independence_Check (N, Ent);
7473 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7475 if Prag_Id /= Pragma_Independent then
7476 Set_Is_Volatile (Ent);
7477 Set_Treat_As_Volatile (Ent);
7479 end Mark_Component_Or_Object;
7485 procedure Mark_Type (Ent : Entity_Id) is
7487 -- Attribute belongs on the base type. If the view of the type is
7488 -- currently private, it also belongs on the underlying type.
7490 -- In Ada 2020, the pragma can apply to a formal type, for which
7491 -- there may be no underlying type.
7493 if Prag_Id = Pragma_Atomic
7494 or else Prag_Id = Pragma_Shared
7495 or else Prag_Id = Pragma_Volatile_Full_Access
7497 Set_Atomic_VFA (Ent);
7498 Set_Atomic_VFA (Base_Type (Ent));
7500 if not Is_Generic_Type (Ent) then
7501 Set_Atomic_VFA (Underlying_Type (Ent));
7505 -- Atomic/Shared/Volatile_Full_Access imply Independent
7507 if Prag_Id /= Pragma_Volatile then
7508 Set_Is_Independent (Ent);
7509 Set_Is_Independent (Base_Type (Ent));
7511 if not Is_Generic_Type (Ent) then
7512 Set_Is_Independent (Underlying_Type (Ent));
7514 if Prag_Id = Pragma_Independent then
7515 Record_Independence_Check (N, Base_Type (Ent));
7520 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7522 if Prag_Id /= Pragma_Independent then
7523 Set_Is_Volatile (Ent);
7524 Set_Is_Volatile (Base_Type (Ent));
7526 if not Is_Generic_Type (Ent) then
7527 Set_Is_Volatile (Underlying_Type (Ent));
7528 Set_Treat_As_Volatile (Underlying_Type (Ent));
7531 Set_Treat_As_Volatile (Ent);
7534 -- Apply Volatile to the composite type's individual components,
7537 if Prag_Id = Pragma_Volatile
7538 and then Is_Record_Type (Etype (Ent))
7543 Comp := First_Component (Ent);
7544 while Present (Comp) loop
7545 Mark_Component_Or_Object (Comp);
7547 Next_Component (Comp);
7553 --------------------
7554 -- Set_Atomic_VFA --
7555 --------------------
7557 procedure Set_Atomic_VFA (Ent : Entity_Id) is
7559 if Prag_Id = Pragma_Volatile_Full_Access then
7560 Set_Is_Volatile_Full_Access (Ent);
7562 Set_Is_Atomic (Ent);
7565 if not Has_Alignment_Clause (Ent) then
7566 Set_Alignment (Ent, Uint_0);
7576 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
7579 Check_Ada_83_Warning;
7580 Check_No_Identifiers;
7581 Check_Arg_Count (1);
7582 Check_Arg_Is_Local_Name (Arg1);
7583 E_Arg := Get_Pragma_Arg (Arg1);
7585 if Etype (E_Arg) = Any_Type then
7589 E := Entity (E_Arg);
7591 -- A pragma that applies to a Ghost entity becomes Ghost for the
7592 -- purposes of legality checks and removal of ignored Ghost code.
7594 Mark_Ghost_Pragma (N, E);
7596 -- Check duplicate before we chain ourselves
7598 Check_Duplicate_Pragma (E);
7600 -- Check appropriateness of the entity
7602 Decl := Declaration_Node (E);
7604 -- Deal with the case where the pragma/attribute is applied to a type
7607 if Rep_Item_Too_Early (E, N)
7608 or else Rep_Item_Too_Late (E, N)
7612 Check_First_Subtype (Arg1);
7617 -- Deal with the case where the pragma/attribute applies to a
7618 -- component or object declaration.
7620 elsif Nkind (Decl) = N_Object_Declaration
7621 or else (Nkind (Decl) = N_Component_Declaration
7622 and then Original_Record_Component (E) = E)
7624 if Rep_Item_Too_Late (E, N) then
7628 Mark_Component_Or_Object (E);
7630 -- In other cases give an error
7633 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
7636 -- Check that Volatile_Full_Access and Atomic do not conflict
7638 Check_VFA_Conflicts (E);
7640 -- Check for the application of Atomic or Volatile_Full_Access to
7641 -- an entity that has [nonatomic] aliased, or else specified to be
7642 -- independently addressable, subcomponents.
7644 if (Prag_Id = Pragma_Atomic and then Ada_Version >= Ada_2020)
7645 or else Prag_Id = Pragma_Volatile_Full_Access
7647 Check_Atomic_VFA (E, VFA => Prag_Id = Pragma_Volatile_Full_Access);
7650 -- The following check is only relevant when SPARK_Mode is on as
7651 -- this is not a standard Ada legality rule. Pragma Volatile can
7652 -- only apply to a full type declaration or an object declaration
7653 -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for
7654 -- untagged derived types that are rewritten as subtypes of their
7655 -- respective root types.
7658 and then Prag_Id = Pragma_Volatile
7659 and then not Nkind_In (Original_Node (Decl),
7660 N_Full_Type_Declaration,
7661 N_Object_Declaration,
7662 N_Single_Protected_Declaration,
7663 N_Single_Task_Declaration)
7666 ("argument of pragma % must denote a full type or object "
7667 & "declaration", Arg1);
7669 end Process_Atomic_Independent_Shared_Volatile;
7671 -------------------------------------------
7672 -- Process_Compile_Time_Warning_Or_Error --
7673 -------------------------------------------
7675 procedure Process_Compile_Time_Warning_Or_Error is
7676 P : Node_Id := Parent (N);
7677 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
7680 Check_Arg_Count (2);
7681 Check_No_Identifiers;
7682 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
7683 Analyze_And_Resolve (Arg1x, Standard_Boolean);
7685 -- In GNATprove mode, pragma Compile_Time_Error is translated as
7686 -- a Check pragma in GNATprove mode, handled as an assumption in
7687 -- GNATprove. This is correct as the compiler will issue an error
7688 -- if the condition cannot be statically evaluated to False.
7689 -- Compile_Time_Warning are ignored, as the analyzer may not have the
7690 -- same information as the compiler (in particular regarding size of
7691 -- objects decided in gigi) so it makes no sense to issue a warning
7694 if GNATprove_Mode then
7695 if Prag_Id = Pragma_Compile_Time_Error then
7699 -- Implement Compile_Time_Error by generating
7700 -- a corresponding Check pragma:
7702 -- pragma Check (name, condition);
7704 -- where name is the identifier matching the pragma name. So
7705 -- rewrite pragma in this manner and analyze the result.
7707 New_Args := New_List
7708 (Make_Pragma_Argument_Association
7710 Expression => Make_Identifier (Loc, Pname)),
7711 Make_Pragma_Argument_Association
7713 Expression => Arg1x));
7715 -- Rewrite as Check pragma
7719 Chars => Name_Check,
7720 Pragma_Argument_Associations => New_Args));
7726 Rewrite (N, Make_Null_Statement (Loc));
7732 -- If the condition is known at compile time (now), validate it now.
7733 -- Otherwise, register the expression for validation after the back
7734 -- end has been called, because it might be known at compile time
7735 -- then. For example, if the expression is "Record_Type'Size /= 32"
7736 -- it might be known after the back end has determined the size of
7737 -- Record_Type. We do not defer validation if we're inside a generic
7738 -- unit, because we will have more information in the instances.
7740 if Compile_Time_Known_Value (Arg1x) then
7741 Validate_Compile_Time_Warning_Or_Error (N, Sloc (Arg1));
7743 while Present (P) and then Nkind (P) not in N_Generic_Declaration
7745 if Nkind_In (P, N_Package_Body, N_Subprogram_Body) then
7746 P := Corresponding_Spec (P);
7753 Defer_Compile_Time_Warning_Error_To_BE (N);
7756 end Process_Compile_Time_Warning_Or_Error;
7758 ------------------------
7759 -- Process_Convention --
7760 ------------------------
7762 procedure Process_Convention
7763 (C : out Convention_Id;
7764 Ent : out Entity_Id)
7768 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
7769 -- Called if we have more than one Export/Import/Convention pragma.
7770 -- This is generally illegal, but we have a special case of allowing
7771 -- Import and Interface to coexist if they specify the convention in
7772 -- a consistent manner. We are allowed to do this, since Interface is
7773 -- an implementation defined pragma, and we choose to do it since we
7774 -- know Rational allows this combination. S is the entity id of the
7775 -- subprogram in question. This procedure also sets the special flag
7776 -- Import_Interface_Present in both pragmas in the case where we do
7777 -- have matching Import and Interface pragmas.
7779 procedure Set_Convention_From_Pragma (E : Entity_Id);
7780 -- Set convention in entity E, and also flag that the entity has a
7781 -- convention pragma. If entity is for a private or incomplete type,
7782 -- also set convention and flag on underlying type. This procedure
7783 -- also deals with the special case of C_Pass_By_Copy convention,
7784 -- and error checks for inappropriate convention specification.
7786 -------------------------------
7787 -- Diagnose_Multiple_Pragmas --
7788 -------------------------------
7790 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
7791 Pdec : constant Node_Id := Declaration_Node (S);
7795 function Same_Convention (Decl : Node_Id) return Boolean;
7796 -- Decl is a pragma node. This function returns True if this
7797 -- pragma has a first argument that is an identifier with a
7798 -- Chars field corresponding to the Convention_Id C.
7800 function Same_Name (Decl : Node_Id) return Boolean;
7801 -- Decl is a pragma node. This function returns True if this
7802 -- pragma has a second argument that is an identifier with a
7803 -- Chars field that matches the Chars of the current subprogram.
7805 ---------------------
7806 -- Same_Convention --
7807 ---------------------
7809 function Same_Convention (Decl : Node_Id) return Boolean is
7810 Arg1 : constant Node_Id :=
7811 First (Pragma_Argument_Associations (Decl));
7814 if Present (Arg1) then
7816 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
7818 if Nkind (Arg) = N_Identifier
7819 and then Is_Convention_Name (Chars (Arg))
7820 and then Get_Convention_Id (Chars (Arg)) = C
7828 end Same_Convention;
7834 function Same_Name (Decl : Node_Id) return Boolean is
7835 Arg1 : constant Node_Id :=
7836 First (Pragma_Argument_Associations (Decl));
7844 Arg2 := Next (Arg1);
7851 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
7853 if Nkind (Arg) = N_Identifier
7854 and then Chars (Arg) = Chars (S)
7863 -- Start of processing for Diagnose_Multiple_Pragmas
7868 -- Definitely give message if we have Convention/Export here
7870 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
7873 -- If we have an Import or Export, scan back from pragma to
7874 -- find any previous pragma applying to the same procedure.
7875 -- The scan will be terminated by the start of the list, or
7876 -- hitting the subprogram declaration. This won't allow one
7877 -- pragma to appear in the public part and one in the private
7878 -- part, but that seems very unlikely in practice.
7882 while Present (Decl) and then Decl /= Pdec loop
7884 -- Look for pragma with same name as us
7886 if Nkind (Decl) = N_Pragma
7887 and then Same_Name (Decl)
7889 -- Give error if same as our pragma or Export/Convention
7891 if Nam_In (Pragma_Name_Unmapped (Decl),
7894 Pragma_Name_Unmapped (N))
7898 -- Case of Import/Interface or the other way round
7900 elsif Nam_In (Pragma_Name_Unmapped (Decl),
7901 Name_Interface, Name_Import)
7903 -- Here we know that we have Import and Interface. It
7904 -- doesn't matter which way round they are. See if
7905 -- they specify the same convention. If so, all OK,
7906 -- and set special flags to stop other messages
7908 if Same_Convention (Decl) then
7909 Set_Import_Interface_Present (N);
7910 Set_Import_Interface_Present (Decl);
7913 -- If different conventions, special message
7916 Error_Msg_Sloc := Sloc (Decl);
7918 ("convention differs from that given#", Arg1);
7928 -- Give message if needed if we fall through those tests
7929 -- except on Relaxed_RM_Semantics where we let go: either this
7930 -- is a case accepted/ignored by other Ada compilers (e.g.
7931 -- a mix of Convention and Import), or another error will be
7932 -- generated later (e.g. using both Import and Export).
7934 if Err and not Relaxed_RM_Semantics then
7936 ("at most one Convention/Export/Import pragma is allowed",
7939 end Diagnose_Multiple_Pragmas;
7941 --------------------------------
7942 -- Set_Convention_From_Pragma --
7943 --------------------------------
7945 procedure Set_Convention_From_Pragma (E : Entity_Id) is
7947 -- Ada 2005 (AI-430): Check invalid attempt to change convention
7948 -- for an overridden dispatching operation. Technically this is
7949 -- an amendment and should only be done in Ada 2005 mode. However,
7950 -- this is clearly a mistake, since the problem that is addressed
7951 -- by this AI is that there is a clear gap in the RM.
7953 if Is_Dispatching_Operation (E)
7954 and then Present (Overridden_Operation (E))
7955 and then C /= Convention (Overridden_Operation (E))
7958 ("cannot change convention for overridden dispatching "
7959 & "operation", Arg1);
7962 -- Special checks for Convention_Stdcall
7964 if C = Convention_Stdcall then
7966 -- A dispatching call is not allowed. A dispatching subprogram
7967 -- cannot be used to interface to the Win32 API, so in fact
7968 -- this check does not impose any effective restriction.
7970 if Is_Dispatching_Operation (E) then
7971 Error_Msg_Sloc := Sloc (E);
7973 -- Note: make this unconditional so that if there is more
7974 -- than one call to which the pragma applies, we get a
7975 -- message for each call. Also don't use Error_Pragma,
7976 -- so that we get multiple messages.
7979 ("dispatching subprogram# cannot use Stdcall convention!",
7982 -- Several allowed cases
7984 elsif Is_Subprogram_Or_Generic_Subprogram (E)
7988 or else Ekind (E) = E_Variable
7990 -- A component as well. The entity does not have its Ekind
7991 -- set until the enclosing record declaration is fully
7994 or else Nkind (Parent (E)) = N_Component_Declaration
7996 -- An access to subprogram is also allowed
8000 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
8002 -- Allow internal call to set convention of subprogram type
8004 or else Ekind (E) = E_Subprogram_Type
8010 ("second argument of pragma% must be subprogram (type)",
8015 -- Set the convention
8017 Set_Convention (E, C);
8018 Set_Has_Convention_Pragma (E);
8020 -- For the case of a record base type, also set the convention of
8021 -- any anonymous access types declared in the record which do not
8022 -- currently have a specified convention.
8023 -- Similarly for an array base type and anonymous access types
8026 if Is_Base_Type (E) then
8027 if Is_Record_Type (E) then
8032 Comp := First_Component (E);
8033 while Present (Comp) loop
8034 if Present (Etype (Comp))
8036 Ekind_In (Etype (Comp),
8037 E_Anonymous_Access_Type,
8038 E_Anonymous_Access_Subprogram_Type)
8039 and then not Has_Convention_Pragma (Comp)
8041 Set_Convention (Comp, C);
8044 Next_Component (Comp);
8048 elsif Is_Array_Type (E)
8049 and then Ekind_In (Component_Type (E),
8050 E_Anonymous_Access_Type,
8051 E_Anonymous_Access_Subprogram_Type)
8053 Set_Convention (Designated_Type (Component_Type (E)), C);
8057 -- Deal with incomplete/private type case, where underlying type
8058 -- is available, so set convention of that underlying type.
8060 if Is_Incomplete_Or_Private_Type (E)
8061 and then Present (Underlying_Type (E))
8063 Set_Convention (Underlying_Type (E), C);
8064 Set_Has_Convention_Pragma (Underlying_Type (E), True);
8067 -- A class-wide type should inherit the convention of the specific
8068 -- root type (although this isn't specified clearly by the RM).
8070 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
8071 Set_Convention (Class_Wide_Type (E), C);
8074 -- If the entity is a record type, then check for special case of
8075 -- C_Pass_By_Copy, which is treated the same as C except that the
8076 -- special record flag is set. This convention is only permitted
8077 -- on record types (see AI95-00131).
8079 if Cname = Name_C_Pass_By_Copy then
8080 if Is_Record_Type (E) then
8081 Set_C_Pass_By_Copy (Base_Type (E));
8082 elsif Is_Incomplete_Or_Private_Type (E)
8083 and then Is_Record_Type (Underlying_Type (E))
8085 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
8088 ("C_Pass_By_Copy convention allowed only for record type",
8093 -- If the entity is a derived boolean type, check for the special
8094 -- case of convention C, C++, or Fortran, where we consider any
8095 -- nonzero value to represent true.
8097 if Is_Discrete_Type (E)
8098 and then Root_Type (Etype (E)) = Standard_Boolean
8104 C = Convention_Fortran)
8106 Set_Nonzero_Is_True (Base_Type (E));
8108 end Set_Convention_From_Pragma;
8112 Comp_Unit : Unit_Number_Type;
8117 -- Start of processing for Process_Convention
8120 Check_At_Least_N_Arguments (2);
8121 Check_Optional_Identifier (Arg1, Name_Convention);
8122 Check_Arg_Is_Identifier (Arg1);
8123 Cname := Chars (Get_Pragma_Arg (Arg1));
8125 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
8126 -- tested again below to set the critical flag).
8128 if Cname = Name_C_Pass_By_Copy then
8131 -- Otherwise we must have something in the standard convention list
8133 elsif Is_Convention_Name (Cname) then
8134 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
8136 -- Otherwise warn on unrecognized convention
8139 if Warn_On_Export_Import then
8141 ("??unrecognized convention name, C assumed",
8142 Get_Pragma_Arg (Arg1));
8148 Check_Optional_Identifier (Arg2, Name_Entity);
8149 Check_Arg_Is_Local_Name (Arg2);
8151 Id := Get_Pragma_Arg (Arg2);
8154 if not Is_Entity_Name (Id) then
8155 Error_Pragma_Arg ("entity name required", Arg2);
8160 -- Set entity to return
8164 -- Ada_Pass_By_Copy special checking
8166 if C = Convention_Ada_Pass_By_Copy then
8167 if not Is_First_Subtype (E) then
8169 ("convention `Ada_Pass_By_Copy` only allowed for types",
8173 if Is_By_Reference_Type (E) then
8175 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
8179 -- Ada_Pass_By_Reference special checking
8181 elsif C = Convention_Ada_Pass_By_Reference then
8182 if not Is_First_Subtype (E) then
8184 ("convention `Ada_Pass_By_Reference` only allowed for types",
8188 if Is_By_Copy_Type (E) then
8190 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
8195 -- Go to renamed subprogram if present, since convention applies to
8196 -- the actual renamed entity, not to the renaming entity. If the
8197 -- subprogram is inherited, go to parent subprogram.
8199 if Is_Subprogram (E)
8200 and then Present (Alias (E))
8202 if Nkind (Parent (Declaration_Node (E))) =
8203 N_Subprogram_Renaming_Declaration
8205 if Scope (E) /= Scope (Alias (E)) then
8207 ("cannot apply pragma% to non-local entity&#", E);
8212 elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
8213 N_Private_Extension_Declaration)
8214 and then Scope (E) = Scope (Alias (E))
8218 -- Return the parent subprogram the entity was inherited from
8224 -- Check that we are not applying this to a specless body. Relax this
8225 -- check if Relaxed_RM_Semantics to accommodate other Ada compilers.
8227 if Is_Subprogram (E)
8228 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
8229 and then not Relaxed_RM_Semantics
8232 ("pragma% requires separate spec and must come before body");
8235 -- Check that we are not applying this to a named constant
8237 if Ekind_In (E, E_Named_Integer, E_Named_Real) then
8238 Error_Msg_Name_1 := Pname;
8240 ("cannot apply pragma% to named constant!",
8241 Get_Pragma_Arg (Arg2));
8243 ("\supply appropriate type for&!", Arg2);
8246 if Ekind (E) = E_Enumeration_Literal then
8247 Error_Pragma ("enumeration literal not allowed for pragma%");
8250 -- Check for rep item appearing too early or too late
8252 if Etype (E) = Any_Type
8253 or else Rep_Item_Too_Early (E, N)
8257 elsif Present (Underlying_Type (E)) then
8258 E := Underlying_Type (E);
8261 if Rep_Item_Too_Late (E, N) then
8265 if Has_Convention_Pragma (E) then
8266 Diagnose_Multiple_Pragmas (E);
8268 elsif Convention (E) = Convention_Protected
8269 or else Ekind (Scope (E)) = E_Protected_Type
8272 ("a protected operation cannot be given a different convention",
8276 -- For Intrinsic, a subprogram is required
8278 if C = Convention_Intrinsic
8279 and then not Is_Subprogram_Or_Generic_Subprogram (E)
8281 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
8283 if not (Is_Type (E) and then Relaxed_RM_Semantics) then
8285 ("second argument of pragma% must be a subprogram", Arg2);
8289 -- Deal with non-subprogram cases
8291 if not Is_Subprogram_Or_Generic_Subprogram (E) then
8292 Set_Convention_From_Pragma (E);
8296 -- The pragma must apply to a first subtype, but it can also
8297 -- apply to a generic type in a generic formal part, in which
8298 -- case it will also appear in the corresponding instance.
8300 if Is_Generic_Type (E) or else In_Instance then
8303 Check_First_Subtype (Arg2);
8306 Set_Convention_From_Pragma (Base_Type (E));
8308 -- For access subprograms, we must set the convention on the
8309 -- internally generated directly designated type as well.
8311 if Ekind (E) = E_Access_Subprogram_Type then
8312 Set_Convention_From_Pragma (Directly_Designated_Type (E));
8316 -- For the subprogram case, set proper convention for all homonyms
8317 -- in same scope and the same declarative part, i.e. the same
8318 -- compilation unit.
8321 Comp_Unit := Get_Source_Unit (E);
8322 Set_Convention_From_Pragma (E);
8324 -- Treat a pragma Import as an implicit body, and pragma import
8325 -- as implicit reference (for navigation in GNAT Studio).
8327 if Prag_Id = Pragma_Import then
8328 Generate_Reference (E, Id, 'b');
8330 -- For exported entities we restrict the generation of references
8331 -- to entities exported to foreign languages since entities
8332 -- exported to Ada do not provide further information to
8333 -- GNAT Studio and add undesired references to the output of the
8336 elsif Prag_Id = Pragma_Export
8337 and then Convention (E) /= Convention_Ada
8339 Generate_Reference (E, Id, 'i');
8342 -- If the pragma comes from an aspect, it only applies to the
8343 -- given entity, not its homonyms.
8345 if From_Aspect_Specification (N) then
8346 if C = Convention_Intrinsic
8347 and then Nkind (Ent) = N_Defining_Operator_Symbol
8349 if Is_Fixed_Point_Type (Etype (Ent))
8350 or else Is_Fixed_Point_Type (Etype (First_Entity (Ent)))
8351 or else Is_Fixed_Point_Type (Etype (Last_Entity (Ent)))
8354 ("no intrinsic operator available for this fixed-point "
8357 ("\use expression functions with the desired "
8358 & "conversions made explicit", N);
8365 -- Otherwise Loop through the homonyms of the pragma argument's
8366 -- entity, an apply convention to those in the current scope.
8372 exit when No (E1) or else Scope (E1) /= Current_Scope;
8374 -- Ignore entry for which convention is already set
8376 if Has_Convention_Pragma (E1) then
8380 if Is_Subprogram (E1)
8381 and then Nkind (Parent (Declaration_Node (E1))) =
8383 and then not Relaxed_RM_Semantics
8385 Set_Has_Completion (E); -- to prevent cascaded error
8387 ("pragma% requires separate spec and must come before "
8391 -- Do not set the pragma on inherited operations or on formal
8394 if Comes_From_Source (E1)
8395 and then Comp_Unit = Get_Source_Unit (E1)
8396 and then not Is_Formal_Subprogram (E1)
8397 and then Nkind (Original_Node (Parent (E1))) /=
8398 N_Full_Type_Declaration
8400 if Present (Alias (E1))
8401 and then Scope (E1) /= Scope (Alias (E1))
8404 ("cannot apply pragma% to non-local entity& declared#",
8408 Set_Convention_From_Pragma (E1);
8410 if Prag_Id = Pragma_Import then
8411 Generate_Reference (E1, Id, 'b');
8419 end Process_Convention;
8421 ----------------------------------------
8422 -- Process_Disable_Enable_Atomic_Sync --
8423 ----------------------------------------
8425 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
8427 Check_No_Identifiers;
8428 Check_At_Most_N_Arguments (1);
8430 -- Modeled internally as
8431 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
8436 Pragma_Argument_Associations => New_List (
8437 Make_Pragma_Argument_Association (Loc,
8439 Make_Identifier (Loc, Name_Atomic_Synchronization)))));
8441 if Present (Arg1) then
8442 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
8446 end Process_Disable_Enable_Atomic_Sync;
8448 -------------------------------------------------
8449 -- Process_Extended_Import_Export_Internal_Arg --
8450 -------------------------------------------------
8452 procedure Process_Extended_Import_Export_Internal_Arg
8453 (Arg_Internal : Node_Id := Empty)
8456 if No (Arg_Internal) then
8457 Error_Pragma ("Internal parameter required for pragma%");
8460 if Nkind (Arg_Internal) = N_Identifier then
8463 elsif Nkind (Arg_Internal) = N_Operator_Symbol
8464 and then (Prag_Id = Pragma_Import_Function
8466 Prag_Id = Pragma_Export_Function)
8472 ("wrong form for Internal parameter for pragma%", Arg_Internal);
8475 Check_Arg_Is_Local_Name (Arg_Internal);
8476 end Process_Extended_Import_Export_Internal_Arg;
8478 --------------------------------------------------
8479 -- Process_Extended_Import_Export_Object_Pragma --
8480 --------------------------------------------------
8482 procedure Process_Extended_Import_Export_Object_Pragma
8483 (Arg_Internal : Node_Id;
8484 Arg_External : Node_Id;
8490 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
8491 Def_Id := Entity (Arg_Internal);
8493 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
8495 ("pragma% must designate an object", Arg_Internal);
8498 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
8500 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
8503 ("previous Common/Psect_Object applies, pragma % not permitted",
8507 if Rep_Item_Too_Late (Def_Id, N) then
8511 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
8513 if Present (Arg_Size) then
8514 Check_Arg_Is_External_Name (Arg_Size);
8517 -- Export_Object case
8519 if Prag_Id = Pragma_Export_Object then
8520 if not Is_Library_Level_Entity (Def_Id) then
8522 ("argument for pragma% must be library level entity",
8526 if Ekind (Current_Scope) = E_Generic_Package then
8527 Error_Pragma ("pragma& cannot appear in a generic unit");
8530 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
8532 ("exported object must have compile time known size",
8536 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
8537 Error_Msg_N ("??duplicate Export_Object pragma", N);
8539 Set_Exported (Def_Id, Arg_Internal);
8542 -- Import_Object case
8545 if Is_Concurrent_Type (Etype (Def_Id)) then
8547 ("cannot use pragma% for task/protected object",
8551 if Ekind (Def_Id) = E_Constant then
8553 ("cannot import a constant", Arg_Internal);
8556 if Warn_On_Export_Import
8557 and then Has_Discriminants (Etype (Def_Id))
8560 ("imported value must be initialized??", Arg_Internal);
8563 if Warn_On_Export_Import
8564 and then Is_Access_Type (Etype (Def_Id))
8567 ("cannot import object of an access type??", Arg_Internal);
8570 if Warn_On_Export_Import
8571 and then Is_Imported (Def_Id)
8573 Error_Msg_N ("??duplicate Import_Object pragma", N);
8575 -- Check for explicit initialization present. Note that an
8576 -- initialization generated by the code generator, e.g. for an
8577 -- access type, does not count here.
8579 elsif Present (Expression (Parent (Def_Id)))
8582 (Original_Node (Expression (Parent (Def_Id))))
8584 Error_Msg_Sloc := Sloc (Def_Id);
8586 ("imported entities cannot be initialized (RM B.1(24))",
8587 "\no initialization allowed for & declared#", Arg1);
8589 Set_Imported (Def_Id);
8590 Note_Possible_Modification (Arg_Internal, Sure => False);
8593 end Process_Extended_Import_Export_Object_Pragma;
8595 ------------------------------------------------------
8596 -- Process_Extended_Import_Export_Subprogram_Pragma --
8597 ------------------------------------------------------
8599 procedure Process_Extended_Import_Export_Subprogram_Pragma
8600 (Arg_Internal : Node_Id;
8601 Arg_External : Node_Id;
8602 Arg_Parameter_Types : Node_Id;
8603 Arg_Result_Type : Node_Id := Empty;
8604 Arg_Mechanism : Node_Id;
8605 Arg_Result_Mechanism : Node_Id := Empty)
8611 Ambiguous : Boolean;
8614 function Same_Base_Type
8616 Formal : Entity_Id) return Boolean;
8617 -- Determines if Ptype references the type of Formal. Note that only
8618 -- the base types need to match according to the spec. Ptype here is
8619 -- the argument from the pragma, which is either a type name, or an
8620 -- access attribute.
8622 --------------------
8623 -- Same_Base_Type --
8624 --------------------
8626 function Same_Base_Type
8628 Formal : Entity_Id) return Boolean
8630 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
8634 -- Case where pragma argument is typ'Access
8636 if Nkind (Ptype) = N_Attribute_Reference
8637 and then Attribute_Name (Ptype) = Name_Access
8639 Pref := Prefix (Ptype);
8642 if not Is_Entity_Name (Pref)
8643 or else Entity (Pref) = Any_Type
8648 -- We have a match if the corresponding argument is of an
8649 -- anonymous access type, and its designated type matches the
8650 -- type of the prefix of the access attribute
8652 return Ekind (Ftyp) = E_Anonymous_Access_Type
8653 and then Base_Type (Entity (Pref)) =
8654 Base_Type (Etype (Designated_Type (Ftyp)));
8656 -- Case where pragma argument is a type name
8661 if not Is_Entity_Name (Ptype)
8662 or else Entity (Ptype) = Any_Type
8667 -- We have a match if the corresponding argument is of the type
8668 -- given in the pragma (comparing base types)
8670 return Base_Type (Entity (Ptype)) = Ftyp;
8674 -- Start of processing for
8675 -- Process_Extended_Import_Export_Subprogram_Pragma
8678 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
8682 -- Loop through homonyms (overloadings) of the entity
8684 Hom_Id := Entity (Arg_Internal);
8685 while Present (Hom_Id) loop
8686 Def_Id := Get_Base_Subprogram (Hom_Id);
8688 -- We need a subprogram in the current scope
8690 if not Is_Subprogram (Def_Id)
8691 or else Scope (Def_Id) /= Current_Scope
8698 -- Pragma cannot apply to subprogram body
8700 if Is_Subprogram (Def_Id)
8701 and then Nkind (Parent (Declaration_Node (Def_Id))) =
8705 ("pragma% requires separate spec and must come before "
8709 -- Test result type if given, note that the result type
8710 -- parameter can only be present for the function cases.
8712 if Present (Arg_Result_Type)
8713 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
8717 elsif Etype (Def_Id) /= Standard_Void_Type
8718 and then Nam_In (Pname, Name_Export_Procedure,
8719 Name_Import_Procedure)
8723 -- Test parameter types if given. Note that this parameter has
8724 -- not been analyzed (and must not be, since it is semantic
8725 -- nonsense), so we get it as the parser left it.
8727 elsif Present (Arg_Parameter_Types) then
8728 Check_Matching_Types : declare
8733 Formal := First_Formal (Def_Id);
8735 if Nkind (Arg_Parameter_Types) = N_Null then
8736 if Present (Formal) then
8740 -- A list of one type, e.g. (List) is parsed as a
8741 -- parenthesized expression.
8743 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
8744 and then Paren_Count (Arg_Parameter_Types) = 1
8747 or else Present (Next_Formal (Formal))
8752 Same_Base_Type (Arg_Parameter_Types, Formal);
8755 -- A list of more than one type is parsed as a aggregate
8757 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
8758 and then Paren_Count (Arg_Parameter_Types) = 0
8760 Ptype := First (Expressions (Arg_Parameter_Types));
8761 while Present (Ptype) or else Present (Formal) loop
8764 or else not Same_Base_Type (Ptype, Formal)
8769 Next_Formal (Formal);
8774 -- Anything else is of the wrong form
8778 ("wrong form for Parameter_Types parameter",
8779 Arg_Parameter_Types);
8781 end Check_Matching_Types;
8784 -- Match is now False if the entry we found did not match
8785 -- either a supplied Parameter_Types or Result_Types argument
8791 -- Ambiguous case, the flag Ambiguous shows if we already
8792 -- detected this and output the initial messages.
8795 if not Ambiguous then
8797 Error_Msg_Name_1 := Pname;
8799 ("pragma% does not uniquely identify subprogram!",
8801 Error_Msg_Sloc := Sloc (Ent);
8802 Error_Msg_N ("matching subprogram #!", N);
8806 Error_Msg_Sloc := Sloc (Def_Id);
8807 Error_Msg_N ("matching subprogram #!", N);
8812 Hom_Id := Homonym (Hom_Id);
8815 -- See if we found an entry
8818 if not Ambiguous then
8819 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
8821 ("pragma% cannot be given for generic subprogram");
8824 ("pragma% does not identify local subprogram");
8831 -- Import pragmas must be for imported entities
8833 if Prag_Id = Pragma_Import_Function
8835 Prag_Id = Pragma_Import_Procedure
8837 Prag_Id = Pragma_Import_Valued_Procedure
8839 if not Is_Imported (Ent) then
8841 ("pragma Import or Interface must precede pragma%");
8844 -- Here we have the Export case which can set the entity as exported
8846 -- But does not do so if the specified external name is null, since
8847 -- that is taken as a signal in DEC Ada 83 (with which we want to be
8848 -- compatible) to request no external name.
8850 elsif Nkind (Arg_External) = N_String_Literal
8851 and then String_Length (Strval (Arg_External)) = 0
8855 -- In all other cases, set entity as exported
8858 Set_Exported (Ent, Arg_Internal);
8861 -- Special processing for Valued_Procedure cases
8863 if Prag_Id = Pragma_Import_Valued_Procedure
8865 Prag_Id = Pragma_Export_Valued_Procedure
8867 Formal := First_Formal (Ent);
8870 Error_Pragma ("at least one parameter required for pragma%");
8872 elsif Ekind (Formal) /= E_Out_Parameter then
8873 Error_Pragma ("first parameter must have mode out for pragma%");
8876 Set_Is_Valued_Procedure (Ent);
8880 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
8882 -- Process Result_Mechanism argument if present. We have already
8883 -- checked that this is only allowed for the function case.
8885 if Present (Arg_Result_Mechanism) then
8886 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
8889 -- Process Mechanism parameter if present. Note that this parameter
8890 -- is not analyzed, and must not be analyzed since it is semantic
8891 -- nonsense, so we get it in exactly as the parser left it.
8893 if Present (Arg_Mechanism) then
8901 -- A single mechanism association without a formal parameter
8902 -- name is parsed as a parenthesized expression. All other
8903 -- cases are parsed as aggregates, so we rewrite the single
8904 -- parameter case as an aggregate for consistency.
8906 if Nkind (Arg_Mechanism) /= N_Aggregate
8907 and then Paren_Count (Arg_Mechanism) = 1
8909 Rewrite (Arg_Mechanism,
8910 Make_Aggregate (Sloc (Arg_Mechanism),
8911 Expressions => New_List (
8912 Relocate_Node (Arg_Mechanism))));
8915 -- Case of only mechanism name given, applies to all formals
8917 if Nkind (Arg_Mechanism) /= N_Aggregate then
8918 Formal := First_Formal (Ent);
8919 while Present (Formal) loop
8920 Set_Mechanism_Value (Formal, Arg_Mechanism);
8921 Next_Formal (Formal);
8924 -- Case of list of mechanism associations given
8927 if Null_Record_Present (Arg_Mechanism) then
8929 ("inappropriate form for Mechanism parameter",
8933 -- Deal with positional ones first
8935 Formal := First_Formal (Ent);
8937 if Present (Expressions (Arg_Mechanism)) then
8938 Mname := First (Expressions (Arg_Mechanism));
8939 while Present (Mname) loop
8942 ("too many mechanism associations", Mname);
8945 Set_Mechanism_Value (Formal, Mname);
8946 Next_Formal (Formal);
8951 -- Deal with named entries
8953 if Present (Component_Associations (Arg_Mechanism)) then
8954 Massoc := First (Component_Associations (Arg_Mechanism));
8955 while Present (Massoc) loop
8956 Choice := First (Choices (Massoc));
8958 if Nkind (Choice) /= N_Identifier
8959 or else Present (Next (Choice))
8962 ("incorrect form for mechanism association",
8966 Formal := First_Formal (Ent);
8970 ("parameter name & not present", Choice);
8973 if Chars (Choice) = Chars (Formal) then
8975 (Formal, Expression (Massoc));
8977 -- Set entity on identifier for proper tree
8980 Set_Entity (Choice, Formal);
8985 Next_Formal (Formal);
8994 end Process_Extended_Import_Export_Subprogram_Pragma;
8996 --------------------------
8997 -- Process_Generic_List --
8998 --------------------------
9000 procedure Process_Generic_List is
9005 Check_No_Identifiers;
9006 Check_At_Least_N_Arguments (1);
9008 -- Check all arguments are names of generic units or instances
9011 while Present (Arg) loop
9012 Exp := Get_Pragma_Arg (Arg);
9015 if not Is_Entity_Name (Exp)
9017 (not Is_Generic_Instance (Entity (Exp))
9019 not Is_Generic_Unit (Entity (Exp)))
9022 ("pragma% argument must be name of generic unit/instance",
9028 end Process_Generic_List;
9030 ------------------------------------
9031 -- Process_Import_Predefined_Type --
9032 ------------------------------------
9034 procedure Process_Import_Predefined_Type is
9035 Loc : constant Source_Ptr := Sloc (N);
9037 Ftyp : Node_Id := Empty;
9043 Nam := String_To_Name (Strval (Expression (Arg3)));
9045 Elmt := First_Elmt (Predefined_Float_Types);
9046 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
9050 Ftyp := Node (Elmt);
9052 if Present (Ftyp) then
9054 -- Don't build a derived type declaration, because predefined C
9055 -- types have no declaration anywhere, so cannot really be named.
9056 -- Instead build a full type declaration, starting with an
9057 -- appropriate type definition is built
9059 if Is_Floating_Point_Type (Ftyp) then
9060 Def := Make_Floating_Point_Definition (Loc,
9061 Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
9062 Make_Real_Range_Specification (Loc,
9063 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
9064 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
9066 -- Should never have a predefined type we cannot handle
9069 raise Program_Error;
9072 -- Build and insert a Full_Type_Declaration, which will be
9073 -- analyzed as soon as this list entry has been analyzed.
9075 Decl := Make_Full_Type_Declaration (Loc,
9076 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
9077 Type_Definition => Def);
9079 Insert_After (N, Decl);
9080 Mark_Rewrite_Insertion (Decl);
9083 Error_Pragma_Arg ("no matching type found for pragma%", Arg2);
9085 end Process_Import_Predefined_Type;
9087 ---------------------------------
9088 -- Process_Import_Or_Interface --
9089 ---------------------------------
9091 procedure Process_Import_Or_Interface is
9097 -- In Relaxed_RM_Semantics, support old Ada 83 style:
9098 -- pragma Import (Entity, "external name");
9100 if Relaxed_RM_Semantics
9101 and then Arg_Count = 2
9102 and then Prag_Id = Pragma_Import
9103 and then Nkind (Expression (Arg2)) = N_String_Literal
9106 Def_Id := Get_Pragma_Arg (Arg1);
9109 if not Is_Entity_Name (Def_Id) then
9110 Error_Pragma_Arg ("entity name required", Arg1);
9113 Def_Id := Entity (Def_Id);
9114 Kill_Size_Check_Code (Def_Id);
9115 Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False);
9118 Process_Convention (C, Def_Id);
9120 -- A pragma that applies to a Ghost entity becomes Ghost for the
9121 -- purposes of legality checks and removal of ignored Ghost code.
9123 Mark_Ghost_Pragma (N, Def_Id);
9124 Kill_Size_Check_Code (Def_Id);
9125 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
9128 -- Various error checks
9130 if Ekind_In (Def_Id, E_Variable, E_Constant) then
9132 -- We do not permit Import to apply to a renaming declaration
9134 if Present (Renamed_Object (Def_Id)) then
9136 ("pragma% not allowed for object renaming", Arg2);
9138 -- User initialization is not allowed for imported object, but
9139 -- the object declaration may contain a default initialization,
9140 -- that will be discarded. Note that an explicit initialization
9141 -- only counts if it comes from source, otherwise it is simply
9142 -- the code generator making an implicit initialization explicit.
9144 elsif Present (Expression (Parent (Def_Id)))
9145 and then Comes_From_Source
9146 (Original_Node (Expression (Parent (Def_Id))))
9148 -- Set imported flag to prevent cascaded errors
9150 Set_Is_Imported (Def_Id);
9152 Error_Msg_Sloc := Sloc (Def_Id);
9154 ("no initialization allowed for declaration of& #",
9155 "\imported entities cannot be initialized (RM B.1(24))",
9159 -- If the pragma comes from an aspect specification the
9160 -- Is_Imported flag has already been set.
9162 if not From_Aspect_Specification (N) then
9163 Set_Imported (Def_Id);
9166 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
9168 -- Note that we do not set Is_Public here. That's because we
9169 -- only want to set it if there is no address clause, and we
9170 -- don't know that yet, so we delay that processing till
9173 -- pragma Import completes deferred constants
9175 if Ekind (Def_Id) = E_Constant then
9176 Set_Has_Completion (Def_Id);
9179 -- It is not possible to import a constant of an unconstrained
9180 -- array type (e.g. string) because there is no simple way to
9181 -- write a meaningful subtype for it.
9183 if Is_Array_Type (Etype (Def_Id))
9184 and then not Is_Constrained (Etype (Def_Id))
9187 ("imported constant& must have a constrained subtype",
9192 elsif Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
9194 -- If the name is overloaded, pragma applies to all of the denoted
9195 -- entities in the same declarative part, unless the pragma comes
9196 -- from an aspect specification or was generated by the compiler
9197 -- (such as for pragma Provide_Shift_Operators).
9200 while Present (Hom_Id) loop
9202 Def_Id := Get_Base_Subprogram (Hom_Id);
9204 -- Ignore inherited subprograms because the pragma will apply
9205 -- to the parent operation, which is the one called.
9207 if Is_Overloadable (Def_Id)
9208 and then Present (Alias (Def_Id))
9212 -- If it is not a subprogram, it must be in an outer scope and
9213 -- pragma does not apply.
9215 elsif not Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
9218 -- The pragma does not apply to primitives of interfaces
9220 elsif Is_Dispatching_Operation (Def_Id)
9221 and then Present (Find_Dispatching_Type (Def_Id))
9222 and then Is_Interface (Find_Dispatching_Type (Def_Id))
9226 -- Verify that the homonym is in the same declarative part (not
9227 -- just the same scope). If the pragma comes from an aspect
9228 -- specification we know that it is part of the declaration.
9230 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
9231 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
9232 and then not From_Aspect_Specification (N)
9237 -- If the pragma comes from an aspect specification the
9238 -- Is_Imported flag has already been set.
9240 if not From_Aspect_Specification (N) then
9241 Set_Imported (Def_Id);
9244 -- Reject an Import applied to an abstract subprogram
9246 if Is_Subprogram (Def_Id)
9247 and then Is_Abstract_Subprogram (Def_Id)
9249 Error_Msg_Sloc := Sloc (Def_Id);
9251 ("cannot import abstract subprogram& declared#",
9255 -- Special processing for Convention_Intrinsic
9257 if C = Convention_Intrinsic then
9259 -- Link_Name argument not allowed for intrinsic
9263 Set_Is_Intrinsic_Subprogram (Def_Id);
9265 -- If no external name is present, then check that this
9266 -- is a valid intrinsic subprogram. If an external name
9267 -- is present, then this is handled by the back end.
9270 Check_Intrinsic_Subprogram
9271 (Def_Id, Get_Pragma_Arg (Arg2));
9275 -- Verify that the subprogram does not have a completion
9276 -- through a renaming declaration. For other completions the
9277 -- pragma appears as a too late representation.
9280 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
9284 and then Nkind (Decl) = N_Subprogram_Declaration
9285 and then Present (Corresponding_Body (Decl))
9286 and then Nkind (Unit_Declaration_Node
9287 (Corresponding_Body (Decl))) =
9288 N_Subprogram_Renaming_Declaration
9290 Error_Msg_Sloc := Sloc (Def_Id);
9292 ("cannot import&, renaming already provided for "
9293 & "declaration #", N, Def_Id);
9297 -- If the pragma comes from an aspect specification, there
9298 -- must be an Import aspect specified as well. In the rare
9299 -- case where Import is set to False, the suprogram needs to
9300 -- have a local completion.
9303 Imp_Aspect : constant Node_Id :=
9304 Find_Aspect (Def_Id, Aspect_Import);
9308 if Present (Imp_Aspect)
9309 and then Present (Expression (Imp_Aspect))
9311 Expr := Expression (Imp_Aspect);
9312 Analyze_And_Resolve (Expr, Standard_Boolean);
9314 if Is_Entity_Name (Expr)
9315 and then Entity (Expr) = Standard_True
9317 Set_Has_Completion (Def_Id);
9320 -- If there is no expression, the default is True, as for
9321 -- all boolean aspects. Same for the older pragma.
9324 Set_Has_Completion (Def_Id);
9328 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
9331 if Is_Compilation_Unit (Hom_Id) then
9333 -- Its possible homonyms are not affected by the pragma.
9334 -- Such homonyms might be present in the context of other
9335 -- units being compiled.
9339 elsif From_Aspect_Specification (N) then
9342 -- If the pragma was created by the compiler, then we don't
9343 -- want it to apply to other homonyms. This kind of case can
9344 -- occur when using pragma Provide_Shift_Operators, which
9345 -- generates implicit shift and rotate operators with Import
9346 -- pragmas that might apply to earlier explicit or implicit
9347 -- declarations marked with Import (for example, coming from
9348 -- an earlier pragma Provide_Shift_Operators for another type),
9349 -- and we don't generally want other homonyms being treated
9350 -- as imported or the pragma flagged as an illegal duplicate.
9352 elsif not Comes_From_Source (N) then
9356 Hom_Id := Homonym (Hom_Id);
9360 -- Import a CPP class
9362 elsif C = Convention_CPP
9363 and then (Is_Record_Type (Def_Id)
9364 or else Ekind (Def_Id) = E_Incomplete_Type)
9366 if Ekind (Def_Id) = E_Incomplete_Type then
9367 if Present (Full_View (Def_Id)) then
9368 Def_Id := Full_View (Def_Id);
9372 ("cannot import 'C'P'P type before full declaration seen",
9373 Get_Pragma_Arg (Arg2));
9375 -- Although we have reported the error we decorate it as
9376 -- CPP_Class to avoid reporting spurious errors
9378 Set_Is_CPP_Class (Def_Id);
9383 -- Types treated as CPP classes must be declared limited (note:
9384 -- this used to be a warning but there is no real benefit to it
9385 -- since we did effectively intend to treat the type as limited
9388 if not Is_Limited_Type (Def_Id) then
9390 ("imported 'C'P'P type must be limited",
9391 Get_Pragma_Arg (Arg2));
9394 if Etype (Def_Id) /= Def_Id
9395 and then not Is_CPP_Class (Root_Type (Def_Id))
9397 Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
9400 Set_Is_CPP_Class (Def_Id);
9402 -- Imported CPP types must not have discriminants (because C++
9403 -- classes do not have discriminants).
9405 if Has_Discriminants (Def_Id) then
9407 ("imported 'C'P'P type cannot have discriminants",
9408 First (Discriminant_Specifications
9409 (Declaration_Node (Def_Id))));
9412 -- Check that components of imported CPP types do not have default
9413 -- expressions. For private types this check is performed when the
9414 -- full view is analyzed (see Process_Full_View).
9416 if not Is_Private_Type (Def_Id) then
9417 Check_CPP_Type_Has_No_Defaults (Def_Id);
9420 -- Import a CPP exception
9422 elsif C = Convention_CPP
9423 and then Ekind (Def_Id) = E_Exception
9427 ("'External_'Name arguments is required for 'Cpp exception",
9430 -- As only a string is allowed, Check_Arg_Is_External_Name
9433 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
9436 if Present (Arg4) then
9438 ("Link_Name argument not allowed for imported Cpp exception",
9442 -- Do not call Set_Interface_Name as the name of the exception
9443 -- shouldn't be modified (and in particular it shouldn't be
9444 -- the External_Name). For exceptions, the External_Name is the
9445 -- name of the RTTI structure.
9447 -- ??? Emit an error if pragma Import/Export_Exception is present
9449 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
9451 Check_Arg_Count (3);
9452 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
9454 Process_Import_Predefined_Type;
9458 ("second argument of pragma% must be object, subprogram "
9459 & "or incomplete type",
9463 -- If this pragma applies to a compilation unit, then the unit, which
9464 -- is a subprogram, does not require (or allow) a body. We also do
9465 -- not need to elaborate imported procedures.
9467 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
9469 Cunit : constant Node_Id := Parent (Parent (N));
9471 Set_Body_Required (Cunit, False);
9474 end Process_Import_Or_Interface;
9476 --------------------
9477 -- Process_Inline --
9478 --------------------
9480 procedure Process_Inline (Status : Inline_Status) is
9487 Ghost_Error_Posted : Boolean := False;
9488 -- Flag set when an error concerning the illegal mix of Ghost and
9489 -- non-Ghost subprograms is emitted.
9491 Ghost_Id : Entity_Id := Empty;
9492 -- The entity of the first Ghost subprogram encountered while
9493 -- processing the arguments of the pragma.
9495 procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id);
9496 -- Verify the placement of pragma Inline_Always with respect to the
9497 -- initial declaration of subprogram Spec_Id.
9499 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
9500 -- Returns True if it can be determined at this stage that inlining
9501 -- is not possible, for example if the body is available and contains
9502 -- exception handlers, we prevent inlining, since otherwise we can
9503 -- get undefined symbols at link time. This function also emits a
9504 -- warning if the pragma appears too late.
9506 -- ??? is business with link symbols still valid, or does it relate
9507 -- to front end ZCX which is being phased out ???
9509 procedure Make_Inline (Subp : Entity_Id);
9510 -- Subp is the defining unit name of the subprogram declaration. If
9511 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
9512 -- the corresponding body, if there is one present.
9514 procedure Set_Inline_Flags (Subp : Entity_Id);
9515 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
9516 -- Also set or clear Is_Inlined flag on Subp depending on Status.
9518 -----------------------------------
9519 -- Check_Inline_Always_Placement --
9520 -----------------------------------
9522 procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id) is
9523 Spec_Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
9525 function Compilation_Unit_OK return Boolean;
9526 pragma Inline (Compilation_Unit_OK);
9527 -- Determine whether pragma Inline_Always applies to a compatible
9528 -- compilation unit denoted by Spec_Id.
9530 function Declarative_List_OK return Boolean;
9531 pragma Inline (Declarative_List_OK);
9532 -- Determine whether the initial declaration of subprogram Spec_Id
9533 -- and the pragma appear in compatible declarative lists.
9535 function Subprogram_Body_OK return Boolean;
9536 pragma Inline (Subprogram_Body_OK);
9537 -- Determine whether pragma Inline_Always applies to a compatible
9538 -- subprogram body denoted by Spec_Id.
9540 -------------------------
9541 -- Compilation_Unit_OK --
9542 -------------------------
9544 function Compilation_Unit_OK return Boolean is
9545 Comp_Unit : constant Node_Id := Parent (Spec_Decl);
9548 -- The pragma appears after the initial declaration of a
9549 -- compilation unit.
9551 -- procedure Comp_Unit;
9552 -- pragma Inline_Always (Comp_Unit);
9554 -- Note that for compatibility reasons, the following case is
9557 -- procedure Stand_Alone_Body_Comp_Unit is
9559 -- end Stand_Alone_Body_Comp_Unit;
9560 -- pragma Inline_Always (Stand_Alone_Body_Comp_Unit);
9563 Nkind (Comp_Unit) = N_Compilation_Unit
9564 and then Present (Aux_Decls_Node (Comp_Unit))
9565 and then Is_List_Member (N)
9566 and then List_Containing (N) =
9567 Pragmas_After (Aux_Decls_Node (Comp_Unit));
9568 end Compilation_Unit_OK;
9570 -------------------------
9571 -- Declarative_List_OK --
9572 -------------------------
9574 function Declarative_List_OK return Boolean is
9575 Context : constant Node_Id := Parent (Spec_Decl);
9577 Init_Decl : Node_Id;
9578 Init_List : List_Id;
9579 Prag_List : List_Id;
9582 -- Determine the proper initial declaration. In general this is
9583 -- the declaration node of the subprogram except when the input
9584 -- denotes a generic instantiation.
9586 -- procedure Inst is new Gen;
9587 -- pragma Inline_Always (Inst);
9589 -- In this case the original subprogram is moved inside an
9590 -- anonymous package while pragma Inline_Always remains at the
9591 -- level of the anonymous package. Use the declaration of the
9592 -- package because it reflects the placement of the original
9595 -- package Anon_Pack is
9596 -- procedure Inst is ... end Inst; -- original
9599 -- procedure Inst renames Anon_Pack.Inst;
9600 -- pragma Inline_Always (Inst);
9602 if Is_Generic_Instance (Spec_Id) then
9603 Init_Decl := Parent (Parent (Spec_Decl));
9604 pragma Assert (Nkind (Init_Decl) = N_Package_Declaration);
9606 Init_Decl := Spec_Decl;
9609 if Is_List_Member (Init_Decl) and then Is_List_Member (N) then
9610 Init_List := List_Containing (Init_Decl);
9611 Prag_List := List_Containing (N);
9613 -- The pragma and then initial declaration appear within the
9614 -- same declarative list.
9616 if Init_List = Prag_List then
9619 -- A special case of the above is when both the pragma and
9620 -- the initial declaration appear in different lists of a
9621 -- package spec, protected definition, or a task definition.
9626 -- pragma Inline_Always (Proc);
9629 elsif Nkind_In (Context, N_Package_Specification,
9630 N_Protected_Definition,
9632 and then Init_List = Visible_Declarations (Context)
9633 and then Prag_List = Private_Declarations (Context)
9640 end Declarative_List_OK;
9642 ------------------------
9643 -- Subprogram_Body_OK --
9644 ------------------------
9646 function Subprogram_Body_OK return Boolean is
9647 Body_Decl : Node_Id;
9650 -- The pragma appears within the declarative list of a stand-
9651 -- alone subprogram body.
9653 -- procedure Stand_Alone_Body is
9654 -- pragma Inline_Always (Stand_Alone_Body);
9657 -- end Stand_Alone_Body;
9659 -- The compiler creates a dummy spec in this case, however the
9660 -- pragma remains within the declarative list of the body.
9662 if Nkind (Spec_Decl) = N_Subprogram_Declaration
9663 and then not Comes_From_Source (Spec_Decl)
9664 and then Present (Corresponding_Body (Spec_Decl))
9667 Unit_Declaration_Node (Corresponding_Body (Spec_Decl));
9669 if Present (Declarations (Body_Decl))
9670 and then Is_List_Member (N)
9671 and then List_Containing (N) = Declarations (Body_Decl)
9678 end Subprogram_Body_OK;
9680 -- Start of processing for Check_Inline_Always_Placement
9683 -- This check is relevant only for pragma Inline_Always
9685 if Pname /= Name_Inline_Always then
9688 -- Nothing to do when the pragma is internally generated on the
9689 -- assumption that it is properly placed.
9691 elsif not Comes_From_Source (N) then
9694 -- Nothing to do for internally generated subprograms that act
9695 -- as accidental homonyms of a source subprogram being inlined.
9697 elsif not Comes_From_Source (Spec_Id) then
9700 -- Nothing to do for generic formal subprograms that act as
9701 -- homonyms of another source subprogram being inlined.
9703 elsif Is_Formal_Subprogram (Spec_Id) then
9706 elsif Compilation_Unit_OK
9707 or else Declarative_List_OK
9708 or else Subprogram_Body_OK
9713 -- At this point it is known that the pragma applies to or appears
9714 -- within a completing body, a completing stub, or a subunit.
9716 Error_Msg_Name_1 := Pname;
9717 Error_Msg_Name_2 := Chars (Spec_Id);
9718 Error_Msg_Sloc := Sloc (Spec_Id);
9721 ("pragma % must appear on initial declaration of subprogram "
9722 & "% defined #", N);
9723 end Check_Inline_Always_Placement;
9725 ---------------------------
9726 -- Inlining_Not_Possible --
9727 ---------------------------
9729 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
9730 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
9734 if Nkind (Decl) = N_Subprogram_Body then
9735 Stats := Handled_Statement_Sequence (Decl);
9736 return Present (Exception_Handlers (Stats))
9737 or else Present (At_End_Proc (Stats));
9739 elsif Nkind (Decl) = N_Subprogram_Declaration
9740 and then Present (Corresponding_Body (Decl))
9742 if Analyzed (Corresponding_Body (Decl)) then
9743 Error_Msg_N ("pragma appears too late, ignored??", N);
9746 -- If the subprogram is a renaming as body, the body is just a
9747 -- call to the renamed subprogram, and inlining is trivially
9751 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
9752 N_Subprogram_Renaming_Declaration
9758 Handled_Statement_Sequence
9759 (Unit_Declaration_Node (Corresponding_Body (Decl)));
9762 Present (Exception_Handlers (Stats))
9763 or else Present (At_End_Proc (Stats));
9767 -- If body is not available, assume the best, the check is
9768 -- performed again when compiling enclosing package bodies.
9772 end Inlining_Not_Possible;
9778 procedure Make_Inline (Subp : Entity_Id) is
9779 Kind : constant Entity_Kind := Ekind (Subp);
9780 Inner_Subp : Entity_Id := Subp;
9783 -- Ignore if bad type, avoid cascaded error
9785 if Etype (Subp) = Any_Type then
9789 -- If inlining is not possible, for now do not treat as an error
9791 elsif Status /= Suppressed
9792 and then Front_End_Inlining
9793 and then Inlining_Not_Possible (Subp)
9798 -- Here we have a candidate for inlining, but we must exclude
9799 -- derived operations. Otherwise we would end up trying to inline
9800 -- a phantom declaration, and the result would be to drag in a
9801 -- body which has no direct inlining associated with it. That
9802 -- would not only be inefficient but would also result in the
9803 -- backend doing cross-unit inlining in cases where it was
9804 -- definitely inappropriate to do so.
9806 -- However, a simple Comes_From_Source test is insufficient, since
9807 -- we do want to allow inlining of generic instances which also do
9808 -- not come from source. We also need to recognize specs generated
9809 -- by the front-end for bodies that carry the pragma. Finally,
9810 -- predefined operators do not come from source but are not
9811 -- inlineable either.
9813 elsif Is_Generic_Instance (Subp)
9814 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
9818 elsif not Comes_From_Source (Subp)
9819 and then Scope (Subp) /= Standard_Standard
9825 -- The referenced entity must either be the enclosing entity, or
9826 -- an entity declared within the current open scope.
9828 if Present (Scope (Subp))
9829 and then Scope (Subp) /= Current_Scope
9830 and then Subp /= Current_Scope
9833 ("argument of% must be entity in current scope", Assoc);
9837 -- Processing for procedure, operator or function. If subprogram
9838 -- is aliased (as for an instance) indicate that the renamed
9839 -- entity (if declared in the same unit) is inlined.
9840 -- If this is the anonymous subprogram created for a subprogram
9841 -- instance, the inlining applies to it directly. Otherwise we
9842 -- retrieve it as the alias of the visible subprogram instance.
9844 if Is_Subprogram (Subp) then
9846 -- Ensure that pragma Inline_Always is associated with the
9847 -- initial declaration of the subprogram.
9849 Check_Inline_Always_Placement (Subp);
9851 if Is_Wrapper_Package (Scope (Subp)) then
9854 Inner_Subp := Ultimate_Alias (Inner_Subp);
9857 if In_Same_Source_Unit (Subp, Inner_Subp) then
9858 Set_Inline_Flags (Inner_Subp);
9860 Decl := Parent (Parent (Inner_Subp));
9862 if Nkind (Decl) = N_Subprogram_Declaration
9863 and then Present (Corresponding_Body (Decl))
9865 Set_Inline_Flags (Corresponding_Body (Decl));
9867 elsif Is_Generic_Instance (Subp)
9868 and then Comes_From_Source (Subp)
9870 -- Indicate that the body needs to be created for
9871 -- inlining subsequent calls. The instantiation node
9872 -- follows the declaration of the wrapper package
9873 -- created for it. The subprogram that requires the
9874 -- body is the anonymous one in the wrapper package.
9876 if Scope (Subp) /= Standard_Standard
9878 Need_Subprogram_Instance_Body
9879 (Next (Unit_Declaration_Node
9880 (Scope (Alias (Subp)))), Subp)
9885 -- Inline is a program unit pragma (RM 10.1.5) and cannot
9886 -- appear in a formal part to apply to a formal subprogram.
9887 -- Do not apply check within an instance or a formal package
9888 -- the test will have been applied to the original generic.
9890 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
9891 and then List_Containing (Decl) = List_Containing (N)
9892 and then not In_Instance
9895 ("Inline cannot apply to a formal subprogram", N);
9901 -- For a generic subprogram set flag as well, for use at the point
9902 -- of instantiation, to determine whether the body should be
9905 elsif Is_Generic_Subprogram (Subp) then
9906 Set_Inline_Flags (Subp);
9909 -- Literals are by definition inlined
9911 elsif Kind = E_Enumeration_Literal then
9914 -- Anything else is an error
9918 ("expect subprogram name for pragma%", Assoc);
9922 ----------------------
9923 -- Set_Inline_Flags --
9924 ----------------------
9926 procedure Set_Inline_Flags (Subp : Entity_Id) is
9928 -- First set the Has_Pragma_XXX flags and issue the appropriate
9929 -- errors and warnings for suspicious combinations.
9931 if Prag_Id = Pragma_No_Inline then
9932 if Has_Pragma_Inline_Always (Subp) then
9934 ("Inline_Always and No_Inline are mutually exclusive", N);
9935 elsif Has_Pragma_Inline (Subp) then
9937 ("Inline and No_Inline both specified for& ??",
9938 N, Entity (Subp_Id));
9941 Set_Has_Pragma_No_Inline (Subp);
9943 if Prag_Id = Pragma_Inline_Always then
9944 if Has_Pragma_No_Inline (Subp) then
9946 ("Inline_Always and No_Inline are mutually exclusive",
9950 Set_Has_Pragma_Inline_Always (Subp);
9952 if Has_Pragma_No_Inline (Subp) then
9954 ("Inline and No_Inline both specified for& ??",
9955 N, Entity (Subp_Id));
9959 Set_Has_Pragma_Inline (Subp);
9962 -- Then adjust the Is_Inlined flag. It can never be set if the
9963 -- subprogram is subject to pragma No_Inline.
9967 Set_Is_Inlined (Subp, False);
9973 if not Has_Pragma_No_Inline (Subp) then
9974 Set_Is_Inlined (Subp, True);
9978 -- A pragma that applies to a Ghost entity becomes Ghost for the
9979 -- purposes of legality checks and removal of ignored Ghost code.
9981 Mark_Ghost_Pragma (N, Subp);
9983 -- Capture the entity of the first Ghost subprogram being
9984 -- processed for error detection purposes.
9986 if Is_Ghost_Entity (Subp) then
9987 if No (Ghost_Id) then
9991 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
9992 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
9994 elsif Present (Ghost_Id) and then not Ghost_Error_Posted then
9995 Ghost_Error_Posted := True;
9997 Error_Msg_Name_1 := Pname;
9999 ("pragma % cannot mention ghost and non-ghost subprograms",
10002 Error_Msg_Sloc := Sloc (Ghost_Id);
10003 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
10005 Error_Msg_Sloc := Sloc (Subp);
10006 Error_Msg_NE ("\& # declared as non-ghost", N, Subp);
10008 end Set_Inline_Flags;
10010 -- Start of processing for Process_Inline
10013 -- An inlined subprogram may grant access to its private enclosing
10014 -- context depending on the placement of its body. From elaboration
10015 -- point of view, the flow of execution may enter this private
10016 -- context, and then reach an external unit, thus producing a
10017 -- dependency on that external unit. For such a path to be properly
10018 -- discovered and encoded in the ALI file of the main unit, let the
10019 -- ABE mechanism process the body of the main unit, and encode all
10020 -- relevant invocation constructs and the relations between them.
10022 Mark_Save_Invocation_Graph_Of_Body;
10024 Check_No_Identifiers;
10025 Check_At_Least_N_Arguments (1);
10027 if Status = Enabled then
10028 Inline_Processing_Required := True;
10032 while Present (Assoc) loop
10033 Subp_Id := Get_Pragma_Arg (Assoc);
10037 if Is_Entity_Name (Subp_Id) then
10038 Subp := Entity (Subp_Id);
10040 if Subp = Any_Id then
10042 -- If previous error, avoid cascaded errors
10044 Check_Error_Detected;
10048 Make_Inline (Subp);
10050 -- For the pragma case, climb homonym chain. This is
10051 -- what implements allowing the pragma in the renaming
10052 -- case, with the result applying to the ancestors, and
10053 -- also allows Inline to apply to all previous homonyms.
10055 if not From_Aspect_Specification (N) then
10056 while Present (Homonym (Subp))
10057 and then Scope (Homonym (Subp)) = Current_Scope
10059 Make_Inline (Homonym (Subp));
10060 Subp := Homonym (Subp);
10066 if not Applies then
10067 Error_Pragma_Arg ("inappropriate argument for pragma%", Assoc);
10073 -- If the context is a package declaration, the pragma indicates
10074 -- that inlining will require the presence of the corresponding
10075 -- body. (this may be further refined).
10078 and then Nkind (Unit (Cunit (Current_Sem_Unit))) =
10079 N_Package_Declaration
10081 Set_Body_Needed_For_Inlining (Cunit_Entity (Current_Sem_Unit));
10083 end Process_Inline;
10085 ----------------------------
10086 -- Process_Interface_Name --
10087 ----------------------------
10089 procedure Process_Interface_Name
10090 (Subprogram_Def : Entity_Id;
10092 Link_Arg : Node_Id;
10096 Link_Nam : Node_Id;
10097 String_Val : String_Id;
10099 procedure Check_Form_Of_Interface_Name (SN : Node_Id);
10100 -- SN is a string literal node for an interface name. This routine
10101 -- performs some minimal checks that the name is reasonable. In
10102 -- particular that no spaces or other obviously incorrect characters
10103 -- appear. This is only a warning, since any characters are allowed.
10105 ----------------------------------
10106 -- Check_Form_Of_Interface_Name --
10107 ----------------------------------
10109 procedure Check_Form_Of_Interface_Name (SN : Node_Id) is
10110 S : constant String_Id := Strval (Expr_Value_S (SN));
10111 SL : constant Nat := String_Length (S);
10116 Error_Msg_N ("interface name cannot be null string", SN);
10119 for J in 1 .. SL loop
10120 C := Get_String_Char (S, J);
10122 -- Look for dubious character and issue unconditional warning.
10123 -- Definitely dubious if not in character range.
10125 if not In_Character_Range (C)
10127 -- Commas, spaces and (back)slashes are dubious
10129 or else Get_Character (C) = ','
10130 or else Get_Character (C) = '\'
10131 or else Get_Character (C) = ' '
10132 or else Get_Character (C) = '/'
10135 ("??interface name contains illegal character",
10136 Sloc (SN) + Source_Ptr (J));
10139 end Check_Form_Of_Interface_Name;
10141 -- Start of processing for Process_Interface_Name
10144 -- If we are looking at a pragma that comes from an aspect then it
10145 -- needs to have its corresponding aspect argument expressions
10146 -- analyzed in addition to the generated pragma so that aspects
10147 -- within generic units get properly resolved.
10149 if Present (Prag) and then From_Aspect_Specification (Prag) then
10151 Asp : constant Node_Id := Corresponding_Aspect (Prag);
10159 -- Obtain all interfacing aspects used to construct the pragma
10161 Get_Interfacing_Aspects
10162 (Asp, Dummy_1, EN, Dummy_2, Dummy_3, LN);
10164 -- Analyze the expression of aspect External_Name
10166 if Present (EN) then
10167 Analyze (Expression (EN));
10170 -- Analyze the expressio of aspect Link_Name
10172 if Present (LN) then
10173 Analyze (Expression (LN));
10178 if No (Link_Arg) then
10179 if No (Ext_Arg) then
10182 elsif Chars (Ext_Arg) = Name_Link_Name then
10184 Link_Nam := Expression (Ext_Arg);
10187 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
10188 Ext_Nam := Expression (Ext_Arg);
10193 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
10194 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
10195 Ext_Nam := Expression (Ext_Arg);
10196 Link_Nam := Expression (Link_Arg);
10199 -- Check expressions for external name and link name are static
10201 if Present (Ext_Nam) then
10202 Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String);
10203 Check_Form_Of_Interface_Name (Ext_Nam);
10205 -- Verify that external name is not the name of a local entity,
10206 -- which would hide the imported one and could lead to run-time
10207 -- surprises. The problem can only arise for entities declared in
10208 -- a package body (otherwise the external name is fully qualified
10209 -- and will not conflict).
10217 if Prag_Id = Pragma_Import then
10218 Nam := String_To_Name (Strval (Expr_Value_S (Ext_Nam)));
10219 E := Entity_Id (Get_Name_Table_Int (Nam));
10221 if Nam /= Chars (Subprogram_Def)
10222 and then Present (E)
10223 and then not Is_Overloadable (E)
10224 and then Is_Immediately_Visible (E)
10225 and then not Is_Imported (E)
10226 and then Ekind (Scope (E)) = E_Package
10229 while Present (Par) loop
10230 if Nkind (Par) = N_Package_Body then
10231 Error_Msg_Sloc := Sloc (E);
10233 ("imported entity is hidden by & declared#",
10238 Par := Parent (Par);
10245 if Present (Link_Nam) then
10246 Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String);
10247 Check_Form_Of_Interface_Name (Link_Nam);
10250 -- If there is no link name, just set the external name
10252 if No (Link_Nam) then
10253 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
10255 -- For the Link_Name case, the given literal is preceded by an
10256 -- asterisk, which indicates to GCC that the given name should be
10257 -- taken literally, and in particular that no prepending of
10258 -- underlines should occur, even in systems where this is the
10263 Store_String_Char (Get_Char_Code ('*'));
10264 String_Val := Strval (Expr_Value_S (Link_Nam));
10265 Store_String_Chars (String_Val);
10267 Make_String_Literal (Sloc (Link_Nam),
10268 Strval => End_String);
10271 -- Set the interface name. If the entity is a generic instance, use
10272 -- its alias, which is the callable entity.
10274 if Is_Generic_Instance (Subprogram_Def) then
10275 Set_Encoded_Interface_Name
10276 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
10278 Set_Encoded_Interface_Name
10279 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
10282 Check_Duplicated_Export_Name (Link_Nam);
10283 end Process_Interface_Name;
10285 -----------------------------------------
10286 -- Process_Interrupt_Or_Attach_Handler --
10287 -----------------------------------------
10289 procedure Process_Interrupt_Or_Attach_Handler is
10290 Handler : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1));
10291 Prot_Typ : constant Entity_Id := Scope (Handler);
10294 -- A pragma that applies to a Ghost entity becomes Ghost for the
10295 -- purposes of legality checks and removal of ignored Ghost code.
10297 Mark_Ghost_Pragma (N, Handler);
10298 Set_Is_Interrupt_Handler (Handler);
10300 pragma Assert (Ekind (Prot_Typ) = E_Protected_Type);
10302 Record_Rep_Item (Prot_Typ, N);
10304 -- Chain the pragma on the contract for completeness
10306 Add_Contract_Item (N, Handler);
10307 end Process_Interrupt_Or_Attach_Handler;
10309 --------------------------------------------------
10310 -- Process_Restrictions_Or_Restriction_Warnings --
10311 --------------------------------------------------
10313 -- Note: some of the simple identifier cases were handled in par-prag,
10314 -- but it is harmless (and more straightforward) to simply handle all
10315 -- cases here, even if it means we repeat a bit of work in some cases.
10317 procedure Process_Restrictions_Or_Restriction_Warnings
10321 R_Id : Restriction_Id;
10327 -- Ignore all Restrictions pragmas in CodePeer mode
10329 if CodePeer_Mode then
10333 Check_Ada_83_Warning;
10334 Check_At_Least_N_Arguments (1);
10335 Check_Valid_Configuration_Pragma;
10338 while Present (Arg) loop
10340 Expr := Get_Pragma_Arg (Arg);
10342 -- Case of no restriction identifier present
10344 if Id = No_Name then
10345 if Nkind (Expr) /= N_Identifier then
10347 ("invalid form for restriction", Arg);
10352 (Process_Restriction_Synonyms (Expr));
10354 if R_Id not in All_Boolean_Restrictions then
10355 Error_Msg_Name_1 := Pname;
10357 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
10359 -- Check for possible misspelling
10361 for J in Restriction_Id loop
10363 Rnm : constant String := Restriction_Id'Image (J);
10366 Name_Buffer (1 .. Rnm'Length) := Rnm;
10367 Name_Len := Rnm'Length;
10368 Set_Casing (All_Lower_Case);
10370 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
10373 (Source_Index (Current_Sem_Unit)));
10374 Error_Msg_String (1 .. Rnm'Length) :=
10375 Name_Buffer (1 .. Name_Len);
10376 Error_Msg_Strlen := Rnm'Length;
10377 Error_Msg_N -- CODEFIX
10378 ("\possible misspelling of ""~""",
10379 Get_Pragma_Arg (Arg));
10388 if Implementation_Restriction (R_Id) then
10389 Check_Restriction (No_Implementation_Restrictions, Arg);
10392 -- Special processing for No_Elaboration_Code restriction
10394 if R_Id = No_Elaboration_Code then
10396 -- Restriction is only recognized within a configuration
10397 -- pragma file, or within a unit of the main extended
10398 -- program. Note: the test for Main_Unit is needed to
10399 -- properly include the case of configuration pragma files.
10401 if not (Current_Sem_Unit = Main_Unit
10402 or else In_Extended_Main_Source_Unit (N))
10406 -- Don't allow in a subunit unless already specified in
10409 elsif Nkind (Parent (N)) = N_Compilation_Unit
10410 and then Nkind (Unit (Parent (N))) = N_Subunit
10411 and then not Restriction_Active (No_Elaboration_Code)
10414 ("invalid specification of ""No_Elaboration_Code""",
10417 ("\restriction cannot be specified in a subunit", N);
10419 ("\unless also specified in body or spec", N);
10422 -- If we accept a No_Elaboration_Code restriction, then it
10423 -- needs to be added to the configuration restriction set so
10424 -- that we get proper application to other units in the main
10425 -- extended source as required.
10428 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
10432 -- If this is a warning, then set the warning unless we already
10433 -- have a real restriction active (we never want a warning to
10434 -- override a real restriction).
10437 if not Restriction_Active (R_Id) then
10438 Set_Restriction (R_Id, N);
10439 Restriction_Warnings (R_Id) := True;
10442 -- If real restriction case, then set it and make sure that the
10443 -- restriction warning flag is off, since a real restriction
10444 -- always overrides a warning.
10447 Set_Restriction (R_Id, N);
10448 Restriction_Warnings (R_Id) := False;
10451 -- Check for obsolescent restrictions in Ada 2005 mode
10454 and then Ada_Version >= Ada_2005
10455 and then (R_Id = No_Asynchronous_Control
10457 R_Id = No_Unchecked_Deallocation
10459 R_Id = No_Unchecked_Conversion)
10461 Check_Restriction (No_Obsolescent_Features, N);
10464 -- A very special case that must be processed here: pragma
10465 -- Restrictions (No_Exceptions) turns off all run-time
10466 -- checking. This is a bit dubious in terms of the formal
10467 -- language definition, but it is what is intended by RM
10468 -- H.4(12). Restriction_Warnings never affects generated code
10469 -- so this is done only in the real restriction case.
10471 -- Atomic_Synchronization is not a real check, so it is not
10472 -- affected by this processing).
10474 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
10475 -- run-time checks in CodePeer and GNATprove modes: we want to
10476 -- generate checks for analysis purposes, as set respectively
10477 -- by -gnatC and -gnatd.F
10480 and then not (CodePeer_Mode or GNATprove_Mode)
10481 and then R_Id = No_Exceptions
10483 for J in Scope_Suppress.Suppress'Range loop
10484 if J /= Atomic_Synchronization then
10485 Scope_Suppress.Suppress (J) := True;
10490 -- Case of No_Dependence => unit-name. Note that the parser
10491 -- already made the necessary entry in the No_Dependence table.
10493 elsif Id = Name_No_Dependence then
10494 if not OK_No_Dependence_Unit_Name (Expr) then
10498 -- Case of No_Specification_Of_Aspect => aspect-identifier
10500 elsif Id = Name_No_Specification_Of_Aspect then
10505 if Nkind (Expr) /= N_Identifier then
10508 A_Id := Get_Aspect_Id (Chars (Expr));
10511 if A_Id = No_Aspect then
10512 Error_Pragma_Arg ("invalid restriction name", Arg);
10514 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
10518 -- Case of No_Use_Of_Attribute => attribute-identifier
10520 elsif Id = Name_No_Use_Of_Attribute then
10521 if Nkind (Expr) /= N_Identifier
10522 or else not Is_Attribute_Name (Chars (Expr))
10524 Error_Msg_N ("unknown attribute name??", Expr);
10527 Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
10530 -- Case of No_Use_Of_Entity => fully-qualified-name
10532 elsif Id = Name_No_Use_Of_Entity then
10534 -- Restriction is only recognized within a configuration
10535 -- pragma file, or within a unit of the main extended
10536 -- program. Note: the test for Main_Unit is needed to
10537 -- properly include the case of configuration pragma files.
10539 if Current_Sem_Unit = Main_Unit
10540 or else In_Extended_Main_Source_Unit (N)
10542 if not OK_No_Dependence_Unit_Name (Expr) then
10543 Error_Msg_N ("wrong form for entity name", Expr);
10545 Set_Restriction_No_Use_Of_Entity
10546 (Expr, Warn, No_Profile);
10550 -- Case of No_Use_Of_Pragma => pragma-identifier
10552 elsif Id = Name_No_Use_Of_Pragma then
10553 if Nkind (Expr) /= N_Identifier
10554 or else not Is_Pragma_Name (Chars (Expr))
10556 Error_Msg_N ("unknown pragma name??", Expr);
10558 Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
10561 -- All other cases of restriction identifier present
10564 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
10565 Analyze_And_Resolve (Expr, Any_Integer);
10567 if R_Id not in All_Parameter_Restrictions then
10569 ("invalid restriction parameter identifier", Arg);
10571 elsif not Is_OK_Static_Expression (Expr) then
10572 Flag_Non_Static_Expr
10573 ("value must be static expression!", Expr);
10576 elsif not Is_Integer_Type (Etype (Expr))
10577 or else Expr_Value (Expr) < 0
10580 ("value must be non-negative integer", Arg);
10583 -- Restriction pragma is active
10585 Val := Expr_Value (Expr);
10587 if not UI_Is_In_Int_Range (Val) then
10589 ("pragma ignored, value too large??", Arg);
10592 -- Warning case. If the real restriction is active, then we
10593 -- ignore the request, since warning never overrides a real
10594 -- restriction. Otherwise we set the proper warning. Note that
10595 -- this circuit sets the warning again if it is already set,
10596 -- which is what we want, since the constant may have changed.
10599 if not Restriction_Active (R_Id) then
10601 (R_Id, N, Integer (UI_To_Int (Val)));
10602 Restriction_Warnings (R_Id) := True;
10605 -- Real restriction case, set restriction and make sure warning
10606 -- flag is off since real restriction always overrides warning.
10609 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
10610 Restriction_Warnings (R_Id) := False;
10616 end Process_Restrictions_Or_Restriction_Warnings;
10618 ---------------------------------
10619 -- Process_Suppress_Unsuppress --
10620 ---------------------------------
10622 -- Note: this procedure makes entries in the check suppress data
10623 -- structures managed by Sem. See spec of package Sem for full
10624 -- details on how we handle recording of check suppression.
10626 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
10631 In_Package_Spec : constant Boolean :=
10632 Is_Package_Or_Generic_Package (Current_Scope)
10633 and then not In_Package_Body (Current_Scope);
10635 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
10636 -- Used to suppress a single check on the given entity
10638 --------------------------------
10639 -- Suppress_Unsuppress_Echeck --
10640 --------------------------------
10642 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
10644 -- Check for error of trying to set atomic synchronization for
10645 -- a non-atomic variable.
10647 if C = Atomic_Synchronization
10648 and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
10651 ("pragma & requires atomic type or variable",
10652 Pragma_Identifier (Original_Node (N)));
10655 Set_Checks_May_Be_Suppressed (E);
10657 if In_Package_Spec then
10658 Push_Global_Suppress_Stack_Entry
10661 Suppress => Suppress_Case);
10663 Push_Local_Suppress_Stack_Entry
10666 Suppress => Suppress_Case);
10669 -- If this is a first subtype, and the base type is distinct,
10670 -- then also set the suppress flags on the base type.
10672 if Is_First_Subtype (E) and then Etype (E) /= E then
10673 Suppress_Unsuppress_Echeck (Etype (E), C);
10675 end Suppress_Unsuppress_Echeck;
10677 -- Start of processing for Process_Suppress_Unsuppress
10680 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
10681 -- on user code: we want to generate checks for analysis purposes, as
10682 -- set respectively by -gnatC and -gnatd.F
10684 if Comes_From_Source (N)
10685 and then (CodePeer_Mode or GNATprove_Mode)
10690 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
10691 -- declarative part or a package spec (RM 11.5(5)).
10693 if not Is_Configuration_Pragma then
10694 Check_Is_In_Decl_Part_Or_Package_Spec;
10697 Check_At_Least_N_Arguments (1);
10698 Check_At_Most_N_Arguments (2);
10699 Check_No_Identifier (Arg1);
10700 Check_Arg_Is_Identifier (Arg1);
10702 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
10704 if C = No_Check_Id then
10706 ("argument of pragma% is not valid check name", Arg1);
10709 -- Warn that suppress of Elaboration_Check has no effect in SPARK
10711 if C = Elaboration_Check and then SPARK_Mode = On then
10713 ("Suppress of Elaboration_Check ignored in SPARK??",
10714 "\elaboration checking rules are statically enforced "
10715 & "(SPARK RM 7.7)", Arg1);
10718 -- One-argument case
10720 if Arg_Count = 1 then
10722 -- Make an entry in the local scope suppress table. This is the
10723 -- table that directly shows the current value of the scope
10724 -- suppress check for any check id value.
10726 if C = All_Checks then
10728 -- For All_Checks, we set all specific predefined checks with
10729 -- the exception of Elaboration_Check, which is handled
10730 -- specially because of not wanting All_Checks to have the
10731 -- effect of deactivating static elaboration order processing.
10732 -- Atomic_Synchronization is also not affected, since this is
10733 -- not a real check.
10735 for J in Scope_Suppress.Suppress'Range loop
10736 if J /= Elaboration_Check
10738 J /= Atomic_Synchronization
10740 Scope_Suppress.Suppress (J) := Suppress_Case;
10744 -- If not All_Checks, and predefined check, then set appropriate
10745 -- scope entry. Note that we will set Elaboration_Check if this
10746 -- is explicitly specified. Atomic_Synchronization is allowed
10747 -- only if internally generated and entity is atomic.
10749 elsif C in Predefined_Check_Id
10750 and then (not Comes_From_Source (N)
10751 or else C /= Atomic_Synchronization)
10753 Scope_Suppress.Suppress (C) := Suppress_Case;
10756 -- Also make an entry in the Local_Entity_Suppress table
10758 Push_Local_Suppress_Stack_Entry
10761 Suppress => Suppress_Case);
10763 -- Case of two arguments present, where the check is suppressed for
10764 -- a specified entity (given as the second argument of the pragma)
10767 -- This is obsolescent in Ada 2005 mode
10769 if Ada_Version >= Ada_2005 then
10770 Check_Restriction (No_Obsolescent_Features, Arg2);
10773 Check_Optional_Identifier (Arg2, Name_On);
10774 E_Id := Get_Pragma_Arg (Arg2);
10777 if not Is_Entity_Name (E_Id) then
10779 ("second argument of pragma% must be entity name", Arg2);
10782 E := Entity (E_Id);
10788 -- A pragma that applies to a Ghost entity becomes Ghost for the
10789 -- purposes of legality checks and removal of ignored Ghost code.
10791 Mark_Ghost_Pragma (N, E);
10793 -- Enforce RM 11.5(7) which requires that for a pragma that
10794 -- appears within a package spec, the named entity must be
10795 -- within the package spec. We allow the package name itself
10796 -- to be mentioned since that makes sense, although it is not
10797 -- strictly allowed by 11.5(7).
10800 and then E /= Current_Scope
10801 and then Scope (E) /= Current_Scope
10804 ("entity in pragma% is not in package spec (RM 11.5(7))",
10808 -- Loop through homonyms. As noted below, in the case of a package
10809 -- spec, only homonyms within the package spec are considered.
10812 Suppress_Unsuppress_Echeck (E, C);
10814 if Is_Generic_Instance (E)
10815 and then Is_Subprogram (E)
10816 and then Present (Alias (E))
10818 Suppress_Unsuppress_Echeck (Alias (E), C);
10821 -- Move to next homonym if not aspect spec case
10823 exit when From_Aspect_Specification (N);
10827 -- If we are within a package specification, the pragma only
10828 -- applies to homonyms in the same scope.
10830 exit when In_Package_Spec
10831 and then Scope (E) /= Current_Scope;
10834 end Process_Suppress_Unsuppress;
10836 -------------------------------
10837 -- Record_Independence_Check --
10838 -------------------------------
10840 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id) is
10841 pragma Unreferenced (N, E);
10843 -- For GCC back ends the validation is done a priori
10844 -- ??? This code is dead, might be useful in the future
10846 -- if not AAMP_On_Target then
10850 -- Independence_Checks.Append ((N, E));
10853 end Record_Independence_Check;
10859 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
10861 if Is_Imported (E) then
10863 ("cannot export entity& that was previously imported", Arg);
10865 elsif Present (Address_Clause (E))
10866 and then not Relaxed_RM_Semantics
10869 ("cannot export entity& that has an address clause", Arg);
10872 Set_Is_Exported (E);
10874 -- Generate a reference for entity explicitly, because the
10875 -- identifier may be overloaded and name resolution will not
10878 Generate_Reference (E, Arg);
10880 -- Deal with exporting non-library level entity
10882 if not Is_Library_Level_Entity (E) then
10884 -- Not allowed at all for subprograms
10886 if Is_Subprogram (E) then
10887 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
10889 -- Otherwise set public and statically allocated
10893 Set_Is_Statically_Allocated (E);
10895 -- Warn if the corresponding W flag is set
10897 if Warn_On_Export_Import
10899 -- Only do this for something that was in the source. Not
10900 -- clear if this can be False now (there used for sure to be
10901 -- cases on some systems where it was False), but anyway the
10902 -- test is harmless if not needed, so it is retained.
10904 and then Comes_From_Source (Arg)
10907 ("?x?& has been made static as a result of Export",
10910 ("\?x?this usage is non-standard and non-portable",
10916 if Warn_On_Export_Import and then Is_Type (E) then
10917 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
10920 if Warn_On_Export_Import and Inside_A_Generic then
10922 ("all instances of& will have the same external name?x?",
10927 ----------------------------------------------
10928 -- Set_Extended_Import_Export_External_Name --
10929 ----------------------------------------------
10931 procedure Set_Extended_Import_Export_External_Name
10932 (Internal_Ent : Entity_Id;
10933 Arg_External : Node_Id)
10935 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
10936 New_Name : Node_Id;
10939 if No (Arg_External) then
10943 Check_Arg_Is_External_Name (Arg_External);
10945 if Nkind (Arg_External) = N_String_Literal then
10946 if String_Length (Strval (Arg_External)) = 0 then
10949 New_Name := Adjust_External_Name_Case (Arg_External);
10952 elsif Nkind (Arg_External) = N_Identifier then
10953 New_Name := Get_Default_External_Name (Arg_External);
10955 -- Check_Arg_Is_External_Name should let through only identifiers and
10956 -- string literals or static string expressions (which are folded to
10957 -- string literals).
10960 raise Program_Error;
10963 -- If we already have an external name set (by a prior normal Import
10964 -- or Export pragma), then the external names must match
10966 if Present (Interface_Name (Internal_Ent)) then
10968 -- Ignore mismatching names in CodePeer mode, to support some
10969 -- old compilers which would export the same procedure under
10970 -- different names, e.g:
10972 -- pragma Export_Procedure (P, "a");
10973 -- pragma Export_Procedure (P, "b");
10975 if CodePeer_Mode then
10979 Check_Matching_Internal_Names : declare
10980 S1 : constant String_Id := Strval (Old_Name);
10981 S2 : constant String_Id := Strval (New_Name);
10983 procedure Mismatch;
10984 pragma No_Return (Mismatch);
10985 -- Called if names do not match
10991 procedure Mismatch is
10993 Error_Msg_Sloc := Sloc (Old_Name);
10995 ("external name does not match that given #",
10999 -- Start of processing for Check_Matching_Internal_Names
11002 if String_Length (S1) /= String_Length (S2) then
11006 for J in 1 .. String_Length (S1) loop
11007 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
11012 end Check_Matching_Internal_Names;
11014 -- Otherwise set the given name
11017 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
11018 Check_Duplicated_Export_Name (New_Name);
11020 end Set_Extended_Import_Export_External_Name;
11026 procedure Set_Imported (E : Entity_Id) is
11028 -- Error message if already imported or exported
11030 if Is_Exported (E) or else Is_Imported (E) then
11032 -- Error if being set Exported twice
11034 if Is_Exported (E) then
11035 Error_Msg_NE ("entity& was previously exported", N, E);
11037 -- Ignore error in CodePeer mode where we treat all imported
11038 -- subprograms as unknown.
11040 elsif CodePeer_Mode then
11043 -- OK if Import/Interface case
11045 elsif Import_Interface_Present (N) then
11048 -- Error if being set Imported twice
11051 Error_Msg_NE ("entity& was previously imported", N, E);
11054 Error_Msg_Name_1 := Pname;
11056 ("\(pragma% applies to all previous entities)", N);
11058 Error_Msg_Sloc := Sloc (E);
11059 Error_Msg_NE ("\import not allowed for& declared#", N, E);
11061 -- Here if not previously imported or exported, OK to import
11064 Set_Is_Imported (E);
11066 -- For subprogram, set Import_Pragma field
11068 if Is_Subprogram (E) then
11069 Set_Import_Pragma (E, N);
11072 -- If the entity is an object that is not at the library level,
11073 -- then it is statically allocated. We do not worry about objects
11074 -- with address clauses in this context since they are not really
11075 -- imported in the linker sense.
11078 and then not Is_Library_Level_Entity (E)
11079 and then No (Address_Clause (E))
11081 Set_Is_Statically_Allocated (E);
11088 -------------------------
11089 -- Set_Mechanism_Value --
11090 -------------------------
11092 -- Note: the mechanism name has not been analyzed (and cannot indeed be
11093 -- analyzed, since it is semantic nonsense), so we get it in the exact
11094 -- form created by the parser.
11096 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
11097 procedure Bad_Mechanism;
11098 pragma No_Return (Bad_Mechanism);
11099 -- Signal bad mechanism name
11101 -------------------
11102 -- Bad_Mechanism --
11103 -------------------
11105 procedure Bad_Mechanism is
11107 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
11110 -- Start of processing for Set_Mechanism_Value
11113 if Mechanism (Ent) /= Default_Mechanism then
11115 ("mechanism for & has already been set", Mech_Name, Ent);
11118 -- MECHANISM_NAME ::= value | reference
11120 if Nkind (Mech_Name) = N_Identifier then
11121 if Chars (Mech_Name) = Name_Value then
11122 Set_Mechanism (Ent, By_Copy);
11125 elsif Chars (Mech_Name) = Name_Reference then
11126 Set_Mechanism (Ent, By_Reference);
11129 elsif Chars (Mech_Name) = Name_Copy then
11131 ("bad mechanism name, Value assumed", Mech_Name);
11140 end Set_Mechanism_Value;
11142 --------------------------
11143 -- Set_Rational_Profile --
11144 --------------------------
11146 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
11147 -- extension to the semantics of renaming declarations.
11149 procedure Set_Rational_Profile is
11151 Implicit_Packing := True;
11152 Overriding_Renamings := True;
11153 Use_VADS_Size := True;
11154 end Set_Rational_Profile;
11156 ---------------------------
11157 -- Set_Ravenscar_Profile --
11158 ---------------------------
11160 -- The tasks to be done here are
11162 -- Set required policies
11164 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11165 -- (For Ravenscar, Jorvik, and GNAT_Extended_Ravenscar profiles)
11166 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11167 -- (For GNAT_Ravenscar_EDF profile)
11168 -- pragma Locking_Policy (Ceiling_Locking)
11170 -- Set Detect_Blocking mode
11172 -- Set required restrictions (see System.Rident for detailed list)
11174 -- Set the No_Dependence rules
11175 -- No_Dependence => Ada.Asynchronous_Task_Control
11176 -- No_Dependence => Ada.Calendar
11177 -- No_Dependence => Ada.Execution_Time.Group_Budget
11178 -- No_Dependence => Ada.Execution_Time.Timers
11179 -- No_Dependence => Ada.Task_Attributes
11180 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11182 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id) is
11183 procedure Set_Error_Msg_To_Profile_Name;
11184 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
11187 -----------------------------------
11188 -- Set_Error_Msg_To_Profile_Name --
11189 -----------------------------------
11191 procedure Set_Error_Msg_To_Profile_Name is
11192 Prof_Nam : constant Node_Id :=
11194 (First (Pragma_Argument_Associations (N)));
11197 Get_Name_String (Chars (Prof_Nam));
11198 Adjust_Name_Case (Global_Name_Buffer, Sloc (Prof_Nam));
11199 Error_Msg_Strlen := Name_Len;
11200 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
11201 end Set_Error_Msg_To_Profile_Name;
11210 Profile_Dispatching_Policy : Character;
11212 -- Start of processing for Set_Ravenscar_Profile
11215 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11217 if Profile = GNAT_Ravenscar_EDF then
11218 Profile_Dispatching_Policy := 'E';
11220 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11223 Profile_Dispatching_Policy := 'F';
11226 if Task_Dispatching_Policy /= ' '
11227 and then Task_Dispatching_Policy /= Profile_Dispatching_Policy
11229 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
11230 Set_Error_Msg_To_Profile_Name;
11231 Error_Pragma ("Profile (~) incompatible with policy#");
11233 -- Set the FIFO_Within_Priorities policy, but always preserve
11234 -- System_Location since we like the error message with the run time
11238 Task_Dispatching_Policy := Profile_Dispatching_Policy;
11240 if Task_Dispatching_Policy_Sloc /= System_Location then
11241 Task_Dispatching_Policy_Sloc := Loc;
11245 -- pragma Locking_Policy (Ceiling_Locking)
11247 if Locking_Policy /= ' '
11248 and then Locking_Policy /= 'C'
11250 Error_Msg_Sloc := Locking_Policy_Sloc;
11251 Set_Error_Msg_To_Profile_Name;
11252 Error_Pragma ("Profile (~) incompatible with policy#");
11254 -- Set the Ceiling_Locking policy, but preserve System_Location since
11255 -- we like the error message with the run time name.
11258 Locking_Policy := 'C';
11260 if Locking_Policy_Sloc /= System_Location then
11261 Locking_Policy_Sloc := Loc;
11265 -- pragma Detect_Blocking
11267 Detect_Blocking := True;
11269 -- Set the corresponding restrictions
11271 Set_Profile_Restrictions
11272 (Profile, N, Warn => Treat_Restrictions_As_Warnings);
11274 -- Set the No_Dependence restrictions
11276 -- The following No_Dependence restrictions:
11277 -- No_Dependence => Ada.Asynchronous_Task_Control
11278 -- No_Dependence => Ada.Calendar
11279 -- No_Dependence => Ada.Task_Attributes
11280 -- are already set by previous call to Set_Profile_Restrictions.
11282 -- Set the following restrictions which were added to Ada 2005:
11283 -- No_Dependence => Ada.Execution_Time.Group_Budget
11284 -- No_Dependence => Ada.Execution_Time.Timers
11286 if Ada_Version >= Ada_2005 then
11287 Pref_Id := Make_Identifier (Loc, Name_Find ("ada"));
11288 Sel_Id := Make_Identifier (Loc, Name_Find ("execution_time"));
11291 Make_Selected_Component
11294 Selector_Name => Sel_Id);
11296 Sel_Id := Make_Identifier (Loc, Name_Find ("group_budgets"));
11299 Make_Selected_Component
11302 Selector_Name => Sel_Id);
11304 Set_Restriction_No_Dependence
11306 Warn => Treat_Restrictions_As_Warnings,
11307 Profile => Ravenscar);
11309 Sel_Id := Make_Identifier (Loc, Name_Find ("timers"));
11312 Make_Selected_Component
11315 Selector_Name => Sel_Id);
11317 Set_Restriction_No_Dependence
11319 Warn => Treat_Restrictions_As_Warnings,
11320 Profile => Ravenscar);
11323 -- Set the following restriction which was added to Ada 2012 (see
11325 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11327 if Ada_Version >= Ada_2012 then
11328 Pref_Id := Make_Identifier (Loc, Name_Find ("system"));
11329 Sel_Id := Make_Identifier (Loc, Name_Find ("multiprocessors"));
11332 Make_Selected_Component
11335 Selector_Name => Sel_Id);
11337 Sel_Id := Make_Identifier (Loc, Name_Find ("dispatching_domains"));
11340 Make_Selected_Component
11343 Selector_Name => Sel_Id);
11345 Set_Restriction_No_Dependence
11347 Warn => Treat_Restrictions_As_Warnings,
11348 Profile => Ravenscar);
11350 -- Set the following restriction which was added to Ada 2020,
11351 -- but as a binding interpretation:
11352 -- No_Dependence => Ada.Synchronous_Barriers
11353 -- for Ravenscar (and therefore for Ravenscar variants) but not
11354 -- for Jorvik. The unit Ada.Synchronous_Barriers was introduced
11355 -- in Ada2012 (AI05-0174).
11357 if Profile /= Jorvik then
11358 Pref_Id := Make_Identifier (Loc, Name_Find ("ada"));
11359 Sel_Id := Make_Identifier (Loc, Name_Find
11360 ("synchronous_barriers"));
11363 Make_Selected_Component
11366 Selector_Name => Sel_Id);
11368 Set_Restriction_No_Dependence
11370 Warn => Treat_Restrictions_As_Warnings,
11371 Profile => Ravenscar);
11375 end Set_Ravenscar_Profile;
11377 -- Start of processing for Analyze_Pragma
11380 -- The following code is a defense against recursion. Not clear that
11381 -- this can happen legitimately, but perhaps some error situations can
11382 -- cause it, and we did see this recursion during testing.
11384 if Analyzed (N) then
11390 Check_Restriction_No_Use_Of_Pragma (N);
11392 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
11393 -- Default_Scalar_Storage_Order if the -gnatI switch was given.
11395 if Should_Ignore_Pragma_Sem (N)
11396 or else (Prag_Id = Pragma_Default_Scalar_Storage_Order
11397 and then Ignore_Rep_Clauses)
11402 -- Deal with unrecognized pragma
11404 if not Is_Pragma_Name (Pname) then
11405 if Warn_On_Unrecognized_Pragma then
11406 Error_Msg_Name_1 := Pname;
11407 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
11409 for PN in First_Pragma_Name .. Last_Pragma_Name loop
11410 if Is_Bad_Spelling_Of (Pname, PN) then
11411 Error_Msg_Name_1 := PN;
11412 Error_Msg_N -- CODEFIX
11413 ("\?g?possible misspelling of %!", Pragma_Identifier (N));
11422 -- Here to start processing for recognized pragma
11424 Pname := Original_Aspect_Pragma_Name (N);
11426 -- Capture setting of Opt.Uneval_Old
11428 case Opt.Uneval_Old is
11430 Set_Uneval_Old_Accept (N);
11436 Set_Uneval_Old_Warn (N);
11439 raise Program_Error;
11442 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
11443 -- is already set, indicating that we have already checked the policy
11444 -- at the right point. This happens for example in the case of a pragma
11445 -- that is derived from an Aspect.
11447 if Is_Ignored (N) or else Is_Checked (N) then
11450 -- For a pragma that is a rewriting of another pragma, copy the
11451 -- Is_Checked/Is_Ignored status from the rewritten pragma.
11453 elsif Is_Rewrite_Substitution (N)
11454 and then Nkind (Original_Node (N)) = N_Pragma
11456 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
11457 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
11459 -- Otherwise query the applicable policy at this point
11462 Check_Applicable_Policy (N);
11464 -- If pragma is disabled, rewrite as NULL and skip analysis
11466 if Is_Disabled (N) then
11467 Rewrite (N, Make_Null_Statement (Loc));
11473 -- Preset arguments
11481 if Present (Pragma_Argument_Associations (N)) then
11482 Arg_Count := List_Length (Pragma_Argument_Associations (N));
11483 Arg1 := First (Pragma_Argument_Associations (N));
11485 if Present (Arg1) then
11486 Arg2 := Next (Arg1);
11488 if Present (Arg2) then
11489 Arg3 := Next (Arg2);
11491 if Present (Arg3) then
11492 Arg4 := Next (Arg3);
11498 -- An enumeration type defines the pragmas that are supported by the
11499 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
11500 -- into the corresponding enumeration value for the following case.
11508 -- pragma Abort_Defer;
11510 when Pragma_Abort_Defer =>
11512 Check_Arg_Count (0);
11514 -- The only required semantic processing is to check the
11515 -- placement. This pragma must appear at the start of the
11516 -- statement sequence of a handled sequence of statements.
11518 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
11519 or else N /= First (Statements (Parent (N)))
11524 --------------------
11525 -- Abstract_State --
11526 --------------------
11528 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
11530 -- ABSTRACT_STATE_LIST ::=
11532 -- | STATE_NAME_WITH_OPTIONS
11533 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
11535 -- STATE_NAME_WITH_OPTIONS ::=
11537 -- | (STATE_NAME with OPTION_LIST)
11539 -- OPTION_LIST ::= OPTION {, OPTION}
11543 -- | NAME_VALUE_OPTION
11545 -- SIMPLE_OPTION ::= Ghost | Synchronous
11547 -- NAME_VALUE_OPTION ::=
11548 -- Part_Of => ABSTRACT_STATE
11549 -- | External [=> EXTERNAL_PROPERTY_LIST]
11551 -- EXTERNAL_PROPERTY_LIST ::=
11552 -- EXTERNAL_PROPERTY
11553 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
11555 -- EXTERNAL_PROPERTY ::=
11556 -- Async_Readers [=> boolean_EXPRESSION]
11557 -- | Async_Writers [=> boolean_EXPRESSION]
11558 -- | Effective_Reads [=> boolean_EXPRESSION]
11559 -- | Effective_Writes [=> boolean_EXPRESSION]
11560 -- others => boolean_EXPRESSION
11562 -- STATE_NAME ::= defining_identifier
11564 -- ABSTRACT_STATE ::= name
11566 -- Characteristics:
11568 -- * Analysis - The annotation is fully analyzed immediately upon
11569 -- elaboration as it cannot forward reference entities.
11571 -- * Expansion - None.
11573 -- * Template - The annotation utilizes the generic template of the
11574 -- related package declaration.
11576 -- * Globals - The annotation cannot reference global entities.
11578 -- * Instance - The annotation is instantiated automatically when
11579 -- the related generic package is instantiated.
11581 when Pragma_Abstract_State => Abstract_State : declare
11582 Missing_Parentheses : Boolean := False;
11583 -- Flag set when a state declaration with options is not properly
11586 -- Flags used to verify the consistency of states
11588 Non_Null_Seen : Boolean := False;
11589 Null_Seen : Boolean := False;
11591 procedure Analyze_Abstract_State
11593 Pack_Id : Entity_Id);
11594 -- Verify the legality of a single state declaration. Create and
11595 -- decorate a state abstraction entity and introduce it into the
11596 -- visibility chain. Pack_Id denotes the entity or the related
11597 -- package where pragma Abstract_State appears.
11599 procedure Malformed_State_Error (State : Node_Id);
11600 -- Emit an error concerning the illegal declaration of abstract
11601 -- state State. This routine diagnoses syntax errors that lead to
11602 -- a different parse tree. The error is issued regardless of the
11603 -- SPARK mode in effect.
11605 ----------------------------
11606 -- Analyze_Abstract_State --
11607 ----------------------------
11609 procedure Analyze_Abstract_State
11611 Pack_Id : Entity_Id)
11613 -- Flags used to verify the consistency of options
11615 AR_Seen : Boolean := False;
11616 AW_Seen : Boolean := False;
11617 ER_Seen : Boolean := False;
11618 EW_Seen : Boolean := False;
11619 External_Seen : Boolean := False;
11620 Ghost_Seen : Boolean := False;
11621 Others_Seen : Boolean := False;
11622 Part_Of_Seen : Boolean := False;
11623 Synchronous_Seen : Boolean := False;
11625 -- Flags used to store the static value of all external states'
11628 AR_Val : Boolean := False;
11629 AW_Val : Boolean := False;
11630 ER_Val : Boolean := False;
11631 EW_Val : Boolean := False;
11633 State_Id : Entity_Id := Empty;
11634 -- The entity to be generated for the current state declaration
11636 procedure Analyze_External_Option (Opt : Node_Id);
11637 -- Verify the legality of option External
11639 procedure Analyze_External_Property
11641 Expr : Node_Id := Empty);
11642 -- Verify the legailty of a single external property. Prop
11643 -- denotes the external property. Expr is the expression used
11644 -- to set the property.
11646 procedure Analyze_Part_Of_Option (Opt : Node_Id);
11647 -- Verify the legality of option Part_Of
11649 procedure Check_Duplicate_Option
11651 Status : in out Boolean);
11652 -- Flag Status denotes whether a particular option has been
11653 -- seen while processing a state. This routine verifies that
11654 -- Opt is not a duplicate option and sets the flag Status
11655 -- (SPARK RM 7.1.4(1)).
11657 procedure Check_Duplicate_Property
11659 Status : in out Boolean);
11660 -- Flag Status denotes whether a particular property has been
11661 -- seen while processing option External. This routine verifies
11662 -- that Prop is not a duplicate property and sets flag Status.
11663 -- Opt is not a duplicate property and sets the flag Status.
11664 -- (SPARK RM 7.1.4(2))
11666 procedure Check_Ghost_Synchronous;
11667 -- Ensure that the abstract state is not subject to both Ghost
11668 -- and Synchronous simple options. Emit an error if this is the
11671 procedure Create_Abstract_State
11675 Is_Null : Boolean);
11676 -- Generate an abstract state entity with name Nam and enter it
11677 -- into visibility. Decl is the "declaration" of the state as
11678 -- it appears in pragma Abstract_State. Loc is the location of
11679 -- the related state "declaration". Flag Is_Null should be set
11680 -- when the associated Abstract_State pragma defines a null
11683 -----------------------------
11684 -- Analyze_External_Option --
11685 -----------------------------
11687 procedure Analyze_External_Option (Opt : Node_Id) is
11688 Errors : constant Nat := Serious_Errors_Detected;
11690 Props : Node_Id := Empty;
11693 if Nkind (Opt) = N_Component_Association then
11694 Props := Expression (Opt);
11697 -- External state with properties
11699 if Present (Props) then
11701 -- Multiple properties appear as an aggregate
11703 if Nkind (Props) = N_Aggregate then
11705 -- Simple property form
11707 Prop := First (Expressions (Props));
11708 while Present (Prop) loop
11709 Analyze_External_Property (Prop);
11713 -- Property with expression form
11715 Prop := First (Component_Associations (Props));
11716 while Present (Prop) loop
11717 Analyze_External_Property
11718 (Prop => First (Choices (Prop)),
11719 Expr => Expression (Prop));
11727 Analyze_External_Property (Props);
11730 -- An external state defined without any properties defaults
11731 -- all properties to True.
11740 -- Once all external properties have been processed, verify
11741 -- their mutual interaction. Do not perform the check when
11742 -- at least one of the properties is illegal as this will
11743 -- produce a bogus error.
11745 if Errors = Serious_Errors_Detected then
11746 Check_External_Properties
11747 (State, AR_Val, AW_Val, ER_Val, EW_Val);
11749 end Analyze_External_Option;
11751 -------------------------------
11752 -- Analyze_External_Property --
11753 -------------------------------
11755 procedure Analyze_External_Property
11757 Expr : Node_Id := Empty)
11759 Expr_Val : Boolean;
11762 -- Check the placement of "others" (if available)
11764 if Nkind (Prop) = N_Others_Choice then
11765 if Others_Seen then
11767 ("only one others choice allowed in option External",
11770 Others_Seen := True;
11773 elsif Others_Seen then
11775 ("others must be the last property in option External",
11778 -- The only remaining legal options are the four predefined
11779 -- external properties.
11781 elsif Nkind (Prop) = N_Identifier
11782 and then Nam_In (Chars (Prop), Name_Async_Readers,
11783 Name_Async_Writers,
11784 Name_Effective_Reads,
11785 Name_Effective_Writes)
11789 -- Otherwise the construct is not a valid property
11792 SPARK_Msg_N ("invalid external state property", Prop);
11796 -- Ensure that the expression of the external state property
11797 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
11799 if Present (Expr) then
11800 Analyze_And_Resolve (Expr, Standard_Boolean);
11802 if Is_OK_Static_Expression (Expr) then
11803 Expr_Val := Is_True (Expr_Value (Expr));
11806 ("expression of external state property must be "
11811 -- The lack of expression defaults the property to True
11817 -- Named properties
11819 if Nkind (Prop) = N_Identifier then
11820 if Chars (Prop) = Name_Async_Readers then
11821 Check_Duplicate_Property (Prop, AR_Seen);
11822 AR_Val := Expr_Val;
11824 elsif Chars (Prop) = Name_Async_Writers then
11825 Check_Duplicate_Property (Prop, AW_Seen);
11826 AW_Val := Expr_Val;
11828 elsif Chars (Prop) = Name_Effective_Reads then
11829 Check_Duplicate_Property (Prop, ER_Seen);
11830 ER_Val := Expr_Val;
11833 Check_Duplicate_Property (Prop, EW_Seen);
11834 EW_Val := Expr_Val;
11837 -- The handling of property "others" must take into account
11838 -- all other named properties that have been encountered so
11839 -- far. Only those that have not been seen are affected by
11843 if not AR_Seen then
11844 AR_Val := Expr_Val;
11847 if not AW_Seen then
11848 AW_Val := Expr_Val;
11851 if not ER_Seen then
11852 ER_Val := Expr_Val;
11855 if not EW_Seen then
11856 EW_Val := Expr_Val;
11859 end Analyze_External_Property;
11861 ----------------------------
11862 -- Analyze_Part_Of_Option --
11863 ----------------------------
11865 procedure Analyze_Part_Of_Option (Opt : Node_Id) is
11866 Encap : constant Node_Id := Expression (Opt);
11867 Constits : Elist_Id;
11868 Encap_Id : Entity_Id;
11872 Check_Duplicate_Option (Opt, Part_Of_Seen);
11875 (Indic => First (Choices (Opt)),
11876 Item_Id => State_Id,
11878 Encap_Id => Encap_Id,
11881 -- The Part_Of indicator transforms the abstract state into
11882 -- a constituent of the encapsulating state or single
11883 -- concurrent type.
11886 pragma Assert (Present (Encap_Id));
11887 Constits := Part_Of_Constituents (Encap_Id);
11889 if No (Constits) then
11890 Constits := New_Elmt_List;
11891 Set_Part_Of_Constituents (Encap_Id, Constits);
11894 Append_Elmt (State_Id, Constits);
11895 Set_Encapsulating_State (State_Id, Encap_Id);
11897 end Analyze_Part_Of_Option;
11899 ----------------------------
11900 -- Check_Duplicate_Option --
11901 ----------------------------
11903 procedure Check_Duplicate_Option
11905 Status : in out Boolean)
11909 SPARK_Msg_N ("duplicate state option", Opt);
11913 end Check_Duplicate_Option;
11915 ------------------------------
11916 -- Check_Duplicate_Property --
11917 ------------------------------
11919 procedure Check_Duplicate_Property
11921 Status : in out Boolean)
11925 SPARK_Msg_N ("duplicate external property", Prop);
11929 end Check_Duplicate_Property;
11931 -----------------------------
11932 -- Check_Ghost_Synchronous --
11933 -----------------------------
11935 procedure Check_Ghost_Synchronous is
11937 -- A synchronized abstract state cannot be Ghost and vice
11938 -- versa (SPARK RM 6.9(19)).
11940 if Ghost_Seen and Synchronous_Seen then
11941 SPARK_Msg_N ("synchronized state cannot be ghost", State);
11943 end Check_Ghost_Synchronous;
11945 ---------------------------
11946 -- Create_Abstract_State --
11947 ---------------------------
11949 procedure Create_Abstract_State
11956 -- The abstract state may be semi-declared when the related
11957 -- package was withed through a limited with clause. In that
11958 -- case reuse the entity to fully declare the state.
11960 if Present (Decl) and then Present (Entity (Decl)) then
11961 State_Id := Entity (Decl);
11963 -- Otherwise the elaboration of pragma Abstract_State
11964 -- declares the state.
11967 State_Id := Make_Defining_Identifier (Loc, Nam);
11969 if Present (Decl) then
11970 Set_Entity (Decl, State_Id);
11974 -- Null states never come from source
11976 Set_Comes_From_Source (State_Id, not Is_Null);
11977 Set_Parent (State_Id, State);
11978 Set_Ekind (State_Id, E_Abstract_State);
11979 Set_Etype (State_Id, Standard_Void_Type);
11980 Set_Encapsulating_State (State_Id, Empty);
11982 -- Set the SPARK mode from the current context
11984 Set_SPARK_Pragma (State_Id, SPARK_Mode_Pragma);
11985 Set_SPARK_Pragma_Inherited (State_Id);
11987 -- An abstract state declared within a Ghost region becomes
11988 -- Ghost (SPARK RM 6.9(2)).
11990 if Ghost_Mode > None or else Is_Ghost_Entity (Pack_Id) then
11991 Set_Is_Ghost_Entity (State_Id);
11994 -- Establish a link between the state declaration and the
11995 -- abstract state entity. Note that a null state remains as
11996 -- N_Null and does not carry any linkages.
11998 if not Is_Null then
11999 if Present (Decl) then
12000 Set_Entity (Decl, State_Id);
12001 Set_Etype (Decl, Standard_Void_Type);
12004 -- Every non-null state must be defined, nameable and
12007 Push_Scope (Pack_Id);
12008 Generate_Definition (State_Id);
12009 Enter_Name (State_Id);
12012 end Create_Abstract_State;
12019 -- Start of processing for Analyze_Abstract_State
12022 -- A package with a null abstract state is not allowed to
12023 -- declare additional states.
12027 ("package & has null abstract state", State, Pack_Id);
12029 -- Null states appear as internally generated entities
12031 elsif Nkind (State) = N_Null then
12032 Create_Abstract_State
12033 (Nam => New_Internal_Name ('S'),
12035 Loc => Sloc (State),
12039 -- Catch a case where a null state appears in a list of
12040 -- non-null states.
12042 if Non_Null_Seen then
12044 ("package & has non-null abstract state",
12048 -- Simple state declaration
12050 elsif Nkind (State) = N_Identifier then
12051 Create_Abstract_State
12052 (Nam => Chars (State),
12054 Loc => Sloc (State),
12056 Non_Null_Seen := True;
12058 -- State declaration with various options. This construct
12059 -- appears as an extension aggregate in the tree.
12061 elsif Nkind (State) = N_Extension_Aggregate then
12062 if Nkind (Ancestor_Part (State)) = N_Identifier then
12063 Create_Abstract_State
12064 (Nam => Chars (Ancestor_Part (State)),
12065 Decl => Ancestor_Part (State),
12066 Loc => Sloc (Ancestor_Part (State)),
12068 Non_Null_Seen := True;
12071 ("state name must be an identifier",
12072 Ancestor_Part (State));
12075 -- Options External, Ghost and Synchronous appear as
12078 Opt := First (Expressions (State));
12079 while Present (Opt) loop
12080 if Nkind (Opt) = N_Identifier then
12084 if Chars (Opt) = Name_External then
12085 Check_Duplicate_Option (Opt, External_Seen);
12086 Analyze_External_Option (Opt);
12090 elsif Chars (Opt) = Name_Ghost then
12091 Check_Duplicate_Option (Opt, Ghost_Seen);
12092 Check_Ghost_Synchronous;
12094 if Present (State_Id) then
12095 Set_Is_Ghost_Entity (State_Id);
12100 elsif Chars (Opt) = Name_Synchronous then
12101 Check_Duplicate_Option (Opt, Synchronous_Seen);
12102 Check_Ghost_Synchronous;
12104 -- Option Part_Of without an encapsulating state is
12105 -- illegal (SPARK RM 7.1.4(8)).
12107 elsif Chars (Opt) = Name_Part_Of then
12109 ("indicator Part_Of must denote abstract state, "
12110 & "single protected type or single task type",
12113 -- Do not emit an error message when a previous state
12114 -- declaration with options was not parenthesized as
12115 -- the option is actually another state declaration.
12117 -- with Abstract_State
12118 -- (State_1 with ..., -- missing parentheses
12119 -- (State_2 with ...),
12120 -- State_3) -- ok state declaration
12122 elsif Missing_Parentheses then
12125 -- Otherwise the option is not allowed. Note that it
12126 -- is not possible to distinguish between an option
12127 -- and a state declaration when a previous state with
12128 -- options not properly parentheses.
12130 -- with Abstract_State
12131 -- (State_1 with ..., -- missing parentheses
12132 -- State_2); -- could be an option
12136 ("simple option not allowed in state declaration",
12140 -- Catch a case where missing parentheses around a state
12141 -- declaration with options cause a subsequent state
12142 -- declaration with options to be treated as an option.
12144 -- with Abstract_State
12145 -- (State_1 with ..., -- missing parentheses
12146 -- (State_2 with ...))
12148 elsif Nkind (Opt) = N_Extension_Aggregate then
12149 Missing_Parentheses := True;
12151 ("state declaration must be parenthesized",
12152 Ancestor_Part (State));
12154 -- Otherwise the option is malformed
12157 SPARK_Msg_N ("malformed option", Opt);
12163 -- Options External and Part_Of appear as component
12166 Opt := First (Component_Associations (State));
12167 while Present (Opt) loop
12168 Opt_Nam := First (Choices (Opt));
12170 if Nkind (Opt_Nam) = N_Identifier then
12171 if Chars (Opt_Nam) = Name_External then
12172 Analyze_External_Option (Opt);
12174 elsif Chars (Opt_Nam) = Name_Part_Of then
12175 Analyze_Part_Of_Option (Opt);
12178 SPARK_Msg_N ("invalid state option", Opt);
12181 SPARK_Msg_N ("invalid state option", Opt);
12187 -- Any other attempt to declare a state is illegal
12190 Malformed_State_Error (State);
12194 -- Guard against a junk state. In such cases no entity is
12195 -- generated and the subsequent checks cannot be applied.
12197 if Present (State_Id) then
12199 -- Verify whether the state does not introduce an illegal
12200 -- hidden state within a package subject to a null abstract
12203 Check_No_Hidden_State (State_Id);
12205 -- Check whether the lack of option Part_Of agrees with the
12206 -- placement of the abstract state with respect to the state
12209 if not Part_Of_Seen then
12210 Check_Missing_Part_Of (State_Id);
12213 -- Associate the state with its related package
12215 if No (Abstract_States (Pack_Id)) then
12216 Set_Abstract_States (Pack_Id, New_Elmt_List);
12219 Append_Elmt (State_Id, Abstract_States (Pack_Id));
12221 end Analyze_Abstract_State;
12223 ---------------------------
12224 -- Malformed_State_Error --
12225 ---------------------------
12227 procedure Malformed_State_Error (State : Node_Id) is
12229 Error_Msg_N ("malformed abstract state declaration", State);
12231 -- An abstract state with a simple option is being declared
12232 -- with "=>" rather than the legal "with". The state appears
12233 -- as a component association.
12235 if Nkind (State) = N_Component_Association then
12236 Error_Msg_N ("\use WITH to specify simple option", State);
12238 end Malformed_State_Error;
12242 Pack_Decl : Node_Id;
12243 Pack_Id : Entity_Id;
12247 -- Start of processing for Abstract_State
12251 Check_No_Identifiers;
12252 Check_Arg_Count (1);
12254 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
12256 if not Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
12257 N_Package_Declaration)
12263 Pack_Id := Defining_Entity (Pack_Decl);
12265 -- A pragma that applies to a Ghost entity becomes Ghost for the
12266 -- purposes of legality checks and removal of ignored Ghost code.
12268 Mark_Ghost_Pragma (N, Pack_Id);
12269 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
12271 -- Chain the pragma on the contract for completeness
12273 Add_Contract_Item (N, Pack_Id);
12275 -- The legality checks of pragmas Abstract_State, Initializes, and
12276 -- Initial_Condition are affected by the SPARK mode in effect. In
12277 -- addition, these three pragmas are subject to an inherent order:
12279 -- 1) Abstract_State
12281 -- 3) Initial_Condition
12283 -- Analyze all these pragmas in the order outlined above
12285 Analyze_If_Present (Pragma_SPARK_Mode);
12286 States := Expression (Get_Argument (N, Pack_Id));
12288 -- Multiple non-null abstract states appear as an aggregate
12290 if Nkind (States) = N_Aggregate then
12291 State := First (Expressions (States));
12292 while Present (State) loop
12293 Analyze_Abstract_State (State, Pack_Id);
12297 -- An abstract state with a simple option is being illegaly
12298 -- declared with "=>" rather than "with". In this case the
12299 -- state declaration appears as a component association.
12301 if Present (Component_Associations (States)) then
12302 State := First (Component_Associations (States));
12303 while Present (State) loop
12304 Malformed_State_Error (State);
12309 -- Various forms of a single abstract state. Note that these may
12310 -- include malformed state declarations.
12313 Analyze_Abstract_State (States, Pack_Id);
12316 Analyze_If_Present (Pragma_Initializes);
12317 Analyze_If_Present (Pragma_Initial_Condition);
12318 end Abstract_State;
12326 -- Note: this pragma also has some specific processing in Par.Prag
12327 -- because we want to set the Ada version mode during parsing.
12329 when Pragma_Ada_83 =>
12331 Check_Arg_Count (0);
12333 -- We really should check unconditionally for proper configuration
12334 -- pragma placement, since we really don't want mixed Ada modes
12335 -- within a single unit, and the GNAT reference manual has always
12336 -- said this was a configuration pragma, but we did not check and
12337 -- are hesitant to add the check now.
12339 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
12340 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
12341 -- or Ada 2012 mode.
12343 if Ada_Version >= Ada_2005 then
12344 Check_Valid_Configuration_Pragma;
12347 -- Now set Ada 83 mode
12349 if Latest_Ada_Only then
12350 Error_Pragma ("??pragma% ignored");
12352 Ada_Version := Ada_83;
12353 Ada_Version_Explicit := Ada_83;
12354 Ada_Version_Pragma := N;
12363 -- Note: this pragma also has some specific processing in Par.Prag
12364 -- because we want to set the Ada 83 version mode during parsing.
12366 when Pragma_Ada_95 =>
12368 Check_Arg_Count (0);
12370 -- We really should check unconditionally for proper configuration
12371 -- pragma placement, since we really don't want mixed Ada modes
12372 -- within a single unit, and the GNAT reference manual has always
12373 -- said this was a configuration pragma, but we did not check and
12374 -- are hesitant to add the check now.
12376 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
12377 -- or Ada 95, so we must check if we are in Ada 2005 mode.
12379 if Ada_Version >= Ada_2005 then
12380 Check_Valid_Configuration_Pragma;
12383 -- Now set Ada 95 mode
12385 if Latest_Ada_Only then
12386 Error_Pragma ("??pragma% ignored");
12388 Ada_Version := Ada_95;
12389 Ada_Version_Explicit := Ada_95;
12390 Ada_Version_Pragma := N;
12393 ---------------------
12394 -- Ada_05/Ada_2005 --
12395 ---------------------
12398 -- pragma Ada_05 (LOCAL_NAME);
12400 -- pragma Ada_2005;
12401 -- pragma Ada_2005 (LOCAL_NAME):
12403 -- Note: these pragmas also have some specific processing in Par.Prag
12404 -- because we want to set the Ada 2005 version mode during parsing.
12406 -- The one argument form is used for managing the transition from
12407 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
12408 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
12409 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
12410 -- mode, a preference rule is established which does not choose
12411 -- such an entity unless it is unambiguously specified. This avoids
12412 -- extra subprograms marked this way from generating ambiguities in
12413 -- otherwise legal pre-Ada_2005 programs. The one argument form is
12414 -- intended for exclusive use in the GNAT run-time library.
12425 if Arg_Count = 1 then
12426 Check_Arg_Is_Local_Name (Arg1);
12427 E_Id := Get_Pragma_Arg (Arg1);
12429 if Etype (E_Id) = Any_Type then
12433 Set_Is_Ada_2005_Only (Entity (E_Id));
12434 Record_Rep_Item (Entity (E_Id), N);
12437 Check_Arg_Count (0);
12439 -- For Ada_2005 we unconditionally enforce the documented
12440 -- configuration pragma placement, since we do not want to
12441 -- tolerate mixed modes in a unit involving Ada 2005. That
12442 -- would cause real difficulties for those cases where there
12443 -- are incompatibilities between Ada 95 and Ada 2005.
12445 Check_Valid_Configuration_Pragma;
12447 -- Now set appropriate Ada mode
12449 if Latest_Ada_Only then
12450 Error_Pragma ("??pragma% ignored");
12452 Ada_Version := Ada_2005;
12453 Ada_Version_Explicit := Ada_2005;
12454 Ada_Version_Pragma := N;
12459 ---------------------
12460 -- Ada_12/Ada_2012 --
12461 ---------------------
12464 -- pragma Ada_12 (LOCAL_NAME);
12466 -- pragma Ada_2012;
12467 -- pragma Ada_2012 (LOCAL_NAME):
12469 -- Note: these pragmas also have some specific processing in Par.Prag
12470 -- because we want to set the Ada 2012 version mode during parsing.
12472 -- The one argument form is used for managing the transition from Ada
12473 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
12474 -- as Ada_2012 only, then referencing the entity in any pre-Ada_2012
12475 -- mode will generate a warning. In addition, in any pre-Ada_2012
12476 -- mode, a preference rule is established which does not choose
12477 -- such an entity unless it is unambiguously specified. This avoids
12478 -- extra subprograms marked this way from generating ambiguities in
12479 -- otherwise legal pre-Ada_2012 programs. The one argument form is
12480 -- intended for exclusive use in the GNAT run-time library.
12491 if Arg_Count = 1 then
12492 Check_Arg_Is_Local_Name (Arg1);
12493 E_Id := Get_Pragma_Arg (Arg1);
12495 if Etype (E_Id) = Any_Type then
12499 Set_Is_Ada_2012_Only (Entity (E_Id));
12500 Record_Rep_Item (Entity (E_Id), N);
12503 Check_Arg_Count (0);
12505 -- For Ada_2012 we unconditionally enforce the documented
12506 -- configuration pragma placement, since we do not want to
12507 -- tolerate mixed modes in a unit involving Ada 2012. That
12508 -- would cause real difficulties for those cases where there
12509 -- are incompatibilities between Ada 95 and Ada 2012. We could
12510 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
12512 Check_Valid_Configuration_Pragma;
12514 -- Now set appropriate Ada mode
12516 Ada_Version := Ada_2012;
12517 Ada_Version_Explicit := Ada_2012;
12518 Ada_Version_Pragma := N;
12526 -- pragma Ada_2020;
12528 -- Note: this pragma also has some specific processing in Par.Prag
12529 -- because we want to set the Ada 2020 version mode during parsing.
12531 when Pragma_Ada_2020 =>
12534 Check_Arg_Count (0);
12536 Check_Valid_Configuration_Pragma;
12538 -- Now set appropriate Ada mode
12540 Ada_Version := Ada_2020;
12541 Ada_Version_Explicit := Ada_2020;
12542 Ada_Version_Pragma := N;
12544 -------------------------------------
12545 -- Aggregate_Individually_Assign --
12546 -------------------------------------
12548 -- pragma Aggregate_Individually_Assign;
12550 when Pragma_Aggregate_Individually_Assign =>
12552 Check_Arg_Count (0);
12553 Check_Valid_Configuration_Pragma;
12554 Aggregate_Individually_Assign := True;
12556 ----------------------
12557 -- All_Calls_Remote --
12558 ----------------------
12560 -- pragma All_Calls_Remote [(library_package_NAME)];
12562 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
12563 Lib_Entity : Entity_Id;
12566 Check_Ada_83_Warning;
12567 Check_Valid_Library_Unit_Pragma;
12569 if Nkind (N) = N_Null_Statement then
12573 Lib_Entity := Find_Lib_Unit_Name;
12575 -- A pragma that applies to a Ghost entity becomes Ghost for the
12576 -- purposes of legality checks and removal of ignored Ghost code.
12578 Mark_Ghost_Pragma (N, Lib_Entity);
12580 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
12582 if Present (Lib_Entity) and then not Debug_Flag_U then
12583 if not Is_Remote_Call_Interface (Lib_Entity) then
12584 Error_Pragma ("pragma% only apply to rci unit");
12586 -- Set flag for entity of the library unit
12589 Set_Has_All_Calls_Remote (Lib_Entity);
12592 end All_Calls_Remote;
12594 ---------------------------
12595 -- Allow_Integer_Address --
12596 ---------------------------
12598 -- pragma Allow_Integer_Address;
12600 when Pragma_Allow_Integer_Address =>
12602 Check_Valid_Configuration_Pragma;
12603 Check_Arg_Count (0);
12605 -- If Address is a private type, then set the flag to allow
12606 -- integer address values. If Address is not private, then this
12607 -- pragma has no purpose, so it is simply ignored. Not clear if
12608 -- there are any such targets now.
12610 if Opt.Address_Is_Private then
12611 Opt.Allow_Integer_Address := True;
12619 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
12620 -- ARG ::= NAME | EXPRESSION
12622 -- The first two arguments are by convention intended to refer to an
12623 -- external tool and a tool-specific function. These arguments are
12626 when Pragma_Annotate => Annotate : declare
12631 --------------------------
12632 -- Inferred_String_Type --
12633 --------------------------
12635 function Preferred_String_Type (Expr : Node_Id) return Entity_Id;
12636 -- Infer the type to use for a string literal or a concatentation
12637 -- of operands whose types can be inferred. For such expressions,
12638 -- returns the "narrowest" of the three predefined string types
12639 -- that can represent the characters occurring in the expression.
12640 -- For other expressions, returns Empty.
12642 function Preferred_String_Type (Expr : Node_Id) return Entity_Id is
12644 case Nkind (Expr) is
12645 when N_String_Literal =>
12646 if Has_Wide_Wide_Character (Expr) then
12647 return Standard_Wide_Wide_String;
12648 elsif Has_Wide_Character (Expr) then
12649 return Standard_Wide_String;
12651 return Standard_String;
12654 when N_Op_Concat =>
12656 L_Type : constant Entity_Id
12657 := Preferred_String_Type (Left_Opnd (Expr));
12658 R_Type : constant Entity_Id
12659 := Preferred_String_Type (Right_Opnd (Expr));
12661 Type_Table : constant array (1 .. 4) of Entity_Id
12663 Standard_Wide_Wide_String,
12664 Standard_Wide_String,
12667 for Idx in Type_Table'Range loop
12668 if (L_Type = Type_Table (Idx)) or
12669 (R_Type = Type_Table (Idx))
12671 return Type_Table (Idx);
12674 raise Program_Error;
12680 end Preferred_String_Type;
12683 Check_At_Least_N_Arguments (1);
12685 Nam_Arg := Last (Pragma_Argument_Associations (N));
12687 -- Determine whether the last argument is "Entity => local_NAME"
12688 -- and if it is, perform the required semantic checks. Remove the
12689 -- argument from further processing.
12691 if Nkind (Nam_Arg) = N_Pragma_Argument_Association
12692 and then Chars (Nam_Arg) = Name_Entity
12694 Check_Arg_Is_Local_Name (Nam_Arg);
12695 Arg_Count := Arg_Count - 1;
12697 -- A pragma that applies to a Ghost entity becomes Ghost for
12698 -- the purposes of legality checks and removal of ignored Ghost
12701 if Is_Entity_Name (Get_Pragma_Arg (Nam_Arg))
12702 and then Present (Entity (Get_Pragma_Arg (Nam_Arg)))
12704 Mark_Ghost_Pragma (N, Entity (Get_Pragma_Arg (Nam_Arg)));
12707 -- Not allowed in compiler units (bootstrap issues)
12709 Check_Compiler_Unit ("Entity for pragma Annotate", N);
12712 -- Continue the processing with last argument removed for now
12714 Check_Arg_Is_Identifier (Arg1);
12715 Check_No_Identifiers;
12718 -- The second parameter is optional, it is never analyzed
12723 -- Otherwise there is a second parameter
12726 -- The second parameter must be an identifier
12728 Check_Arg_Is_Identifier (Arg2);
12730 -- Process the remaining parameters (if any)
12732 Arg := Next (Arg2);
12733 while Present (Arg) loop
12734 Expr := Get_Pragma_Arg (Arg);
12737 if Is_Entity_Name (Expr) then
12740 -- For string literals and concatenations of string literals
12741 -- we assume Standard_String as the type, unless the string
12742 -- contains wide or wide_wide characters.
12744 elsif Present (Preferred_String_Type (Expr)) then
12745 Resolve (Expr, Preferred_String_Type (Expr));
12747 elsif Is_Overloaded (Expr) then
12748 Error_Pragma_Arg ("ambiguous argument for pragma%", Expr);
12759 -------------------------------------------------
12760 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
12761 -------------------------------------------------
12764 -- ( [Check => ] Boolean_EXPRESSION
12765 -- [, [Message =>] Static_String_EXPRESSION]);
12767 -- pragma Assert_And_Cut
12768 -- ( [Check => ] Boolean_EXPRESSION
12769 -- [, [Message =>] Static_String_EXPRESSION]);
12772 -- ( [Check => ] Boolean_EXPRESSION
12773 -- [, [Message =>] Static_String_EXPRESSION]);
12775 -- pragma Loop_Invariant
12776 -- ( [Check => ] Boolean_EXPRESSION
12777 -- [, [Message =>] Static_String_EXPRESSION]);
12780 | Pragma_Assert_And_Cut
12782 | Pragma_Loop_Invariant
12785 function Contains_Loop_Entry (Expr : Node_Id) return Boolean;
12786 -- Determine whether expression Expr contains a Loop_Entry
12787 -- attribute reference.
12789 -------------------------
12790 -- Contains_Loop_Entry --
12791 -------------------------
12793 function Contains_Loop_Entry (Expr : Node_Id) return Boolean is
12794 Has_Loop_Entry : Boolean := False;
12796 function Process (N : Node_Id) return Traverse_Result;
12797 -- Process function for traversal to look for Loop_Entry
12803 function Process (N : Node_Id) return Traverse_Result is
12805 if Nkind (N) = N_Attribute_Reference
12806 and then Attribute_Name (N) = Name_Loop_Entry
12808 Has_Loop_Entry := True;
12815 procedure Traverse is new Traverse_Proc (Process);
12817 -- Start of processing for Contains_Loop_Entry
12821 return Has_Loop_Entry;
12822 end Contains_Loop_Entry;
12827 New_Args : List_Id;
12829 -- Start of processing for Assert
12832 -- Assert is an Ada 2005 RM-defined pragma
12834 if Prag_Id = Pragma_Assert then
12837 -- The remaining ones are GNAT pragmas
12843 Check_At_Least_N_Arguments (1);
12844 Check_At_Most_N_Arguments (2);
12845 Check_Arg_Order ((Name_Check, Name_Message));
12846 Check_Optional_Identifier (Arg1, Name_Check);
12847 Expr := Get_Pragma_Arg (Arg1);
12849 -- Special processing for Loop_Invariant, Loop_Variant or for
12850 -- other cases where a Loop_Entry attribute is present. If the
12851 -- assertion pragma contains attribute Loop_Entry, ensure that
12852 -- the related pragma is within a loop.
12854 if Prag_Id = Pragma_Loop_Invariant
12855 or else Prag_Id = Pragma_Loop_Variant
12856 or else Contains_Loop_Entry (Expr)
12858 Check_Loop_Pragma_Placement;
12860 -- Perform preanalysis to deal with embedded Loop_Entry
12863 Preanalyze_Assert_Expression (Expr, Any_Boolean);
12866 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
12867 -- a corresponding Check pragma:
12869 -- pragma Check (name, condition [, msg]);
12871 -- Where name is the identifier matching the pragma name. So
12872 -- rewrite pragma in this manner, transfer the message argument
12873 -- if present, and analyze the result
12875 -- Note: When dealing with a semantically analyzed tree, the
12876 -- information that a Check node N corresponds to a source Assert,
12877 -- Assume, or Assert_And_Cut pragma can be retrieved from the
12878 -- pragma kind of Original_Node(N).
12880 New_Args := New_List (
12881 Make_Pragma_Argument_Association (Loc,
12882 Expression => Make_Identifier (Loc, Pname)),
12883 Make_Pragma_Argument_Association (Sloc (Expr),
12884 Expression => Expr));
12886 if Arg_Count > 1 then
12887 Check_Optional_Identifier (Arg2, Name_Message);
12889 -- Provide semantic annotations for optional argument, for
12890 -- ASIS use, before rewriting.
12891 -- Is this still needed???
12893 Preanalyze_And_Resolve (Expression (Arg2), Standard_String);
12894 Append_To (New_Args, New_Copy_Tree (Arg2));
12897 -- Rewrite as Check pragma
12901 Chars => Name_Check,
12902 Pragma_Argument_Associations => New_Args));
12907 ----------------------
12908 -- Assertion_Policy --
12909 ----------------------
12911 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
12913 -- The following form is Ada 2012 only, but we allow it in all modes
12915 -- Pragma Assertion_Policy (
12916 -- ASSERTION_KIND => POLICY_IDENTIFIER
12917 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
12919 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
12921 -- RM_ASSERTION_KIND ::= Assert |
12922 -- Static_Predicate |
12923 -- Dynamic_Predicate |
12928 -- Type_Invariant |
12929 -- Type_Invariant'Class
12931 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
12933 -- Contract_Cases |
12935 -- Default_Initial_Condition |
12937 -- Initial_Condition |
12938 -- Loop_Invariant |
12944 -- Statement_Assertions
12946 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
12947 -- ID_ASSERTION_KIND list contains implementation-defined additions
12948 -- recognized by GNAT. The effect is to control the behavior of
12949 -- identically named aspects and pragmas, depending on the specified
12950 -- policy identifier:
12952 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
12954 -- Note: Check and Ignore are language-defined. Disable is a GNAT
12955 -- implementation-defined addition that results in totally ignoring
12956 -- the corresponding assertion. If Disable is specified, then the
12957 -- argument of the assertion is not even analyzed. This is useful
12958 -- when the aspect/pragma argument references entities in a with'ed
12959 -- package that is replaced by a dummy package in the final build.
12961 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
12962 -- and Type_Invariant'Class were recognized by the parser and
12963 -- transformed into references to the special internal identifiers
12964 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
12965 -- processing is required here.
12967 when Pragma_Assertion_Policy => Assertion_Policy : declare
12968 procedure Resolve_Suppressible (Policy : Node_Id);
12969 -- Converts the assertion policy 'Suppressible' to either Check or
12970 -- Ignore based on whether checks are suppressed via -gnatp.
12972 --------------------------
12973 -- Resolve_Suppressible --
12974 --------------------------
12976 procedure Resolve_Suppressible (Policy : Node_Id) is
12977 Arg : constant Node_Id := Get_Pragma_Arg (Policy);
12981 -- Transform policy argument Suppressible into either Ignore or
12982 -- Check depending on whether checks are enabled or suppressed.
12984 if Chars (Arg) = Name_Suppressible then
12985 if Suppress_Checks then
12986 Nam := Name_Ignore;
12991 Rewrite (Arg, Make_Identifier (Sloc (Arg), Nam));
12993 end Resolve_Suppressible;
13005 -- This can always appear as a configuration pragma
13007 if Is_Configuration_Pragma then
13010 -- It can also appear in a declarative part or package spec in Ada
13011 -- 2012 mode. We allow this in other modes, but in that case we
13012 -- consider that we have an Ada 2012 pragma on our hands.
13015 Check_Is_In_Decl_Part_Or_Package_Spec;
13019 -- One argument case with no identifier (first form above)
13022 and then (Nkind (Arg1) /= N_Pragma_Argument_Association
13023 or else Chars (Arg1) = No_Name)
13025 Check_Arg_Is_One_Of (Arg1,
13026 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
13028 Resolve_Suppressible (Arg1);
13030 -- Treat one argument Assertion_Policy as equivalent to:
13032 -- pragma Check_Policy (Assertion, policy)
13034 -- So rewrite pragma in that manner and link on to the chain
13035 -- of Check_Policy pragmas, marking the pragma as analyzed.
13037 Policy := Get_Pragma_Arg (Arg1);
13041 Chars => Name_Check_Policy,
13042 Pragma_Argument_Associations => New_List (
13043 Make_Pragma_Argument_Association (Loc,
13044 Expression => Make_Identifier (Loc, Name_Assertion)),
13046 Make_Pragma_Argument_Association (Loc,
13048 Make_Identifier (Sloc (Policy), Chars (Policy))))));
13051 -- Here if we have two or more arguments
13054 Check_At_Least_N_Arguments (1);
13057 -- Loop through arguments
13060 while Present (Arg) loop
13061 LocP := Sloc (Arg);
13063 -- Kind must be specified
13065 if Nkind (Arg) /= N_Pragma_Argument_Association
13066 or else Chars (Arg) = No_Name
13069 ("missing assertion kind for pragma%", Arg);
13072 -- Check Kind and Policy have allowed forms
13074 Kind := Chars (Arg);
13075 Policy := Get_Pragma_Arg (Arg);
13077 if not Is_Valid_Assertion_Kind (Kind) then
13079 ("invalid assertion kind for pragma%", Arg);
13082 Check_Arg_Is_One_Of (Arg,
13083 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
13085 Resolve_Suppressible (Arg);
13087 if Kind = Name_Ghost then
13089 -- The Ghost policy must be either Check or Ignore
13090 -- (SPARK RM 6.9(6)).
13092 if not Nam_In (Chars (Policy), Name_Check,
13096 ("argument of pragma % Ghost must be Check or "
13097 & "Ignore", Policy);
13100 -- Pragma Assertion_Policy specifying a Ghost policy
13101 -- cannot occur within a Ghost subprogram or package
13102 -- (SPARK RM 6.9(14)).
13104 if Ghost_Mode > None then
13106 ("pragma % cannot appear within ghost subprogram or "
13111 -- Rewrite the Assertion_Policy pragma as a series of
13112 -- Check_Policy pragmas of the form:
13114 -- Check_Policy (Kind, Policy);
13116 -- Note: the insertion of the pragmas cannot be done with
13117 -- Insert_Action because in the configuration case, there
13118 -- are no scopes on the scope stack and the mechanism will
13121 Insert_Before_And_Analyze (N,
13123 Chars => Name_Check_Policy,
13124 Pragma_Argument_Associations => New_List (
13125 Make_Pragma_Argument_Association (LocP,
13126 Expression => Make_Identifier (LocP, Kind)),
13127 Make_Pragma_Argument_Association (LocP,
13128 Expression => Policy))));
13133 -- Rewrite the Assertion_Policy pragma as null since we have
13134 -- now inserted all the equivalent Check pragmas.
13136 Rewrite (N, Make_Null_Statement (Loc));
13139 end Assertion_Policy;
13141 ------------------------------
13142 -- Assume_No_Invalid_Values --
13143 ------------------------------
13145 -- pragma Assume_No_Invalid_Values (On | Off);
13147 when Pragma_Assume_No_Invalid_Values =>
13149 Check_Valid_Configuration_Pragma;
13150 Check_Arg_Count (1);
13151 Check_No_Identifiers;
13152 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
13154 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
13155 Assume_No_Invalid_Values := True;
13157 Assume_No_Invalid_Values := False;
13160 --------------------------
13161 -- Attribute_Definition --
13162 --------------------------
13164 -- pragma Attribute_Definition
13165 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
13166 -- [Entity =>] LOCAL_NAME,
13167 -- [Expression =>] EXPRESSION | NAME);
13169 when Pragma_Attribute_Definition => Attribute_Definition : declare
13170 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
13175 Check_Arg_Count (3);
13176 Check_Optional_Identifier (Arg1, "attribute");
13177 Check_Optional_Identifier (Arg2, "entity");
13178 Check_Optional_Identifier (Arg3, "expression");
13180 if Nkind (Attribute_Designator) /= N_Identifier then
13181 Error_Msg_N ("attribute name expected", Attribute_Designator);
13185 Check_Arg_Is_Local_Name (Arg2);
13187 -- If the attribute is not recognized, then issue a warning (not
13188 -- an error), and ignore the pragma.
13190 Aname := Chars (Attribute_Designator);
13192 if not Is_Attribute_Name (Aname) then
13193 Bad_Attribute (Attribute_Designator, Aname, Warn => True);
13197 -- Otherwise, rewrite the pragma as an attribute definition clause
13200 Make_Attribute_Definition_Clause (Loc,
13201 Name => Get_Pragma_Arg (Arg2),
13203 Expression => Get_Pragma_Arg (Arg3)));
13205 end Attribute_Definition;
13207 ------------------------------------------------------------------
13208 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
13210 ------------------------------------------------------------------
13212 -- pragma Async_Readers [ (boolean_EXPRESSION) ];
13213 -- pragma Async_Writers [ (boolean_EXPRESSION) ];
13214 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
13215 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
13216 -- pragma No_Caching [ (boolean_EXPRESSION) ];
13218 when Pragma_Async_Readers
13219 | Pragma_Async_Writers
13220 | Pragma_Effective_Reads
13221 | Pragma_Effective_Writes
13222 | Pragma_No_Caching
13224 Async_Effective : declare
13225 Obj_Decl : Node_Id;
13226 Obj_Id : Entity_Id;
13230 Check_No_Identifiers;
13231 Check_At_Most_N_Arguments (1);
13233 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
13235 -- Object declaration
13237 if Nkind (Obj_Decl) /= N_Object_Declaration then
13242 Obj_Id := Defining_Entity (Obj_Decl);
13244 -- Perform minimal verification to ensure that the argument is at
13245 -- least a variable. Subsequent finer grained checks will be done
13246 -- at the end of the declarative region the contains the pragma.
13248 if Ekind (Obj_Id) = E_Variable then
13250 -- A pragma that applies to a Ghost entity becomes Ghost for
13251 -- the purposes of legality checks and removal of ignored Ghost
13254 Mark_Ghost_Pragma (N, Obj_Id);
13256 -- Chain the pragma on the contract for further processing by
13257 -- Analyze_External_Property_In_Decl_Part.
13259 Add_Contract_Item (N, Obj_Id);
13261 -- Analyze the Boolean expression (if any)
13263 if Present (Arg1) then
13264 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
13267 -- Otherwise the external property applies to a constant
13270 Error_Pragma ("pragma % must apply to a volatile object");
13272 end Async_Effective;
13278 -- pragma Asynchronous (LOCAL_NAME);
13280 when Pragma_Asynchronous => Asynchronous : declare
13283 Formal : Entity_Id;
13288 procedure Process_Async_Pragma;
13289 -- Common processing for procedure and access-to-procedure case
13291 --------------------------
13292 -- Process_Async_Pragma --
13293 --------------------------
13295 procedure Process_Async_Pragma is
13298 Set_Is_Asynchronous (Nm);
13302 -- The formals should be of mode IN (RM E.4.1(6))
13305 while Present (S) loop
13306 Formal := Defining_Identifier (S);
13308 if Nkind (Formal) = N_Defining_Identifier
13309 and then Ekind (Formal) /= E_In_Parameter
13312 ("pragma% procedure can only have IN parameter",
13319 Set_Is_Asynchronous (Nm);
13320 end Process_Async_Pragma;
13322 -- Start of processing for pragma Asynchronous
13325 Check_Ada_83_Warning;
13326 Check_No_Identifiers;
13327 Check_Arg_Count (1);
13328 Check_Arg_Is_Local_Name (Arg1);
13330 if Debug_Flag_U then
13334 C_Ent := Cunit_Entity (Current_Sem_Unit);
13335 Analyze (Get_Pragma_Arg (Arg1));
13336 Nm := Entity (Get_Pragma_Arg (Arg1));
13338 -- A pragma that applies to a Ghost entity becomes Ghost for the
13339 -- purposes of legality checks and removal of ignored Ghost code.
13341 Mark_Ghost_Pragma (N, Nm);
13343 if not Is_Remote_Call_Interface (C_Ent)
13344 and then not Is_Remote_Types (C_Ent)
13346 -- This pragma should only appear in an RCI or Remote Types
13347 -- unit (RM E.4.1(4)).
13350 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
13353 if Ekind (Nm) = E_Procedure
13354 and then Nkind (Parent (Nm)) = N_Procedure_Specification
13356 if not Is_Remote_Call_Interface (Nm) then
13358 ("pragma% cannot be applied on non-remote procedure",
13362 L := Parameter_Specifications (Parent (Nm));
13363 Process_Async_Pragma;
13366 elsif Ekind (Nm) = E_Function then
13368 ("pragma% cannot be applied to function", Arg1);
13370 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
13371 if Is_Record_Type (Nm) then
13373 -- A record type that is the Equivalent_Type for a remote
13374 -- access-to-subprogram type.
13376 Decl := Declaration_Node (Corresponding_Remote_Type (Nm));
13379 -- A non-expanded RAS type (distribution is not enabled)
13381 Decl := Declaration_Node (Nm);
13384 if Nkind (Decl) = N_Full_Type_Declaration
13385 and then Nkind (Type_Definition (Decl)) =
13386 N_Access_Procedure_Definition
13388 L := Parameter_Specifications (Type_Definition (Decl));
13389 Process_Async_Pragma;
13391 if Is_Asynchronous (Nm)
13392 and then Expander_Active
13393 and then Get_PCS_Name /= Name_No_DSA
13395 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
13400 ("pragma% cannot reference access-to-function type",
13404 -- Only other possibility is Access-to-class-wide type
13406 elsif Is_Access_Type (Nm)
13407 and then Is_Class_Wide_Type (Designated_Type (Nm))
13409 Check_First_Subtype (Arg1);
13410 Set_Is_Asynchronous (Nm);
13411 if Expander_Active then
13412 RACW_Type_Is_Asynchronous (Nm);
13416 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
13424 -- pragma Atomic (LOCAL_NAME);
13426 when Pragma_Atomic =>
13427 Process_Atomic_Independent_Shared_Volatile;
13429 -----------------------
13430 -- Atomic_Components --
13431 -----------------------
13433 -- pragma Atomic_Components (array_LOCAL_NAME);
13435 -- This processing is shared by Volatile_Components
13437 when Pragma_Atomic_Components
13438 | Pragma_Volatile_Components
13440 Atomic_Components : declare
13446 Check_Ada_83_Warning;
13447 Check_No_Identifiers;
13448 Check_Arg_Count (1);
13449 Check_Arg_Is_Local_Name (Arg1);
13450 E_Id := Get_Pragma_Arg (Arg1);
13452 if Etype (E_Id) = Any_Type then
13456 E := Entity (E_Id);
13458 -- A pragma that applies to a Ghost entity becomes Ghost for the
13459 -- purposes of legality checks and removal of ignored Ghost code.
13461 Mark_Ghost_Pragma (N, E);
13462 Check_Duplicate_Pragma (E);
13464 if Rep_Item_Too_Early (E, N)
13466 Rep_Item_Too_Late (E, N)
13471 D := Declaration_Node (E);
13473 if (Nkind (D) = N_Full_Type_Declaration and then Is_Array_Type (E))
13475 (Nkind (D) = N_Object_Declaration
13476 and then (Ekind (E) = E_Constant
13478 Ekind (E) = E_Variable)
13479 and then Nkind (Object_Definition (D)) =
13480 N_Constrained_Array_Definition)
13482 (Ada_Version >= Ada_2020
13483 and then Nkind (D) = N_Formal_Type_Declaration)
13485 -- The flag is set on the base type, or on the object
13487 if Nkind (D) = N_Full_Type_Declaration then
13488 E := Base_Type (E);
13491 -- Atomic implies both Independent and Volatile
13493 if Prag_Id = Pragma_Atomic_Components then
13494 if Ada_Version >= Ada_2020 then
13496 (Component_Type (Etype (E)), VFA => False);
13499 Set_Has_Atomic_Components (E);
13500 Set_Has_Independent_Components (E);
13503 Set_Has_Volatile_Components (E);
13506 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
13508 end Atomic_Components;
13510 --------------------
13511 -- Attach_Handler --
13512 --------------------
13514 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
13516 when Pragma_Attach_Handler =>
13517 Check_Ada_83_Warning;
13518 Check_No_Identifiers;
13519 Check_Arg_Count (2);
13521 if No_Run_Time_Mode then
13522 Error_Msg_CRT ("Attach_Handler pragma", N);
13524 Check_Interrupt_Or_Attach_Handler;
13526 -- The expression that designates the attribute may depend on a
13527 -- discriminant, and is therefore a per-object expression, to
13528 -- be expanded in the init proc. If expansion is enabled, then
13529 -- perform semantic checks on a copy only.
13534 Parg2 : constant Node_Id := Get_Pragma_Arg (Arg2);
13537 -- In Relaxed_RM_Semantics mode, we allow any static
13538 -- integer value, for compatibility with other compilers.
13540 if Relaxed_RM_Semantics
13541 and then Nkind (Parg2) = N_Integer_Literal
13543 Typ := Standard_Integer;
13545 Typ := RTE (RE_Interrupt_ID);
13548 if Expander_Active then
13549 Temp := New_Copy_Tree (Parg2);
13550 Set_Parent (Temp, N);
13551 Preanalyze_And_Resolve (Temp, Typ);
13554 Resolve (Parg2, Typ);
13558 Process_Interrupt_Or_Attach_Handler;
13561 --------------------
13562 -- C_Pass_By_Copy --
13563 --------------------
13565 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
13567 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
13573 Check_Valid_Configuration_Pragma;
13574 Check_Arg_Count (1);
13575 Check_Optional_Identifier (Arg1, "max_size");
13577 Arg := Get_Pragma_Arg (Arg1);
13578 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
13580 Val := Expr_Value (Arg);
13584 ("maximum size for pragma% must be positive", Arg1);
13586 elsif UI_Is_In_Int_Range (Val) then
13587 Default_C_Record_Mechanism := UI_To_Int (Val);
13589 -- If a giant value is given, Int'Last will do well enough.
13590 -- If sometime someone complains that a record larger than
13591 -- two gigabytes is not copied, we will worry about it then.
13594 Default_C_Record_Mechanism := Mechanism_Type'Last;
13596 end C_Pass_By_Copy;
13602 -- pragma Check ([Name =>] CHECK_KIND,
13603 -- [Check =>] Boolean_EXPRESSION
13604 -- [,[Message =>] String_EXPRESSION]);
13606 -- CHECK_KIND ::= IDENTIFIER |
13609 -- Invariant'Class |
13610 -- Type_Invariant'Class
13612 -- The identifiers Assertions and Statement_Assertions are not
13613 -- allowed, since they have special meaning for Check_Policy.
13615 -- WARNING: The code below manages Ghost regions. Return statements
13616 -- must be replaced by gotos which jump to the end of the code and
13617 -- restore the Ghost mode.
13619 when Pragma_Check => Check : declare
13620 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
13621 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
13622 -- Save the Ghost-related attributes to restore on exit
13628 pragma Warnings (Off, Str);
13631 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
13632 -- the mode now to ensure that any nodes generated during analysis
13633 -- and expansion are marked as Ghost.
13635 Set_Ghost_Mode (N);
13638 Check_At_Least_N_Arguments (2);
13639 Check_At_Most_N_Arguments (3);
13640 Check_Optional_Identifier (Arg1, Name_Name);
13641 Check_Optional_Identifier (Arg2, Name_Check);
13643 if Arg_Count = 3 then
13644 Check_Optional_Identifier (Arg3, Name_Message);
13645 Str := Get_Pragma_Arg (Arg3);
13648 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
13649 Check_Arg_Is_Identifier (Arg1);
13650 Cname := Chars (Get_Pragma_Arg (Arg1));
13652 -- Check forbidden name Assertions or Statement_Assertions
13655 when Name_Assertions =>
13657 ("""Assertions"" is not allowed as a check kind for "
13658 & "pragma%", Arg1);
13660 when Name_Statement_Assertions =>
13662 ("""Statement_Assertions"" is not allowed as a check kind "
13663 & "for pragma%", Arg1);
13669 -- Check applicable policy. We skip this if Checked/Ignored status
13670 -- is already set (e.g. in the case of a pragma from an aspect).
13672 if Is_Checked (N) or else Is_Ignored (N) then
13675 -- For a non-source pragma that is a rewriting of another pragma,
13676 -- copy the Is_Checked/Ignored status from the rewritten pragma.
13678 elsif Is_Rewrite_Substitution (N)
13679 and then Nkind (Original_Node (N)) = N_Pragma
13681 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
13682 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
13684 -- Otherwise query the applicable policy at this point
13687 case Check_Kind (Cname) is
13688 when Name_Ignore =>
13689 Set_Is_Ignored (N, True);
13690 Set_Is_Checked (N, False);
13693 Set_Is_Ignored (N, False);
13694 Set_Is_Checked (N, True);
13696 -- For disable, rewrite pragma as null statement and skip
13697 -- rest of the analysis of the pragma.
13699 when Name_Disable =>
13700 Rewrite (N, Make_Null_Statement (Loc));
13704 -- No other possibilities
13707 raise Program_Error;
13711 -- If check kind was not Disable, then continue pragma analysis
13713 Expr := Get_Pragma_Arg (Arg2);
13715 -- Mark the pragma (or, if rewritten from an aspect, the original
13716 -- aspect) as enabled. Nothing to do for an internally generated
13717 -- check for a dynamic predicate.
13720 and then not Split_PPC (N)
13721 and then Cname /= Name_Dynamic_Predicate
13723 Set_SCO_Pragma_Enabled (Loc);
13726 -- Deal with analyzing the string argument. If checks are not
13727 -- on we don't want any expansion (since such expansion would
13728 -- not get properly deleted) but we do want to analyze (to get
13729 -- proper references). The Preanalyze_And_Resolve routine does
13730 -- just what we want. Ditto if pragma is active, because it will
13731 -- be rewritten as an if-statement whose analysis will complete
13732 -- analysis and expansion of the string message. This makes a
13733 -- difference in the unusual case where the expression for the
13734 -- string may have a side effect, such as raising an exception.
13735 -- This is mandated by RM 11.4.2, which specifies that the string
13736 -- expression is only evaluated if the check fails and
13737 -- Assertion_Error is to be raised.
13739 if Arg_Count = 3 then
13740 Preanalyze_And_Resolve (Str, Standard_String);
13743 -- Now you might think we could just do the same with the Boolean
13744 -- expression if checks are off (and expansion is on) and then
13745 -- rewrite the check as a null statement. This would work but we
13746 -- would lose the useful warnings about an assertion being bound
13747 -- to fail even if assertions are turned off.
13749 -- So instead we wrap the boolean expression in an if statement
13750 -- that looks like:
13752 -- if False and then condition then
13756 -- The reason we do this rewriting during semantic analysis rather
13757 -- than as part of normal expansion is that we cannot analyze and
13758 -- expand the code for the boolean expression directly, or it may
13759 -- cause insertion of actions that would escape the attempt to
13760 -- suppress the check code.
13762 -- Note that the Sloc for the if statement corresponds to the
13763 -- argument condition, not the pragma itself. The reason for
13764 -- this is that we may generate a warning if the condition is
13765 -- False at compile time, and we do not want to delete this
13766 -- warning when we delete the if statement.
13768 if Expander_Active and Is_Ignored (N) then
13769 Eloc := Sloc (Expr);
13772 Make_If_Statement (Eloc,
13774 Make_And_Then (Eloc,
13775 Left_Opnd => Make_Identifier (Eloc, Name_False),
13776 Right_Opnd => Expr),
13777 Then_Statements => New_List (
13778 Make_Null_Statement (Eloc))));
13780 -- Now go ahead and analyze the if statement
13782 In_Assertion_Expr := In_Assertion_Expr + 1;
13784 -- One rather special treatment. If we are now in Eliminated
13785 -- overflow mode, then suppress overflow checking since we do
13786 -- not want to drag in the bignum stuff if we are in Ignore
13787 -- mode anyway. This is particularly important if we are using
13788 -- a configurable run time that does not support bignum ops.
13790 if Scope_Suppress.Overflow_Mode_Assertions = Eliminated then
13792 Svo : constant Boolean :=
13793 Scope_Suppress.Suppress (Overflow_Check);
13795 Scope_Suppress.Overflow_Mode_Assertions := Strict;
13796 Scope_Suppress.Suppress (Overflow_Check) := True;
13798 Scope_Suppress.Suppress (Overflow_Check) := Svo;
13799 Scope_Suppress.Overflow_Mode_Assertions := Eliminated;
13802 -- Not that special case
13808 -- All done with this check
13810 In_Assertion_Expr := In_Assertion_Expr - 1;
13812 -- Check is active or expansion not active. In these cases we can
13813 -- just go ahead and analyze the boolean with no worries.
13816 In_Assertion_Expr := In_Assertion_Expr + 1;
13817 Analyze_And_Resolve (Expr, Any_Boolean);
13818 In_Assertion_Expr := In_Assertion_Expr - 1;
13821 Restore_Ghost_Region (Saved_GM, Saved_IGR);
13824 --------------------------
13825 -- Check_Float_Overflow --
13826 --------------------------
13828 -- pragma Check_Float_Overflow;
13830 when Pragma_Check_Float_Overflow =>
13832 Check_Valid_Configuration_Pragma;
13833 Check_Arg_Count (0);
13834 Check_Float_Overflow := not Machine_Overflows_On_Target;
13840 -- pragma Check_Name (check_IDENTIFIER);
13842 when Pragma_Check_Name =>
13844 Check_No_Identifiers;
13845 Check_Valid_Configuration_Pragma;
13846 Check_Arg_Count (1);
13847 Check_Arg_Is_Identifier (Arg1);
13850 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
13853 for J in Check_Names.First .. Check_Names.Last loop
13854 if Check_Names.Table (J) = Nam then
13859 Check_Names.Append (Nam);
13866 -- This is the old style syntax, which is still allowed in all modes:
13868 -- pragma Check_Policy ([Name =>] CHECK_KIND
13869 -- [Policy =>] POLICY_IDENTIFIER);
13871 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
13873 -- CHECK_KIND ::= IDENTIFIER |
13876 -- Type_Invariant'Class |
13879 -- This is the new style syntax, compatible with Assertion_Policy
13880 -- and also allowed in all modes.
13882 -- Pragma Check_Policy (
13883 -- CHECK_KIND => POLICY_IDENTIFIER
13884 -- {, CHECK_KIND => POLICY_IDENTIFIER});
13886 -- Note: the identifiers Name and Policy are not allowed as
13887 -- Check_Kind values. This avoids ambiguities between the old and
13888 -- new form syntax.
13890 when Pragma_Check_Policy => Check_Policy : declare
13895 Check_At_Least_N_Arguments (1);
13897 -- A Check_Policy pragma can appear either as a configuration
13898 -- pragma, or in a declarative part or a package spec (see RM
13899 -- 11.5(5) for rules for Suppress/Unsuppress which are also
13900 -- followed for Check_Policy).
13902 if not Is_Configuration_Pragma then
13903 Check_Is_In_Decl_Part_Or_Package_Spec;
13906 -- Figure out if we have the old or new syntax. We have the
13907 -- old syntax if the first argument has no identifier, or the
13908 -- identifier is Name.
13910 if Nkind (Arg1) /= N_Pragma_Argument_Association
13911 or else Nam_In (Chars (Arg1), No_Name, Name_Name)
13915 Check_Arg_Count (2);
13916 Check_Optional_Identifier (Arg1, Name_Name);
13917 Kind := Get_Pragma_Arg (Arg1);
13918 Rewrite_Assertion_Kind (Kind,
13919 From_Policy => Comes_From_Source (N));
13920 Check_Arg_Is_Identifier (Arg1);
13922 -- Check forbidden check kind
13924 if Nam_In (Chars (Kind), Name_Name, Name_Policy) then
13925 Error_Msg_Name_2 := Chars (Kind);
13927 ("pragma% does not allow% as check name", Arg1);
13932 Check_Optional_Identifier (Arg2, Name_Policy);
13933 Check_Arg_Is_One_Of
13935 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
13937 -- And chain pragma on the Check_Policy_List for search
13939 Set_Next_Pragma (N, Opt.Check_Policy_List);
13940 Opt.Check_Policy_List := N;
13942 -- For the new syntax, what we do is to convert each argument to
13943 -- an old syntax equivalent. We do that because we want to chain
13944 -- old style Check_Policy pragmas for the search (we don't want
13945 -- to have to deal with multiple arguments in the search).
13956 while Present (Arg) loop
13957 LocP := Sloc (Arg);
13958 Argx := Get_Pragma_Arg (Arg);
13960 -- Kind must be specified
13962 if Nkind (Arg) /= N_Pragma_Argument_Association
13963 or else Chars (Arg) = No_Name
13966 ("missing assertion kind for pragma%", Arg);
13969 -- Construct equivalent old form syntax Check_Policy
13970 -- pragma and insert it to get remaining checks.
13974 Chars => Name_Check_Policy,
13975 Pragma_Argument_Associations => New_List (
13976 Make_Pragma_Argument_Association (LocP,
13978 Make_Identifier (LocP, Chars (Arg))),
13979 Make_Pragma_Argument_Association (Sloc (Argx),
13980 Expression => Argx)));
13984 -- For a configuration pragma, insert old form in
13985 -- the corresponding file.
13987 if Is_Configuration_Pragma then
13988 Insert_After (N, New_P);
13992 Insert_Action (N, New_P);
13996 -- Rewrite original Check_Policy pragma to null, since we
13997 -- have converted it into a series of old syntax pragmas.
13999 Rewrite (N, Make_Null_Statement (Loc));
14009 -- pragma Comment (static_string_EXPRESSION)
14011 -- Processing for pragma Comment shares the circuitry for pragma
14012 -- Ident. The only differences are that Ident enforces a limit of 31
14013 -- characters on its argument, and also enforces limitations on
14014 -- placement for DEC compatibility. Pragma Comment shares neither of
14015 -- these restrictions.
14017 -------------------
14018 -- Common_Object --
14019 -------------------
14021 -- pragma Common_Object (
14022 -- [Internal =>] LOCAL_NAME
14023 -- [, [External =>] EXTERNAL_SYMBOL]
14024 -- [, [Size =>] EXTERNAL_SYMBOL]);
14026 -- Processing for this pragma is shared with Psect_Object
14028 ----------------------------------------------
14029 -- Compile_Time_Error, Compile_Time_Warning --
14030 ----------------------------------------------
14032 -- pragma Compile_Time_Error
14033 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14035 -- pragma Compile_Time_Warning
14036 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14038 when Pragma_Compile_Time_Error | Pragma_Compile_Time_Warning =>
14040 Process_Compile_Time_Warning_Or_Error;
14042 ---------------------------
14043 -- Compiler_Unit_Warning --
14044 ---------------------------
14046 -- pragma Compiler_Unit_Warning;
14050 -- Originally, we had only pragma Compiler_Unit, and it resulted in
14051 -- errors not warnings. This means that we had introduced a big extra
14052 -- inertia to compiler changes, since even if we implemented a new
14053 -- feature, and even if all versions to be used for bootstrapping
14054 -- implemented this new feature, we could not use it, since old
14055 -- compilers would give errors for using this feature in units
14056 -- having Compiler_Unit pragmas.
14058 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
14059 -- problem. We no longer have any units mentioning Compiler_Unit,
14060 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
14061 -- and thus generates a warning which can be ignored. So that deals
14062 -- with the problem of old compilers not implementing the newer form
14065 -- Newer compilers recognize the new pragma, but generate warning
14066 -- messages instead of errors, which again can be ignored in the
14067 -- case of an old compiler which implements a wanted new feature
14068 -- but at the time felt like warning about it for older compilers.
14070 -- We retain Compiler_Unit so that new compilers can be used to build
14071 -- older run-times that use this pragma. That's an unusual case, but
14072 -- it's easy enough to handle, so why not?
14074 when Pragma_Compiler_Unit
14075 | Pragma_Compiler_Unit_Warning
14078 Check_Arg_Count (0);
14080 -- Only recognized in main unit
14082 if Current_Sem_Unit = Main_Unit then
14083 Compiler_Unit := True;
14086 -----------------------------
14087 -- Complete_Representation --
14088 -----------------------------
14090 -- pragma Complete_Representation;
14092 when Pragma_Complete_Representation =>
14094 Check_Arg_Count (0);
14096 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
14098 ("pragma & must appear within record representation clause");
14101 ----------------------------
14102 -- Complex_Representation --
14103 ----------------------------
14105 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
14107 when Pragma_Complex_Representation => Complex_Representation : declare
14114 Check_Arg_Count (1);
14115 Check_Optional_Identifier (Arg1, Name_Entity);
14116 Check_Arg_Is_Local_Name (Arg1);
14117 E_Id := Get_Pragma_Arg (Arg1);
14119 if Etype (E_Id) = Any_Type then
14123 E := Entity (E_Id);
14125 if not Is_Record_Type (E) then
14127 ("argument for pragma% must be record type", Arg1);
14130 Ent := First_Entity (E);
14133 or else No (Next_Entity (Ent))
14134 or else Present (Next_Entity (Next_Entity (Ent)))
14135 or else not Is_Floating_Point_Type (Etype (Ent))
14136 or else Etype (Ent) /= Etype (Next_Entity (Ent))
14139 ("record for pragma% must have two fields of the same "
14140 & "floating-point type", Arg1);
14143 Set_Has_Complex_Representation (Base_Type (E));
14145 -- We need to treat the type has having a non-standard
14146 -- representation, for back-end purposes, even though in
14147 -- general a complex will have the default representation
14148 -- of a record with two real components.
14150 Set_Has_Non_Standard_Rep (Base_Type (E));
14152 end Complex_Representation;
14154 -------------------------
14155 -- Component_Alignment --
14156 -------------------------
14158 -- pragma Component_Alignment (
14159 -- [Form =>] ALIGNMENT_CHOICE
14160 -- [, [Name =>] type_LOCAL_NAME]);
14162 -- ALIGNMENT_CHOICE ::=
14164 -- | Component_Size_4
14168 when Pragma_Component_Alignment => Component_AlignmentP : declare
14169 Args : Args_List (1 .. 2);
14170 Names : constant Name_List (1 .. 2) := (
14174 Form : Node_Id renames Args (1);
14175 Name : Node_Id renames Args (2);
14177 Atype : Component_Alignment_Kind;
14182 Gather_Associations (Names, Args);
14185 Error_Pragma ("missing Form argument for pragma%");
14188 Check_Arg_Is_Identifier (Form);
14190 -- Get proper alignment, note that Default = Component_Size on all
14191 -- machines we have so far, and we want to set this value rather
14192 -- than the default value to indicate that it has been explicitly
14193 -- set (and thus will not get overridden by the default component
14194 -- alignment for the current scope)
14196 if Chars (Form) = Name_Component_Size then
14197 Atype := Calign_Component_Size;
14199 elsif Chars (Form) = Name_Component_Size_4 then
14200 Atype := Calign_Component_Size_4;
14202 elsif Chars (Form) = Name_Default then
14203 Atype := Calign_Component_Size;
14205 elsif Chars (Form) = Name_Storage_Unit then
14206 Atype := Calign_Storage_Unit;
14210 ("invalid Form parameter for pragma%", Form);
14213 -- The pragma appears in a configuration file
14215 if No (Parent (N)) then
14216 Check_Valid_Configuration_Pragma;
14218 -- Capture the component alignment in a global variable when
14219 -- the pragma appears in a configuration file. Note that the
14220 -- scope stack is empty at this point and cannot be used to
14221 -- store the alignment value.
14223 Configuration_Component_Alignment := Atype;
14225 -- Case with no name, supplied, affects scope table entry
14227 elsif No (Name) then
14229 (Scope_Stack.Last).Component_Alignment_Default := Atype;
14231 -- Case of name supplied
14234 Check_Arg_Is_Local_Name (Name);
14236 Typ := Entity (Name);
14239 or else Rep_Item_Too_Early (Typ, N)
14243 Typ := Underlying_Type (Typ);
14246 if not Is_Record_Type (Typ)
14247 and then not Is_Array_Type (Typ)
14250 ("Name parameter of pragma% must identify record or "
14251 & "array type", Name);
14254 -- An explicit Component_Alignment pragma overrides an
14255 -- implicit pragma Pack, but not an explicit one.
14257 if not Has_Pragma_Pack (Base_Type (Typ)) then
14258 Set_Is_Packed (Base_Type (Typ), False);
14259 Set_Component_Alignment (Base_Type (Typ), Atype);
14262 end Component_AlignmentP;
14264 --------------------------------
14265 -- Constant_After_Elaboration --
14266 --------------------------------
14268 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
14270 when Pragma_Constant_After_Elaboration => Constant_After_Elaboration :
14272 Obj_Decl : Node_Id;
14273 Obj_Id : Entity_Id;
14277 Check_No_Identifiers;
14278 Check_At_Most_N_Arguments (1);
14280 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
14282 if Nkind (Obj_Decl) /= N_Object_Declaration then
14287 Obj_Id := Defining_Entity (Obj_Decl);
14289 -- The object declaration must be a library-level variable which
14290 -- is either explicitly initialized or obtains a value during the
14291 -- elaboration of a package body (SPARK RM 3.3.1).
14293 if Ekind (Obj_Id) = E_Variable then
14294 if not Is_Library_Level_Entity (Obj_Id) then
14296 ("pragma % must apply to a library level variable");
14300 -- Otherwise the pragma applies to a constant, which is illegal
14303 Error_Pragma ("pragma % must apply to a variable declaration");
14307 -- A pragma that applies to a Ghost entity becomes Ghost for the
14308 -- purposes of legality checks and removal of ignored Ghost code.
14310 Mark_Ghost_Pragma (N, Obj_Id);
14312 -- Chain the pragma on the contract for completeness
14314 Add_Contract_Item (N, Obj_Id);
14316 -- Analyze the Boolean expression (if any)
14318 if Present (Arg1) then
14319 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
14321 end Constant_After_Elaboration;
14323 --------------------
14324 -- Contract_Cases --
14325 --------------------
14327 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
14329 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
14331 -- CASE_GUARD ::= boolean_EXPRESSION | others
14333 -- CONSEQUENCE ::= boolean_EXPRESSION
14335 -- Characteristics:
14337 -- * Analysis - The annotation undergoes initial checks to verify
14338 -- the legal placement and context. Secondary checks preanalyze the
14341 -- Analyze_Contract_Cases_In_Decl_Part
14343 -- * Expansion - The annotation is expanded during the expansion of
14344 -- the related subprogram [body] contract as performed in:
14346 -- Expand_Subprogram_Contract
14348 -- * Template - The annotation utilizes the generic template of the
14349 -- related subprogram [body] when it is:
14351 -- aspect on subprogram declaration
14352 -- aspect on stand-alone subprogram body
14353 -- pragma on stand-alone subprogram body
14355 -- The annotation must prepare its own template when it is:
14357 -- pragma on subprogram declaration
14359 -- * Globals - Capture of global references must occur after full
14362 -- * Instance - The annotation is instantiated automatically when
14363 -- the related generic subprogram [body] is instantiated except for
14364 -- the "pragma on subprogram declaration" case. In that scenario
14365 -- the annotation must instantiate itself.
14367 when Pragma_Contract_Cases => Contract_Cases : declare
14368 Spec_Id : Entity_Id;
14369 Subp_Decl : Node_Id;
14370 Subp_Spec : Node_Id;
14374 Check_No_Identifiers;
14375 Check_Arg_Count (1);
14377 -- Ensure the proper placement of the pragma. Contract_Cases must
14378 -- be associated with a subprogram declaration or a body that acts
14382 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
14386 if Nkind (Subp_Decl) = N_Entry_Declaration then
14389 -- Generic subprogram
14391 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
14394 -- Body acts as spec
14396 elsif Nkind (Subp_Decl) = N_Subprogram_Body
14397 and then No (Corresponding_Spec (Subp_Decl))
14401 -- Body stub acts as spec
14403 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
14404 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
14410 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
14411 Subp_Spec := Specification (Subp_Decl);
14413 -- Pragma Contract_Cases is forbidden on null procedures, as
14414 -- this may lead to potential ambiguities in behavior when
14415 -- interface null procedures are involved.
14417 if Nkind (Subp_Spec) = N_Procedure_Specification
14418 and then Null_Present (Subp_Spec)
14420 Error_Msg_N (Fix_Error
14421 ("pragma % cannot apply to null procedure"), N);
14430 Spec_Id := Unique_Defining_Entity (Subp_Decl);
14432 -- A pragma that applies to a Ghost entity becomes Ghost for the
14433 -- purposes of legality checks and removal of ignored Ghost code.
14435 Mark_Ghost_Pragma (N, Spec_Id);
14436 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
14438 -- Chain the pragma on the contract for further processing by
14439 -- Analyze_Contract_Cases_In_Decl_Part.
14441 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
14443 -- Fully analyze the pragma when it appears inside an entry
14444 -- or subprogram body because it cannot benefit from forward
14447 if Nkind_In (Subp_Decl, N_Entry_Body,
14449 N_Subprogram_Body_Stub)
14451 -- The legality checks of pragma Contract_Cases are affected by
14452 -- the SPARK mode in effect and the volatility of the context.
14453 -- Analyze all pragmas in a specific order.
14455 Analyze_If_Present (Pragma_SPARK_Mode);
14456 Analyze_If_Present (Pragma_Volatile_Function);
14457 Analyze_Contract_Cases_In_Decl_Part (N);
14459 end Contract_Cases;
14465 -- pragma Controlled (first_subtype_LOCAL_NAME);
14467 when Pragma_Controlled => Controlled : declare
14471 Check_No_Identifiers;
14472 Check_Arg_Count (1);
14473 Check_Arg_Is_Local_Name (Arg1);
14474 Arg := Get_Pragma_Arg (Arg1);
14476 if not Is_Entity_Name (Arg)
14477 or else not Is_Access_Type (Entity (Arg))
14479 Error_Pragma_Arg ("pragma% requires access type", Arg1);
14481 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
14489 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
14490 -- [Entity =>] LOCAL_NAME);
14492 when Pragma_Convention => Convention : declare
14495 pragma Warnings (Off, C);
14496 pragma Warnings (Off, E);
14499 Check_Arg_Order ((Name_Convention, Name_Entity));
14500 Check_Ada_83_Warning;
14501 Check_Arg_Count (2);
14502 Process_Convention (C, E);
14504 -- A pragma that applies to a Ghost entity becomes Ghost for the
14505 -- purposes of legality checks and removal of ignored Ghost code.
14507 Mark_Ghost_Pragma (N, E);
14510 ---------------------------
14511 -- Convention_Identifier --
14512 ---------------------------
14514 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
14515 -- [Convention =>] convention_IDENTIFIER);
14517 when Pragma_Convention_Identifier => Convention_Identifier : declare
14523 Check_Arg_Order ((Name_Name, Name_Convention));
14524 Check_Arg_Count (2);
14525 Check_Optional_Identifier (Arg1, Name_Name);
14526 Check_Optional_Identifier (Arg2, Name_Convention);
14527 Check_Arg_Is_Identifier (Arg1);
14528 Check_Arg_Is_Identifier (Arg2);
14529 Idnam := Chars (Get_Pragma_Arg (Arg1));
14530 Cname := Chars (Get_Pragma_Arg (Arg2));
14532 if Is_Convention_Name (Cname) then
14533 Record_Convention_Identifier
14534 (Idnam, Get_Convention_Id (Cname));
14537 ("second arg for % pragma must be convention", Arg2);
14539 end Convention_Identifier;
14545 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
14547 when Pragma_CPP_Class =>
14550 if Warn_On_Obsolescent_Feature then
14552 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
14553 & "effect; replace it by pragma import?j?", N);
14556 Check_Arg_Count (1);
14560 Chars => Name_Import,
14561 Pragma_Argument_Associations => New_List (
14562 Make_Pragma_Argument_Association (Loc,
14563 Expression => Make_Identifier (Loc, Name_CPP)),
14564 New_Copy (First (Pragma_Argument_Associations (N))))));
14567 ---------------------
14568 -- CPP_Constructor --
14569 ---------------------
14571 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
14572 -- [, [External_Name =>] static_string_EXPRESSION ]
14573 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14575 when Pragma_CPP_Constructor => CPP_Constructor : declare
14578 Def_Id : Entity_Id;
14579 Tag_Typ : Entity_Id;
14583 Check_At_Least_N_Arguments (1);
14584 Check_At_Most_N_Arguments (3);
14585 Check_Optional_Identifier (Arg1, Name_Entity);
14586 Check_Arg_Is_Local_Name (Arg1);
14588 Id := Get_Pragma_Arg (Arg1);
14589 Find_Program_Unit_Name (Id);
14591 -- If we did not find the name, we are done
14593 if Etype (Id) = Any_Type then
14597 Def_Id := Entity (Id);
14599 -- Check if already defined as constructor
14601 if Is_Constructor (Def_Id) then
14603 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
14607 if Ekind (Def_Id) = E_Function
14608 and then (Is_CPP_Class (Etype (Def_Id))
14609 or else (Is_Class_Wide_Type (Etype (Def_Id))
14611 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
14613 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
14615 ("'C'P'P constructor must be defined in the scope of "
14616 & "its returned type", Arg1);
14619 if Arg_Count >= 2 then
14620 Set_Imported (Def_Id);
14621 Set_Is_Public (Def_Id);
14622 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
14625 Set_Has_Completion (Def_Id);
14626 Set_Is_Constructor (Def_Id);
14627 Set_Convention (Def_Id, Convention_CPP);
14629 -- Imported C++ constructors are not dispatching primitives
14630 -- because in C++ they don't have a dispatch table slot.
14631 -- However, in Ada the constructor has the profile of a
14632 -- function that returns a tagged type and therefore it has
14633 -- been treated as a primitive operation during semantic
14634 -- analysis. We now remove it from the list of primitive
14635 -- operations of the type.
14637 if Is_Tagged_Type (Etype (Def_Id))
14638 and then not Is_Class_Wide_Type (Etype (Def_Id))
14639 and then Is_Dispatching_Operation (Def_Id)
14641 Tag_Typ := Etype (Def_Id);
14643 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
14644 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
14648 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
14649 Set_Is_Dispatching_Operation (Def_Id, False);
14652 -- For backward compatibility, if the constructor returns a
14653 -- class wide type, and we internally change the return type to
14654 -- the corresponding root type.
14656 if Is_Class_Wide_Type (Etype (Def_Id)) then
14657 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
14661 ("pragma% requires function returning a 'C'P'P_Class type",
14664 end CPP_Constructor;
14670 when Pragma_CPP_Virtual =>
14673 if Warn_On_Obsolescent_Feature then
14675 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
14683 when Pragma_CPP_Vtable =>
14686 if Warn_On_Obsolescent_Feature then
14688 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
14696 -- pragma CPU (EXPRESSION);
14698 when Pragma_CPU => CPU : declare
14699 P : constant Node_Id := Parent (N);
14705 Check_No_Identifiers;
14706 Check_Arg_Count (1);
14710 if Nkind (P) = N_Subprogram_Body then
14711 Check_In_Main_Program;
14713 Arg := Get_Pragma_Arg (Arg1);
14714 Analyze_And_Resolve (Arg, Any_Integer);
14716 Ent := Defining_Unit_Name (Specification (P));
14718 if Nkind (Ent) = N_Defining_Program_Unit_Name then
14719 Ent := Defining_Identifier (Ent);
14724 if not Is_OK_Static_Expression (Arg) then
14725 Flag_Non_Static_Expr
14726 ("main subprogram affinity is not static!", Arg);
14729 -- If constraint error, then we already signalled an error
14731 elsif Raises_Constraint_Error (Arg) then
14734 -- Otherwise check in range
14738 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
14739 -- This is the entity System.Multiprocessors.CPU_Range;
14741 Val : constant Uint := Expr_Value (Arg);
14744 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
14746 Val > Expr_Value (Type_High_Bound (CPU_Id))
14749 ("main subprogram CPU is out of range", Arg1);
14755 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
14759 elsif Nkind (P) = N_Task_Definition then
14760 Arg := Get_Pragma_Arg (Arg1);
14761 Ent := Defining_Identifier (Parent (P));
14763 -- The expression must be analyzed in the special manner
14764 -- described in "Handling of Default and Per-Object
14765 -- Expressions" in sem.ads.
14767 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
14769 -- Anything else is incorrect
14775 -- Check duplicate pragma before we chain the pragma in the Rep
14776 -- Item chain of Ent.
14778 Check_Duplicate_Pragma (Ent);
14779 Record_Rep_Item (Ent, N);
14782 --------------------
14783 -- Deadline_Floor --
14784 --------------------
14786 -- pragma Deadline_Floor (time_span_EXPRESSION);
14788 when Pragma_Deadline_Floor => Deadline_Floor : declare
14789 P : constant Node_Id := Parent (N);
14795 Check_No_Identifiers;
14796 Check_Arg_Count (1);
14798 Arg := Get_Pragma_Arg (Arg1);
14800 -- The expression must be analyzed in the special manner described
14801 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
14803 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
14805 -- Only protected types allowed
14807 if Nkind (P) /= N_Protected_Definition then
14811 Ent := Defining_Identifier (Parent (P));
14813 -- Check duplicate pragma before we chain the pragma in the Rep
14814 -- Item chain of Ent.
14816 Check_Duplicate_Pragma (Ent);
14817 Record_Rep_Item (Ent, N);
14819 end Deadline_Floor;
14825 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
14827 when Pragma_Debug => Debug : declare
14834 -- The condition for executing the call is that the expander
14835 -- is active and that we are not ignoring this debug pragma.
14840 (Expander_Active and then not Is_Ignored (N)),
14843 if not Is_Ignored (N) then
14844 Set_SCO_Pragma_Enabled (Loc);
14847 if Arg_Count = 2 then
14849 Make_And_Then (Loc,
14850 Left_Opnd => Relocate_Node (Cond),
14851 Right_Opnd => Get_Pragma_Arg (Arg1));
14852 Call := Get_Pragma_Arg (Arg2);
14854 Call := Get_Pragma_Arg (Arg1);
14857 if Nkind_In (Call, N_Expanded_Name,
14860 N_Indexed_Component,
14861 N_Selected_Component)
14863 -- If this pragma Debug comes from source, its argument was
14864 -- parsed as a name form (which is syntactically identical).
14865 -- In a generic context a parameterless call will be left as
14866 -- an expanded name (if global) or selected_component if local.
14867 -- Change it to a procedure call statement now.
14869 Change_Name_To_Procedure_Call_Statement (Call);
14871 elsif Nkind (Call) = N_Procedure_Call_Statement then
14873 -- Already in the form of a procedure call statement: nothing
14874 -- to do (could happen in case of an internally generated
14880 -- All other cases: diagnose error
14883 ("argument of pragma ""Debug"" is not procedure call",
14888 -- Rewrite into a conditional with an appropriate condition. We
14889 -- wrap the procedure call in a block so that overhead from e.g.
14890 -- use of the secondary stack does not generate execution overhead
14891 -- for suppressed conditions.
14893 -- Normally the analysis that follows will freeze the subprogram
14894 -- being called. However, if the call is to a null procedure,
14895 -- we want to freeze it before creating the block, because the
14896 -- analysis that follows may be done with expansion disabled, in
14897 -- which case the body will not be generated, leading to spurious
14900 if Nkind (Call) = N_Procedure_Call_Statement
14901 and then Is_Entity_Name (Name (Call))
14903 Analyze (Name (Call));
14904 Freeze_Before (N, Entity (Name (Call)));
14908 Make_Implicit_If_Statement (N,
14910 Then_Statements => New_List (
14911 Make_Block_Statement (Loc,
14912 Handled_Statement_Sequence =>
14913 Make_Handled_Sequence_Of_Statements (Loc,
14914 Statements => New_List (Relocate_Node (Call)))))));
14917 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
14918 -- after analysis of the normally rewritten node, to capture all
14919 -- references to entities, which avoids issuing wrong warnings
14920 -- about unused entities.
14922 if GNATprove_Mode then
14923 Rewrite (N, Make_Null_Statement (Loc));
14931 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
14933 when Pragma_Debug_Policy =>
14935 Check_Arg_Count (1);
14936 Check_No_Identifiers;
14937 Check_Arg_Is_Identifier (Arg1);
14939 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
14940 -- rewrite it that way, and let the rest of the checking come
14941 -- from analyzing the rewritten pragma.
14945 Chars => Name_Check_Policy,
14946 Pragma_Argument_Associations => New_List (
14947 Make_Pragma_Argument_Association (Loc,
14948 Expression => Make_Identifier (Loc, Name_Debug)),
14950 Make_Pragma_Argument_Association (Loc,
14951 Expression => Get_Pragma_Arg (Arg1)))));
14954 -------------------------------
14955 -- Default_Initial_Condition --
14956 -------------------------------
14958 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
14960 when Pragma_Default_Initial_Condition => DIC : declare
14967 Check_No_Identifiers;
14968 Check_At_Most_N_Arguments (1);
14972 while Present (Stmt) loop
14974 -- Skip prior pragmas, but check for duplicates
14976 if Nkind (Stmt) = N_Pragma then
14977 if Pragma_Name (Stmt) = Pname then
14984 -- Skip internally generated code. Note that derived type
14985 -- declarations of untagged types with discriminants are
14986 -- rewritten as private type declarations.
14988 elsif not Comes_From_Source (Stmt)
14989 and then Nkind (Stmt) /= N_Private_Type_Declaration
14993 -- The associated private type [extension] has been found, stop
14996 elsif Nkind_In (Stmt, N_Private_Extension_Declaration,
14997 N_Private_Type_Declaration)
14999 Typ := Defining_Entity (Stmt);
15002 -- The pragma does not apply to a legal construct, issue an
15003 -- error and stop the analysis.
15010 Stmt := Prev (Stmt);
15013 -- The pragma does not apply to a legal construct, issue an error
15014 -- and stop the analysis.
15021 -- A pragma that applies to a Ghost entity becomes Ghost for the
15022 -- purposes of legality checks and removal of ignored Ghost code.
15024 Mark_Ghost_Pragma (N, Typ);
15026 -- The pragma signals that the type defines its own DIC assertion
15029 Set_Has_Own_DIC (Typ);
15031 -- Chain the pragma on the rep item chain for further processing
15033 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
15035 -- Create the declaration of the procedure which verifies the
15036 -- assertion expression of pragma DIC at runtime.
15038 Build_DIC_Procedure_Declaration (Typ);
15041 ----------------------------------
15042 -- Default_Scalar_Storage_Order --
15043 ----------------------------------
15045 -- pragma Default_Scalar_Storage_Order
15046 -- (High_Order_First | Low_Order_First);
15048 when Pragma_Default_Scalar_Storage_Order => DSSO : declare
15049 Default : Character;
15053 Check_Arg_Count (1);
15055 -- Default_Scalar_Storage_Order can appear as a configuration
15056 -- pragma, or in a declarative part of a package spec.
15058 if not Is_Configuration_Pragma then
15059 Check_Is_In_Decl_Part_Or_Package_Spec;
15062 Check_No_Identifiers;
15063 Check_Arg_Is_One_Of
15064 (Arg1, Name_High_Order_First, Name_Low_Order_First);
15065 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
15066 Default := Fold_Upper (Name_Buffer (1));
15068 if not Support_Nondefault_SSO_On_Target
15069 and then (Ttypes.Bytes_Big_Endian /= (Default = 'H'))
15071 if Warn_On_Unrecognized_Pragma then
15073 ("non-default Scalar_Storage_Order not supported "
15074 & "on target?g?", N);
15076 ("\pragma Default_Scalar_Storage_Order ignored?g?", N);
15079 -- Here set the specified default
15082 Opt.Default_SSO := Default;
15086 --------------------------
15087 -- Default_Storage_Pool --
15088 --------------------------
15090 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
15092 when Pragma_Default_Storage_Pool => Default_Storage_Pool : declare
15097 Check_Arg_Count (1);
15099 -- Default_Storage_Pool can appear as a configuration pragma, or
15100 -- in a declarative part of a package spec.
15102 if not Is_Configuration_Pragma then
15103 Check_Is_In_Decl_Part_Or_Package_Spec;
15106 if From_Aspect_Specification (N) then
15108 E : constant Entity_Id := Entity (Corresponding_Aspect (N));
15110 if not In_Open_Scopes (E) then
15112 ("aspect must apply to package or subprogram", N);
15117 if Present (Arg1) then
15118 Pool := Get_Pragma_Arg (Arg1);
15120 -- Case of Default_Storage_Pool (null);
15122 if Nkind (Pool) = N_Null then
15125 -- This is an odd case, this is not really an expression,
15126 -- so we don't have a type for it. So just set the type to
15129 Set_Etype (Pool, Empty);
15131 -- Case of Default_Storage_Pool (storage_pool_NAME);
15134 -- If it's a configuration pragma, then the only allowed
15135 -- argument is "null".
15137 if Is_Configuration_Pragma then
15138 Error_Pragma_Arg ("NULL expected", Arg1);
15141 -- The expected type for a non-"null" argument is
15142 -- Root_Storage_Pool'Class, and the pool must be a variable.
15144 Analyze_And_Resolve
15145 (Pool, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
15147 if Is_Variable (Pool) then
15149 -- A pragma that applies to a Ghost entity becomes Ghost
15150 -- for the purposes of legality checks and removal of
15151 -- ignored Ghost code.
15153 Mark_Ghost_Pragma (N, Entity (Pool));
15157 ("default storage pool must be a variable", Arg1);
15161 -- Record the pool name (or null). Freeze.Freeze_Entity for an
15162 -- access type will use this information to set the appropriate
15163 -- attributes of the access type. If the pragma appears in a
15164 -- generic unit it is ignored, given that it may refer to a
15167 if not Inside_A_Generic then
15168 Default_Pool := Pool;
15171 end Default_Storage_Pool;
15177 -- pragma Depends (DEPENDENCY_RELATION);
15179 -- DEPENDENCY_RELATION ::=
15181 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
15183 -- DEPENDENCY_CLAUSE ::=
15184 -- OUTPUT_LIST =>[+] INPUT_LIST
15185 -- | NULL_DEPENDENCY_CLAUSE
15187 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
15189 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
15191 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
15193 -- OUTPUT ::= NAME | FUNCTION_RESULT
15196 -- where FUNCTION_RESULT is a function Result attribute_reference
15198 -- Characteristics:
15200 -- * Analysis - The annotation undergoes initial checks to verify
15201 -- the legal placement and context. Secondary checks fully analyze
15202 -- the dependency clauses in:
15204 -- Analyze_Depends_In_Decl_Part
15206 -- * Expansion - None.
15208 -- * Template - The annotation utilizes the generic template of the
15209 -- related subprogram [body] when it is:
15211 -- aspect on subprogram declaration
15212 -- aspect on stand-alone subprogram body
15213 -- pragma on stand-alone subprogram body
15215 -- The annotation must prepare its own template when it is:
15217 -- pragma on subprogram declaration
15219 -- * Globals - Capture of global references must occur after full
15222 -- * Instance - The annotation is instantiated automatically when
15223 -- the related generic subprogram [body] is instantiated except for
15224 -- the "pragma on subprogram declaration" case. In that scenario
15225 -- the annotation must instantiate itself.
15227 when Pragma_Depends => Depends : declare
15229 Spec_Id : Entity_Id;
15230 Subp_Decl : Node_Id;
15233 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
15237 -- Chain the pragma on the contract for further processing by
15238 -- Analyze_Depends_In_Decl_Part.
15240 Add_Contract_Item (N, Spec_Id);
15242 -- Fully analyze the pragma when it appears inside an entry
15243 -- or subprogram body because it cannot benefit from forward
15246 if Nkind_In (Subp_Decl, N_Entry_Body,
15248 N_Subprogram_Body_Stub)
15250 -- The legality checks of pragmas Depends and Global are
15251 -- affected by the SPARK mode in effect and the volatility
15252 -- of the context. In addition these two pragmas are subject
15253 -- to an inherent order:
15258 -- Analyze all these pragmas in the order outlined above
15260 Analyze_If_Present (Pragma_SPARK_Mode);
15261 Analyze_If_Present (Pragma_Volatile_Function);
15262 Analyze_If_Present (Pragma_Global);
15263 Analyze_Depends_In_Decl_Part (N);
15268 ---------------------
15269 -- Detect_Blocking --
15270 ---------------------
15272 -- pragma Detect_Blocking;
15274 when Pragma_Detect_Blocking =>
15276 Check_Arg_Count (0);
15277 Check_Valid_Configuration_Pragma;
15278 Detect_Blocking := True;
15280 ------------------------------------
15281 -- Disable_Atomic_Synchronization --
15282 ------------------------------------
15284 -- pragma Disable_Atomic_Synchronization [(Entity)];
15286 when Pragma_Disable_Atomic_Synchronization =>
15288 Process_Disable_Enable_Atomic_Sync (Name_Suppress);
15290 -------------------
15291 -- Discard_Names --
15292 -------------------
15294 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
15296 when Pragma_Discard_Names => Discard_Names : declare
15301 Check_Ada_83_Warning;
15303 -- Deal with configuration pragma case
15305 if Arg_Count = 0 and then Is_Configuration_Pragma then
15306 Global_Discard_Names := True;
15309 -- Otherwise, check correct appropriate context
15312 Check_Is_In_Decl_Part_Or_Package_Spec;
15314 if Arg_Count = 0 then
15316 -- If there is no parameter, then from now on this pragma
15317 -- applies to any enumeration, exception or tagged type
15318 -- defined in the current declarative part, and recursively
15319 -- to any nested scope.
15321 Set_Discard_Names (Current_Scope);
15325 Check_Arg_Count (1);
15326 Check_Optional_Identifier (Arg1, Name_On);
15327 Check_Arg_Is_Local_Name (Arg1);
15329 E_Id := Get_Pragma_Arg (Arg1);
15331 if Etype (E_Id) = Any_Type then
15335 E := Entity (E_Id);
15337 -- A pragma that applies to a Ghost entity becomes Ghost for
15338 -- the purposes of legality checks and removal of ignored
15341 Mark_Ghost_Pragma (N, E);
15343 if (Is_First_Subtype (E)
15345 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
15346 or else Ekind (E) = E_Exception
15348 Set_Discard_Names (E);
15349 Record_Rep_Item (E, N);
15353 ("inappropriate entity for pragma%", Arg1);
15359 ------------------------
15360 -- Dispatching_Domain --
15361 ------------------------
15363 -- pragma Dispatching_Domain (EXPRESSION);
15365 when Pragma_Dispatching_Domain => Dispatching_Domain : declare
15366 P : constant Node_Id := Parent (N);
15372 Check_No_Identifiers;
15373 Check_Arg_Count (1);
15375 -- This pragma is born obsolete, but not the aspect
15377 if not From_Aspect_Specification (N) then
15379 (No_Obsolescent_Features, Pragma_Identifier (N));
15382 if Nkind (P) = N_Task_Definition then
15383 Arg := Get_Pragma_Arg (Arg1);
15384 Ent := Defining_Identifier (Parent (P));
15386 -- A pragma that applies to a Ghost entity becomes Ghost for
15387 -- the purposes of legality checks and removal of ignored Ghost
15390 Mark_Ghost_Pragma (N, Ent);
15392 -- The expression must be analyzed in the special manner
15393 -- described in "Handling of Default and Per-Object
15394 -- Expressions" in sem.ads.
15396 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
15398 -- Check duplicate pragma before we chain the pragma in the Rep
15399 -- Item chain of Ent.
15401 Check_Duplicate_Pragma (Ent);
15402 Record_Rep_Item (Ent, N);
15404 -- Anything else is incorrect
15409 end Dispatching_Domain;
15415 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
15417 when Pragma_Elaborate => Elaborate : declare
15422 -- Pragma must be in context items list of a compilation unit
15424 if not Is_In_Context_Clause then
15428 -- Must be at least one argument
15430 if Arg_Count = 0 then
15431 Error_Pragma ("pragma% requires at least one argument");
15434 -- In Ada 83 mode, there can be no items following it in the
15435 -- context list except other pragmas and implicit with clauses
15436 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
15437 -- placement rule does not apply.
15439 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
15441 while Present (Citem) loop
15442 if Nkind (Citem) = N_Pragma
15443 or else (Nkind (Citem) = N_With_Clause
15444 and then Implicit_With (Citem))
15449 ("(Ada 83) pragma% must be at end of context clause");
15456 -- Finally, the arguments must all be units mentioned in a with
15457 -- clause in the same context clause. Note we already checked (in
15458 -- Par.Prag) that the arguments are all identifiers or selected
15462 Outer : while Present (Arg) loop
15463 Citem := First (List_Containing (N));
15464 Inner : while Citem /= N loop
15465 if Nkind (Citem) = N_With_Clause
15466 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
15468 Set_Elaborate_Present (Citem, True);
15469 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
15471 -- With the pragma present, elaboration calls on
15472 -- subprograms from the named unit need no further
15473 -- checks, as long as the pragma appears in the current
15474 -- compilation unit. If the pragma appears in some unit
15475 -- in the context, there might still be a need for an
15476 -- Elaborate_All_Desirable from the current compilation
15477 -- to the named unit, so we keep the check enabled. This
15478 -- does not apply in SPARK mode, where we allow pragma
15479 -- Elaborate, but we don't trust it to be right so we
15480 -- will still insist on the Elaborate_All.
15482 if Legacy_Elaboration_Checks
15483 and then In_Extended_Main_Source_Unit (N)
15484 and then SPARK_Mode /= On
15486 Set_Suppress_Elaboration_Warnings
15487 (Entity (Name (Citem)));
15498 ("argument of pragma% is not withed unit", Arg);
15505 -------------------
15506 -- Elaborate_All --
15507 -------------------
15509 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
15511 when Pragma_Elaborate_All => Elaborate_All : declare
15516 Check_Ada_83_Warning;
15518 -- Pragma must be in context items list of a compilation unit
15520 if not Is_In_Context_Clause then
15524 -- Must be at least one argument
15526 if Arg_Count = 0 then
15527 Error_Pragma ("pragma% requires at least one argument");
15530 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
15531 -- have to appear at the end of the context clause, but may
15532 -- appear mixed in with other items, even in Ada 83 mode.
15534 -- Final check: the arguments must all be units mentioned in
15535 -- a with clause in the same context clause. Note that we
15536 -- already checked (in Par.Prag) that all the arguments are
15537 -- either identifiers or selected components.
15540 Outr : while Present (Arg) loop
15541 Citem := First (List_Containing (N));
15542 Innr : while Citem /= N loop
15543 if Nkind (Citem) = N_With_Clause
15544 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
15546 Set_Elaborate_All_Present (Citem, True);
15547 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
15549 -- Suppress warnings and elaboration checks on the named
15550 -- unit if the pragma is in the current compilation, as
15551 -- for pragma Elaborate.
15553 if Legacy_Elaboration_Checks
15554 and then In_Extended_Main_Source_Unit (N)
15556 Set_Suppress_Elaboration_Warnings
15557 (Entity (Name (Citem)));
15567 Set_Error_Posted (N);
15569 ("argument of pragma% is not withed unit", Arg);
15576 --------------------
15577 -- Elaborate_Body --
15578 --------------------
15580 -- pragma Elaborate_Body [( library_unit_NAME )];
15582 when Pragma_Elaborate_Body => Elaborate_Body : declare
15583 Cunit_Node : Node_Id;
15584 Cunit_Ent : Entity_Id;
15587 Check_Ada_83_Warning;
15588 Check_Valid_Library_Unit_Pragma;
15590 if Nkind (N) = N_Null_Statement then
15594 Cunit_Node := Cunit (Current_Sem_Unit);
15595 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
15597 -- A pragma that applies to a Ghost entity becomes Ghost for the
15598 -- purposes of legality checks and removal of ignored Ghost code.
15600 Mark_Ghost_Pragma (N, Cunit_Ent);
15602 if Nkind_In (Unit (Cunit_Node), N_Package_Body,
15605 Error_Pragma ("pragma% must refer to a spec, not a body");
15607 Set_Body_Required (Cunit_Node);
15608 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
15610 -- If we are in dynamic elaboration mode, then we suppress
15611 -- elaboration warnings for the unit, since it is definitely
15612 -- fine NOT to do dynamic checks at the first level (and such
15613 -- checks will be suppressed because no elaboration boolean
15614 -- is created for Elaborate_Body packages).
15616 -- But in the static model of elaboration, Elaborate_Body is
15617 -- definitely NOT good enough to ensure elaboration safety on
15618 -- its own, since the body may WITH other units that are not
15619 -- safe from an elaboration point of view, so a client must
15620 -- still do an Elaborate_All on such units.
15622 -- Debug flag -gnatdD restores the old behavior of 3.13, where
15623 -- Elaborate_Body always suppressed elab warnings.
15625 if Legacy_Elaboration_Checks
15626 and then (Dynamic_Elaboration_Checks or Debug_Flag_DD)
15628 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
15631 end Elaborate_Body;
15633 ------------------------
15634 -- Elaboration_Checks --
15635 ------------------------
15637 -- pragma Elaboration_Checks (Static | Dynamic);
15639 when Pragma_Elaboration_Checks => Elaboration_Checks : declare
15640 procedure Check_Duplicate_Elaboration_Checks_Pragma;
15641 -- Emit an error if the current context list already contains
15642 -- a previous Elaboration_Checks pragma. This routine raises
15643 -- Pragma_Exit if a duplicate is found.
15645 procedure Ignore_Elaboration_Checks_Pragma;
15646 -- Warn that the effects of the pragma are ignored. This routine
15647 -- raises Pragma_Exit.
15649 -----------------------------------------------
15650 -- Check_Duplicate_Elaboration_Checks_Pragma --
15651 -----------------------------------------------
15653 procedure Check_Duplicate_Elaboration_Checks_Pragma is
15658 while Present (Item) loop
15659 if Nkind (Item) = N_Pragma
15660 and then Pragma_Name (Item) = Name_Elaboration_Checks
15670 end Check_Duplicate_Elaboration_Checks_Pragma;
15672 --------------------------------------
15673 -- Ignore_Elaboration_Checks_Pragma --
15674 --------------------------------------
15676 procedure Ignore_Elaboration_Checks_Pragma is
15678 Error_Msg_Name_1 := Pname;
15679 Error_Msg_N ("??effects of pragma % are ignored", N);
15681 ("\place pragma on initial declaration of library unit", N);
15684 end Ignore_Elaboration_Checks_Pragma;
15688 Context : constant Node_Id := Parent (N);
15691 -- Start of processing for Elaboration_Checks
15695 Check_Arg_Count (1);
15696 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
15698 -- The pragma appears in a configuration file
15700 if No (Context) then
15701 Check_Valid_Configuration_Pragma;
15702 Check_Duplicate_Elaboration_Checks_Pragma;
15704 -- The pragma acts as a configuration pragma in a compilation unit
15706 -- pragma Elaboration_Checks (...);
15707 -- package Pack is ...;
15709 elsif Nkind (Context) = N_Compilation_Unit
15710 and then List_Containing (N) = Context_Items (Context)
15712 Check_Valid_Configuration_Pragma;
15713 Check_Duplicate_Elaboration_Checks_Pragma;
15715 Unt := Unit (Context);
15717 -- The pragma must appear on the initial declaration of a unit.
15718 -- If this is not the case, warn that the effects of the pragma
15721 if Nkind (Unt) = N_Package_Body then
15722 Ignore_Elaboration_Checks_Pragma;
15724 -- Check the Acts_As_Spec flag of the compilation units itself
15725 -- to determine whether the subprogram body completes since it
15726 -- has not been analyzed yet. This is safe because compilation
15727 -- units are not overloadable.
15729 elsif Nkind (Unt) = N_Subprogram_Body
15730 and then not Acts_As_Spec (Context)
15732 Ignore_Elaboration_Checks_Pragma;
15734 elsif Nkind (Unt) = N_Subunit then
15735 Ignore_Elaboration_Checks_Pragma;
15738 -- Otherwise the pragma does not appear at the configuration level
15745 -- At this point the pragma is not a duplicate, and appears in the
15746 -- proper context. Set the elaboration model in effect.
15748 Dynamic_Elaboration_Checks :=
15749 Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic;
15750 end Elaboration_Checks;
15756 -- pragma Eliminate (
15757 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
15758 -- [Entity =>] IDENTIFIER |
15759 -- SELECTED_COMPONENT |
15761 -- [, Source_Location => SOURCE_TRACE]);
15763 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
15764 -- SOURCE_TRACE ::= STRING_LITERAL
15766 when Pragma_Eliminate => Eliminate : declare
15767 Args : Args_List (1 .. 5);
15768 Names : constant Name_List (1 .. 5) := (
15771 Name_Parameter_Types,
15773 Name_Source_Location);
15775 -- Note : Parameter_Types and Result_Type are leftovers from
15776 -- prior implementations of the pragma. They are not generated
15777 -- by the gnatelim tool, and play no role in selecting which
15778 -- of a set of overloaded names is chosen for elimination.
15780 Unit_Name : Node_Id renames Args (1);
15781 Entity : Node_Id renames Args (2);
15782 Parameter_Types : Node_Id renames Args (3);
15783 Result_Type : Node_Id renames Args (4);
15784 Source_Location : Node_Id renames Args (5);
15788 Check_Valid_Configuration_Pragma;
15789 Gather_Associations (Names, Args);
15791 if No (Unit_Name) then
15792 Error_Pragma ("missing Unit_Name argument for pragma%");
15796 and then (Present (Parameter_Types)
15798 Present (Result_Type)
15800 Present (Source_Location))
15802 Error_Pragma ("missing Entity argument for pragma%");
15805 if (Present (Parameter_Types)
15807 Present (Result_Type))
15809 Present (Source_Location)
15812 ("parameter profile and source location cannot be used "
15813 & "together in pragma%");
15816 Process_Eliminate_Pragma
15825 -----------------------------------
15826 -- Enable_Atomic_Synchronization --
15827 -----------------------------------
15829 -- pragma Enable_Atomic_Synchronization [(Entity)];
15831 when Pragma_Enable_Atomic_Synchronization =>
15833 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
15840 -- [ Convention =>] convention_IDENTIFIER,
15841 -- [ Entity =>] LOCAL_NAME
15842 -- [, [External_Name =>] static_string_EXPRESSION ]
15843 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15845 when Pragma_Export => Export : declare
15847 Def_Id : Entity_Id;
15849 pragma Warnings (Off, C);
15852 Check_Ada_83_Warning;
15856 Name_External_Name,
15859 Check_At_Least_N_Arguments (2);
15860 Check_At_Most_N_Arguments (4);
15862 -- In Relaxed_RM_Semantics, support old Ada 83 style:
15863 -- pragma Export (Entity, "external name");
15865 if Relaxed_RM_Semantics
15866 and then Arg_Count = 2
15867 and then Nkind (Expression (Arg2)) = N_String_Literal
15870 Def_Id := Get_Pragma_Arg (Arg1);
15873 if not Is_Entity_Name (Def_Id) then
15874 Error_Pragma_Arg ("entity name required", Arg1);
15877 Def_Id := Entity (Def_Id);
15878 Set_Exported (Def_Id, Arg1);
15881 Process_Convention (C, Def_Id);
15883 -- A pragma that applies to a Ghost entity becomes Ghost for
15884 -- the purposes of legality checks and removal of ignored Ghost
15887 Mark_Ghost_Pragma (N, Def_Id);
15889 if Ekind (Def_Id) /= E_Constant then
15890 Note_Possible_Modification
15891 (Get_Pragma_Arg (Arg2), Sure => False);
15894 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
15895 Set_Exported (Def_Id, Arg2);
15898 -- If the entity is a deferred constant, propagate the information
15899 -- to the full view, because gigi elaborates the full view only.
15901 if Ekind (Def_Id) = E_Constant
15902 and then Present (Full_View (Def_Id))
15905 Id2 : constant Entity_Id := Full_View (Def_Id);
15907 Set_Is_Exported (Id2, Is_Exported (Def_Id));
15908 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
15909 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
15914 ---------------------
15915 -- Export_Function --
15916 ---------------------
15918 -- pragma Export_Function (
15919 -- [Internal =>] LOCAL_NAME
15920 -- [, [External =>] EXTERNAL_SYMBOL]
15921 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15922 -- [, [Result_Type =>] TYPE_DESIGNATOR]
15923 -- [, [Mechanism =>] MECHANISM]
15924 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
15926 -- EXTERNAL_SYMBOL ::=
15928 -- | static_string_EXPRESSION
15930 -- PARAMETER_TYPES ::=
15932 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15934 -- TYPE_DESIGNATOR ::=
15936 -- | subtype_Name ' Access
15940 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15942 -- MECHANISM_ASSOCIATION ::=
15943 -- [formal_parameter_NAME =>] MECHANISM_NAME
15945 -- MECHANISM_NAME ::=
15949 when Pragma_Export_Function => Export_Function : declare
15950 Args : Args_List (1 .. 6);
15951 Names : constant Name_List (1 .. 6) := (
15954 Name_Parameter_Types,
15957 Name_Result_Mechanism);
15959 Internal : Node_Id renames Args (1);
15960 External : Node_Id renames Args (2);
15961 Parameter_Types : Node_Id renames Args (3);
15962 Result_Type : Node_Id renames Args (4);
15963 Mechanism : Node_Id renames Args (5);
15964 Result_Mechanism : Node_Id renames Args (6);
15968 Gather_Associations (Names, Args);
15969 Process_Extended_Import_Export_Subprogram_Pragma (
15970 Arg_Internal => Internal,
15971 Arg_External => External,
15972 Arg_Parameter_Types => Parameter_Types,
15973 Arg_Result_Type => Result_Type,
15974 Arg_Mechanism => Mechanism,
15975 Arg_Result_Mechanism => Result_Mechanism);
15976 end Export_Function;
15978 -------------------
15979 -- Export_Object --
15980 -------------------
15982 -- pragma Export_Object (
15983 -- [Internal =>] LOCAL_NAME
15984 -- [, [External =>] EXTERNAL_SYMBOL]
15985 -- [, [Size =>] EXTERNAL_SYMBOL]);
15987 -- EXTERNAL_SYMBOL ::=
15989 -- | static_string_EXPRESSION
15991 -- PARAMETER_TYPES ::=
15993 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15995 -- TYPE_DESIGNATOR ::=
15997 -- | subtype_Name ' Access
16001 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16003 -- MECHANISM_ASSOCIATION ::=
16004 -- [formal_parameter_NAME =>] MECHANISM_NAME
16006 -- MECHANISM_NAME ::=
16010 when Pragma_Export_Object => Export_Object : declare
16011 Args : Args_List (1 .. 3);
16012 Names : constant Name_List (1 .. 3) := (
16017 Internal : Node_Id renames Args (1);
16018 External : Node_Id renames Args (2);
16019 Size : Node_Id renames Args (3);
16023 Gather_Associations (Names, Args);
16024 Process_Extended_Import_Export_Object_Pragma (
16025 Arg_Internal => Internal,
16026 Arg_External => External,
16030 ----------------------
16031 -- Export_Procedure --
16032 ----------------------
16034 -- pragma Export_Procedure (
16035 -- [Internal =>] LOCAL_NAME
16036 -- [, [External =>] EXTERNAL_SYMBOL]
16037 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16038 -- [, [Mechanism =>] MECHANISM]);
16040 -- EXTERNAL_SYMBOL ::=
16042 -- | static_string_EXPRESSION
16044 -- PARAMETER_TYPES ::=
16046 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16048 -- TYPE_DESIGNATOR ::=
16050 -- | subtype_Name ' Access
16054 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16056 -- MECHANISM_ASSOCIATION ::=
16057 -- [formal_parameter_NAME =>] MECHANISM_NAME
16059 -- MECHANISM_NAME ::=
16063 when Pragma_Export_Procedure => Export_Procedure : declare
16064 Args : Args_List (1 .. 4);
16065 Names : constant Name_List (1 .. 4) := (
16068 Name_Parameter_Types,
16071 Internal : Node_Id renames Args (1);
16072 External : Node_Id renames Args (2);
16073 Parameter_Types : Node_Id renames Args (3);
16074 Mechanism : Node_Id renames Args (4);
16078 Gather_Associations (Names, Args);
16079 Process_Extended_Import_Export_Subprogram_Pragma (
16080 Arg_Internal => Internal,
16081 Arg_External => External,
16082 Arg_Parameter_Types => Parameter_Types,
16083 Arg_Mechanism => Mechanism);
16084 end Export_Procedure;
16090 -- pragma Export_Value (
16091 -- [Value =>] static_integer_EXPRESSION,
16092 -- [Link_Name =>] static_string_EXPRESSION);
16094 when Pragma_Export_Value =>
16096 Check_Arg_Order ((Name_Value, Name_Link_Name));
16097 Check_Arg_Count (2);
16099 Check_Optional_Identifier (Arg1, Name_Value);
16100 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
16102 Check_Optional_Identifier (Arg2, Name_Link_Name);
16103 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
16105 -----------------------------
16106 -- Export_Valued_Procedure --
16107 -----------------------------
16109 -- pragma Export_Valued_Procedure (
16110 -- [Internal =>] LOCAL_NAME
16111 -- [, [External =>] EXTERNAL_SYMBOL,]
16112 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16113 -- [, [Mechanism =>] MECHANISM]);
16115 -- EXTERNAL_SYMBOL ::=
16117 -- | static_string_EXPRESSION
16119 -- PARAMETER_TYPES ::=
16121 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16123 -- TYPE_DESIGNATOR ::=
16125 -- | subtype_Name ' Access
16129 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16131 -- MECHANISM_ASSOCIATION ::=
16132 -- [formal_parameter_NAME =>] MECHANISM_NAME
16134 -- MECHANISM_NAME ::=
16138 when Pragma_Export_Valued_Procedure =>
16139 Export_Valued_Procedure : declare
16140 Args : Args_List (1 .. 4);
16141 Names : constant Name_List (1 .. 4) := (
16144 Name_Parameter_Types,
16147 Internal : Node_Id renames Args (1);
16148 External : Node_Id renames Args (2);
16149 Parameter_Types : Node_Id renames Args (3);
16150 Mechanism : Node_Id renames Args (4);
16154 Gather_Associations (Names, Args);
16155 Process_Extended_Import_Export_Subprogram_Pragma (
16156 Arg_Internal => Internal,
16157 Arg_External => External,
16158 Arg_Parameter_Types => Parameter_Types,
16159 Arg_Mechanism => Mechanism);
16160 end Export_Valued_Procedure;
16162 -------------------
16163 -- Extend_System --
16164 -------------------
16166 -- pragma Extend_System ([Name =>] Identifier);
16168 when Pragma_Extend_System =>
16170 Check_Valid_Configuration_Pragma;
16171 Check_Arg_Count (1);
16172 Check_Optional_Identifier (Arg1, Name_Name);
16173 Check_Arg_Is_Identifier (Arg1);
16175 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
16178 and then Name_Buffer (1 .. 4) = "aux_"
16180 if Present (System_Extend_Pragma_Arg) then
16181 if Chars (Get_Pragma_Arg (Arg1)) =
16182 Chars (Expression (System_Extend_Pragma_Arg))
16186 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
16187 Error_Pragma ("pragma% conflicts with that #");
16191 System_Extend_Pragma_Arg := Arg1;
16193 if not GNAT_Mode then
16194 System_Extend_Unit := Arg1;
16198 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
16201 ------------------------
16202 -- Extensions_Allowed --
16203 ------------------------
16205 -- pragma Extensions_Allowed (ON | OFF);
16207 when Pragma_Extensions_Allowed =>
16209 Check_Arg_Count (1);
16210 Check_No_Identifiers;
16211 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
16213 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
16214 Extensions_Allowed := True;
16215 Ada_Version := Ada_Version_Type'Last;
16218 Extensions_Allowed := False;
16219 Ada_Version := Ada_Version_Explicit;
16220 Ada_Version_Pragma := Empty;
16223 ------------------------
16224 -- Extensions_Visible --
16225 ------------------------
16227 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
16229 -- Characteristics:
16231 -- * Analysis - The annotation is fully analyzed immediately upon
16232 -- elaboration as its expression must be static.
16234 -- * Expansion - None.
16236 -- * Template - The annotation utilizes the generic template of the
16237 -- related subprogram [body] when it is:
16239 -- aspect on subprogram declaration
16240 -- aspect on stand-alone subprogram body
16241 -- pragma on stand-alone subprogram body
16243 -- The annotation must prepare its own template when it is:
16245 -- pragma on subprogram declaration
16247 -- * Globals - Capture of global references must occur after full
16250 -- * Instance - The annotation is instantiated automatically when
16251 -- the related generic subprogram [body] is instantiated except for
16252 -- the "pragma on subprogram declaration" case. In that scenario
16253 -- the annotation must instantiate itself.
16255 when Pragma_Extensions_Visible => Extensions_Visible : declare
16256 Formal : Entity_Id;
16257 Has_OK_Formal : Boolean := False;
16258 Spec_Id : Entity_Id;
16259 Subp_Decl : Node_Id;
16263 Check_No_Identifiers;
16264 Check_At_Most_N_Arguments (1);
16267 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
16269 -- Abstract subprogram declaration
16271 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
16274 -- Generic subprogram declaration
16276 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
16279 -- Body acts as spec
16281 elsif Nkind (Subp_Decl) = N_Subprogram_Body
16282 and then No (Corresponding_Spec (Subp_Decl))
16286 -- Body stub acts as spec
16288 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
16289 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
16293 -- Subprogram declaration
16295 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
16298 -- Otherwise the pragma is associated with an illegal construct
16301 Error_Pragma ("pragma % must apply to a subprogram");
16305 -- Mark the pragma as Ghost if the related subprogram is also
16306 -- Ghost. This also ensures that any expansion performed further
16307 -- below will produce Ghost nodes.
16309 Spec_Id := Unique_Defining_Entity (Subp_Decl);
16310 Mark_Ghost_Pragma (N, Spec_Id);
16312 -- Chain the pragma on the contract for completeness
16314 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
16316 -- The legality checks of pragma Extension_Visible are affected
16317 -- by the SPARK mode in effect. Analyze all pragmas in specific
16320 Analyze_If_Present (Pragma_SPARK_Mode);
16322 -- Examine the formals of the related subprogram
16324 Formal := First_Formal (Spec_Id);
16325 while Present (Formal) loop
16327 -- At least one of the formals is of a specific tagged type,
16328 -- the pragma is legal.
16330 if Is_Specific_Tagged_Type (Etype (Formal)) then
16331 Has_OK_Formal := True;
16334 -- A generic subprogram with at least one formal of a private
16335 -- type ensures the legality of the pragma because the actual
16336 -- may be specifically tagged. Note that this is verified by
16337 -- the check above at instantiation time.
16339 elsif Is_Private_Type (Etype (Formal))
16340 and then Is_Generic_Type (Etype (Formal))
16342 Has_OK_Formal := True;
16346 Next_Formal (Formal);
16349 if not Has_OK_Formal then
16350 Error_Msg_Name_1 := Pname;
16351 Error_Msg_N (Fix_Error ("incorrect placement of pragma %"), N);
16353 ("\subprogram & lacks parameter of specific tagged or "
16354 & "generic private type", N, Spec_Id);
16359 -- Analyze the Boolean expression (if any)
16361 if Present (Arg1) then
16362 Check_Static_Boolean_Expression
16363 (Expression (Get_Argument (N, Spec_Id)));
16365 end Extensions_Visible;
16371 -- pragma External (
16372 -- [ Convention =>] convention_IDENTIFIER,
16373 -- [ Entity =>] LOCAL_NAME
16374 -- [, [External_Name =>] static_string_EXPRESSION ]
16375 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16377 when Pragma_External => External : declare
16380 pragma Warnings (Off, C);
16387 Name_External_Name,
16389 Check_At_Least_N_Arguments (2);
16390 Check_At_Most_N_Arguments (4);
16391 Process_Convention (C, E);
16393 -- A pragma that applies to a Ghost entity becomes Ghost for the
16394 -- purposes of legality checks and removal of ignored Ghost code.
16396 Mark_Ghost_Pragma (N, E);
16398 Note_Possible_Modification
16399 (Get_Pragma_Arg (Arg2), Sure => False);
16400 Process_Interface_Name (E, Arg3, Arg4, N);
16401 Set_Exported (E, Arg2);
16404 --------------------------
16405 -- External_Name_Casing --
16406 --------------------------
16408 -- pragma External_Name_Casing (
16409 -- UPPERCASE | LOWERCASE
16410 -- [, AS_IS | UPPERCASE | LOWERCASE]);
16412 when Pragma_External_Name_Casing =>
16414 Check_No_Identifiers;
16416 if Arg_Count = 2 then
16417 Check_Arg_Is_One_Of
16418 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
16420 case Chars (Get_Pragma_Arg (Arg2)) is
16422 Opt.External_Name_Exp_Casing := As_Is;
16424 when Name_Uppercase =>
16425 Opt.External_Name_Exp_Casing := Uppercase;
16427 when Name_Lowercase =>
16428 Opt.External_Name_Exp_Casing := Lowercase;
16435 Check_Arg_Count (1);
16438 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
16440 case Chars (Get_Pragma_Arg (Arg1)) is
16441 when Name_Uppercase =>
16442 Opt.External_Name_Imp_Casing := Uppercase;
16444 when Name_Lowercase =>
16445 Opt.External_Name_Imp_Casing := Lowercase;
16455 -- pragma Fast_Math;
16457 when Pragma_Fast_Math =>
16459 Check_No_Identifiers;
16460 Check_Valid_Configuration_Pragma;
16463 --------------------------
16464 -- Favor_Top_Level --
16465 --------------------------
16467 -- pragma Favor_Top_Level (type_NAME);
16469 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
16474 Check_No_Identifiers;
16475 Check_Arg_Count (1);
16476 Check_Arg_Is_Local_Name (Arg1);
16477 Typ := Entity (Get_Pragma_Arg (Arg1));
16479 -- A pragma that applies to a Ghost entity becomes Ghost for the
16480 -- purposes of legality checks and removal of ignored Ghost code.
16482 Mark_Ghost_Pragma (N, Typ);
16484 -- If it's an access-to-subprogram type (in particular, not a
16485 -- subtype), set the flag on that type.
16487 if Is_Access_Subprogram_Type (Typ) then
16488 Set_Can_Use_Internal_Rep (Typ, False);
16490 -- Otherwise it's an error (name denotes the wrong sort of entity)
16494 ("access-to-subprogram type expected",
16495 Get_Pragma_Arg (Arg1));
16497 end Favor_Top_Level;
16499 ---------------------------
16500 -- Finalize_Storage_Only --
16501 ---------------------------
16503 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
16505 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
16506 Assoc : constant Node_Id := Arg1;
16507 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
16512 Check_No_Identifiers;
16513 Check_Arg_Count (1);
16514 Check_Arg_Is_Local_Name (Arg1);
16516 Find_Type (Type_Id);
16517 Typ := Entity (Type_Id);
16520 or else Rep_Item_Too_Early (Typ, N)
16524 Typ := Underlying_Type (Typ);
16527 if not Is_Controlled (Typ) then
16528 Error_Pragma ("pragma% must specify controlled type");
16531 Check_First_Subtype (Arg1);
16533 if Finalize_Storage_Only (Typ) then
16534 Error_Pragma ("duplicate pragma%, only one allowed");
16536 elsif not Rep_Item_Too_Late (Typ, N) then
16537 Set_Finalize_Storage_Only (Base_Type (Typ), True);
16539 end Finalize_Storage;
16545 -- pragma Ghost [ (boolean_EXPRESSION) ];
16547 when Pragma_Ghost => Ghost : declare
16551 Orig_Stmt : Node_Id;
16552 Prev_Id : Entity_Id;
16557 Check_No_Identifiers;
16558 Check_At_Most_N_Arguments (1);
16562 while Present (Stmt) loop
16564 -- Skip prior pragmas, but check for duplicates
16566 if Nkind (Stmt) = N_Pragma then
16567 if Pragma_Name (Stmt) = Pname then
16574 -- Task unit declared without a definition cannot be subject to
16575 -- pragma Ghost (SPARK RM 6.9(19)).
16577 elsif Nkind_In (Stmt, N_Single_Task_Declaration,
16578 N_Task_Type_Declaration)
16580 Error_Pragma ("pragma % cannot apply to a task type");
16583 -- Skip internally generated code
16585 elsif not Comes_From_Source (Stmt) then
16586 Orig_Stmt := Original_Node (Stmt);
16588 -- When pragma Ghost applies to an untagged derivation, the
16589 -- derivation is transformed into a [sub]type declaration.
16591 if Nkind_In (Stmt, N_Full_Type_Declaration,
16592 N_Subtype_Declaration)
16593 and then Comes_From_Source (Orig_Stmt)
16594 and then Nkind (Orig_Stmt) = N_Full_Type_Declaration
16595 and then Nkind (Type_Definition (Orig_Stmt)) =
16596 N_Derived_Type_Definition
16598 Id := Defining_Entity (Stmt);
16601 -- When pragma Ghost applies to an object declaration which
16602 -- is initialized by means of a function call that returns
16603 -- on the secondary stack, the object declaration becomes a
16606 elsif Nkind (Stmt) = N_Object_Renaming_Declaration
16607 and then Comes_From_Source (Orig_Stmt)
16608 and then Nkind (Orig_Stmt) = N_Object_Declaration
16610 Id := Defining_Entity (Stmt);
16613 -- When pragma Ghost applies to an expression function, the
16614 -- expression function is transformed into a subprogram.
16616 elsif Nkind (Stmt) = N_Subprogram_Declaration
16617 and then Comes_From_Source (Orig_Stmt)
16618 and then Nkind (Orig_Stmt) = N_Expression_Function
16620 Id := Defining_Entity (Stmt);
16624 -- The pragma applies to a legal construct, stop the traversal
16626 elsif Nkind_In (Stmt, N_Abstract_Subprogram_Declaration,
16627 N_Full_Type_Declaration,
16628 N_Generic_Subprogram_Declaration,
16629 N_Object_Declaration,
16630 N_Private_Extension_Declaration,
16631 N_Private_Type_Declaration,
16632 N_Subprogram_Declaration,
16633 N_Subtype_Declaration)
16635 Id := Defining_Entity (Stmt);
16638 -- The pragma does not apply to a legal construct, issue an
16639 -- error and stop the analysis.
16643 ("pragma % must apply to an object, package, subprogram "
16648 Stmt := Prev (Stmt);
16651 Context := Parent (N);
16653 -- Handle compilation units
16655 if Nkind (Context) = N_Compilation_Unit_Aux then
16656 Context := Unit (Parent (Context));
16659 -- Protected and task types cannot be subject to pragma Ghost
16660 -- (SPARK RM 6.9(19)).
16662 if Nkind_In (Context, N_Protected_Body, N_Protected_Definition)
16664 Error_Pragma ("pragma % cannot apply to a protected type");
16667 elsif Nkind_In (Context, N_Task_Body, N_Task_Definition) then
16668 Error_Pragma ("pragma % cannot apply to a task type");
16674 -- When pragma Ghost is associated with a [generic] package, it
16675 -- appears in the visible declarations.
16677 if Nkind (Context) = N_Package_Specification
16678 and then Present (Visible_Declarations (Context))
16679 and then List_Containing (N) = Visible_Declarations (Context)
16681 Id := Defining_Entity (Context);
16683 -- Pragma Ghost applies to a stand-alone subprogram body
16685 elsif Nkind (Context) = N_Subprogram_Body
16686 and then No (Corresponding_Spec (Context))
16688 Id := Defining_Entity (Context);
16690 -- Pragma Ghost applies to a subprogram declaration that acts
16691 -- as a compilation unit.
16693 elsif Nkind (Context) = N_Subprogram_Declaration then
16694 Id := Defining_Entity (Context);
16696 -- Pragma Ghost applies to a generic subprogram
16698 elsif Nkind (Context) = N_Generic_Subprogram_Declaration then
16699 Id := Defining_Entity (Specification (Context));
16705 ("pragma % must apply to an object, package, subprogram or "
16710 -- Handle completions of types and constants that are subject to
16713 if Is_Record_Type (Id) or else Ekind (Id) = E_Constant then
16714 Prev_Id := Incomplete_Or_Partial_View (Id);
16716 if Present (Prev_Id) and then not Is_Ghost_Entity (Prev_Id) then
16717 Error_Msg_Name_1 := Pname;
16719 -- The full declaration of a deferred constant cannot be
16720 -- subject to pragma Ghost unless the deferred declaration
16721 -- is also Ghost (SPARK RM 6.9(9)).
16723 if Ekind (Prev_Id) = E_Constant then
16724 Error_Msg_Name_1 := Pname;
16725 Error_Msg_NE (Fix_Error
16726 ("pragma % must apply to declaration of deferred "
16727 & "constant &"), N, Id);
16730 -- Pragma Ghost may appear on the full view of an incomplete
16731 -- type because the incomplete declaration lacks aspects and
16732 -- cannot be subject to pragma Ghost.
16734 elsif Ekind (Prev_Id) = E_Incomplete_Type then
16737 -- The full declaration of a type cannot be subject to
16738 -- pragma Ghost unless the partial view is also Ghost
16739 -- (SPARK RM 6.9(9)).
16742 Error_Msg_NE (Fix_Error
16743 ("pragma % must apply to partial view of type &"),
16749 -- A synchronized object cannot be subject to pragma Ghost
16750 -- (SPARK RM 6.9(19)).
16752 elsif Ekind (Id) = E_Variable then
16753 if Is_Protected_Type (Etype (Id)) then
16754 Error_Pragma ("pragma % cannot apply to a protected object");
16757 elsif Is_Task_Type (Etype (Id)) then
16758 Error_Pragma ("pragma % cannot apply to a task object");
16763 -- Analyze the Boolean expression (if any)
16765 if Present (Arg1) then
16766 Expr := Get_Pragma_Arg (Arg1);
16768 Analyze_And_Resolve (Expr, Standard_Boolean);
16770 if Is_OK_Static_Expression (Expr) then
16772 -- "Ghostness" cannot be turned off once enabled within a
16773 -- region (SPARK RM 6.9(6)).
16775 if Is_False (Expr_Value (Expr))
16776 and then Ghost_Mode > None
16779 ("pragma % with value False cannot appear in enabled "
16784 -- Otherwie the expression is not static
16788 ("expression of pragma % must be static", Expr);
16793 Set_Is_Ghost_Entity (Id);
16800 -- pragma Global (GLOBAL_SPECIFICATION);
16802 -- GLOBAL_SPECIFICATION ::=
16805 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
16807 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
16809 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
16810 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
16811 -- GLOBAL_ITEM ::= NAME
16813 -- Characteristics:
16815 -- * Analysis - The annotation undergoes initial checks to verify
16816 -- the legal placement and context. Secondary checks fully analyze
16817 -- the dependency clauses in:
16819 -- Analyze_Global_In_Decl_Part
16821 -- * Expansion - None.
16823 -- * Template - The annotation utilizes the generic template of the
16824 -- related subprogram [body] when it is:
16826 -- aspect on subprogram declaration
16827 -- aspect on stand-alone subprogram body
16828 -- pragma on stand-alone subprogram body
16830 -- The annotation must prepare its own template when it is:
16832 -- pragma on subprogram declaration
16834 -- * Globals - Capture of global references must occur after full
16837 -- * Instance - The annotation is instantiated automatically when
16838 -- the related generic subprogram [body] is instantiated except for
16839 -- the "pragma on subprogram declaration" case. In that scenario
16840 -- the annotation must instantiate itself.
16842 when Pragma_Global => Global : declare
16844 Spec_Id : Entity_Id;
16845 Subp_Decl : Node_Id;
16848 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
16852 -- Chain the pragma on the contract for further processing by
16853 -- Analyze_Global_In_Decl_Part.
16855 Add_Contract_Item (N, Spec_Id);
16857 -- Fully analyze the pragma when it appears inside an entry
16858 -- or subprogram body because it cannot benefit from forward
16861 if Nkind_In (Subp_Decl, N_Entry_Body,
16863 N_Subprogram_Body_Stub)
16865 -- The legality checks of pragmas Depends and Global are
16866 -- affected by the SPARK mode in effect and the volatility
16867 -- of the context. In addition these two pragmas are subject
16868 -- to an inherent order:
16873 -- Analyze all these pragmas in the order outlined above
16875 Analyze_If_Present (Pragma_SPARK_Mode);
16876 Analyze_If_Present (Pragma_Volatile_Function);
16877 Analyze_Global_In_Decl_Part (N);
16878 Analyze_If_Present (Pragma_Depends);
16887 -- pragma Ident (static_string_EXPRESSION)
16889 -- Note: pragma Comment shares this processing. Pragma Ident is
16890 -- identical in effect to pragma Commment.
16892 when Pragma_Comment
16900 Check_Arg_Count (1);
16901 Check_No_Identifiers;
16902 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
16905 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
16912 GP := Parent (Parent (N));
16914 if Nkind_In (GP, N_Package_Declaration,
16915 N_Generic_Package_Declaration)
16920 -- If we have a compilation unit, then record the ident value,
16921 -- checking for improper duplication.
16923 if Nkind (GP) = N_Compilation_Unit then
16924 CS := Ident_String (Current_Sem_Unit);
16926 if Present (CS) then
16928 -- If we have multiple instances, concatenate them.
16930 Start_String (Strval (CS));
16931 Store_String_Char (' ');
16932 Store_String_Chars (Strval (Str));
16933 Set_Strval (CS, End_String);
16936 Set_Ident_String (Current_Sem_Unit, Str);
16939 -- For subunits, we just ignore the Ident, since in GNAT these
16940 -- are not separate object files, and hence not separate units
16941 -- in the unit table.
16943 elsif Nkind (GP) = N_Subunit then
16949 -------------------
16950 -- Ignore_Pragma --
16951 -------------------
16953 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
16955 -- Entirely handled in the parser, nothing to do here
16957 when Pragma_Ignore_Pragma =>
16960 ----------------------------
16961 -- Implementation_Defined --
16962 ----------------------------
16964 -- pragma Implementation_Defined (LOCAL_NAME);
16966 -- Marks previously declared entity as implementation defined. For
16967 -- an overloaded entity, applies to the most recent homonym.
16969 -- pragma Implementation_Defined;
16971 -- The form with no arguments appears anywhere within a scope, most
16972 -- typically a package spec, and indicates that all entities that are
16973 -- defined within the package spec are Implementation_Defined.
16975 when Pragma_Implementation_Defined => Implementation_Defined : declare
16980 Check_No_Identifiers;
16982 -- Form with no arguments
16984 if Arg_Count = 0 then
16985 Set_Is_Implementation_Defined (Current_Scope);
16987 -- Form with one argument
16990 Check_Arg_Count (1);
16991 Check_Arg_Is_Local_Name (Arg1);
16992 Ent := Entity (Get_Pragma_Arg (Arg1));
16993 Set_Is_Implementation_Defined (Ent);
16995 end Implementation_Defined;
17001 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
17003 -- IMPLEMENTATION_KIND ::=
17004 -- By_Entry | By_Protected_Procedure | By_Any | Optional
17006 -- "By_Any" and "Optional" are treated as synonyms in order to
17007 -- support Ada 2012 aspect Synchronization.
17009 when Pragma_Implemented => Implemented : declare
17010 Proc_Id : Entity_Id;
17015 Check_Arg_Count (2);
17016 Check_No_Identifiers;
17017 Check_Arg_Is_Identifier (Arg1);
17018 Check_Arg_Is_Local_Name (Arg1);
17019 Check_Arg_Is_One_Of (Arg2,
17022 Name_By_Protected_Procedure,
17025 -- Extract the name of the local procedure
17027 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
17029 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
17030 -- primitive procedure of a synchronized tagged type.
17032 if Ekind (Proc_Id) = E_Procedure
17033 and then Is_Primitive (Proc_Id)
17034 and then Present (First_Formal (Proc_Id))
17036 Typ := Etype (First_Formal (Proc_Id));
17038 if Is_Tagged_Type (Typ)
17041 -- Check for a protected, a synchronized or a task interface
17043 ((Is_Interface (Typ)
17044 and then Is_Synchronized_Interface (Typ))
17046 -- Check for a protected type or a task type that implements
17050 (Is_Concurrent_Record_Type (Typ)
17051 and then Present (Interfaces (Typ)))
17053 -- In analysis-only mode, examine original protected type
17056 (Nkind (Parent (Typ)) = N_Protected_Type_Declaration
17057 and then Present (Interface_List (Parent (Typ))))
17059 -- Check for a private record extension with keyword
17063 (Ekind_In (Typ, E_Record_Type_With_Private,
17064 E_Record_Subtype_With_Private)
17065 and then Synchronized_Present (Parent (Typ))))
17070 ("controlling formal must be of synchronized tagged type",
17075 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
17076 -- By_Protected_Procedure to the primitive procedure of a task
17079 if Chars (Arg2) = Name_By_Protected_Procedure
17080 and then Is_Interface (Typ)
17081 and then Is_Task_Interface (Typ)
17084 ("implementation kind By_Protected_Procedure cannot be "
17085 & "applied to a task interface primitive", Arg2);
17089 -- Procedures declared inside a protected type must be accepted
17091 elsif Ekind (Proc_Id) = E_Procedure
17092 and then Is_Protected_Type (Scope (Proc_Id))
17096 -- The first argument is not a primitive procedure
17100 ("pragma % must be applied to a primitive procedure", Arg1);
17104 Record_Rep_Item (Proc_Id, N);
17107 ----------------------
17108 -- Implicit_Packing --
17109 ----------------------
17111 -- pragma Implicit_Packing;
17113 when Pragma_Implicit_Packing =>
17115 Check_Arg_Count (0);
17116 Implicit_Packing := True;
17123 -- [Convention =>] convention_IDENTIFIER,
17124 -- [Entity =>] LOCAL_NAME
17125 -- [, [External_Name =>] static_string_EXPRESSION ]
17126 -- [, [Link_Name =>] static_string_EXPRESSION ]);
17128 when Pragma_Import =>
17129 Check_Ada_83_Warning;
17133 Name_External_Name,
17136 Check_At_Least_N_Arguments (2);
17137 Check_At_Most_N_Arguments (4);
17138 Process_Import_Or_Interface;
17140 ---------------------
17141 -- Import_Function --
17142 ---------------------
17144 -- pragma Import_Function (
17145 -- [Internal =>] LOCAL_NAME,
17146 -- [, [External =>] EXTERNAL_SYMBOL]
17147 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17148 -- [, [Result_Type =>] SUBTYPE_MARK]
17149 -- [, [Mechanism =>] MECHANISM]
17150 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
17152 -- EXTERNAL_SYMBOL ::=
17154 -- | static_string_EXPRESSION
17156 -- PARAMETER_TYPES ::=
17158 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17160 -- TYPE_DESIGNATOR ::=
17162 -- | subtype_Name ' Access
17166 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17168 -- MECHANISM_ASSOCIATION ::=
17169 -- [formal_parameter_NAME =>] MECHANISM_NAME
17171 -- MECHANISM_NAME ::=
17175 when Pragma_Import_Function => Import_Function : declare
17176 Args : Args_List (1 .. 6);
17177 Names : constant Name_List (1 .. 6) := (
17180 Name_Parameter_Types,
17183 Name_Result_Mechanism);
17185 Internal : Node_Id renames Args (1);
17186 External : Node_Id renames Args (2);
17187 Parameter_Types : Node_Id renames Args (3);
17188 Result_Type : Node_Id renames Args (4);
17189 Mechanism : Node_Id renames Args (5);
17190 Result_Mechanism : Node_Id renames Args (6);
17194 Gather_Associations (Names, Args);
17195 Process_Extended_Import_Export_Subprogram_Pragma (
17196 Arg_Internal => Internal,
17197 Arg_External => External,
17198 Arg_Parameter_Types => Parameter_Types,
17199 Arg_Result_Type => Result_Type,
17200 Arg_Mechanism => Mechanism,
17201 Arg_Result_Mechanism => Result_Mechanism);
17202 end Import_Function;
17204 -------------------
17205 -- Import_Object --
17206 -------------------
17208 -- pragma Import_Object (
17209 -- [Internal =>] LOCAL_NAME
17210 -- [, [External =>] EXTERNAL_SYMBOL]
17211 -- [, [Size =>] EXTERNAL_SYMBOL]);
17213 -- EXTERNAL_SYMBOL ::=
17215 -- | static_string_EXPRESSION
17217 when Pragma_Import_Object => Import_Object : declare
17218 Args : Args_List (1 .. 3);
17219 Names : constant Name_List (1 .. 3) := (
17224 Internal : Node_Id renames Args (1);
17225 External : Node_Id renames Args (2);
17226 Size : Node_Id renames Args (3);
17230 Gather_Associations (Names, Args);
17231 Process_Extended_Import_Export_Object_Pragma (
17232 Arg_Internal => Internal,
17233 Arg_External => External,
17237 ----------------------
17238 -- Import_Procedure --
17239 ----------------------
17241 -- pragma Import_Procedure (
17242 -- [Internal =>] LOCAL_NAME
17243 -- [, [External =>] EXTERNAL_SYMBOL]
17244 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17245 -- [, [Mechanism =>] MECHANISM]);
17247 -- EXTERNAL_SYMBOL ::=
17249 -- | static_string_EXPRESSION
17251 -- PARAMETER_TYPES ::=
17253 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17255 -- TYPE_DESIGNATOR ::=
17257 -- | subtype_Name ' Access
17261 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17263 -- MECHANISM_ASSOCIATION ::=
17264 -- [formal_parameter_NAME =>] MECHANISM_NAME
17266 -- MECHANISM_NAME ::=
17270 when Pragma_Import_Procedure => Import_Procedure : declare
17271 Args : Args_List (1 .. 4);
17272 Names : constant Name_List (1 .. 4) := (
17275 Name_Parameter_Types,
17278 Internal : Node_Id renames Args (1);
17279 External : Node_Id renames Args (2);
17280 Parameter_Types : Node_Id renames Args (3);
17281 Mechanism : Node_Id renames Args (4);
17285 Gather_Associations (Names, Args);
17286 Process_Extended_Import_Export_Subprogram_Pragma (
17287 Arg_Internal => Internal,
17288 Arg_External => External,
17289 Arg_Parameter_Types => Parameter_Types,
17290 Arg_Mechanism => Mechanism);
17291 end Import_Procedure;
17293 -----------------------------
17294 -- Import_Valued_Procedure --
17295 -----------------------------
17297 -- pragma Import_Valued_Procedure (
17298 -- [Internal =>] LOCAL_NAME
17299 -- [, [External =>] EXTERNAL_SYMBOL]
17300 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17301 -- [, [Mechanism =>] MECHANISM]);
17303 -- EXTERNAL_SYMBOL ::=
17305 -- | static_string_EXPRESSION
17307 -- PARAMETER_TYPES ::=
17309 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17311 -- TYPE_DESIGNATOR ::=
17313 -- | subtype_Name ' Access
17317 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17319 -- MECHANISM_ASSOCIATION ::=
17320 -- [formal_parameter_NAME =>] MECHANISM_NAME
17322 -- MECHANISM_NAME ::=
17326 when Pragma_Import_Valued_Procedure =>
17327 Import_Valued_Procedure : declare
17328 Args : Args_List (1 .. 4);
17329 Names : constant Name_List (1 .. 4) := (
17332 Name_Parameter_Types,
17335 Internal : Node_Id renames Args (1);
17336 External : Node_Id renames Args (2);
17337 Parameter_Types : Node_Id renames Args (3);
17338 Mechanism : Node_Id renames Args (4);
17342 Gather_Associations (Names, Args);
17343 Process_Extended_Import_Export_Subprogram_Pragma (
17344 Arg_Internal => Internal,
17345 Arg_External => External,
17346 Arg_Parameter_Types => Parameter_Types,
17347 Arg_Mechanism => Mechanism);
17348 end Import_Valued_Procedure;
17354 -- pragma Independent (LOCAL_NAME);
17356 when Pragma_Independent =>
17357 Process_Atomic_Independent_Shared_Volatile;
17359 ----------------------------
17360 -- Independent_Components --
17361 ----------------------------
17363 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
17365 when Pragma_Independent_Components => Independent_Components : declare
17372 Check_Ada_83_Warning;
17374 Check_No_Identifiers;
17375 Check_Arg_Count (1);
17376 Check_Arg_Is_Local_Name (Arg1);
17377 E_Id := Get_Pragma_Arg (Arg1);
17379 if Etype (E_Id) = Any_Type then
17383 E := Entity (E_Id);
17385 -- A record type with a self-referential component of anonymous
17386 -- access type is given an incomplete view in order to handle the
17389 -- type Rec is record
17390 -- Self : access Rec;
17396 -- type Ptr is access Rec;
17397 -- type Rec is record
17401 -- Since the incomplete view is now the initial view of the type,
17402 -- the argument of the pragma will reference the incomplete view,
17403 -- but this view is illegal according to the semantics of the
17406 -- Obtain the full view of an internally-generated incomplete type
17407 -- only. This way an attempt to associate the pragma with a source
17408 -- incomplete type is still caught.
17410 if Ekind (E) = E_Incomplete_Type
17411 and then not Comes_From_Source (E)
17412 and then Present (Full_View (E))
17414 E := Full_View (E);
17417 -- A pragma that applies to a Ghost entity becomes Ghost for the
17418 -- purposes of legality checks and removal of ignored Ghost code.
17420 Mark_Ghost_Pragma (N, E);
17422 -- Check duplicate before we chain ourselves
17424 Check_Duplicate_Pragma (E);
17426 -- Check appropriate entity
17428 if Rep_Item_Too_Early (E, N)
17430 Rep_Item_Too_Late (E, N)
17435 D := Declaration_Node (E);
17437 -- The flag is set on the base type, or on the object
17439 if Nkind (D) = N_Full_Type_Declaration
17440 and then (Is_Array_Type (E) or else Is_Record_Type (E))
17442 Set_Has_Independent_Components (Base_Type (E));
17443 Record_Independence_Check (N, Base_Type (E));
17445 -- For record type, set all components independent
17447 if Is_Record_Type (E) then
17448 C := First_Component (E);
17449 while Present (C) loop
17450 Set_Is_Independent (C);
17451 Next_Component (C);
17455 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
17456 and then Nkind (D) = N_Object_Declaration
17457 and then Nkind (Object_Definition (D)) =
17458 N_Constrained_Array_Definition
17460 Set_Has_Independent_Components (E);
17461 Record_Independence_Check (N, E);
17464 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
17466 end Independent_Components;
17468 -----------------------
17469 -- Initial_Condition --
17470 -----------------------
17472 -- pragma Initial_Condition (boolean_EXPRESSION);
17474 -- Characteristics:
17476 -- * Analysis - The annotation undergoes initial checks to verify
17477 -- the legal placement and context. Secondary checks preanalyze the
17480 -- Analyze_Initial_Condition_In_Decl_Part
17482 -- * Expansion - The annotation is expanded during the expansion of
17483 -- the package body whose declaration is subject to the annotation
17486 -- Expand_Pragma_Initial_Condition
17488 -- * Template - The annotation utilizes the generic template of the
17489 -- related package declaration.
17491 -- * Globals - Capture of global references must occur after full
17494 -- * Instance - The annotation is instantiated automatically when
17495 -- the related generic package is instantiated.
17497 when Pragma_Initial_Condition => Initial_Condition : declare
17498 Pack_Decl : Node_Id;
17499 Pack_Id : Entity_Id;
17503 Check_No_Identifiers;
17504 Check_Arg_Count (1);
17506 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
17508 if not Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
17509 N_Package_Declaration)
17515 Pack_Id := Defining_Entity (Pack_Decl);
17517 -- A pragma that applies to a Ghost entity becomes Ghost for the
17518 -- purposes of legality checks and removal of ignored Ghost code.
17520 Mark_Ghost_Pragma (N, Pack_Id);
17522 -- Chain the pragma on the contract for further processing by
17523 -- Analyze_Initial_Condition_In_Decl_Part.
17525 Add_Contract_Item (N, Pack_Id);
17527 -- The legality checks of pragmas Abstract_State, Initializes, and
17528 -- Initial_Condition are affected by the SPARK mode in effect. In
17529 -- addition, these three pragmas are subject to an inherent order:
17531 -- 1) Abstract_State
17533 -- 3) Initial_Condition
17535 -- Analyze all these pragmas in the order outlined above
17537 Analyze_If_Present (Pragma_SPARK_Mode);
17538 Analyze_If_Present (Pragma_Abstract_State);
17539 Analyze_If_Present (Pragma_Initializes);
17540 end Initial_Condition;
17542 ------------------------
17543 -- Initialize_Scalars --
17544 ------------------------
17546 -- pragma Initialize_Scalars
17547 -- [ ( TYPE_VALUE_PAIR {, TYPE_VALUE_PAIR} ) ];
17549 -- TYPE_VALUE_PAIR ::=
17550 -- SCALAR_TYPE => static_EXPRESSION
17556 -- | Long_Long_Flat
17566 when Pragma_Initialize_Scalars => Do_Initialize_Scalars : declare
17567 Seen : array (Scalar_Id) of Node_Id := (others => Empty);
17568 -- This collection holds the individual pairs which specify the
17569 -- invalid values of their respective scalar types.
17571 procedure Analyze_Float_Value
17572 (Scal_Typ : Float_Scalar_Id;
17573 Val_Expr : Node_Id);
17574 -- Analyze a type value pair associated with float type Scal_Typ
17575 -- and expression Val_Expr.
17577 procedure Analyze_Integer_Value
17578 (Scal_Typ : Integer_Scalar_Id;
17579 Val_Expr : Node_Id);
17580 -- Analyze a type value pair associated with integer type Scal_Typ
17581 -- and expression Val_Expr.
17583 procedure Analyze_Type_Value_Pair (Pair : Node_Id);
17584 -- Analyze type value pair Pair
17586 -------------------------
17587 -- Analyze_Float_Value --
17588 -------------------------
17590 procedure Analyze_Float_Value
17591 (Scal_Typ : Float_Scalar_Id;
17592 Val_Expr : Node_Id)
17595 Analyze_And_Resolve (Val_Expr, Any_Real);
17597 if Is_OK_Static_Expression (Val_Expr) then
17598 Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value_R (Val_Expr));
17601 Error_Msg_Name_1 := Scal_Typ;
17602 Error_Msg_N ("value for type % must be static", Val_Expr);
17604 end Analyze_Float_Value;
17606 ---------------------------
17607 -- Analyze_Integer_Value --
17608 ---------------------------
17610 procedure Analyze_Integer_Value
17611 (Scal_Typ : Integer_Scalar_Id;
17612 Val_Expr : Node_Id)
17615 Analyze_And_Resolve (Val_Expr, Any_Integer);
17617 if Is_OK_Static_Expression (Val_Expr) then
17618 Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value (Val_Expr));
17621 Error_Msg_Name_1 := Scal_Typ;
17622 Error_Msg_N ("value for type % must be static", Val_Expr);
17624 end Analyze_Integer_Value;
17626 -----------------------------
17627 -- Analyze_Type_Value_Pair --
17628 -----------------------------
17630 procedure Analyze_Type_Value_Pair (Pair : Node_Id) is
17631 Scal_Typ : constant Name_Id := Chars (Pair);
17632 Val_Expr : constant Node_Id := Expression (Pair);
17633 Prev_Pair : Node_Id;
17636 if Scal_Typ in Scalar_Id then
17637 Prev_Pair := Seen (Scal_Typ);
17639 -- Prevent multiple attempts to set a value for a scalar
17642 if Present (Prev_Pair) then
17643 Error_Msg_Name_1 := Scal_Typ;
17645 ("cannot specify multiple invalid values for type %",
17648 Error_Msg_Sloc := Sloc (Prev_Pair);
17649 Error_Msg_N ("previous value set #", Pair);
17651 -- Ignore the effects of the pair, but do not halt the
17652 -- analysis of the pragma altogether.
17656 -- Otherwise capture the first pair for this scalar type
17659 Seen (Scal_Typ) := Pair;
17662 if Scal_Typ in Float_Scalar_Id then
17663 Analyze_Float_Value (Scal_Typ, Val_Expr);
17665 else pragma Assert (Scal_Typ in Integer_Scalar_Id);
17666 Analyze_Integer_Value (Scal_Typ, Val_Expr);
17669 -- Otherwise the scalar family is illegal
17672 Error_Msg_Name_1 := Pname;
17674 ("argument of pragma % must denote valid scalar family",
17677 end Analyze_Type_Value_Pair;
17681 Pairs : constant List_Id := Pragma_Argument_Associations (N);
17684 -- Start of processing for Do_Initialize_Scalars
17688 Check_Valid_Configuration_Pragma;
17689 Check_Restriction (No_Initialize_Scalars, N);
17691 -- Ignore the effects of the pragma when No_Initialize_Scalars is
17694 if Restriction_Active (No_Initialize_Scalars) then
17697 -- Initialize_Scalars creates false positives in CodePeer, and
17698 -- incorrect negative results in GNATprove mode, so ignore this
17699 -- pragma in these modes.
17701 elsif CodePeer_Mode or GNATprove_Mode then
17704 -- Otherwise analyze the pragma
17707 if Present (Pairs) then
17709 -- Install Standard in order to provide access to primitive
17710 -- types in case the expressions contain attributes such as
17713 Push_Scope (Standard_Standard);
17715 Pair := First (Pairs);
17716 while Present (Pair) loop
17717 Analyze_Type_Value_Pair (Pair);
17726 Init_Or_Norm_Scalars := True;
17727 Initialize_Scalars := True;
17729 end Do_Initialize_Scalars;
17735 -- pragma Initializes (INITIALIZATION_LIST);
17737 -- INITIALIZATION_LIST ::=
17739 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
17741 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
17746 -- | (INPUT {, INPUT})
17750 -- Characteristics:
17752 -- * Analysis - The annotation undergoes initial checks to verify
17753 -- the legal placement and context. Secondary checks preanalyze the
17756 -- Analyze_Initializes_In_Decl_Part
17758 -- * Expansion - None.
17760 -- * Template - The annotation utilizes the generic template of the
17761 -- related package declaration.
17763 -- * Globals - Capture of global references must occur after full
17766 -- * Instance - The annotation is instantiated automatically when
17767 -- the related generic package is instantiated.
17769 when Pragma_Initializes => Initializes : declare
17770 Pack_Decl : Node_Id;
17771 Pack_Id : Entity_Id;
17775 Check_No_Identifiers;
17776 Check_Arg_Count (1);
17778 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
17780 if not Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
17781 N_Package_Declaration)
17787 Pack_Id := Defining_Entity (Pack_Decl);
17789 -- A pragma that applies to a Ghost entity becomes Ghost for the
17790 -- purposes of legality checks and removal of ignored Ghost code.
17792 Mark_Ghost_Pragma (N, Pack_Id);
17793 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
17795 -- Chain the pragma on the contract for further processing by
17796 -- Analyze_Initializes_In_Decl_Part.
17798 Add_Contract_Item (N, Pack_Id);
17800 -- The legality checks of pragmas Abstract_State, Initializes, and
17801 -- Initial_Condition are affected by the SPARK mode in effect. In
17802 -- addition, these three pragmas are subject to an inherent order:
17804 -- 1) Abstract_State
17806 -- 3) Initial_Condition
17808 -- Analyze all these pragmas in the order outlined above
17810 Analyze_If_Present (Pragma_SPARK_Mode);
17811 Analyze_If_Present (Pragma_Abstract_State);
17812 Analyze_If_Present (Pragma_Initial_Condition);
17819 -- pragma Inline ( NAME {, NAME} );
17821 when Pragma_Inline =>
17823 -- Pragma always active unless in GNATprove mode. It is disabled
17824 -- in GNATprove mode because frontend inlining is applied
17825 -- independently of pragmas Inline and Inline_Always for
17826 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
17829 if not GNATprove_Mode then
17831 -- Inline status is Enabled if option -gnatn is specified.
17832 -- However this status determines only the value of the
17833 -- Is_Inlined flag on the subprogram and does not prevent
17834 -- the pragma itself from being recorded for later use,
17835 -- in particular for a later modification of Is_Inlined
17836 -- independently of the -gnatn option.
17838 -- In other words, if -gnatn is specified for a unit, then
17839 -- all Inline pragmas processed for the compilation of this
17840 -- unit, including those in the spec of other units, are
17841 -- activated, so subprograms will be inlined across units.
17843 -- If -gnatn is not specified, no Inline pragma is activated
17844 -- here, which means that subprograms will not be inlined
17845 -- across units. The Is_Inlined flag will nevertheless be
17846 -- set later when bodies are analyzed, so subprograms will
17847 -- be inlined within the unit.
17849 if Inline_Active then
17850 Process_Inline (Enabled);
17852 Process_Inline (Disabled);
17856 -------------------
17857 -- Inline_Always --
17858 -------------------
17860 -- pragma Inline_Always ( NAME {, NAME} );
17862 when Pragma_Inline_Always =>
17865 -- Pragma always active unless in CodePeer mode or GNATprove
17866 -- mode. It is disabled in CodePeer mode because inlining is
17867 -- not helpful, and enabling it caused walk order issues. It
17868 -- is disabled in GNATprove mode because frontend inlining is
17869 -- applied independently of pragmas Inline and Inline_Always for
17870 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
17873 if not CodePeer_Mode and not GNATprove_Mode then
17874 Process_Inline (Enabled);
17877 --------------------
17878 -- Inline_Generic --
17879 --------------------
17881 -- pragma Inline_Generic (NAME {, NAME});
17883 when Pragma_Inline_Generic =>
17885 Process_Generic_List;
17887 ----------------------
17888 -- Inspection_Point --
17889 ----------------------
17891 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
17893 when Pragma_Inspection_Point => Inspection_Point : declare
17900 if Arg_Count > 0 then
17903 Exp := Get_Pragma_Arg (Arg);
17906 if not Is_Entity_Name (Exp)
17907 or else not Is_Object (Entity (Exp))
17909 Error_Pragma_Arg ("object name required", Arg);
17913 exit when No (Arg);
17916 end Inspection_Point;
17922 -- pragma Interface (
17923 -- [ Convention =>] convention_IDENTIFIER,
17924 -- [ Entity =>] LOCAL_NAME
17925 -- [, [External_Name =>] static_string_EXPRESSION ]
17926 -- [, [Link_Name =>] static_string_EXPRESSION ]);
17928 when Pragma_Interface =>
17933 Name_External_Name,
17935 Check_At_Least_N_Arguments (2);
17936 Check_At_Most_N_Arguments (4);
17937 Process_Import_Or_Interface;
17939 -- In Ada 2005, the permission to use Interface (a reserved word)
17940 -- as a pragma name is considered an obsolescent feature, and this
17941 -- pragma was already obsolescent in Ada 95.
17943 if Ada_Version >= Ada_95 then
17945 (No_Obsolescent_Features, Pragma_Identifier (N));
17947 if Warn_On_Obsolescent_Feature then
17949 ("pragma Interface is an obsolescent feature?j?", N);
17951 ("|use pragma Import instead?j?", N);
17955 --------------------
17956 -- Interface_Name --
17957 --------------------
17959 -- pragma Interface_Name (
17960 -- [ Entity =>] LOCAL_NAME
17961 -- [,[External_Name =>] static_string_EXPRESSION ]
17962 -- [,[Link_Name =>] static_string_EXPRESSION ]);
17964 when Pragma_Interface_Name => Interface_Name : declare
17966 Def_Id : Entity_Id;
17967 Hom_Id : Entity_Id;
17973 ((Name_Entity, Name_External_Name, Name_Link_Name));
17974 Check_At_Least_N_Arguments (2);
17975 Check_At_Most_N_Arguments (3);
17976 Id := Get_Pragma_Arg (Arg1);
17979 -- This is obsolete from Ada 95 on, but it is an implementation
17980 -- defined pragma, so we do not consider that it violates the
17981 -- restriction (No_Obsolescent_Features).
17983 if Ada_Version >= Ada_95 then
17984 if Warn_On_Obsolescent_Feature then
17986 ("pragma Interface_Name is an obsolescent feature?j?", N);
17988 ("|use pragma Import instead?j?", N);
17992 if not Is_Entity_Name (Id) then
17994 ("first argument for pragma% must be entity name", Arg1);
17995 elsif Etype (Id) = Any_Type then
17998 Def_Id := Entity (Id);
18001 -- Special DEC-compatible processing for the object case, forces
18002 -- object to be imported.
18004 if Ekind (Def_Id) = E_Variable then
18005 Kill_Size_Check_Code (Def_Id);
18006 Note_Possible_Modification (Id, Sure => False);
18008 -- Initialization is not allowed for imported variable
18010 if Present (Expression (Parent (Def_Id)))
18011 and then Comes_From_Source (Expression (Parent (Def_Id)))
18013 Error_Msg_Sloc := Sloc (Def_Id);
18015 ("no initialization allowed for declaration of& #",
18019 -- For compatibility, support VADS usage of providing both
18020 -- pragmas Interface and Interface_Name to obtain the effect
18021 -- of a single Import pragma.
18023 if Is_Imported (Def_Id)
18024 and then Present (First_Rep_Item (Def_Id))
18025 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
18026 and then Pragma_Name (First_Rep_Item (Def_Id)) =
18031 Set_Imported (Def_Id);
18034 Set_Is_Public (Def_Id);
18035 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
18038 -- Otherwise must be subprogram
18040 elsif not Is_Subprogram (Def_Id) then
18042 ("argument of pragma% is not subprogram", Arg1);
18045 Check_At_Most_N_Arguments (3);
18049 -- Loop through homonyms
18052 Def_Id := Get_Base_Subprogram (Hom_Id);
18054 if Is_Imported (Def_Id) then
18055 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
18059 exit when From_Aspect_Specification (N);
18060 Hom_Id := Homonym (Hom_Id);
18062 exit when No (Hom_Id)
18063 or else Scope (Hom_Id) /= Current_Scope;
18068 ("argument of pragma% is not imported subprogram",
18072 end Interface_Name;
18074 -----------------------
18075 -- Interrupt_Handler --
18076 -----------------------
18078 -- pragma Interrupt_Handler (handler_NAME);
18080 when Pragma_Interrupt_Handler =>
18081 Check_Ada_83_Warning;
18082 Check_Arg_Count (1);
18083 Check_No_Identifiers;
18085 if No_Run_Time_Mode then
18086 Error_Msg_CRT ("Interrupt_Handler pragma", N);
18088 Check_Interrupt_Or_Attach_Handler;
18089 Process_Interrupt_Or_Attach_Handler;
18092 ------------------------
18093 -- Interrupt_Priority --
18094 ------------------------
18096 -- pragma Interrupt_Priority [(EXPRESSION)];
18098 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
18099 P : constant Node_Id := Parent (N);
18104 Check_Ada_83_Warning;
18106 if Arg_Count /= 0 then
18107 Arg := Get_Pragma_Arg (Arg1);
18108 Check_Arg_Count (1);
18109 Check_No_Identifiers;
18111 -- The expression must be analyzed in the special manner
18112 -- described in "Handling of Default and Per-Object
18113 -- Expressions" in sem.ads.
18115 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
18118 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
18123 Ent := Defining_Identifier (Parent (P));
18125 -- Check duplicate pragma before we chain the pragma in the Rep
18126 -- Item chain of Ent.
18128 Check_Duplicate_Pragma (Ent);
18129 Record_Rep_Item (Ent, N);
18131 -- Check the No_Task_At_Interrupt_Priority restriction
18133 if Nkind (P) = N_Task_Definition then
18134 Check_Restriction (No_Task_At_Interrupt_Priority, N);
18137 end Interrupt_Priority;
18139 ---------------------
18140 -- Interrupt_State --
18141 ---------------------
18143 -- pragma Interrupt_State (
18144 -- [Name =>] INTERRUPT_ID,
18145 -- [State =>] INTERRUPT_STATE);
18147 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
18148 -- INTERRUPT_STATE => System | Runtime | User
18150 -- Note: if the interrupt id is given as an identifier, then it must
18151 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
18152 -- given as a static integer expression which must be in the range of
18153 -- Ada.Interrupts.Interrupt_ID.
18155 when Pragma_Interrupt_State => Interrupt_State : declare
18156 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
18157 -- This is the entity Ada.Interrupts.Interrupt_ID;
18159 State_Type : Character;
18160 -- Set to 's'/'r'/'u' for System/Runtime/User
18163 -- Index to entry in Interrupt_States table
18166 -- Value of interrupt
18168 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
18169 -- The first argument to the pragma
18171 Int_Ent : Entity_Id;
18172 -- Interrupt entity in Ada.Interrupts.Names
18176 Check_Arg_Order ((Name_Name, Name_State));
18177 Check_Arg_Count (2);
18179 Check_Optional_Identifier (Arg1, Name_Name);
18180 Check_Optional_Identifier (Arg2, Name_State);
18181 Check_Arg_Is_Identifier (Arg2);
18183 -- First argument is identifier
18185 if Nkind (Arg1X) = N_Identifier then
18187 -- Search list of names in Ada.Interrupts.Names
18189 Int_Ent := First_Entity (RTE (RE_Names));
18191 if No (Int_Ent) then
18192 Error_Pragma_Arg ("invalid interrupt name", Arg1);
18194 elsif Chars (Int_Ent) = Chars (Arg1X) then
18195 Int_Val := Expr_Value (Constant_Value (Int_Ent));
18199 Next_Entity (Int_Ent);
18202 -- First argument is not an identifier, so it must be a static
18203 -- expression of type Ada.Interrupts.Interrupt_ID.
18206 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
18207 Int_Val := Expr_Value (Arg1X);
18209 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
18211 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
18214 ("value not in range of type "
18215 & """Ada.Interrupts.Interrupt_'I'D""", Arg1);
18221 case Chars (Get_Pragma_Arg (Arg2)) is
18222 when Name_Runtime => State_Type := 'r';
18223 when Name_System => State_Type := 's';
18224 when Name_User => State_Type := 'u';
18227 Error_Pragma_Arg ("invalid interrupt state", Arg2);
18230 -- Check if entry is already stored
18232 IST_Num := Interrupt_States.First;
18234 -- If entry not found, add it
18236 if IST_Num > Interrupt_States.Last then
18237 Interrupt_States.Append
18238 ((Interrupt_Number => UI_To_Int (Int_Val),
18239 Interrupt_State => State_Type,
18240 Pragma_Loc => Loc));
18243 -- Case of entry for the same entry
18245 elsif Int_Val = Interrupt_States.Table (IST_Num).
18248 -- If state matches, done, no need to make redundant entry
18251 State_Type = Interrupt_States.Table (IST_Num).
18254 -- Otherwise if state does not match, error
18257 Interrupt_States.Table (IST_Num).Pragma_Loc;
18259 ("state conflicts with that given #", Arg2);
18263 IST_Num := IST_Num + 1;
18265 end Interrupt_State;
18271 -- pragma Invariant
18272 -- ([Entity =>] type_LOCAL_NAME,
18273 -- [Check =>] EXPRESSION
18274 -- [,[Message =>] String_Expression]);
18276 when Pragma_Invariant => Invariant : declare
18283 Check_At_Least_N_Arguments (2);
18284 Check_At_Most_N_Arguments (3);
18285 Check_Optional_Identifier (Arg1, Name_Entity);
18286 Check_Optional_Identifier (Arg2, Name_Check);
18288 if Arg_Count = 3 then
18289 Check_Optional_Identifier (Arg3, Name_Message);
18290 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
18293 Check_Arg_Is_Local_Name (Arg1);
18295 Typ_Arg := Get_Pragma_Arg (Arg1);
18296 Find_Type (Typ_Arg);
18297 Typ := Entity (Typ_Arg);
18299 -- Nothing to do of the related type is erroneous in some way
18301 if Typ = Any_Type then
18304 -- AI12-0041: Invariants are allowed in interface types
18306 elsif Is_Interface (Typ) then
18309 -- An invariant must apply to a private type, or appear in the
18310 -- private part of a package spec and apply to a completion.
18311 -- a class-wide invariant can only appear on a private declaration
18312 -- or private extension, not a completion.
18314 -- A [class-wide] invariant may be associated a [limited] private
18315 -- type or a private extension.
18317 elsif Ekind_In (Typ, E_Limited_Private_Type,
18319 E_Record_Type_With_Private)
18323 -- A non-class-wide invariant may be associated with the full view
18324 -- of a [limited] private type or a private extension.
18326 elsif Has_Private_Declaration (Typ)
18327 and then not Class_Present (N)
18331 -- A class-wide invariant may appear on the partial view only
18333 elsif Class_Present (N) then
18335 ("pragma % only allowed for private type", Arg1);
18338 -- A regular invariant may appear on both views
18342 ("pragma % only allowed for private type or corresponding "
18343 & "full view", Arg1);
18347 -- An invariant associated with an abstract type (this includes
18348 -- interfaces) must be class-wide.
18350 if Is_Abstract_Type (Typ) and then not Class_Present (N) then
18352 ("pragma % not allowed for abstract type", Arg1);
18356 -- If invariants should be ignored, delete the pragma and then
18357 -- return. We do this here, after checking for errors, and before
18358 -- generating anything that has a run-time effect.
18360 if Present (Check_Policy_List)
18362 (Policy_In_Effect (Name_Invariant) = Name_Ignore
18364 Policy_In_Effect (Name_Type_Invariant) = Name_Ignore)
18366 Rewrite (N, Make_Null_Statement (Loc));
18370 -- A pragma that applies to a Ghost entity becomes Ghost for the
18371 -- purposes of legality checks and removal of ignored Ghost code.
18373 Mark_Ghost_Pragma (N, Typ);
18375 -- The pragma defines a type-specific invariant, the type is said
18376 -- to have invariants of its "own".
18378 Set_Has_Own_Invariants (Typ);
18380 -- If the invariant is class-wide, then it can be inherited by
18381 -- derived or interface implementing types. The type is said to
18382 -- have "inheritable" invariants.
18384 if Class_Present (N) then
18385 Set_Has_Inheritable_Invariants (Typ);
18388 -- Chain the pragma on to the rep item chain, for processing when
18389 -- the type is frozen.
18391 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
18393 -- Create the declaration of the invariant procedure that will
18394 -- verify the invariant at run time. Interfaces are treated as the
18395 -- partial view of a private type in order to achieve uniformity
18396 -- with the general case. As a result, an interface receives only
18397 -- a "partial" invariant procedure, which is never called.
18399 Build_Invariant_Procedure_Declaration
18401 Partial_Invariant => Is_Interface (Typ));
18408 -- pragma Keep_Names ([On => ] LOCAL_NAME);
18410 when Pragma_Keep_Names => Keep_Names : declare
18415 Check_Arg_Count (1);
18416 Check_Optional_Identifier (Arg1, Name_On);
18417 Check_Arg_Is_Local_Name (Arg1);
18419 Arg := Get_Pragma_Arg (Arg1);
18422 if Etype (Arg) = Any_Type then
18426 if not Is_Entity_Name (Arg)
18427 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
18430 ("pragma% requires a local enumeration type", Arg1);
18433 Set_Discard_Names (Entity (Arg), False);
18440 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
18442 when Pragma_License =>
18445 -- Do not analyze pragma any further in CodePeer mode, to avoid
18446 -- extraneous errors in this implementation-dependent pragma,
18447 -- which has a different profile on other compilers.
18449 if CodePeer_Mode then
18453 Check_Arg_Count (1);
18454 Check_No_Identifiers;
18455 Check_Valid_Configuration_Pragma;
18456 Check_Arg_Is_Identifier (Arg1);
18459 Sind : constant Source_File_Index :=
18460 Source_Index (Current_Sem_Unit);
18463 case Chars (Get_Pragma_Arg (Arg1)) is
18465 Set_License (Sind, GPL);
18467 when Name_Modified_GPL =>
18468 Set_License (Sind, Modified_GPL);
18470 when Name_Restricted =>
18471 Set_License (Sind, Restricted);
18473 when Name_Unrestricted =>
18474 Set_License (Sind, Unrestricted);
18477 Error_Pragma_Arg ("invalid license name", Arg1);
18485 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
18487 when Pragma_Link_With => Link_With : declare
18493 if Operating_Mode = Generate_Code
18494 and then In_Extended_Main_Source_Unit (N)
18496 Check_At_Least_N_Arguments (1);
18497 Check_No_Identifiers;
18498 Check_Is_In_Decl_Part_Or_Package_Spec;
18499 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
18503 while Present (Arg) loop
18504 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
18506 -- Store argument, converting sequences of spaces to a
18507 -- single null character (this is one of the differences
18508 -- in processing between Link_With and Linker_Options).
18510 Arg_Store : declare
18511 C : constant Char_Code := Get_Char_Code (' ');
18512 S : constant String_Id :=
18513 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
18514 L : constant Nat := String_Length (S);
18517 procedure Skip_Spaces;
18518 -- Advance F past any spaces
18524 procedure Skip_Spaces is
18526 while F <= L and then Get_String_Char (S, F) = C loop
18531 -- Start of processing for Arg_Store
18534 Skip_Spaces; -- skip leading spaces
18536 -- Loop through characters, changing any embedded
18537 -- sequence of spaces to a single null character (this
18538 -- is how Link_With/Linker_Options differ)
18541 if Get_String_Char (S, F) = C then
18544 Store_String_Char (ASCII.NUL);
18547 Store_String_Char (Get_String_Char (S, F));
18555 if Present (Arg) then
18556 Store_String_Char (ASCII.NUL);
18560 Store_Linker_Option_String (End_String);
18568 -- pragma Linker_Alias (
18569 -- [Entity =>] LOCAL_NAME
18570 -- [Target =>] static_string_EXPRESSION);
18572 when Pragma_Linker_Alias =>
18574 Check_Arg_Order ((Name_Entity, Name_Target));
18575 Check_Arg_Count (2);
18576 Check_Optional_Identifier (Arg1, Name_Entity);
18577 Check_Optional_Identifier (Arg2, Name_Target);
18578 Check_Arg_Is_Library_Level_Local_Name (Arg1);
18579 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
18581 -- The only processing required is to link this item on to the
18582 -- list of rep items for the given entity. This is accomplished
18583 -- by the call to Rep_Item_Too_Late (when no error is detected
18584 -- and False is returned).
18586 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
18589 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
18592 ------------------------
18593 -- Linker_Constructor --
18594 ------------------------
18596 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
18598 -- Code is shared with Linker_Destructor
18600 -----------------------
18601 -- Linker_Destructor --
18602 -----------------------
18604 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
18606 when Pragma_Linker_Constructor
18607 | Pragma_Linker_Destructor
18609 Linker_Constructor : declare
18615 Check_Arg_Count (1);
18616 Check_No_Identifiers;
18617 Check_Arg_Is_Local_Name (Arg1);
18618 Arg1_X := Get_Pragma_Arg (Arg1);
18620 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
18622 if not Is_Library_Level_Entity (Proc) then
18624 ("argument for pragma% must be library level entity", Arg1);
18627 -- The only processing required is to link this item on to the
18628 -- list of rep items for the given entity. This is accomplished
18629 -- by the call to Rep_Item_Too_Late (when no error is detected
18630 -- and False is returned).
18632 if Rep_Item_Too_Late (Proc, N) then
18635 Set_Has_Gigi_Rep_Item (Proc);
18637 end Linker_Constructor;
18639 --------------------
18640 -- Linker_Options --
18641 --------------------
18643 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
18645 when Pragma_Linker_Options => Linker_Options : declare
18649 Check_Ada_83_Warning;
18650 Check_No_Identifiers;
18651 Check_Arg_Count (1);
18652 Check_Is_In_Decl_Part_Or_Package_Spec;
18653 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
18654 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
18657 while Present (Arg) loop
18658 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
18659 Store_String_Char (ASCII.NUL);
18661 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
18665 if Operating_Mode = Generate_Code
18666 and then In_Extended_Main_Source_Unit (N)
18668 Store_Linker_Option_String (End_String);
18670 end Linker_Options;
18672 --------------------
18673 -- Linker_Section --
18674 --------------------
18676 -- pragma Linker_Section (
18677 -- [Entity =>] LOCAL_NAME
18678 -- [Section =>] static_string_EXPRESSION);
18680 when Pragma_Linker_Section => Linker_Section : declare
18685 Ghost_Error_Posted : Boolean := False;
18686 -- Flag set when an error concerning the illegal mix of Ghost and
18687 -- non-Ghost subprograms is emitted.
18689 Ghost_Id : Entity_Id := Empty;
18690 -- The entity of the first Ghost subprogram encountered while
18691 -- processing the arguments of the pragma.
18695 Check_Arg_Order ((Name_Entity, Name_Section));
18696 Check_Arg_Count (2);
18697 Check_Optional_Identifier (Arg1, Name_Entity);
18698 Check_Optional_Identifier (Arg2, Name_Section);
18699 Check_Arg_Is_Library_Level_Local_Name (Arg1);
18700 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
18702 -- Check kind of entity
18704 Arg := Get_Pragma_Arg (Arg1);
18705 Ent := Entity (Arg);
18707 case Ekind (Ent) is
18709 -- Objects (constants and variables) and types. For these cases
18710 -- all we need to do is to set the Linker_Section_pragma field,
18711 -- checking that we do not have a duplicate.
18717 LPE := Linker_Section_Pragma (Ent);
18719 if Present (LPE) then
18720 Error_Msg_Sloc := Sloc (LPE);
18722 ("Linker_Section already specified for &#", Arg1, Ent);
18725 Set_Linker_Section_Pragma (Ent, N);
18727 -- A pragma that applies to a Ghost entity becomes Ghost for
18728 -- the purposes of legality checks and removal of ignored
18731 Mark_Ghost_Pragma (N, Ent);
18735 when Subprogram_Kind =>
18737 -- Aspect case, entity already set
18739 if From_Aspect_Specification (N) then
18740 Set_Linker_Section_Pragma
18741 (Entity (Corresponding_Aspect (N)), N);
18743 -- Propagate it to its ultimate aliased entity to
18744 -- facilitate the backend processing this attribute
18745 -- in instantiations of generic subprograms.
18747 if Present (Alias (Entity (Corresponding_Aspect (N))))
18749 Set_Linker_Section_Pragma
18751 (Entity (Corresponding_Aspect (N))), N);
18754 -- Pragma case, we must climb the homonym chain, but skip
18755 -- any for which the linker section is already set.
18759 if No (Linker_Section_Pragma (Ent)) then
18760 Set_Linker_Section_Pragma (Ent, N);
18762 -- Propagate it to its ultimate aliased entity to
18763 -- facilitate the backend processing this attribute
18764 -- in instantiations of generic subprograms.
18766 if Present (Alias (Ent)) then
18767 Set_Linker_Section_Pragma
18768 (Ultimate_Alias (Ent), N);
18771 -- A pragma that applies to a Ghost entity becomes
18772 -- Ghost for the purposes of legality checks and
18773 -- removal of ignored Ghost code.
18775 Mark_Ghost_Pragma (N, Ent);
18777 -- Capture the entity of the first Ghost subprogram
18778 -- being processed for error detection purposes.
18780 if Is_Ghost_Entity (Ent) then
18781 if No (Ghost_Id) then
18785 -- Otherwise the subprogram is non-Ghost. It is
18786 -- illegal to mix references to Ghost and non-Ghost
18787 -- entities (SPARK RM 6.9).
18789 elsif Present (Ghost_Id)
18790 and then not Ghost_Error_Posted
18792 Ghost_Error_Posted := True;
18794 Error_Msg_Name_1 := Pname;
18796 ("pragma % cannot mention ghost and "
18797 & "non-ghost subprograms", N);
18799 Error_Msg_Sloc := Sloc (Ghost_Id);
18801 ("\& # declared as ghost", N, Ghost_Id);
18803 Error_Msg_Sloc := Sloc (Ent);
18805 ("\& # declared as non-ghost", N, Ent);
18809 Ent := Homonym (Ent);
18811 or else Scope (Ent) /= Current_Scope;
18815 -- All other cases are illegal
18819 ("pragma% applies only to objects, subprograms, and types",
18822 end Linker_Section;
18828 -- pragma List (On | Off)
18830 -- There is nothing to do here, since we did all the processing for
18831 -- this pragma in Par.Prag (so that it works properly even in syntax
18834 when Pragma_List =>
18841 -- pragma Lock_Free [(Boolean_EXPRESSION)];
18843 when Pragma_Lock_Free => Lock_Free : declare
18844 P : constant Node_Id := Parent (N);
18850 Check_No_Identifiers;
18851 Check_At_Most_N_Arguments (1);
18853 -- Protected definition case
18855 if Nkind (P) = N_Protected_Definition then
18856 Ent := Defining_Identifier (Parent (P));
18860 if Arg_Count = 1 then
18861 Arg := Get_Pragma_Arg (Arg1);
18862 Val := Is_True (Static_Boolean (Arg));
18864 -- No arguments (expression is considered to be True)
18870 -- Check duplicate pragma before we chain the pragma in the Rep
18871 -- Item chain of Ent.
18873 Check_Duplicate_Pragma (Ent);
18874 Record_Rep_Item (Ent, N);
18875 Set_Uses_Lock_Free (Ent, Val);
18877 -- Anything else is incorrect placement
18884 --------------------
18885 -- Locking_Policy --
18886 --------------------
18888 -- pragma Locking_Policy (policy_IDENTIFIER);
18890 when Pragma_Locking_Policy => declare
18891 subtype LP_Range is Name_Id
18892 range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
18897 Check_Ada_83_Warning;
18898 Check_Arg_Count (1);
18899 Check_No_Identifiers;
18900 Check_Arg_Is_Locking_Policy (Arg1);
18901 Check_Valid_Configuration_Pragma;
18902 LP_Val := Chars (Get_Pragma_Arg (Arg1));
18905 when Name_Ceiling_Locking => LP := 'C';
18906 when Name_Concurrent_Readers_Locking => LP := 'R';
18907 when Name_Inheritance_Locking => LP := 'I';
18910 if Locking_Policy /= ' '
18911 and then Locking_Policy /= LP
18913 Error_Msg_Sloc := Locking_Policy_Sloc;
18914 Error_Pragma ("locking policy incompatible with policy#");
18916 -- Set new policy, but always preserve System_Location since we
18917 -- like the error message with the run time name.
18920 Locking_Policy := LP;
18922 if Locking_Policy_Sloc /= System_Location then
18923 Locking_Policy_Sloc := Loc;
18928 -------------------
18929 -- Loop_Optimize --
18930 -------------------
18932 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
18934 -- OPTIMIZATION_HINT ::=
18935 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
18937 when Pragma_Loop_Optimize => Loop_Optimize : declare
18942 Check_At_Least_N_Arguments (1);
18943 Check_No_Identifiers;
18945 Hint := First (Pragma_Argument_Associations (N));
18946 while Present (Hint) loop
18947 Check_Arg_Is_One_Of (Hint, Name_Ivdep,
18955 Check_Loop_Pragma_Placement;
18962 -- pragma Loop_Variant
18963 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
18965 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
18967 -- CHANGE_DIRECTION ::= Increases | Decreases
18969 when Pragma_Loop_Variant => Loop_Variant : declare
18974 Check_At_Least_N_Arguments (1);
18975 Check_Loop_Pragma_Placement;
18977 -- Process all increasing / decreasing expressions
18979 Variant := First (Pragma_Argument_Associations (N));
18980 while Present (Variant) loop
18981 if Chars (Variant) = No_Name then
18982 Error_Pragma_Arg_Ident ("expect name `Increases`", Variant);
18984 elsif not Nam_In (Chars (Variant), Name_Decreases,
18988 Name : String := Get_Name_String (Chars (Variant));
18991 -- It is a common mistake to write "Increasing" for
18992 -- "Increases" or "Decreasing" for "Decreases". Recognize
18993 -- specially names starting with "incr" or "decr" to
18994 -- suggest the corresponding name.
18996 System.Case_Util.To_Lower (Name);
18998 if Name'Length >= 4
18999 and then Name (1 .. 4) = "incr"
19001 Error_Pragma_Arg_Ident
19002 ("expect name `Increases`", Variant);
19004 elsif Name'Length >= 4
19005 and then Name (1 .. 4) = "decr"
19007 Error_Pragma_Arg_Ident
19008 ("expect name `Decreases`", Variant);
19011 Error_Pragma_Arg_Ident
19012 ("expect name `Increases` or `Decreases`", Variant);
19017 Preanalyze_Assert_Expression
19018 (Expression (Variant), Any_Discrete);
19024 -----------------------
19025 -- Machine_Attribute --
19026 -----------------------
19028 -- pragma Machine_Attribute (
19029 -- [Entity =>] LOCAL_NAME,
19030 -- [Attribute_Name =>] static_string_EXPRESSION
19031 -- [, [Info =>] static_EXPRESSION {, static_EXPRESSION}] );
19033 when Pragma_Machine_Attribute => Machine_Attribute : declare
19035 Def_Id : Entity_Id;
19039 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
19041 if Arg_Count >= 3 then
19042 Check_Optional_Identifier (Arg3, Name_Info);
19044 while Present (Arg) loop
19045 Check_Arg_Is_OK_Static_Expression (Arg);
19049 Check_Arg_Count (2);
19052 Check_Optional_Identifier (Arg1, Name_Entity);
19053 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
19054 Check_Arg_Is_Local_Name (Arg1);
19055 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
19056 Def_Id := Entity (Get_Pragma_Arg (Arg1));
19058 if Is_Access_Type (Def_Id) then
19059 Def_Id := Designated_Type (Def_Id);
19062 if Rep_Item_Too_Early (Def_Id, N) then
19066 Def_Id := Underlying_Type (Def_Id);
19068 -- The only processing required is to link this item on to the
19069 -- list of rep items for the given entity. This is accomplished
19070 -- by the call to Rep_Item_Too_Late (when no error is detected
19071 -- and False is returned).
19073 if Rep_Item_Too_Late (Def_Id, N) then
19076 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
19078 end Machine_Attribute;
19085 -- (MAIN_OPTION [, MAIN_OPTION]);
19088 -- [STACK_SIZE =>] static_integer_EXPRESSION
19089 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
19090 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
19092 when Pragma_Main => Main : declare
19093 Args : Args_List (1 .. 3);
19094 Names : constant Name_List (1 .. 3) := (
19096 Name_Task_Stack_Size_Default,
19097 Name_Time_Slicing_Enabled);
19103 Gather_Associations (Names, Args);
19105 for J in 1 .. 2 loop
19106 if Present (Args (J)) then
19107 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
19111 if Present (Args (3)) then
19112 Check_Arg_Is_OK_Static_Expression (Args (3), Standard_Boolean);
19116 while Present (Nod) loop
19117 if Nkind (Nod) = N_Pragma
19118 and then Pragma_Name (Nod) = Name_Main
19120 Error_Msg_Name_1 := Pname;
19121 Error_Msg_N ("duplicate pragma% not permitted", Nod);
19132 -- pragma Main_Storage
19133 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
19135 -- MAIN_STORAGE_OPTION ::=
19136 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
19137 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
19139 when Pragma_Main_Storage => Main_Storage : declare
19140 Args : Args_List (1 .. 2);
19141 Names : constant Name_List (1 .. 2) := (
19142 Name_Working_Storage,
19149 Gather_Associations (Names, Args);
19151 for J in 1 .. 2 loop
19152 if Present (Args (J)) then
19153 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
19157 Check_In_Main_Program;
19160 while Present (Nod) loop
19161 if Nkind (Nod) = N_Pragma
19162 and then Pragma_Name (Nod) = Name_Main_Storage
19164 Error_Msg_Name_1 := Pname;
19165 Error_Msg_N ("duplicate pragma% not permitted", Nod);
19172 ----------------------------
19173 -- Max_Entry_Queue_Length --
19174 ----------------------------
19176 -- pragma Max_Entry_Queue_Length (static_integer_EXPRESSION);
19178 -- This processing is shared by Pragma_Max_Entry_Queue_Depth and
19179 -- Pragma_Max_Queue_Length.
19181 when Pragma_Max_Entry_Queue_Length
19182 | Pragma_Max_Entry_Queue_Depth
19183 | Pragma_Max_Queue_Length
19185 Max_Entry_Queue_Length : declare
19187 Entry_Decl : Node_Id;
19188 Entry_Id : Entity_Id;
19192 if Prag_Id = Pragma_Max_Entry_Queue_Depth
19193 or else Prag_Id = Pragma_Max_Queue_Length
19198 Check_Arg_Count (1);
19201 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
19203 -- Entry declaration
19205 if Nkind (Entry_Decl) = N_Entry_Declaration then
19207 -- Entry illegally within a task
19209 if Nkind (Parent (N)) = N_Task_Definition then
19210 Error_Pragma ("pragma % cannot apply to task entries");
19214 Entry_Id := Defining_Entity (Entry_Decl);
19216 -- Otherwise the pragma is associated with an illegal construct
19219 Error_Pragma ("pragma % must apply to a protected entry");
19223 -- Mark the pragma as Ghost if the related subprogram is also
19224 -- Ghost. This also ensures that any expansion performed further
19225 -- below will produce Ghost nodes.
19227 Mark_Ghost_Pragma (N, Entry_Id);
19229 -- Analyze the Integer expression
19231 Arg := Get_Pragma_Arg (Arg1);
19232 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
19234 Val := Expr_Value (Arg);
19238 ("argument for pragma% cannot be less than -1", Arg1);
19240 elsif not UI_Is_In_Int_Range (Val) then
19242 ("argument for pragma% out of range of Integer", Arg1);
19246 Record_Rep_Item (Entry_Id, N);
19247 end Max_Entry_Queue_Length;
19253 -- pragma Memory_Size (NUMERIC_LITERAL)
19255 when Pragma_Memory_Size =>
19258 -- Memory size is simply ignored
19260 Check_No_Identifiers;
19261 Check_Arg_Count (1);
19262 Check_Arg_Is_Integer_Literal (Arg1);
19270 -- The only correct use of this pragma is on its own in a file, in
19271 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
19272 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
19273 -- check for a file containing nothing but a No_Body pragma). If we
19274 -- attempt to process it during normal semantics processing, it means
19275 -- it was misplaced.
19277 when Pragma_No_Body =>
19281 -----------------------------
19282 -- No_Elaboration_Code_All --
19283 -----------------------------
19285 -- pragma No_Elaboration_Code_All;
19287 when Pragma_No_Elaboration_Code_All =>
19289 Check_Valid_Library_Unit_Pragma;
19291 if Nkind (N) = N_Null_Statement then
19295 -- Must appear for a spec or generic spec
19297 if not Nkind_In (Unit (Cunit (Current_Sem_Unit)),
19298 N_Generic_Package_Declaration,
19299 N_Generic_Subprogram_Declaration,
19300 N_Package_Declaration,
19301 N_Subprogram_Declaration)
19305 ("pragma% can only occur for package "
19306 & "or subprogram spec"));
19309 -- Set flag in unit table
19311 Set_No_Elab_Code_All (Current_Sem_Unit);
19313 -- Set restriction No_Elaboration_Code if this is the main unit
19315 if Current_Sem_Unit = Main_Unit then
19316 Set_Restriction (No_Elaboration_Code, N);
19319 -- If we are in the main unit or in an extended main source unit,
19320 -- then we also add it to the configuration restrictions so that
19321 -- it will apply to all units in the extended main source.
19323 if Current_Sem_Unit = Main_Unit
19324 or else In_Extended_Main_Source_Unit (N)
19326 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
19329 -- If in main extended unit, activate transitive with test
19331 if In_Extended_Main_Source_Unit (N) then
19332 Opt.No_Elab_Code_All_Pragma := N;
19335 -----------------------------
19336 -- No_Component_Reordering --
19337 -----------------------------
19339 -- pragma No_Component_Reordering [([Entity =>] type_LOCAL_NAME)];
19341 when Pragma_No_Component_Reordering => No_Comp_Reordering : declare
19347 Check_At_Most_N_Arguments (1);
19349 if Arg_Count = 0 then
19350 Check_Valid_Configuration_Pragma;
19351 Opt.No_Component_Reordering := True;
19354 Check_Optional_Identifier (Arg2, Name_Entity);
19355 Check_Arg_Is_Local_Name (Arg1);
19356 E_Id := Get_Pragma_Arg (Arg1);
19358 if Etype (E_Id) = Any_Type then
19362 E := Entity (E_Id);
19364 if not Is_Record_Type (E) then
19365 Error_Pragma_Arg ("pragma% requires record type", Arg1);
19368 Set_No_Reordering (Base_Type (E));
19370 end No_Comp_Reordering;
19372 --------------------------
19373 -- No_Heap_Finalization --
19374 --------------------------
19376 -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];
19378 when Pragma_No_Heap_Finalization => No_Heap_Finalization : declare
19379 Context : constant Node_Id := Parent (N);
19380 Typ_Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
19386 Check_No_Identifiers;
19388 -- The pragma appears in a configuration file
19390 if No (Context) then
19391 Check_Arg_Count (0);
19392 Check_Valid_Configuration_Pragma;
19394 -- Detect a duplicate pragma
19396 if Present (No_Heap_Finalization_Pragma) then
19399 Prev => No_Heap_Finalization_Pragma);
19403 No_Heap_Finalization_Pragma := N;
19405 -- Otherwise the pragma should be associated with a library-level
19406 -- named access-to-object type.
19409 Check_Arg_Count (1);
19410 Check_Arg_Is_Local_Name (Arg1);
19412 Find_Type (Typ_Arg);
19413 Typ := Entity (Typ_Arg);
19415 -- The type being subjected to the pragma is erroneous
19417 if Typ = Any_Type then
19418 Error_Pragma ("cannot find type referenced by pragma %");
19420 -- The pragma is applied to an incomplete or generic formal
19421 -- type way too early.
19423 elsif Rep_Item_Too_Early (Typ, N) then
19427 Typ := Underlying_Type (Typ);
19430 -- The pragma must apply to an access-to-object type
19432 if Ekind_In (Typ, E_Access_Type, E_General_Access_Type) then
19435 -- Give a detailed error message on all other access type kinds
19437 elsif Ekind (Typ) = E_Access_Protected_Subprogram_Type then
19439 ("pragma % cannot apply to access protected subprogram "
19442 elsif Ekind (Typ) = E_Access_Subprogram_Type then
19444 ("pragma % cannot apply to access subprogram type");
19446 elsif Is_Anonymous_Access_Type (Typ) then
19448 ("pragma % cannot apply to anonymous access type");
19450 -- Give a general error message in case the pragma applies to a
19451 -- non-access type.
19455 ("pragma % must apply to library level access type");
19458 -- At this point the argument denotes an access-to-object type.
19459 -- Ensure that the type is declared at the library level.
19461 if Is_Library_Level_Entity (Typ) then
19464 -- Quietly ignore an access-to-object type originally declared
19465 -- at the library level within a generic, but instantiated at
19466 -- a non-library level. As a result the access-to-object type
19467 -- "loses" its No_Heap_Finalization property.
19469 elsif In_Instance then
19474 ("pragma % must apply to library level access type");
19477 -- Detect a duplicate pragma
19479 if Present (No_Heap_Finalization_Pragma) then
19482 Prev => No_Heap_Finalization_Pragma);
19486 Prev := Get_Pragma (Typ, Pragma_No_Heap_Finalization);
19488 if Present (Prev) then
19496 Record_Rep_Item (Typ, N);
19498 end No_Heap_Finalization;
19504 -- pragma No_Inline ( NAME {, NAME} );
19506 when Pragma_No_Inline =>
19508 Process_Inline (Suppressed);
19514 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
19516 when Pragma_No_Return => No_Return : declare
19522 Ghost_Error_Posted : Boolean := False;
19523 -- Flag set when an error concerning the illegal mix of Ghost and
19524 -- non-Ghost subprograms is emitted.
19526 Ghost_Id : Entity_Id := Empty;
19527 -- The entity of the first Ghost procedure encountered while
19528 -- processing the arguments of the pragma.
19532 Check_At_Least_N_Arguments (1);
19534 -- Loop through arguments of pragma
19537 while Present (Arg) loop
19538 Check_Arg_Is_Local_Name (Arg);
19539 Id := Get_Pragma_Arg (Arg);
19542 if not Is_Entity_Name (Id) then
19543 Error_Pragma_Arg ("entity name required", Arg);
19546 if Etype (Id) = Any_Type then
19550 -- Loop to find matching procedures
19556 and then Scope (E) = Current_Scope
19558 if Ekind_In (E, E_Generic_Procedure, E_Procedure) then
19560 -- Check that the pragma is not applied to a body.
19561 -- First check the specless body case, to give a
19562 -- different error message. These checks do not apply
19563 -- if Relaxed_RM_Semantics, to accommodate other Ada
19564 -- compilers. Disable these checks under -gnatd.J.
19566 if not Debug_Flag_Dot_JJ then
19567 if Nkind (Parent (Declaration_Node (E))) =
19569 and then not Relaxed_RM_Semantics
19572 ("pragma% requires separate spec and must come "
19576 -- Now the "specful" body case
19578 if Rep_Item_Too_Late (E, N) then
19585 -- A pragma that applies to a Ghost entity becomes Ghost
19586 -- for the purposes of legality checks and removal of
19587 -- ignored Ghost code.
19589 Mark_Ghost_Pragma (N, E);
19591 -- Capture the entity of the first Ghost procedure being
19592 -- processed for error detection purposes.
19594 if Is_Ghost_Entity (E) then
19595 if No (Ghost_Id) then
19599 -- Otherwise the subprogram is non-Ghost. It is illegal
19600 -- to mix references to Ghost and non-Ghost entities
19603 elsif Present (Ghost_Id)
19604 and then not Ghost_Error_Posted
19606 Ghost_Error_Posted := True;
19608 Error_Msg_Name_1 := Pname;
19610 ("pragma % cannot mention ghost and non-ghost "
19611 & "procedures", N);
19613 Error_Msg_Sloc := Sloc (Ghost_Id);
19614 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
19616 Error_Msg_Sloc := Sloc (E);
19617 Error_Msg_NE ("\& # declared as non-ghost", N, E);
19620 -- Set flag on any alias as well
19622 if Is_Overloadable (E) and then Present (Alias (E)) then
19623 Set_No_Return (Alias (E));
19629 exit when From_Aspect_Specification (N);
19633 -- If entity in not in current scope it may be the enclosing
19634 -- suprogram body to which the aspect applies.
19637 if Entity (Id) = Current_Scope
19638 and then From_Aspect_Specification (N)
19640 Set_No_Return (Entity (Id));
19642 Error_Pragma_Arg ("no procedure& found for pragma%", Arg);
19654 -- pragma No_Run_Time;
19656 -- Note: this pragma is retained for backwards compatibility. See
19657 -- body of Rtsfind for full details on its handling.
19659 when Pragma_No_Run_Time =>
19661 Check_Valid_Configuration_Pragma;
19662 Check_Arg_Count (0);
19664 -- Remove backward compatibility if Build_Type is FSF or GPL and
19665 -- generate a warning.
19668 Ignore : constant Boolean := Build_Type in FSF .. GPL;
19671 Error_Pragma ("pragma% is ignored, has no effect??");
19673 No_Run_Time_Mode := True;
19674 Configurable_Run_Time_Mode := True;
19676 -- Set Duration to 32 bits if word size is 32
19678 if Ttypes.System_Word_Size = 32 then
19679 Duration_32_Bits_On_Target := True;
19682 -- Set appropriate restrictions
19684 Set_Restriction (No_Finalization, N);
19685 Set_Restriction (No_Exception_Handlers, N);
19686 Set_Restriction (Max_Tasks, N, 0);
19687 Set_Restriction (No_Tasking, N);
19691 -----------------------
19692 -- No_Tagged_Streams --
19693 -----------------------
19695 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
19697 when Pragma_No_Tagged_Streams => No_Tagged_Strms : declare
19703 Check_At_Most_N_Arguments (1);
19705 -- One argument case
19707 if Arg_Count = 1 then
19708 Check_Optional_Identifier (Arg1, Name_Entity);
19709 Check_Arg_Is_Local_Name (Arg1);
19710 E_Id := Get_Pragma_Arg (Arg1);
19712 if Etype (E_Id) = Any_Type then
19716 E := Entity (E_Id);
19718 Check_Duplicate_Pragma (E);
19720 if not Is_Tagged_Type (E) or else Is_Derived_Type (E) then
19722 ("argument for pragma% must be root tagged type", Arg1);
19725 if Rep_Item_Too_Early (E, N)
19727 Rep_Item_Too_Late (E, N)
19731 Set_No_Tagged_Streams_Pragma (E, N);
19734 -- Zero argument case
19737 Check_Is_In_Decl_Part_Or_Package_Spec;
19738 No_Tagged_Streams := N;
19740 end No_Tagged_Strms;
19742 ------------------------
19743 -- No_Strict_Aliasing --
19744 ------------------------
19746 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
19748 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
19754 Check_At_Most_N_Arguments (1);
19756 if Arg_Count = 0 then
19757 Check_Valid_Configuration_Pragma;
19758 Opt.No_Strict_Aliasing := True;
19761 Check_Optional_Identifier (Arg2, Name_Entity);
19762 Check_Arg_Is_Local_Name (Arg1);
19763 E_Id := Get_Pragma_Arg (Arg1);
19765 if Etype (E_Id) = Any_Type then
19769 E := Entity (E_Id);
19771 if not Is_Access_Type (E) then
19772 Error_Pragma_Arg ("pragma% requires access type", Arg1);
19775 Set_No_Strict_Aliasing (Base_Type (E));
19777 end No_Strict_Aliasing;
19779 -----------------------
19780 -- Normalize_Scalars --
19781 -----------------------
19783 -- pragma Normalize_Scalars;
19785 when Pragma_Normalize_Scalars =>
19786 Check_Ada_83_Warning;
19787 Check_Arg_Count (0);
19788 Check_Valid_Configuration_Pragma;
19790 -- Normalize_Scalars creates false positives in CodePeer, and
19791 -- incorrect negative results in GNATprove mode, so ignore this
19792 -- pragma in these modes.
19794 if not (CodePeer_Mode or GNATprove_Mode) then
19795 Normalize_Scalars := True;
19796 Init_Or_Norm_Scalars := True;
19803 -- pragma Obsolescent;
19805 -- pragma Obsolescent (
19806 -- [Message =>] static_string_EXPRESSION
19807 -- [,[Version =>] Ada_05]]);
19809 -- pragma Obsolescent (
19810 -- [Entity =>] NAME
19811 -- [,[Message =>] static_string_EXPRESSION
19812 -- [,[Version =>] Ada_05]] );
19814 when Pragma_Obsolescent => Obsolescent : declare
19818 procedure Set_Obsolescent (E : Entity_Id);
19819 -- Given an entity Ent, mark it as obsolescent if appropriate
19821 ---------------------
19822 -- Set_Obsolescent --
19823 ---------------------
19825 procedure Set_Obsolescent (E : Entity_Id) is
19834 -- A pragma that applies to a Ghost entity becomes Ghost for
19835 -- the purposes of legality checks and removal of ignored Ghost
19838 Mark_Ghost_Pragma (N, E);
19840 -- Entity name was given
19842 if Present (Ename) then
19844 -- If entity name matches, we are fine.
19846 if Chars (Ename) = Chars (Ent) then
19847 Set_Entity (Ename, Ent);
19848 Generate_Reference (Ent, Ename);
19850 -- If entity name does not match, only possibility is an
19851 -- enumeration literal from an enumeration type declaration.
19853 elsif Ekind (Ent) /= E_Enumeration_Type then
19855 ("pragma % entity name does not match declaration");
19858 Ent := First_Literal (E);
19862 ("pragma % entity name does not match any "
19863 & "enumeration literal");
19865 elsif Chars (Ent) = Chars (Ename) then
19866 Set_Entity (Ename, Ent);
19867 Generate_Reference (Ent, Ename);
19871 Next_Literal (Ent);
19877 -- Ent points to entity to be marked
19879 if Arg_Count >= 1 then
19881 -- Deal with static string argument
19883 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
19884 S := Strval (Get_Pragma_Arg (Arg1));
19886 for J in 1 .. String_Length (S) loop
19887 if not In_Character_Range (Get_String_Char (S, J)) then
19889 ("pragma% argument does not allow wide characters",
19894 Obsolescent_Warnings.Append
19895 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
19897 -- Check for Ada_05 parameter
19899 if Arg_Count /= 1 then
19900 Check_Arg_Count (2);
19903 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
19906 Check_Arg_Is_Identifier (Argx);
19908 if Chars (Argx) /= Name_Ada_05 then
19909 Error_Msg_Name_2 := Name_Ada_05;
19911 ("only allowed argument for pragma% is %", Argx);
19914 if Ada_Version_Explicit < Ada_2005
19915 or else not Warn_On_Ada_2005_Compatibility
19923 -- Set flag if pragma active
19926 Set_Is_Obsolescent (Ent);
19930 end Set_Obsolescent;
19932 -- Start of processing for pragma Obsolescent
19937 Check_At_Most_N_Arguments (3);
19939 -- See if first argument specifies an entity name
19943 (Chars (Arg1) = Name_Entity
19945 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
19947 N_Operator_Symbol))
19949 Ename := Get_Pragma_Arg (Arg1);
19951 -- Eliminate first argument, so we can share processing
19955 Arg_Count := Arg_Count - 1;
19957 -- No Entity name argument given
19963 if Arg_Count >= 1 then
19964 Check_Optional_Identifier (Arg1, Name_Message);
19966 if Arg_Count = 2 then
19967 Check_Optional_Identifier (Arg2, Name_Version);
19971 -- Get immediately preceding declaration
19974 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
19978 -- Cases where we do not follow anything other than another pragma
19982 -- First case: library level compilation unit declaration with
19983 -- the pragma immediately following the declaration.
19985 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
19987 (Defining_Entity (Unit (Parent (Parent (N)))));
19990 -- Case 2: library unit placement for package
19994 Ent : constant Entity_Id := Find_Lib_Unit_Name;
19996 if Is_Package_Or_Generic_Package (Ent) then
19997 Set_Obsolescent (Ent);
20003 -- Cases where we must follow a declaration, including an
20004 -- abstract subprogram declaration, which is not in the
20005 -- other node subtypes.
20008 if Nkind (Decl) not in N_Declaration
20009 and then Nkind (Decl) not in N_Later_Decl_Item
20010 and then Nkind (Decl) not in N_Generic_Declaration
20011 and then Nkind (Decl) not in N_Renaming_Declaration
20012 and then Nkind (Decl) /= N_Abstract_Subprogram_Declaration
20015 ("pragma% misplaced, "
20016 & "must immediately follow a declaration");
20019 Set_Obsolescent (Defining_Entity (Decl));
20029 -- pragma Optimize (Time | Space | Off);
20031 -- The actual check for optimize is done in Gigi. Note that this
20032 -- pragma does not actually change the optimization setting, it
20033 -- simply checks that it is consistent with the pragma.
20035 when Pragma_Optimize =>
20036 Check_No_Identifiers;
20037 Check_Arg_Count (1);
20038 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
20040 ------------------------
20041 -- Optimize_Alignment --
20042 ------------------------
20044 -- pragma Optimize_Alignment (Time | Space | Off);
20046 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
20048 Check_No_Identifiers;
20049 Check_Arg_Count (1);
20050 Check_Valid_Configuration_Pragma;
20053 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
20056 when Name_Off => Opt.Optimize_Alignment := 'O';
20057 when Name_Space => Opt.Optimize_Alignment := 'S';
20058 when Name_Time => Opt.Optimize_Alignment := 'T';
20061 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
20065 -- Set indication that mode is set locally. If we are in fact in a
20066 -- configuration pragma file, this setting is harmless since the
20067 -- switch will get reset anyway at the start of each unit.
20069 Optimize_Alignment_Local := True;
20070 end Optimize_Alignment;
20076 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
20078 when Pragma_Ordered => Ordered : declare
20079 Assoc : constant Node_Id := Arg1;
20085 Check_No_Identifiers;
20086 Check_Arg_Count (1);
20087 Check_Arg_Is_Local_Name (Arg1);
20089 Type_Id := Get_Pragma_Arg (Assoc);
20090 Find_Type (Type_Id);
20091 Typ := Entity (Type_Id);
20093 if Typ = Any_Type then
20096 Typ := Underlying_Type (Typ);
20099 if not Is_Enumeration_Type (Typ) then
20100 Error_Pragma ("pragma% must specify enumeration type");
20103 Check_First_Subtype (Arg1);
20104 Set_Has_Pragma_Ordered (Base_Type (Typ));
20107 -------------------
20108 -- Overflow_Mode --
20109 -------------------
20111 -- pragma Overflow_Mode
20112 -- ([General => ] MODE [, [Assertions => ] MODE]);
20114 -- MODE := STRICT | MINIMIZED | ELIMINATED
20116 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
20117 -- since System.Bignums makes this assumption. This is true of nearly
20118 -- all (all?) targets.
20120 when Pragma_Overflow_Mode => Overflow_Mode : declare
20121 function Get_Overflow_Mode
20123 Arg : Node_Id) return Overflow_Mode_Type;
20124 -- Function to process one pragma argument, Arg. If an identifier
20125 -- is present, it must be Name. Mode type is returned if a valid
20126 -- argument exists, otherwise an error is signalled.
20128 -----------------------
20129 -- Get_Overflow_Mode --
20130 -----------------------
20132 function Get_Overflow_Mode
20134 Arg : Node_Id) return Overflow_Mode_Type
20136 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
20139 Check_Optional_Identifier (Arg, Name);
20140 Check_Arg_Is_Identifier (Argx);
20142 if Chars (Argx) = Name_Strict then
20145 elsif Chars (Argx) = Name_Minimized then
20148 elsif Chars (Argx) = Name_Eliminated then
20149 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then
20151 ("Eliminated not implemented on this target", Argx);
20157 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
20159 end Get_Overflow_Mode;
20161 -- Start of processing for Overflow_Mode
20165 Check_At_Least_N_Arguments (1);
20166 Check_At_Most_N_Arguments (2);
20168 -- Process first argument
20170 Scope_Suppress.Overflow_Mode_General :=
20171 Get_Overflow_Mode (Name_General, Arg1);
20173 -- Case of only one argument
20175 if Arg_Count = 1 then
20176 Scope_Suppress.Overflow_Mode_Assertions :=
20177 Scope_Suppress.Overflow_Mode_General;
20179 -- Case of two arguments present
20182 Scope_Suppress.Overflow_Mode_Assertions :=
20183 Get_Overflow_Mode (Name_Assertions, Arg2);
20187 --------------------------
20188 -- Overriding Renamings --
20189 --------------------------
20191 -- pragma Overriding_Renamings;
20193 when Pragma_Overriding_Renamings =>
20195 Check_Arg_Count (0);
20196 Check_Valid_Configuration_Pragma;
20197 Overriding_Renamings := True;
20203 -- pragma Pack (first_subtype_LOCAL_NAME);
20205 when Pragma_Pack => Pack : declare
20206 Assoc : constant Node_Id := Arg1;
20208 Ignore : Boolean := False;
20213 Check_No_Identifiers;
20214 Check_Arg_Count (1);
20215 Check_Arg_Is_Local_Name (Arg1);
20216 Type_Id := Get_Pragma_Arg (Assoc);
20218 if not Is_Entity_Name (Type_Id)
20219 or else not Is_Type (Entity (Type_Id))
20222 ("argument for pragma% must be type or subtype", Arg1);
20225 Find_Type (Type_Id);
20226 Typ := Entity (Type_Id);
20229 or else Rep_Item_Too_Early (Typ, N)
20233 Typ := Underlying_Type (Typ);
20236 -- A pragma that applies to a Ghost entity becomes Ghost for the
20237 -- purposes of legality checks and removal of ignored Ghost code.
20239 Mark_Ghost_Pragma (N, Typ);
20241 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
20242 Error_Pragma ("pragma% must specify array or record type");
20245 Check_First_Subtype (Arg1);
20246 Check_Duplicate_Pragma (Typ);
20250 if Is_Array_Type (Typ) then
20251 Ctyp := Component_Type (Typ);
20253 -- Ignore pack that does nothing
20255 if Known_Static_Esize (Ctyp)
20256 and then Known_Static_RM_Size (Ctyp)
20257 and then Esize (Ctyp) = RM_Size (Ctyp)
20258 and then Addressable (Esize (Ctyp))
20263 -- Process OK pragma Pack. Note that if there is a separate
20264 -- component clause present, the Pack will be cancelled. This
20265 -- processing is in Freeze.
20267 if not Rep_Item_Too_Late (Typ, N) then
20269 -- In CodePeer mode, we do not need complex front-end
20270 -- expansions related to pragma Pack, so disable handling
20273 if CodePeer_Mode then
20276 -- Normal case where we do the pack action
20280 Set_Is_Packed (Base_Type (Typ));
20281 Set_Has_Non_Standard_Rep (Base_Type (Typ));
20284 Set_Has_Pragma_Pack (Base_Type (Typ));
20288 -- For record types, the pack is always effective
20290 else pragma Assert (Is_Record_Type (Typ));
20291 if not Rep_Item_Too_Late (Typ, N) then
20292 Set_Is_Packed (Base_Type (Typ));
20293 Set_Has_Pragma_Pack (Base_Type (Typ));
20294 Set_Has_Non_Standard_Rep (Base_Type (Typ));
20305 -- There is nothing to do here, since we did all the processing for
20306 -- this pragma in Par.Prag (so that it works properly even in syntax
20309 when Pragma_Page =>
20316 -- pragma Part_Of (ABSTRACT_STATE);
20318 -- ABSTRACT_STATE ::= NAME
20320 when Pragma_Part_Of => Part_Of : declare
20321 procedure Propagate_Part_Of
20322 (Pack_Id : Entity_Id;
20323 State_Id : Entity_Id;
20324 Instance : Node_Id);
20325 -- Propagate the Part_Of indicator to all abstract states and
20326 -- objects declared in the visible state space of a package
20327 -- denoted by Pack_Id. State_Id is the encapsulating state.
20328 -- Instance is the package instantiation node.
20330 -----------------------
20331 -- Propagate_Part_Of --
20332 -----------------------
20334 procedure Propagate_Part_Of
20335 (Pack_Id : Entity_Id;
20336 State_Id : Entity_Id;
20337 Instance : Node_Id)
20339 Has_Item : Boolean := False;
20340 -- Flag set when the visible state space contains at least one
20341 -- abstract state or variable.
20343 procedure Propagate_Part_Of (Pack_Id : Entity_Id);
20344 -- Propagate the Part_Of indicator to all abstract states and
20345 -- objects declared in the visible state space of a package
20346 -- denoted by Pack_Id.
20348 -----------------------
20349 -- Propagate_Part_Of --
20350 -----------------------
20352 procedure Propagate_Part_Of (Pack_Id : Entity_Id) is
20353 Constits : Elist_Id;
20354 Item_Id : Entity_Id;
20357 -- Traverse the entity chain of the package and set relevant
20358 -- attributes of abstract states and objects declared in the
20359 -- visible state space of the package.
20361 Item_Id := First_Entity (Pack_Id);
20362 while Present (Item_Id)
20363 and then not In_Private_Part (Item_Id)
20365 -- Do not consider internally generated items
20367 if not Comes_From_Source (Item_Id) then
20370 -- Do not consider generic formals or their corresponding
20371 -- actuals because they are not part of a visible state.
20372 -- Note that both entities are marked as hidden.
20374 elsif Is_Hidden (Item_Id) then
20377 -- The Part_Of indicator turns an abstract state or an
20378 -- object into a constituent of the encapsulating state.
20379 -- Note that constants are considered here even though
20380 -- they may not depend on variable input. This check is
20381 -- left to the SPARK prover.
20383 elsif Ekind_In (Item_Id, E_Abstract_State,
20388 Constits := Part_Of_Constituents (State_Id);
20390 if No (Constits) then
20391 Constits := New_Elmt_List;
20392 Set_Part_Of_Constituents (State_Id, Constits);
20395 Append_Elmt (Item_Id, Constits);
20396 Set_Encapsulating_State (Item_Id, State_Id);
20398 -- Recursively handle nested packages and instantiations
20400 elsif Ekind (Item_Id) = E_Package then
20401 Propagate_Part_Of (Item_Id);
20404 Next_Entity (Item_Id);
20406 end Propagate_Part_Of;
20408 -- Start of processing for Propagate_Part_Of
20411 Propagate_Part_Of (Pack_Id);
20413 -- Detect a package instantiation that is subject to a Part_Of
20414 -- indicator, but has no visible state.
20416 if not Has_Item then
20418 ("package instantiation & has Part_Of indicator but "
20419 & "lacks visible state", Instance, Pack_Id);
20421 end Propagate_Part_Of;
20425 Constits : Elist_Id;
20427 Encap_Id : Entity_Id;
20428 Item_Id : Entity_Id;
20432 -- Start of processing for Part_Of
20436 Check_No_Identifiers;
20437 Check_Arg_Count (1);
20439 Stmt := Find_Related_Context (N, Do_Checks => True);
20441 -- Object declaration
20443 if Nkind (Stmt) = N_Object_Declaration then
20446 -- Package instantiation
20448 elsif Nkind (Stmt) = N_Package_Instantiation then
20451 -- Single concurrent type declaration
20453 elsif Is_Single_Concurrent_Type_Declaration (Stmt) then
20456 -- Otherwise the pragma is associated with an illegal construct
20463 -- Extract the entity of the related object declaration or package
20464 -- instantiation. In the case of the instantiation, use the entity
20465 -- of the instance spec.
20467 if Nkind (Stmt) = N_Package_Instantiation then
20468 Stmt := Instance_Spec (Stmt);
20471 Item_Id := Defining_Entity (Stmt);
20473 -- A pragma that applies to a Ghost entity becomes Ghost for the
20474 -- purposes of legality checks and removal of ignored Ghost code.
20476 Mark_Ghost_Pragma (N, Item_Id);
20478 -- Chain the pragma on the contract for further processing by
20479 -- Analyze_Part_Of_In_Decl_Part or for completeness.
20481 Add_Contract_Item (N, Item_Id);
20483 -- A variable may act as constituent of a single concurrent type
20484 -- which in turn could be declared after the variable. Due to this
20485 -- discrepancy, the full analysis of indicator Part_Of is delayed
20486 -- until the end of the enclosing declarative region (see routine
20487 -- Analyze_Part_Of_In_Decl_Part).
20489 if Ekind (Item_Id) = E_Variable then
20492 -- Otherwise indicator Part_Of applies to a constant or a package
20496 Encap := Get_Pragma_Arg (Arg1);
20498 -- Detect any discrepancies between the placement of the
20499 -- constant or package instantiation with respect to state
20500 -- space and the encapsulating state.
20504 Item_Id => Item_Id,
20506 Encap_Id => Encap_Id,
20510 pragma Assert (Present (Encap_Id));
20512 if Ekind (Item_Id) = E_Constant then
20513 Constits := Part_Of_Constituents (Encap_Id);
20515 if No (Constits) then
20516 Constits := New_Elmt_List;
20517 Set_Part_Of_Constituents (Encap_Id, Constits);
20520 Append_Elmt (Item_Id, Constits);
20521 Set_Encapsulating_State (Item_Id, Encap_Id);
20523 -- Propagate the Part_Of indicator to the visible state
20524 -- space of the package instantiation.
20528 (Pack_Id => Item_Id,
20529 State_Id => Encap_Id,
20536 ----------------------------------
20537 -- Partition_Elaboration_Policy --
20538 ----------------------------------
20540 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
20542 when Pragma_Partition_Elaboration_Policy => PEP : declare
20543 subtype PEP_Range is Name_Id
20544 range First_Partition_Elaboration_Policy_Name
20545 .. Last_Partition_Elaboration_Policy_Name;
20546 PEP_Val : PEP_Range;
20551 Check_Arg_Count (1);
20552 Check_No_Identifiers;
20553 Check_Arg_Is_Partition_Elaboration_Policy (Arg1);
20554 Check_Valid_Configuration_Pragma;
20555 PEP_Val := Chars (Get_Pragma_Arg (Arg1));
20558 when Name_Concurrent => PEP := 'C';
20559 when Name_Sequential => PEP := 'S';
20562 if Partition_Elaboration_Policy /= ' '
20563 and then Partition_Elaboration_Policy /= PEP
20565 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc;
20567 ("partition elaboration policy incompatible with policy#");
20569 -- Set new policy, but always preserve System_Location since we
20570 -- like the error message with the run time name.
20573 Partition_Elaboration_Policy := PEP;
20575 if Partition_Elaboration_Policy_Sloc /= System_Location then
20576 Partition_Elaboration_Policy_Sloc := Loc;
20585 -- pragma Passive [(PASSIVE_FORM)];
20587 -- PASSIVE_FORM ::= Semaphore | No
20589 when Pragma_Passive =>
20592 if Nkind (Parent (N)) /= N_Task_Definition then
20593 Error_Pragma ("pragma% must be within task definition");
20596 if Arg_Count /= 0 then
20597 Check_Arg_Count (1);
20598 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
20601 ----------------------------------
20602 -- Preelaborable_Initialization --
20603 ----------------------------------
20605 -- pragma Preelaborable_Initialization (DIRECT_NAME);
20607 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
20612 Check_Arg_Count (1);
20613 Check_No_Identifiers;
20614 Check_Arg_Is_Identifier (Arg1);
20615 Check_Arg_Is_Local_Name (Arg1);
20616 Check_First_Subtype (Arg1);
20617 Ent := Entity (Get_Pragma_Arg (Arg1));
20619 -- A pragma that applies to a Ghost entity becomes Ghost for the
20620 -- purposes of legality checks and removal of ignored Ghost code.
20622 Mark_Ghost_Pragma (N, Ent);
20624 -- The pragma may come from an aspect on a private declaration,
20625 -- even if the freeze point at which this is analyzed in the
20626 -- private part after the full view.
20628 if Has_Private_Declaration (Ent)
20629 and then From_Aspect_Specification (N)
20633 -- Check appropriate type argument
20635 elsif Is_Private_Type (Ent)
20636 or else Is_Protected_Type (Ent)
20637 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))
20639 -- AI05-0028: The pragma applies to all composite types. Note
20640 -- that we apply this binding interpretation to earlier versions
20641 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
20642 -- choice since there are other compilers that do the same.
20644 or else Is_Composite_Type (Ent)
20650 ("pragma % can only be applied to private, formal derived, "
20651 & "protected, or composite type", Arg1);
20654 -- Give an error if the pragma is applied to a protected type that
20655 -- does not qualify (due to having entries, or due to components
20656 -- that do not qualify).
20658 if Is_Protected_Type (Ent)
20659 and then not Has_Preelaborable_Initialization (Ent)
20662 ("protected type & does not have preelaborable "
20663 & "initialization", Ent);
20665 -- Otherwise mark the type as definitely having preelaborable
20669 Set_Known_To_Have_Preelab_Init (Ent);
20672 if Has_Pragma_Preelab_Init (Ent)
20673 and then Warn_On_Redundant_Constructs
20675 Error_Pragma ("?r?duplicate pragma%!");
20677 Set_Has_Pragma_Preelab_Init (Ent);
20681 --------------------
20682 -- Persistent_BSS --
20683 --------------------
20685 -- pragma Persistent_BSS [(object_NAME)];
20687 when Pragma_Persistent_BSS => Persistent_BSS : declare
20694 Check_At_Most_N_Arguments (1);
20696 -- Case of application to specific object (one argument)
20698 if Arg_Count = 1 then
20699 Check_Arg_Is_Library_Level_Local_Name (Arg1);
20701 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
20703 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
20706 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
20709 Ent := Entity (Get_Pragma_Arg (Arg1));
20711 -- A pragma that applies to a Ghost entity becomes Ghost for
20712 -- the purposes of legality checks and removal of ignored Ghost
20715 Mark_Ghost_Pragma (N, Ent);
20717 -- Check for duplication before inserting in list of
20718 -- representation items.
20720 Check_Duplicate_Pragma (Ent);
20722 if Rep_Item_Too_Late (Ent, N) then
20726 Decl := Parent (Ent);
20728 if Present (Expression (Decl)) then
20729 -- Variables in Persistent_BSS cannot be initialized, so
20730 -- turn off any initialization that might be caused by
20731 -- pragmas Initialize_Scalars or Normalize_Scalars.
20733 if Kill_Range_Check (Expression (Decl)) then
20736 Name_Suppress_Initialization,
20737 Pragma_Argument_Associations => New_List (
20738 Make_Pragma_Argument_Association (Loc,
20739 Expression => New_Occurrence_Of (Ent, Loc))));
20740 Insert_Before (N, Prag);
20745 ("object for pragma% cannot have initialization", Arg1);
20749 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
20751 ("object type for pragma% is not potentially persistent",
20756 Make_Linker_Section_Pragma
20757 (Ent, Loc, ".persistent.bss");
20758 Insert_After (N, Prag);
20761 -- Case of use as configuration pragma with no arguments
20764 Check_Valid_Configuration_Pragma;
20765 Persistent_BSS_Mode := True;
20767 end Persistent_BSS;
20769 --------------------
20770 -- Rename_Pragma --
20771 --------------------
20773 -- pragma Rename_Pragma (
20774 -- [New_Name =>] IDENTIFIER,
20775 -- [Renamed =>] pragma_IDENTIFIER);
20777 when Pragma_Rename_Pragma => Rename_Pragma : declare
20778 New_Name : constant Node_Id := Get_Pragma_Arg (Arg1);
20779 Old_Name : constant Node_Id := Get_Pragma_Arg (Arg2);
20783 Check_Valid_Configuration_Pragma;
20784 Check_Arg_Count (2);
20785 Check_Optional_Identifier (Arg1, Name_New_Name);
20786 Check_Optional_Identifier (Arg2, Name_Renamed);
20788 if Nkind (New_Name) /= N_Identifier then
20789 Error_Pragma_Arg ("identifier expected", Arg1);
20792 if Nkind (Old_Name) /= N_Identifier then
20793 Error_Pragma_Arg ("identifier expected", Arg2);
20796 -- The New_Name arg should not be an existing pragma (but we allow
20797 -- it; it's just a warning). The Old_Name arg must be an existing
20800 if Is_Pragma_Name (Chars (New_Name)) then
20801 Error_Pragma_Arg ("??pragma is already defined", Arg1);
20804 if not Is_Pragma_Name (Chars (Old_Name)) then
20805 Error_Pragma_Arg ("existing pragma name expected", Arg1);
20808 Map_Pragma_Name (From => Chars (New_Name), To => Chars (Old_Name));
20815 -- pragma Polling (ON | OFF);
20817 when Pragma_Polling =>
20819 Check_Arg_Count (1);
20820 Check_No_Identifiers;
20821 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
20822 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
20824 -----------------------------------
20825 -- Post/Post_Class/Postcondition --
20826 -----------------------------------
20828 -- pragma Post (Boolean_EXPRESSION);
20829 -- pragma Post_Class (Boolean_EXPRESSION);
20830 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
20831 -- [,[Message =>] String_EXPRESSION]);
20833 -- Characteristics:
20835 -- * Analysis - The annotation undergoes initial checks to verify
20836 -- the legal placement and context. Secondary checks preanalyze the
20839 -- Analyze_Pre_Post_Condition_In_Decl_Part
20841 -- * Expansion - The annotation is expanded during the expansion of
20842 -- the related subprogram [body] contract as performed in:
20844 -- Expand_Subprogram_Contract
20846 -- * Template - The annotation utilizes the generic template of the
20847 -- related subprogram [body] when it is:
20849 -- aspect on subprogram declaration
20850 -- aspect on stand-alone subprogram body
20851 -- pragma on stand-alone subprogram body
20853 -- The annotation must prepare its own template when it is:
20855 -- pragma on subprogram declaration
20857 -- * Globals - Capture of global references must occur after full
20860 -- * Instance - The annotation is instantiated automatically when
20861 -- the related generic subprogram [body] is instantiated except for
20862 -- the "pragma on subprogram declaration" case. In that scenario
20863 -- the annotation must instantiate itself.
20866 | Pragma_Post_Class
20867 | Pragma_Postcondition
20869 Analyze_Pre_Post_Condition;
20871 --------------------------------
20872 -- Pre/Pre_Class/Precondition --
20873 --------------------------------
20875 -- pragma Pre (Boolean_EXPRESSION);
20876 -- pragma Pre_Class (Boolean_EXPRESSION);
20877 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
20878 -- [,[Message =>] String_EXPRESSION]);
20880 -- Characteristics:
20882 -- * Analysis - The annotation undergoes initial checks to verify
20883 -- the legal placement and context. Secondary checks preanalyze the
20886 -- Analyze_Pre_Post_Condition_In_Decl_Part
20888 -- * Expansion - The annotation is expanded during the expansion of
20889 -- the related subprogram [body] contract as performed in:
20891 -- Expand_Subprogram_Contract
20893 -- * Template - The annotation utilizes the generic template of the
20894 -- related subprogram [body] when it is:
20896 -- aspect on subprogram declaration
20897 -- aspect on stand-alone subprogram body
20898 -- pragma on stand-alone subprogram body
20900 -- The annotation must prepare its own template when it is:
20902 -- pragma on subprogram declaration
20904 -- * Globals - Capture of global references must occur after full
20907 -- * Instance - The annotation is instantiated automatically when
20908 -- the related generic subprogram [body] is instantiated except for
20909 -- the "pragma on subprogram declaration" case. In that scenario
20910 -- the annotation must instantiate itself.
20914 | Pragma_Precondition
20916 Analyze_Pre_Post_Condition;
20922 -- pragma Predicate
20923 -- ([Entity =>] type_LOCAL_NAME,
20924 -- [Check =>] boolean_EXPRESSION);
20926 when Pragma_Predicate => Predicate : declare
20933 Check_Arg_Count (2);
20934 Check_Optional_Identifier (Arg1, Name_Entity);
20935 Check_Optional_Identifier (Arg2, Name_Check);
20937 Check_Arg_Is_Local_Name (Arg1);
20939 Type_Id := Get_Pragma_Arg (Arg1);
20940 Find_Type (Type_Id);
20941 Typ := Entity (Type_Id);
20943 if Typ = Any_Type then
20947 -- A pragma that applies to a Ghost entity becomes Ghost for the
20948 -- purposes of legality checks and removal of ignored Ghost code.
20950 Mark_Ghost_Pragma (N, Typ);
20952 -- The remaining processing is simply to link the pragma on to
20953 -- the rep item chain, for processing when the type is frozen.
20954 -- This is accomplished by a call to Rep_Item_Too_Late. We also
20955 -- mark the type as having predicates.
20957 -- If the current policy for predicate checking is Ignore mark the
20958 -- subtype accordingly. In the case of predicates we consider them
20959 -- enabled unless Ignore is specified (either directly or with a
20960 -- general Assertion_Policy pragma) to preserve existing warnings.
20962 Set_Has_Predicates (Typ);
20964 -- Indicate that the pragma must be processed at the point the
20965 -- type is frozen, as is done for the corresponding aspect.
20967 Set_Has_Delayed_Aspects (Typ);
20968 Set_Has_Delayed_Freeze (Typ);
20970 Set_Predicates_Ignored (Typ,
20971 Present (Check_Policy_List)
20973 Policy_In_Effect (Name_Dynamic_Predicate) = Name_Ignore);
20974 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
20977 -----------------------
20978 -- Predicate_Failure --
20979 -----------------------
20981 -- pragma Predicate_Failure
20982 -- ([Entity =>] type_LOCAL_NAME,
20983 -- [Message =>] string_EXPRESSION);
20985 when Pragma_Predicate_Failure => Predicate_Failure : declare
20992 Check_Arg_Count (2);
20993 Check_Optional_Identifier (Arg1, Name_Entity);
20994 Check_Optional_Identifier (Arg2, Name_Message);
20996 Check_Arg_Is_Local_Name (Arg1);
20998 Type_Id := Get_Pragma_Arg (Arg1);
20999 Find_Type (Type_Id);
21000 Typ := Entity (Type_Id);
21002 if Typ = Any_Type then
21006 -- A pragma that applies to a Ghost entity becomes Ghost for the
21007 -- purposes of legality checks and removal of ignored Ghost code.
21009 Mark_Ghost_Pragma (N, Typ);
21011 -- The remaining processing is simply to link the pragma on to
21012 -- the rep item chain, for processing when the type is frozen.
21013 -- This is accomplished by a call to Rep_Item_Too_Late.
21015 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
21016 end Predicate_Failure;
21022 -- pragma Preelaborate [(library_unit_NAME)];
21024 -- Set the flag Is_Preelaborated of program unit name entity
21026 when Pragma_Preelaborate => Preelaborate : declare
21027 Pa : constant Node_Id := Parent (N);
21028 Pk : constant Node_Kind := Nkind (Pa);
21032 Check_Ada_83_Warning;
21033 Check_Valid_Library_Unit_Pragma;
21035 if Nkind (N) = N_Null_Statement then
21039 Ent := Find_Lib_Unit_Name;
21041 -- A pragma that applies to a Ghost entity becomes Ghost for the
21042 -- purposes of legality checks and removal of ignored Ghost code.
21044 Mark_Ghost_Pragma (N, Ent);
21045 Check_Duplicate_Pragma (Ent);
21047 -- This filters out pragmas inside generic parents that show up
21048 -- inside instantiations. Pragmas that come from aspects in the
21049 -- unit are not ignored.
21051 if Present (Ent) then
21052 if Pk = N_Package_Specification
21053 and then Present (Generic_Parent (Pa))
21054 and then not From_Aspect_Specification (N)
21059 if not Debug_Flag_U then
21060 Set_Is_Preelaborated (Ent);
21062 if Legacy_Elaboration_Checks then
21063 Set_Suppress_Elaboration_Warnings (Ent);
21070 -------------------------------
21071 -- Prefix_Exception_Messages --
21072 -------------------------------
21074 -- pragma Prefix_Exception_Messages;
21076 when Pragma_Prefix_Exception_Messages =>
21078 Check_Valid_Configuration_Pragma;
21079 Check_Arg_Count (0);
21080 Prefix_Exception_Messages := True;
21086 -- pragma Priority (EXPRESSION);
21088 when Pragma_Priority => Priority : declare
21089 P : constant Node_Id := Parent (N);
21094 Check_No_Identifiers;
21095 Check_Arg_Count (1);
21099 if Nkind (P) = N_Subprogram_Body then
21100 Check_In_Main_Program;
21102 Ent := Defining_Unit_Name (Specification (P));
21104 if Nkind (Ent) = N_Defining_Program_Unit_Name then
21105 Ent := Defining_Identifier (Ent);
21108 Arg := Get_Pragma_Arg (Arg1);
21109 Analyze_And_Resolve (Arg, Standard_Integer);
21113 if not Is_OK_Static_Expression (Arg) then
21114 Flag_Non_Static_Expr
21115 ("main subprogram priority is not static!", Arg);
21118 -- If constraint error, then we already signalled an error
21120 elsif Raises_Constraint_Error (Arg) then
21123 -- Otherwise check in range except if Relaxed_RM_Semantics
21124 -- where we ignore the value if out of range.
21127 if not Relaxed_RM_Semantics
21128 and then not Is_In_Range (Arg, RTE (RE_Priority))
21131 ("main subprogram priority is out of range", Arg1);
21134 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
21138 -- Load an arbitrary entity from System.Tasking.Stages or
21139 -- System.Tasking.Restricted.Stages (depending on the
21140 -- supported profile) to make sure that one of these packages
21141 -- is implicitly with'ed, since we need to have the tasking
21142 -- run time active for the pragma Priority to have any effect.
21143 -- Previously we with'ed the package System.Tasking, but this
21144 -- package does not trigger the required initialization of the
21145 -- run-time library.
21148 Discard : Entity_Id;
21149 pragma Warnings (Off, Discard);
21151 if Restricted_Profile then
21152 Discard := RTE (RE_Activate_Restricted_Tasks);
21154 Discard := RTE (RE_Activate_Tasks);
21158 -- Task or Protected, must be of type Integer
21160 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
21161 Arg := Get_Pragma_Arg (Arg1);
21162 Ent := Defining_Identifier (Parent (P));
21164 -- The expression must be analyzed in the special manner
21165 -- described in "Handling of Default and Per-Object
21166 -- Expressions" in sem.ads.
21168 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority));
21170 if not Is_OK_Static_Expression (Arg) then
21171 Check_Restriction (Static_Priorities, Arg);
21174 -- Anything else is incorrect
21180 -- Check duplicate pragma before we chain the pragma in the Rep
21181 -- Item chain of Ent.
21183 Check_Duplicate_Pragma (Ent);
21184 Record_Rep_Item (Ent, N);
21187 -----------------------------------
21188 -- Priority_Specific_Dispatching --
21189 -----------------------------------
21191 -- pragma Priority_Specific_Dispatching (
21192 -- policy_IDENTIFIER,
21193 -- first_priority_EXPRESSION,
21194 -- last_priority_EXPRESSION);
21196 when Pragma_Priority_Specific_Dispatching =>
21197 Priority_Specific_Dispatching : declare
21198 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
21199 -- This is the entity System.Any_Priority;
21202 Lower_Bound : Node_Id;
21203 Upper_Bound : Node_Id;
21209 Check_Arg_Count (3);
21210 Check_No_Identifiers;
21211 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
21212 Check_Valid_Configuration_Pragma;
21213 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
21214 DP := Fold_Upper (Name_Buffer (1));
21216 Lower_Bound := Get_Pragma_Arg (Arg2);
21217 Check_Arg_Is_OK_Static_Expression (Lower_Bound, Standard_Integer);
21218 Lower_Val := Expr_Value (Lower_Bound);
21220 Upper_Bound := Get_Pragma_Arg (Arg3);
21221 Check_Arg_Is_OK_Static_Expression (Upper_Bound, Standard_Integer);
21222 Upper_Val := Expr_Value (Upper_Bound);
21224 -- It is not allowed to use Task_Dispatching_Policy and
21225 -- Priority_Specific_Dispatching in the same partition.
21227 if Task_Dispatching_Policy /= ' ' then
21228 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
21230 ("pragma% incompatible with Task_Dispatching_Policy#");
21232 -- Check lower bound in range
21234 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
21236 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
21239 ("first_priority is out of range", Arg2);
21241 -- Check upper bound in range
21243 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
21245 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
21248 ("last_priority is out of range", Arg3);
21250 -- Check that the priority range is valid
21252 elsif Lower_Val > Upper_Val then
21254 ("last_priority_expression must be greater than or equal to "
21255 & "first_priority_expression");
21257 -- Store the new policy, but always preserve System_Location since
21258 -- we like the error message with the run-time name.
21261 -- Check overlapping in the priority ranges specified in other
21262 -- Priority_Specific_Dispatching pragmas within the same
21263 -- partition. We can only check those we know about.
21266 Specific_Dispatching.First .. Specific_Dispatching.Last
21268 if Specific_Dispatching.Table (J).First_Priority in
21269 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
21270 or else Specific_Dispatching.Table (J).Last_Priority in
21271 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
21274 Specific_Dispatching.Table (J).Pragma_Loc;
21276 ("priority range overlaps with "
21277 & "Priority_Specific_Dispatching#");
21281 -- The use of Priority_Specific_Dispatching is incompatible
21282 -- with Task_Dispatching_Policy.
21284 if Task_Dispatching_Policy /= ' ' then
21285 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
21287 ("Priority_Specific_Dispatching incompatible "
21288 & "with Task_Dispatching_Policy#");
21291 -- The use of Priority_Specific_Dispatching forces ceiling
21294 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
21295 Error_Msg_Sloc := Locking_Policy_Sloc;
21297 ("Priority_Specific_Dispatching incompatible "
21298 & "with Locking_Policy#");
21300 -- Set the Ceiling_Locking policy, but preserve System_Location
21301 -- since we like the error message with the run time name.
21304 Locking_Policy := 'C';
21306 if Locking_Policy_Sloc /= System_Location then
21307 Locking_Policy_Sloc := Loc;
21311 -- Add entry in the table
21313 Specific_Dispatching.Append
21314 ((Dispatching_Policy => DP,
21315 First_Priority => UI_To_Int (Lower_Val),
21316 Last_Priority => UI_To_Int (Upper_Val),
21317 Pragma_Loc => Loc));
21319 end Priority_Specific_Dispatching;
21325 -- pragma Profile (profile_IDENTIFIER);
21327 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
21329 when Pragma_Profile =>
21331 Check_Arg_Count (1);
21332 Check_Valid_Configuration_Pragma;
21333 Check_No_Identifiers;
21336 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21339 if Chars (Argx) = Name_Ravenscar then
21340 Set_Ravenscar_Profile (Ravenscar, N);
21342 elsif Chars (Argx) = Name_Jorvik then
21343 Set_Ravenscar_Profile (Jorvik, N);
21345 elsif Chars (Argx) = Name_Gnat_Extended_Ravenscar then
21346 Set_Ravenscar_Profile (GNAT_Extended_Ravenscar, N);
21348 elsif Chars (Argx) = Name_Gnat_Ravenscar_EDF then
21349 Set_Ravenscar_Profile (GNAT_Ravenscar_EDF, N);
21351 elsif Chars (Argx) = Name_Restricted then
21352 Set_Profile_Restrictions
21354 N, Warn => Treat_Restrictions_As_Warnings);
21356 elsif Chars (Argx) = Name_Rational then
21357 Set_Rational_Profile;
21359 elsif Chars (Argx) = Name_No_Implementation_Extensions then
21360 Set_Profile_Restrictions
21361 (No_Implementation_Extensions,
21362 N, Warn => Treat_Restrictions_As_Warnings);
21365 Error_Pragma_Arg ("& is not a valid profile", Argx);
21369 ----------------------
21370 -- Profile_Warnings --
21371 ----------------------
21373 -- pragma Profile_Warnings (profile_IDENTIFIER);
21375 -- profile_IDENTIFIER => Restricted | Ravenscar
21377 when Pragma_Profile_Warnings =>
21379 Check_Arg_Count (1);
21380 Check_Valid_Configuration_Pragma;
21381 Check_No_Identifiers;
21384 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21387 if Chars (Argx) = Name_Ravenscar then
21388 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
21390 elsif Chars (Argx) = Name_Restricted then
21391 Set_Profile_Restrictions (Restricted, N, Warn => True);
21393 elsif Chars (Argx) = Name_No_Implementation_Extensions then
21394 Set_Profile_Restrictions
21395 (No_Implementation_Extensions, N, Warn => True);
21398 Error_Pragma_Arg ("& is not a valid profile", Argx);
21402 --------------------------
21403 -- Propagate_Exceptions --
21404 --------------------------
21406 -- pragma Propagate_Exceptions;
21408 -- Note: this pragma is obsolete and has no effect
21410 when Pragma_Propagate_Exceptions =>
21412 Check_Arg_Count (0);
21414 if Warn_On_Obsolescent_Feature then
21416 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
21417 "and has no effect?j?", N);
21420 -----------------------------
21421 -- Provide_Shift_Operators --
21422 -----------------------------
21424 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
21426 when Pragma_Provide_Shift_Operators =>
21427 Provide_Shift_Operators : declare
21430 procedure Declare_Shift_Operator (Nam : Name_Id);
21431 -- Insert declaration and pragma Instrinsic for named shift op
21433 ----------------------------
21434 -- Declare_Shift_Operator --
21435 ----------------------------
21437 procedure Declare_Shift_Operator (Nam : Name_Id) is
21443 Make_Subprogram_Declaration (Loc,
21444 Make_Function_Specification (Loc,
21445 Defining_Unit_Name =>
21446 Make_Defining_Identifier (Loc, Chars => Nam),
21448 Result_Definition =>
21449 Make_Identifier (Loc, Chars => Chars (Ent)),
21451 Parameter_Specifications => New_List (
21452 Make_Parameter_Specification (Loc,
21453 Defining_Identifier =>
21454 Make_Defining_Identifier (Loc, Name_Value),
21456 Make_Identifier (Loc, Chars => Chars (Ent))),
21458 Make_Parameter_Specification (Loc,
21459 Defining_Identifier =>
21460 Make_Defining_Identifier (Loc, Name_Amount),
21462 New_Occurrence_Of (Standard_Natural, Loc)))));
21466 Chars => Name_Import,
21467 Pragma_Argument_Associations => New_List (
21468 Make_Pragma_Argument_Association (Loc,
21469 Expression => Make_Identifier (Loc, Name_Intrinsic)),
21470 Make_Pragma_Argument_Association (Loc,
21471 Expression => Make_Identifier (Loc, Nam))));
21473 Insert_After (N, Import);
21474 Insert_After (N, Func);
21475 end Declare_Shift_Operator;
21477 -- Start of processing for Provide_Shift_Operators
21481 Check_Arg_Count (1);
21482 Check_Arg_Is_Local_Name (Arg1);
21484 Arg1 := Get_Pragma_Arg (Arg1);
21486 -- We must have an entity name
21488 if not Is_Entity_Name (Arg1) then
21490 ("pragma % must apply to integer first subtype", Arg1);
21493 -- If no Entity, means there was a prior error so ignore
21495 if Present (Entity (Arg1)) then
21496 Ent := Entity (Arg1);
21498 -- Apply error checks
21500 if not Is_First_Subtype (Ent) then
21502 ("cannot apply pragma %",
21503 "\& is not a first subtype",
21506 elsif not Is_Integer_Type (Ent) then
21508 ("cannot apply pragma %",
21509 "\& is not an integer type",
21512 elsif Has_Shift_Operator (Ent) then
21514 ("cannot apply pragma %",
21515 "\& already has declared shift operators",
21518 elsif Is_Frozen (Ent) then
21520 ("pragma % appears too late",
21521 "\& is already frozen",
21525 -- Now declare the operators. We do this during analysis rather
21526 -- than expansion, since we want the operators available if we
21527 -- are operating in -gnatc mode.
21529 Declare_Shift_Operator (Name_Rotate_Left);
21530 Declare_Shift_Operator (Name_Rotate_Right);
21531 Declare_Shift_Operator (Name_Shift_Left);
21532 Declare_Shift_Operator (Name_Shift_Right);
21533 Declare_Shift_Operator (Name_Shift_Right_Arithmetic);
21535 end Provide_Shift_Operators;
21541 -- pragma Psect_Object (
21542 -- [Internal =>] LOCAL_NAME,
21543 -- [, [External =>] EXTERNAL_SYMBOL]
21544 -- [, [Size =>] EXTERNAL_SYMBOL]);
21546 when Pragma_Common_Object
21547 | Pragma_Psect_Object
21549 Psect_Object : declare
21550 Args : Args_List (1 .. 3);
21551 Names : constant Name_List (1 .. 3) := (
21556 Internal : Node_Id renames Args (1);
21557 External : Node_Id renames Args (2);
21558 Size : Node_Id renames Args (3);
21560 Def_Id : Entity_Id;
21562 procedure Check_Arg (Arg : Node_Id);
21563 -- Checks that argument is either a string literal or an
21564 -- identifier, and posts error message if not.
21570 procedure Check_Arg (Arg : Node_Id) is
21572 if not Nkind_In (Original_Node (Arg),
21577 ("inappropriate argument for pragma %", Arg);
21581 -- Start of processing for Common_Object/Psect_Object
21585 Gather_Associations (Names, Args);
21586 Process_Extended_Import_Export_Internal_Arg (Internal);
21588 Def_Id := Entity (Internal);
21590 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
21592 ("pragma% must designate an object", Internal);
21595 Check_Arg (Internal);
21597 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
21599 ("cannot use pragma% for imported/exported object",
21603 if Is_Concurrent_Type (Etype (Internal)) then
21605 ("cannot specify pragma % for task/protected object",
21609 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
21611 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
21613 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N);
21616 if Ekind (Def_Id) = E_Constant then
21618 ("cannot specify pragma % for a constant", Internal);
21621 if Is_Record_Type (Etype (Internal)) then
21627 Ent := First_Entity (Etype (Internal));
21628 while Present (Ent) loop
21629 Decl := Declaration_Node (Ent);
21631 if Ekind (Ent) = E_Component
21632 and then Nkind (Decl) = N_Component_Declaration
21633 and then Present (Expression (Decl))
21634 and then Warn_On_Export_Import
21637 ("?x?object for pragma % has defaults", Internal);
21647 if Present (Size) then
21651 if Present (External) then
21652 Check_Arg_Is_External_Name (External);
21655 -- If all error tests pass, link pragma on to the rep item chain
21657 Record_Rep_Item (Def_Id, N);
21664 -- pragma Pure [(library_unit_NAME)];
21666 when Pragma_Pure => Pure : declare
21670 Check_Ada_83_Warning;
21672 -- If the pragma comes from a subprogram instantiation, nothing to
21673 -- check, this can happen at any level of nesting.
21675 if Is_Wrapper_Package (Current_Scope) then
21678 Check_Valid_Library_Unit_Pragma;
21681 if Nkind (N) = N_Null_Statement then
21685 Ent := Find_Lib_Unit_Name;
21687 -- A pragma that applies to a Ghost entity becomes Ghost for the
21688 -- purposes of legality checks and removal of ignored Ghost code.
21690 Mark_Ghost_Pragma (N, Ent);
21692 if not Debug_Flag_U then
21694 Set_Has_Pragma_Pure (Ent);
21696 if Legacy_Elaboration_Checks then
21697 Set_Suppress_Elaboration_Warnings (Ent);
21702 -------------------
21703 -- Pure_Function --
21704 -------------------
21706 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
21708 when Pragma_Pure_Function => Pure_Function : declare
21709 Def_Id : Entity_Id;
21712 Effective : Boolean := False;
21713 Orig_Def : Entity_Id;
21714 Same_Decl : Boolean := False;
21718 Check_Arg_Count (1);
21719 Check_Optional_Identifier (Arg1, Name_Entity);
21720 Check_Arg_Is_Local_Name (Arg1);
21721 E_Id := Get_Pragma_Arg (Arg1);
21723 if Etype (E_Id) = Any_Type then
21727 -- Loop through homonyms (overloadings) of referenced entity
21729 E := Entity (E_Id);
21731 -- A pragma that applies to a Ghost entity becomes Ghost for the
21732 -- purposes of legality checks and removal of ignored Ghost code.
21734 Mark_Ghost_Pragma (N, E);
21736 if Present (E) then
21738 Def_Id := Get_Base_Subprogram (E);
21740 if not Ekind_In (Def_Id, E_Function,
21741 E_Generic_Function,
21745 ("pragma% requires a function name", Arg1);
21748 -- When we have a generic function we must jump up a level
21749 -- to the declaration of the wrapper package itself.
21751 Orig_Def := Def_Id;
21753 if Is_Generic_Instance (Def_Id) then
21754 while Nkind (Orig_Def) /= N_Package_Declaration loop
21755 Orig_Def := Parent (Orig_Def);
21759 if In_Same_Declarative_Part (Parent (N), Orig_Def) then
21761 Set_Is_Pure (Def_Id);
21763 if not Has_Pragma_Pure_Function (Def_Id) then
21764 Set_Has_Pragma_Pure_Function (Def_Id);
21769 exit when From_Aspect_Specification (N);
21771 exit when No (E) or else Scope (E) /= Current_Scope;
21775 and then Warn_On_Redundant_Constructs
21778 ("pragma Pure_Function on& is redundant?r?",
21781 elsif not Same_Decl then
21783 ("pragma% argument must be in same declarative part",
21789 --------------------
21790 -- Queuing_Policy --
21791 --------------------
21793 -- pragma Queuing_Policy (policy_IDENTIFIER);
21795 when Pragma_Queuing_Policy => declare
21799 Check_Ada_83_Warning;
21800 Check_Arg_Count (1);
21801 Check_No_Identifiers;
21802 Check_Arg_Is_Queuing_Policy (Arg1);
21803 Check_Valid_Configuration_Pragma;
21804 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
21805 QP := Fold_Upper (Name_Buffer (1));
21807 if Queuing_Policy /= ' '
21808 and then Queuing_Policy /= QP
21810 Error_Msg_Sloc := Queuing_Policy_Sloc;
21811 Error_Pragma ("queuing policy incompatible with policy#");
21813 -- Set new policy, but always preserve System_Location since we
21814 -- like the error message with the run time name.
21817 Queuing_Policy := QP;
21819 if Queuing_Policy_Sloc /= System_Location then
21820 Queuing_Policy_Sloc := Loc;
21829 -- pragma Rational, for compatibility with foreign compiler
21831 when Pragma_Rational =>
21832 Set_Rational_Profile;
21834 ---------------------
21835 -- Refined_Depends --
21836 ---------------------
21838 -- pragma Refined_Depends (DEPENDENCY_RELATION);
21840 -- DEPENDENCY_RELATION ::=
21842 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
21844 -- DEPENDENCY_CLAUSE ::=
21845 -- OUTPUT_LIST =>[+] INPUT_LIST
21846 -- | NULL_DEPENDENCY_CLAUSE
21848 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
21850 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
21852 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
21854 -- OUTPUT ::= NAME | FUNCTION_RESULT
21857 -- where FUNCTION_RESULT is a function Result attribute_reference
21859 -- Characteristics:
21861 -- * Analysis - The annotation undergoes initial checks to verify
21862 -- the legal placement and context. Secondary checks fully analyze
21863 -- the dependency clauses/global list in:
21865 -- Analyze_Refined_Depends_In_Decl_Part
21867 -- * Expansion - None.
21869 -- * Template - The annotation utilizes the generic template of the
21870 -- related subprogram body.
21872 -- * Globals - Capture of global references must occur after full
21875 -- * Instance - The annotation is instantiated automatically when
21876 -- the related generic subprogram body is instantiated.
21878 when Pragma_Refined_Depends => Refined_Depends : declare
21879 Body_Id : Entity_Id;
21881 Spec_Id : Entity_Id;
21884 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
21888 -- Chain the pragma on the contract for further processing by
21889 -- Analyze_Refined_Depends_In_Decl_Part.
21891 Add_Contract_Item (N, Body_Id);
21893 -- The legality checks of pragmas Refined_Depends and
21894 -- Refined_Global are affected by the SPARK mode in effect and
21895 -- the volatility of the context. In addition these two pragmas
21896 -- are subject to an inherent order:
21898 -- 1) Refined_Global
21899 -- 2) Refined_Depends
21901 -- Analyze all these pragmas in the order outlined above
21903 Analyze_If_Present (Pragma_SPARK_Mode);
21904 Analyze_If_Present (Pragma_Volatile_Function);
21905 Analyze_If_Present (Pragma_Refined_Global);
21906 Analyze_Refined_Depends_In_Decl_Part (N);
21908 end Refined_Depends;
21910 --------------------
21911 -- Refined_Global --
21912 --------------------
21914 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
21916 -- GLOBAL_SPECIFICATION ::=
21919 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
21921 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
21923 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
21924 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
21925 -- GLOBAL_ITEM ::= NAME
21927 -- Characteristics:
21929 -- * Analysis - The annotation undergoes initial checks to verify
21930 -- the legal placement and context. Secondary checks fully analyze
21931 -- the dependency clauses/global list in:
21933 -- Analyze_Refined_Global_In_Decl_Part
21935 -- * Expansion - None.
21937 -- * Template - The annotation utilizes the generic template of the
21938 -- related subprogram body.
21940 -- * Globals - Capture of global references must occur after full
21943 -- * Instance - The annotation is instantiated automatically when
21944 -- the related generic subprogram body is instantiated.
21946 when Pragma_Refined_Global => Refined_Global : declare
21947 Body_Id : Entity_Id;
21949 Spec_Id : Entity_Id;
21952 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
21956 -- Chain the pragma on the contract for further processing by
21957 -- Analyze_Refined_Global_In_Decl_Part.
21959 Add_Contract_Item (N, Body_Id);
21961 -- The legality checks of pragmas Refined_Depends and
21962 -- Refined_Global are affected by the SPARK mode in effect and
21963 -- the volatility of the context. In addition these two pragmas
21964 -- are subject to an inherent order:
21966 -- 1) Refined_Global
21967 -- 2) Refined_Depends
21969 -- Analyze all these pragmas in the order outlined above
21971 Analyze_If_Present (Pragma_SPARK_Mode);
21972 Analyze_If_Present (Pragma_Volatile_Function);
21973 Analyze_Refined_Global_In_Decl_Part (N);
21974 Analyze_If_Present (Pragma_Refined_Depends);
21976 end Refined_Global;
21982 -- pragma Refined_Post (boolean_EXPRESSION);
21984 -- Characteristics:
21986 -- * Analysis - The annotation is fully analyzed immediately upon
21987 -- elaboration as it cannot forward reference entities.
21989 -- * Expansion - The annotation is expanded during the expansion of
21990 -- the related subprogram body contract as performed in:
21992 -- Expand_Subprogram_Contract
21994 -- * Template - The annotation utilizes the generic template of the
21995 -- related subprogram body.
21997 -- * Globals - Capture of global references must occur after full
22000 -- * Instance - The annotation is instantiated automatically when
22001 -- the related generic subprogram body is instantiated.
22003 when Pragma_Refined_Post => Refined_Post : declare
22004 Body_Id : Entity_Id;
22006 Spec_Id : Entity_Id;
22009 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
22011 -- Fully analyze the pragma when it appears inside a subprogram
22012 -- body because it cannot benefit from forward references.
22016 -- Chain the pragma on the contract for completeness
22018 Add_Contract_Item (N, Body_Id);
22020 -- The legality checks of pragma Refined_Post are affected by
22021 -- the SPARK mode in effect and the volatility of the context.
22022 -- Analyze all pragmas in a specific order.
22024 Analyze_If_Present (Pragma_SPARK_Mode);
22025 Analyze_If_Present (Pragma_Volatile_Function);
22026 Analyze_Pre_Post_Condition_In_Decl_Part (N);
22028 -- Currently it is not possible to inline pre/postconditions on
22029 -- a subprogram subject to pragma Inline_Always.
22031 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
22035 -------------------
22036 -- Refined_State --
22037 -------------------
22039 -- pragma Refined_State (REFINEMENT_LIST);
22041 -- REFINEMENT_LIST ::=
22042 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
22044 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
22046 -- CONSTITUENT_LIST ::=
22049 -- | (CONSTITUENT {, CONSTITUENT})
22051 -- CONSTITUENT ::= object_NAME | state_NAME
22053 -- Characteristics:
22055 -- * Analysis - The annotation undergoes initial checks to verify
22056 -- the legal placement and context. Secondary checks preanalyze the
22057 -- refinement clauses in:
22059 -- Analyze_Refined_State_In_Decl_Part
22061 -- * Expansion - None.
22063 -- * Template - The annotation utilizes the template of the related
22066 -- * Globals - Capture of global references must occur after full
22069 -- * Instance - The annotation is instantiated automatically when
22070 -- the related generic package body is instantiated.
22072 when Pragma_Refined_State => Refined_State : declare
22073 Pack_Decl : Node_Id;
22074 Spec_Id : Entity_Id;
22078 Check_No_Identifiers;
22079 Check_Arg_Count (1);
22081 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
22083 if Nkind (Pack_Decl) /= N_Package_Body then
22088 Spec_Id := Corresponding_Spec (Pack_Decl);
22090 -- A pragma that applies to a Ghost entity becomes Ghost for the
22091 -- purposes of legality checks and removal of ignored Ghost code.
22093 Mark_Ghost_Pragma (N, Spec_Id);
22095 -- Chain the pragma on the contract for further processing by
22096 -- Analyze_Refined_State_In_Decl_Part.
22098 Add_Contract_Item (N, Defining_Entity (Pack_Decl));
22100 -- The legality checks of pragma Refined_State are affected by the
22101 -- SPARK mode in effect. Analyze all pragmas in a specific order.
22103 Analyze_If_Present (Pragma_SPARK_Mode);
22105 -- State refinement is allowed only when the corresponding package
22106 -- declaration has non-null pragma Abstract_State. Refinement not
22107 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
22109 if SPARK_Mode /= Off
22111 (No (Abstract_States (Spec_Id))
22112 or else Has_Null_Abstract_State (Spec_Id))
22115 ("useless refinement, package & does not define abstract "
22116 & "states", N, Spec_Id);
22121 -----------------------
22122 -- Relative_Deadline --
22123 -----------------------
22125 -- pragma Relative_Deadline (time_span_EXPRESSION);
22127 when Pragma_Relative_Deadline => Relative_Deadline : declare
22128 P : constant Node_Id := Parent (N);
22133 Check_No_Identifiers;
22134 Check_Arg_Count (1);
22136 Arg := Get_Pragma_Arg (Arg1);
22138 -- The expression must be analyzed in the special manner described
22139 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
22141 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
22145 if Nkind (P) = N_Subprogram_Body then
22146 Check_In_Main_Program;
22148 -- Only Task and subprogram cases allowed
22150 elsif Nkind (P) /= N_Task_Definition then
22154 -- Check duplicate pragma before we set the corresponding flag
22156 if Has_Relative_Deadline_Pragma (P) then
22157 Error_Pragma ("duplicate pragma% not allowed");
22160 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
22161 -- Relative_Deadline pragma node cannot be inserted in the Rep
22162 -- Item chain of Ent since it is rewritten by the expander as a
22163 -- procedure call statement that will break the chain.
22165 Set_Has_Relative_Deadline_Pragma (P);
22166 end Relative_Deadline;
22168 ------------------------
22169 -- Remote_Access_Type --
22170 ------------------------
22172 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
22174 when Pragma_Remote_Access_Type => Remote_Access_Type : declare
22179 Check_Arg_Count (1);
22180 Check_Optional_Identifier (Arg1, Name_Entity);
22181 Check_Arg_Is_Local_Name (Arg1);
22183 E := Entity (Get_Pragma_Arg (Arg1));
22185 -- A pragma that applies to a Ghost entity becomes Ghost for the
22186 -- purposes of legality checks and removal of ignored Ghost code.
22188 Mark_Ghost_Pragma (N, E);
22190 if Nkind (Parent (E)) = N_Formal_Type_Declaration
22191 and then Ekind (E) = E_General_Access_Type
22192 and then Is_Class_Wide_Type (Directly_Designated_Type (E))
22193 and then Scope (Root_Type (Directly_Designated_Type (E)))
22195 and then Is_Valid_Remote_Object_Type
22196 (Root_Type (Directly_Designated_Type (E)))
22198 Set_Is_Remote_Types (E);
22202 ("pragma% applies only to formal access-to-class-wide types",
22205 end Remote_Access_Type;
22207 ---------------------------
22208 -- Remote_Call_Interface --
22209 ---------------------------
22211 -- pragma Remote_Call_Interface [(library_unit_NAME)];
22213 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
22214 Cunit_Node : Node_Id;
22215 Cunit_Ent : Entity_Id;
22219 Check_Ada_83_Warning;
22220 Check_Valid_Library_Unit_Pragma;
22222 if Nkind (N) = N_Null_Statement then
22226 Cunit_Node := Cunit (Current_Sem_Unit);
22227 K := Nkind (Unit (Cunit_Node));
22228 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22230 -- A pragma that applies to a Ghost entity becomes Ghost for the
22231 -- purposes of legality checks and removal of ignored Ghost code.
22233 Mark_Ghost_Pragma (N, Cunit_Ent);
22235 if K = N_Package_Declaration
22236 or else K = N_Generic_Package_Declaration
22237 or else K = N_Subprogram_Declaration
22238 or else K = N_Generic_Subprogram_Declaration
22239 or else (K = N_Subprogram_Body
22240 and then Acts_As_Spec (Unit (Cunit_Node)))
22245 "pragma% must apply to package or subprogram declaration");
22248 Set_Is_Remote_Call_Interface (Cunit_Ent);
22249 end Remote_Call_Interface;
22255 -- pragma Remote_Types [(library_unit_NAME)];
22257 when Pragma_Remote_Types => Remote_Types : declare
22258 Cunit_Node : Node_Id;
22259 Cunit_Ent : Entity_Id;
22262 Check_Ada_83_Warning;
22263 Check_Valid_Library_Unit_Pragma;
22265 if Nkind (N) = N_Null_Statement then
22269 Cunit_Node := Cunit (Current_Sem_Unit);
22270 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22272 -- A pragma that applies to a Ghost entity becomes Ghost for the
22273 -- purposes of legality checks and removal of ignored Ghost code.
22275 Mark_Ghost_Pragma (N, Cunit_Ent);
22277 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
22278 N_Generic_Package_Declaration)
22281 ("pragma% can only apply to a package declaration");
22284 Set_Is_Remote_Types (Cunit_Ent);
22291 -- pragma Ravenscar;
22293 when Pragma_Ravenscar =>
22295 Check_Arg_Count (0);
22296 Check_Valid_Configuration_Pragma;
22297 Set_Ravenscar_Profile (Ravenscar, N);
22299 if Warn_On_Obsolescent_Feature then
22301 ("pragma Ravenscar is an obsolescent feature?j?", N);
22303 ("|use pragma Profile (Ravenscar) instead?j?", N);
22306 -------------------------
22307 -- Restricted_Run_Time --
22308 -------------------------
22310 -- pragma Restricted_Run_Time;
22312 when Pragma_Restricted_Run_Time =>
22314 Check_Arg_Count (0);
22315 Check_Valid_Configuration_Pragma;
22316 Set_Profile_Restrictions
22317 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
22319 if Warn_On_Obsolescent_Feature then
22321 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
22324 ("|use pragma Profile (Restricted) instead?j?", N);
22331 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
22334 -- restriction_IDENTIFIER
22335 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22337 when Pragma_Restrictions =>
22338 Process_Restrictions_Or_Restriction_Warnings
22339 (Warn => Treat_Restrictions_As_Warnings);
22341 --------------------------
22342 -- Restriction_Warnings --
22343 --------------------------
22345 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
22348 -- restriction_IDENTIFIER
22349 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22351 when Pragma_Restriction_Warnings =>
22353 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
22359 -- pragma Reviewable;
22361 when Pragma_Reviewable =>
22362 Check_Ada_83_Warning;
22363 Check_Arg_Count (0);
22365 -- Call dummy debugging function rv. This is done to assist front
22366 -- end debugging. By placing a Reviewable pragma in the source
22367 -- program, a breakpoint on rv catches this place in the source,
22368 -- allowing convenient stepping to the point of interest.
22372 --------------------------
22373 -- Secondary_Stack_Size --
22374 --------------------------
22376 -- pragma Secondary_Stack_Size (EXPRESSION);
22378 when Pragma_Secondary_Stack_Size => Secondary_Stack_Size : declare
22379 P : constant Node_Id := Parent (N);
22385 Check_No_Identifiers;
22386 Check_Arg_Count (1);
22388 if Nkind (P) = N_Task_Definition then
22389 Arg := Get_Pragma_Arg (Arg1);
22390 Ent := Defining_Identifier (Parent (P));
22392 -- The expression must be analyzed in the special manner
22393 -- described in "Handling of Default Expressions" in sem.ads.
22395 Preanalyze_Spec_Expression (Arg, Any_Integer);
22397 -- The pragma cannot appear if the No_Secondary_Stack
22398 -- restriction is in effect.
22400 Check_Restriction (No_Secondary_Stack, Arg);
22402 -- Anything else is incorrect
22408 -- Check duplicate pragma before we chain the pragma in the Rep
22409 -- Item chain of Ent.
22411 Check_Duplicate_Pragma (Ent);
22412 Record_Rep_Item (Ent, N);
22413 end Secondary_Stack_Size;
22415 --------------------------
22416 -- Short_Circuit_And_Or --
22417 --------------------------
22419 -- pragma Short_Circuit_And_Or;
22421 when Pragma_Short_Circuit_And_Or =>
22423 Check_Arg_Count (0);
22424 Check_Valid_Configuration_Pragma;
22425 Short_Circuit_And_Or := True;
22427 -------------------
22428 -- Share_Generic --
22429 -------------------
22431 -- pragma Share_Generic (GNAME {, GNAME});
22433 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
22435 when Pragma_Share_Generic =>
22437 Process_Generic_List;
22443 -- pragma Shared (LOCAL_NAME);
22445 when Pragma_Shared =>
22447 Process_Atomic_Independent_Shared_Volatile;
22449 --------------------
22450 -- Shared_Passive --
22451 --------------------
22453 -- pragma Shared_Passive [(library_unit_NAME)];
22455 -- Set the flag Is_Shared_Passive of program unit name entity
22457 when Pragma_Shared_Passive => Shared_Passive : declare
22458 Cunit_Node : Node_Id;
22459 Cunit_Ent : Entity_Id;
22462 Check_Ada_83_Warning;
22463 Check_Valid_Library_Unit_Pragma;
22465 if Nkind (N) = N_Null_Statement then
22469 Cunit_Node := Cunit (Current_Sem_Unit);
22470 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22472 -- A pragma that applies to a Ghost entity becomes Ghost for the
22473 -- purposes of legality checks and removal of ignored Ghost code.
22475 Mark_Ghost_Pragma (N, Cunit_Ent);
22477 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
22478 N_Generic_Package_Declaration)
22481 ("pragma% can only apply to a package declaration");
22484 Set_Is_Shared_Passive (Cunit_Ent);
22485 end Shared_Passive;
22487 -----------------------
22488 -- Short_Descriptors --
22489 -----------------------
22491 -- pragma Short_Descriptors;
22493 -- Recognize and validate, but otherwise ignore
22495 when Pragma_Short_Descriptors =>
22497 Check_Arg_Count (0);
22498 Check_Valid_Configuration_Pragma;
22500 ------------------------------
22501 -- Simple_Storage_Pool_Type --
22502 ------------------------------
22504 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
22506 when Pragma_Simple_Storage_Pool_Type =>
22507 Simple_Storage_Pool_Type : declare
22513 Check_Arg_Count (1);
22514 Check_Arg_Is_Library_Level_Local_Name (Arg1);
22516 Type_Id := Get_Pragma_Arg (Arg1);
22517 Find_Type (Type_Id);
22518 Typ := Entity (Type_Id);
22520 if Typ = Any_Type then
22524 -- A pragma that applies to a Ghost entity becomes Ghost for the
22525 -- purposes of legality checks and removal of ignored Ghost code.
22527 Mark_Ghost_Pragma (N, Typ);
22529 -- We require the pragma to apply to a type declared in a package
22530 -- declaration, but not (immediately) within a package body.
22532 if Ekind (Current_Scope) /= E_Package
22533 or else In_Package_Body (Current_Scope)
22536 ("pragma% can only apply to type declared immediately "
22537 & "within a package declaration");
22540 -- A simple storage pool type must be an immutably limited record
22541 -- or private type. If the pragma is given for a private type,
22542 -- the full type is similarly restricted (which is checked later
22543 -- in Freeze_Entity).
22545 if Is_Record_Type (Typ)
22546 and then not Is_Limited_View (Typ)
22549 ("pragma% can only apply to explicitly limited record type");
22551 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
22553 ("pragma% can only apply to a private type that is limited");
22555 elsif not Is_Record_Type (Typ)
22556 and then not Is_Private_Type (Typ)
22559 ("pragma% can only apply to limited record or private type");
22562 Record_Rep_Item (Typ, N);
22563 end Simple_Storage_Pool_Type;
22565 ----------------------
22566 -- Source_File_Name --
22567 ----------------------
22569 -- There are five forms for this pragma:
22571 -- pragma Source_File_Name (
22572 -- [UNIT_NAME =>] unit_NAME,
22573 -- BODY_FILE_NAME => STRING_LITERAL
22574 -- [, [INDEX =>] INTEGER_LITERAL]);
22576 -- pragma Source_File_Name (
22577 -- [UNIT_NAME =>] unit_NAME,
22578 -- SPEC_FILE_NAME => STRING_LITERAL
22579 -- [, [INDEX =>] INTEGER_LITERAL]);
22581 -- pragma Source_File_Name (
22582 -- BODY_FILE_NAME => STRING_LITERAL
22583 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22584 -- [, CASING => CASING_SPEC]);
22586 -- pragma Source_File_Name (
22587 -- SPEC_FILE_NAME => STRING_LITERAL
22588 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22589 -- [, CASING => CASING_SPEC]);
22591 -- pragma Source_File_Name (
22592 -- SUBUNIT_FILE_NAME => STRING_LITERAL
22593 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22594 -- [, CASING => CASING_SPEC]);
22596 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
22598 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
22599 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
22600 -- only be used when no project file is used, while SFNP can only be
22601 -- used when a project file is used.
22603 -- No processing here. Processing was completed during parsing, since
22604 -- we need to have file names set as early as possible. Units are
22605 -- loaded well before semantic processing starts.
22607 -- The only processing we defer to this point is the check for
22608 -- correct placement.
22610 when Pragma_Source_File_Name =>
22612 Check_Valid_Configuration_Pragma;
22614 ------------------------------
22615 -- Source_File_Name_Project --
22616 ------------------------------
22618 -- See Source_File_Name for syntax
22620 -- No processing here. Processing was completed during parsing, since
22621 -- we need to have file names set as early as possible. Units are
22622 -- loaded well before semantic processing starts.
22624 -- The only processing we defer to this point is the check for
22625 -- correct placement.
22627 when Pragma_Source_File_Name_Project =>
22629 Check_Valid_Configuration_Pragma;
22631 -- Check that a pragma Source_File_Name_Project is used only in a
22632 -- configuration pragmas file.
22634 -- Pragmas Source_File_Name_Project should only be generated by
22635 -- the Project Manager in configuration pragmas files.
22637 -- This is really an ugly test. It seems to depend on some
22638 -- accidental and undocumented property. At the very least it
22639 -- needs to be documented, but it would be better to have a
22640 -- clean way of testing if we are in a configuration file???
22642 if Present (Parent (N)) then
22644 ("pragma% can only appear in a configuration pragmas file");
22647 ----------------------
22648 -- Source_Reference --
22649 ----------------------
22651 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
22653 -- Nothing to do, all processing completed in Par.Prag, since we need
22654 -- the information for possible parser messages that are output.
22656 when Pragma_Source_Reference =>
22663 -- pragma SPARK_Mode [(On | Off)];
22665 when Pragma_SPARK_Mode => Do_SPARK_Mode : declare
22666 Mode_Id : SPARK_Mode_Type;
22668 procedure Check_Pragma_Conformance
22669 (Context_Pragma : Node_Id;
22670 Entity : Entity_Id;
22671 Entity_Pragma : Node_Id);
22672 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
22673 -- conformance of pragma N depending the following scenarios:
22675 -- If pragma Context_Pragma is not Empty, verify that pragma N is
22676 -- compatible with the pragma Context_Pragma that was inherited
22677 -- from the context:
22678 -- * If the mode of Context_Pragma is ON, then the new mode can
22680 -- * If the mode of Context_Pragma is OFF, then the only allowed
22681 -- new mode is also OFF. Emit error if this is not the case.
22683 -- If Entity is not Empty, verify that pragma N is compatible with
22684 -- pragma Entity_Pragma that belongs to Entity.
22685 -- * If Entity_Pragma is Empty, always issue an error as this
22686 -- corresponds to the case where a previous section of Entity
22687 -- has no SPARK_Mode set.
22688 -- * If the mode of Entity_Pragma is ON, then the new mode can
22690 -- * If the mode of Entity_Pragma is OFF, then the only allowed
22691 -- new mode is also OFF. Emit error if this is not the case.
22693 procedure Check_Library_Level_Entity (E : Entity_Id);
22694 -- Subsidiary to routines Process_xxx. Verify that the related
22695 -- entity E subject to pragma SPARK_Mode is library-level.
22697 procedure Process_Body (Decl : Node_Id);
22698 -- Verify the legality of pragma SPARK_Mode when it appears as the
22699 -- top of the body declarations of entry, package, protected unit,
22700 -- subprogram or task unit body denoted by Decl.
22702 procedure Process_Overloadable (Decl : Node_Id);
22703 -- Verify the legality of pragma SPARK_Mode when it applies to an
22704 -- entry or [generic] subprogram declaration denoted by Decl.
22706 procedure Process_Private_Part (Decl : Node_Id);
22707 -- Verify the legality of pragma SPARK_Mode when it appears at the
22708 -- top of the private declarations of a package spec, protected or
22709 -- task unit declaration denoted by Decl.
22711 procedure Process_Statement_Part (Decl : Node_Id);
22712 -- Verify the legality of pragma SPARK_Mode when it appears at the
22713 -- top of the statement sequence of a package body denoted by node
22716 procedure Process_Visible_Part (Decl : Node_Id);
22717 -- Verify the legality of pragma SPARK_Mode when it appears at the
22718 -- top of the visible declarations of a package spec, protected or
22719 -- task unit declaration denoted by Decl. The routine is also used
22720 -- on protected or task units declared without a definition.
22722 procedure Set_SPARK_Context;
22723 -- Subsidiary to routines Process_xxx. Set the global variables
22724 -- which represent the mode of the context from pragma N. Ensure
22725 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
22727 ------------------------------
22728 -- Check_Pragma_Conformance --
22729 ------------------------------
22731 procedure Check_Pragma_Conformance
22732 (Context_Pragma : Node_Id;
22733 Entity : Entity_Id;
22734 Entity_Pragma : Node_Id)
22736 Err_Id : Entity_Id;
22740 -- The current pragma may appear without an argument. If this
22741 -- is the case, associate all error messages with the pragma
22744 if Present (Arg1) then
22750 -- The mode of the current pragma is compared against that of
22751 -- an enclosing context.
22753 if Present (Context_Pragma) then
22754 pragma Assert (Nkind (Context_Pragma) = N_Pragma);
22756 -- Issue an error if the new mode is less restrictive than
22757 -- that of the context.
22759 if Get_SPARK_Mode_From_Annotation (Context_Pragma) = Off
22760 and then Get_SPARK_Mode_From_Annotation (N) = On
22763 ("cannot change SPARK_Mode from Off to On", Err_N);
22764 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
22765 Error_Msg_N ("\SPARK_Mode was set to Off#", Err_N);
22770 -- The mode of the current pragma is compared against that of
22771 -- an initial package, protected type, subprogram or task type
22774 if Present (Entity) then
22776 -- A simple protected or task type is transformed into an
22777 -- anonymous type whose name cannot be used to issue error
22778 -- messages. Recover the original entity of the type.
22780 if Ekind_In (Entity, E_Protected_Type, E_Task_Type) then
22783 (Original_Node (Unit_Declaration_Node (Entity)));
22788 -- Both the initial declaration and the completion carry
22789 -- SPARK_Mode pragmas.
22791 if Present (Entity_Pragma) then
22792 pragma Assert (Nkind (Entity_Pragma) = N_Pragma);
22794 -- Issue an error if the new mode is less restrictive
22795 -- than that of the initial declaration.
22797 if Get_SPARK_Mode_From_Annotation (Entity_Pragma) = Off
22798 and then Get_SPARK_Mode_From_Annotation (N) = On
22800 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
22801 Error_Msg_Sloc := Sloc (Entity_Pragma);
22803 ("\value Off was set for SPARK_Mode on&#",
22808 -- Otherwise the initial declaration lacks a SPARK_Mode
22809 -- pragma in which case the current pragma is illegal as
22810 -- it cannot "complete".
22812 elsif Get_SPARK_Mode_From_Annotation (N) = Off
22813 and then (Is_Generic_Unit (Entity) or else In_Instance)
22818 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
22819 Error_Msg_Sloc := Sloc (Err_Id);
22821 ("\no value was set for SPARK_Mode on&#",
22826 end Check_Pragma_Conformance;
22828 --------------------------------
22829 -- Check_Library_Level_Entity --
22830 --------------------------------
22832 procedure Check_Library_Level_Entity (E : Entity_Id) is
22833 procedure Add_Entity_To_Name_Buffer;
22834 -- Add the E_Kind of entity E to the name buffer
22836 -------------------------------
22837 -- Add_Entity_To_Name_Buffer --
22838 -------------------------------
22840 procedure Add_Entity_To_Name_Buffer is
22842 if Ekind_In (E, E_Entry, E_Entry_Family) then
22843 Add_Str_To_Name_Buffer ("entry");
22845 elsif Ekind_In (E, E_Generic_Package,
22849 Add_Str_To_Name_Buffer ("package");
22851 elsif Ekind_In (E, E_Protected_Body, E_Protected_Type) then
22852 Add_Str_To_Name_Buffer ("protected type");
22854 elsif Ekind_In (E, E_Function,
22855 E_Generic_Function,
22856 E_Generic_Procedure,
22860 Add_Str_To_Name_Buffer ("subprogram");
22863 pragma Assert (Ekind_In (E, E_Task_Body, E_Task_Type));
22864 Add_Str_To_Name_Buffer ("task type");
22866 end Add_Entity_To_Name_Buffer;
22870 Msg_1 : constant String := "incorrect placement of pragma%";
22873 -- Start of processing for Check_Library_Level_Entity
22876 -- A SPARK_Mode of On shall only apply to library-level
22877 -- entities, except for those in generic instances, which are
22878 -- ignored (even if the entity gets SPARK_Mode pragma attached
22879 -- in the AST, its effect is not taken into account unless the
22880 -- context already provides SPARK_Mode of On in GNATprove).
22882 if Get_SPARK_Mode_From_Annotation (N) = On
22883 and then not Is_Library_Level_Entity (E)
22884 and then Instantiation_Location (Sloc (N)) = No_Location
22886 Error_Msg_Name_1 := Pname;
22887 Error_Msg_N (Fix_Error (Msg_1), N);
22890 Add_Str_To_Name_Buffer ("\& is not a library-level ");
22891 Add_Entity_To_Name_Buffer;
22893 Msg_2 := Name_Find;
22894 Error_Msg_NE (Get_Name_String (Msg_2), N, E);
22898 end Check_Library_Level_Entity;
22904 procedure Process_Body (Decl : Node_Id) is
22905 Body_Id : constant Entity_Id := Defining_Entity (Decl);
22906 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl);
22909 -- Ignore pragma when applied to the special body created for
22910 -- inlining, recognized by its internal name _Parent.
22912 if Chars (Body_Id) = Name_uParent then
22916 Check_Library_Level_Entity (Body_Id);
22918 -- For entry bodies, verify the legality against:
22919 -- * The mode of the context
22920 -- * The mode of the spec (if any)
22922 if Nkind_In (Decl, N_Entry_Body, N_Subprogram_Body) then
22924 -- A stand-alone subprogram body
22926 if Body_Id = Spec_Id then
22927 Check_Pragma_Conformance
22928 (Context_Pragma => SPARK_Pragma (Body_Id),
22930 Entity_Pragma => Empty);
22932 -- An entry or subprogram body that completes a previous
22936 Check_Pragma_Conformance
22937 (Context_Pragma => SPARK_Pragma (Body_Id),
22939 Entity_Pragma => SPARK_Pragma (Spec_Id));
22943 Set_SPARK_Pragma (Body_Id, N);
22944 Set_SPARK_Pragma_Inherited (Body_Id, False);
22946 -- For package bodies, verify the legality against:
22947 -- * The mode of the context
22948 -- * The mode of the private part
22950 -- This case is separated from protected and task bodies
22951 -- because the statement part of the package body inherits
22952 -- the mode of the body declarations.
22954 elsif Nkind (Decl) = N_Package_Body then
22955 Check_Pragma_Conformance
22956 (Context_Pragma => SPARK_Pragma (Body_Id),
22958 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
22961 Set_SPARK_Pragma (Body_Id, N);
22962 Set_SPARK_Pragma_Inherited (Body_Id, False);
22963 Set_SPARK_Aux_Pragma (Body_Id, N);
22964 Set_SPARK_Aux_Pragma_Inherited (Body_Id, True);
22966 -- For protected and task bodies, verify the legality against:
22967 -- * The mode of the context
22968 -- * The mode of the private part
22972 (Nkind_In (Decl, N_Protected_Body, N_Task_Body));
22974 Check_Pragma_Conformance
22975 (Context_Pragma => SPARK_Pragma (Body_Id),
22977 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
22980 Set_SPARK_Pragma (Body_Id, N);
22981 Set_SPARK_Pragma_Inherited (Body_Id, False);
22985 --------------------------
22986 -- Process_Overloadable --
22987 --------------------------
22989 procedure Process_Overloadable (Decl : Node_Id) is
22990 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
22991 Spec_Typ : constant Entity_Id := Etype (Spec_Id);
22994 Check_Library_Level_Entity (Spec_Id);
22996 -- Verify the legality against:
22997 -- * The mode of the context
22999 Check_Pragma_Conformance
23000 (Context_Pragma => SPARK_Pragma (Spec_Id),
23002 Entity_Pragma => Empty);
23004 Set_SPARK_Pragma (Spec_Id, N);
23005 Set_SPARK_Pragma_Inherited (Spec_Id, False);
23007 -- When the pragma applies to the anonymous object created for
23008 -- a single task type, decorate the type as well. This scenario
23009 -- arises when the single task type lacks a task definition,
23010 -- therefore there is no issue with respect to a potential
23011 -- pragma SPARK_Mode in the private part.
23013 -- task type Anon_Task_Typ;
23014 -- Obj : Anon_Task_Typ;
23015 -- pragma SPARK_Mode ...;
23017 if Is_Single_Task_Object (Spec_Id) then
23018 Set_SPARK_Pragma (Spec_Typ, N);
23019 Set_SPARK_Pragma_Inherited (Spec_Typ, False);
23020 Set_SPARK_Aux_Pragma (Spec_Typ, N);
23021 Set_SPARK_Aux_Pragma_Inherited (Spec_Typ, True);
23023 end Process_Overloadable;
23025 --------------------------
23026 -- Process_Private_Part --
23027 --------------------------
23029 procedure Process_Private_Part (Decl : Node_Id) is
23030 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
23033 Check_Library_Level_Entity (Spec_Id);
23035 -- Verify the legality against:
23036 -- * The mode of the visible declarations
23038 Check_Pragma_Conformance
23039 (Context_Pragma => Empty,
23041 Entity_Pragma => SPARK_Pragma (Spec_Id));
23044 Set_SPARK_Aux_Pragma (Spec_Id, N);
23045 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False);
23046 end Process_Private_Part;
23048 ----------------------------
23049 -- Process_Statement_Part --
23050 ----------------------------
23052 procedure Process_Statement_Part (Decl : Node_Id) is
23053 Body_Id : constant Entity_Id := Defining_Entity (Decl);
23056 Check_Library_Level_Entity (Body_Id);
23058 -- Verify the legality against:
23059 -- * The mode of the body declarations
23061 Check_Pragma_Conformance
23062 (Context_Pragma => Empty,
23064 Entity_Pragma => SPARK_Pragma (Body_Id));
23067 Set_SPARK_Aux_Pragma (Body_Id, N);
23068 Set_SPARK_Aux_Pragma_Inherited (Body_Id, False);
23069 end Process_Statement_Part;
23071 --------------------------
23072 -- Process_Visible_Part --
23073 --------------------------
23075 procedure Process_Visible_Part (Decl : Node_Id) is
23076 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
23077 Obj_Id : Entity_Id;
23080 Check_Library_Level_Entity (Spec_Id);
23082 -- Verify the legality against:
23083 -- * The mode of the context
23085 Check_Pragma_Conformance
23086 (Context_Pragma => SPARK_Pragma (Spec_Id),
23088 Entity_Pragma => Empty);
23090 -- A task unit declared without a definition does not set the
23091 -- SPARK_Mode of the context because the task does not have any
23092 -- entries that could inherit the mode.
23094 if not Nkind_In (Decl, N_Single_Task_Declaration,
23095 N_Task_Type_Declaration)
23100 Set_SPARK_Pragma (Spec_Id, N);
23101 Set_SPARK_Pragma_Inherited (Spec_Id, False);
23102 Set_SPARK_Aux_Pragma (Spec_Id, N);
23103 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True);
23105 -- When the pragma applies to a single protected or task type,
23106 -- decorate the corresponding anonymous object as well.
23108 -- protected Anon_Prot_Typ is
23109 -- pragma SPARK_Mode ...;
23111 -- end Anon_Prot_Typ;
23113 -- Obj : Anon_Prot_Typ;
23115 if Is_Single_Concurrent_Type (Spec_Id) then
23116 Obj_Id := Anonymous_Object (Spec_Id);
23118 Set_SPARK_Pragma (Obj_Id, N);
23119 Set_SPARK_Pragma_Inherited (Obj_Id, False);
23121 end Process_Visible_Part;
23123 -----------------------
23124 -- Set_SPARK_Context --
23125 -----------------------
23127 procedure Set_SPARK_Context is
23129 SPARK_Mode := Mode_Id;
23130 SPARK_Mode_Pragma := N;
23131 end Set_SPARK_Context;
23139 -- Start of processing for Do_SPARK_Mode
23143 Check_No_Identifiers;
23144 Check_At_Most_N_Arguments (1);
23146 -- Check the legality of the mode (no argument = ON)
23148 if Arg_Count = 1 then
23149 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23150 Mode := Chars (Get_Pragma_Arg (Arg1));
23155 Mode_Id := Get_SPARK_Mode_Type (Mode);
23156 Context := Parent (N);
23158 -- When a SPARK_Mode pragma appears inside an instantiation whose
23159 -- enclosing context has SPARK_Mode set to "off", the pragma has
23160 -- no semantic effect.
23162 if Ignore_SPARK_Mode_Pragmas_In_Instance
23163 and then Mode_Id /= Off
23165 Rewrite (N, Make_Null_Statement (Loc));
23170 -- The pragma appears in a configuration file
23172 if No (Context) then
23173 Check_Valid_Configuration_Pragma;
23175 if Present (SPARK_Mode_Pragma) then
23178 Prev => SPARK_Mode_Pragma);
23184 -- The pragma acts as a configuration pragma in a compilation unit
23186 -- pragma SPARK_Mode ...;
23187 -- package Pack is ...;
23189 elsif Nkind (Context) = N_Compilation_Unit
23190 and then List_Containing (N) = Context_Items (Context)
23192 Check_Valid_Configuration_Pragma;
23195 -- Otherwise the placement of the pragma within the tree dictates
23196 -- its associated construct. Inspect the declarative list where
23197 -- the pragma resides to find a potential construct.
23201 while Present (Stmt) loop
23203 -- Skip prior pragmas, but check for duplicates. Note that
23204 -- this also takes care of pragmas generated for aspects.
23206 if Nkind (Stmt) = N_Pragma then
23207 if Pragma_Name (Stmt) = Pname then
23214 -- The pragma applies to an expression function that has
23215 -- already been rewritten into a subprogram declaration.
23217 -- function Expr_Func return ... is (...);
23218 -- pragma SPARK_Mode ...;
23220 elsif Nkind (Stmt) = N_Subprogram_Declaration
23221 and then Nkind (Original_Node (Stmt)) =
23222 N_Expression_Function
23224 Process_Overloadable (Stmt);
23227 -- The pragma applies to the anonymous object created for a
23228 -- single concurrent type.
23230 -- protected type Anon_Prot_Typ ...;
23231 -- Obj : Anon_Prot_Typ;
23232 -- pragma SPARK_Mode ...;
23234 elsif Nkind (Stmt) = N_Object_Declaration
23235 and then Is_Single_Concurrent_Object
23236 (Defining_Entity (Stmt))
23238 Process_Overloadable (Stmt);
23241 -- Skip internally generated code
23243 elsif not Comes_From_Source (Stmt) then
23246 -- The pragma applies to an entry or [generic] subprogram
23250 -- pragma SPARK_Mode ...;
23253 -- procedure Proc ...;
23254 -- pragma SPARK_Mode ...;
23256 elsif Nkind_In (Stmt, N_Generic_Subprogram_Declaration,
23257 N_Subprogram_Declaration)
23258 or else (Nkind (Stmt) = N_Entry_Declaration
23259 and then Is_Protected_Type
23260 (Scope (Defining_Entity (Stmt))))
23262 Process_Overloadable (Stmt);
23265 -- Otherwise the pragma does not apply to a legal construct
23266 -- or it does not appear at the top of a declarative or a
23267 -- statement list. Issue an error and stop the analysis.
23277 -- The pragma applies to a package or a subprogram that acts as
23278 -- a compilation unit.
23280 -- procedure Proc ...;
23281 -- pragma SPARK_Mode ...;
23283 if Nkind (Context) = N_Compilation_Unit_Aux then
23284 Context := Unit (Parent (Context));
23287 -- The pragma appears at the top of entry, package, protected
23288 -- unit, subprogram or task unit body declarations.
23290 -- entry Ent when ... is
23291 -- pragma SPARK_Mode ...;
23293 -- package body Pack is
23294 -- pragma SPARK_Mode ...;
23296 -- procedure Proc ... is
23297 -- pragma SPARK_Mode;
23299 -- protected body Prot is
23300 -- pragma SPARK_Mode ...;
23302 if Nkind_In (Context, N_Entry_Body,
23308 Process_Body (Context);
23310 -- The pragma appears at the top of the visible or private
23311 -- declaration of a package spec, protected or task unit.
23314 -- pragma SPARK_Mode ...;
23316 -- pragma SPARK_Mode ...;
23318 -- protected [type] Prot is
23319 -- pragma SPARK_Mode ...;
23321 -- pragma SPARK_Mode ...;
23323 elsif Nkind_In (Context, N_Package_Specification,
23324 N_Protected_Definition,
23327 if List_Containing (N) = Visible_Declarations (Context) then
23328 Process_Visible_Part (Parent (Context));
23330 Process_Private_Part (Parent (Context));
23333 -- The pragma appears at the top of package body statements
23335 -- package body Pack is
23337 -- pragma SPARK_Mode;
23339 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
23340 and then Nkind (Parent (Context)) = N_Package_Body
23342 Process_Statement_Part (Parent (Context));
23344 -- The pragma appeared as an aspect of a [generic] subprogram
23345 -- declaration that acts as a compilation unit.
23348 -- procedure Proc ...;
23349 -- pragma SPARK_Mode ...;
23351 elsif Nkind_In (Context, N_Generic_Subprogram_Declaration,
23352 N_Subprogram_Declaration)
23354 Process_Overloadable (Context);
23356 -- The pragma does not apply to a legal construct, issue error
23364 --------------------------------
23365 -- Static_Elaboration_Desired --
23366 --------------------------------
23368 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
23370 when Pragma_Static_Elaboration_Desired =>
23372 Check_At_Most_N_Arguments (1);
23374 if Is_Compilation_Unit (Current_Scope)
23375 and then Ekind (Current_Scope) = E_Package
23377 Set_Static_Elaboration_Desired (Current_Scope, True);
23379 Error_Pragma ("pragma% must apply to a library-level package");
23386 -- pragma Storage_Size (EXPRESSION);
23388 when Pragma_Storage_Size => Storage_Size : declare
23389 P : constant Node_Id := Parent (N);
23393 Check_No_Identifiers;
23394 Check_Arg_Count (1);
23396 -- The expression must be analyzed in the special manner described
23397 -- in "Handling of Default Expressions" in sem.ads.
23399 Arg := Get_Pragma_Arg (Arg1);
23400 Preanalyze_Spec_Expression (Arg, Any_Integer);
23402 if not Is_OK_Static_Expression (Arg) then
23403 Check_Restriction (Static_Storage_Size, Arg);
23406 if Nkind (P) /= N_Task_Definition then
23411 if Has_Storage_Size_Pragma (P) then
23412 Error_Pragma ("duplicate pragma% not allowed");
23414 Set_Has_Storage_Size_Pragma (P, True);
23417 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
23425 -- pragma Storage_Unit (NUMERIC_LITERAL);
23427 -- Only permitted argument is System'Storage_Unit value
23429 when Pragma_Storage_Unit =>
23430 Check_No_Identifiers;
23431 Check_Arg_Count (1);
23432 Check_Arg_Is_Integer_Literal (Arg1);
23434 if Intval (Get_Pragma_Arg (Arg1)) /=
23435 UI_From_Int (Ttypes.System_Storage_Unit)
23437 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
23439 ("the only allowed argument for pragma% is ^", Arg1);
23442 --------------------
23443 -- Stream_Convert --
23444 --------------------
23446 -- pragma Stream_Convert (
23447 -- [Entity =>] type_LOCAL_NAME,
23448 -- [Read =>] function_NAME,
23449 -- [Write =>] function NAME);
23451 when Pragma_Stream_Convert => Stream_Convert : declare
23452 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
23453 -- Check that the given argument is the name of a local function
23454 -- of one argument that is not overloaded earlier in the current
23455 -- local scope. A check is also made that the argument is a
23456 -- function with one parameter.
23458 --------------------------------------
23459 -- Check_OK_Stream_Convert_Function --
23460 --------------------------------------
23462 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
23466 Check_Arg_Is_Local_Name (Arg);
23467 Ent := Entity (Get_Pragma_Arg (Arg));
23469 if Has_Homonym (Ent) then
23471 ("argument for pragma% may not be overloaded", Arg);
23474 if Ekind (Ent) /= E_Function
23475 or else No (First_Formal (Ent))
23476 or else Present (Next_Formal (First_Formal (Ent)))
23479 ("argument for pragma% must be function of one argument",
23482 end Check_OK_Stream_Convert_Function;
23484 -- Start of processing for Stream_Convert
23488 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
23489 Check_Arg_Count (3);
23490 Check_Optional_Identifier (Arg1, Name_Entity);
23491 Check_Optional_Identifier (Arg2, Name_Read);
23492 Check_Optional_Identifier (Arg3, Name_Write);
23493 Check_Arg_Is_Local_Name (Arg1);
23494 Check_OK_Stream_Convert_Function (Arg2);
23495 Check_OK_Stream_Convert_Function (Arg3);
23498 Typ : constant Entity_Id :=
23499 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
23500 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
23501 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
23504 Check_First_Subtype (Arg1);
23506 -- Check for too early or too late. Note that we don't enforce
23507 -- the rule about primitive operations in this case, since, as
23508 -- is the case for explicit stream attributes themselves, these
23509 -- restrictions are not appropriate. Note that the chaining of
23510 -- the pragma by Rep_Item_Too_Late is actually the critical
23511 -- processing done for this pragma.
23513 if Rep_Item_Too_Early (Typ, N)
23515 Rep_Item_Too_Late (Typ, N, FOnly => True)
23520 -- Return if previous error
23522 if Etype (Typ) = Any_Type
23524 Etype (Read) = Any_Type
23526 Etype (Write) = Any_Type
23533 if Underlying_Type (Etype (Read)) /= Typ then
23535 ("incorrect return type for function&", Arg2);
23538 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
23540 ("incorrect parameter type for function&", Arg3);
23543 if Underlying_Type (Etype (First_Formal (Read))) /=
23544 Underlying_Type (Etype (Write))
23547 ("result type of & does not match Read parameter type",
23551 end Stream_Convert;
23557 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
23559 -- This is processed by the parser since some of the style checks
23560 -- take place during source scanning and parsing. This means that
23561 -- we don't need to issue error messages here.
23563 when Pragma_Style_Checks => Style_Checks : declare
23564 A : constant Node_Id := Get_Pragma_Arg (Arg1);
23570 Check_No_Identifiers;
23572 -- Two argument form
23574 if Arg_Count = 2 then
23575 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23582 E_Id := Get_Pragma_Arg (Arg2);
23585 if not Is_Entity_Name (E_Id) then
23587 ("second argument of pragma% must be entity name",
23591 E := Entity (E_Id);
23593 if not Ignore_Style_Checks_Pragmas then
23598 Set_Suppress_Style_Checks
23599 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off);
23600 exit when No (Homonym (E));
23607 -- One argument form
23610 Check_Arg_Count (1);
23612 if Nkind (A) = N_String_Literal then
23616 Slen : constant Natural := Natural (String_Length (S));
23617 Options : String (1 .. Slen);
23623 C := Get_String_Char (S, Pos (J));
23624 exit when not In_Character_Range (C);
23625 Options (J) := Get_Character (C);
23627 -- If at end of string, set options. As per discussion
23628 -- above, no need to check for errors, since we issued
23629 -- them in the parser.
23632 if not Ignore_Style_Checks_Pragmas then
23633 Set_Style_Check_Options (Options);
23643 elsif Nkind (A) = N_Identifier then
23644 if Chars (A) = Name_All_Checks then
23645 if not Ignore_Style_Checks_Pragmas then
23647 Set_GNAT_Style_Check_Options;
23649 Set_Default_Style_Check_Options;
23653 elsif Chars (A) = Name_On then
23654 if not Ignore_Style_Checks_Pragmas then
23655 Style_Check := True;
23658 elsif Chars (A) = Name_Off then
23659 if not Ignore_Style_Checks_Pragmas then
23660 Style_Check := False;
23671 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
23673 when Pragma_Subtitle =>
23675 Check_Arg_Count (1);
23676 Check_Optional_Identifier (Arg1, Name_Subtitle);
23677 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
23684 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
23686 when Pragma_Suppress =>
23687 Process_Suppress_Unsuppress (Suppress_Case => True);
23693 -- pragma Suppress_All;
23695 -- The only check made here is that the pragma has no arguments.
23696 -- There are no placement rules, and the processing required (setting
23697 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
23698 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
23699 -- then creates and inserts a pragma Suppress (All_Checks).
23701 when Pragma_Suppress_All =>
23703 Check_Arg_Count (0);
23705 -------------------------
23706 -- Suppress_Debug_Info --
23707 -------------------------
23709 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
23711 when Pragma_Suppress_Debug_Info => Suppress_Debug_Info : declare
23712 Nam_Id : Entity_Id;
23716 Check_Arg_Count (1);
23717 Check_Optional_Identifier (Arg1, Name_Entity);
23718 Check_Arg_Is_Local_Name (Arg1);
23720 Nam_Id := Entity (Get_Pragma_Arg (Arg1));
23722 -- A pragma that applies to a Ghost entity becomes Ghost for the
23723 -- purposes of legality checks and removal of ignored Ghost code.
23725 Mark_Ghost_Pragma (N, Nam_Id);
23726 Set_Debug_Info_Off (Nam_Id);
23727 end Suppress_Debug_Info;
23729 ----------------------------------
23730 -- Suppress_Exception_Locations --
23731 ----------------------------------
23733 -- pragma Suppress_Exception_Locations;
23735 when Pragma_Suppress_Exception_Locations =>
23737 Check_Arg_Count (0);
23738 Check_Valid_Configuration_Pragma;
23739 Exception_Locations_Suppressed := True;
23741 -----------------------------
23742 -- Suppress_Initialization --
23743 -----------------------------
23745 -- pragma Suppress_Initialization ([Entity =>] type_Name);
23747 when Pragma_Suppress_Initialization => Suppress_Init : declare
23753 Check_Arg_Count (1);
23754 Check_Optional_Identifier (Arg1, Name_Entity);
23755 Check_Arg_Is_Local_Name (Arg1);
23757 E_Id := Get_Pragma_Arg (Arg1);
23759 if Etype (E_Id) = Any_Type then
23763 E := Entity (E_Id);
23765 -- A pragma that applies to a Ghost entity becomes Ghost for the
23766 -- purposes of legality checks and removal of ignored Ghost code.
23768 Mark_Ghost_Pragma (N, E);
23770 if not Is_Type (E) and then Ekind (E) /= E_Variable then
23772 ("pragma% requires variable, type or subtype", Arg1);
23775 if Rep_Item_Too_Early (E, N)
23777 Rep_Item_Too_Late (E, N, FOnly => True)
23782 -- For incomplete/private type, set flag on full view
23784 if Is_Incomplete_Or_Private_Type (E) then
23785 if No (Full_View (Base_Type (E))) then
23787 ("argument of pragma% cannot be an incomplete type", Arg1);
23789 Set_Suppress_Initialization (Full_View (E));
23792 -- For first subtype, set flag on base type
23794 elsif Is_First_Subtype (E) then
23795 Set_Suppress_Initialization (Base_Type (E));
23797 -- For other than first subtype, set flag on subtype or variable
23800 Set_Suppress_Initialization (E);
23808 -- pragma System_Name (DIRECT_NAME);
23810 -- Syntax check: one argument, which must be the identifier GNAT or
23811 -- the identifier GCC, no other identifiers are acceptable.
23813 when Pragma_System_Name =>
23815 Check_No_Identifiers;
23816 Check_Arg_Count (1);
23817 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
23819 -----------------------------
23820 -- Task_Dispatching_Policy --
23821 -----------------------------
23823 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
23825 when Pragma_Task_Dispatching_Policy => declare
23829 Check_Ada_83_Warning;
23830 Check_Arg_Count (1);
23831 Check_No_Identifiers;
23832 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
23833 Check_Valid_Configuration_Pragma;
23834 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
23835 DP := Fold_Upper (Name_Buffer (1));
23837 if Task_Dispatching_Policy /= ' '
23838 and then Task_Dispatching_Policy /= DP
23840 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
23842 ("task dispatching policy incompatible with policy#");
23844 -- Set new policy, but always preserve System_Location since we
23845 -- like the error message with the run time name.
23848 Task_Dispatching_Policy := DP;
23850 if Task_Dispatching_Policy_Sloc /= System_Location then
23851 Task_Dispatching_Policy_Sloc := Loc;
23860 -- pragma Task_Info (EXPRESSION);
23862 when Pragma_Task_Info => Task_Info : declare
23863 P : constant Node_Id := Parent (N);
23869 if Warn_On_Obsolescent_Feature then
23871 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
23872 & "instead?j?", N);
23875 if Nkind (P) /= N_Task_Definition then
23876 Error_Pragma ("pragma% must appear in task definition");
23879 Check_No_Identifiers;
23880 Check_Arg_Count (1);
23882 Analyze_And_Resolve
23883 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
23885 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
23889 Ent := Defining_Identifier (Parent (P));
23891 -- Check duplicate pragma before we chain the pragma in the Rep
23892 -- Item chain of Ent.
23895 (Ent, Name_Task_Info, Check_Parents => False)
23897 Error_Pragma ("duplicate pragma% not allowed");
23900 Record_Rep_Item (Ent, N);
23907 -- pragma Task_Name (string_EXPRESSION);
23909 when Pragma_Task_Name => Task_Name : declare
23910 P : constant Node_Id := Parent (N);
23915 Check_No_Identifiers;
23916 Check_Arg_Count (1);
23918 Arg := Get_Pragma_Arg (Arg1);
23920 -- The expression is used in the call to Create_Task, and must be
23921 -- expanded there, not in the context of the current spec. It must
23922 -- however be analyzed to capture global references, in case it
23923 -- appears in a generic context.
23925 Preanalyze_And_Resolve (Arg, Standard_String);
23927 if Nkind (P) /= N_Task_Definition then
23931 Ent := Defining_Identifier (Parent (P));
23933 -- Check duplicate pragma before we chain the pragma in the Rep
23934 -- Item chain of Ent.
23937 (Ent, Name_Task_Name, Check_Parents => False)
23939 Error_Pragma ("duplicate pragma% not allowed");
23942 Record_Rep_Item (Ent, N);
23949 -- pragma Task_Storage (
23950 -- [Task_Type =>] LOCAL_NAME,
23951 -- [Top_Guard =>] static_integer_EXPRESSION);
23953 when Pragma_Task_Storage => Task_Storage : declare
23954 Args : Args_List (1 .. 2);
23955 Names : constant Name_List (1 .. 2) := (
23959 Task_Type : Node_Id renames Args (1);
23960 Top_Guard : Node_Id renames Args (2);
23966 Gather_Associations (Names, Args);
23968 if No (Task_Type) then
23970 ("missing task_type argument for pragma%");
23973 Check_Arg_Is_Local_Name (Task_Type);
23975 Ent := Entity (Task_Type);
23977 if not Is_Task_Type (Ent) then
23979 ("argument for pragma% must be task type", Task_Type);
23982 if No (Top_Guard) then
23984 ("pragma% takes two arguments", Task_Type);
23986 Check_Arg_Is_OK_Static_Expression (Top_Guard, Any_Integer);
23989 Check_First_Subtype (Task_Type);
23991 if Rep_Item_Too_Late (Ent, N) then
24000 -- pragma Test_Case
24001 -- ([Name =>] Static_String_EXPRESSION
24002 -- ,[Mode =>] MODE_TYPE
24003 -- [, Requires => Boolean_EXPRESSION]
24004 -- [, Ensures => Boolean_EXPRESSION]);
24006 -- MODE_TYPE ::= Nominal | Robustness
24008 -- Characteristics:
24010 -- * Analysis - The annotation undergoes initial checks to verify
24011 -- the legal placement and context. Secondary checks preanalyze the
24014 -- Analyze_Test_Case_In_Decl_Part
24016 -- * Expansion - None.
24018 -- * Template - The annotation utilizes the generic template of the
24019 -- related subprogram when it is:
24021 -- aspect on subprogram declaration
24023 -- The annotation must prepare its own template when it is:
24025 -- pragma on subprogram declaration
24027 -- * Globals - Capture of global references must occur after full
24030 -- * Instance - The annotation is instantiated automatically when
24031 -- the related generic subprogram is instantiated except for the
24032 -- "pragma on subprogram declaration" case. In that scenario the
24033 -- annotation must instantiate itself.
24035 when Pragma_Test_Case => Test_Case : declare
24036 procedure Check_Distinct_Name (Subp_Id : Entity_Id);
24037 -- Ensure that the contract of subprogram Subp_Id does not contain
24038 -- another Test_Case pragma with the same Name as the current one.
24040 -------------------------
24041 -- Check_Distinct_Name --
24042 -------------------------
24044 procedure Check_Distinct_Name (Subp_Id : Entity_Id) is
24045 Items : constant Node_Id := Contract (Subp_Id);
24046 Name : constant String_Id := Get_Name_From_CTC_Pragma (N);
24050 -- Inspect all Test_Case pragma of the related subprogram
24051 -- looking for one with a duplicate "Name" argument.
24053 if Present (Items) then
24054 Prag := Contract_Test_Cases (Items);
24055 while Present (Prag) loop
24056 if Pragma_Name (Prag) = Name_Test_Case
24058 and then String_Equal
24059 (Name, Get_Name_From_CTC_Pragma (Prag))
24061 Error_Msg_Sloc := Sloc (Prag);
24062 Error_Pragma ("name for pragma % is already used #");
24065 Prag := Next_Pragma (Prag);
24068 end Check_Distinct_Name;
24072 Pack_Decl : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
24075 Subp_Decl : Node_Id;
24076 Subp_Id : Entity_Id;
24078 -- Start of processing for Test_Case
24082 Check_At_Least_N_Arguments (2);
24083 Check_At_Most_N_Arguments (4);
24085 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
24089 Check_Optional_Identifier (Arg1, Name_Name);
24090 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
24094 Check_Optional_Identifier (Arg2, Name_Mode);
24095 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
24097 -- Arguments "Requires" and "Ensures"
24099 if Present (Arg3) then
24100 if Present (Arg4) then
24101 Check_Identifier (Arg3, Name_Requires);
24102 Check_Identifier (Arg4, Name_Ensures);
24104 Check_Identifier_Is_One_Of
24105 (Arg3, Name_Requires, Name_Ensures);
24109 -- Pragma Test_Case must be associated with a subprogram declared
24110 -- in a library-level package. First determine whether the current
24111 -- compilation unit is a legal context.
24113 if Nkind_In (Pack_Decl, N_Package_Declaration,
24114 N_Generic_Package_Declaration)
24118 -- Otherwise the placement is illegal
24122 ("pragma % must be specified within a package declaration");
24126 Subp_Decl := Find_Related_Declaration_Or_Body (N);
24128 -- Find the enclosing context
24130 Context := Parent (Subp_Decl);
24132 if Present (Context) then
24133 Context := Parent (Context);
24136 -- Verify the placement of the pragma
24138 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
24140 ("pragma % cannot be applied to abstract subprogram");
24143 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
24144 Error_Pragma ("pragma % cannot be applied to entry");
24147 -- The context is a [generic] subprogram declared at the top level
24148 -- of the [generic] package unit.
24150 elsif Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration,
24151 N_Subprogram_Declaration)
24152 and then Present (Context)
24153 and then Nkind_In (Context, N_Generic_Package_Declaration,
24154 N_Package_Declaration)
24158 -- Otherwise the placement is illegal
24162 ("pragma % must be applied to a library-level subprogram "
24167 Subp_Id := Defining_Entity (Subp_Decl);
24169 -- A pragma that applies to a Ghost entity becomes Ghost for the
24170 -- purposes of legality checks and removal of ignored Ghost code.
24172 Mark_Ghost_Pragma (N, Subp_Id);
24174 -- Chain the pragma on the contract for further processing by
24175 -- Analyze_Test_Case_In_Decl_Part.
24177 Add_Contract_Item (N, Subp_Id);
24179 -- Preanalyze the original aspect argument "Name" for a generic
24180 -- subprogram to properly capture global references.
24182 if Is_Generic_Subprogram (Subp_Id) then
24183 Asp_Arg := Test_Case_Arg (N, Name_Name, From_Aspect => True);
24185 if Present (Asp_Arg) then
24187 -- The argument appears with an identifier in association
24190 if Nkind (Asp_Arg) = N_Component_Association then
24191 Asp_Arg := Expression (Asp_Arg);
24194 Check_Expr_Is_OK_Static_Expression
24195 (Asp_Arg, Standard_String);
24199 -- Ensure that the all Test_Case pragmas of the related subprogram
24200 -- have distinct names.
24202 Check_Distinct_Name (Subp_Id);
24204 -- Fully analyze the pragma when it appears inside an entry
24205 -- or subprogram body because it cannot benefit from forward
24208 if Nkind_In (Subp_Decl, N_Entry_Body,
24210 N_Subprogram_Body_Stub)
24212 -- The legality checks of pragma Test_Case are affected by the
24213 -- SPARK mode in effect and the volatility of the context.
24214 -- Analyze all pragmas in a specific order.
24216 Analyze_If_Present (Pragma_SPARK_Mode);
24217 Analyze_If_Present (Pragma_Volatile_Function);
24218 Analyze_Test_Case_In_Decl_Part (N);
24222 --------------------------
24223 -- Thread_Local_Storage --
24224 --------------------------
24226 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
24228 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
24234 Check_Arg_Count (1);
24235 Check_Optional_Identifier (Arg1, Name_Entity);
24236 Check_Arg_Is_Library_Level_Local_Name (Arg1);
24238 Id := Get_Pragma_Arg (Arg1);
24241 if not Is_Entity_Name (Id)
24242 or else Ekind (Entity (Id)) /= E_Variable
24244 Error_Pragma_Arg ("local variable name required", Arg1);
24249 -- A pragma that applies to a Ghost entity becomes Ghost for the
24250 -- purposes of legality checks and removal of ignored Ghost code.
24252 Mark_Ghost_Pragma (N, E);
24254 if Rep_Item_Too_Early (E, N)
24256 Rep_Item_Too_Late (E, N)
24261 Set_Has_Pragma_Thread_Local_Storage (E);
24262 Set_Has_Gigi_Rep_Item (E);
24263 end Thread_Local_Storage;
24269 -- pragma Time_Slice (static_duration_EXPRESSION);
24271 when Pragma_Time_Slice => Time_Slice : declare
24277 Check_Arg_Count (1);
24278 Check_No_Identifiers;
24279 Check_In_Main_Program;
24280 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_Duration);
24282 if not Error_Posted (Arg1) then
24284 while Present (Nod) loop
24285 if Nkind (Nod) = N_Pragma
24286 and then Pragma_Name (Nod) = Name_Time_Slice
24288 Error_Msg_Name_1 := Pname;
24289 Error_Msg_N ("duplicate pragma% not permitted", Nod);
24296 -- Process only if in main unit
24298 if Get_Source_Unit (Loc) = Main_Unit then
24299 Opt.Time_Slice_Set := True;
24300 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
24302 if Val <= Ureal_0 then
24303 Opt.Time_Slice_Value := 0;
24305 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
24306 Opt.Time_Slice_Value := 1_000_000_000;
24309 Opt.Time_Slice_Value :=
24310 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
24319 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
24321 -- TITLING_OPTION ::=
24322 -- [Title =>] STRING_LITERAL
24323 -- | [Subtitle =>] STRING_LITERAL
24325 when Pragma_Title => Title : declare
24326 Args : Args_List (1 .. 2);
24327 Names : constant Name_List (1 .. 2) := (
24333 Gather_Associations (Names, Args);
24336 for J in 1 .. 2 loop
24337 if Present (Args (J)) then
24338 Check_Arg_Is_OK_Static_Expression
24339 (Args (J), Standard_String);
24344 ----------------------------
24345 -- Type_Invariant[_Class] --
24346 ----------------------------
24348 -- pragma Type_Invariant[_Class]
24349 -- ([Entity =>] type_LOCAL_NAME,
24350 -- [Check =>] EXPRESSION);
24352 when Pragma_Type_Invariant
24353 | Pragma_Type_Invariant_Class
24355 Type_Invariant : declare
24356 I_Pragma : Node_Id;
24359 Check_Arg_Count (2);
24361 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
24362 -- setting Class_Present for the Type_Invariant_Class case.
24364 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class);
24365 I_Pragma := New_Copy (N);
24366 Set_Pragma_Identifier
24367 (I_Pragma, Make_Identifier (Loc, Name_Invariant));
24368 Rewrite (N, I_Pragma);
24369 Set_Analyzed (N, False);
24371 end Type_Invariant;
24373 ---------------------
24374 -- Unchecked_Union --
24375 ---------------------
24377 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
24379 when Pragma_Unchecked_Union => Unchecked_Union : declare
24380 Assoc : constant Node_Id := Arg1;
24381 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
24391 Check_No_Identifiers;
24392 Check_Arg_Count (1);
24393 Check_Arg_Is_Local_Name (Arg1);
24395 Find_Type (Type_Id);
24397 Typ := Entity (Type_Id);
24399 -- A pragma that applies to a Ghost entity becomes Ghost for the
24400 -- purposes of legality checks and removal of ignored Ghost code.
24402 Mark_Ghost_Pragma (N, Typ);
24405 or else Rep_Item_Too_Early (Typ, N)
24409 Typ := Underlying_Type (Typ);
24412 if Rep_Item_Too_Late (Typ, N) then
24416 Check_First_Subtype (Arg1);
24418 -- Note remaining cases are references to a type in the current
24419 -- declarative part. If we find an error, we post the error on
24420 -- the relevant type declaration at an appropriate point.
24422 if not Is_Record_Type (Typ) then
24423 Error_Msg_N ("unchecked union must be record type", Typ);
24426 elsif Is_Tagged_Type (Typ) then
24427 Error_Msg_N ("unchecked union must not be tagged", Typ);
24430 elsif not Has_Discriminants (Typ) then
24432 ("unchecked union must have one discriminant", Typ);
24435 -- Note: in previous versions of GNAT we used to check for limited
24436 -- types and give an error, but in fact the standard does allow
24437 -- Unchecked_Union on limited types, so this check was removed.
24439 -- Similarly, GNAT used to require that all discriminants have
24440 -- default values, but this is not mandated by the RM.
24442 -- Proceed with basic error checks completed
24445 Tdef := Type_Definition (Declaration_Node (Typ));
24446 Clist := Component_List (Tdef);
24448 -- Check presence of component list and variant part
24450 if No (Clist) or else No (Variant_Part (Clist)) then
24452 ("unchecked union must have variant part", Tdef);
24456 -- Check components
24458 Comp := First_Non_Pragma (Component_Items (Clist));
24459 while Present (Comp) loop
24460 Check_Component (Comp, Typ);
24461 Next_Non_Pragma (Comp);
24464 -- Check variant part
24466 Vpart := Variant_Part (Clist);
24468 Variant := First_Non_Pragma (Variants (Vpart));
24469 while Present (Variant) loop
24470 Check_Variant (Variant, Typ);
24471 Next_Non_Pragma (Variant);
24475 Set_Is_Unchecked_Union (Typ);
24476 Set_Convention (Typ, Convention_C);
24477 Set_Has_Unchecked_Union (Base_Type (Typ));
24478 Set_Is_Unchecked_Union (Base_Type (Typ));
24479 end Unchecked_Union;
24481 ----------------------------
24482 -- Unevaluated_Use_Of_Old --
24483 ----------------------------
24485 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
24487 when Pragma_Unevaluated_Use_Of_Old =>
24489 Check_Arg_Count (1);
24490 Check_No_Identifiers;
24491 Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow);
24493 -- Suppress/Unsuppress can appear as a configuration pragma, or in
24494 -- a declarative part or a package spec.
24496 if not Is_Configuration_Pragma then
24497 Check_Is_In_Decl_Part_Or_Package_Spec;
24500 -- Store proper setting of Uneval_Old
24502 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
24503 Uneval_Old := Fold_Upper (Name_Buffer (1));
24505 ------------------------
24506 -- Unimplemented_Unit --
24507 ------------------------
24509 -- pragma Unimplemented_Unit;
24511 -- Note: this only gives an error if we are generating code, or if
24512 -- we are in a generic library unit (where the pragma appears in the
24513 -- body, not in the spec).
24515 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
24516 Cunitent : constant Entity_Id :=
24517 Cunit_Entity (Get_Source_Unit (Loc));
24518 Ent_Kind : constant Entity_Kind := Ekind (Cunitent);
24522 Check_Arg_Count (0);
24524 if Operating_Mode = Generate_Code
24525 or else Ent_Kind = E_Generic_Function
24526 or else Ent_Kind = E_Generic_Procedure
24527 or else Ent_Kind = E_Generic_Package
24529 Get_Name_String (Chars (Cunitent));
24530 Set_Casing (Mixed_Case);
24531 Write_Str (Name_Buffer (1 .. Name_Len));
24532 Write_Str (" is not supported in this configuration");
24534 raise Unrecoverable_Error;
24536 end Unimplemented_Unit;
24538 ------------------------
24539 -- Universal_Aliasing --
24540 ------------------------
24542 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
24544 when Pragma_Universal_Aliasing => Universal_Alias : declare
24550 Check_Arg_Count (1);
24551 Check_Optional_Identifier (Arg2, Name_Entity);
24552 Check_Arg_Is_Local_Name (Arg1);
24553 E_Id := Get_Pragma_Arg (Arg1);
24555 if Etype (E_Id) = Any_Type then
24559 E := Entity (E_Id);
24561 if not Is_Type (E) then
24562 Error_Pragma_Arg ("pragma% requires type", Arg1);
24565 -- A pragma that applies to a Ghost entity becomes Ghost for the
24566 -- purposes of legality checks and removal of ignored Ghost code.
24568 Mark_Ghost_Pragma (N, E);
24569 Set_Universal_Aliasing (Base_Type (E));
24570 Record_Rep_Item (E, N);
24571 end Universal_Alias;
24573 --------------------
24574 -- Universal_Data --
24575 --------------------
24577 -- pragma Universal_Data [(library_unit_NAME)];
24579 when Pragma_Universal_Data =>
24581 Error_Pragma ("??pragma% ignored (applies only to AAMP)");
24587 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
24589 when Pragma_Unmodified =>
24590 Analyze_Unmodified_Or_Unused;
24596 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
24598 -- or when used in a context clause:
24600 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
24602 when Pragma_Unreferenced =>
24603 Analyze_Unreferenced_Or_Unused;
24605 --------------------------
24606 -- Unreferenced_Objects --
24607 --------------------------
24609 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
24611 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
24613 Arg_Expr : Node_Id;
24614 Arg_Id : Entity_Id;
24616 Ghost_Error_Posted : Boolean := False;
24617 -- Flag set when an error concerning the illegal mix of Ghost and
24618 -- non-Ghost types is emitted.
24620 Ghost_Id : Entity_Id := Empty;
24621 -- The entity of the first Ghost type encountered while processing
24622 -- the arguments of the pragma.
24626 Check_At_Least_N_Arguments (1);
24629 while Present (Arg) loop
24630 Check_No_Identifier (Arg);
24631 Check_Arg_Is_Local_Name (Arg);
24632 Arg_Expr := Get_Pragma_Arg (Arg);
24634 if Is_Entity_Name (Arg_Expr) then
24635 Arg_Id := Entity (Arg_Expr);
24637 if Is_Type (Arg_Id) then
24638 Set_Has_Pragma_Unreferenced_Objects (Arg_Id);
24640 -- A pragma that applies to a Ghost entity becomes Ghost
24641 -- for the purposes of legality checks and removal of
24642 -- ignored Ghost code.
24644 Mark_Ghost_Pragma (N, Arg_Id);
24646 -- Capture the entity of the first Ghost type being
24647 -- processed for error detection purposes.
24649 if Is_Ghost_Entity (Arg_Id) then
24650 if No (Ghost_Id) then
24651 Ghost_Id := Arg_Id;
24654 -- Otherwise the type is non-Ghost. It is illegal to mix
24655 -- references to Ghost and non-Ghost entities
24658 elsif Present (Ghost_Id)
24659 and then not Ghost_Error_Posted
24661 Ghost_Error_Posted := True;
24663 Error_Msg_Name_1 := Pname;
24665 ("pragma % cannot mention ghost and non-ghost types",
24668 Error_Msg_Sloc := Sloc (Ghost_Id);
24669 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
24671 Error_Msg_Sloc := Sloc (Arg_Id);
24672 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
24676 ("argument for pragma% must be type or subtype", Arg);
24680 ("argument for pragma% must be type or subtype", Arg);
24685 end Unreferenced_Objects;
24687 ------------------------------
24688 -- Unreserve_All_Interrupts --
24689 ------------------------------
24691 -- pragma Unreserve_All_Interrupts;
24693 when Pragma_Unreserve_All_Interrupts =>
24695 Check_Arg_Count (0);
24697 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
24698 Unreserve_All_Interrupts := True;
24705 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
24707 when Pragma_Unsuppress =>
24709 Process_Suppress_Unsuppress (Suppress_Case => False);
24715 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
24717 when Pragma_Unused =>
24718 Analyze_Unmodified_Or_Unused (Is_Unused => True);
24719 Analyze_Unreferenced_Or_Unused (Is_Unused => True);
24721 -------------------
24722 -- Use_VADS_Size --
24723 -------------------
24725 -- pragma Use_VADS_Size;
24727 when Pragma_Use_VADS_Size =>
24729 Check_Arg_Count (0);
24730 Check_Valid_Configuration_Pragma;
24731 Use_VADS_Size := True;
24733 ---------------------
24734 -- Validity_Checks --
24735 ---------------------
24737 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
24739 when Pragma_Validity_Checks => Validity_Checks : declare
24740 A : constant Node_Id := Get_Pragma_Arg (Arg1);
24746 Check_Arg_Count (1);
24747 Check_No_Identifiers;
24749 -- Pragma always active unless in CodePeer or GNATprove modes,
24750 -- which use a fixed configuration of validity checks.
24752 if not (CodePeer_Mode or GNATprove_Mode) then
24753 if Nkind (A) = N_String_Literal then
24757 Slen : constant Natural := Natural (String_Length (S));
24758 Options : String (1 .. Slen);
24762 -- Couldn't we use a for loop here over Options'Range???
24766 C := Get_String_Char (S, Pos (J));
24768 -- This is a weird test, it skips setting validity
24769 -- checks entirely if any element of S is out of
24770 -- range of Character, what is that about ???
24772 exit when not In_Character_Range (C);
24773 Options (J) := Get_Character (C);
24776 Set_Validity_Check_Options (Options);
24784 elsif Nkind (A) = N_Identifier then
24785 if Chars (A) = Name_All_Checks then
24786 Set_Validity_Check_Options ("a");
24787 elsif Chars (A) = Name_On then
24788 Validity_Checks_On := True;
24789 elsif Chars (A) = Name_Off then
24790 Validity_Checks_On := False;
24794 end Validity_Checks;
24800 -- pragma Volatile (LOCAL_NAME);
24802 when Pragma_Volatile =>
24803 Process_Atomic_Independent_Shared_Volatile;
24805 -------------------------
24806 -- Volatile_Components --
24807 -------------------------
24809 -- pragma Volatile_Components (array_LOCAL_NAME);
24811 -- Volatile is handled by the same circuit as Atomic_Components
24813 --------------------------
24814 -- Volatile_Full_Access --
24815 --------------------------
24817 -- pragma Volatile_Full_Access (LOCAL_NAME);
24819 when Pragma_Volatile_Full_Access =>
24821 Process_Atomic_Independent_Shared_Volatile;
24823 -----------------------
24824 -- Volatile_Function --
24825 -----------------------
24827 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
24829 when Pragma_Volatile_Function => Volatile_Function : declare
24830 Over_Id : Entity_Id;
24831 Spec_Id : Entity_Id;
24832 Subp_Decl : Node_Id;
24836 Check_No_Identifiers;
24837 Check_At_Most_N_Arguments (1);
24840 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
24842 -- Generic subprogram
24844 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
24847 -- Body acts as spec
24849 elsif Nkind (Subp_Decl) = N_Subprogram_Body
24850 and then No (Corresponding_Spec (Subp_Decl))
24854 -- Body stub acts as spec
24856 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
24857 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
24863 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
24871 Spec_Id := Unique_Defining_Entity (Subp_Decl);
24873 if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
24878 -- A pragma that applies to a Ghost entity becomes Ghost for the
24879 -- purposes of legality checks and removal of ignored Ghost code.
24881 Mark_Ghost_Pragma (N, Spec_Id);
24883 -- Chain the pragma on the contract for completeness
24885 Add_Contract_Item (N, Spec_Id);
24887 -- The legality checks of pragma Volatile_Function are affected by
24888 -- the SPARK mode in effect. Analyze all pragmas in a specific
24891 Analyze_If_Present (Pragma_SPARK_Mode);
24893 -- A volatile function cannot override a non-volatile function
24894 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
24895 -- in New_Overloaded_Entity, however at that point the pragma has
24896 -- not been processed yet.
24898 Over_Id := Overridden_Operation (Spec_Id);
24900 if Present (Over_Id)
24901 and then not Is_Volatile_Function (Over_Id)
24904 ("incompatible volatile function values in effect", Spec_Id);
24906 Error_Msg_Sloc := Sloc (Over_Id);
24908 ("\& declared # with Volatile_Function value False",
24911 Error_Msg_Sloc := Sloc (Spec_Id);
24913 ("\overridden # with Volatile_Function value True",
24917 -- Analyze the Boolean expression (if any)
24919 if Present (Arg1) then
24920 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
24922 end Volatile_Function;
24924 ----------------------
24925 -- Warning_As_Error --
24926 ----------------------
24928 -- pragma Warning_As_Error (static_string_EXPRESSION);
24930 when Pragma_Warning_As_Error =>
24932 Check_Arg_Count (1);
24933 Check_No_Identifiers;
24934 Check_Valid_Configuration_Pragma;
24936 if not Is_Static_String_Expression (Arg1) then
24938 ("argument of pragma% must be static string expression",
24941 -- OK static string expression
24944 Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1;
24945 Warnings_As_Errors (Warnings_As_Errors_Count) :=
24946 new String'(Acquire_Warning_Match_String
24947 (Expr_Value_S (Get_Pragma_Arg (Arg1))));
24954 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
24956 -- DETAILS ::= On | Off
24957 -- DETAILS ::= On | Off, local_NAME
24958 -- DETAILS ::= static_string_EXPRESSION
24959 -- DETAILS ::= On | Off, static_string_EXPRESSION
24961 -- TOOL_NAME ::= GNAT | GNATProve
24963 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
24965 -- Note: If the first argument matches an allowed tool name, it is
24966 -- always considered to be a tool name, even if there is a string
24967 -- variable of that name.
24969 -- Note if the second argument of DETAILS is a local_NAME then the
24970 -- second form is always understood. If the intention is to use
24971 -- the fourth form, then you can write NAME & "" to force the
24972 -- intepretation as a static_string_EXPRESSION.
24974 when Pragma_Warnings => Warnings : declare
24975 Reason : String_Id;
24979 Check_At_Least_N_Arguments (1);
24981 -- See if last argument is labeled Reason. If so, make sure we
24982 -- have a string literal or a concatenation of string literals,
24983 -- and acquire the REASON string. Then remove the REASON argument
24984 -- by decreasing Num_Args by one; Remaining processing looks only
24985 -- at first Num_Args arguments).
24988 Last_Arg : constant Node_Id :=
24989 Last (Pragma_Argument_Associations (N));
24992 if Nkind (Last_Arg) = N_Pragma_Argument_Association
24993 and then Chars (Last_Arg) = Name_Reason
24996 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
24997 Reason := End_String;
24998 Arg_Count := Arg_Count - 1;
25000 -- Not allowed in compiler units (bootstrap issues)
25002 Check_Compiler_Unit ("Reason for pragma Warnings", N);
25004 -- No REASON string, set null string as reason
25007 Reason := Null_String_Id;
25011 -- Now proceed with REASON taken care of and eliminated
25013 Check_No_Identifiers;
25015 -- If debug flag -gnatd.i is set, pragma is ignored
25017 if Debug_Flag_Dot_I then
25021 -- Process various forms of the pragma
25024 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
25025 Shifted_Args : List_Id;
25028 -- See if first argument is a tool name, currently either
25029 -- GNAT or GNATprove. If so, either ignore the pragma if the
25030 -- tool used does not match, or continue as if no tool name
25031 -- was given otherwise, by shifting the arguments.
25033 if Nkind (Argx) = N_Identifier
25034 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
25036 if Chars (Argx) = Name_Gnat then
25037 if CodePeer_Mode or GNATprove_Mode then
25038 Rewrite (N, Make_Null_Statement (Loc));
25043 elsif Chars (Argx) = Name_Gnatprove then
25044 if not GNATprove_Mode then
25045 Rewrite (N, Make_Null_Statement (Loc));
25051 raise Program_Error;
25054 -- At this point, the pragma Warnings applies to the tool,
25055 -- so continue with shifted arguments.
25057 Arg_Count := Arg_Count - 1;
25059 if Arg_Count = 1 then
25060 Shifted_Args := New_List (New_Copy (Arg2));
25061 elsif Arg_Count = 2 then
25062 Shifted_Args := New_List (New_Copy (Arg2),
25064 elsif Arg_Count = 3 then
25065 Shifted_Args := New_List (New_Copy (Arg2),
25069 raise Program_Error;
25074 Chars => Name_Warnings,
25075 Pragma_Argument_Associations => Shifted_Args));
25080 -- One argument case
25082 if Arg_Count = 1 then
25084 -- On/Off one argument case was processed by parser
25086 if Nkind (Argx) = N_Identifier
25087 and then Nam_In (Chars (Argx), Name_On, Name_Off)
25091 -- One argument case must be ON/OFF or static string expr
25093 elsif not Is_Static_String_Expression (Arg1) then
25095 ("argument of pragma% must be On/Off or static string "
25096 & "expression", Arg1);
25098 -- One argument string expression case
25102 Lit : constant Node_Id := Expr_Value_S (Argx);
25103 Str : constant String_Id := Strval (Lit);
25104 Len : constant Nat := String_Length (Str);
25112 while J <= Len loop
25113 C := Get_String_Char (Str, J);
25114 OK := In_Character_Range (C);
25117 Chr := Get_Character (C);
25119 -- Dash case: only -Wxxx is accepted
25126 C := Get_String_Char (Str, J);
25127 Chr := Get_Character (C);
25128 exit when Chr = 'W';
25133 elsif J < Len and then Chr = '.' then
25135 C := Get_String_Char (Str, J);
25136 Chr := Get_Character (C);
25138 if not Set_Dot_Warning_Switch (Chr) then
25140 ("invalid warning switch character "
25141 & '.' & Chr, Arg1);
25147 OK := Set_Warning_Switch (Chr);
25152 ("invalid warning switch character " & Chr,
25158 ("invalid wide character in warning switch ",
25167 -- Two or more arguments (must be two)
25170 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
25171 Check_Arg_Count (2);
25179 E_Id := Get_Pragma_Arg (Arg2);
25182 -- In the expansion of an inlined body, a reference to
25183 -- the formal may be wrapped in a conversion if the
25184 -- actual is a conversion. Retrieve the real entity name.
25186 if (In_Instance_Body or In_Inlined_Body)
25187 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
25189 E_Id := Expression (E_Id);
25192 -- Entity name case
25194 if Is_Entity_Name (E_Id) then
25195 E := Entity (E_Id);
25202 (E, (Chars (Get_Pragma_Arg (Arg1)) =
25205 -- Suppress elaboration warnings if the entity
25206 -- denotes an elaboration target.
25208 if Is_Elaboration_Target (E) then
25209 Set_Is_Elaboration_Warnings_OK_Id (E, False);
25212 -- For OFF case, make entry in warnings off
25213 -- pragma table for later processing. But we do
25214 -- not do that within an instance, since these
25215 -- warnings are about what is needed in the
25216 -- template, not an instance of it.
25218 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
25219 and then Warn_On_Warnings_Off
25220 and then not In_Instance
25222 Warnings_Off_Pragmas.Append ((N, E, Reason));
25225 if Is_Enumeration_Type (E) then
25229 Lit := First_Literal (E);
25230 while Present (Lit) loop
25231 Set_Warnings_Off (Lit);
25232 Next_Literal (Lit);
25237 exit when No (Homonym (E));
25242 -- Error if not entity or static string expression case
25244 elsif not Is_Static_String_Expression (Arg2) then
25246 ("second argument of pragma% must be entity name "
25247 & "or static string expression", Arg2);
25249 -- Static string expression case
25252 -- Note on configuration pragma case: If this is a
25253 -- configuration pragma, then for an OFF pragma, we
25254 -- just set Config True in the call, which is all
25255 -- that needs to be done. For the case of ON, this
25256 -- is normally an error, unless it is canceling the
25257 -- effect of a previous OFF pragma in the same file.
25258 -- In any other case, an error will be signalled (ON
25259 -- with no matching OFF).
25261 -- Note: We set Used if we are inside a generic to
25262 -- disable the test that the non-config case actually
25263 -- cancels a warning. That's because we can't be sure
25264 -- there isn't an instantiation in some other unit
25265 -- where a warning is suppressed.
25267 -- We could do a little better here by checking if the
25268 -- generic unit we are inside is public, but for now
25269 -- we don't bother with that refinement.
25272 Message : constant String :=
25273 Acquire_Warning_Match_String
25274 (Expr_Value_S (Get_Pragma_Arg (Arg2)));
25276 if Chars (Argx) = Name_Off then
25277 Set_Specific_Warning_Off
25278 (Loc, Message, Reason,
25279 Config => Is_Configuration_Pragma,
25280 Used => Inside_A_Generic or else In_Instance);
25282 elsif Chars (Argx) = Name_On then
25283 Set_Specific_Warning_On (Loc, Message, Err);
25287 ("??pragma Warnings On with no matching "
25288 & "Warnings Off", Loc);
25298 -------------------
25299 -- Weak_External --
25300 -------------------
25302 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
25304 when Pragma_Weak_External => Weak_External : declare
25309 Check_Arg_Count (1);
25310 Check_Optional_Identifier (Arg1, Name_Entity);
25311 Check_Arg_Is_Library_Level_Local_Name (Arg1);
25312 Ent := Entity (Get_Pragma_Arg (Arg1));
25314 if Rep_Item_Too_Early (Ent, N) then
25317 Ent := Underlying_Type (Ent);
25320 -- The pragma applies to entities with addresses
25322 if Is_Type (Ent) then
25323 Error_Pragma ("pragma applies to objects and subprograms");
25326 -- The only processing required is to link this item on to the
25327 -- list of rep items for the given entity. This is accomplished
25328 -- by the call to Rep_Item_Too_Late (when no error is detected
25329 -- and False is returned).
25331 if Rep_Item_Too_Late (Ent, N) then
25334 Set_Has_Gigi_Rep_Item (Ent);
25338 -----------------------------
25339 -- Wide_Character_Encoding --
25340 -----------------------------
25342 -- pragma Wide_Character_Encoding (IDENTIFIER);
25344 when Pragma_Wide_Character_Encoding =>
25347 -- Nothing to do, handled in parser. Note that we do not enforce
25348 -- configuration pragma placement, this pragma can appear at any
25349 -- place in the source, allowing mixed encodings within a single
25354 --------------------
25355 -- Unknown_Pragma --
25356 --------------------
25358 -- Should be impossible, since the case of an unknown pragma is
25359 -- separately processed before the case statement is entered.
25361 when Unknown_Pragma =>
25362 raise Program_Error;
25365 -- AI05-0144: detect dangerous order dependence. Disabled for now,
25366 -- until AI is formally approved.
25368 -- Check_Order_Dependence;
25371 when Pragma_Exit => null;
25372 end Analyze_Pragma;
25374 ---------------------------------------------
25375 -- Analyze_Pre_Post_Condition_In_Decl_Part --
25376 ---------------------------------------------
25378 -- WARNING: This routine manages Ghost regions. Return statements must be
25379 -- replaced by gotos which jump to the end of the routine and restore the
25382 procedure Analyze_Pre_Post_Condition_In_Decl_Part
25384 Freeze_Id : Entity_Id := Empty)
25386 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
25387 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
25389 Disp_Typ : Entity_Id;
25390 -- The dispatching type of the subprogram subject to the pre- or
25393 function Check_References (Nod : Node_Id) return Traverse_Result;
25394 -- Check that expression Nod does not mention non-primitives of the
25395 -- type, global objects of the type, or other illegalities described
25396 -- and implied by AI12-0113.
25398 ----------------------
25399 -- Check_References --
25400 ----------------------
25402 function Check_References (Nod : Node_Id) return Traverse_Result is
25404 if Nkind (Nod) = N_Function_Call
25405 and then Is_Entity_Name (Name (Nod))
25408 Func : constant Entity_Id := Entity (Name (Nod));
25412 -- An operation of the type must be a primitive
25414 if No (Find_Dispatching_Type (Func)) then
25415 Form := First_Formal (Func);
25416 while Present (Form) loop
25417 if Etype (Form) = Disp_Typ then
25419 ("operation in class-wide condition must be "
25420 & "primitive of &", Nod, Disp_Typ);
25423 Next_Formal (Form);
25426 -- A return object of the type is illegal as well
25428 if Etype (Func) = Disp_Typ
25429 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
25432 ("operation in class-wide condition must be primitive "
25433 & "of &", Nod, Disp_Typ);
25436 -- Otherwise we have a call to an overridden primitive, and we
25437 -- will create a common class-wide clone for the body of
25438 -- original operation and its eventual inherited versions. If
25439 -- the original operation dispatches on result it is never
25440 -- inherited and there is no need for a clone. There is not
25441 -- need for a clone either in GNATprove mode, as cases that
25442 -- would require it are rejected (when an inherited primitive
25443 -- calls an overridden operation in a class-wide contract), and
25444 -- the clone would make proof impossible in some cases.
25446 elsif not Is_Abstract_Subprogram (Spec_Id)
25447 and then No (Class_Wide_Clone (Spec_Id))
25448 and then not Has_Controlling_Result (Spec_Id)
25449 and then not GNATprove_Mode
25451 Build_Class_Wide_Clone_Decl (Spec_Id);
25455 elsif Is_Entity_Name (Nod)
25457 (Etype (Nod) = Disp_Typ
25458 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
25459 and then Ekind_In (Entity (Nod), E_Constant, E_Variable)
25462 ("object in class-wide condition must be formal of type &",
25465 elsif Nkind (Nod) = N_Explicit_Dereference
25466 and then (Etype (Nod) = Disp_Typ
25467 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
25468 and then (not Is_Entity_Name (Prefix (Nod))
25469 or else not Is_Formal (Entity (Prefix (Nod))))
25472 ("operation in class-wide condition must be primitive of &",
25477 end Check_References;
25479 procedure Check_Class_Wide_Condition is
25480 new Traverse_Proc (Check_References);
25484 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
25486 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
25487 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
25488 -- Save the Ghost-related attributes to restore on exit
25491 Restore_Scope : Boolean := False;
25493 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
25496 -- Do not analyze the pragma multiple times
25498 if Is_Analyzed_Pragma (N) then
25502 -- Set the Ghost mode in effect from the pragma. Due to the delayed
25503 -- analysis of the pragma, the Ghost mode at point of declaration and
25504 -- point of analysis may not necessarily be the same. Use the mode in
25505 -- effect at the point of declaration.
25507 Set_Ghost_Mode (N);
25509 -- Ensure that the subprogram and its formals are visible when analyzing
25510 -- the expression of the pragma.
25512 if not In_Open_Scopes (Spec_Id) then
25513 Restore_Scope := True;
25514 Push_Scope (Spec_Id);
25516 if Is_Generic_Subprogram (Spec_Id) then
25517 Install_Generic_Formals (Spec_Id);
25519 Install_Formals (Spec_Id);
25523 Errors := Serious_Errors_Detected;
25524 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
25526 -- Emit a clarification message when the expression contains at least
25527 -- one undefined reference, possibly due to contract freezing.
25529 if Errors /= Serious_Errors_Detected
25530 and then Present (Freeze_Id)
25531 and then Has_Undefined_Reference (Expr)
25533 Contract_Freeze_Error (Spec_Id, Freeze_Id);
25536 if Class_Present (N) then
25538 -- Verify that a class-wide condition is legal, i.e. the operation is
25539 -- a primitive of a tagged type. Note that a generic subprogram is
25540 -- not a primitive operation.
25542 Disp_Typ := Find_Dispatching_Type (Spec_Id);
25544 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
25545 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
25547 if From_Aspect_Specification (N) then
25549 ("aspect % can only be specified for a primitive operation "
25550 & "of a tagged type", Corresponding_Aspect (N));
25552 -- The pragma is a source construct
25556 ("pragma % can only be specified for a primitive operation "
25557 & "of a tagged type", N);
25560 -- Remaining semantic checks require a full tree traversal
25563 Check_Class_Wide_Condition (Expr);
25568 if Restore_Scope then
25572 -- If analysis of the condition indicates that a class-wide clone
25573 -- has been created, build and analyze its declaration.
25575 if Is_Subprogram (Spec_Id)
25576 and then Present (Class_Wide_Clone (Spec_Id))
25578 Analyze (Unit_Declaration_Node (Class_Wide_Clone (Spec_Id)));
25581 -- Currently it is not possible to inline pre/postconditions on a
25582 -- subprogram subject to pragma Inline_Always.
25584 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
25585 Set_Is_Analyzed_Pragma (N);
25587 Restore_Ghost_Region (Saved_GM, Saved_IGR);
25588 end Analyze_Pre_Post_Condition_In_Decl_Part;
25590 ------------------------------------------
25591 -- Analyze_Refined_Depends_In_Decl_Part --
25592 ------------------------------------------
25594 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
25595 procedure Check_Dependency_Clause
25596 (Spec_Id : Entity_Id;
25597 Dep_Clause : Node_Id;
25598 Dep_States : Elist_Id;
25599 Refinements : List_Id;
25600 Matched_Items : in out Elist_Id);
25601 -- Try to match a single dependency clause Dep_Clause against one or
25602 -- more refinement clauses found in list Refinements. Each successful
25603 -- match eliminates at least one refinement clause from Refinements.
25604 -- Spec_Id denotes the entity of the related subprogram. Dep_States
25605 -- denotes the entities of all abstract states which appear in pragma
25606 -- Depends. Matched_Items contains the entities of all successfully
25607 -- matched items found in pragma Depends.
25609 procedure Check_Output_States
25610 (Spec_Inputs : Elist_Id;
25611 Spec_Outputs : Elist_Id;
25612 Body_Inputs : Elist_Id;
25613 Body_Outputs : Elist_Id);
25614 -- Determine whether pragma Depends contains an output state with a
25615 -- visible refinement and if so, ensure that pragma Refined_Depends
25616 -- mentions all its constituents as outputs. Spec_Inputs and
25617 -- Spec_Outputs denote the inputs and outputs of the subprogram spec
25618 -- synthesized from pragma Depends. Body_Inputs and Body_Outputs denote
25619 -- the inputs and outputs of the subprogram body synthesized from pragma
25620 -- Refined_Depends.
25622 function Collect_States (Clauses : List_Id) return Elist_Id;
25623 -- Given a normalized list of dependencies obtained from calling
25624 -- Normalize_Clauses, return a list containing the entities of all
25625 -- states appearing in dependencies. It helps in checking refinements
25626 -- involving a state and a corresponding constituent which is not a
25627 -- direct constituent of the state.
25629 procedure Normalize_Clauses (Clauses : List_Id);
25630 -- Given a list of dependence or refinement clauses Clauses, normalize
25631 -- each clause by creating multiple dependencies with exactly one input
25634 procedure Remove_Extra_Clauses
25635 (Clauses : List_Id;
25636 Matched_Items : Elist_Id);
25637 -- Given a list of refinement clauses Clauses, remove all clauses whose
25638 -- inputs and/or outputs have been previously matched. See the body for
25639 -- all special cases. Matched_Items contains the entities of all matched
25640 -- items found in pragma Depends.
25642 procedure Report_Extra_Clauses (Clauses : List_Id);
25643 -- Emit an error for each extra clause found in list Clauses
25645 -----------------------------
25646 -- Check_Dependency_Clause --
25647 -----------------------------
25649 procedure Check_Dependency_Clause
25650 (Spec_Id : Entity_Id;
25651 Dep_Clause : Node_Id;
25652 Dep_States : Elist_Id;
25653 Refinements : List_Id;
25654 Matched_Items : in out Elist_Id)
25656 Dep_Input : constant Node_Id := Expression (Dep_Clause);
25657 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
25659 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
25660 -- Determine whether dependency item Dep_Item has been matched in a
25661 -- previous clause.
25663 function Is_In_Out_State_Clause return Boolean;
25664 -- Determine whether dependence clause Dep_Clause denotes an abstract
25665 -- state that depends on itself (State => State).
25667 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
25668 -- Determine whether item Item denotes an abstract state with visible
25669 -- null refinement.
25671 procedure Match_Items
25672 (Dep_Item : Node_Id;
25673 Ref_Item : Node_Id;
25674 Matched : out Boolean);
25675 -- Try to match dependence item Dep_Item against refinement item
25676 -- Ref_Item. To match against a possible null refinement (see 2, 9),
25677 -- set Ref_Item to Empty. Flag Matched is set to True when one of
25678 -- the following conformance scenarios is in effect:
25679 -- 1) Both items denote null
25680 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
25681 -- 3) Both items denote attribute 'Result
25682 -- 4) Both items denote the same object
25683 -- 5) Both items denote the same formal parameter
25684 -- 6) Both items denote the same current instance of a type
25685 -- 7) Both items denote the same discriminant
25686 -- 8) Dep_Item is an abstract state with visible null refinement
25687 -- and Ref_Item denotes null.
25688 -- 9) Dep_Item is an abstract state with visible null refinement
25689 -- and Ref_Item is Empty (special case).
25690 -- 10) Dep_Item is an abstract state with full or partial visible
25691 -- non-null refinement and Ref_Item denotes one of its
25693 -- 11) Dep_Item is an abstract state without a full visible
25694 -- refinement and Ref_Item denotes the same state.
25695 -- When scenario 10 is in effect, the entity of the abstract state
25696 -- denoted by Dep_Item is added to list Refined_States.
25698 procedure Record_Item (Item_Id : Entity_Id);
25699 -- Store the entity of an item denoted by Item_Id in Matched_Items
25701 ------------------------
25702 -- Is_Already_Matched --
25703 ------------------------
25705 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean is
25706 Item_Id : Entity_Id := Empty;
25709 -- When the dependency item denotes attribute 'Result, check for
25710 -- the entity of the related subprogram.
25712 if Is_Attribute_Result (Dep_Item) then
25713 Item_Id := Spec_Id;
25715 elsif Is_Entity_Name (Dep_Item) then
25716 Item_Id := Available_View (Entity_Of (Dep_Item));
25720 Present (Item_Id) and then Contains (Matched_Items, Item_Id);
25721 end Is_Already_Matched;
25723 ----------------------------
25724 -- Is_In_Out_State_Clause --
25725 ----------------------------
25727 function Is_In_Out_State_Clause return Boolean is
25728 Dep_Input_Id : Entity_Id;
25729 Dep_Output_Id : Entity_Id;
25732 -- Detect the following clause:
25735 if Is_Entity_Name (Dep_Input)
25736 and then Is_Entity_Name (Dep_Output)
25738 -- Handle abstract views generated for limited with clauses
25740 Dep_Input_Id := Available_View (Entity_Of (Dep_Input));
25741 Dep_Output_Id := Available_View (Entity_Of (Dep_Output));
25744 Ekind (Dep_Input_Id) = E_Abstract_State
25745 and then Dep_Input_Id = Dep_Output_Id;
25749 end Is_In_Out_State_Clause;
25751 ---------------------------
25752 -- Is_Null_Refined_State --
25753 ---------------------------
25755 function Is_Null_Refined_State (Item : Node_Id) return Boolean is
25756 Item_Id : Entity_Id;
25759 if Is_Entity_Name (Item) then
25761 -- Handle abstract views generated for limited with clauses
25763 Item_Id := Available_View (Entity_Of (Item));
25766 Ekind (Item_Id) = E_Abstract_State
25767 and then Has_Null_Visible_Refinement (Item_Id);
25771 end Is_Null_Refined_State;
25777 procedure Match_Items
25778 (Dep_Item : Node_Id;
25779 Ref_Item : Node_Id;
25780 Matched : out Boolean)
25782 Dep_Item_Id : Entity_Id;
25783 Ref_Item_Id : Entity_Id;
25786 -- Assume that the two items do not match
25790 -- A null matches null or Empty (special case)
25792 if Nkind (Dep_Item) = N_Null
25793 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
25797 -- Attribute 'Result matches attribute 'Result
25799 elsif Is_Attribute_Result (Dep_Item)
25800 and then Is_Attribute_Result (Ref_Item)
25802 -- Put the entity of the related function on the list of
25803 -- matched items because attribute 'Result does not carry
25804 -- an entity similar to states and constituents.
25806 Record_Item (Spec_Id);
25809 -- Abstract states, current instances of concurrent types,
25810 -- discriminants, formal parameters and objects.
25812 elsif Is_Entity_Name (Dep_Item) then
25814 -- Handle abstract views generated for limited with clauses
25816 Dep_Item_Id := Available_View (Entity_Of (Dep_Item));
25818 if Ekind (Dep_Item_Id) = E_Abstract_State then
25820 -- An abstract state with visible null refinement matches
25821 -- null or Empty (special case).
25823 if Has_Null_Visible_Refinement (Dep_Item_Id)
25824 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
25826 Record_Item (Dep_Item_Id);
25829 -- An abstract state with visible non-null refinement
25830 -- matches one of its constituents, or itself for an
25831 -- abstract state with partial visible refinement.
25833 elsif Has_Non_Null_Visible_Refinement (Dep_Item_Id) then
25834 if Is_Entity_Name (Ref_Item) then
25835 Ref_Item_Id := Entity_Of (Ref_Item);
25837 if Ekind_In (Ref_Item_Id, E_Abstract_State,
25840 and then Present (Encapsulating_State (Ref_Item_Id))
25841 and then Find_Encapsulating_State
25842 (Dep_States, Ref_Item_Id) = Dep_Item_Id
25844 Record_Item (Dep_Item_Id);
25847 elsif not Has_Visible_Refinement (Dep_Item_Id)
25848 and then Ref_Item_Id = Dep_Item_Id
25850 Record_Item (Dep_Item_Id);
25855 -- An abstract state without a visible refinement matches
25858 elsif Is_Entity_Name (Ref_Item)
25859 and then Entity_Of (Ref_Item) = Dep_Item_Id
25861 Record_Item (Dep_Item_Id);
25865 -- A current instance of a concurrent type, discriminant,
25866 -- formal parameter or an object matches itself.
25868 elsif Is_Entity_Name (Ref_Item)
25869 and then Entity_Of (Ref_Item) = Dep_Item_Id
25871 Record_Item (Dep_Item_Id);
25881 procedure Record_Item (Item_Id : Entity_Id) is
25883 if No (Matched_Items) then
25884 Matched_Items := New_Elmt_List;
25887 Append_Unique_Elmt (Item_Id, Matched_Items);
25892 Clause_Matched : Boolean := False;
25893 Dummy : Boolean := False;
25894 Inputs_Match : Boolean;
25895 Next_Ref_Clause : Node_Id;
25896 Outputs_Match : Boolean;
25897 Ref_Clause : Node_Id;
25898 Ref_Input : Node_Id;
25899 Ref_Output : Node_Id;
25901 -- Start of processing for Check_Dependency_Clause
25904 -- Do not perform this check in an instance because it was already
25905 -- performed successfully in the generic template.
25907 if In_Instance then
25911 -- Examine all refinement clauses and compare them against the
25912 -- dependence clause.
25914 Ref_Clause := First (Refinements);
25915 while Present (Ref_Clause) loop
25916 Next_Ref_Clause := Next (Ref_Clause);
25918 -- Obtain the attributes of the current refinement clause
25920 Ref_Input := Expression (Ref_Clause);
25921 Ref_Output := First (Choices (Ref_Clause));
25923 -- The current refinement clause matches the dependence clause
25924 -- when both outputs match and both inputs match. See routine
25925 -- Match_Items for all possible conformance scenarios.
25927 -- Depends Dep_Output => Dep_Input
25931 -- Refined_Depends Ref_Output => Ref_Input
25934 (Dep_Item => Dep_Input,
25935 Ref_Item => Ref_Input,
25936 Matched => Inputs_Match);
25939 (Dep_Item => Dep_Output,
25940 Ref_Item => Ref_Output,
25941 Matched => Outputs_Match);
25943 -- An In_Out state clause may be matched against a refinement with
25944 -- a null input or null output as long as the non-null side of the
25945 -- relation contains a valid constituent of the In_Out_State.
25947 if Is_In_Out_State_Clause then
25949 -- Depends => (State => State)
25950 -- Refined_Depends => (null => Constit) -- OK
25953 and then not Outputs_Match
25954 and then Nkind (Ref_Output) = N_Null
25956 Outputs_Match := True;
25959 -- Depends => (State => State)
25960 -- Refined_Depends => (Constit => null) -- OK
25962 if not Inputs_Match
25963 and then Outputs_Match
25964 and then Nkind (Ref_Input) = N_Null
25966 Inputs_Match := True;
25970 -- The current refinement clause is legally constructed following
25971 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
25972 -- the pool of candidates. The seach continues because a single
25973 -- dependence clause may have multiple matching refinements.
25975 if Inputs_Match and Outputs_Match then
25976 Clause_Matched := True;
25977 Remove (Ref_Clause);
25980 Ref_Clause := Next_Ref_Clause;
25983 -- Depending on the order or composition of refinement clauses, an
25984 -- In_Out state clause may not be directly refinable.
25986 -- Refined_State => (State => (Constit_1, Constit_2))
25987 -- Depends => ((Output, State) => (Input, State))
25988 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
25990 -- Matching normalized clause (State => State) fails because there is
25991 -- no direct refinement capable of satisfying this relation. Another
25992 -- similar case arises when clauses (Constit_1 => Input) and (Output
25993 -- => Constit_2) are matched first, leaving no candidates for clause
25994 -- (State => State). Both scenarios are legal as long as one of the
25995 -- previous clauses mentioned a valid constituent of State.
25997 if not Clause_Matched
25998 and then Is_In_Out_State_Clause
25999 and then Is_Already_Matched (Dep_Input)
26001 Clause_Matched := True;
26004 -- A clause where the input is an abstract state with visible null
26005 -- refinement or a 'Result attribute is implicitly matched when the
26006 -- output has already been matched in a previous clause.
26008 -- Refined_State => (State => null)
26009 -- Depends => (Output => State) -- implicitly OK
26010 -- Refined_Depends => (Output => ...)
26011 -- Depends => (...'Result => State) -- implicitly OK
26012 -- Refined_Depends => (...'Result => ...)
26014 if not Clause_Matched
26015 and then Is_Null_Refined_State (Dep_Input)
26016 and then Is_Already_Matched (Dep_Output)
26018 Clause_Matched := True;
26021 -- A clause where the output is an abstract state with visible null
26022 -- refinement is implicitly matched when the input has already been
26023 -- matched in a previous clause.
26025 -- Refined_State => (State => null)
26026 -- Depends => (State => Input) -- implicitly OK
26027 -- Refined_Depends => (... => Input)
26029 if not Clause_Matched
26030 and then Is_Null_Refined_State (Dep_Output)
26031 and then Is_Already_Matched (Dep_Input)
26033 Clause_Matched := True;
26036 -- At this point either all refinement clauses have been examined or
26037 -- pragma Refined_Depends contains a solitary null. Only an abstract
26038 -- state with null refinement can possibly match these cases.
26040 -- Refined_State => (State => null)
26041 -- Depends => (State => null)
26042 -- Refined_Depends => null -- OK
26044 if not Clause_Matched then
26046 (Dep_Item => Dep_Input,
26048 Matched => Inputs_Match);
26051 (Dep_Item => Dep_Output,
26053 Matched => Outputs_Match);
26055 Clause_Matched := Inputs_Match and Outputs_Match;
26058 -- If the contents of Refined_Depends are legal, then the current
26059 -- dependence clause should be satisfied either by an explicit match
26060 -- or by one of the special cases.
26062 if not Clause_Matched then
26064 (Fix_Msg (Spec_Id, "dependence clause of subprogram & has no "
26065 & "matching refinement in body"), Dep_Clause, Spec_Id);
26067 end Check_Dependency_Clause;
26069 -------------------------
26070 -- Check_Output_States --
26071 -------------------------
26073 procedure Check_Output_States
26074 (Spec_Inputs : Elist_Id;
26075 Spec_Outputs : Elist_Id;
26076 Body_Inputs : Elist_Id;
26077 Body_Outputs : Elist_Id)
26079 procedure Check_Constituent_Usage (State_Id : Entity_Id);
26080 -- Determine whether all constituents of state State_Id with full
26081 -- visible refinement are used as outputs in pragma Refined_Depends.
26082 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
26084 -----------------------------
26085 -- Check_Constituent_Usage --
26086 -----------------------------
26088 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
26089 Constits : constant Elist_Id :=
26090 Partial_Refinement_Constituents (State_Id);
26091 Constit_Elmt : Elmt_Id;
26092 Constit_Id : Entity_Id;
26093 Only_Partial : constant Boolean :=
26094 not Has_Visible_Refinement (State_Id);
26095 Posted : Boolean := False;
26098 if Present (Constits) then
26099 Constit_Elmt := First_Elmt (Constits);
26100 while Present (Constit_Elmt) loop
26101 Constit_Id := Node (Constit_Elmt);
26103 -- Issue an error when a constituent of State_Id is used,
26104 -- and State_Id has only partial visible refinement
26105 -- (SPARK RM 7.2.4(3d)).
26107 if Only_Partial then
26108 if (Present (Body_Inputs)
26109 and then Appears_In (Body_Inputs, Constit_Id))
26111 (Present (Body_Outputs)
26112 and then Appears_In (Body_Outputs, Constit_Id))
26114 Error_Msg_Name_1 := Chars (State_Id);
26116 ("constituent & of state % cannot be used in "
26117 & "dependence refinement", N, Constit_Id);
26118 Error_Msg_Name_1 := Chars (State_Id);
26119 SPARK_Msg_N ("\use state % instead", N);
26122 -- The constituent acts as an input (SPARK RM 7.2.5(3))
26124 elsif Present (Body_Inputs)
26125 and then Appears_In (Body_Inputs, Constit_Id)
26127 Error_Msg_Name_1 := Chars (State_Id);
26129 ("constituent & of state % must act as output in "
26130 & "dependence refinement", N, Constit_Id);
26132 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
26134 elsif No (Body_Outputs)
26135 or else not Appears_In (Body_Outputs, Constit_Id)
26140 ("output state & must be replaced by all its "
26141 & "constituents in dependence refinement",
26146 ("\constituent & is missing in output list",
26150 Next_Elmt (Constit_Elmt);
26153 end Check_Constituent_Usage;
26158 Item_Elmt : Elmt_Id;
26159 Item_Id : Entity_Id;
26161 -- Start of processing for Check_Output_States
26164 -- Do not perform this check in an instance because it was already
26165 -- performed successfully in the generic template.
26167 if In_Instance then
26170 -- Inspect the outputs of pragma Depends looking for a state with a
26171 -- visible refinement.
26173 elsif Present (Spec_Outputs) then
26174 Item_Elmt := First_Elmt (Spec_Outputs);
26175 while Present (Item_Elmt) loop
26176 Item := Node (Item_Elmt);
26178 -- Deal with the mixed nature of the input and output lists
26180 if Nkind (Item) = N_Defining_Identifier then
26183 Item_Id := Available_View (Entity_Of (Item));
26186 if Ekind (Item_Id) = E_Abstract_State then
26188 -- The state acts as an input-output, skip it
26190 if Present (Spec_Inputs)
26191 and then Appears_In (Spec_Inputs, Item_Id)
26195 -- Ensure that all of the constituents are utilized as
26196 -- outputs in pragma Refined_Depends.
26198 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
26199 Check_Constituent_Usage (Item_Id);
26203 Next_Elmt (Item_Elmt);
26206 end Check_Output_States;
26208 --------------------
26209 -- Collect_States --
26210 --------------------
26212 function Collect_States (Clauses : List_Id) return Elist_Id is
26213 procedure Collect_State
26215 States : in out Elist_Id);
26216 -- Add the entity of Item to list States when it denotes to a state
26218 -------------------
26219 -- Collect_State --
26220 -------------------
26222 procedure Collect_State
26224 States : in out Elist_Id)
26229 if Is_Entity_Name (Item) then
26230 Id := Entity_Of (Item);
26232 if Ekind (Id) = E_Abstract_State then
26233 if No (States) then
26234 States := New_Elmt_List;
26237 Append_Unique_Elmt (Id, States);
26247 States : Elist_Id := No_Elist;
26249 -- Start of processing for Collect_States
26252 Clause := First (Clauses);
26253 while Present (Clause) loop
26254 Input := Expression (Clause);
26255 Output := First (Choices (Clause));
26257 Collect_State (Input, States);
26258 Collect_State (Output, States);
26264 end Collect_States;
26266 -----------------------
26267 -- Normalize_Clauses --
26268 -----------------------
26270 procedure Normalize_Clauses (Clauses : List_Id) is
26271 procedure Normalize_Inputs (Clause : Node_Id);
26272 -- Normalize clause Clause by creating multiple clauses for each
26273 -- input item of Clause. It is assumed that Clause has exactly one
26274 -- output. The transformation is as follows:
26276 -- Output => (Input_1, Input_2) -- original
26278 -- Output => Input_1 -- normalizations
26279 -- Output => Input_2
26281 procedure Normalize_Outputs (Clause : Node_Id);
26282 -- Normalize clause Clause by creating multiple clause for each
26283 -- output item of Clause. The transformation is as follows:
26285 -- (Output_1, Output_2) => Input -- original
26287 -- Output_1 => Input -- normalization
26288 -- Output_2 => Input
26290 ----------------------
26291 -- Normalize_Inputs --
26292 ----------------------
26294 procedure Normalize_Inputs (Clause : Node_Id) is
26295 Inputs : constant Node_Id := Expression (Clause);
26296 Loc : constant Source_Ptr := Sloc (Clause);
26297 Output : constant List_Id := Choices (Clause);
26298 Last_Input : Node_Id;
26300 New_Clause : Node_Id;
26301 Next_Input : Node_Id;
26304 -- Normalization is performed only when the original clause has
26305 -- more than one input. Multiple inputs appear as an aggregate.
26307 if Nkind (Inputs) = N_Aggregate then
26308 Last_Input := Last (Expressions (Inputs));
26310 -- Create a new clause for each input
26312 Input := First (Expressions (Inputs));
26313 while Present (Input) loop
26314 Next_Input := Next (Input);
26316 -- Unhook the current input from the original input list
26317 -- because it will be relocated to a new clause.
26321 -- Special processing for the last input. At this point the
26322 -- original aggregate has been stripped down to one element.
26323 -- Replace the aggregate by the element itself.
26325 if Input = Last_Input then
26326 Rewrite (Inputs, Input);
26328 -- Generate a clause of the form:
26333 Make_Component_Association (Loc,
26334 Choices => New_Copy_List_Tree (Output),
26335 Expression => Input);
26337 -- The new clause contains replicated content that has
26338 -- already been analyzed, mark the clause as analyzed.
26340 Set_Analyzed (New_Clause);
26341 Insert_After (Clause, New_Clause);
26344 Input := Next_Input;
26347 end Normalize_Inputs;
26349 -----------------------
26350 -- Normalize_Outputs --
26351 -----------------------
26353 procedure Normalize_Outputs (Clause : Node_Id) is
26354 Inputs : constant Node_Id := Expression (Clause);
26355 Loc : constant Source_Ptr := Sloc (Clause);
26356 Outputs : constant Node_Id := First (Choices (Clause));
26357 Last_Output : Node_Id;
26358 New_Clause : Node_Id;
26359 Next_Output : Node_Id;
26363 -- Multiple outputs appear as an aggregate. Nothing to do when
26364 -- the clause has exactly one output.
26366 if Nkind (Outputs) = N_Aggregate then
26367 Last_Output := Last (Expressions (Outputs));
26369 -- Create a clause for each output. Note that each time a new
26370 -- clause is created, the original output list slowly shrinks
26371 -- until there is one item left.
26373 Output := First (Expressions (Outputs));
26374 while Present (Output) loop
26375 Next_Output := Next (Output);
26377 -- Unhook the output from the original output list as it
26378 -- will be relocated to a new clause.
26382 -- Special processing for the last output. At this point
26383 -- the original aggregate has been stripped down to one
26384 -- element. Replace the aggregate by the element itself.
26386 if Output = Last_Output then
26387 Rewrite (Outputs, Output);
26390 -- Generate a clause of the form:
26391 -- (Output => Inputs)
26394 Make_Component_Association (Loc,
26395 Choices => New_List (Output),
26396 Expression => New_Copy_Tree (Inputs));
26398 -- The new clause contains replicated content that has
26399 -- already been analyzed. There is not need to reanalyze
26402 Set_Analyzed (New_Clause);
26403 Insert_After (Clause, New_Clause);
26406 Output := Next_Output;
26409 end Normalize_Outputs;
26415 -- Start of processing for Normalize_Clauses
26418 Clause := First (Clauses);
26419 while Present (Clause) loop
26420 Normalize_Outputs (Clause);
26424 Clause := First (Clauses);
26425 while Present (Clause) loop
26426 Normalize_Inputs (Clause);
26429 end Normalize_Clauses;
26431 --------------------------
26432 -- Remove_Extra_Clauses --
26433 --------------------------
26435 procedure Remove_Extra_Clauses
26436 (Clauses : List_Id;
26437 Matched_Items : Elist_Id)
26441 Input_Id : Entity_Id;
26442 Next_Clause : Node_Id;
26444 State_Id : Entity_Id;
26447 Clause := First (Clauses);
26448 while Present (Clause) loop
26449 Next_Clause := Next (Clause);
26451 Input := Expression (Clause);
26452 Output := First (Choices (Clause));
26454 -- Recognize a clause of the form
26458 -- where Input is a constituent of a state which was already
26459 -- successfully matched. This clause must be removed because it
26460 -- simply indicates that some of the constituents of the state
26463 -- Refined_State => (State => (Constit_1, Constit_2))
26464 -- Depends => (Output => State)
26465 -- Refined_Depends => ((Output => Constit_1), -- State matched
26466 -- (null => Constit_2)) -- OK
26468 if Nkind (Output) = N_Null and then Is_Entity_Name (Input) then
26470 -- Handle abstract views generated for limited with clauses
26472 Input_Id := Available_View (Entity_Of (Input));
26474 -- The input must be a constituent of a state
26476 if Ekind_In (Input_Id, E_Abstract_State,
26479 and then Present (Encapsulating_State (Input_Id))
26481 State_Id := Encapsulating_State (Input_Id);
26483 -- The state must have a non-null visible refinement and be
26484 -- matched in a previous clause.
26486 if Has_Non_Null_Visible_Refinement (State_Id)
26487 and then Contains (Matched_Items, State_Id)
26493 -- Recognize a clause of the form
26497 -- where Output is an arbitrary item. This clause must be removed
26498 -- because a null input legitimately matches anything.
26500 elsif Nkind (Input) = N_Null then
26504 Clause := Next_Clause;
26506 end Remove_Extra_Clauses;
26508 --------------------------
26509 -- Report_Extra_Clauses --
26510 --------------------------
26512 procedure Report_Extra_Clauses (Clauses : List_Id) is
26516 -- Do not perform this check in an instance because it was already
26517 -- performed successfully in the generic template.
26519 if In_Instance then
26522 elsif Present (Clauses) then
26523 Clause := First (Clauses);
26524 while Present (Clause) loop
26526 ("unmatched or extra clause in dependence refinement",
26532 end Report_Extra_Clauses;
26536 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
26537 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
26538 Errors : constant Nat := Serious_Errors_Detected;
26545 Body_Inputs : Elist_Id := No_Elist;
26546 Body_Outputs : Elist_Id := No_Elist;
26547 -- The inputs and outputs of the subprogram body synthesized from pragma
26548 -- Refined_Depends.
26550 Dependencies : List_Id := No_List;
26552 -- The corresponding Depends pragma along with its clauses
26554 Matched_Items : Elist_Id := No_Elist;
26555 -- A list containing the entities of all successfully matched items
26556 -- found in pragma Depends.
26558 Refinements : List_Id := No_List;
26559 -- The clauses of pragma Refined_Depends
26561 Spec_Id : Entity_Id;
26562 -- The entity of the subprogram subject to pragma Refined_Depends
26564 Spec_Inputs : Elist_Id := No_Elist;
26565 Spec_Outputs : Elist_Id := No_Elist;
26566 -- The inputs and outputs of the subprogram spec synthesized from pragma
26569 States : Elist_Id := No_Elist;
26570 -- A list containing the entities of all states whose constituents
26571 -- appear in pragma Depends.
26573 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
26576 -- Do not analyze the pragma multiple times
26578 if Is_Analyzed_Pragma (N) then
26582 Spec_Id := Unique_Defining_Entity (Body_Decl);
26584 -- Use the anonymous object as the proper spec when Refined_Depends
26585 -- applies to the body of a single task type. The object carries the
26586 -- proper Chars as well as all non-refined versions of pragmas.
26588 if Is_Single_Concurrent_Type (Spec_Id) then
26589 Spec_Id := Anonymous_Object (Spec_Id);
26592 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
26594 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
26595 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
26597 if No (Depends) then
26599 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
26600 & "& lacks aspect or pragma Depends"), N, Spec_Id);
26604 Deps := Expression (Get_Argument (Depends, Spec_Id));
26606 -- A null dependency relation renders the refinement useless because it
26607 -- cannot possibly mention abstract states with visible refinement. Note
26608 -- that the inverse is not true as states may be refined to null
26609 -- (SPARK RM 7.2.5(2)).
26611 if Nkind (Deps) = N_Null then
26613 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
26614 & "depend on abstract state with visible refinement"), N, Spec_Id);
26618 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
26619 -- This ensures that the categorization of all refined dependency items
26620 -- is consistent with their role.
26622 Analyze_Depends_In_Decl_Part (N);
26624 -- Do not match dependencies against refinements if Refined_Depends is
26625 -- illegal to avoid emitting misleading error.
26627 if Serious_Errors_Detected = Errors then
26629 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
26630 -- the inputs and outputs of the subprogram spec and body to verify
26631 -- the use of states with visible refinement and their constituents.
26633 if No (Get_Pragma (Spec_Id, Pragma_Global))
26634 or else No (Get_Pragma (Body_Id, Pragma_Refined_Global))
26636 Collect_Subprogram_Inputs_Outputs
26637 (Subp_Id => Spec_Id,
26638 Synthesize => True,
26639 Subp_Inputs => Spec_Inputs,
26640 Subp_Outputs => Spec_Outputs,
26641 Global_Seen => Dummy);
26643 Collect_Subprogram_Inputs_Outputs
26644 (Subp_Id => Body_Id,
26645 Synthesize => True,
26646 Subp_Inputs => Body_Inputs,
26647 Subp_Outputs => Body_Outputs,
26648 Global_Seen => Dummy);
26650 -- For an output state with a visible refinement, ensure that all
26651 -- constituents appear as outputs in the dependency refinement.
26653 Check_Output_States
26654 (Spec_Inputs => Spec_Inputs,
26655 Spec_Outputs => Spec_Outputs,
26656 Body_Inputs => Body_Inputs,
26657 Body_Outputs => Body_Outputs);
26660 -- Multiple dependency clauses appear as component associations of an
26661 -- aggregate. Note that the clauses are copied because the algorithm
26662 -- modifies them and this should not be visible in Depends.
26664 pragma Assert (Nkind (Deps) = N_Aggregate);
26665 Dependencies := New_Copy_List_Tree (Component_Associations (Deps));
26666 Normalize_Clauses (Dependencies);
26668 -- Gather all states which appear in Depends
26670 States := Collect_States (Dependencies);
26672 Refs := Expression (Get_Argument (N, Spec_Id));
26674 if Nkind (Refs) = N_Null then
26675 Refinements := No_List;
26677 -- Multiple dependency clauses appear as component associations of an
26678 -- aggregate. Note that the clauses are copied because the algorithm
26679 -- modifies them and this should not be visible in Refined_Depends.
26681 else pragma Assert (Nkind (Refs) = N_Aggregate);
26682 Refinements := New_Copy_List_Tree (Component_Associations (Refs));
26683 Normalize_Clauses (Refinements);
26686 -- At this point the clauses of pragmas Depends and Refined_Depends
26687 -- have been normalized into simple dependencies between one output
26688 -- and one input. Examine all clauses of pragma Depends looking for
26689 -- matching clauses in pragma Refined_Depends.
26691 Clause := First (Dependencies);
26692 while Present (Clause) loop
26693 Check_Dependency_Clause
26694 (Spec_Id => Spec_Id,
26695 Dep_Clause => Clause,
26696 Dep_States => States,
26697 Refinements => Refinements,
26698 Matched_Items => Matched_Items);
26703 -- Pragma Refined_Depends may contain multiple clarification clauses
26704 -- which indicate that certain constituents do not influence the data
26705 -- flow in any way. Such clauses must be removed as long as the state
26706 -- has been matched, otherwise they will be incorrectly flagged as
26709 -- Refined_State => (State => (Constit_1, Constit_2))
26710 -- Depends => (Output => State)
26711 -- Refined_Depends => ((Output => Constit_1), -- State matched
26712 -- (null => Constit_2)) -- must be removed
26714 Remove_Extra_Clauses (Refinements, Matched_Items);
26716 if Serious_Errors_Detected = Errors then
26717 Report_Extra_Clauses (Refinements);
26722 Set_Is_Analyzed_Pragma (N);
26723 end Analyze_Refined_Depends_In_Decl_Part;
26725 -----------------------------------------
26726 -- Analyze_Refined_Global_In_Decl_Part --
26727 -----------------------------------------
26729 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is
26731 -- The corresponding Global pragma
26733 Has_In_State : Boolean := False;
26734 Has_In_Out_State : Boolean := False;
26735 Has_Out_State : Boolean := False;
26736 Has_Proof_In_State : Boolean := False;
26737 -- These flags are set when the corresponding Global pragma has a state
26738 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
26741 Has_Null_State : Boolean := False;
26742 -- This flag is set when the corresponding Global pragma has at least
26743 -- one state with a null refinement.
26745 In_Constits : Elist_Id := No_Elist;
26746 In_Out_Constits : Elist_Id := No_Elist;
26747 Out_Constits : Elist_Id := No_Elist;
26748 Proof_In_Constits : Elist_Id := No_Elist;
26749 -- These lists contain the entities of all Input, In_Out, Output and
26750 -- Proof_In constituents that appear in Refined_Global and participate
26751 -- in state refinement.
26753 In_Items : Elist_Id := No_Elist;
26754 In_Out_Items : Elist_Id := No_Elist;
26755 Out_Items : Elist_Id := No_Elist;
26756 Proof_In_Items : Elist_Id := No_Elist;
26757 -- These lists contain the entities of all Input, In_Out, Output and
26758 -- Proof_In items defined in the corresponding Global pragma.
26760 Repeat_Items : Elist_Id := No_Elist;
26761 -- A list of all global items without full visible refinement found
26762 -- in pragma Global. These states should be repeated in the global
26763 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
26764 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
26766 Spec_Id : Entity_Id;
26767 -- The entity of the subprogram subject to pragma Refined_Global
26769 States : Elist_Id := No_Elist;
26770 -- A list of all states with full or partial visible refinement found in
26773 procedure Check_In_Out_States;
26774 -- Determine whether the corresponding Global pragma mentions In_Out
26775 -- states with visible refinement and if so, ensure that one of the
26776 -- following completions apply to the constituents of the state:
26777 -- 1) there is at least one constituent of mode In_Out
26778 -- 2) there is at least one Input and one Output constituent
26779 -- 3) not all constituents are present and one of them is of mode
26781 -- This routine may remove elements from In_Constits, In_Out_Constits,
26782 -- Out_Constits and Proof_In_Constits.
26784 procedure Check_Input_States;
26785 -- Determine whether the corresponding Global pragma mentions Input
26786 -- states with visible refinement and if so, ensure that at least one of
26787 -- its constituents appears as an Input item in Refined_Global.
26788 -- This routine may remove elements from In_Constits, In_Out_Constits,
26789 -- Out_Constits and Proof_In_Constits.
26791 procedure Check_Output_States;
26792 -- Determine whether the corresponding Global pragma mentions Output
26793 -- states with visible refinement and if so, ensure that all of its
26794 -- constituents appear as Output items in Refined_Global.
26795 -- This routine may remove elements from In_Constits, In_Out_Constits,
26796 -- Out_Constits and Proof_In_Constits.
26798 procedure Check_Proof_In_States;
26799 -- Determine whether the corresponding Global pragma mentions Proof_In
26800 -- states with visible refinement and if so, ensure that at least one of
26801 -- its constituents appears as a Proof_In item in Refined_Global.
26802 -- This routine may remove elements from In_Constits, In_Out_Constits,
26803 -- Out_Constits and Proof_In_Constits.
26805 procedure Check_Refined_Global_List
26807 Global_Mode : Name_Id := Name_Input);
26808 -- Verify the legality of a single global list declaration. Global_Mode
26809 -- denotes the current mode in effect.
26811 procedure Collect_Global_Items
26813 Mode : Name_Id := Name_Input);
26814 -- Gather all Input, In_Out, Output and Proof_In items from node List
26815 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
26816 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
26817 -- and Has_Proof_In_State are set when there is at least one abstract
26818 -- state with full or partial visible refinement available in the
26819 -- corresponding mode. Flag Has_Null_State is set when at least state
26820 -- has a null refinement. Mode denotes the current global mode in
26823 function Present_Then_Remove
26825 Item : Entity_Id) return Boolean;
26826 -- Search List for a particular entity Item. If Item has been found,
26827 -- remove it from List. This routine is used to strip lists In_Constits,
26828 -- In_Out_Constits and Out_Constits of valid constituents.
26830 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id);
26831 -- Same as function Present_Then_Remove, but do not report the presence
26832 -- of Item in List.
26834 procedure Report_Extra_Constituents;
26835 -- Emit an error for each constituent found in lists In_Constits,
26836 -- In_Out_Constits and Out_Constits.
26838 procedure Report_Missing_Items;
26839 -- Emit an error for each global item not repeated found in list
26842 -------------------------
26843 -- Check_In_Out_States --
26844 -------------------------
26846 procedure Check_In_Out_States is
26847 procedure Check_Constituent_Usage (State_Id : Entity_Id);
26848 -- Determine whether one of the following coverage scenarios is in
26850 -- 1) there is at least one constituent of mode In_Out or Output
26851 -- 2) there is at least one pair of constituents with modes Input
26852 -- and Output, or Proof_In and Output.
26853 -- 3) there is at least one constituent of mode Output and not all
26854 -- constituents are present.
26855 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
26857 -----------------------------
26858 -- Check_Constituent_Usage --
26859 -----------------------------
26861 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
26862 Constits : constant Elist_Id :=
26863 Partial_Refinement_Constituents (State_Id);
26864 Constit_Elmt : Elmt_Id;
26865 Constit_Id : Entity_Id;
26866 Has_Missing : Boolean := False;
26867 In_Out_Seen : Boolean := False;
26868 Input_Seen : Boolean := False;
26869 Output_Seen : Boolean := False;
26870 Proof_In_Seen : Boolean := False;
26873 -- Process all the constituents of the state and note their modes
26874 -- within the global refinement.
26876 if Present (Constits) then
26877 Constit_Elmt := First_Elmt (Constits);
26878 while Present (Constit_Elmt) loop
26879 Constit_Id := Node (Constit_Elmt);
26881 if Present_Then_Remove (In_Constits, Constit_Id) then
26882 Input_Seen := True;
26884 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then
26885 In_Out_Seen := True;
26887 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
26888 Output_Seen := True;
26890 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
26892 Proof_In_Seen := True;
26895 Has_Missing := True;
26898 Next_Elmt (Constit_Elmt);
26902 -- An In_Out constituent is a valid completion
26904 if In_Out_Seen then
26907 -- A pair of one Input/Proof_In and one Output constituent is a
26908 -- valid completion.
26910 elsif (Input_Seen or Proof_In_Seen) and Output_Seen then
26913 elsif Output_Seen then
26915 -- A single Output constituent is a valid completion only when
26916 -- some of the other constituents are missing.
26918 if Has_Missing then
26921 -- Otherwise all constituents are of mode Output
26925 ("global refinement of state & must include at least one "
26926 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
26930 -- The state lacks a completion. When full refinement is visible,
26931 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
26932 -- refinement is visible, emit an error if the abstract state
26933 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
26934 -- both are utilized, Check_State_And_Constituent_Use. will issue
26937 elsif not Input_Seen
26938 and then not In_Out_Seen
26939 and then not Output_Seen
26940 and then not Proof_In_Seen
26942 if Has_Visible_Refinement (State_Id)
26943 or else Contains (Repeat_Items, State_Id)
26946 ("missing global refinement of state &", N, State_Id);
26949 -- Otherwise the state has a malformed completion where at least
26950 -- one of the constituents has a different mode.
26954 ("global refinement of state & redefines the mode of its "
26955 & "constituents", N, State_Id);
26957 end Check_Constituent_Usage;
26961 Item_Elmt : Elmt_Id;
26962 Item_Id : Entity_Id;
26964 -- Start of processing for Check_In_Out_States
26967 -- Do not perform this check in an instance because it was already
26968 -- performed successfully in the generic template.
26970 if In_Instance then
26973 -- Inspect the In_Out items of the corresponding Global pragma
26974 -- looking for a state with a visible refinement.
26976 elsif Has_In_Out_State and then Present (In_Out_Items) then
26977 Item_Elmt := First_Elmt (In_Out_Items);
26978 while Present (Item_Elmt) loop
26979 Item_Id := Node (Item_Elmt);
26981 -- Ensure that one of the three coverage variants is satisfied
26983 if Ekind (Item_Id) = E_Abstract_State
26984 and then Has_Non_Null_Visible_Refinement (Item_Id)
26986 Check_Constituent_Usage (Item_Id);
26989 Next_Elmt (Item_Elmt);
26992 end Check_In_Out_States;
26994 ------------------------
26995 -- Check_Input_States --
26996 ------------------------
26998 procedure Check_Input_States is
26999 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27000 -- Determine whether at least one constituent of state State_Id with
27001 -- full or partial visible refinement is used and has mode Input.
27002 -- Ensure that the remaining constituents do not have In_Out or
27003 -- Output modes. Emit an error if this is not the case
27004 -- (SPARK RM 7.2.4(5)).
27006 -----------------------------
27007 -- Check_Constituent_Usage --
27008 -----------------------------
27010 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27011 Constits : constant Elist_Id :=
27012 Partial_Refinement_Constituents (State_Id);
27013 Constit_Elmt : Elmt_Id;
27014 Constit_Id : Entity_Id;
27015 In_Seen : Boolean := False;
27018 if Present (Constits) then
27019 Constit_Elmt := First_Elmt (Constits);
27020 while Present (Constit_Elmt) loop
27021 Constit_Id := Node (Constit_Elmt);
27023 -- At least one of the constituents appears as an Input
27025 if Present_Then_Remove (In_Constits, Constit_Id) then
27028 -- A Proof_In constituent can refine an Input state as long
27029 -- as there is at least one Input constituent present.
27031 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
27035 -- The constituent appears in the global refinement, but has
27036 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
27038 elsif Present_Then_Remove (In_Out_Constits, Constit_Id)
27039 or else Present_Then_Remove (Out_Constits, Constit_Id)
27041 Error_Msg_Name_1 := Chars (State_Id);
27043 ("constituent & of state % must have mode `Input` in "
27044 & "global refinement", N, Constit_Id);
27047 Next_Elmt (Constit_Elmt);
27051 -- Not one of the constituents appeared as Input. Always emit an
27052 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
27053 -- When only partial refinement is visible, emit an error if the
27054 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27055 -- the case where both are utilized, an error will be issued in
27056 -- Check_State_And_Constituent_Use.
27059 and then (Has_Visible_Refinement (State_Id)
27060 or else Contains (Repeat_Items, State_Id))
27063 ("global refinement of state & must include at least one "
27064 & "constituent of mode `Input`", N, State_Id);
27066 end Check_Constituent_Usage;
27070 Item_Elmt : Elmt_Id;
27071 Item_Id : Entity_Id;
27073 -- Start of processing for Check_Input_States
27076 -- Do not perform this check in an instance because it was already
27077 -- performed successfully in the generic template.
27079 if In_Instance then
27082 -- Inspect the Input items of the corresponding Global pragma looking
27083 -- for a state with a visible refinement.
27085 elsif Has_In_State and then Present (In_Items) then
27086 Item_Elmt := First_Elmt (In_Items);
27087 while Present (Item_Elmt) loop
27088 Item_Id := Node (Item_Elmt);
27090 -- When full refinement is visible, ensure that at least one of
27091 -- the constituents is utilized and is of mode Input. When only
27092 -- partial refinement is visible, ensure that either one of
27093 -- the constituents is utilized and is of mode Input, or the
27094 -- abstract state is repeated and no constituent is utilized.
27096 if Ekind (Item_Id) = E_Abstract_State
27097 and then Has_Non_Null_Visible_Refinement (Item_Id)
27099 Check_Constituent_Usage (Item_Id);
27102 Next_Elmt (Item_Elmt);
27105 end Check_Input_States;
27107 -------------------------
27108 -- Check_Output_States --
27109 -------------------------
27111 procedure Check_Output_States is
27112 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27113 -- Determine whether all constituents of state State_Id with full
27114 -- visible refinement are used and have mode Output. Emit an error
27115 -- if this is not the case (SPARK RM 7.2.4(5)).
27117 -----------------------------
27118 -- Check_Constituent_Usage --
27119 -----------------------------
27121 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27122 Constits : constant Elist_Id :=
27123 Partial_Refinement_Constituents (State_Id);
27124 Only_Partial : constant Boolean :=
27125 not Has_Visible_Refinement (State_Id);
27126 Constit_Elmt : Elmt_Id;
27127 Constit_Id : Entity_Id;
27128 Posted : Boolean := False;
27131 if Present (Constits) then
27132 Constit_Elmt := First_Elmt (Constits);
27133 while Present (Constit_Elmt) loop
27134 Constit_Id := Node (Constit_Elmt);
27136 -- Issue an error when a constituent of State_Id is utilized
27137 -- and State_Id has only partial visible refinement
27138 -- (SPARK RM 7.2.4(3d)).
27140 if Only_Partial then
27141 if Present_Then_Remove (Out_Constits, Constit_Id)
27142 or else Present_Then_Remove (In_Constits, Constit_Id)
27144 Present_Then_Remove (In_Out_Constits, Constit_Id)
27146 Present_Then_Remove (Proof_In_Constits, Constit_Id)
27148 Error_Msg_Name_1 := Chars (State_Id);
27150 ("constituent & of state % cannot be used in global "
27151 & "refinement", N, Constit_Id);
27152 Error_Msg_Name_1 := Chars (State_Id);
27153 SPARK_Msg_N ("\use state % instead", N);
27156 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
27159 -- The constituent appears in the global refinement, but has
27160 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
27162 elsif Present_Then_Remove (In_Constits, Constit_Id)
27163 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
27164 or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
27166 Error_Msg_Name_1 := Chars (State_Id);
27168 ("constituent & of state % must have mode `Output` in "
27169 & "global refinement", N, Constit_Id);
27171 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
27177 ("`Output` state & must be replaced by all its "
27178 & "constituents in global refinement", N, State_Id);
27182 ("\constituent & is missing in output list",
27186 Next_Elmt (Constit_Elmt);
27189 end Check_Constituent_Usage;
27193 Item_Elmt : Elmt_Id;
27194 Item_Id : Entity_Id;
27196 -- Start of processing for Check_Output_States
27199 -- Do not perform this check in an instance because it was already
27200 -- performed successfully in the generic template.
27202 if In_Instance then
27205 -- Inspect the Output items of the corresponding Global pragma
27206 -- looking for a state with a visible refinement.
27208 elsif Has_Out_State and then Present (Out_Items) then
27209 Item_Elmt := First_Elmt (Out_Items);
27210 while Present (Item_Elmt) loop
27211 Item_Id := Node (Item_Elmt);
27213 -- When full refinement is visible, ensure that all of the
27214 -- constituents are utilized and they have mode Output. When
27215 -- only partial refinement is visible, ensure that no
27216 -- constituent is utilized.
27218 if Ekind (Item_Id) = E_Abstract_State
27219 and then Has_Non_Null_Visible_Refinement (Item_Id)
27221 Check_Constituent_Usage (Item_Id);
27224 Next_Elmt (Item_Elmt);
27227 end Check_Output_States;
27229 ---------------------------
27230 -- Check_Proof_In_States --
27231 ---------------------------
27233 procedure Check_Proof_In_States is
27234 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27235 -- Determine whether at least one constituent of state State_Id with
27236 -- full or partial visible refinement is used and has mode Proof_In.
27237 -- Ensure that the remaining constituents do not have Input, In_Out,
27238 -- or Output modes. Emit an error if this is not the case
27239 -- (SPARK RM 7.2.4(5)).
27241 -----------------------------
27242 -- Check_Constituent_Usage --
27243 -----------------------------
27245 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27246 Constits : constant Elist_Id :=
27247 Partial_Refinement_Constituents (State_Id);
27248 Constit_Elmt : Elmt_Id;
27249 Constit_Id : Entity_Id;
27250 Proof_In_Seen : Boolean := False;
27253 if Present (Constits) then
27254 Constit_Elmt := First_Elmt (Constits);
27255 while Present (Constit_Elmt) loop
27256 Constit_Id := Node (Constit_Elmt);
27258 -- At least one of the constituents appears as Proof_In
27260 if Present_Then_Remove (Proof_In_Constits, Constit_Id) then
27261 Proof_In_Seen := True;
27263 -- The constituent appears in the global refinement, but has
27264 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
27266 elsif Present_Then_Remove (In_Constits, Constit_Id)
27267 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
27268 or else Present_Then_Remove (Out_Constits, Constit_Id)
27270 Error_Msg_Name_1 := Chars (State_Id);
27272 ("constituent & of state % must have mode `Proof_In` "
27273 & "in global refinement", N, Constit_Id);
27276 Next_Elmt (Constit_Elmt);
27280 -- Not one of the constituents appeared as Proof_In. Always emit
27281 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
27282 -- When only partial refinement is visible, emit an error if the
27283 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27284 -- the case where both are utilized, an error will be issued by
27285 -- Check_State_And_Constituent_Use.
27287 if not Proof_In_Seen
27288 and then (Has_Visible_Refinement (State_Id)
27289 or else Contains (Repeat_Items, State_Id))
27292 ("global refinement of state & must include at least one "
27293 & "constituent of mode `Proof_In`", N, State_Id);
27295 end Check_Constituent_Usage;
27299 Item_Elmt : Elmt_Id;
27300 Item_Id : Entity_Id;
27302 -- Start of processing for Check_Proof_In_States
27305 -- Do not perform this check in an instance because it was already
27306 -- performed successfully in the generic template.
27308 if In_Instance then
27311 -- Inspect the Proof_In items of the corresponding Global pragma
27312 -- looking for a state with a visible refinement.
27314 elsif Has_Proof_In_State and then Present (Proof_In_Items) then
27315 Item_Elmt := First_Elmt (Proof_In_Items);
27316 while Present (Item_Elmt) loop
27317 Item_Id := Node (Item_Elmt);
27319 -- Ensure that at least one of the constituents is utilized
27320 -- and is of mode Proof_In. When only partial refinement is
27321 -- visible, ensure that either one of the constituents is
27322 -- utilized and is of mode Proof_In, or the abstract state
27323 -- is repeated and no constituent is utilized.
27325 if Ekind (Item_Id) = E_Abstract_State
27326 and then Has_Non_Null_Visible_Refinement (Item_Id)
27328 Check_Constituent_Usage (Item_Id);
27331 Next_Elmt (Item_Elmt);
27334 end Check_Proof_In_States;
27336 -------------------------------
27337 -- Check_Refined_Global_List --
27338 -------------------------------
27340 procedure Check_Refined_Global_List
27342 Global_Mode : Name_Id := Name_Input)
27344 procedure Check_Refined_Global_Item
27346 Global_Mode : Name_Id);
27347 -- Verify the legality of a single global item declaration. Parameter
27348 -- Global_Mode denotes the current mode in effect.
27350 -------------------------------
27351 -- Check_Refined_Global_Item --
27352 -------------------------------
27354 procedure Check_Refined_Global_Item
27356 Global_Mode : Name_Id)
27358 Item_Id : constant Entity_Id := Entity_Of (Item);
27360 procedure Inconsistent_Mode_Error (Expect : Name_Id);
27361 -- Issue a common error message for all mode mismatches. Expect
27362 -- denotes the expected mode.
27364 -----------------------------
27365 -- Inconsistent_Mode_Error --
27366 -----------------------------
27368 procedure Inconsistent_Mode_Error (Expect : Name_Id) is
27371 ("global item & has inconsistent modes", Item, Item_Id);
27373 Error_Msg_Name_1 := Global_Mode;
27374 Error_Msg_Name_2 := Expect;
27375 SPARK_Msg_N ("\expected mode %, found mode %", Item);
27376 end Inconsistent_Mode_Error;
27380 Enc_State : Entity_Id := Empty;
27381 -- Encapsulating state for constituent, Empty otherwise
27383 -- Start of processing for Check_Refined_Global_Item
27386 if Ekind_In (Item_Id, E_Abstract_State,
27390 Enc_State := Find_Encapsulating_State (States, Item_Id);
27393 -- When the state or object acts as a constituent of another
27394 -- state with a visible refinement, collect it for the state
27395 -- completeness checks performed later on. Note that the item
27396 -- acts as a constituent only when the encapsulating state is
27397 -- present in pragma Global.
27399 if Present (Enc_State)
27400 and then (Has_Visible_Refinement (Enc_State)
27401 or else Has_Partial_Visible_Refinement (Enc_State))
27402 and then Contains (States, Enc_State)
27404 -- If the state has only partial visible refinement, remove it
27405 -- from the list of items that should be repeated from pragma
27408 if not Has_Visible_Refinement (Enc_State) then
27409 Present_Then_Remove (Repeat_Items, Enc_State);
27412 if Global_Mode = Name_Input then
27413 Append_New_Elmt (Item_Id, In_Constits);
27415 elsif Global_Mode = Name_In_Out then
27416 Append_New_Elmt (Item_Id, In_Out_Constits);
27418 elsif Global_Mode = Name_Output then
27419 Append_New_Elmt (Item_Id, Out_Constits);
27421 elsif Global_Mode = Name_Proof_In then
27422 Append_New_Elmt (Item_Id, Proof_In_Constits);
27425 -- When not a constituent, ensure that both occurrences of the
27426 -- item in pragmas Global and Refined_Global match. Also remove
27427 -- it when present from the list of items that should be repeated
27428 -- from pragma Global.
27431 Present_Then_Remove (Repeat_Items, Item_Id);
27433 if Contains (In_Items, Item_Id) then
27434 if Global_Mode /= Name_Input then
27435 Inconsistent_Mode_Error (Name_Input);
27438 elsif Contains (In_Out_Items, Item_Id) then
27439 if Global_Mode /= Name_In_Out then
27440 Inconsistent_Mode_Error (Name_In_Out);
27443 elsif Contains (Out_Items, Item_Id) then
27444 if Global_Mode /= Name_Output then
27445 Inconsistent_Mode_Error (Name_Output);
27448 elsif Contains (Proof_In_Items, Item_Id) then
27451 -- The item does not appear in the corresponding Global pragma,
27452 -- it must be an extra (SPARK RM 7.2.4(3)).
27455 pragma Assert (Present (Global));
27456 Error_Msg_Sloc := Sloc (Global);
27458 ("extra global item & does not refine or repeat any "
27459 & "global item #", Item, Item_Id);
27462 end Check_Refined_Global_Item;
27468 -- Start of processing for Check_Refined_Global_List
27471 -- Do not perform this check in an instance because it was already
27472 -- performed successfully in the generic template.
27474 if In_Instance then
27477 elsif Nkind (List) = N_Null then
27480 -- Single global item declaration
27482 elsif Nkind_In (List, N_Expanded_Name,
27484 N_Selected_Component)
27486 Check_Refined_Global_Item (List, Global_Mode);
27488 -- Simple global list or moded global list declaration
27490 elsif Nkind (List) = N_Aggregate then
27492 -- The declaration of a simple global list appear as a collection
27495 if Present (Expressions (List)) then
27496 Item := First (Expressions (List));
27497 while Present (Item) loop
27498 Check_Refined_Global_Item (Item, Global_Mode);
27502 -- The declaration of a moded global list appears as a collection
27503 -- of component associations where individual choices denote
27506 elsif Present (Component_Associations (List)) then
27507 Item := First (Component_Associations (List));
27508 while Present (Item) loop
27509 Check_Refined_Global_List
27510 (List => Expression (Item),
27511 Global_Mode => Chars (First (Choices (Item))));
27519 raise Program_Error;
27525 raise Program_Error;
27527 end Check_Refined_Global_List;
27529 --------------------------
27530 -- Collect_Global_Items --
27531 --------------------------
27533 procedure Collect_Global_Items
27535 Mode : Name_Id := Name_Input)
27537 procedure Collect_Global_Item
27539 Item_Mode : Name_Id);
27540 -- Add a single item to the appropriate list. Item_Mode denotes the
27541 -- current mode in effect.
27543 -------------------------
27544 -- Collect_Global_Item --
27545 -------------------------
27547 procedure Collect_Global_Item
27549 Item_Mode : Name_Id)
27551 Item_Id : constant Entity_Id := Available_View (Entity_Of (Item));
27552 -- The above handles abstract views of variables and states built
27553 -- for limited with clauses.
27556 -- Signal that the global list contains at least one abstract
27557 -- state with a visible refinement. Note that the refinement may
27558 -- be null in which case there are no constituents.
27560 if Ekind (Item_Id) = E_Abstract_State then
27561 if Has_Null_Visible_Refinement (Item_Id) then
27562 Has_Null_State := True;
27564 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
27565 Append_New_Elmt (Item_Id, States);
27567 if Item_Mode = Name_Input then
27568 Has_In_State := True;
27569 elsif Item_Mode = Name_In_Out then
27570 Has_In_Out_State := True;
27571 elsif Item_Mode = Name_Output then
27572 Has_Out_State := True;
27573 elsif Item_Mode = Name_Proof_In then
27574 Has_Proof_In_State := True;
27579 -- Record global items without full visible refinement found in
27580 -- pragma Global which should be repeated in the global refinement
27581 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
27583 if Ekind (Item_Id) /= E_Abstract_State
27584 or else not Has_Visible_Refinement (Item_Id)
27586 Append_New_Elmt (Item_Id, Repeat_Items);
27589 -- Add the item to the proper list
27591 if Item_Mode = Name_Input then
27592 Append_New_Elmt (Item_Id, In_Items);
27593 elsif Item_Mode = Name_In_Out then
27594 Append_New_Elmt (Item_Id, In_Out_Items);
27595 elsif Item_Mode = Name_Output then
27596 Append_New_Elmt (Item_Id, Out_Items);
27597 elsif Item_Mode = Name_Proof_In then
27598 Append_New_Elmt (Item_Id, Proof_In_Items);
27600 end Collect_Global_Item;
27606 -- Start of processing for Collect_Global_Items
27609 if Nkind (List) = N_Null then
27612 -- Single global item declaration
27614 elsif Nkind_In (List, N_Expanded_Name,
27616 N_Selected_Component)
27618 Collect_Global_Item (List, Mode);
27620 -- Single global list or moded global list declaration
27622 elsif Nkind (List) = N_Aggregate then
27624 -- The declaration of a simple global list appear as a collection
27627 if Present (Expressions (List)) then
27628 Item := First (Expressions (List));
27629 while Present (Item) loop
27630 Collect_Global_Item (Item, Mode);
27634 -- The declaration of a moded global list appears as a collection
27635 -- of component associations where individual choices denote mode.
27637 elsif Present (Component_Associations (List)) then
27638 Item := First (Component_Associations (List));
27639 while Present (Item) loop
27640 Collect_Global_Items
27641 (List => Expression (Item),
27642 Mode => Chars (First (Choices (Item))));
27650 raise Program_Error;
27653 -- To accommodate partial decoration of disabled SPARK features, this
27654 -- routine may be called with illegal input. If this is the case, do
27655 -- not raise Program_Error.
27660 end Collect_Global_Items;
27662 -------------------------
27663 -- Present_Then_Remove --
27664 -------------------------
27666 function Present_Then_Remove
27668 Item : Entity_Id) return Boolean
27673 if Present (List) then
27674 Elmt := First_Elmt (List);
27675 while Present (Elmt) loop
27676 if Node (Elmt) = Item then
27677 Remove_Elmt (List, Elmt);
27686 end Present_Then_Remove;
27688 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id) is
27691 Ignore := Present_Then_Remove (List, Item);
27692 end Present_Then_Remove;
27694 -------------------------------
27695 -- Report_Extra_Constituents --
27696 -------------------------------
27698 procedure Report_Extra_Constituents is
27699 procedure Report_Extra_Constituents_In_List (List : Elist_Id);
27700 -- Emit an error for every element of List
27702 ---------------------------------------
27703 -- Report_Extra_Constituents_In_List --
27704 ---------------------------------------
27706 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is
27707 Constit_Elmt : Elmt_Id;
27710 if Present (List) then
27711 Constit_Elmt := First_Elmt (List);
27712 while Present (Constit_Elmt) loop
27713 SPARK_Msg_NE ("extra constituent &", N, Node (Constit_Elmt));
27714 Next_Elmt (Constit_Elmt);
27717 end Report_Extra_Constituents_In_List;
27719 -- Start of processing for Report_Extra_Constituents
27722 -- Do not perform this check in an instance because it was already
27723 -- performed successfully in the generic template.
27725 if In_Instance then
27729 Report_Extra_Constituents_In_List (In_Constits);
27730 Report_Extra_Constituents_In_List (In_Out_Constits);
27731 Report_Extra_Constituents_In_List (Out_Constits);
27732 Report_Extra_Constituents_In_List (Proof_In_Constits);
27734 end Report_Extra_Constituents;
27736 --------------------------
27737 -- Report_Missing_Items --
27738 --------------------------
27740 procedure Report_Missing_Items is
27741 Item_Elmt : Elmt_Id;
27742 Item_Id : Entity_Id;
27745 -- Do not perform this check in an instance because it was already
27746 -- performed successfully in the generic template.
27748 if In_Instance then
27752 if Present (Repeat_Items) then
27753 Item_Elmt := First_Elmt (Repeat_Items);
27754 while Present (Item_Elmt) loop
27755 Item_Id := Node (Item_Elmt);
27756 SPARK_Msg_NE ("missing global item &", N, Item_Id);
27757 Next_Elmt (Item_Elmt);
27761 end Report_Missing_Items;
27765 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
27766 Errors : constant Nat := Serious_Errors_Detected;
27768 No_Constit : Boolean;
27770 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
27773 -- Do not analyze the pragma multiple times
27775 if Is_Analyzed_Pragma (N) then
27779 Spec_Id := Unique_Defining_Entity (Body_Decl);
27781 -- Use the anonymous object as the proper spec when Refined_Global
27782 -- applies to the body of a single task type. The object carries the
27783 -- proper Chars as well as all non-refined versions of pragmas.
27785 if Is_Single_Concurrent_Type (Spec_Id) then
27786 Spec_Id := Anonymous_Object (Spec_Id);
27789 Global := Get_Pragma (Spec_Id, Pragma_Global);
27790 Items := Expression (Get_Argument (N, Spec_Id));
27792 -- The subprogram declaration lacks pragma Global. This renders
27793 -- Refined_Global useless as there is nothing to refine.
27795 if No (Global) then
27797 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
27798 & "& lacks aspect or pragma Global"), N, Spec_Id);
27802 -- Extract all relevant items from the corresponding Global pragma
27804 Collect_Global_Items (Expression (Get_Argument (Global, Spec_Id)));
27806 -- Package and subprogram bodies are instantiated individually in
27807 -- a separate compiler pass. Due to this mode of instantiation, the
27808 -- refinement of a state may no longer be visible when a subprogram
27809 -- body contract is instantiated. Since the generic template is legal,
27810 -- do not perform this check in the instance to circumvent this oddity.
27812 if In_Instance then
27815 -- Non-instance case
27818 -- The corresponding Global pragma must mention at least one
27819 -- state with a visible refinement at the point Refined_Global
27820 -- is processed. States with null refinements need Refined_Global
27821 -- pragma (SPARK RM 7.2.4(2)).
27823 if not Has_In_State
27824 and then not Has_In_Out_State
27825 and then not Has_Out_State
27826 and then not Has_Proof_In_State
27827 and then not Has_Null_State
27830 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
27831 & "depend on abstract state with visible refinement"),
27835 -- The global refinement of inputs and outputs cannot be null when
27836 -- the corresponding Global pragma contains at least one item except
27837 -- in the case where we have states with null refinements.
27839 elsif Nkind (Items) = N_Null
27841 (Present (In_Items)
27842 or else Present (In_Out_Items)
27843 or else Present (Out_Items)
27844 or else Present (Proof_In_Items))
27845 and then not Has_Null_State
27848 (Fix_Msg (Spec_Id, "refinement cannot be null, subprogram & has "
27849 & "global items"), N, Spec_Id);
27854 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
27855 -- This ensures that the categorization of all refined global items is
27856 -- consistent with their role.
27858 Analyze_Global_In_Decl_Part (N);
27860 -- Perform all refinement checks with respect to completeness and mode
27863 if Serious_Errors_Detected = Errors then
27864 Check_Refined_Global_List (Items);
27867 -- Store the information that no constituent is used in the global
27868 -- refinement, prior to calling checking procedures which remove items
27869 -- from the list of constituents.
27873 and then No (In_Out_Constits)
27874 and then No (Out_Constits)
27875 and then No (Proof_In_Constits);
27877 -- For Input states with visible refinement, at least one constituent
27878 -- must be used as an Input in the global refinement.
27880 if Serious_Errors_Detected = Errors then
27881 Check_Input_States;
27884 -- Verify all possible completion variants for In_Out states with
27885 -- visible refinement.
27887 if Serious_Errors_Detected = Errors then
27888 Check_In_Out_States;
27891 -- For Output states with visible refinement, all constituents must be
27892 -- used as Outputs in the global refinement.
27894 if Serious_Errors_Detected = Errors then
27895 Check_Output_States;
27898 -- For Proof_In states with visible refinement, at least one constituent
27899 -- must be used as Proof_In in the global refinement.
27901 if Serious_Errors_Detected = Errors then
27902 Check_Proof_In_States;
27905 -- Emit errors for all constituents that belong to other states with
27906 -- visible refinement that do not appear in Global.
27908 if Serious_Errors_Detected = Errors then
27909 Report_Extra_Constituents;
27912 -- Emit errors for all items in Global that are not repeated in the
27913 -- global refinement and for which there is no full visible refinement
27914 -- and, in the case of states with partial visible refinement, no
27915 -- constituent is mentioned in the global refinement.
27917 if Serious_Errors_Detected = Errors then
27918 Report_Missing_Items;
27921 -- Emit an error if no constituent is used in the global refinement
27922 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
27923 -- one may be issued by the checking procedures. Do not perform this
27924 -- check in an instance because it was already performed successfully
27925 -- in the generic template.
27927 if Serious_Errors_Detected = Errors
27928 and then not In_Instance
27929 and then not Has_Null_State
27930 and then No_Constit
27932 SPARK_Msg_N ("missing refinement", N);
27936 Set_Is_Analyzed_Pragma (N);
27937 end Analyze_Refined_Global_In_Decl_Part;
27939 ----------------------------------------
27940 -- Analyze_Refined_State_In_Decl_Part --
27941 ----------------------------------------
27943 procedure Analyze_Refined_State_In_Decl_Part
27945 Freeze_Id : Entity_Id := Empty)
27947 Body_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
27948 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
27949 Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl);
27951 Available_States : Elist_Id := No_Elist;
27952 -- A list of all abstract states defined in the package declaration that
27953 -- are available for refinement. The list is used to report unrefined
27956 Body_States : Elist_Id := No_Elist;
27957 -- A list of all hidden states that appear in the body of the related
27958 -- package. The list is used to report unused hidden states.
27960 Constituents_Seen : Elist_Id := No_Elist;
27961 -- A list that contains all constituents processed so far. The list is
27962 -- used to detect multiple uses of the same constituent.
27964 Freeze_Posted : Boolean := False;
27965 -- A flag that controls the output of a freezing-related error (see use
27968 Refined_States_Seen : Elist_Id := No_Elist;
27969 -- A list that contains all refined states processed so far. The list is
27970 -- used to detect duplicate refinements.
27972 procedure Analyze_Refinement_Clause (Clause : Node_Id);
27973 -- Perform full analysis of a single refinement clause
27975 procedure Report_Unrefined_States (States : Elist_Id);
27976 -- Emit errors for all unrefined abstract states found in list States
27978 -------------------------------
27979 -- Analyze_Refinement_Clause --
27980 -------------------------------
27982 procedure Analyze_Refinement_Clause (Clause : Node_Id) is
27983 AR_Constit : Entity_Id := Empty;
27984 AW_Constit : Entity_Id := Empty;
27985 ER_Constit : Entity_Id := Empty;
27986 EW_Constit : Entity_Id := Empty;
27987 -- The entities of external constituents that contain one of the
27988 -- following enabled properties: Async_Readers, Async_Writers,
27989 -- Effective_Reads and Effective_Writes.
27991 External_Constit_Seen : Boolean := False;
27992 -- Flag used to mark when at least one external constituent is part
27993 -- of the state refinement.
27995 Non_Null_Seen : Boolean := False;
27996 Null_Seen : Boolean := False;
27997 -- Flags used to detect multiple uses of null in a single clause or a
27998 -- mixture of null and non-null constituents.
28000 Part_Of_Constits : Elist_Id := No_Elist;
28001 -- A list of all candidate constituents subject to indicator Part_Of
28002 -- where the encapsulating state is the current state.
28005 State_Id : Entity_Id;
28006 -- The current state being refined
28008 procedure Analyze_Constituent (Constit : Node_Id);
28009 -- Perform full analysis of a single constituent
28011 procedure Check_External_Property
28012 (Prop_Nam : Name_Id;
28014 Constit : Entity_Id);
28015 -- Determine whether a property denoted by name Prop_Nam is present
28016 -- in the refined state. Emit an error if this is not the case. Flag
28017 -- Enabled should be set when the property applies to the refined
28018 -- state. Constit denotes the constituent (if any) which introduces
28019 -- the property in the refinement.
28021 procedure Match_State;
28022 -- Determine whether the state being refined appears in list
28023 -- Available_States. Emit an error when attempting to re-refine the
28024 -- state or when the state is not defined in the package declaration,
28025 -- otherwise remove the state from Available_States.
28027 procedure Report_Unused_Constituents (Constits : Elist_Id);
28028 -- Emit errors for all unused Part_Of constituents in list Constits
28030 -------------------------
28031 -- Analyze_Constituent --
28032 -------------------------
28034 procedure Analyze_Constituent (Constit : Node_Id) is
28035 procedure Match_Constituent (Constit_Id : Entity_Id);
28036 -- Determine whether constituent Constit denoted by its entity
28037 -- Constit_Id appears in Body_States. Emit an error when the
28038 -- constituent is not a valid hidden state of the related package
28039 -- or when it is used more than once. Otherwise remove the
28040 -- constituent from Body_States.
28042 -----------------------
28043 -- Match_Constituent --
28044 -----------------------
28046 procedure Match_Constituent (Constit_Id : Entity_Id) is
28047 procedure Collect_Constituent;
28048 -- Verify the legality of constituent Constit_Id and add it to
28049 -- the refinements of State_Id.
28051 -------------------------
28052 -- Collect_Constituent --
28053 -------------------------
28055 procedure Collect_Constituent is
28056 Constits : Elist_Id;
28059 -- The Ghost policy in effect at the point of abstract state
28060 -- declaration and constituent must match (SPARK RM 6.9(15))
28062 Check_Ghost_Refinement
28063 (State, State_Id, Constit, Constit_Id);
28065 -- A synchronized state must be refined by a synchronized
28066 -- object or another synchronized state (SPARK RM 9.6).
28068 if Is_Synchronized_State (State_Id)
28069 and then not Is_Synchronized_Object (Constit_Id)
28070 and then not Is_Synchronized_State (Constit_Id)
28073 ("constituent of synchronized state & must be "
28074 & "synchronized", Constit, State_Id);
28077 -- Add the constituent to the list of processed items to aid
28078 -- with the detection of duplicates.
28080 Append_New_Elmt (Constit_Id, Constituents_Seen);
28082 -- Collect the constituent in the list of refinement items
28083 -- and establish a relation between the refined state and
28086 Constits := Refinement_Constituents (State_Id);
28088 if No (Constits) then
28089 Constits := New_Elmt_List;
28090 Set_Refinement_Constituents (State_Id, Constits);
28093 Append_Elmt (Constit_Id, Constits);
28094 Set_Encapsulating_State (Constit_Id, State_Id);
28096 -- The state has at least one legal constituent, mark the
28097 -- start of the refinement region. The region ends when the
28098 -- body declarations end (see routine Analyze_Declarations).
28100 Set_Has_Visible_Refinement (State_Id);
28102 -- When the constituent is external, save its relevant
28103 -- property for further checks.
28105 if Async_Readers_Enabled (Constit_Id) then
28106 AR_Constit := Constit_Id;
28107 External_Constit_Seen := True;
28110 if Async_Writers_Enabled (Constit_Id) then
28111 AW_Constit := Constit_Id;
28112 External_Constit_Seen := True;
28115 if Effective_Reads_Enabled (Constit_Id) then
28116 ER_Constit := Constit_Id;
28117 External_Constit_Seen := True;
28120 if Effective_Writes_Enabled (Constit_Id) then
28121 EW_Constit := Constit_Id;
28122 External_Constit_Seen := True;
28124 end Collect_Constituent;
28128 State_Elmt : Elmt_Id;
28130 -- Start of processing for Match_Constituent
28133 -- Detect a duplicate use of a constituent
28135 if Contains (Constituents_Seen, Constit_Id) then
28137 ("duplicate use of constituent &", Constit, Constit_Id);
28141 -- The constituent is subject to a Part_Of indicator
28143 if Present (Encapsulating_State (Constit_Id)) then
28144 if Encapsulating_State (Constit_Id) = State_Id then
28145 Remove (Part_Of_Constits, Constit_Id);
28146 Collect_Constituent;
28148 -- The constituent is part of another state and is used
28149 -- incorrectly in the refinement of the current state.
28152 Error_Msg_Name_1 := Chars (State_Id);
28154 ("& cannot act as constituent of state %",
28155 Constit, Constit_Id);
28157 ("\Part_Of indicator specifies encapsulator &",
28158 Constit, Encapsulating_State (Constit_Id));
28161 -- The only other source of legal constituents is the body
28162 -- state space of the related package.
28165 if Present (Body_States) then
28166 State_Elmt := First_Elmt (Body_States);
28167 while Present (State_Elmt) loop
28169 -- Consume a valid constituent to signal that it has
28170 -- been encountered.
28172 if Node (State_Elmt) = Constit_Id then
28173 Remove_Elmt (Body_States, State_Elmt);
28174 Collect_Constituent;
28178 Next_Elmt (State_Elmt);
28182 -- At this point it is known that the constituent is not
28183 -- part of the package hidden state and cannot be used in
28184 -- a refinement (SPARK RM 7.2.2(9)).
28186 Error_Msg_Name_1 := Chars (Spec_Id);
28188 ("cannot use & in refinement, constituent is not a hidden "
28189 & "state of package %", Constit, Constit_Id);
28191 end Match_Constituent;
28195 Constit_Id : Entity_Id;
28196 Constits : Elist_Id;
28198 -- Start of processing for Analyze_Constituent
28201 -- Detect multiple uses of null in a single refinement clause or a
28202 -- mixture of null and non-null constituents.
28204 if Nkind (Constit) = N_Null then
28207 ("multiple null constituents not allowed", Constit);
28209 elsif Non_Null_Seen then
28211 ("cannot mix null and non-null constituents", Constit);
28216 -- Collect the constituent in the list of refinement items
28218 Constits := Refinement_Constituents (State_Id);
28220 if No (Constits) then
28221 Constits := New_Elmt_List;
28222 Set_Refinement_Constituents (State_Id, Constits);
28225 Append_Elmt (Constit, Constits);
28227 -- The state has at least one legal constituent, mark the
28228 -- start of the refinement region. The region ends when the
28229 -- body declarations end (see Analyze_Declarations).
28231 Set_Has_Visible_Refinement (State_Id);
28234 -- Non-null constituents
28237 Non_Null_Seen := True;
28241 ("cannot mix null and non-null constituents", Constit);
28245 Resolve_State (Constit);
28247 -- Ensure that the constituent denotes a valid state or a
28248 -- whole object (SPARK RM 7.2.2(5)).
28250 if Is_Entity_Name (Constit) then
28251 Constit_Id := Entity_Of (Constit);
28253 -- When a constituent is declared after a subprogram body
28254 -- that caused freezing of the related contract where
28255 -- pragma Refined_State resides, the constituent appears
28256 -- undefined and carries Any_Id as its entity.
28258 -- package body Pack
28259 -- with Refined_State => (State => Constit)
28262 -- with Refined_Global => (Input => Constit)
28270 if Constit_Id = Any_Id then
28271 SPARK_Msg_NE ("& is undefined", Constit, Constit_Id);
28273 -- Emit a specialized info message when the contract of
28274 -- the related package body was "frozen" by another body.
28275 -- Note that it is not possible to precisely identify why
28276 -- the constituent is undefined because it is not visible
28277 -- when pragma Refined_State is analyzed. This message is
28278 -- a reasonable approximation.
28280 if Present (Freeze_Id) and then not Freeze_Posted then
28281 Freeze_Posted := True;
28283 Error_Msg_Name_1 := Chars (Body_Id);
28284 Error_Msg_Sloc := Sloc (Freeze_Id);
28286 ("body & declared # freezes the contract of %",
28289 ("\all constituents must be declared before body #",
28292 -- A misplaced constituent is a critical error because
28293 -- pragma Refined_Depends or Refined_Global depends on
28294 -- the proper link between a state and a constituent.
28295 -- Stop the compilation, as this leads to a multitude
28296 -- of misleading cascaded errors.
28298 raise Unrecoverable_Error;
28301 -- The constituent is a valid state or object
28303 elsif Ekind_In (Constit_Id, E_Abstract_State,
28307 Match_Constituent (Constit_Id);
28309 -- The variable may eventually become a constituent of a
28310 -- single protected/task type. Record the reference now
28311 -- and verify its legality when analyzing the contract of
28312 -- the variable (SPARK RM 9.3).
28314 if Ekind (Constit_Id) = E_Variable then
28315 Record_Possible_Part_Of_Reference
28316 (Var_Id => Constit_Id,
28320 -- Otherwise the constituent is illegal
28324 ("constituent & must denote object or state",
28325 Constit, Constit_Id);
28328 -- The constituent is illegal
28331 SPARK_Msg_N ("malformed constituent", Constit);
28334 end Analyze_Constituent;
28336 -----------------------------
28337 -- Check_External_Property --
28338 -----------------------------
28340 procedure Check_External_Property
28341 (Prop_Nam : Name_Id;
28343 Constit : Entity_Id)
28346 -- The property is missing in the declaration of the state, but
28347 -- a constituent is introducing it in the state refinement
28348 -- (SPARK RM 7.2.8(2)).
28350 if not Enabled and then Present (Constit) then
28351 Error_Msg_Name_1 := Prop_Nam;
28352 Error_Msg_Name_2 := Chars (State_Id);
28354 ("constituent & introduces external property % in refinement "
28355 & "of state %", State, Constit);
28357 Error_Msg_Sloc := Sloc (State_Id);
28359 ("\property is missing in abstract state declaration #",
28362 end Check_External_Property;
28368 procedure Match_State is
28369 State_Elmt : Elmt_Id;
28372 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
28374 if Contains (Refined_States_Seen, State_Id) then
28376 ("duplicate refinement of state &", State, State_Id);
28380 -- Inspect the abstract states defined in the package declaration
28381 -- looking for a match.
28383 State_Elmt := First_Elmt (Available_States);
28384 while Present (State_Elmt) loop
28386 -- A valid abstract state is being refined in the body. Add
28387 -- the state to the list of processed refined states to aid
28388 -- with the detection of duplicate refinements. Remove the
28389 -- state from Available_States to signal that it has already
28392 if Node (State_Elmt) = State_Id then
28393 Append_New_Elmt (State_Id, Refined_States_Seen);
28394 Remove_Elmt (Available_States, State_Elmt);
28398 Next_Elmt (State_Elmt);
28401 -- If we get here, we are refining a state that is not defined in
28402 -- the package declaration.
28404 Error_Msg_Name_1 := Chars (Spec_Id);
28406 ("cannot refine state, & is not defined in package %",
28410 --------------------------------
28411 -- Report_Unused_Constituents --
28412 --------------------------------
28414 procedure Report_Unused_Constituents (Constits : Elist_Id) is
28415 Constit_Elmt : Elmt_Id;
28416 Constit_Id : Entity_Id;
28417 Posted : Boolean := False;
28420 if Present (Constits) then
28421 Constit_Elmt := First_Elmt (Constits);
28422 while Present (Constit_Elmt) loop
28423 Constit_Id := Node (Constit_Elmt);
28425 -- Generate an error message of the form:
28427 -- state ... has unused Part_Of constituents
28428 -- abstract state ... defined at ...
28429 -- constant ... defined at ...
28430 -- variable ... defined at ...
28435 ("state & has unused Part_Of constituents",
28439 Error_Msg_Sloc := Sloc (Constit_Id);
28441 if Ekind (Constit_Id) = E_Abstract_State then
28443 ("\abstract state & defined #", State, Constit_Id);
28445 elsif Ekind (Constit_Id) = E_Constant then
28447 ("\constant & defined #", State, Constit_Id);
28450 pragma Assert (Ekind (Constit_Id) = E_Variable);
28451 SPARK_Msg_NE ("\variable & defined #", State, Constit_Id);
28454 Next_Elmt (Constit_Elmt);
28457 end Report_Unused_Constituents;
28459 -- Local declarations
28461 Body_Ref : Node_Id;
28462 Body_Ref_Elmt : Elmt_Id;
28464 Extra_State : Node_Id;
28466 -- Start of processing for Analyze_Refinement_Clause
28469 -- A refinement clause appears as a component association where the
28470 -- sole choice is the state and the expressions are the constituents.
28471 -- This is a syntax error, always report.
28473 if Nkind (Clause) /= N_Component_Association then
28474 Error_Msg_N ("malformed state refinement clause", Clause);
28478 -- Analyze the state name of a refinement clause
28480 State := First (Choices (Clause));
28483 Resolve_State (State);
28485 -- Ensure that the state name denotes a valid abstract state that is
28486 -- defined in the spec of the related package.
28488 if Is_Entity_Name (State) then
28489 State_Id := Entity_Of (State);
28491 -- When the abstract state is undefined, it appears as Any_Id. Do
28492 -- not continue with the analysis of the clause.
28494 if State_Id = Any_Id then
28497 -- Catch any attempts to re-refine a state or refine a state that
28498 -- is not defined in the package declaration.
28500 elsif Ekind (State_Id) = E_Abstract_State then
28504 SPARK_Msg_NE ("& must denote abstract state", State, State_Id);
28508 -- References to a state with visible refinement are illegal.
28509 -- When nested packages are involved, detecting such references is
28510 -- tricky because pragma Refined_State is analyzed later than the
28511 -- offending pragma Depends or Global. References that occur in
28512 -- such nested context are stored in a list. Emit errors for all
28513 -- references found in Body_References (SPARK RM 6.1.4(8)).
28515 if Present (Body_References (State_Id)) then
28516 Body_Ref_Elmt := First_Elmt (Body_References (State_Id));
28517 while Present (Body_Ref_Elmt) loop
28518 Body_Ref := Node (Body_Ref_Elmt);
28520 SPARK_Msg_N ("reference to & not allowed", Body_Ref);
28521 Error_Msg_Sloc := Sloc (State);
28522 SPARK_Msg_N ("\refinement of & is visible#", Body_Ref);
28524 Next_Elmt (Body_Ref_Elmt);
28528 -- The state name is illegal. This is a syntax error, always report.
28531 Error_Msg_N ("malformed state name in refinement clause", State);
28535 -- A refinement clause may only refine one state at a time
28537 Extra_State := Next (State);
28539 if Present (Extra_State) then
28541 ("refinement clause cannot cover multiple states", Extra_State);
28544 -- Replicate the Part_Of constituents of the refined state because
28545 -- the algorithm will consume items.
28547 Part_Of_Constits := New_Copy_Elist (Part_Of_Constituents (State_Id));
28549 -- Analyze all constituents of the refinement. Multiple constituents
28550 -- appear as an aggregate.
28552 Constit := Expression (Clause);
28554 if Nkind (Constit) = N_Aggregate then
28555 if Present (Component_Associations (Constit)) then
28557 ("constituents of refinement clause must appear in "
28558 & "positional form", Constit);
28560 else pragma Assert (Present (Expressions (Constit)));
28561 Constit := First (Expressions (Constit));
28562 while Present (Constit) loop
28563 Analyze_Constituent (Constit);
28568 -- Various forms of a single constituent. Note that these may include
28569 -- malformed constituents.
28572 Analyze_Constituent (Constit);
28575 -- Verify that external constituents do not introduce new external
28576 -- property in the state refinement (SPARK RM 7.2.8(2)).
28578 if Is_External_State (State_Id) then
28579 Check_External_Property
28580 (Prop_Nam => Name_Async_Readers,
28581 Enabled => Async_Readers_Enabled (State_Id),
28582 Constit => AR_Constit);
28584 Check_External_Property
28585 (Prop_Nam => Name_Async_Writers,
28586 Enabled => Async_Writers_Enabled (State_Id),
28587 Constit => AW_Constit);
28589 Check_External_Property
28590 (Prop_Nam => Name_Effective_Reads,
28591 Enabled => Effective_Reads_Enabled (State_Id),
28592 Constit => ER_Constit);
28594 Check_External_Property
28595 (Prop_Nam => Name_Effective_Writes,
28596 Enabled => Effective_Writes_Enabled (State_Id),
28597 Constit => EW_Constit);
28599 -- When a refined state is not external, it should not have external
28600 -- constituents (SPARK RM 7.2.8(1)).
28602 elsif External_Constit_Seen then
28604 ("non-external state & cannot contain external constituents in "
28605 & "refinement", State, State_Id);
28608 -- Ensure that all Part_Of candidate constituents have been mentioned
28609 -- in the refinement clause.
28611 Report_Unused_Constituents (Part_Of_Constits);
28612 end Analyze_Refinement_Clause;
28614 -----------------------------
28615 -- Report_Unrefined_States --
28616 -----------------------------
28618 procedure Report_Unrefined_States (States : Elist_Id) is
28619 State_Elmt : Elmt_Id;
28622 if Present (States) then
28623 State_Elmt := First_Elmt (States);
28624 while Present (State_Elmt) loop
28626 ("abstract state & must be refined", Node (State_Elmt));
28628 Next_Elmt (State_Elmt);
28631 end Report_Unrefined_States;
28633 -- Local declarations
28635 Clauses : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
28638 -- Start of processing for Analyze_Refined_State_In_Decl_Part
28641 -- Do not analyze the pragma multiple times
28643 if Is_Analyzed_Pragma (N) then
28647 -- Save the scenario for examination by the ABE Processing phase
28649 Record_Elaboration_Scenario (N);
28651 -- Replicate the abstract states declared by the package because the
28652 -- matching algorithm will consume states.
28654 Available_States := New_Copy_Elist (Abstract_States (Spec_Id));
28656 -- Gather all abstract states and objects declared in the visible
28657 -- state space of the package body. These items must be utilized as
28658 -- constituents in a state refinement.
28660 Body_States := Collect_Body_States (Body_Id);
28662 -- Multiple non-null state refinements appear as an aggregate
28664 if Nkind (Clauses) = N_Aggregate then
28665 if Present (Expressions (Clauses)) then
28667 ("state refinements must appear as component associations",
28670 else pragma Assert (Present (Component_Associations (Clauses)));
28671 Clause := First (Component_Associations (Clauses));
28672 while Present (Clause) loop
28673 Analyze_Refinement_Clause (Clause);
28678 -- Various forms of a single state refinement. Note that these may
28679 -- include malformed refinements.
28682 Analyze_Refinement_Clause (Clauses);
28685 -- List all abstract states that were left unrefined
28687 Report_Unrefined_States (Available_States);
28689 Set_Is_Analyzed_Pragma (N);
28690 end Analyze_Refined_State_In_Decl_Part;
28692 ------------------------------------
28693 -- Analyze_Test_Case_In_Decl_Part --
28694 ------------------------------------
28696 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id) is
28697 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
28698 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
28700 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id);
28701 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
28702 -- denoted by Arg_Nam.
28704 ------------------------------
28705 -- Preanalyze_Test_Case_Arg --
28706 ------------------------------
28708 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id) is
28712 -- Preanalyze the original aspect argument for a generic subprogram
28713 -- to properly capture global references.
28715 if Is_Generic_Subprogram (Spec_Id) then
28719 Arg_Nam => Arg_Nam,
28720 From_Aspect => True);
28722 if Present (Arg) then
28723 Preanalyze_Assert_Expression
28724 (Expression (Arg), Standard_Boolean);
28728 Arg := Test_Case_Arg (N, Arg_Nam);
28730 if Present (Arg) then
28731 Preanalyze_Assert_Expression (Expression (Arg), Standard_Boolean);
28733 end Preanalyze_Test_Case_Arg;
28737 Restore_Scope : Boolean := False;
28739 -- Start of processing for Analyze_Test_Case_In_Decl_Part
28742 -- Do not analyze the pragma multiple times
28744 if Is_Analyzed_Pragma (N) then
28748 -- Ensure that the formal parameters are visible when analyzing all
28749 -- clauses. This falls out of the general rule of aspects pertaining
28750 -- to subprogram declarations.
28752 if not In_Open_Scopes (Spec_Id) then
28753 Restore_Scope := True;
28754 Push_Scope (Spec_Id);
28756 if Is_Generic_Subprogram (Spec_Id) then
28757 Install_Generic_Formals (Spec_Id);
28759 Install_Formals (Spec_Id);
28763 Preanalyze_Test_Case_Arg (Name_Requires);
28764 Preanalyze_Test_Case_Arg (Name_Ensures);
28766 if Restore_Scope then
28770 -- Currently it is not possible to inline pre/postconditions on a
28771 -- subprogram subject to pragma Inline_Always.
28773 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
28775 Set_Is_Analyzed_Pragma (N);
28776 end Analyze_Test_Case_In_Decl_Part;
28782 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is
28787 if Present (List) then
28788 Elmt := First_Elmt (List);
28789 while Present (Elmt) loop
28790 if Nkind (Node (Elmt)) = N_Defining_Identifier then
28793 Id := Entity_Of (Node (Elmt));
28796 if Id = Item_Id then
28807 -----------------------------------
28808 -- Build_Pragma_Check_Equivalent --
28809 -----------------------------------
28811 function Build_Pragma_Check_Equivalent
28813 Subp_Id : Entity_Id := Empty;
28814 Inher_Id : Entity_Id := Empty;
28815 Keep_Pragma_Id : Boolean := False) return Node_Id
28817 function Suppress_Reference (N : Node_Id) return Traverse_Result;
28818 -- Detect whether node N references a formal parameter subject to
28819 -- pragma Unreferenced. If this is the case, set Comes_From_Source
28820 -- to False to suppress the generation of a reference when analyzing
28823 ------------------------
28824 -- Suppress_Reference --
28825 ------------------------
28827 function Suppress_Reference (N : Node_Id) return Traverse_Result is
28828 Formal : Entity_Id;
28831 if Is_Entity_Name (N) and then Present (Entity (N)) then
28832 Formal := Entity (N);
28834 -- The formal parameter is subject to pragma Unreferenced. Prevent
28835 -- the generation of references by resetting the Comes_From_Source
28838 if Is_Formal (Formal)
28839 and then Has_Pragma_Unreferenced (Formal)
28841 Set_Comes_From_Source (N, False);
28846 end Suppress_Reference;
28848 procedure Suppress_References is
28849 new Traverse_Proc (Suppress_Reference);
28853 Loc : constant Source_Ptr := Sloc (Prag);
28854 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
28855 Check_Prag : Node_Id;
28859 Needs_Wrapper : Boolean;
28860 pragma Unreferenced (Needs_Wrapper);
28862 -- Start of processing for Build_Pragma_Check_Equivalent
28865 -- When the pre- or postcondition is inherited, map the formals of the
28866 -- inherited subprogram to those of the current subprogram. In addition,
28867 -- map primitive operations of the parent type into the corresponding
28868 -- primitive operations of the descendant.
28870 if Present (Inher_Id) then
28871 pragma Assert (Present (Subp_Id));
28873 Update_Primitives_Mapping (Inher_Id, Subp_Id);
28875 -- Use generic machinery to copy inherited pragma, as if it were an
28876 -- instantiation, resetting source locations appropriately, so that
28877 -- expressions inside the inherited pragma use chained locations.
28878 -- This is used in particular in GNATprove to locate precisely
28879 -- messages on a given inherited pragma.
28881 Set_Copied_Sloc_For_Inherited_Pragma
28882 (Unit_Declaration_Node (Subp_Id), Inher_Id);
28883 Check_Prag := New_Copy_Tree (Source => Prag);
28885 -- Build the inherited class-wide condition
28887 Build_Class_Wide_Expression
28888 (Prag => Check_Prag,
28890 Par_Subp => Inher_Id,
28891 Adjust_Sloc => True,
28892 Needs_Wrapper => Needs_Wrapper);
28894 -- If not an inherited condition simply copy the original pragma
28897 Check_Prag := New_Copy_Tree (Source => Prag);
28900 -- Mark the pragma as being internally generated and reset the Analyzed
28903 Set_Analyzed (Check_Prag, False);
28904 Set_Comes_From_Source (Check_Prag, False);
28906 -- The tree of the original pragma may contain references to the
28907 -- formal parameters of the related subprogram. At the same time
28908 -- the corresponding body may mark the formals as unreferenced:
28910 -- procedure Proc (Formal : ...)
28911 -- with Pre => Formal ...;
28913 -- procedure Proc (Formal : ...) is
28914 -- pragma Unreferenced (Formal);
28917 -- This creates problems because all pragma Check equivalents are
28918 -- analyzed at the end of the body declarations. Since all source
28919 -- references have already been accounted for, reset any references
28920 -- to such formals in the generated pragma Check equivalent.
28922 Suppress_References (Check_Prag);
28924 if Present (Corresponding_Aspect (Prag)) then
28925 Nam := Chars (Identifier (Corresponding_Aspect (Prag)));
28930 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
28931 -- the copied pragma in the newly created pragma, convert the copy into
28932 -- pragma Check by correcting the name and adding a check_kind argument.
28934 if not Keep_Pragma_Id then
28935 Set_Class_Present (Check_Prag, False);
28937 Set_Pragma_Identifier
28938 (Check_Prag, Make_Identifier (Loc, Name_Check));
28940 Prepend_To (Pragma_Argument_Associations (Check_Prag),
28941 Make_Pragma_Argument_Association (Loc,
28942 Expression => Make_Identifier (Loc, Nam)));
28945 -- Update the error message when the pragma is inherited
28947 if Present (Inher_Id) then
28948 Msg_Arg := Last (Pragma_Argument_Associations (Check_Prag));
28950 if Chars (Msg_Arg) = Name_Message then
28951 String_To_Name_Buffer (Strval (Expression (Msg_Arg)));
28953 -- Insert "inherited" to improve the error message
28955 if Name_Buffer (1 .. 8) = "failed p" then
28956 Insert_Str_In_Name_Buffer ("inherited ", 8);
28957 Set_Strval (Expression (Msg_Arg), String_From_Name_Buffer);
28963 end Build_Pragma_Check_Equivalent;
28965 -----------------------------
28966 -- Check_Applicable_Policy --
28967 -----------------------------
28969 procedure Check_Applicable_Policy (N : Node_Id) is
28973 Ename : constant Name_Id := Original_Aspect_Pragma_Name (N);
28976 -- No effect if not valid assertion kind name
28978 if not Is_Valid_Assertion_Kind (Ename) then
28982 -- Loop through entries in check policy list
28984 PP := Opt.Check_Policy_List;
28985 while Present (PP) loop
28987 PPA : constant List_Id := Pragma_Argument_Associations (PP);
28988 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
28992 or else Pnm = Name_Assertion
28993 or else (Pnm = Name_Statement_Assertions
28994 and then Nam_In (Ename, Name_Assert,
28995 Name_Assert_And_Cut,
28997 Name_Loop_Invariant,
28998 Name_Loop_Variant))
29000 Policy := Chars (Get_Pragma_Arg (Last (PPA)));
29006 -- In CodePeer mode and GNATprove mode, we need to
29007 -- consider all assertions, unless they are disabled.
29008 -- Force Is_Checked on ignored assertions, in particular
29009 -- because transformations of the AST may depend on
29010 -- assertions being checked (e.g. the translation of
29011 -- attribute 'Loop_Entry).
29013 if CodePeer_Mode or GNATprove_Mode then
29014 Set_Is_Checked (N, True);
29015 Set_Is_Ignored (N, False);
29017 Set_Is_Checked (N, False);
29018 Set_Is_Ignored (N, True);
29024 Set_Is_Checked (N, True);
29025 Set_Is_Ignored (N, False);
29027 when Name_Disable =>
29028 Set_Is_Ignored (N, True);
29029 Set_Is_Checked (N, False);
29030 Set_Is_Disabled (N, True);
29032 -- That should be exhaustive, the null here is a defence
29033 -- against a malformed tree from previous errors.
29042 PP := Next_Pragma (PP);
29046 -- If there are no specific entries that matched, then we let the
29047 -- setting of assertions govern. Note that this provides the needed
29048 -- compatibility with the RM for the cases of assertion, invariant,
29049 -- precondition, predicate, and postcondition. Note also that
29050 -- Assertions_Enabled is forced in CodePeer mode and GNATprove mode.
29052 if Assertions_Enabled then
29053 Set_Is_Checked (N, True);
29054 Set_Is_Ignored (N, False);
29056 Set_Is_Checked (N, False);
29057 Set_Is_Ignored (N, True);
29059 end Check_Applicable_Policy;
29061 -------------------------------
29062 -- Check_External_Properties --
29063 -------------------------------
29065 procedure Check_External_Properties
29073 -- All properties enabled
29075 if AR and AW and ER and EW then
29078 -- Async_Readers + Effective_Writes
29079 -- Async_Readers + Async_Writers + Effective_Writes
29081 elsif AR and EW and not ER then
29084 -- Async_Writers + Effective_Reads
29085 -- Async_Readers + Async_Writers + Effective_Reads
29087 elsif AW and ER and not EW then
29090 -- Async_Readers + Async_Writers
29092 elsif AR and AW and not ER and not EW then
29097 elsif AR and not AW and not ER and not EW then
29102 elsif AW and not AR and not ER and not EW then
29107 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
29110 end Check_External_Properties;
29116 function Check_Kind (Nam : Name_Id) return Name_Id is
29120 -- Loop through entries in check policy list
29122 PP := Opt.Check_Policy_List;
29123 while Present (PP) loop
29125 PPA : constant List_Id := Pragma_Argument_Associations (PP);
29126 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
29130 or else (Pnm = Name_Assertion
29131 and then Is_Valid_Assertion_Kind (Nam))
29132 or else (Pnm = Name_Statement_Assertions
29133 and then Nam_In (Nam, Name_Assert,
29134 Name_Assert_And_Cut,
29136 Name_Loop_Invariant,
29137 Name_Loop_Variant))
29139 case (Chars (Get_Pragma_Arg (Last (PPA)))) is
29148 return Name_Ignore;
29150 when Name_Disable =>
29151 return Name_Disable;
29154 raise Program_Error;
29158 PP := Next_Pragma (PP);
29163 -- If there are no specific entries that matched, then we let the
29164 -- setting of assertions govern. Note that this provides the needed
29165 -- compatibility with the RM for the cases of assertion, invariant,
29166 -- precondition, predicate, and postcondition.
29168 if Assertions_Enabled then
29171 return Name_Ignore;
29175 ---------------------------
29176 -- Check_Missing_Part_Of --
29177 ---------------------------
29179 procedure Check_Missing_Part_Of (Item_Id : Entity_Id) is
29180 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean;
29181 -- Determine whether a package denoted by Pack_Id declares at least one
29184 -----------------------
29185 -- Has_Visible_State --
29186 -----------------------
29188 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean is
29189 Item_Id : Entity_Id;
29192 -- Traverse the entity chain of the package trying to find at least
29193 -- one visible abstract state, variable or a package [instantiation]
29194 -- that declares a visible state.
29196 Item_Id := First_Entity (Pack_Id);
29197 while Present (Item_Id)
29198 and then not In_Private_Part (Item_Id)
29200 -- Do not consider internally generated items
29202 if not Comes_From_Source (Item_Id) then
29205 -- Do not consider generic formals or their corresponding actuals
29206 -- because they are not part of a visible state. Note that both
29207 -- entities are marked as hidden.
29209 elsif Is_Hidden (Item_Id) then
29212 -- A visible state has been found. Note that constants are not
29213 -- considered here because it is not possible to determine whether
29214 -- they depend on variable input. This check is left to the SPARK
29217 elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
29220 -- Recursively peek into nested packages and instantiations
29222 elsif Ekind (Item_Id) = E_Package
29223 and then Has_Visible_State (Item_Id)
29228 Next_Entity (Item_Id);
29232 end Has_Visible_State;
29236 Pack_Id : Entity_Id;
29237 Placement : State_Space_Kind;
29239 -- Start of processing for Check_Missing_Part_Of
29242 -- Do not consider abstract states, variables or package instantiations
29243 -- coming from an instance as those always inherit the Part_Of indicator
29244 -- of the instance itself.
29246 if In_Instance then
29249 -- Do not consider internally generated entities as these can never
29250 -- have a Part_Of indicator.
29252 elsif not Comes_From_Source (Item_Id) then
29255 -- Perform these checks only when SPARK_Mode is enabled as they will
29256 -- interfere with standard Ada rules and produce false positives.
29258 elsif SPARK_Mode /= On then
29261 -- Do not consider constants, because the compiler cannot accurately
29262 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
29263 -- act as a hidden state of a package.
29265 elsif Ekind (Item_Id) = E_Constant then
29269 -- Find where the abstract state, variable or package instantiation
29270 -- lives with respect to the state space.
29272 Find_Placement_In_State_Space
29273 (Item_Id => Item_Id,
29274 Placement => Placement,
29275 Pack_Id => Pack_Id);
29277 -- Items that appear in a non-package construct (subprogram, block, etc)
29278 -- do not require a Part_Of indicator because they can never act as a
29281 if Placement = Not_In_Package then
29284 -- An item declared in the body state space of a package always act as a
29285 -- constituent and does not need explicit Part_Of indicator.
29287 elsif Placement = Body_State_Space then
29290 -- In general an item declared in the visible state space of a package
29291 -- does not require a Part_Of indicator. The only exception is when the
29292 -- related package is a nongeneric private child unit, in which case
29293 -- Part_Of must denote a state in the parent unit or in one of its
29296 elsif Placement = Visible_State_Space then
29297 if Is_Child_Unit (Pack_Id)
29298 and then not Is_Generic_Unit (Pack_Id)
29299 and then Is_Private_Descendant (Pack_Id)
29301 -- A package instantiation does not need a Part_Of indicator when
29302 -- the related generic template has no visible state.
29304 if Ekind (Item_Id) = E_Package
29305 and then Is_Generic_Instance (Item_Id)
29306 and then not Has_Visible_State (Item_Id)
29310 -- All other cases require Part_Of
29314 ("indicator Part_Of is required in this context "
29315 & "(SPARK RM 7.2.6(3))", Item_Id);
29316 Error_Msg_Name_1 := Chars (Pack_Id);
29318 ("\& is declared in the visible part of private child "
29319 & "unit %", Item_Id);
29323 -- When the item appears in the private state space of a package, it
29324 -- must be a part of some state declared by the said package.
29326 else pragma Assert (Placement = Private_State_Space);
29328 -- The related package does not declare a state, the item cannot act
29329 -- as a Part_Of constituent.
29331 if No (Get_Pragma (Pack_Id, Pragma_Abstract_State)) then
29334 -- A package instantiation does not need a Part_Of indicator when the
29335 -- related generic template has no visible state.
29337 elsif Ekind (Item_Id) = E_Package
29338 and then Is_Generic_Instance (Item_Id)
29339 and then not Has_Visible_State (Item_Id)
29343 -- All other cases require Part_Of
29347 ("indicator Part_Of is required in this context "
29348 & "(SPARK RM 7.2.6(2))", Item_Id);
29349 Error_Msg_Name_1 := Chars (Pack_Id);
29351 ("\& is declared in the private part of package %", Item_Id);
29354 end Check_Missing_Part_Of;
29356 ---------------------------------------------------
29357 -- Check_Postcondition_Use_In_Inlined_Subprogram --
29358 ---------------------------------------------------
29360 procedure Check_Postcondition_Use_In_Inlined_Subprogram
29362 Spec_Id : Entity_Id)
29365 if Warn_On_Redundant_Constructs
29366 and then Has_Pragma_Inline_Always (Spec_Id)
29367 and then Assertions_Enabled
29369 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
29371 if From_Aspect_Specification (Prag) then
29373 ("aspect % not enforced on inlined subprogram &?r?",
29374 Corresponding_Aspect (Prag), Spec_Id);
29377 ("pragma % not enforced on inlined subprogram &?r?",
29381 end Check_Postcondition_Use_In_Inlined_Subprogram;
29383 -------------------------------------
29384 -- Check_State_And_Constituent_Use --
29385 -------------------------------------
29387 procedure Check_State_And_Constituent_Use
29388 (States : Elist_Id;
29389 Constits : Elist_Id;
29392 Constit_Elmt : Elmt_Id;
29393 Constit_Id : Entity_Id;
29394 State_Id : Entity_Id;
29397 -- Nothing to do if there are no states or constituents
29399 if No (States) or else No (Constits) then
29403 -- Inspect the list of constituents and try to determine whether its
29404 -- encapsulating state is in list States.
29406 Constit_Elmt := First_Elmt (Constits);
29407 while Present (Constit_Elmt) loop
29408 Constit_Id := Node (Constit_Elmt);
29410 -- Determine whether the constituent is part of an encapsulating
29411 -- state that appears in the same context and if this is the case,
29412 -- emit an error (SPARK RM 7.2.6(7)).
29414 State_Id := Find_Encapsulating_State (States, Constit_Id);
29416 if Present (State_Id) then
29417 Error_Msg_Name_1 := Chars (Constit_Id);
29419 ("cannot mention state & and its constituent % in the same "
29420 & "context", Context, State_Id);
29424 Next_Elmt (Constit_Elmt);
29426 end Check_State_And_Constituent_Use;
29428 ---------------------------------------------
29429 -- Collect_Inherited_Class_Wide_Conditions --
29430 ---------------------------------------------
29432 procedure Collect_Inherited_Class_Wide_Conditions (Subp : Entity_Id) is
29433 Parent_Subp : constant Entity_Id :=
29434 Ultimate_Alias (Overridden_Operation (Subp));
29435 -- The Overridden_Operation may itself be inherited and as such have no
29436 -- explicit contract.
29438 Prags : constant Node_Id := Contract (Parent_Subp);
29439 In_Spec_Expr : Boolean := In_Spec_Expression;
29440 Installed : Boolean;
29442 New_Prag : Node_Id;
29445 Installed := False;
29447 -- Iterate over the contract of the overridden subprogram to find all
29448 -- inherited class-wide pre- and postconditions.
29450 if Present (Prags) then
29451 Prag := Pre_Post_Conditions (Prags);
29453 while Present (Prag) loop
29454 if Nam_In (Pragma_Name_Unmapped (Prag),
29455 Name_Precondition, Name_Postcondition)
29456 and then Class_Present (Prag)
29458 -- The generated pragma must be analyzed in the context of
29459 -- the subprogram, to make its formals visible. In addition,
29460 -- we must inhibit freezing and full analysis because the
29461 -- controlling type of the subprogram is not frozen yet, and
29462 -- may have further primitives.
29464 if not Installed then
29467 Install_Formals (Subp);
29468 In_Spec_Expr := In_Spec_Expression;
29469 In_Spec_Expression := True;
29473 Build_Pragma_Check_Equivalent
29474 (Prag, Subp, Parent_Subp, Keep_Pragma_Id => True);
29476 Insert_After (Unit_Declaration_Node (Subp), New_Prag);
29477 Preanalyze (New_Prag);
29479 -- Prevent further analysis in subsequent processing of the
29480 -- current list of declarations
29482 Set_Analyzed (New_Prag);
29485 Prag := Next_Pragma (Prag);
29489 In_Spec_Expression := In_Spec_Expr;
29493 end Collect_Inherited_Class_Wide_Conditions;
29495 ---------------------------------------
29496 -- Collect_Subprogram_Inputs_Outputs --
29497 ---------------------------------------
29499 procedure Collect_Subprogram_Inputs_Outputs
29500 (Subp_Id : Entity_Id;
29501 Synthesize : Boolean := False;
29502 Subp_Inputs : in out Elist_Id;
29503 Subp_Outputs : in out Elist_Id;
29504 Global_Seen : out Boolean)
29506 procedure Collect_Dependency_Clause (Clause : Node_Id);
29507 -- Collect all relevant items from a dependency clause
29509 procedure Collect_Global_List
29511 Mode : Name_Id := Name_Input);
29512 -- Collect all relevant items from a global list
29514 -------------------------------
29515 -- Collect_Dependency_Clause --
29516 -------------------------------
29518 procedure Collect_Dependency_Clause (Clause : Node_Id) is
29519 procedure Collect_Dependency_Item
29521 Is_Input : Boolean);
29522 -- Add an item to the proper subprogram input or output collection
29524 -----------------------------
29525 -- Collect_Dependency_Item --
29526 -----------------------------
29528 procedure Collect_Dependency_Item
29530 Is_Input : Boolean)
29535 -- Nothing to collect when the item is null
29537 if Nkind (Item) = N_Null then
29540 -- Ditto for attribute 'Result
29542 elsif Is_Attribute_Result (Item) then
29545 -- Multiple items appear as an aggregate
29547 elsif Nkind (Item) = N_Aggregate then
29548 Extra := First (Expressions (Item));
29549 while Present (Extra) loop
29550 Collect_Dependency_Item (Extra, Is_Input);
29554 -- Otherwise this is a solitary item
29558 Append_New_Elmt (Item, Subp_Inputs);
29560 Append_New_Elmt (Item, Subp_Outputs);
29563 end Collect_Dependency_Item;
29565 -- Start of processing for Collect_Dependency_Clause
29568 if Nkind (Clause) = N_Null then
29571 -- A dependency clause appears as component association
29573 elsif Nkind (Clause) = N_Component_Association then
29574 Collect_Dependency_Item
29575 (Item => Expression (Clause),
29578 Collect_Dependency_Item
29579 (Item => First (Choices (Clause)),
29580 Is_Input => False);
29582 -- To accommodate partial decoration of disabled SPARK features, this
29583 -- routine may be called with illegal input. If this is the case, do
29584 -- not raise Program_Error.
29589 end Collect_Dependency_Clause;
29591 -------------------------
29592 -- Collect_Global_List --
29593 -------------------------
29595 procedure Collect_Global_List
29597 Mode : Name_Id := Name_Input)
29599 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id);
29600 -- Add an item to the proper subprogram input or output collection
29602 -------------------------
29603 -- Collect_Global_Item --
29604 -------------------------
29606 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is
29608 if Nam_In (Mode, Name_In_Out, Name_Input) then
29609 Append_New_Elmt (Item, Subp_Inputs);
29612 if Nam_In (Mode, Name_In_Out, Name_Output) then
29613 Append_New_Elmt (Item, Subp_Outputs);
29615 end Collect_Global_Item;
29622 -- Start of processing for Collect_Global_List
29625 if Nkind (List) = N_Null then
29628 -- Single global item declaration
29630 elsif Nkind_In (List, N_Expanded_Name,
29632 N_Selected_Component)
29634 Collect_Global_Item (List, Mode);
29636 -- Simple global list or moded global list declaration
29638 elsif Nkind (List) = N_Aggregate then
29639 if Present (Expressions (List)) then
29640 Item := First (Expressions (List));
29641 while Present (Item) loop
29642 Collect_Global_Item (Item, Mode);
29647 Assoc := First (Component_Associations (List));
29648 while Present (Assoc) loop
29649 Collect_Global_List
29650 (List => Expression (Assoc),
29651 Mode => Chars (First (Choices (Assoc))));
29656 -- To accommodate partial decoration of disabled SPARK features, this
29657 -- routine may be called with illegal input. If this is the case, do
29658 -- not raise Program_Error.
29663 end Collect_Global_List;
29670 Formal : Entity_Id;
29672 Spec_Id : Entity_Id := Empty;
29673 Subp_Decl : Node_Id;
29676 -- Start of processing for Collect_Subprogram_Inputs_Outputs
29679 Global_Seen := False;
29681 -- Process all formal parameters of entries, [generic] subprograms, and
29684 if Ekind_In (Subp_Id, E_Entry,
29687 E_Generic_Function,
29688 E_Generic_Procedure,
29692 Subp_Decl := Unit_Declaration_Node (Subp_Id);
29693 Spec_Id := Unique_Defining_Entity (Subp_Decl);
29695 -- Process all formal parameters
29697 Formal := First_Entity (Spec_Id);
29698 while Present (Formal) loop
29699 if Ekind_In (Formal, E_In_Out_Parameter, E_In_Parameter) then
29700 Append_New_Elmt (Formal, Subp_Inputs);
29703 if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then
29704 Append_New_Elmt (Formal, Subp_Outputs);
29706 -- Out parameters can act as inputs when the related type is
29707 -- tagged, unconstrained array, unconstrained record, or record
29708 -- with unconstrained components.
29710 if Ekind (Formal) = E_Out_Parameter
29711 and then Is_Unconstrained_Or_Tagged_Item (Formal)
29713 Append_New_Elmt (Formal, Subp_Inputs);
29717 Next_Entity (Formal);
29720 -- Otherwise the input denotes a task type, a task body, or the
29721 -- anonymous object created for a single task type.
29723 elsif Ekind_In (Subp_Id, E_Task_Type, E_Task_Body)
29724 or else Is_Single_Task_Object (Subp_Id)
29726 Subp_Decl := Declaration_Node (Subp_Id);
29727 Spec_Id := Unique_Defining_Entity (Subp_Decl);
29730 -- When processing an entry, subprogram or task body, look for pragmas
29731 -- Refined_Depends and Refined_Global as they specify the inputs and
29734 if Is_Entry_Body (Subp_Id)
29735 or else Ekind_In (Subp_Id, E_Subprogram_Body, E_Task_Body)
29737 Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends);
29738 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global);
29740 -- Subprogram declaration or stand-alone body case, look for pragmas
29741 -- Depends and Global
29744 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
29745 Global := Get_Pragma (Spec_Id, Pragma_Global);
29748 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
29749 -- because it provides finer granularity of inputs and outputs.
29751 if Present (Global) then
29752 Global_Seen := True;
29753 Collect_Global_List (Expression (Get_Argument (Global, Spec_Id)));
29755 -- When the related subprogram lacks pragma [Refined_]Global, fall back
29756 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
29757 -- the inputs and outputs from [Refined_]Depends.
29759 elsif Synthesize and then Present (Depends) then
29760 Clauses := Expression (Get_Argument (Depends, Spec_Id));
29762 -- Multiple dependency clauses appear as an aggregate
29764 if Nkind (Clauses) = N_Aggregate then
29765 Clause := First (Component_Associations (Clauses));
29766 while Present (Clause) loop
29767 Collect_Dependency_Clause (Clause);
29771 -- Otherwise this is a single dependency clause
29774 Collect_Dependency_Clause (Clauses);
29778 -- The current instance of a protected type acts as a formal parameter
29779 -- of mode IN for functions and IN OUT for entries and procedures
29780 -- (SPARK RM 6.1.4).
29782 if Ekind (Scope (Spec_Id)) = E_Protected_Type then
29783 Typ := Scope (Spec_Id);
29785 -- Use the anonymous object when the type is single protected
29787 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
29788 Typ := Anonymous_Object (Typ);
29791 Append_New_Elmt (Typ, Subp_Inputs);
29793 if Ekind_In (Spec_Id, E_Entry, E_Entry_Family, E_Procedure) then
29794 Append_New_Elmt (Typ, Subp_Outputs);
29797 -- The current instance of a task type acts as a formal parameter of
29798 -- mode IN OUT (SPARK RM 6.1.4).
29800 elsif Ekind (Spec_Id) = E_Task_Type then
29803 -- Use the anonymous object when the type is single task
29805 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
29806 Typ := Anonymous_Object (Typ);
29809 Append_New_Elmt (Typ, Subp_Inputs);
29810 Append_New_Elmt (Typ, Subp_Outputs);
29812 elsif Is_Single_Task_Object (Spec_Id) then
29813 Append_New_Elmt (Spec_Id, Subp_Inputs);
29814 Append_New_Elmt (Spec_Id, Subp_Outputs);
29816 end Collect_Subprogram_Inputs_Outputs;
29818 ---------------------------
29819 -- Contract_Freeze_Error --
29820 ---------------------------
29822 procedure Contract_Freeze_Error
29823 (Contract_Id : Entity_Id;
29824 Freeze_Id : Entity_Id)
29827 Error_Msg_Name_1 := Chars (Contract_Id);
29828 Error_Msg_Sloc := Sloc (Freeze_Id);
29831 ("body & declared # freezes the contract of%", Contract_Id, Freeze_Id);
29833 ("\all contractual items must be declared before body #", Contract_Id);
29834 end Contract_Freeze_Error;
29836 ---------------------------------
29837 -- Delay_Config_Pragma_Analyze --
29838 ---------------------------------
29840 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
29842 return Nam_In (Pragma_Name_Unmapped (N),
29843 Name_Interrupt_State, Name_Priority_Specific_Dispatching);
29844 end Delay_Config_Pragma_Analyze;
29846 -----------------------
29847 -- Duplication_Error --
29848 -----------------------
29850 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id) is
29851 Prag_From_Asp : constant Boolean := From_Aspect_Specification (Prag);
29852 Prev_From_Asp : constant Boolean := From_Aspect_Specification (Prev);
29855 Error_Msg_Sloc := Sloc (Prev);
29856 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
29858 -- Emit a precise message to distinguish between source pragmas and
29859 -- pragmas generated from aspects. The ordering of the two pragmas is
29863 -- Prag -- duplicate
29865 -- No error is emitted when both pragmas come from aspects because this
29866 -- is already detected by the general aspect analysis mechanism.
29868 if Prag_From_Asp and Prev_From_Asp then
29870 elsif Prag_From_Asp then
29871 Error_Msg_N ("aspect % duplicates pragma declared #", Prag);
29872 elsif Prev_From_Asp then
29873 Error_Msg_N ("pragma % duplicates aspect declared #", Prag);
29875 Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
29877 end Duplication_Error;
29879 ------------------------------
29880 -- Find_Encapsulating_State --
29881 ------------------------------
29883 function Find_Encapsulating_State
29884 (States : Elist_Id;
29885 Constit_Id : Entity_Id) return Entity_Id
29887 State_Id : Entity_Id;
29890 -- Since a constituent may be part of a larger constituent set, climb
29891 -- the encapsulating state chain looking for a state that appears in
29894 State_Id := Encapsulating_State (Constit_Id);
29895 while Present (State_Id) loop
29896 if Contains (States, State_Id) then
29900 State_Id := Encapsulating_State (State_Id);
29904 end Find_Encapsulating_State;
29906 --------------------------
29907 -- Find_Related_Context --
29908 --------------------------
29910 function Find_Related_Context
29912 Do_Checks : Boolean := False) return Node_Id
29917 Stmt := Prev (Prag);
29918 while Present (Stmt) loop
29920 -- Skip prior pragmas, but check for duplicates
29922 if Nkind (Stmt) = N_Pragma then
29924 and then Pragma_Name (Stmt) = Pragma_Name (Prag)
29931 -- Skip internally generated code
29933 elsif not Comes_From_Source (Stmt) then
29935 -- The anonymous object created for a single concurrent type is a
29936 -- suitable context.
29938 if Nkind (Stmt) = N_Object_Declaration
29939 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
29944 -- Return the current source construct
29954 end Find_Related_Context;
29956 --------------------------------------
29957 -- Find_Related_Declaration_Or_Body --
29958 --------------------------------------
29960 function Find_Related_Declaration_Or_Body
29962 Do_Checks : Boolean := False) return Node_Id
29964 Prag_Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
29966 procedure Expression_Function_Error;
29967 -- Emit an error concerning pragma Prag that illegaly applies to an
29968 -- expression function.
29970 -------------------------------
29971 -- Expression_Function_Error --
29972 -------------------------------
29974 procedure Expression_Function_Error is
29976 Error_Msg_Name_1 := Prag_Nam;
29978 -- Emit a precise message to distinguish between source pragmas and
29979 -- pragmas generated from aspects.
29981 if From_Aspect_Specification (Prag) then
29983 ("aspect % cannot apply to a stand alone expression function",
29987 ("pragma % cannot apply to a stand alone expression function",
29990 end Expression_Function_Error;
29994 Context : constant Node_Id := Parent (Prag);
29997 Look_For_Body : constant Boolean :=
29998 Nam_In (Prag_Nam, Name_Refined_Depends,
29999 Name_Refined_Global,
30001 Name_Refined_State);
30002 -- Refinement pragmas must be associated with a subprogram body [stub]
30004 -- Start of processing for Find_Related_Declaration_Or_Body
30007 Stmt := Prev (Prag);
30008 while Present (Stmt) loop
30010 -- Skip prior pragmas, but check for duplicates. Pragmas produced
30011 -- by splitting a complex pre/postcondition are not considered to
30014 if Nkind (Stmt) = N_Pragma then
30016 and then not Split_PPC (Stmt)
30017 and then Original_Aspect_Pragma_Name (Stmt) = Prag_Nam
30024 -- Emit an error when a refinement pragma appears on an expression
30025 -- function without a completion.
30028 and then Look_For_Body
30029 and then Nkind (Stmt) = N_Subprogram_Declaration
30030 and then Nkind (Original_Node (Stmt)) = N_Expression_Function
30031 and then not Has_Completion (Defining_Entity (Stmt))
30033 Expression_Function_Error;
30036 -- The refinement pragma applies to a subprogram body stub
30038 elsif Look_For_Body
30039 and then Nkind (Stmt) = N_Subprogram_Body_Stub
30043 -- Skip internally generated code
30045 elsif not Comes_From_Source (Stmt) then
30047 -- The anonymous object created for a single concurrent type is a
30048 -- suitable context.
30050 if Nkind (Stmt) = N_Object_Declaration
30051 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
30055 elsif Nkind (Stmt) = N_Subprogram_Declaration then
30057 -- The subprogram declaration is an internally generated spec
30058 -- for an expression function.
30060 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
30063 -- The subprogram declaration is an internally generated spec
30064 -- for a stand-alone subrogram body declared inside a protected
30067 elsif Present (Corresponding_Body (Stmt))
30068 and then Comes_From_Source (Corresponding_Body (Stmt))
30069 and then Is_Protected_Type (Current_Scope)
30073 -- The subprogram is actually an instance housed within an
30074 -- anonymous wrapper package.
30076 elsif Present (Generic_Parent (Specification (Stmt))) then
30079 -- Ada 2020: contract on formal subprogram
30081 elsif Is_Generic_Actual_Subprogram (Defining_Entity (Stmt))
30082 and then Ada_Version >= Ada_2020
30088 -- Return the current construct which is either a subprogram body,
30089 -- a subprogram declaration or is illegal.
30098 -- If we fall through, then the pragma was either the first declaration
30099 -- or it was preceded by other pragmas and no source constructs.
30101 -- The pragma is associated with a library-level subprogram
30103 if Nkind (Context) = N_Compilation_Unit_Aux then
30104 return Unit (Parent (Context));
30106 -- The pragma appears inside the declarations of an entry body
30108 elsif Nkind (Context) = N_Entry_Body then
30111 -- The pragma appears inside the statements of a subprogram body. This
30112 -- placement is the result of subprogram contract expansion.
30114 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then
30115 return Parent (Context);
30117 -- The pragma appears inside the declarative part of a package body
30119 elsif Nkind (Context) = N_Package_Body then
30122 -- The pragma appears inside the declarative part of a subprogram body
30124 elsif Nkind (Context) = N_Subprogram_Body then
30127 -- The pragma appears inside the declarative part of a task body
30129 elsif Nkind (Context) = N_Task_Body then
30132 -- The pragma appears inside the visible part of a package specification
30134 elsif Nkind (Context) = N_Package_Specification then
30135 return Parent (Context);
30137 -- The pragma is a byproduct of aspect expansion, return the related
30138 -- context of the original aspect. This case has a lower priority as
30139 -- the above circuitry pinpoints precisely the related context.
30141 elsif Present (Corresponding_Aspect (Prag)) then
30142 return Parent (Corresponding_Aspect (Prag));
30144 -- No candidate subprogram [body] found
30149 end Find_Related_Declaration_Or_Body;
30151 ----------------------------------
30152 -- Find_Related_Package_Or_Body --
30153 ----------------------------------
30155 function Find_Related_Package_Or_Body
30157 Do_Checks : Boolean := False) return Node_Id
30159 Context : constant Node_Id := Parent (Prag);
30160 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
30164 Stmt := Prev (Prag);
30165 while Present (Stmt) loop
30167 -- Skip prior pragmas, but check for duplicates
30169 if Nkind (Stmt) = N_Pragma then
30170 if Do_Checks and then Pragma_Name (Stmt) = Prag_Nam then
30176 -- Skip internally generated code
30178 elsif not Comes_From_Source (Stmt) then
30179 if Nkind (Stmt) = N_Subprogram_Declaration then
30181 -- The subprogram declaration is an internally generated spec
30182 -- for an expression function.
30184 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
30187 -- The subprogram is actually an instance housed within an
30188 -- anonymous wrapper package.
30190 elsif Present (Generic_Parent (Specification (Stmt))) then
30195 -- Return the current source construct which is illegal
30204 -- If we fall through, then the pragma was either the first declaration
30205 -- or it was preceded by other pragmas and no source constructs.
30207 -- The pragma is associated with a package. The immediate context in
30208 -- this case is the specification of the package.
30210 if Nkind (Context) = N_Package_Specification then
30211 return Parent (Context);
30213 -- The pragma appears in the declarations of a package body
30215 elsif Nkind (Context) = N_Package_Body then
30218 -- The pragma appears in the statements of a package body
30220 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
30221 and then Nkind (Parent (Context)) = N_Package_Body
30223 return Parent (Context);
30225 -- The pragma is a byproduct of aspect expansion, return the related
30226 -- context of the original aspect. This case has a lower priority as
30227 -- the above circuitry pinpoints precisely the related context.
30229 elsif Present (Corresponding_Aspect (Prag)) then
30230 return Parent (Corresponding_Aspect (Prag));
30232 -- No candidate package [body] found
30237 end Find_Related_Package_Or_Body;
30243 function Get_Argument
30245 Context_Id : Entity_Id := Empty) return Node_Id
30247 Args : constant List_Id := Pragma_Argument_Associations (Prag);
30250 -- Use the expression of the original aspect when analyzing the template
30251 -- of a generic unit. In both cases the aspect's tree must be decorated
30252 -- to allow for ASIS queries or to save the global references in the
30253 -- generic context.
30255 if From_Aspect_Specification (Prag)
30256 and then (Present (Context_Id) and then Is_Generic_Unit (Context_Id))
30258 return Corresponding_Aspect (Prag);
30260 -- Otherwise use the expression of the pragma
30262 elsif Present (Args) then
30263 return First (Args);
30270 -------------------------
30271 -- Get_Base_Subprogram --
30272 -------------------------
30274 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
30276 -- Follow subprogram renaming chain
30278 if Is_Subprogram (Def_Id)
30279 and then Nkind (Parent (Declaration_Node (Def_Id))) =
30280 N_Subprogram_Renaming_Declaration
30281 and then Present (Alias (Def_Id))
30283 return Alias (Def_Id);
30287 end Get_Base_Subprogram;
30289 -----------------------
30290 -- Get_SPARK_Mode_Type --
30291 -----------------------
30293 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is
30295 if N = Name_On then
30297 elsif N = Name_Off then
30300 -- Any other argument is illegal. Assume that no SPARK mode applies to
30301 -- avoid potential cascaded errors.
30306 end Get_SPARK_Mode_Type;
30308 ------------------------------------
30309 -- Get_SPARK_Mode_From_Annotation --
30310 ------------------------------------
30312 function Get_SPARK_Mode_From_Annotation
30313 (N : Node_Id) return SPARK_Mode_Type
30318 if Nkind (N) = N_Aspect_Specification then
30319 Mode := Expression (N);
30321 else pragma Assert (Nkind (N) = N_Pragma);
30322 Mode := First (Pragma_Argument_Associations (N));
30324 if Present (Mode) then
30325 Mode := Get_Pragma_Arg (Mode);
30329 -- Aspect or pragma SPARK_Mode specifies an explicit mode
30331 if Present (Mode) then
30332 if Nkind (Mode) = N_Identifier then
30333 return Get_SPARK_Mode_Type (Chars (Mode));
30335 -- In case of a malformed aspect or pragma, return the default None
30341 -- Otherwise the lack of an expression defaults SPARK_Mode to On
30346 end Get_SPARK_Mode_From_Annotation;
30348 ---------------------------
30349 -- Has_Extra_Parentheses --
30350 ---------------------------
30352 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean is
30356 -- The aggregate should not have an expression list because a clause
30357 -- is always interpreted as a component association. The only way an
30358 -- expression list can sneak in is by adding extra parentheses around
30359 -- the individual clauses:
30361 -- Depends (Output => Input) -- proper form
30362 -- Depends ((Output => Input)) -- extra parentheses
30364 -- Since the extra parentheses are not allowed by the syntax of the
30365 -- pragma, flag them now to avoid emitting misleading errors down the
30368 if Nkind (Clause) = N_Aggregate
30369 and then Present (Expressions (Clause))
30371 Expr := First (Expressions (Clause));
30372 while Present (Expr) loop
30374 -- A dependency clause surrounded by extra parentheses appears
30375 -- as an aggregate of component associations with an optional
30376 -- Paren_Count set.
30378 if Nkind (Expr) = N_Aggregate
30379 and then Present (Component_Associations (Expr))
30382 ("dependency clause contains extra parentheses", Expr);
30384 -- Otherwise the expression is a malformed construct
30387 SPARK_Msg_N ("malformed dependency clause", Expr);
30397 end Has_Extra_Parentheses;
30403 procedure Initialize is
30406 Compile_Time_Warnings_Errors.Init;
30415 Dummy := Dummy + 1;
30418 -----------------------------
30419 -- Is_Config_Static_String --
30420 -----------------------------
30422 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
30424 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
30425 -- This is an internal recursive function that is just like the outer
30426 -- function except that it adds the string to the name buffer rather
30427 -- than placing the string in the name buffer.
30429 ------------------------------
30430 -- Add_Config_Static_String --
30431 ------------------------------
30433 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
30440 if Nkind (N) = N_Op_Concat then
30441 if Add_Config_Static_String (Left_Opnd (N)) then
30442 N := Right_Opnd (N);
30448 if Nkind (N) /= N_String_Literal then
30449 Error_Msg_N ("string literal expected for pragma argument", N);
30453 for J in 1 .. String_Length (Strval (N)) loop
30454 C := Get_String_Char (Strval (N), J);
30456 if not In_Character_Range (C) then
30458 ("string literal contains invalid wide character",
30459 Sloc (N) + 1 + Source_Ptr (J));
30463 Add_Char_To_Name_Buffer (Get_Character (C));
30468 end Add_Config_Static_String;
30470 -- Start of processing for Is_Config_Static_String
30475 return Add_Config_Static_String (Arg);
30476 end Is_Config_Static_String;
30478 -------------------------------
30479 -- Is_Elaboration_SPARK_Mode --
30480 -------------------------------
30482 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is
30485 (Nkind (N) = N_Pragma
30486 and then Pragma_Name (N) = Name_SPARK_Mode
30487 and then Is_List_Member (N));
30489 -- Pragma SPARK_Mode affects the elaboration of a package body when it
30490 -- appears in the statement part of the body.
30493 Present (Parent (N))
30494 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
30495 and then List_Containing (N) = Statements (Parent (N))
30496 and then Present (Parent (Parent (N)))
30497 and then Nkind (Parent (Parent (N))) = N_Package_Body;
30498 end Is_Elaboration_SPARK_Mode;
30500 -----------------------
30501 -- Is_Enabled_Pragma --
30502 -----------------------
30504 function Is_Enabled_Pragma (Prag : Node_Id) return Boolean is
30508 if Present (Prag) then
30509 Arg := First (Pragma_Argument_Associations (Prag));
30511 if Present (Arg) then
30512 return Is_True (Expr_Value (Get_Pragma_Arg (Arg)));
30514 -- The lack of a Boolean argument automatically enables the pragma
30520 -- The pragma is missing, therefore it is not enabled
30525 end Is_Enabled_Pragma;
30527 -----------------------------------------
30528 -- Is_Non_Significant_Pragma_Reference --
30529 -----------------------------------------
30531 -- This function makes use of the following static table which indicates
30532 -- whether appearance of some name in a given pragma is to be considered
30533 -- as a reference for the purposes of warnings about unreferenced objects.
30535 -- -1 indicates that appearence in any argument is significant
30536 -- 0 indicates that appearance in any argument is not significant
30537 -- +n indicates that appearance as argument n is significant, but all
30538 -- other arguments are not significant
30539 -- 9n arguments from n on are significant, before n insignificant
30541 Sig_Flags : constant array (Pragma_Id) of Int :=
30542 (Pragma_Abort_Defer => -1,
30543 Pragma_Abstract_State => -1,
30544 Pragma_Ada_83 => -1,
30545 Pragma_Ada_95 => -1,
30546 Pragma_Ada_05 => -1,
30547 Pragma_Ada_2005 => -1,
30548 Pragma_Ada_12 => -1,
30549 Pragma_Ada_2012 => -1,
30550 Pragma_Ada_2020 => -1,
30551 Pragma_Aggregate_Individually_Assign => 0,
30552 Pragma_All_Calls_Remote => -1,
30553 Pragma_Allow_Integer_Address => -1,
30554 Pragma_Annotate => 93,
30555 Pragma_Assert => -1,
30556 Pragma_Assert_And_Cut => -1,
30557 Pragma_Assertion_Policy => 0,
30558 Pragma_Assume => -1,
30559 Pragma_Assume_No_Invalid_Values => 0,
30560 Pragma_Async_Readers => 0,
30561 Pragma_Async_Writers => 0,
30562 Pragma_Asynchronous => 0,
30563 Pragma_Atomic => 0,
30564 Pragma_Atomic_Components => 0,
30565 Pragma_Attach_Handler => -1,
30566 Pragma_Attribute_Definition => 92,
30567 Pragma_Check => -1,
30568 Pragma_Check_Float_Overflow => 0,
30569 Pragma_Check_Name => 0,
30570 Pragma_Check_Policy => 0,
30571 Pragma_CPP_Class => 0,
30572 Pragma_CPP_Constructor => 0,
30573 Pragma_CPP_Virtual => 0,
30574 Pragma_CPP_Vtable => 0,
30576 Pragma_C_Pass_By_Copy => 0,
30577 Pragma_Comment => -1,
30578 Pragma_Common_Object => 0,
30579 Pragma_Compile_Time_Error => -1,
30580 Pragma_Compile_Time_Warning => -1,
30581 Pragma_Compiler_Unit => -1,
30582 Pragma_Compiler_Unit_Warning => -1,
30583 Pragma_Complete_Representation => 0,
30584 Pragma_Complex_Representation => 0,
30585 Pragma_Component_Alignment => 0,
30586 Pragma_Constant_After_Elaboration => 0,
30587 Pragma_Contract_Cases => -1,
30588 Pragma_Controlled => 0,
30589 Pragma_Convention => 0,
30590 Pragma_Convention_Identifier => 0,
30591 Pragma_Deadline_Floor => -1,
30592 Pragma_Debug => -1,
30593 Pragma_Debug_Policy => 0,
30594 Pragma_Detect_Blocking => 0,
30595 Pragma_Default_Initial_Condition => -1,
30596 Pragma_Default_Scalar_Storage_Order => 0,
30597 Pragma_Default_Storage_Pool => 0,
30598 Pragma_Depends => -1,
30599 Pragma_Disable_Atomic_Synchronization => 0,
30600 Pragma_Discard_Names => 0,
30601 Pragma_Dispatching_Domain => -1,
30602 Pragma_Effective_Reads => 0,
30603 Pragma_Effective_Writes => 0,
30604 Pragma_Elaborate => 0,
30605 Pragma_Elaborate_All => 0,
30606 Pragma_Elaborate_Body => 0,
30607 Pragma_Elaboration_Checks => 0,
30608 Pragma_Eliminate => 0,
30609 Pragma_Enable_Atomic_Synchronization => 0,
30610 Pragma_Export => -1,
30611 Pragma_Export_Function => -1,
30612 Pragma_Export_Object => -1,
30613 Pragma_Export_Procedure => -1,
30614 Pragma_Export_Value => -1,
30615 Pragma_Export_Valued_Procedure => -1,
30616 Pragma_Extend_System => -1,
30617 Pragma_Extensions_Allowed => 0,
30618 Pragma_Extensions_Visible => 0,
30619 Pragma_External => -1,
30620 Pragma_Favor_Top_Level => 0,
30621 Pragma_External_Name_Casing => 0,
30622 Pragma_Fast_Math => 0,
30623 Pragma_Finalize_Storage_Only => 0,
30625 Pragma_Global => -1,
30626 Pragma_Ident => -1,
30627 Pragma_Ignore_Pragma => 0,
30628 Pragma_Implementation_Defined => -1,
30629 Pragma_Implemented => -1,
30630 Pragma_Implicit_Packing => 0,
30631 Pragma_Import => 93,
30632 Pragma_Import_Function => 0,
30633 Pragma_Import_Object => 0,
30634 Pragma_Import_Procedure => 0,
30635 Pragma_Import_Valued_Procedure => 0,
30636 Pragma_Independent => 0,
30637 Pragma_Independent_Components => 0,
30638 Pragma_Initial_Condition => -1,
30639 Pragma_Initialize_Scalars => 0,
30640 Pragma_Initializes => -1,
30641 Pragma_Inline => 0,
30642 Pragma_Inline_Always => 0,
30643 Pragma_Inline_Generic => 0,
30644 Pragma_Inspection_Point => -1,
30645 Pragma_Interface => 92,
30646 Pragma_Interface_Name => 0,
30647 Pragma_Interrupt_Handler => -1,
30648 Pragma_Interrupt_Priority => -1,
30649 Pragma_Interrupt_State => -1,
30650 Pragma_Invariant => -1,
30651 Pragma_Keep_Names => 0,
30652 Pragma_License => 0,
30653 Pragma_Link_With => -1,
30654 Pragma_Linker_Alias => -1,
30655 Pragma_Linker_Constructor => -1,
30656 Pragma_Linker_Destructor => -1,
30657 Pragma_Linker_Options => -1,
30658 Pragma_Linker_Section => -1,
30660 Pragma_Lock_Free => 0,
30661 Pragma_Locking_Policy => 0,
30662 Pragma_Loop_Invariant => -1,
30663 Pragma_Loop_Optimize => 0,
30664 Pragma_Loop_Variant => -1,
30665 Pragma_Machine_Attribute => -1,
30667 Pragma_Main_Storage => -1,
30668 Pragma_Max_Entry_Queue_Depth => 0,
30669 Pragma_Max_Entry_Queue_Length => 0,
30670 Pragma_Max_Queue_Length => 0,
30671 Pragma_Memory_Size => 0,
30672 Pragma_No_Body => 0,
30673 Pragma_No_Caching => 0,
30674 Pragma_No_Component_Reordering => -1,
30675 Pragma_No_Elaboration_Code_All => 0,
30676 Pragma_No_Heap_Finalization => 0,
30677 Pragma_No_Inline => 0,
30678 Pragma_No_Return => 0,
30679 Pragma_No_Run_Time => -1,
30680 Pragma_No_Strict_Aliasing => -1,
30681 Pragma_No_Tagged_Streams => 0,
30682 Pragma_Normalize_Scalars => 0,
30683 Pragma_Obsolescent => 0,
30684 Pragma_Optimize => 0,
30685 Pragma_Optimize_Alignment => 0,
30686 Pragma_Overflow_Mode => 0,
30687 Pragma_Overriding_Renamings => 0,
30688 Pragma_Ordered => 0,
30691 Pragma_Part_Of => 0,
30692 Pragma_Partition_Elaboration_Policy => 0,
30693 Pragma_Passive => 0,
30694 Pragma_Persistent_BSS => 0,
30695 Pragma_Polling => 0,
30696 Pragma_Prefix_Exception_Messages => 0,
30698 Pragma_Postcondition => -1,
30699 Pragma_Post_Class => -1,
30701 Pragma_Precondition => -1,
30702 Pragma_Predicate => -1,
30703 Pragma_Predicate_Failure => -1,
30704 Pragma_Preelaborable_Initialization => -1,
30705 Pragma_Preelaborate => 0,
30706 Pragma_Pre_Class => -1,
30707 Pragma_Priority => -1,
30708 Pragma_Priority_Specific_Dispatching => 0,
30709 Pragma_Profile => 0,
30710 Pragma_Profile_Warnings => 0,
30711 Pragma_Propagate_Exceptions => 0,
30712 Pragma_Provide_Shift_Operators => 0,
30713 Pragma_Psect_Object => 0,
30715 Pragma_Pure_Function => 0,
30716 Pragma_Queuing_Policy => 0,
30717 Pragma_Rational => 0,
30718 Pragma_Ravenscar => 0,
30719 Pragma_Refined_Depends => -1,
30720 Pragma_Refined_Global => -1,
30721 Pragma_Refined_Post => -1,
30722 Pragma_Refined_State => -1,
30723 Pragma_Relative_Deadline => 0,
30724 Pragma_Rename_Pragma => 0,
30725 Pragma_Remote_Access_Type => -1,
30726 Pragma_Remote_Call_Interface => -1,
30727 Pragma_Remote_Types => -1,
30728 Pragma_Restricted_Run_Time => 0,
30729 Pragma_Restriction_Warnings => 0,
30730 Pragma_Restrictions => 0,
30731 Pragma_Reviewable => -1,
30732 Pragma_Secondary_Stack_Size => -1,
30733 Pragma_Short_Circuit_And_Or => 0,
30734 Pragma_Share_Generic => 0,
30735 Pragma_Shared => 0,
30736 Pragma_Shared_Passive => 0,
30737 Pragma_Short_Descriptors => 0,
30738 Pragma_Simple_Storage_Pool_Type => 0,
30739 Pragma_Source_File_Name => 0,
30740 Pragma_Source_File_Name_Project => 0,
30741 Pragma_Source_Reference => 0,
30742 Pragma_SPARK_Mode => 0,
30743 Pragma_Storage_Size => -1,
30744 Pragma_Storage_Unit => 0,
30745 Pragma_Static_Elaboration_Desired => 0,
30746 Pragma_Stream_Convert => 0,
30747 Pragma_Style_Checks => 0,
30748 Pragma_Subtitle => 0,
30749 Pragma_Suppress => 0,
30750 Pragma_Suppress_Exception_Locations => 0,
30751 Pragma_Suppress_All => 0,
30752 Pragma_Suppress_Debug_Info => 0,
30753 Pragma_Suppress_Initialization => 0,
30754 Pragma_System_Name => 0,
30755 Pragma_Task_Dispatching_Policy => 0,
30756 Pragma_Task_Info => -1,
30757 Pragma_Task_Name => -1,
30758 Pragma_Task_Storage => -1,
30759 Pragma_Test_Case => -1,
30760 Pragma_Thread_Local_Storage => -1,
30761 Pragma_Time_Slice => -1,
30763 Pragma_Type_Invariant => -1,
30764 Pragma_Type_Invariant_Class => -1,
30765 Pragma_Unchecked_Union => 0,
30766 Pragma_Unevaluated_Use_Of_Old => 0,
30767 Pragma_Unimplemented_Unit => 0,
30768 Pragma_Universal_Aliasing => 0,
30769 Pragma_Universal_Data => 0,
30770 Pragma_Unmodified => 0,
30771 Pragma_Unreferenced => 0,
30772 Pragma_Unreferenced_Objects => 0,
30773 Pragma_Unreserve_All_Interrupts => 0,
30774 Pragma_Unsuppress => 0,
30775 Pragma_Unused => 0,
30776 Pragma_Use_VADS_Size => 0,
30777 Pragma_Validity_Checks => 0,
30778 Pragma_Volatile => 0,
30779 Pragma_Volatile_Components => 0,
30780 Pragma_Volatile_Full_Access => 0,
30781 Pragma_Volatile_Function => 0,
30782 Pragma_Warning_As_Error => 0,
30783 Pragma_Warnings => 0,
30784 Pragma_Weak_External => 0,
30785 Pragma_Wide_Character_Encoding => 0,
30786 Unknown_Pragma => 0);
30788 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
30794 function Arg_No return Nat;
30795 -- Returns an integer showing what argument we are in. A value of
30796 -- zero means we are not in any of the arguments.
30802 function Arg_No return Nat is
30807 A := First (Pragma_Argument_Associations (Parent (P)));
30821 -- Start of processing for Non_Significant_Pragma_Reference
30826 if Nkind (P) /= N_Pragma_Argument_Association then
30830 Id := Get_Pragma_Id (Parent (P));
30831 C := Sig_Flags (Id);
30846 return AN < (C - 90);
30852 end Is_Non_Significant_Pragma_Reference;
30854 ------------------------------
30855 -- Is_Pragma_String_Literal --
30856 ------------------------------
30858 -- This function returns true if the corresponding pragma argument is a
30859 -- static string expression. These are the only cases in which string
30860 -- literals can appear as pragma arguments. We also allow a string literal
30861 -- as the first argument to pragma Assert (although it will of course
30862 -- always generate a type error).
30864 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
30865 Pragn : constant Node_Id := Parent (Par);
30866 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
30867 Pname : constant Name_Id := Pragma_Name (Pragn);
30873 N := First (Assoc);
30880 if Pname = Name_Assert then
30883 elsif Pname = Name_Export then
30886 elsif Pname = Name_Ident then
30889 elsif Pname = Name_Import then
30892 elsif Pname = Name_Interface_Name then
30895 elsif Pname = Name_Linker_Alias then
30898 elsif Pname = Name_Linker_Section then
30901 elsif Pname = Name_Machine_Attribute then
30904 elsif Pname = Name_Source_File_Name then
30907 elsif Pname = Name_Source_Reference then
30910 elsif Pname = Name_Title then
30913 elsif Pname = Name_Subtitle then
30919 end Is_Pragma_String_Literal;
30921 ---------------------------
30922 -- Is_Private_SPARK_Mode --
30923 ---------------------------
30925 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is
30928 (Nkind (N) = N_Pragma
30929 and then Pragma_Name (N) = Name_SPARK_Mode
30930 and then Is_List_Member (N));
30932 -- For pragma SPARK_Mode to be private, it has to appear in the private
30933 -- declarations of a package.
30936 Present (Parent (N))
30937 and then Nkind (Parent (N)) = N_Package_Specification
30938 and then List_Containing (N) = Private_Declarations (Parent (N));
30939 end Is_Private_SPARK_Mode;
30941 -------------------------------------
30942 -- Is_Unconstrained_Or_Tagged_Item --
30943 -------------------------------------
30945 function Is_Unconstrained_Or_Tagged_Item
30946 (Item : Entity_Id) return Boolean
30948 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean;
30949 -- Determine whether record type Typ has at least one unconstrained
30952 ---------------------------------
30953 -- Has_Unconstrained_Component --
30954 ---------------------------------
30956 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is
30960 Comp := First_Component (Typ);
30961 while Present (Comp) loop
30962 if Is_Unconstrained_Or_Tagged_Item (Comp) then
30966 Next_Component (Comp);
30970 end Has_Unconstrained_Component;
30974 Typ : constant Entity_Id := Etype (Item);
30976 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
30979 if Is_Tagged_Type (Typ) then
30982 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
30985 elsif Is_Record_Type (Typ) then
30986 if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then
30989 return Has_Unconstrained_Component (Typ);
30992 elsif Is_Private_Type (Typ) and then Has_Discriminants (Typ) then
30998 end Is_Unconstrained_Or_Tagged_Item;
31000 -----------------------------
31001 -- Is_Valid_Assertion_Kind --
31002 -----------------------------
31004 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is
31011 | Name_Assertion_Policy
31012 | Name_Static_Predicate
31013 | Name_Dynamic_Predicate
31018 | Name_Type_Invariant
31019 | Name_uType_Invariant
31023 | Name_Assert_And_Cut
31025 | Name_Contract_Cases
31027 | Name_Default_Initial_Condition
31029 | Name_Initial_Condition
31032 | Name_Loop_Invariant
31033 | Name_Loop_Variant
31034 | Name_Postcondition
31035 | Name_Precondition
31037 | Name_Refined_Post
31038 | Name_Statement_Assertions
31045 end Is_Valid_Assertion_Kind;
31047 --------------------------------------
31048 -- Process_Compilation_Unit_Pragmas --
31049 --------------------------------------
31051 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
31053 -- A special check for pragma Suppress_All, a very strange DEC pragma,
31054 -- strange because it comes at the end of the unit. Rational has the
31055 -- same name for a pragma, but treats it as a program unit pragma, In
31056 -- GNAT we just decide to allow it anywhere at all. If it appeared then
31057 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
31058 -- node, and we insert a pragma Suppress (All_Checks) at the start of
31059 -- the context clause to ensure the correct processing.
31061 if Has_Pragma_Suppress_All (N) then
31062 Prepend_To (Context_Items (N),
31063 Make_Pragma (Sloc (N),
31064 Chars => Name_Suppress,
31065 Pragma_Argument_Associations => New_List (
31066 Make_Pragma_Argument_Association (Sloc (N),
31067 Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
31070 -- Nothing else to do at the current time
31072 end Process_Compilation_Unit_Pragmas;
31074 --------------------------------------------
31075 -- Validate_Compile_Time_Warning_Or_Error --
31076 --------------------------------------------
31078 procedure Validate_Compile_Time_Warning_Or_Error
31082 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
31083 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
31084 Arg2 : constant Node_Id := Next (Arg1);
31086 Pname : constant Name_Id := Pragma_Name_Unmapped (N);
31087 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
31090 Analyze_And_Resolve (Arg1x, Standard_Boolean);
31092 if Compile_Time_Known_Value (Arg1x) then
31093 if Is_True (Expr_Value (Arg1x)) then
31095 -- We have already verified that the second argument is a static
31096 -- string expression. Its string value must be retrieved
31097 -- explicitly if it is a declared constant, otherwise it has
31098 -- been constant-folded previously.
31101 Cent : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
31102 Str : constant String_Id :=
31103 Strval (Expr_Value_S (Get_Pragma_Arg (Arg2)));
31104 Str_Len : constant Nat := String_Length (Str);
31106 Force : constant Boolean :=
31107 Prag_Id = Pragma_Compile_Time_Warning
31108 and then Is_Spec_Name (Unit_Name (Current_Sem_Unit))
31109 and then (Ekind (Cent) /= E_Package
31110 or else not In_Private_Part (Cent));
31111 -- Set True if this is the warning case, and we are in the
31112 -- visible part of a package spec, or in a subprogram spec,
31113 -- in which case we want to force the client to see the
31114 -- warning, even though it is not in the main unit.
31122 -- Loop through segments of message separated by line feeds.
31123 -- We output these segments as separate messages with
31124 -- continuation marks for all but the first.
31129 Error_Msg_Strlen := 0;
31131 -- Loop to copy characters from argument to error message
31135 exit when Ptr > Str_Len;
31136 CC := Get_String_Char (Str, Ptr);
31139 -- Ignore wide chars ??? else store character
31141 if In_Character_Range (CC) then
31142 C := Get_Character (CC);
31143 exit when C = ASCII.LF;
31144 Error_Msg_Strlen := Error_Msg_Strlen + 1;
31145 Error_Msg_String (Error_Msg_Strlen) := C;
31149 -- Here with one line ready to go
31151 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
31153 -- If this is a warning in a spec, then we want clients
31154 -- to see the warning, so mark the message with the
31155 -- special sequence !! to force the warning. In the case
31156 -- of a package spec, we do not force this if we are in
31157 -- the private part of the spec.
31160 if Cont = False then
31161 Error_Msg ("<<~!!", Eloc);
31164 Error_Msg ("\<<~!!", Eloc);
31167 -- Error, rather than warning, or in a body, so we do not
31168 -- need to force visibility for client (error will be
31169 -- output in any case, and this is the situation in which
31170 -- we do not want a client to get a warning, since the
31171 -- warning is in the body or the spec private part).
31174 if Cont = False then
31175 Error_Msg ("<<~", Eloc);
31178 Error_Msg ("\<<~", Eloc);
31182 exit when Ptr > Str_Len;
31187 -- Arg1x is not known at compile time, so possibly issue an error
31188 -- or warning. This can happen only if the pragma's processing
31189 -- was deferred until after the back end is run (see
31190 -- Process_Compile_Time_Warning_Or_Error). Note that the warning
31191 -- control switch applies to only the warning case.
31193 elsif Prag_Id = Pragma_Compile_Time_Error then
31194 Error_Msg_N ("condition is not known at compile time", Arg1x);
31196 elsif Warn_On_Unknown_Compile_Time_Warning then
31197 Error_Msg_N ("??condition is not known at compile time", Arg1x);
31199 end Validate_Compile_Time_Warning_Or_Error;
31201 ------------------------------------
31202 -- Record_Possible_Body_Reference --
31203 ------------------------------------
31205 procedure Record_Possible_Body_Reference
31206 (State_Id : Entity_Id;
31210 Spec_Id : Entity_Id;
31213 -- Ensure that we are dealing with a reference to a state
31215 pragma Assert (Ekind (State_Id) = E_Abstract_State);
31217 -- Climb the tree starting from the reference looking for a package body
31218 -- whose spec declares the referenced state. This criteria automatically
31219 -- excludes references in package specs which are legal. Note that it is
31220 -- not wise to emit an error now as the package body may lack pragma
31221 -- Refined_State or the referenced state may not be mentioned in the
31222 -- refinement. This approach avoids the generation of misleading errors.
31225 while Present (Context) loop
31226 if Nkind (Context) = N_Package_Body then
31227 Spec_Id := Corresponding_Spec (Context);
31229 if Present (Abstract_States (Spec_Id))
31230 and then Contains (Abstract_States (Spec_Id), State_Id)
31232 if No (Body_References (State_Id)) then
31233 Set_Body_References (State_Id, New_Elmt_List);
31236 Append_Elmt (Ref, To => Body_References (State_Id));
31241 Context := Parent (Context);
31243 end Record_Possible_Body_Reference;
31245 ------------------------------------------
31246 -- Relocate_Pragmas_To_Anonymous_Object --
31247 ------------------------------------------
31249 procedure Relocate_Pragmas_To_Anonymous_Object
31250 (Typ_Decl : Node_Id;
31251 Obj_Decl : Node_Id)
31255 Next_Decl : Node_Id;
31258 if Nkind (Typ_Decl) = N_Protected_Type_Declaration then
31259 Def := Protected_Definition (Typ_Decl);
31261 pragma Assert (Nkind (Typ_Decl) = N_Task_Type_Declaration);
31262 Def := Task_Definition (Typ_Decl);
31265 -- The concurrent definition has a visible declaration list. Inspect it
31266 -- and relocate all canidate pragmas.
31268 if Present (Def) and then Present (Visible_Declarations (Def)) then
31269 Decl := First (Visible_Declarations (Def));
31270 while Present (Decl) loop
31272 -- Preserve the following declaration for iteration purposes due
31273 -- to possible relocation of a pragma.
31275 Next_Decl := Next (Decl);
31277 if Nkind (Decl) = N_Pragma
31278 and then Pragma_On_Anonymous_Object_OK (Get_Pragma_Id (Decl))
31281 Insert_After (Obj_Decl, Decl);
31283 -- Skip internally generated code
31285 elsif not Comes_From_Source (Decl) then
31288 -- No candidate pragmas are available for relocation
31297 end Relocate_Pragmas_To_Anonymous_Object;
31299 ------------------------------
31300 -- Relocate_Pragmas_To_Body --
31301 ------------------------------
31303 procedure Relocate_Pragmas_To_Body
31304 (Subp_Body : Node_Id;
31305 Target_Body : Node_Id := Empty)
31307 procedure Relocate_Pragma (Prag : Node_Id);
31308 -- Remove a single pragma from its current list and add it to the
31309 -- declarations of the proper body (either Subp_Body or Target_Body).
31311 ---------------------
31312 -- Relocate_Pragma --
31313 ---------------------
31315 procedure Relocate_Pragma (Prag : Node_Id) is
31320 -- When subprogram stubs or expression functions are involves, the
31321 -- destination declaration list belongs to the proper body.
31323 if Present (Target_Body) then
31324 Target := Target_Body;
31326 Target := Subp_Body;
31329 Decls := Declarations (Target);
31333 Set_Declarations (Target, Decls);
31336 -- Unhook the pragma from its current list
31339 Prepend (Prag, Decls);
31340 end Relocate_Pragma;
31344 Body_Id : constant Entity_Id :=
31345 Defining_Unit_Name (Specification (Subp_Body));
31346 Next_Stmt : Node_Id;
31349 -- Start of processing for Relocate_Pragmas_To_Body
31352 -- Do not process a body that comes from a separate unit as no construct
31353 -- can possibly follow it.
31355 if not Is_List_Member (Subp_Body) then
31358 -- Do not relocate pragmas that follow a stub if the stub does not have
31361 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub
31362 and then No (Target_Body)
31366 -- Do not process internally generated routine _Postconditions
31368 elsif Ekind (Body_Id) = E_Procedure
31369 and then Chars (Body_Id) = Name_uPostconditions
31374 -- Look at what is following the body. We are interested in certain kind
31375 -- of pragmas (either from source or byproducts of expansion) that can
31376 -- apply to a body [stub].
31378 Stmt := Next (Subp_Body);
31379 while Present (Stmt) loop
31381 -- Preserve the following statement for iteration purposes due to a
31382 -- possible relocation of a pragma.
31384 Next_Stmt := Next (Stmt);
31386 -- Move a candidate pragma following the body to the declarations of
31389 if Nkind (Stmt) = N_Pragma
31390 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt))
31393 -- If a source pragma Warnings follows the body, it applies to
31394 -- following statements and does not belong in the body.
31396 if Get_Pragma_Id (Stmt) = Pragma_Warnings
31397 and then Comes_From_Source (Stmt)
31401 Relocate_Pragma (Stmt);
31404 -- Skip internally generated code
31406 elsif not Comes_From_Source (Stmt) then
31409 -- No candidate pragmas are available for relocation
31417 end Relocate_Pragmas_To_Body;
31419 -------------------
31420 -- Resolve_State --
31421 -------------------
31423 procedure Resolve_State (N : Node_Id) is
31428 if Is_Entity_Name (N) and then Present (Entity (N)) then
31429 Func := Entity (N);
31431 -- Handle overloading of state names by functions. Traverse the
31432 -- homonym chain looking for an abstract state.
31434 if Ekind (Func) = E_Function and then Has_Homonym (Func) then
31435 pragma Assert (Is_Overloaded (N));
31437 State := Homonym (Func);
31438 while Present (State) loop
31439 if Ekind (State) = E_Abstract_State then
31441 -- Resolve the overloading by setting the proper entity of
31442 -- the reference to that of the state.
31444 Set_Etype (N, Standard_Void_Type);
31445 Set_Entity (N, State);
31446 Set_Is_Overloaded (N, False);
31448 Generate_Reference (State, N);
31452 State := Homonym (State);
31455 -- A function can never act as a state. If the homonym chain does
31456 -- not contain a corresponding state, then something went wrong in
31457 -- the overloading mechanism.
31459 raise Program_Error;
31464 ----------------------------
31465 -- Rewrite_Assertion_Kind --
31466 ----------------------------
31468 procedure Rewrite_Assertion_Kind
31470 From_Policy : Boolean := False)
31476 if Nkind (N) = N_Attribute_Reference
31477 and then Attribute_Name (N) = Name_Class
31478 and then Nkind (Prefix (N)) = N_Identifier
31480 case Chars (Prefix (N)) is
31487 when Name_Type_Invariant =>
31488 Nam := Name_uType_Invariant;
31490 when Name_Invariant =>
31491 Nam := Name_uInvariant;
31497 -- Recommend standard use of aspect names Pre/Post
31499 elsif Nkind (N) = N_Identifier
31500 and then From_Policy
31501 and then Serious_Errors_Detected = 0
31503 if Chars (N) = Name_Precondition
31504 or else Chars (N) = Name_Postcondition
31506 Error_Msg_N ("Check_Policy is a non-standard pragma??", N);
31508 ("\use Assertion_Policy and aspect names Pre/Post for "
31509 & "Ada2012 conformance?", N);
31515 if Nam /= No_Name then
31516 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam));
31518 end Rewrite_Assertion_Kind;
31526 Dummy := Dummy + 1;
31529 --------------------------------
31530 -- Set_Encoded_Interface_Name --
31531 --------------------------------
31533 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
31534 Str : constant String_Id := Strval (S);
31535 Len : constant Nat := String_Length (Str);
31540 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
31543 -- Stores encoded value of character code CC. The encoding we use an
31544 -- underscore followed by four lower case hex digits.
31550 procedure Encode is
31552 Store_String_Char (Get_Char_Code ('_'));
31554 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
31556 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
31558 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
31560 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
31563 -- Start of processing for Set_Encoded_Interface_Name
31566 -- If first character is asterisk, this is a link name, and we leave it
31567 -- completely unmodified. We also ignore null strings (the latter case
31568 -- happens only in error cases).
31571 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
31573 Set_Interface_Name (E, S);
31578 CC := Get_String_Char (Str, J);
31580 exit when not In_Character_Range (CC);
31582 C := Get_Character (CC);
31584 exit when C /= '_' and then C /= '$'
31585 and then C not in '0' .. '9'
31586 and then C not in 'a' .. 'z'
31587 and then C not in 'A' .. 'Z';
31590 Set_Interface_Name (E, S);
31598 -- Here we need to encode. The encoding we use as follows:
31599 -- three underscores + four hex digits (lower case)
31603 for J in 1 .. String_Length (Str) loop
31604 CC := Get_String_Char (Str, J);
31606 if not In_Character_Range (CC) then
31609 C := Get_Character (CC);
31611 if C = '_' or else C = '$'
31612 or else C in '0' .. '9'
31613 or else C in 'a' .. 'z'
31614 or else C in 'A' .. 'Z'
31616 Store_String_Char (CC);
31623 Set_Interface_Name (E,
31624 Make_String_Literal (Sloc (S),
31625 Strval => End_String));
31627 end Set_Encoded_Interface_Name;
31629 ------------------------
31630 -- Set_Elab_Unit_Name --
31631 ------------------------
31633 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id) is
31638 if Nkind (N) = N_Identifier
31639 and then Nkind (With_Item) = N_Identifier
31641 Set_Entity (N, Entity (With_Item));
31643 elsif Nkind (N) = N_Selected_Component then
31644 Change_Selected_Component_To_Expanded_Name (N);
31645 Set_Entity (N, Entity (With_Item));
31646 Set_Entity (Selector_Name (N), Entity (N));
31648 Pref := Prefix (N);
31649 Scop := Scope (Entity (N));
31650 while Nkind (Pref) = N_Selected_Component loop
31651 Change_Selected_Component_To_Expanded_Name (Pref);
31652 Set_Entity (Selector_Name (Pref), Scop);
31653 Set_Entity (Pref, Scop);
31654 Pref := Prefix (Pref);
31655 Scop := Scope (Scop);
31658 Set_Entity (Pref, Scop);
31661 Generate_Reference (Entity (With_Item), N, Set_Ref => False);
31662 end Set_Elab_Unit_Name;
31664 -----------------------
31665 -- Set_Overflow_Mode --
31666 -----------------------
31668 procedure Set_Overflow_Mode (N : Node_Id) is
31670 function Get_Overflow_Mode (Arg : Node_Id) return Overflow_Mode_Type;
31671 -- Function to process one pragma argument, Arg
31673 -----------------------
31674 -- Get_Overflow_Mode --
31675 -----------------------
31677 function Get_Overflow_Mode (Arg : Node_Id) return Overflow_Mode_Type is
31678 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
31681 if Chars (Argx) = Name_Strict then
31684 elsif Chars (Argx) = Name_Minimized then
31687 elsif Chars (Argx) = Name_Eliminated then
31691 raise Program_Error;
31693 end Get_Overflow_Mode;
31697 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
31698 Arg2 : constant Node_Id := Next (Arg1);
31700 -- Start of processing for Set_Overflow_Mode
31703 -- Process first argument
31705 Scope_Suppress.Overflow_Mode_General :=
31706 Get_Overflow_Mode (Arg1);
31708 -- Case of only one argument
31711 Scope_Suppress.Overflow_Mode_Assertions :=
31712 Scope_Suppress.Overflow_Mode_General;
31714 -- Case of two arguments present
31717 Scope_Suppress.Overflow_Mode_Assertions :=
31718 Get_Overflow_Mode (Arg2);
31720 end Set_Overflow_Mode;
31722 -------------------
31723 -- Test_Case_Arg --
31724 -------------------
31726 function Test_Case_Arg
31729 From_Aspect : Boolean := False) return Node_Id
31731 Aspect : constant Node_Id := Corresponding_Aspect (Prag);
31736 pragma Assert (Nam_In (Arg_Nam, Name_Ensures,
31741 -- The caller requests the aspect argument
31743 if From_Aspect then
31744 if Present (Aspect)
31745 and then Nkind (Expression (Aspect)) = N_Aggregate
31747 Args := Expression (Aspect);
31749 -- "Name" and "Mode" may appear without an identifier as a
31750 -- positional association.
31752 if Present (Expressions (Args)) then
31753 Arg := First (Expressions (Args));
31755 if Present (Arg) and then Arg_Nam = Name_Name then
31763 if Present (Arg) and then Arg_Nam = Name_Mode then
31768 -- Some or all arguments may appear as component associatons
31770 if Present (Component_Associations (Args)) then
31771 Arg := First (Component_Associations (Args));
31772 while Present (Arg) loop
31773 if Chars (First (Choices (Arg))) = Arg_Nam then
31782 -- Otherwise retrieve the argument directly from the pragma
31785 Arg := First (Pragma_Argument_Associations (Prag));
31787 if Present (Arg) and then Arg_Nam = Name_Name then
31791 -- Skip argument "Name"
31795 if Present (Arg) and then Arg_Nam = Name_Mode then
31799 -- Skip argument "Mode"
31803 -- Arguments "Requires" and "Ensures" are optional and may not be
31806 while Present (Arg) loop
31807 if Chars (Arg) = Arg_Nam then
31818 --------------------------------------------
31819 -- Defer_Compile_Time_Warning_Error_To_BE --
31820 --------------------------------------------
31822 procedure Defer_Compile_Time_Warning_Error_To_BE (N : Node_Id) is
31823 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
31825 Compile_Time_Warnings_Errors.Append
31826 (New_Val => CTWE_Entry'(Eloc => Sloc (Arg1),
31827 Scope => Current_Scope,
31830 -- If the Boolean expression contains T'Size, and we're not in the main
31831 -- unit being compiled, then we need to copy the pragma into the main
31832 -- unit, because otherwise T'Size might never be computed, leaving it
31835 if not In_Extended_Main_Code_Unit (N) then
31836 Insert_Library_Level_Action (New_Copy_Tree (N));
31838 end Defer_Compile_Time_Warning_Error_To_BE;
31840 ------------------------------------------
31841 -- Validate_Compile_Time_Warning_Errors --
31842 ------------------------------------------
31844 procedure Validate_Compile_Time_Warning_Errors is
31845 procedure Set_Scope (S : Entity_Id);
31846 -- Install all enclosing scopes of S along with S itself
31848 procedure Unset_Scope (S : Entity_Id);
31849 -- Uninstall all enclosing scopes of S along with S itself
31855 procedure Set_Scope (S : Entity_Id) is
31857 if S /= Standard_Standard then
31858 Set_Scope (Scope (S));
31868 procedure Unset_Scope (S : Entity_Id) is
31870 if S /= Standard_Standard then
31871 Unset_Scope (Scope (S));
31877 -- Start of processing for Validate_Compile_Time_Warning_Errors
31880 Expander_Mode_Save_And_Set (False);
31881 In_Compile_Time_Warning_Or_Error := True;
31883 for N in Compile_Time_Warnings_Errors.First ..
31884 Compile_Time_Warnings_Errors.Last
31887 T : CTWE_Entry renames Compile_Time_Warnings_Errors.Table (N);
31890 Set_Scope (T.Scope);
31891 Reset_Analyzed_Flags (T.Prag);
31892 Validate_Compile_Time_Warning_Or_Error (T.Prag, T.Eloc);
31893 Unset_Scope (T.Scope);
31897 In_Compile_Time_Warning_Or_Error := False;
31898 Expander_Mode_Restore;
31899 end Validate_Compile_Time_Warning_Errors;