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, or Ravenscar. N is the corresponding pragma node,
4334 -- which is used for error messages on any constructs violating the
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.
8024 if Is_Record_Type (E) and then Is_Base_Type (E) then
8029 Comp := First_Component (E);
8030 while Present (Comp) loop
8031 if Present (Etype (Comp))
8032 and then Ekind_In (Etype (Comp),
8033 E_Anonymous_Access_Type,
8034 E_Anonymous_Access_Subprogram_Type)
8035 and then not Has_Convention_Pragma (Comp)
8037 Set_Convention (Comp, C);
8040 Next_Component (Comp);
8045 -- Deal with incomplete/private type case, where underlying type
8046 -- is available, so set convention of that underlying type.
8048 if Is_Incomplete_Or_Private_Type (E)
8049 and then Present (Underlying_Type (E))
8051 Set_Convention (Underlying_Type (E), C);
8052 Set_Has_Convention_Pragma (Underlying_Type (E), True);
8055 -- A class-wide type should inherit the convention of the specific
8056 -- root type (although this isn't specified clearly by the RM).
8058 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
8059 Set_Convention (Class_Wide_Type (E), C);
8062 -- If the entity is a record type, then check for special case of
8063 -- C_Pass_By_Copy, which is treated the same as C except that the
8064 -- special record flag is set. This convention is only permitted
8065 -- on record types (see AI95-00131).
8067 if Cname = Name_C_Pass_By_Copy then
8068 if Is_Record_Type (E) then
8069 Set_C_Pass_By_Copy (Base_Type (E));
8070 elsif Is_Incomplete_Or_Private_Type (E)
8071 and then Is_Record_Type (Underlying_Type (E))
8073 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
8076 ("C_Pass_By_Copy convention allowed only for record type",
8081 -- If the entity is a derived boolean type, check for the special
8082 -- case of convention C, C++, or Fortran, where we consider any
8083 -- nonzero value to represent true.
8085 if Is_Discrete_Type (E)
8086 and then Root_Type (Etype (E)) = Standard_Boolean
8092 C = Convention_Fortran)
8094 Set_Nonzero_Is_True (Base_Type (E));
8096 end Set_Convention_From_Pragma;
8100 Comp_Unit : Unit_Number_Type;
8105 -- Start of processing for Process_Convention
8108 Check_At_Least_N_Arguments (2);
8109 Check_Optional_Identifier (Arg1, Name_Convention);
8110 Check_Arg_Is_Identifier (Arg1);
8111 Cname := Chars (Get_Pragma_Arg (Arg1));
8113 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
8114 -- tested again below to set the critical flag).
8116 if Cname = Name_C_Pass_By_Copy then
8119 -- Otherwise we must have something in the standard convention list
8121 elsif Is_Convention_Name (Cname) then
8122 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
8124 -- Otherwise warn on unrecognized convention
8127 if Warn_On_Export_Import then
8129 ("??unrecognized convention name, C assumed",
8130 Get_Pragma_Arg (Arg1));
8136 Check_Optional_Identifier (Arg2, Name_Entity);
8137 Check_Arg_Is_Local_Name (Arg2);
8139 Id := Get_Pragma_Arg (Arg2);
8142 if not Is_Entity_Name (Id) then
8143 Error_Pragma_Arg ("entity name required", Arg2);
8148 -- Set entity to return
8152 -- Ada_Pass_By_Copy special checking
8154 if C = Convention_Ada_Pass_By_Copy then
8155 if not Is_First_Subtype (E) then
8157 ("convention `Ada_Pass_By_Copy` only allowed for types",
8161 if Is_By_Reference_Type (E) then
8163 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
8167 -- Ada_Pass_By_Reference special checking
8169 elsif C = Convention_Ada_Pass_By_Reference then
8170 if not Is_First_Subtype (E) then
8172 ("convention `Ada_Pass_By_Reference` only allowed for types",
8176 if Is_By_Copy_Type (E) then
8178 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
8183 -- Go to renamed subprogram if present, since convention applies to
8184 -- the actual renamed entity, not to the renaming entity. If the
8185 -- subprogram is inherited, go to parent subprogram.
8187 if Is_Subprogram (E)
8188 and then Present (Alias (E))
8190 if Nkind (Parent (Declaration_Node (E))) =
8191 N_Subprogram_Renaming_Declaration
8193 if Scope (E) /= Scope (Alias (E)) then
8195 ("cannot apply pragma% to non-local entity&#", E);
8200 elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
8201 N_Private_Extension_Declaration)
8202 and then Scope (E) = Scope (Alias (E))
8206 -- Return the parent subprogram the entity was inherited from
8212 -- Check that we are not applying this to a specless body. Relax this
8213 -- check if Relaxed_RM_Semantics to accommodate other Ada compilers.
8215 if Is_Subprogram (E)
8216 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
8217 and then not Relaxed_RM_Semantics
8220 ("pragma% requires separate spec and must come before body");
8223 -- Check that we are not applying this to a named constant
8225 if Ekind_In (E, E_Named_Integer, E_Named_Real) then
8226 Error_Msg_Name_1 := Pname;
8228 ("cannot apply pragma% to named constant!",
8229 Get_Pragma_Arg (Arg2));
8231 ("\supply appropriate type for&!", Arg2);
8234 if Ekind (E) = E_Enumeration_Literal then
8235 Error_Pragma ("enumeration literal not allowed for pragma%");
8238 -- Check for rep item appearing too early or too late
8240 if Etype (E) = Any_Type
8241 or else Rep_Item_Too_Early (E, N)
8245 elsif Present (Underlying_Type (E)) then
8246 E := Underlying_Type (E);
8249 if Rep_Item_Too_Late (E, N) then
8253 if Has_Convention_Pragma (E) then
8254 Diagnose_Multiple_Pragmas (E);
8256 elsif Convention (E) = Convention_Protected
8257 or else Ekind (Scope (E)) = E_Protected_Type
8260 ("a protected operation cannot be given a different convention",
8264 -- For Intrinsic, a subprogram is required
8266 if C = Convention_Intrinsic
8267 and then not Is_Subprogram_Or_Generic_Subprogram (E)
8269 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
8271 if not (Is_Type (E) and then Relaxed_RM_Semantics) then
8273 ("second argument of pragma% must be a subprogram", Arg2);
8277 -- Deal with non-subprogram cases
8279 if not Is_Subprogram_Or_Generic_Subprogram (E) then
8280 Set_Convention_From_Pragma (E);
8284 -- The pragma must apply to a first subtype, but it can also
8285 -- apply to a generic type in a generic formal part, in which
8286 -- case it will also appear in the corresponding instance.
8288 if Is_Generic_Type (E) or else In_Instance then
8291 Check_First_Subtype (Arg2);
8294 Set_Convention_From_Pragma (Base_Type (E));
8296 -- For access subprograms, we must set the convention on the
8297 -- internally generated directly designated type as well.
8299 if Ekind (E) = E_Access_Subprogram_Type then
8300 Set_Convention_From_Pragma (Directly_Designated_Type (E));
8304 -- For the subprogram case, set proper convention for all homonyms
8305 -- in same scope and the same declarative part, i.e. the same
8306 -- compilation unit.
8309 Comp_Unit := Get_Source_Unit (E);
8310 Set_Convention_From_Pragma (E);
8312 -- Treat a pragma Import as an implicit body, and pragma import
8313 -- as implicit reference (for navigation in GNAT Studio).
8315 if Prag_Id = Pragma_Import then
8316 Generate_Reference (E, Id, 'b');
8318 -- For exported entities we restrict the generation of references
8319 -- to entities exported to foreign languages since entities
8320 -- exported to Ada do not provide further information to
8321 -- GNAT Studio and add undesired references to the output of the
8324 elsif Prag_Id = Pragma_Export
8325 and then Convention (E) /= Convention_Ada
8327 Generate_Reference (E, Id, 'i');
8330 -- If the pragma comes from an aspect, it only applies to the
8331 -- given entity, not its homonyms.
8333 if From_Aspect_Specification (N) then
8334 if C = Convention_Intrinsic
8335 and then Nkind (Ent) = N_Defining_Operator_Symbol
8337 if Is_Fixed_Point_Type (Etype (Ent))
8338 or else Is_Fixed_Point_Type (Etype (First_Entity (Ent)))
8339 or else Is_Fixed_Point_Type (Etype (Last_Entity (Ent)))
8342 ("no intrinsic operator available for this fixed-point "
8345 ("\use expression functions with the desired "
8346 & "conversions made explicit", N);
8353 -- Otherwise Loop through the homonyms of the pragma argument's
8354 -- entity, an apply convention to those in the current scope.
8360 exit when No (E1) or else Scope (E1) /= Current_Scope;
8362 -- Ignore entry for which convention is already set
8364 if Has_Convention_Pragma (E1) then
8368 if Is_Subprogram (E1)
8369 and then Nkind (Parent (Declaration_Node (E1))) =
8371 and then not Relaxed_RM_Semantics
8373 Set_Has_Completion (E); -- to prevent cascaded error
8375 ("pragma% requires separate spec and must come before "
8379 -- Do not set the pragma on inherited operations or on formal
8382 if Comes_From_Source (E1)
8383 and then Comp_Unit = Get_Source_Unit (E1)
8384 and then not Is_Formal_Subprogram (E1)
8385 and then Nkind (Original_Node (Parent (E1))) /=
8386 N_Full_Type_Declaration
8388 if Present (Alias (E1))
8389 and then Scope (E1) /= Scope (Alias (E1))
8392 ("cannot apply pragma% to non-local entity& declared#",
8396 Set_Convention_From_Pragma (E1);
8398 if Prag_Id = Pragma_Import then
8399 Generate_Reference (E1, Id, 'b');
8407 end Process_Convention;
8409 ----------------------------------------
8410 -- Process_Disable_Enable_Atomic_Sync --
8411 ----------------------------------------
8413 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
8415 Check_No_Identifiers;
8416 Check_At_Most_N_Arguments (1);
8418 -- Modeled internally as
8419 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
8424 Pragma_Argument_Associations => New_List (
8425 Make_Pragma_Argument_Association (Loc,
8427 Make_Identifier (Loc, Name_Atomic_Synchronization)))));
8429 if Present (Arg1) then
8430 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
8434 end Process_Disable_Enable_Atomic_Sync;
8436 -------------------------------------------------
8437 -- Process_Extended_Import_Export_Internal_Arg --
8438 -------------------------------------------------
8440 procedure Process_Extended_Import_Export_Internal_Arg
8441 (Arg_Internal : Node_Id := Empty)
8444 if No (Arg_Internal) then
8445 Error_Pragma ("Internal parameter required for pragma%");
8448 if Nkind (Arg_Internal) = N_Identifier then
8451 elsif Nkind (Arg_Internal) = N_Operator_Symbol
8452 and then (Prag_Id = Pragma_Import_Function
8454 Prag_Id = Pragma_Export_Function)
8460 ("wrong form for Internal parameter for pragma%", Arg_Internal);
8463 Check_Arg_Is_Local_Name (Arg_Internal);
8464 end Process_Extended_Import_Export_Internal_Arg;
8466 --------------------------------------------------
8467 -- Process_Extended_Import_Export_Object_Pragma --
8468 --------------------------------------------------
8470 procedure Process_Extended_Import_Export_Object_Pragma
8471 (Arg_Internal : Node_Id;
8472 Arg_External : Node_Id;
8478 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
8479 Def_Id := Entity (Arg_Internal);
8481 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
8483 ("pragma% must designate an object", Arg_Internal);
8486 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
8488 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
8491 ("previous Common/Psect_Object applies, pragma % not permitted",
8495 if Rep_Item_Too_Late (Def_Id, N) then
8499 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
8501 if Present (Arg_Size) then
8502 Check_Arg_Is_External_Name (Arg_Size);
8505 -- Export_Object case
8507 if Prag_Id = Pragma_Export_Object then
8508 if not Is_Library_Level_Entity (Def_Id) then
8510 ("argument for pragma% must be library level entity",
8514 if Ekind (Current_Scope) = E_Generic_Package then
8515 Error_Pragma ("pragma& cannot appear in a generic unit");
8518 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
8520 ("exported object must have compile time known size",
8524 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
8525 Error_Msg_N ("??duplicate Export_Object pragma", N);
8527 Set_Exported (Def_Id, Arg_Internal);
8530 -- Import_Object case
8533 if Is_Concurrent_Type (Etype (Def_Id)) then
8535 ("cannot use pragma% for task/protected object",
8539 if Ekind (Def_Id) = E_Constant then
8541 ("cannot import a constant", Arg_Internal);
8544 if Warn_On_Export_Import
8545 and then Has_Discriminants (Etype (Def_Id))
8548 ("imported value must be initialized??", Arg_Internal);
8551 if Warn_On_Export_Import
8552 and then Is_Access_Type (Etype (Def_Id))
8555 ("cannot import object of an access type??", Arg_Internal);
8558 if Warn_On_Export_Import
8559 and then Is_Imported (Def_Id)
8561 Error_Msg_N ("??duplicate Import_Object pragma", N);
8563 -- Check for explicit initialization present. Note that an
8564 -- initialization generated by the code generator, e.g. for an
8565 -- access type, does not count here.
8567 elsif Present (Expression (Parent (Def_Id)))
8570 (Original_Node (Expression (Parent (Def_Id))))
8572 Error_Msg_Sloc := Sloc (Def_Id);
8574 ("imported entities cannot be initialized (RM B.1(24))",
8575 "\no initialization allowed for & declared#", Arg1);
8577 Set_Imported (Def_Id);
8578 Note_Possible_Modification (Arg_Internal, Sure => False);
8581 end Process_Extended_Import_Export_Object_Pragma;
8583 ------------------------------------------------------
8584 -- Process_Extended_Import_Export_Subprogram_Pragma --
8585 ------------------------------------------------------
8587 procedure Process_Extended_Import_Export_Subprogram_Pragma
8588 (Arg_Internal : Node_Id;
8589 Arg_External : Node_Id;
8590 Arg_Parameter_Types : Node_Id;
8591 Arg_Result_Type : Node_Id := Empty;
8592 Arg_Mechanism : Node_Id;
8593 Arg_Result_Mechanism : Node_Id := Empty)
8599 Ambiguous : Boolean;
8602 function Same_Base_Type
8604 Formal : Entity_Id) return Boolean;
8605 -- Determines if Ptype references the type of Formal. Note that only
8606 -- the base types need to match according to the spec. Ptype here is
8607 -- the argument from the pragma, which is either a type name, or an
8608 -- access attribute.
8610 --------------------
8611 -- Same_Base_Type --
8612 --------------------
8614 function Same_Base_Type
8616 Formal : Entity_Id) return Boolean
8618 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
8622 -- Case where pragma argument is typ'Access
8624 if Nkind (Ptype) = N_Attribute_Reference
8625 and then Attribute_Name (Ptype) = Name_Access
8627 Pref := Prefix (Ptype);
8630 if not Is_Entity_Name (Pref)
8631 or else Entity (Pref) = Any_Type
8636 -- We have a match if the corresponding argument is of an
8637 -- anonymous access type, and its designated type matches the
8638 -- type of the prefix of the access attribute
8640 return Ekind (Ftyp) = E_Anonymous_Access_Type
8641 and then Base_Type (Entity (Pref)) =
8642 Base_Type (Etype (Designated_Type (Ftyp)));
8644 -- Case where pragma argument is a type name
8649 if not Is_Entity_Name (Ptype)
8650 or else Entity (Ptype) = Any_Type
8655 -- We have a match if the corresponding argument is of the type
8656 -- given in the pragma (comparing base types)
8658 return Base_Type (Entity (Ptype)) = Ftyp;
8662 -- Start of processing for
8663 -- Process_Extended_Import_Export_Subprogram_Pragma
8666 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
8670 -- Loop through homonyms (overloadings) of the entity
8672 Hom_Id := Entity (Arg_Internal);
8673 while Present (Hom_Id) loop
8674 Def_Id := Get_Base_Subprogram (Hom_Id);
8676 -- We need a subprogram in the current scope
8678 if not Is_Subprogram (Def_Id)
8679 or else Scope (Def_Id) /= Current_Scope
8686 -- Pragma cannot apply to subprogram body
8688 if Is_Subprogram (Def_Id)
8689 and then Nkind (Parent (Declaration_Node (Def_Id))) =
8693 ("pragma% requires separate spec and must come before "
8697 -- Test result type if given, note that the result type
8698 -- parameter can only be present for the function cases.
8700 if Present (Arg_Result_Type)
8701 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
8705 elsif Etype (Def_Id) /= Standard_Void_Type
8706 and then Nam_In (Pname, Name_Export_Procedure,
8707 Name_Import_Procedure)
8711 -- Test parameter types if given. Note that this parameter has
8712 -- not been analyzed (and must not be, since it is semantic
8713 -- nonsense), so we get it as the parser left it.
8715 elsif Present (Arg_Parameter_Types) then
8716 Check_Matching_Types : declare
8721 Formal := First_Formal (Def_Id);
8723 if Nkind (Arg_Parameter_Types) = N_Null then
8724 if Present (Formal) then
8728 -- A list of one type, e.g. (List) is parsed as a
8729 -- parenthesized expression.
8731 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
8732 and then Paren_Count (Arg_Parameter_Types) = 1
8735 or else Present (Next_Formal (Formal))
8740 Same_Base_Type (Arg_Parameter_Types, Formal);
8743 -- A list of more than one type is parsed as a aggregate
8745 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
8746 and then Paren_Count (Arg_Parameter_Types) = 0
8748 Ptype := First (Expressions (Arg_Parameter_Types));
8749 while Present (Ptype) or else Present (Formal) loop
8752 or else not Same_Base_Type (Ptype, Formal)
8757 Next_Formal (Formal);
8762 -- Anything else is of the wrong form
8766 ("wrong form for Parameter_Types parameter",
8767 Arg_Parameter_Types);
8769 end Check_Matching_Types;
8772 -- Match is now False if the entry we found did not match
8773 -- either a supplied Parameter_Types or Result_Types argument
8779 -- Ambiguous case, the flag Ambiguous shows if we already
8780 -- detected this and output the initial messages.
8783 if not Ambiguous then
8785 Error_Msg_Name_1 := Pname;
8787 ("pragma% does not uniquely identify subprogram!",
8789 Error_Msg_Sloc := Sloc (Ent);
8790 Error_Msg_N ("matching subprogram #!", N);
8794 Error_Msg_Sloc := Sloc (Def_Id);
8795 Error_Msg_N ("matching subprogram #!", N);
8800 Hom_Id := Homonym (Hom_Id);
8803 -- See if we found an entry
8806 if not Ambiguous then
8807 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
8809 ("pragma% cannot be given for generic subprogram");
8812 ("pragma% does not identify local subprogram");
8819 -- Import pragmas must be for imported entities
8821 if Prag_Id = Pragma_Import_Function
8823 Prag_Id = Pragma_Import_Procedure
8825 Prag_Id = Pragma_Import_Valued_Procedure
8827 if not Is_Imported (Ent) then
8829 ("pragma Import or Interface must precede pragma%");
8832 -- Here we have the Export case which can set the entity as exported
8834 -- But does not do so if the specified external name is null, since
8835 -- that is taken as a signal in DEC Ada 83 (with which we want to be
8836 -- compatible) to request no external name.
8838 elsif Nkind (Arg_External) = N_String_Literal
8839 and then String_Length (Strval (Arg_External)) = 0
8843 -- In all other cases, set entity as exported
8846 Set_Exported (Ent, Arg_Internal);
8849 -- Special processing for Valued_Procedure cases
8851 if Prag_Id = Pragma_Import_Valued_Procedure
8853 Prag_Id = Pragma_Export_Valued_Procedure
8855 Formal := First_Formal (Ent);
8858 Error_Pragma ("at least one parameter required for pragma%");
8860 elsif Ekind (Formal) /= E_Out_Parameter then
8861 Error_Pragma ("first parameter must have mode out for pragma%");
8864 Set_Is_Valued_Procedure (Ent);
8868 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
8870 -- Process Result_Mechanism argument if present. We have already
8871 -- checked that this is only allowed for the function case.
8873 if Present (Arg_Result_Mechanism) then
8874 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
8877 -- Process Mechanism parameter if present. Note that this parameter
8878 -- is not analyzed, and must not be analyzed since it is semantic
8879 -- nonsense, so we get it in exactly as the parser left it.
8881 if Present (Arg_Mechanism) then
8889 -- A single mechanism association without a formal parameter
8890 -- name is parsed as a parenthesized expression. All other
8891 -- cases are parsed as aggregates, so we rewrite the single
8892 -- parameter case as an aggregate for consistency.
8894 if Nkind (Arg_Mechanism) /= N_Aggregate
8895 and then Paren_Count (Arg_Mechanism) = 1
8897 Rewrite (Arg_Mechanism,
8898 Make_Aggregate (Sloc (Arg_Mechanism),
8899 Expressions => New_List (
8900 Relocate_Node (Arg_Mechanism))));
8903 -- Case of only mechanism name given, applies to all formals
8905 if Nkind (Arg_Mechanism) /= N_Aggregate then
8906 Formal := First_Formal (Ent);
8907 while Present (Formal) loop
8908 Set_Mechanism_Value (Formal, Arg_Mechanism);
8909 Next_Formal (Formal);
8912 -- Case of list of mechanism associations given
8915 if Null_Record_Present (Arg_Mechanism) then
8917 ("inappropriate form for Mechanism parameter",
8921 -- Deal with positional ones first
8923 Formal := First_Formal (Ent);
8925 if Present (Expressions (Arg_Mechanism)) then
8926 Mname := First (Expressions (Arg_Mechanism));
8927 while Present (Mname) loop
8930 ("too many mechanism associations", Mname);
8933 Set_Mechanism_Value (Formal, Mname);
8934 Next_Formal (Formal);
8939 -- Deal with named entries
8941 if Present (Component_Associations (Arg_Mechanism)) then
8942 Massoc := First (Component_Associations (Arg_Mechanism));
8943 while Present (Massoc) loop
8944 Choice := First (Choices (Massoc));
8946 if Nkind (Choice) /= N_Identifier
8947 or else Present (Next (Choice))
8950 ("incorrect form for mechanism association",
8954 Formal := First_Formal (Ent);
8958 ("parameter name & not present", Choice);
8961 if Chars (Choice) = Chars (Formal) then
8963 (Formal, Expression (Massoc));
8965 -- Set entity on identifier for proper tree
8968 Set_Entity (Choice, Formal);
8973 Next_Formal (Formal);
8982 end Process_Extended_Import_Export_Subprogram_Pragma;
8984 --------------------------
8985 -- Process_Generic_List --
8986 --------------------------
8988 procedure Process_Generic_List is
8993 Check_No_Identifiers;
8994 Check_At_Least_N_Arguments (1);
8996 -- Check all arguments are names of generic units or instances
8999 while Present (Arg) loop
9000 Exp := Get_Pragma_Arg (Arg);
9003 if not Is_Entity_Name (Exp)
9005 (not Is_Generic_Instance (Entity (Exp))
9007 not Is_Generic_Unit (Entity (Exp)))
9010 ("pragma% argument must be name of generic unit/instance",
9016 end Process_Generic_List;
9018 ------------------------------------
9019 -- Process_Import_Predefined_Type --
9020 ------------------------------------
9022 procedure Process_Import_Predefined_Type is
9023 Loc : constant Source_Ptr := Sloc (N);
9025 Ftyp : Node_Id := Empty;
9031 Nam := String_To_Name (Strval (Expression (Arg3)));
9033 Elmt := First_Elmt (Predefined_Float_Types);
9034 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
9038 Ftyp := Node (Elmt);
9040 if Present (Ftyp) then
9042 -- Don't build a derived type declaration, because predefined C
9043 -- types have no declaration anywhere, so cannot really be named.
9044 -- Instead build a full type declaration, starting with an
9045 -- appropriate type definition is built
9047 if Is_Floating_Point_Type (Ftyp) then
9048 Def := Make_Floating_Point_Definition (Loc,
9049 Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
9050 Make_Real_Range_Specification (Loc,
9051 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
9052 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
9054 -- Should never have a predefined type we cannot handle
9057 raise Program_Error;
9060 -- Build and insert a Full_Type_Declaration, which will be
9061 -- analyzed as soon as this list entry has been analyzed.
9063 Decl := Make_Full_Type_Declaration (Loc,
9064 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
9065 Type_Definition => Def);
9067 Insert_After (N, Decl);
9068 Mark_Rewrite_Insertion (Decl);
9071 Error_Pragma_Arg ("no matching type found for pragma%", Arg2);
9073 end Process_Import_Predefined_Type;
9075 ---------------------------------
9076 -- Process_Import_Or_Interface --
9077 ---------------------------------
9079 procedure Process_Import_Or_Interface is
9085 -- In Relaxed_RM_Semantics, support old Ada 83 style:
9086 -- pragma Import (Entity, "external name");
9088 if Relaxed_RM_Semantics
9089 and then Arg_Count = 2
9090 and then Prag_Id = Pragma_Import
9091 and then Nkind (Expression (Arg2)) = N_String_Literal
9094 Def_Id := Get_Pragma_Arg (Arg1);
9097 if not Is_Entity_Name (Def_Id) then
9098 Error_Pragma_Arg ("entity name required", Arg1);
9101 Def_Id := Entity (Def_Id);
9102 Kill_Size_Check_Code (Def_Id);
9103 Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False);
9106 Process_Convention (C, Def_Id);
9108 -- A pragma that applies to a Ghost entity becomes Ghost for the
9109 -- purposes of legality checks and removal of ignored Ghost code.
9111 Mark_Ghost_Pragma (N, Def_Id);
9112 Kill_Size_Check_Code (Def_Id);
9113 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
9116 -- Various error checks
9118 if Ekind_In (Def_Id, E_Variable, E_Constant) then
9120 -- We do not permit Import to apply to a renaming declaration
9122 if Present (Renamed_Object (Def_Id)) then
9124 ("pragma% not allowed for object renaming", Arg2);
9126 -- User initialization is not allowed for imported object, but
9127 -- the object declaration may contain a default initialization,
9128 -- that will be discarded. Note that an explicit initialization
9129 -- only counts if it comes from source, otherwise it is simply
9130 -- the code generator making an implicit initialization explicit.
9132 elsif Present (Expression (Parent (Def_Id)))
9133 and then Comes_From_Source
9134 (Original_Node (Expression (Parent (Def_Id))))
9136 -- Set imported flag to prevent cascaded errors
9138 Set_Is_Imported (Def_Id);
9140 Error_Msg_Sloc := Sloc (Def_Id);
9142 ("no initialization allowed for declaration of& #",
9143 "\imported entities cannot be initialized (RM B.1(24))",
9147 -- If the pragma comes from an aspect specification the
9148 -- Is_Imported flag has already been set.
9150 if not From_Aspect_Specification (N) then
9151 Set_Imported (Def_Id);
9154 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
9156 -- Note that we do not set Is_Public here. That's because we
9157 -- only want to set it if there is no address clause, and we
9158 -- don't know that yet, so we delay that processing till
9161 -- pragma Import completes deferred constants
9163 if Ekind (Def_Id) = E_Constant then
9164 Set_Has_Completion (Def_Id);
9167 -- It is not possible to import a constant of an unconstrained
9168 -- array type (e.g. string) because there is no simple way to
9169 -- write a meaningful subtype for it.
9171 if Is_Array_Type (Etype (Def_Id))
9172 and then not Is_Constrained (Etype (Def_Id))
9175 ("imported constant& must have a constrained subtype",
9180 elsif Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
9182 -- If the name is overloaded, pragma applies to all of the denoted
9183 -- entities in the same declarative part, unless the pragma comes
9184 -- from an aspect specification or was generated by the compiler
9185 -- (such as for pragma Provide_Shift_Operators).
9188 while Present (Hom_Id) loop
9190 Def_Id := Get_Base_Subprogram (Hom_Id);
9192 -- Ignore inherited subprograms because the pragma will apply
9193 -- to the parent operation, which is the one called.
9195 if Is_Overloadable (Def_Id)
9196 and then Present (Alias (Def_Id))
9200 -- If it is not a subprogram, it must be in an outer scope and
9201 -- pragma does not apply.
9203 elsif not Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
9206 -- The pragma does not apply to primitives of interfaces
9208 elsif Is_Dispatching_Operation (Def_Id)
9209 and then Present (Find_Dispatching_Type (Def_Id))
9210 and then Is_Interface (Find_Dispatching_Type (Def_Id))
9214 -- Verify that the homonym is in the same declarative part (not
9215 -- just the same scope). If the pragma comes from an aspect
9216 -- specification we know that it is part of the declaration.
9218 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
9219 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
9220 and then not From_Aspect_Specification (N)
9225 -- If the pragma comes from an aspect specification the
9226 -- Is_Imported flag has already been set.
9228 if not From_Aspect_Specification (N) then
9229 Set_Imported (Def_Id);
9232 -- Reject an Import applied to an abstract subprogram
9234 if Is_Subprogram (Def_Id)
9235 and then Is_Abstract_Subprogram (Def_Id)
9237 Error_Msg_Sloc := Sloc (Def_Id);
9239 ("cannot import abstract subprogram& declared#",
9243 -- Special processing for Convention_Intrinsic
9245 if C = Convention_Intrinsic then
9247 -- Link_Name argument not allowed for intrinsic
9251 Set_Is_Intrinsic_Subprogram (Def_Id);
9253 -- If no external name is present, then check that this
9254 -- is a valid intrinsic subprogram. If an external name
9255 -- is present, then this is handled by the back end.
9258 Check_Intrinsic_Subprogram
9259 (Def_Id, Get_Pragma_Arg (Arg2));
9263 -- Verify that the subprogram does not have a completion
9264 -- through a renaming declaration. For other completions the
9265 -- pragma appears as a too late representation.
9268 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
9272 and then Nkind (Decl) = N_Subprogram_Declaration
9273 and then Present (Corresponding_Body (Decl))
9274 and then Nkind (Unit_Declaration_Node
9275 (Corresponding_Body (Decl))) =
9276 N_Subprogram_Renaming_Declaration
9278 Error_Msg_Sloc := Sloc (Def_Id);
9280 ("cannot import&, renaming already provided for "
9281 & "declaration #", N, Def_Id);
9285 -- If the pragma comes from an aspect specification, there
9286 -- must be an Import aspect specified as well. In the rare
9287 -- case where Import is set to False, the suprogram needs to
9288 -- have a local completion.
9291 Imp_Aspect : constant Node_Id :=
9292 Find_Aspect (Def_Id, Aspect_Import);
9296 if Present (Imp_Aspect)
9297 and then Present (Expression (Imp_Aspect))
9299 Expr := Expression (Imp_Aspect);
9300 Analyze_And_Resolve (Expr, Standard_Boolean);
9302 if Is_Entity_Name (Expr)
9303 and then Entity (Expr) = Standard_True
9305 Set_Has_Completion (Def_Id);
9308 -- If there is no expression, the default is True, as for
9309 -- all boolean aspects. Same for the older pragma.
9312 Set_Has_Completion (Def_Id);
9316 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
9319 if Is_Compilation_Unit (Hom_Id) then
9321 -- Its possible homonyms are not affected by the pragma.
9322 -- Such homonyms might be present in the context of other
9323 -- units being compiled.
9327 elsif From_Aspect_Specification (N) then
9330 -- If the pragma was created by the compiler, then we don't
9331 -- want it to apply to other homonyms. This kind of case can
9332 -- occur when using pragma Provide_Shift_Operators, which
9333 -- generates implicit shift and rotate operators with Import
9334 -- pragmas that might apply to earlier explicit or implicit
9335 -- declarations marked with Import (for example, coming from
9336 -- an earlier pragma Provide_Shift_Operators for another type),
9337 -- and we don't generally want other homonyms being treated
9338 -- as imported or the pragma flagged as an illegal duplicate.
9340 elsif not Comes_From_Source (N) then
9344 Hom_Id := Homonym (Hom_Id);
9348 -- Import a CPP class
9350 elsif C = Convention_CPP
9351 and then (Is_Record_Type (Def_Id)
9352 or else Ekind (Def_Id) = E_Incomplete_Type)
9354 if Ekind (Def_Id) = E_Incomplete_Type then
9355 if Present (Full_View (Def_Id)) then
9356 Def_Id := Full_View (Def_Id);
9360 ("cannot import 'C'P'P type before full declaration seen",
9361 Get_Pragma_Arg (Arg2));
9363 -- Although we have reported the error we decorate it as
9364 -- CPP_Class to avoid reporting spurious errors
9366 Set_Is_CPP_Class (Def_Id);
9371 -- Types treated as CPP classes must be declared limited (note:
9372 -- this used to be a warning but there is no real benefit to it
9373 -- since we did effectively intend to treat the type as limited
9376 if not Is_Limited_Type (Def_Id) then
9378 ("imported 'C'P'P type must be limited",
9379 Get_Pragma_Arg (Arg2));
9382 if Etype (Def_Id) /= Def_Id
9383 and then not Is_CPP_Class (Root_Type (Def_Id))
9385 Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
9388 Set_Is_CPP_Class (Def_Id);
9390 -- Imported CPP types must not have discriminants (because C++
9391 -- classes do not have discriminants).
9393 if Has_Discriminants (Def_Id) then
9395 ("imported 'C'P'P type cannot have discriminants",
9396 First (Discriminant_Specifications
9397 (Declaration_Node (Def_Id))));
9400 -- Check that components of imported CPP types do not have default
9401 -- expressions. For private types this check is performed when the
9402 -- full view is analyzed (see Process_Full_View).
9404 if not Is_Private_Type (Def_Id) then
9405 Check_CPP_Type_Has_No_Defaults (Def_Id);
9408 -- Import a CPP exception
9410 elsif C = Convention_CPP
9411 and then Ekind (Def_Id) = E_Exception
9415 ("'External_'Name arguments is required for 'Cpp exception",
9418 -- As only a string is allowed, Check_Arg_Is_External_Name
9421 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
9424 if Present (Arg4) then
9426 ("Link_Name argument not allowed for imported Cpp exception",
9430 -- Do not call Set_Interface_Name as the name of the exception
9431 -- shouldn't be modified (and in particular it shouldn't be
9432 -- the External_Name). For exceptions, the External_Name is the
9433 -- name of the RTTI structure.
9435 -- ??? Emit an error if pragma Import/Export_Exception is present
9437 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
9439 Check_Arg_Count (3);
9440 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
9442 Process_Import_Predefined_Type;
9446 ("second argument of pragma% must be object, subprogram "
9447 & "or incomplete type",
9451 -- If this pragma applies to a compilation unit, then the unit, which
9452 -- is a subprogram, does not require (or allow) a body. We also do
9453 -- not need to elaborate imported procedures.
9455 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
9457 Cunit : constant Node_Id := Parent (Parent (N));
9459 Set_Body_Required (Cunit, False);
9462 end Process_Import_Or_Interface;
9464 --------------------
9465 -- Process_Inline --
9466 --------------------
9468 procedure Process_Inline (Status : Inline_Status) is
9475 Ghost_Error_Posted : Boolean := False;
9476 -- Flag set when an error concerning the illegal mix of Ghost and
9477 -- non-Ghost subprograms is emitted.
9479 Ghost_Id : Entity_Id := Empty;
9480 -- The entity of the first Ghost subprogram encountered while
9481 -- processing the arguments of the pragma.
9483 procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id);
9484 -- Verify the placement of pragma Inline_Always with respect to the
9485 -- initial declaration of subprogram Spec_Id.
9487 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
9488 -- Returns True if it can be determined at this stage that inlining
9489 -- is not possible, for example if the body is available and contains
9490 -- exception handlers, we prevent inlining, since otherwise we can
9491 -- get undefined symbols at link time. This function also emits a
9492 -- warning if the pragma appears too late.
9494 -- ??? is business with link symbols still valid, or does it relate
9495 -- to front end ZCX which is being phased out ???
9497 procedure Make_Inline (Subp : Entity_Id);
9498 -- Subp is the defining unit name of the subprogram declaration. If
9499 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
9500 -- the corresponding body, if there is one present.
9502 procedure Set_Inline_Flags (Subp : Entity_Id);
9503 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
9504 -- Also set or clear Is_Inlined flag on Subp depending on Status.
9506 -----------------------------------
9507 -- Check_Inline_Always_Placement --
9508 -----------------------------------
9510 procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id) is
9511 Spec_Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
9513 function Compilation_Unit_OK return Boolean;
9514 pragma Inline (Compilation_Unit_OK);
9515 -- Determine whether pragma Inline_Always applies to a compatible
9516 -- compilation unit denoted by Spec_Id.
9518 function Declarative_List_OK return Boolean;
9519 pragma Inline (Declarative_List_OK);
9520 -- Determine whether the initial declaration of subprogram Spec_Id
9521 -- and the pragma appear in compatible declarative lists.
9523 function Subprogram_Body_OK return Boolean;
9524 pragma Inline (Subprogram_Body_OK);
9525 -- Determine whether pragma Inline_Always applies to a compatible
9526 -- subprogram body denoted by Spec_Id.
9528 -------------------------
9529 -- Compilation_Unit_OK --
9530 -------------------------
9532 function Compilation_Unit_OK return Boolean is
9533 Comp_Unit : constant Node_Id := Parent (Spec_Decl);
9536 -- The pragma appears after the initial declaration of a
9537 -- compilation unit.
9539 -- procedure Comp_Unit;
9540 -- pragma Inline_Always (Comp_Unit);
9542 -- Note that for compatibility reasons, the following case is
9545 -- procedure Stand_Alone_Body_Comp_Unit is
9547 -- end Stand_Alone_Body_Comp_Unit;
9548 -- pragma Inline_Always (Stand_Alone_Body_Comp_Unit);
9551 Nkind (Comp_Unit) = N_Compilation_Unit
9552 and then Present (Aux_Decls_Node (Comp_Unit))
9553 and then Is_List_Member (N)
9554 and then List_Containing (N) =
9555 Pragmas_After (Aux_Decls_Node (Comp_Unit));
9556 end Compilation_Unit_OK;
9558 -------------------------
9559 -- Declarative_List_OK --
9560 -------------------------
9562 function Declarative_List_OK return Boolean is
9563 Context : constant Node_Id := Parent (Spec_Decl);
9565 Init_Decl : Node_Id;
9566 Init_List : List_Id;
9567 Prag_List : List_Id;
9570 -- Determine the proper initial declaration. In general this is
9571 -- the declaration node of the subprogram except when the input
9572 -- denotes a generic instantiation.
9574 -- procedure Inst is new Gen;
9575 -- pragma Inline_Always (Inst);
9577 -- In this case the original subprogram is moved inside an
9578 -- anonymous package while pragma Inline_Always remains at the
9579 -- level of the anonymous package. Use the declaration of the
9580 -- package because it reflects the placement of the original
9583 -- package Anon_Pack is
9584 -- procedure Inst is ... end Inst; -- original
9587 -- procedure Inst renames Anon_Pack.Inst;
9588 -- pragma Inline_Always (Inst);
9590 if Is_Generic_Instance (Spec_Id) then
9591 Init_Decl := Parent (Parent (Spec_Decl));
9592 pragma Assert (Nkind (Init_Decl) = N_Package_Declaration);
9594 Init_Decl := Spec_Decl;
9597 if Is_List_Member (Init_Decl) and then Is_List_Member (N) then
9598 Init_List := List_Containing (Init_Decl);
9599 Prag_List := List_Containing (N);
9601 -- The pragma and then initial declaration appear within the
9602 -- same declarative list.
9604 if Init_List = Prag_List then
9607 -- A special case of the above is when both the pragma and
9608 -- the initial declaration appear in different lists of a
9609 -- package spec, protected definition, or a task definition.
9614 -- pragma Inline_Always (Proc);
9617 elsif Nkind_In (Context, N_Package_Specification,
9618 N_Protected_Definition,
9620 and then Init_List = Visible_Declarations (Context)
9621 and then Prag_List = Private_Declarations (Context)
9628 end Declarative_List_OK;
9630 ------------------------
9631 -- Subprogram_Body_OK --
9632 ------------------------
9634 function Subprogram_Body_OK return Boolean is
9635 Body_Decl : Node_Id;
9638 -- The pragma appears within the declarative list of a stand-
9639 -- alone subprogram body.
9641 -- procedure Stand_Alone_Body is
9642 -- pragma Inline_Always (Stand_Alone_Body);
9645 -- end Stand_Alone_Body;
9647 -- The compiler creates a dummy spec in this case, however the
9648 -- pragma remains within the declarative list of the body.
9650 if Nkind (Spec_Decl) = N_Subprogram_Declaration
9651 and then not Comes_From_Source (Spec_Decl)
9652 and then Present (Corresponding_Body (Spec_Decl))
9655 Unit_Declaration_Node (Corresponding_Body (Spec_Decl));
9657 if Present (Declarations (Body_Decl))
9658 and then Is_List_Member (N)
9659 and then List_Containing (N) = Declarations (Body_Decl)
9666 end Subprogram_Body_OK;
9668 -- Start of processing for Check_Inline_Always_Placement
9671 -- This check is relevant only for pragma Inline_Always
9673 if Pname /= Name_Inline_Always then
9676 -- Nothing to do when the pragma is internally generated on the
9677 -- assumption that it is properly placed.
9679 elsif not Comes_From_Source (N) then
9682 -- Nothing to do for internally generated subprograms that act
9683 -- as accidental homonyms of a source subprogram being inlined.
9685 elsif not Comes_From_Source (Spec_Id) then
9688 -- Nothing to do for generic formal subprograms that act as
9689 -- homonyms of another source subprogram being inlined.
9691 elsif Is_Formal_Subprogram (Spec_Id) then
9694 elsif Compilation_Unit_OK
9695 or else Declarative_List_OK
9696 or else Subprogram_Body_OK
9701 -- At this point it is known that the pragma applies to or appears
9702 -- within a completing body, a completing stub, or a subunit.
9704 Error_Msg_Name_1 := Pname;
9705 Error_Msg_Name_2 := Chars (Spec_Id);
9706 Error_Msg_Sloc := Sloc (Spec_Id);
9709 ("pragma % must appear on initial declaration of subprogram "
9710 & "% defined #", N);
9711 end Check_Inline_Always_Placement;
9713 ---------------------------
9714 -- Inlining_Not_Possible --
9715 ---------------------------
9717 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
9718 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
9722 if Nkind (Decl) = N_Subprogram_Body then
9723 Stats := Handled_Statement_Sequence (Decl);
9724 return Present (Exception_Handlers (Stats))
9725 or else Present (At_End_Proc (Stats));
9727 elsif Nkind (Decl) = N_Subprogram_Declaration
9728 and then Present (Corresponding_Body (Decl))
9730 if Analyzed (Corresponding_Body (Decl)) then
9731 Error_Msg_N ("pragma appears too late, ignored??", N);
9734 -- If the subprogram is a renaming as body, the body is just a
9735 -- call to the renamed subprogram, and inlining is trivially
9739 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
9740 N_Subprogram_Renaming_Declaration
9746 Handled_Statement_Sequence
9747 (Unit_Declaration_Node (Corresponding_Body (Decl)));
9750 Present (Exception_Handlers (Stats))
9751 or else Present (At_End_Proc (Stats));
9755 -- If body is not available, assume the best, the check is
9756 -- performed again when compiling enclosing package bodies.
9760 end Inlining_Not_Possible;
9766 procedure Make_Inline (Subp : Entity_Id) is
9767 Kind : constant Entity_Kind := Ekind (Subp);
9768 Inner_Subp : Entity_Id := Subp;
9771 -- Ignore if bad type, avoid cascaded error
9773 if Etype (Subp) = Any_Type then
9777 -- If inlining is not possible, for now do not treat as an error
9779 elsif Status /= Suppressed
9780 and then Front_End_Inlining
9781 and then Inlining_Not_Possible (Subp)
9786 -- Here we have a candidate for inlining, but we must exclude
9787 -- derived operations. Otherwise we would end up trying to inline
9788 -- a phantom declaration, and the result would be to drag in a
9789 -- body which has no direct inlining associated with it. That
9790 -- would not only be inefficient but would also result in the
9791 -- backend doing cross-unit inlining in cases where it was
9792 -- definitely inappropriate to do so.
9794 -- However, a simple Comes_From_Source test is insufficient, since
9795 -- we do want to allow inlining of generic instances which also do
9796 -- not come from source. We also need to recognize specs generated
9797 -- by the front-end for bodies that carry the pragma. Finally,
9798 -- predefined operators do not come from source but are not
9799 -- inlineable either.
9801 elsif Is_Generic_Instance (Subp)
9802 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
9806 elsif not Comes_From_Source (Subp)
9807 and then Scope (Subp) /= Standard_Standard
9813 -- The referenced entity must either be the enclosing entity, or
9814 -- an entity declared within the current open scope.
9816 if Present (Scope (Subp))
9817 and then Scope (Subp) /= Current_Scope
9818 and then Subp /= Current_Scope
9821 ("argument of% must be entity in current scope", Assoc);
9825 -- Processing for procedure, operator or function. If subprogram
9826 -- is aliased (as for an instance) indicate that the renamed
9827 -- entity (if declared in the same unit) is inlined.
9828 -- If this is the anonymous subprogram created for a subprogram
9829 -- instance, the inlining applies to it directly. Otherwise we
9830 -- retrieve it as the alias of the visible subprogram instance.
9832 if Is_Subprogram (Subp) then
9834 -- Ensure that pragma Inline_Always is associated with the
9835 -- initial declaration of the subprogram.
9837 Check_Inline_Always_Placement (Subp);
9839 if Is_Wrapper_Package (Scope (Subp)) then
9842 Inner_Subp := Ultimate_Alias (Inner_Subp);
9845 if In_Same_Source_Unit (Subp, Inner_Subp) then
9846 Set_Inline_Flags (Inner_Subp);
9848 Decl := Parent (Parent (Inner_Subp));
9850 if Nkind (Decl) = N_Subprogram_Declaration
9851 and then Present (Corresponding_Body (Decl))
9853 Set_Inline_Flags (Corresponding_Body (Decl));
9855 elsif Is_Generic_Instance (Subp)
9856 and then Comes_From_Source (Subp)
9858 -- Indicate that the body needs to be created for
9859 -- inlining subsequent calls. The instantiation node
9860 -- follows the declaration of the wrapper package
9861 -- created for it. The subprogram that requires the
9862 -- body is the anonymous one in the wrapper package.
9864 if Scope (Subp) /= Standard_Standard
9866 Need_Subprogram_Instance_Body
9867 (Next (Unit_Declaration_Node
9868 (Scope (Alias (Subp)))), Subp)
9873 -- Inline is a program unit pragma (RM 10.1.5) and cannot
9874 -- appear in a formal part to apply to a formal subprogram.
9875 -- Do not apply check within an instance or a formal package
9876 -- the test will have been applied to the original generic.
9878 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
9879 and then List_Containing (Decl) = List_Containing (N)
9880 and then not In_Instance
9883 ("Inline cannot apply to a formal subprogram", N);
9889 -- For a generic subprogram set flag as well, for use at the point
9890 -- of instantiation, to determine whether the body should be
9893 elsif Is_Generic_Subprogram (Subp) then
9894 Set_Inline_Flags (Subp);
9897 -- Literals are by definition inlined
9899 elsif Kind = E_Enumeration_Literal then
9902 -- Anything else is an error
9906 ("expect subprogram name for pragma%", Assoc);
9910 ----------------------
9911 -- Set_Inline_Flags --
9912 ----------------------
9914 procedure Set_Inline_Flags (Subp : Entity_Id) is
9916 -- First set the Has_Pragma_XXX flags and issue the appropriate
9917 -- errors and warnings for suspicious combinations.
9919 if Prag_Id = Pragma_No_Inline then
9920 if Has_Pragma_Inline_Always (Subp) then
9922 ("Inline_Always and No_Inline are mutually exclusive", N);
9923 elsif Has_Pragma_Inline (Subp) then
9925 ("Inline and No_Inline both specified for& ??",
9926 N, Entity (Subp_Id));
9929 Set_Has_Pragma_No_Inline (Subp);
9931 if Prag_Id = Pragma_Inline_Always then
9932 if Has_Pragma_No_Inline (Subp) then
9934 ("Inline_Always and No_Inline are mutually exclusive",
9938 Set_Has_Pragma_Inline_Always (Subp);
9940 if Has_Pragma_No_Inline (Subp) then
9942 ("Inline and No_Inline both specified for& ??",
9943 N, Entity (Subp_Id));
9947 Set_Has_Pragma_Inline (Subp);
9950 -- Then adjust the Is_Inlined flag. It can never be set if the
9951 -- subprogram is subject to pragma No_Inline.
9955 Set_Is_Inlined (Subp, False);
9961 if not Has_Pragma_No_Inline (Subp) then
9962 Set_Is_Inlined (Subp, True);
9966 -- A pragma that applies to a Ghost entity becomes Ghost for the
9967 -- purposes of legality checks and removal of ignored Ghost code.
9969 Mark_Ghost_Pragma (N, Subp);
9971 -- Capture the entity of the first Ghost subprogram being
9972 -- processed for error detection purposes.
9974 if Is_Ghost_Entity (Subp) then
9975 if No (Ghost_Id) then
9979 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
9980 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
9982 elsif Present (Ghost_Id) and then not Ghost_Error_Posted then
9983 Ghost_Error_Posted := True;
9985 Error_Msg_Name_1 := Pname;
9987 ("pragma % cannot mention ghost and non-ghost subprograms",
9990 Error_Msg_Sloc := Sloc (Ghost_Id);
9991 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
9993 Error_Msg_Sloc := Sloc (Subp);
9994 Error_Msg_NE ("\& # declared as non-ghost", N, Subp);
9996 end Set_Inline_Flags;
9998 -- Start of processing for Process_Inline
10001 -- An inlined subprogram may grant access to its private enclosing
10002 -- context depending on the placement of its body. From elaboration
10003 -- point of view, the flow of execution may enter this private
10004 -- context, and then reach an external unit, thus producing a
10005 -- dependency on that external unit. For such a path to be properly
10006 -- discovered and encoded in the ALI file of the main unit, let the
10007 -- ABE mechanism process the body of the main unit, and encode all
10008 -- relevant invocation constructs and the relations between them.
10010 Mark_Save_Invocation_Graph_Of_Body;
10012 Check_No_Identifiers;
10013 Check_At_Least_N_Arguments (1);
10015 if Status = Enabled then
10016 Inline_Processing_Required := True;
10020 while Present (Assoc) loop
10021 Subp_Id := Get_Pragma_Arg (Assoc);
10025 if Is_Entity_Name (Subp_Id) then
10026 Subp := Entity (Subp_Id);
10028 if Subp = Any_Id then
10030 -- If previous error, avoid cascaded errors
10032 Check_Error_Detected;
10036 Make_Inline (Subp);
10038 -- For the pragma case, climb homonym chain. This is
10039 -- what implements allowing the pragma in the renaming
10040 -- case, with the result applying to the ancestors, and
10041 -- also allows Inline to apply to all previous homonyms.
10043 if not From_Aspect_Specification (N) then
10044 while Present (Homonym (Subp))
10045 and then Scope (Homonym (Subp)) = Current_Scope
10047 Make_Inline (Homonym (Subp));
10048 Subp := Homonym (Subp);
10054 if not Applies then
10055 Error_Pragma_Arg ("inappropriate argument for pragma%", Assoc);
10061 -- If the context is a package declaration, the pragma indicates
10062 -- that inlining will require the presence of the corresponding
10063 -- body. (this may be further refined).
10066 and then Nkind (Unit (Cunit (Current_Sem_Unit))) =
10067 N_Package_Declaration
10069 Set_Body_Needed_For_Inlining (Cunit_Entity (Current_Sem_Unit));
10071 end Process_Inline;
10073 ----------------------------
10074 -- Process_Interface_Name --
10075 ----------------------------
10077 procedure Process_Interface_Name
10078 (Subprogram_Def : Entity_Id;
10080 Link_Arg : Node_Id;
10084 Link_Nam : Node_Id;
10085 String_Val : String_Id;
10087 procedure Check_Form_Of_Interface_Name (SN : Node_Id);
10088 -- SN is a string literal node for an interface name. This routine
10089 -- performs some minimal checks that the name is reasonable. In
10090 -- particular that no spaces or other obviously incorrect characters
10091 -- appear. This is only a warning, since any characters are allowed.
10093 ----------------------------------
10094 -- Check_Form_Of_Interface_Name --
10095 ----------------------------------
10097 procedure Check_Form_Of_Interface_Name (SN : Node_Id) is
10098 S : constant String_Id := Strval (Expr_Value_S (SN));
10099 SL : constant Nat := String_Length (S);
10104 Error_Msg_N ("interface name cannot be null string", SN);
10107 for J in 1 .. SL loop
10108 C := Get_String_Char (S, J);
10110 -- Look for dubious character and issue unconditional warning.
10111 -- Definitely dubious if not in character range.
10113 if not In_Character_Range (C)
10115 -- Commas, spaces and (back)slashes are dubious
10117 or else Get_Character (C) = ','
10118 or else Get_Character (C) = '\'
10119 or else Get_Character (C) = ' '
10120 or else Get_Character (C) = '/'
10123 ("??interface name contains illegal character",
10124 Sloc (SN) + Source_Ptr (J));
10127 end Check_Form_Of_Interface_Name;
10129 -- Start of processing for Process_Interface_Name
10132 -- If we are looking at a pragma that comes from an aspect then it
10133 -- needs to have its corresponding aspect argument expressions
10134 -- analyzed in addition to the generated pragma so that aspects
10135 -- within generic units get properly resolved.
10137 if Present (Prag) and then From_Aspect_Specification (Prag) then
10139 Asp : constant Node_Id := Corresponding_Aspect (Prag);
10147 -- Obtain all interfacing aspects used to construct the pragma
10149 Get_Interfacing_Aspects
10150 (Asp, Dummy_1, EN, Dummy_2, Dummy_3, LN);
10152 -- Analyze the expression of aspect External_Name
10154 if Present (EN) then
10155 Analyze (Expression (EN));
10158 -- Analyze the expressio of aspect Link_Name
10160 if Present (LN) then
10161 Analyze (Expression (LN));
10166 if No (Link_Arg) then
10167 if No (Ext_Arg) then
10170 elsif Chars (Ext_Arg) = Name_Link_Name then
10172 Link_Nam := Expression (Ext_Arg);
10175 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
10176 Ext_Nam := Expression (Ext_Arg);
10181 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
10182 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
10183 Ext_Nam := Expression (Ext_Arg);
10184 Link_Nam := Expression (Link_Arg);
10187 -- Check expressions for external name and link name are static
10189 if Present (Ext_Nam) then
10190 Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String);
10191 Check_Form_Of_Interface_Name (Ext_Nam);
10193 -- Verify that external name is not the name of a local entity,
10194 -- which would hide the imported one and could lead to run-time
10195 -- surprises. The problem can only arise for entities declared in
10196 -- a package body (otherwise the external name is fully qualified
10197 -- and will not conflict).
10205 if Prag_Id = Pragma_Import then
10206 Nam := String_To_Name (Strval (Expr_Value_S (Ext_Nam)));
10207 E := Entity_Id (Get_Name_Table_Int (Nam));
10209 if Nam /= Chars (Subprogram_Def)
10210 and then Present (E)
10211 and then not Is_Overloadable (E)
10212 and then Is_Immediately_Visible (E)
10213 and then not Is_Imported (E)
10214 and then Ekind (Scope (E)) = E_Package
10217 while Present (Par) loop
10218 if Nkind (Par) = N_Package_Body then
10219 Error_Msg_Sloc := Sloc (E);
10221 ("imported entity is hidden by & declared#",
10226 Par := Parent (Par);
10233 if Present (Link_Nam) then
10234 Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String);
10235 Check_Form_Of_Interface_Name (Link_Nam);
10238 -- If there is no link name, just set the external name
10240 if No (Link_Nam) then
10241 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
10243 -- For the Link_Name case, the given literal is preceded by an
10244 -- asterisk, which indicates to GCC that the given name should be
10245 -- taken literally, and in particular that no prepending of
10246 -- underlines should occur, even in systems where this is the
10251 Store_String_Char (Get_Char_Code ('*'));
10252 String_Val := Strval (Expr_Value_S (Link_Nam));
10253 Store_String_Chars (String_Val);
10255 Make_String_Literal (Sloc (Link_Nam),
10256 Strval => End_String);
10259 -- Set the interface name. If the entity is a generic instance, use
10260 -- its alias, which is the callable entity.
10262 if Is_Generic_Instance (Subprogram_Def) then
10263 Set_Encoded_Interface_Name
10264 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
10266 Set_Encoded_Interface_Name
10267 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
10270 Check_Duplicated_Export_Name (Link_Nam);
10271 end Process_Interface_Name;
10273 -----------------------------------------
10274 -- Process_Interrupt_Or_Attach_Handler --
10275 -----------------------------------------
10277 procedure Process_Interrupt_Or_Attach_Handler is
10278 Handler : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1));
10279 Prot_Typ : constant Entity_Id := Scope (Handler);
10282 -- A pragma that applies to a Ghost entity becomes Ghost for the
10283 -- purposes of legality checks and removal of ignored Ghost code.
10285 Mark_Ghost_Pragma (N, Handler);
10286 Set_Is_Interrupt_Handler (Handler);
10288 pragma Assert (Ekind (Prot_Typ) = E_Protected_Type);
10290 Record_Rep_Item (Prot_Typ, N);
10292 -- Chain the pragma on the contract for completeness
10294 Add_Contract_Item (N, Handler);
10295 end Process_Interrupt_Or_Attach_Handler;
10297 --------------------------------------------------
10298 -- Process_Restrictions_Or_Restriction_Warnings --
10299 --------------------------------------------------
10301 -- Note: some of the simple identifier cases were handled in par-prag,
10302 -- but it is harmless (and more straightforward) to simply handle all
10303 -- cases here, even if it means we repeat a bit of work in some cases.
10305 procedure Process_Restrictions_Or_Restriction_Warnings
10309 R_Id : Restriction_Id;
10315 -- Ignore all Restrictions pragmas in CodePeer mode
10317 if CodePeer_Mode then
10321 Check_Ada_83_Warning;
10322 Check_At_Least_N_Arguments (1);
10323 Check_Valid_Configuration_Pragma;
10326 while Present (Arg) loop
10328 Expr := Get_Pragma_Arg (Arg);
10330 -- Case of no restriction identifier present
10332 if Id = No_Name then
10333 if Nkind (Expr) /= N_Identifier then
10335 ("invalid form for restriction", Arg);
10340 (Process_Restriction_Synonyms (Expr));
10342 if R_Id not in All_Boolean_Restrictions then
10343 Error_Msg_Name_1 := Pname;
10345 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
10347 -- Check for possible misspelling
10349 for J in Restriction_Id loop
10351 Rnm : constant String := Restriction_Id'Image (J);
10354 Name_Buffer (1 .. Rnm'Length) := Rnm;
10355 Name_Len := Rnm'Length;
10356 Set_Casing (All_Lower_Case);
10358 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
10361 (Source_Index (Current_Sem_Unit)));
10362 Error_Msg_String (1 .. Rnm'Length) :=
10363 Name_Buffer (1 .. Name_Len);
10364 Error_Msg_Strlen := Rnm'Length;
10365 Error_Msg_N -- CODEFIX
10366 ("\possible misspelling of ""~""",
10367 Get_Pragma_Arg (Arg));
10376 if Implementation_Restriction (R_Id) then
10377 Check_Restriction (No_Implementation_Restrictions, Arg);
10380 -- Special processing for No_Elaboration_Code restriction
10382 if R_Id = No_Elaboration_Code then
10384 -- Restriction is only recognized within a configuration
10385 -- pragma file, or within a unit of the main extended
10386 -- program. Note: the test for Main_Unit is needed to
10387 -- properly include the case of configuration pragma files.
10389 if not (Current_Sem_Unit = Main_Unit
10390 or else In_Extended_Main_Source_Unit (N))
10394 -- Don't allow in a subunit unless already specified in
10397 elsif Nkind (Parent (N)) = N_Compilation_Unit
10398 and then Nkind (Unit (Parent (N))) = N_Subunit
10399 and then not Restriction_Active (No_Elaboration_Code)
10402 ("invalid specification of ""No_Elaboration_Code""",
10405 ("\restriction cannot be specified in a subunit", N);
10407 ("\unless also specified in body or spec", N);
10410 -- If we accept a No_Elaboration_Code restriction, then it
10411 -- needs to be added to the configuration restriction set so
10412 -- that we get proper application to other units in the main
10413 -- extended source as required.
10416 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
10420 -- If this is a warning, then set the warning unless we already
10421 -- have a real restriction active (we never want a warning to
10422 -- override a real restriction).
10425 if not Restriction_Active (R_Id) then
10426 Set_Restriction (R_Id, N);
10427 Restriction_Warnings (R_Id) := True;
10430 -- If real restriction case, then set it and make sure that the
10431 -- restriction warning flag is off, since a real restriction
10432 -- always overrides a warning.
10435 Set_Restriction (R_Id, N);
10436 Restriction_Warnings (R_Id) := False;
10439 -- Check for obsolescent restrictions in Ada 2005 mode
10442 and then Ada_Version >= Ada_2005
10443 and then (R_Id = No_Asynchronous_Control
10445 R_Id = No_Unchecked_Deallocation
10447 R_Id = No_Unchecked_Conversion)
10449 Check_Restriction (No_Obsolescent_Features, N);
10452 -- A very special case that must be processed here: pragma
10453 -- Restrictions (No_Exceptions) turns off all run-time
10454 -- checking. This is a bit dubious in terms of the formal
10455 -- language definition, but it is what is intended by RM
10456 -- H.4(12). Restriction_Warnings never affects generated code
10457 -- so this is done only in the real restriction case.
10459 -- Atomic_Synchronization is not a real check, so it is not
10460 -- affected by this processing).
10462 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
10463 -- run-time checks in CodePeer and GNATprove modes: we want to
10464 -- generate checks for analysis purposes, as set respectively
10465 -- by -gnatC and -gnatd.F
10468 and then not (CodePeer_Mode or GNATprove_Mode)
10469 and then R_Id = No_Exceptions
10471 for J in Scope_Suppress.Suppress'Range loop
10472 if J /= Atomic_Synchronization then
10473 Scope_Suppress.Suppress (J) := True;
10478 -- Case of No_Dependence => unit-name. Note that the parser
10479 -- already made the necessary entry in the No_Dependence table.
10481 elsif Id = Name_No_Dependence then
10482 if not OK_No_Dependence_Unit_Name (Expr) then
10486 -- Case of No_Specification_Of_Aspect => aspect-identifier
10488 elsif Id = Name_No_Specification_Of_Aspect then
10493 if Nkind (Expr) /= N_Identifier then
10496 A_Id := Get_Aspect_Id (Chars (Expr));
10499 if A_Id = No_Aspect then
10500 Error_Pragma_Arg ("invalid restriction name", Arg);
10502 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
10506 -- Case of No_Use_Of_Attribute => attribute-identifier
10508 elsif Id = Name_No_Use_Of_Attribute then
10509 if Nkind (Expr) /= N_Identifier
10510 or else not Is_Attribute_Name (Chars (Expr))
10512 Error_Msg_N ("unknown attribute name??", Expr);
10515 Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
10518 -- Case of No_Use_Of_Entity => fully-qualified-name
10520 elsif Id = Name_No_Use_Of_Entity then
10522 -- Restriction is only recognized within a configuration
10523 -- pragma file, or within a unit of the main extended
10524 -- program. Note: the test for Main_Unit is needed to
10525 -- properly include the case of configuration pragma files.
10527 if Current_Sem_Unit = Main_Unit
10528 or else In_Extended_Main_Source_Unit (N)
10530 if not OK_No_Dependence_Unit_Name (Expr) then
10531 Error_Msg_N ("wrong form for entity name", Expr);
10533 Set_Restriction_No_Use_Of_Entity
10534 (Expr, Warn, No_Profile);
10538 -- Case of No_Use_Of_Pragma => pragma-identifier
10540 elsif Id = Name_No_Use_Of_Pragma then
10541 if Nkind (Expr) /= N_Identifier
10542 or else not Is_Pragma_Name (Chars (Expr))
10544 Error_Msg_N ("unknown pragma name??", Expr);
10546 Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
10549 -- All other cases of restriction identifier present
10552 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
10553 Analyze_And_Resolve (Expr, Any_Integer);
10555 if R_Id not in All_Parameter_Restrictions then
10557 ("invalid restriction parameter identifier", Arg);
10559 elsif not Is_OK_Static_Expression (Expr) then
10560 Flag_Non_Static_Expr
10561 ("value must be static expression!", Expr);
10564 elsif not Is_Integer_Type (Etype (Expr))
10565 or else Expr_Value (Expr) < 0
10568 ("value must be non-negative integer", Arg);
10571 -- Restriction pragma is active
10573 Val := Expr_Value (Expr);
10575 if not UI_Is_In_Int_Range (Val) then
10577 ("pragma ignored, value too large??", Arg);
10580 -- Warning case. If the real restriction is active, then we
10581 -- ignore the request, since warning never overrides a real
10582 -- restriction. Otherwise we set the proper warning. Note that
10583 -- this circuit sets the warning again if it is already set,
10584 -- which is what we want, since the constant may have changed.
10587 if not Restriction_Active (R_Id) then
10589 (R_Id, N, Integer (UI_To_Int (Val)));
10590 Restriction_Warnings (R_Id) := True;
10593 -- Real restriction case, set restriction and make sure warning
10594 -- flag is off since real restriction always overrides warning.
10597 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
10598 Restriction_Warnings (R_Id) := False;
10604 end Process_Restrictions_Or_Restriction_Warnings;
10606 ---------------------------------
10607 -- Process_Suppress_Unsuppress --
10608 ---------------------------------
10610 -- Note: this procedure makes entries in the check suppress data
10611 -- structures managed by Sem. See spec of package Sem for full
10612 -- details on how we handle recording of check suppression.
10614 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
10619 In_Package_Spec : constant Boolean :=
10620 Is_Package_Or_Generic_Package (Current_Scope)
10621 and then not In_Package_Body (Current_Scope);
10623 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
10624 -- Used to suppress a single check on the given entity
10626 --------------------------------
10627 -- Suppress_Unsuppress_Echeck --
10628 --------------------------------
10630 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
10632 -- Check for error of trying to set atomic synchronization for
10633 -- a non-atomic variable.
10635 if C = Atomic_Synchronization
10636 and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
10639 ("pragma & requires atomic type or variable",
10640 Pragma_Identifier (Original_Node (N)));
10643 Set_Checks_May_Be_Suppressed (E);
10645 if In_Package_Spec then
10646 Push_Global_Suppress_Stack_Entry
10649 Suppress => Suppress_Case);
10651 Push_Local_Suppress_Stack_Entry
10654 Suppress => Suppress_Case);
10657 -- If this is a first subtype, and the base type is distinct,
10658 -- then also set the suppress flags on the base type.
10660 if Is_First_Subtype (E) and then Etype (E) /= E then
10661 Suppress_Unsuppress_Echeck (Etype (E), C);
10663 end Suppress_Unsuppress_Echeck;
10665 -- Start of processing for Process_Suppress_Unsuppress
10668 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
10669 -- on user code: we want to generate checks for analysis purposes, as
10670 -- set respectively by -gnatC and -gnatd.F
10672 if Comes_From_Source (N)
10673 and then (CodePeer_Mode or GNATprove_Mode)
10678 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
10679 -- declarative part or a package spec (RM 11.5(5)).
10681 if not Is_Configuration_Pragma then
10682 Check_Is_In_Decl_Part_Or_Package_Spec;
10685 Check_At_Least_N_Arguments (1);
10686 Check_At_Most_N_Arguments (2);
10687 Check_No_Identifier (Arg1);
10688 Check_Arg_Is_Identifier (Arg1);
10690 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
10692 if C = No_Check_Id then
10694 ("argument of pragma% is not valid check name", Arg1);
10697 -- Warn that suppress of Elaboration_Check has no effect in SPARK
10699 if C = Elaboration_Check and then SPARK_Mode = On then
10701 ("Suppress of Elaboration_Check ignored in SPARK??",
10702 "\elaboration checking rules are statically enforced "
10703 & "(SPARK RM 7.7)", Arg1);
10706 -- One-argument case
10708 if Arg_Count = 1 then
10710 -- Make an entry in the local scope suppress table. This is the
10711 -- table that directly shows the current value of the scope
10712 -- suppress check for any check id value.
10714 if C = All_Checks then
10716 -- For All_Checks, we set all specific predefined checks with
10717 -- the exception of Elaboration_Check, which is handled
10718 -- specially because of not wanting All_Checks to have the
10719 -- effect of deactivating static elaboration order processing.
10720 -- Atomic_Synchronization is also not affected, since this is
10721 -- not a real check.
10723 for J in Scope_Suppress.Suppress'Range loop
10724 if J /= Elaboration_Check
10726 J /= Atomic_Synchronization
10728 Scope_Suppress.Suppress (J) := Suppress_Case;
10732 -- If not All_Checks, and predefined check, then set appropriate
10733 -- scope entry. Note that we will set Elaboration_Check if this
10734 -- is explicitly specified. Atomic_Synchronization is allowed
10735 -- only if internally generated and entity is atomic.
10737 elsif C in Predefined_Check_Id
10738 and then (not Comes_From_Source (N)
10739 or else C /= Atomic_Synchronization)
10741 Scope_Suppress.Suppress (C) := Suppress_Case;
10744 -- Also make an entry in the Local_Entity_Suppress table
10746 Push_Local_Suppress_Stack_Entry
10749 Suppress => Suppress_Case);
10751 -- Case of two arguments present, where the check is suppressed for
10752 -- a specified entity (given as the second argument of the pragma)
10755 -- This is obsolescent in Ada 2005 mode
10757 if Ada_Version >= Ada_2005 then
10758 Check_Restriction (No_Obsolescent_Features, Arg2);
10761 Check_Optional_Identifier (Arg2, Name_On);
10762 E_Id := Get_Pragma_Arg (Arg2);
10765 if not Is_Entity_Name (E_Id) then
10767 ("second argument of pragma% must be entity name", Arg2);
10770 E := Entity (E_Id);
10776 -- A pragma that applies to a Ghost entity becomes Ghost for the
10777 -- purposes of legality checks and removal of ignored Ghost code.
10779 Mark_Ghost_Pragma (N, E);
10781 -- Enforce RM 11.5(7) which requires that for a pragma that
10782 -- appears within a package spec, the named entity must be
10783 -- within the package spec. We allow the package name itself
10784 -- to be mentioned since that makes sense, although it is not
10785 -- strictly allowed by 11.5(7).
10788 and then E /= Current_Scope
10789 and then Scope (E) /= Current_Scope
10792 ("entity in pragma% is not in package spec (RM 11.5(7))",
10796 -- Loop through homonyms. As noted below, in the case of a package
10797 -- spec, only homonyms within the package spec are considered.
10800 Suppress_Unsuppress_Echeck (E, C);
10802 if Is_Generic_Instance (E)
10803 and then Is_Subprogram (E)
10804 and then Present (Alias (E))
10806 Suppress_Unsuppress_Echeck (Alias (E), C);
10809 -- Move to next homonym if not aspect spec case
10811 exit when From_Aspect_Specification (N);
10815 -- If we are within a package specification, the pragma only
10816 -- applies to homonyms in the same scope.
10818 exit when In_Package_Spec
10819 and then Scope (E) /= Current_Scope;
10822 end Process_Suppress_Unsuppress;
10824 -------------------------------
10825 -- Record_Independence_Check --
10826 -------------------------------
10828 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id) is
10829 pragma Unreferenced (N, E);
10831 -- For GCC back ends the validation is done a priori
10832 -- ??? This code is dead, might be useful in the future
10834 -- if not AAMP_On_Target then
10838 -- Independence_Checks.Append ((N, E));
10841 end Record_Independence_Check;
10847 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
10849 if Is_Imported (E) then
10851 ("cannot export entity& that was previously imported", Arg);
10853 elsif Present (Address_Clause (E))
10854 and then not Relaxed_RM_Semantics
10857 ("cannot export entity& that has an address clause", Arg);
10860 Set_Is_Exported (E);
10862 -- Generate a reference for entity explicitly, because the
10863 -- identifier may be overloaded and name resolution will not
10866 Generate_Reference (E, Arg);
10868 -- Deal with exporting non-library level entity
10870 if not Is_Library_Level_Entity (E) then
10872 -- Not allowed at all for subprograms
10874 if Is_Subprogram (E) then
10875 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
10877 -- Otherwise set public and statically allocated
10881 Set_Is_Statically_Allocated (E);
10883 -- Warn if the corresponding W flag is set
10885 if Warn_On_Export_Import
10887 -- Only do this for something that was in the source. Not
10888 -- clear if this can be False now (there used for sure to be
10889 -- cases on some systems where it was False), but anyway the
10890 -- test is harmless if not needed, so it is retained.
10892 and then Comes_From_Source (Arg)
10895 ("?x?& has been made static as a result of Export",
10898 ("\?x?this usage is non-standard and non-portable",
10904 if Warn_On_Export_Import and then Is_Type (E) then
10905 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
10908 if Warn_On_Export_Import and Inside_A_Generic then
10910 ("all instances of& will have the same external name?x?",
10915 ----------------------------------------------
10916 -- Set_Extended_Import_Export_External_Name --
10917 ----------------------------------------------
10919 procedure Set_Extended_Import_Export_External_Name
10920 (Internal_Ent : Entity_Id;
10921 Arg_External : Node_Id)
10923 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
10924 New_Name : Node_Id;
10927 if No (Arg_External) then
10931 Check_Arg_Is_External_Name (Arg_External);
10933 if Nkind (Arg_External) = N_String_Literal then
10934 if String_Length (Strval (Arg_External)) = 0 then
10937 New_Name := Adjust_External_Name_Case (Arg_External);
10940 elsif Nkind (Arg_External) = N_Identifier then
10941 New_Name := Get_Default_External_Name (Arg_External);
10943 -- Check_Arg_Is_External_Name should let through only identifiers and
10944 -- string literals or static string expressions (which are folded to
10945 -- string literals).
10948 raise Program_Error;
10951 -- If we already have an external name set (by a prior normal Import
10952 -- or Export pragma), then the external names must match
10954 if Present (Interface_Name (Internal_Ent)) then
10956 -- Ignore mismatching names in CodePeer mode, to support some
10957 -- old compilers which would export the same procedure under
10958 -- different names, e.g:
10960 -- pragma Export_Procedure (P, "a");
10961 -- pragma Export_Procedure (P, "b");
10963 if CodePeer_Mode then
10967 Check_Matching_Internal_Names : declare
10968 S1 : constant String_Id := Strval (Old_Name);
10969 S2 : constant String_Id := Strval (New_Name);
10971 procedure Mismatch;
10972 pragma No_Return (Mismatch);
10973 -- Called if names do not match
10979 procedure Mismatch is
10981 Error_Msg_Sloc := Sloc (Old_Name);
10983 ("external name does not match that given #",
10987 -- Start of processing for Check_Matching_Internal_Names
10990 if String_Length (S1) /= String_Length (S2) then
10994 for J in 1 .. String_Length (S1) loop
10995 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
11000 end Check_Matching_Internal_Names;
11002 -- Otherwise set the given name
11005 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
11006 Check_Duplicated_Export_Name (New_Name);
11008 end Set_Extended_Import_Export_External_Name;
11014 procedure Set_Imported (E : Entity_Id) is
11016 -- Error message if already imported or exported
11018 if Is_Exported (E) or else Is_Imported (E) then
11020 -- Error if being set Exported twice
11022 if Is_Exported (E) then
11023 Error_Msg_NE ("entity& was previously exported", N, E);
11025 -- Ignore error in CodePeer mode where we treat all imported
11026 -- subprograms as unknown.
11028 elsif CodePeer_Mode then
11031 -- OK if Import/Interface case
11033 elsif Import_Interface_Present (N) then
11036 -- Error if being set Imported twice
11039 Error_Msg_NE ("entity& was previously imported", N, E);
11042 Error_Msg_Name_1 := Pname;
11044 ("\(pragma% applies to all previous entities)", N);
11046 Error_Msg_Sloc := Sloc (E);
11047 Error_Msg_NE ("\import not allowed for& declared#", N, E);
11049 -- Here if not previously imported or exported, OK to import
11052 Set_Is_Imported (E);
11054 -- For subprogram, set Import_Pragma field
11056 if Is_Subprogram (E) then
11057 Set_Import_Pragma (E, N);
11060 -- If the entity is an object that is not at the library level,
11061 -- then it is statically allocated. We do not worry about objects
11062 -- with address clauses in this context since they are not really
11063 -- imported in the linker sense.
11066 and then not Is_Library_Level_Entity (E)
11067 and then No (Address_Clause (E))
11069 Set_Is_Statically_Allocated (E);
11076 -------------------------
11077 -- Set_Mechanism_Value --
11078 -------------------------
11080 -- Note: the mechanism name has not been analyzed (and cannot indeed be
11081 -- analyzed, since it is semantic nonsense), so we get it in the exact
11082 -- form created by the parser.
11084 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
11085 procedure Bad_Mechanism;
11086 pragma No_Return (Bad_Mechanism);
11087 -- Signal bad mechanism name
11089 -------------------
11090 -- Bad_Mechanism --
11091 -------------------
11093 procedure Bad_Mechanism is
11095 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
11098 -- Start of processing for Set_Mechanism_Value
11101 if Mechanism (Ent) /= Default_Mechanism then
11103 ("mechanism for & has already been set", Mech_Name, Ent);
11106 -- MECHANISM_NAME ::= value | reference
11108 if Nkind (Mech_Name) = N_Identifier then
11109 if Chars (Mech_Name) = Name_Value then
11110 Set_Mechanism (Ent, By_Copy);
11113 elsif Chars (Mech_Name) = Name_Reference then
11114 Set_Mechanism (Ent, By_Reference);
11117 elsif Chars (Mech_Name) = Name_Copy then
11119 ("bad mechanism name, Value assumed", Mech_Name);
11128 end Set_Mechanism_Value;
11130 --------------------------
11131 -- Set_Rational_Profile --
11132 --------------------------
11134 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
11135 -- extension to the semantics of renaming declarations.
11137 procedure Set_Rational_Profile is
11139 Implicit_Packing := True;
11140 Overriding_Renamings := True;
11141 Use_VADS_Size := True;
11142 end Set_Rational_Profile;
11144 ---------------------------
11145 -- Set_Ravenscar_Profile --
11146 ---------------------------
11148 -- The tasks to be done here are
11150 -- Set required policies
11152 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11153 -- (For Ravenscar and GNAT_Extended_Ravenscar profiles)
11154 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11155 -- (For GNAT_Ravenscar_EDF profile)
11156 -- pragma Locking_Policy (Ceiling_Locking)
11158 -- Set Detect_Blocking mode
11160 -- Set required restrictions (see System.Rident for detailed list)
11162 -- Set the No_Dependence rules
11163 -- No_Dependence => Ada.Asynchronous_Task_Control
11164 -- No_Dependence => Ada.Calendar
11165 -- No_Dependence => Ada.Execution_Time.Group_Budget
11166 -- No_Dependence => Ada.Execution_Time.Timers
11167 -- No_Dependence => Ada.Task_Attributes
11168 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11170 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id) is
11171 procedure Set_Error_Msg_To_Profile_Name;
11172 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
11175 -----------------------------------
11176 -- Set_Error_Msg_To_Profile_Name --
11177 -----------------------------------
11179 procedure Set_Error_Msg_To_Profile_Name is
11180 Prof_Nam : constant Node_Id :=
11182 (First (Pragma_Argument_Associations (N)));
11185 Get_Name_String (Chars (Prof_Nam));
11186 Adjust_Name_Case (Global_Name_Buffer, Sloc (Prof_Nam));
11187 Error_Msg_Strlen := Name_Len;
11188 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
11189 end Set_Error_Msg_To_Profile_Name;
11198 Profile_Dispatching_Policy : Character;
11200 -- Start of processing for Set_Ravenscar_Profile
11203 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11205 if Profile = GNAT_Ravenscar_EDF then
11206 Profile_Dispatching_Policy := 'E';
11208 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11211 Profile_Dispatching_Policy := 'F';
11214 if Task_Dispatching_Policy /= ' '
11215 and then Task_Dispatching_Policy /= Profile_Dispatching_Policy
11217 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
11218 Set_Error_Msg_To_Profile_Name;
11219 Error_Pragma ("Profile (~) incompatible with policy#");
11221 -- Set the FIFO_Within_Priorities policy, but always preserve
11222 -- System_Location since we like the error message with the run time
11226 Task_Dispatching_Policy := Profile_Dispatching_Policy;
11228 if Task_Dispatching_Policy_Sloc /= System_Location then
11229 Task_Dispatching_Policy_Sloc := Loc;
11233 -- pragma Locking_Policy (Ceiling_Locking)
11235 if Locking_Policy /= ' '
11236 and then Locking_Policy /= 'C'
11238 Error_Msg_Sloc := Locking_Policy_Sloc;
11239 Set_Error_Msg_To_Profile_Name;
11240 Error_Pragma ("Profile (~) incompatible with policy#");
11242 -- Set the Ceiling_Locking policy, but preserve System_Location since
11243 -- we like the error message with the run time name.
11246 Locking_Policy := 'C';
11248 if Locking_Policy_Sloc /= System_Location then
11249 Locking_Policy_Sloc := Loc;
11253 -- pragma Detect_Blocking
11255 Detect_Blocking := True;
11257 -- Set the corresponding restrictions
11259 Set_Profile_Restrictions
11260 (Profile, N, Warn => Treat_Restrictions_As_Warnings);
11262 -- Set the No_Dependence restrictions
11264 -- The following No_Dependence restrictions:
11265 -- No_Dependence => Ada.Asynchronous_Task_Control
11266 -- No_Dependence => Ada.Calendar
11267 -- No_Dependence => Ada.Task_Attributes
11268 -- are already set by previous call to Set_Profile_Restrictions.
11270 -- Set the following restrictions which were added to Ada 2005:
11271 -- No_Dependence => Ada.Execution_Time.Group_Budget
11272 -- No_Dependence => Ada.Execution_Time.Timers
11274 if Ada_Version >= Ada_2005 then
11275 Pref_Id := Make_Identifier (Loc, Name_Find ("ada"));
11276 Sel_Id := Make_Identifier (Loc, Name_Find ("execution_time"));
11279 Make_Selected_Component
11282 Selector_Name => Sel_Id);
11284 Sel_Id := Make_Identifier (Loc, Name_Find ("group_budgets"));
11287 Make_Selected_Component
11290 Selector_Name => Sel_Id);
11292 Set_Restriction_No_Dependence
11294 Warn => Treat_Restrictions_As_Warnings,
11295 Profile => Ravenscar);
11297 Sel_Id := Make_Identifier (Loc, Name_Find ("timers"));
11300 Make_Selected_Component
11303 Selector_Name => Sel_Id);
11305 Set_Restriction_No_Dependence
11307 Warn => Treat_Restrictions_As_Warnings,
11308 Profile => Ravenscar);
11311 -- Set the following restriction which was added to Ada 2012 (see
11313 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11315 if Ada_Version >= Ada_2012 then
11316 Pref_Id := Make_Identifier (Loc, Name_Find ("system"));
11317 Sel_Id := Make_Identifier (Loc, Name_Find ("multiprocessors"));
11320 Make_Selected_Component
11323 Selector_Name => Sel_Id);
11325 Sel_Id := Make_Identifier (Loc, Name_Find ("dispatching_domains"));
11328 Make_Selected_Component
11331 Selector_Name => Sel_Id);
11333 Set_Restriction_No_Dependence
11335 Warn => Treat_Restrictions_As_Warnings,
11336 Profile => Ravenscar);
11338 end Set_Ravenscar_Profile;
11340 -- Start of processing for Analyze_Pragma
11343 -- The following code is a defense against recursion. Not clear that
11344 -- this can happen legitimately, but perhaps some error situations can
11345 -- cause it, and we did see this recursion during testing.
11347 if Analyzed (N) then
11353 Check_Restriction_No_Use_Of_Pragma (N);
11355 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
11356 -- Default_Scalar_Storage_Order if the -gnatI switch was given.
11358 if Should_Ignore_Pragma_Sem (N)
11359 or else (Prag_Id = Pragma_Default_Scalar_Storage_Order
11360 and then Ignore_Rep_Clauses)
11365 -- Deal with unrecognized pragma
11367 if not Is_Pragma_Name (Pname) then
11368 if Warn_On_Unrecognized_Pragma then
11369 Error_Msg_Name_1 := Pname;
11370 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
11372 for PN in First_Pragma_Name .. Last_Pragma_Name loop
11373 if Is_Bad_Spelling_Of (Pname, PN) then
11374 Error_Msg_Name_1 := PN;
11375 Error_Msg_N -- CODEFIX
11376 ("\?g?possible misspelling of %!", Pragma_Identifier (N));
11385 -- Here to start processing for recognized pragma
11387 Pname := Original_Aspect_Pragma_Name (N);
11389 -- Capture setting of Opt.Uneval_Old
11391 case Opt.Uneval_Old is
11393 Set_Uneval_Old_Accept (N);
11399 Set_Uneval_Old_Warn (N);
11402 raise Program_Error;
11405 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
11406 -- is already set, indicating that we have already checked the policy
11407 -- at the right point. This happens for example in the case of a pragma
11408 -- that is derived from an Aspect.
11410 if Is_Ignored (N) or else Is_Checked (N) then
11413 -- For a pragma that is a rewriting of another pragma, copy the
11414 -- Is_Checked/Is_Ignored status from the rewritten pragma.
11416 elsif Is_Rewrite_Substitution (N)
11417 and then Nkind (Original_Node (N)) = N_Pragma
11419 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
11420 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
11422 -- Otherwise query the applicable policy at this point
11425 Check_Applicable_Policy (N);
11427 -- If pragma is disabled, rewrite as NULL and skip analysis
11429 if Is_Disabled (N) then
11430 Rewrite (N, Make_Null_Statement (Loc));
11436 -- Preset arguments
11444 if Present (Pragma_Argument_Associations (N)) then
11445 Arg_Count := List_Length (Pragma_Argument_Associations (N));
11446 Arg1 := First (Pragma_Argument_Associations (N));
11448 if Present (Arg1) then
11449 Arg2 := Next (Arg1);
11451 if Present (Arg2) then
11452 Arg3 := Next (Arg2);
11454 if Present (Arg3) then
11455 Arg4 := Next (Arg3);
11461 -- An enumeration type defines the pragmas that are supported by the
11462 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
11463 -- into the corresponding enumeration value for the following case.
11471 -- pragma Abort_Defer;
11473 when Pragma_Abort_Defer =>
11475 Check_Arg_Count (0);
11477 -- The only required semantic processing is to check the
11478 -- placement. This pragma must appear at the start of the
11479 -- statement sequence of a handled sequence of statements.
11481 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
11482 or else N /= First (Statements (Parent (N)))
11487 --------------------
11488 -- Abstract_State --
11489 --------------------
11491 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
11493 -- ABSTRACT_STATE_LIST ::=
11495 -- | STATE_NAME_WITH_OPTIONS
11496 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
11498 -- STATE_NAME_WITH_OPTIONS ::=
11500 -- | (STATE_NAME with OPTION_LIST)
11502 -- OPTION_LIST ::= OPTION {, OPTION}
11506 -- | NAME_VALUE_OPTION
11508 -- SIMPLE_OPTION ::= Ghost | Synchronous
11510 -- NAME_VALUE_OPTION ::=
11511 -- Part_Of => ABSTRACT_STATE
11512 -- | External [=> EXTERNAL_PROPERTY_LIST]
11514 -- EXTERNAL_PROPERTY_LIST ::=
11515 -- EXTERNAL_PROPERTY
11516 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
11518 -- EXTERNAL_PROPERTY ::=
11519 -- Async_Readers [=> boolean_EXPRESSION]
11520 -- | Async_Writers [=> boolean_EXPRESSION]
11521 -- | Effective_Reads [=> boolean_EXPRESSION]
11522 -- | Effective_Writes [=> boolean_EXPRESSION]
11523 -- others => boolean_EXPRESSION
11525 -- STATE_NAME ::= defining_identifier
11527 -- ABSTRACT_STATE ::= name
11529 -- Characteristics:
11531 -- * Analysis - The annotation is fully analyzed immediately upon
11532 -- elaboration as it cannot forward reference entities.
11534 -- * Expansion - None.
11536 -- * Template - The annotation utilizes the generic template of the
11537 -- related package declaration.
11539 -- * Globals - The annotation cannot reference global entities.
11541 -- * Instance - The annotation is instantiated automatically when
11542 -- the related generic package is instantiated.
11544 when Pragma_Abstract_State => Abstract_State : declare
11545 Missing_Parentheses : Boolean := False;
11546 -- Flag set when a state declaration with options is not properly
11549 -- Flags used to verify the consistency of states
11551 Non_Null_Seen : Boolean := False;
11552 Null_Seen : Boolean := False;
11554 procedure Analyze_Abstract_State
11556 Pack_Id : Entity_Id);
11557 -- Verify the legality of a single state declaration. Create and
11558 -- decorate a state abstraction entity and introduce it into the
11559 -- visibility chain. Pack_Id denotes the entity or the related
11560 -- package where pragma Abstract_State appears.
11562 procedure Malformed_State_Error (State : Node_Id);
11563 -- Emit an error concerning the illegal declaration of abstract
11564 -- state State. This routine diagnoses syntax errors that lead to
11565 -- a different parse tree. The error is issued regardless of the
11566 -- SPARK mode in effect.
11568 ----------------------------
11569 -- Analyze_Abstract_State --
11570 ----------------------------
11572 procedure Analyze_Abstract_State
11574 Pack_Id : Entity_Id)
11576 -- Flags used to verify the consistency of options
11578 AR_Seen : Boolean := False;
11579 AW_Seen : Boolean := False;
11580 ER_Seen : Boolean := False;
11581 EW_Seen : Boolean := False;
11582 External_Seen : Boolean := False;
11583 Ghost_Seen : Boolean := False;
11584 Others_Seen : Boolean := False;
11585 Part_Of_Seen : Boolean := False;
11586 Synchronous_Seen : Boolean := False;
11588 -- Flags used to store the static value of all external states'
11591 AR_Val : Boolean := False;
11592 AW_Val : Boolean := False;
11593 ER_Val : Boolean := False;
11594 EW_Val : Boolean := False;
11596 State_Id : Entity_Id := Empty;
11597 -- The entity to be generated for the current state declaration
11599 procedure Analyze_External_Option (Opt : Node_Id);
11600 -- Verify the legality of option External
11602 procedure Analyze_External_Property
11604 Expr : Node_Id := Empty);
11605 -- Verify the legailty of a single external property. Prop
11606 -- denotes the external property. Expr is the expression used
11607 -- to set the property.
11609 procedure Analyze_Part_Of_Option (Opt : Node_Id);
11610 -- Verify the legality of option Part_Of
11612 procedure Check_Duplicate_Option
11614 Status : in out Boolean);
11615 -- Flag Status denotes whether a particular option has been
11616 -- seen while processing a state. This routine verifies that
11617 -- Opt is not a duplicate option and sets the flag Status
11618 -- (SPARK RM 7.1.4(1)).
11620 procedure Check_Duplicate_Property
11622 Status : in out Boolean);
11623 -- Flag Status denotes whether a particular property has been
11624 -- seen while processing option External. This routine verifies
11625 -- that Prop is not a duplicate property and sets flag Status.
11626 -- Opt is not a duplicate property and sets the flag Status.
11627 -- (SPARK RM 7.1.4(2))
11629 procedure Check_Ghost_Synchronous;
11630 -- Ensure that the abstract state is not subject to both Ghost
11631 -- and Synchronous simple options. Emit an error if this is the
11634 procedure Create_Abstract_State
11638 Is_Null : Boolean);
11639 -- Generate an abstract state entity with name Nam and enter it
11640 -- into visibility. Decl is the "declaration" of the state as
11641 -- it appears in pragma Abstract_State. Loc is the location of
11642 -- the related state "declaration". Flag Is_Null should be set
11643 -- when the associated Abstract_State pragma defines a null
11646 -----------------------------
11647 -- Analyze_External_Option --
11648 -----------------------------
11650 procedure Analyze_External_Option (Opt : Node_Id) is
11651 Errors : constant Nat := Serious_Errors_Detected;
11653 Props : Node_Id := Empty;
11656 if Nkind (Opt) = N_Component_Association then
11657 Props := Expression (Opt);
11660 -- External state with properties
11662 if Present (Props) then
11664 -- Multiple properties appear as an aggregate
11666 if Nkind (Props) = N_Aggregate then
11668 -- Simple property form
11670 Prop := First (Expressions (Props));
11671 while Present (Prop) loop
11672 Analyze_External_Property (Prop);
11676 -- Property with expression form
11678 Prop := First (Component_Associations (Props));
11679 while Present (Prop) loop
11680 Analyze_External_Property
11681 (Prop => First (Choices (Prop)),
11682 Expr => Expression (Prop));
11690 Analyze_External_Property (Props);
11693 -- An external state defined without any properties defaults
11694 -- all properties to True.
11703 -- Once all external properties have been processed, verify
11704 -- their mutual interaction. Do not perform the check when
11705 -- at least one of the properties is illegal as this will
11706 -- produce a bogus error.
11708 if Errors = Serious_Errors_Detected then
11709 Check_External_Properties
11710 (State, AR_Val, AW_Val, ER_Val, EW_Val);
11712 end Analyze_External_Option;
11714 -------------------------------
11715 -- Analyze_External_Property --
11716 -------------------------------
11718 procedure Analyze_External_Property
11720 Expr : Node_Id := Empty)
11722 Expr_Val : Boolean;
11725 -- Check the placement of "others" (if available)
11727 if Nkind (Prop) = N_Others_Choice then
11728 if Others_Seen then
11730 ("only one others choice allowed in option External",
11733 Others_Seen := True;
11736 elsif Others_Seen then
11738 ("others must be the last property in option External",
11741 -- The only remaining legal options are the four predefined
11742 -- external properties.
11744 elsif Nkind (Prop) = N_Identifier
11745 and then Nam_In (Chars (Prop), Name_Async_Readers,
11746 Name_Async_Writers,
11747 Name_Effective_Reads,
11748 Name_Effective_Writes)
11752 -- Otherwise the construct is not a valid property
11755 SPARK_Msg_N ("invalid external state property", Prop);
11759 -- Ensure that the expression of the external state property
11760 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
11762 if Present (Expr) then
11763 Analyze_And_Resolve (Expr, Standard_Boolean);
11765 if Is_OK_Static_Expression (Expr) then
11766 Expr_Val := Is_True (Expr_Value (Expr));
11769 ("expression of external state property must be "
11774 -- The lack of expression defaults the property to True
11780 -- Named properties
11782 if Nkind (Prop) = N_Identifier then
11783 if Chars (Prop) = Name_Async_Readers then
11784 Check_Duplicate_Property (Prop, AR_Seen);
11785 AR_Val := Expr_Val;
11787 elsif Chars (Prop) = Name_Async_Writers then
11788 Check_Duplicate_Property (Prop, AW_Seen);
11789 AW_Val := Expr_Val;
11791 elsif Chars (Prop) = Name_Effective_Reads then
11792 Check_Duplicate_Property (Prop, ER_Seen);
11793 ER_Val := Expr_Val;
11796 Check_Duplicate_Property (Prop, EW_Seen);
11797 EW_Val := Expr_Val;
11800 -- The handling of property "others" must take into account
11801 -- all other named properties that have been encountered so
11802 -- far. Only those that have not been seen are affected by
11806 if not AR_Seen then
11807 AR_Val := Expr_Val;
11810 if not AW_Seen then
11811 AW_Val := Expr_Val;
11814 if not ER_Seen then
11815 ER_Val := Expr_Val;
11818 if not EW_Seen then
11819 EW_Val := Expr_Val;
11822 end Analyze_External_Property;
11824 ----------------------------
11825 -- Analyze_Part_Of_Option --
11826 ----------------------------
11828 procedure Analyze_Part_Of_Option (Opt : Node_Id) is
11829 Encap : constant Node_Id := Expression (Opt);
11830 Constits : Elist_Id;
11831 Encap_Id : Entity_Id;
11835 Check_Duplicate_Option (Opt, Part_Of_Seen);
11838 (Indic => First (Choices (Opt)),
11839 Item_Id => State_Id,
11841 Encap_Id => Encap_Id,
11844 -- The Part_Of indicator transforms the abstract state into
11845 -- a constituent of the encapsulating state or single
11846 -- concurrent type.
11849 pragma Assert (Present (Encap_Id));
11850 Constits := Part_Of_Constituents (Encap_Id);
11852 if No (Constits) then
11853 Constits := New_Elmt_List;
11854 Set_Part_Of_Constituents (Encap_Id, Constits);
11857 Append_Elmt (State_Id, Constits);
11858 Set_Encapsulating_State (State_Id, Encap_Id);
11860 end Analyze_Part_Of_Option;
11862 ----------------------------
11863 -- Check_Duplicate_Option --
11864 ----------------------------
11866 procedure Check_Duplicate_Option
11868 Status : in out Boolean)
11872 SPARK_Msg_N ("duplicate state option", Opt);
11876 end Check_Duplicate_Option;
11878 ------------------------------
11879 -- Check_Duplicate_Property --
11880 ------------------------------
11882 procedure Check_Duplicate_Property
11884 Status : in out Boolean)
11888 SPARK_Msg_N ("duplicate external property", Prop);
11892 end Check_Duplicate_Property;
11894 -----------------------------
11895 -- Check_Ghost_Synchronous --
11896 -----------------------------
11898 procedure Check_Ghost_Synchronous is
11900 -- A synchronized abstract state cannot be Ghost and vice
11901 -- versa (SPARK RM 6.9(19)).
11903 if Ghost_Seen and Synchronous_Seen then
11904 SPARK_Msg_N ("synchronized state cannot be ghost", State);
11906 end Check_Ghost_Synchronous;
11908 ---------------------------
11909 -- Create_Abstract_State --
11910 ---------------------------
11912 procedure Create_Abstract_State
11919 -- The abstract state may be semi-declared when the related
11920 -- package was withed through a limited with clause. In that
11921 -- case reuse the entity to fully declare the state.
11923 if Present (Decl) and then Present (Entity (Decl)) then
11924 State_Id := Entity (Decl);
11926 -- Otherwise the elaboration of pragma Abstract_State
11927 -- declares the state.
11930 State_Id := Make_Defining_Identifier (Loc, Nam);
11932 if Present (Decl) then
11933 Set_Entity (Decl, State_Id);
11937 -- Null states never come from source
11939 Set_Comes_From_Source (State_Id, not Is_Null);
11940 Set_Parent (State_Id, State);
11941 Set_Ekind (State_Id, E_Abstract_State);
11942 Set_Etype (State_Id, Standard_Void_Type);
11943 Set_Encapsulating_State (State_Id, Empty);
11945 -- Set the SPARK mode from the current context
11947 Set_SPARK_Pragma (State_Id, SPARK_Mode_Pragma);
11948 Set_SPARK_Pragma_Inherited (State_Id);
11950 -- An abstract state declared within a Ghost region becomes
11951 -- Ghost (SPARK RM 6.9(2)).
11953 if Ghost_Mode > None or else Is_Ghost_Entity (Pack_Id) then
11954 Set_Is_Ghost_Entity (State_Id);
11957 -- Establish a link between the state declaration and the
11958 -- abstract state entity. Note that a null state remains as
11959 -- N_Null and does not carry any linkages.
11961 if not Is_Null then
11962 if Present (Decl) then
11963 Set_Entity (Decl, State_Id);
11964 Set_Etype (Decl, Standard_Void_Type);
11967 -- Every non-null state must be defined, nameable and
11970 Push_Scope (Pack_Id);
11971 Generate_Definition (State_Id);
11972 Enter_Name (State_Id);
11975 end Create_Abstract_State;
11982 -- Start of processing for Analyze_Abstract_State
11985 -- A package with a null abstract state is not allowed to
11986 -- declare additional states.
11990 ("package & has null abstract state", State, Pack_Id);
11992 -- Null states appear as internally generated entities
11994 elsif Nkind (State) = N_Null then
11995 Create_Abstract_State
11996 (Nam => New_Internal_Name ('S'),
11998 Loc => Sloc (State),
12002 -- Catch a case where a null state appears in a list of
12003 -- non-null states.
12005 if Non_Null_Seen then
12007 ("package & has non-null abstract state",
12011 -- Simple state declaration
12013 elsif Nkind (State) = N_Identifier then
12014 Create_Abstract_State
12015 (Nam => Chars (State),
12017 Loc => Sloc (State),
12019 Non_Null_Seen := True;
12021 -- State declaration with various options. This construct
12022 -- appears as an extension aggregate in the tree.
12024 elsif Nkind (State) = N_Extension_Aggregate then
12025 if Nkind (Ancestor_Part (State)) = N_Identifier then
12026 Create_Abstract_State
12027 (Nam => Chars (Ancestor_Part (State)),
12028 Decl => Ancestor_Part (State),
12029 Loc => Sloc (Ancestor_Part (State)),
12031 Non_Null_Seen := True;
12034 ("state name must be an identifier",
12035 Ancestor_Part (State));
12038 -- Options External, Ghost and Synchronous appear as
12041 Opt := First (Expressions (State));
12042 while Present (Opt) loop
12043 if Nkind (Opt) = N_Identifier then
12047 if Chars (Opt) = Name_External then
12048 Check_Duplicate_Option (Opt, External_Seen);
12049 Analyze_External_Option (Opt);
12053 elsif Chars (Opt) = Name_Ghost then
12054 Check_Duplicate_Option (Opt, Ghost_Seen);
12055 Check_Ghost_Synchronous;
12057 if Present (State_Id) then
12058 Set_Is_Ghost_Entity (State_Id);
12063 elsif Chars (Opt) = Name_Synchronous then
12064 Check_Duplicate_Option (Opt, Synchronous_Seen);
12065 Check_Ghost_Synchronous;
12067 -- Option Part_Of without an encapsulating state is
12068 -- illegal (SPARK RM 7.1.4(8)).
12070 elsif Chars (Opt) = Name_Part_Of then
12072 ("indicator Part_Of must denote abstract state, "
12073 & "single protected type or single task type",
12076 -- Do not emit an error message when a previous state
12077 -- declaration with options was not parenthesized as
12078 -- the option is actually another state declaration.
12080 -- with Abstract_State
12081 -- (State_1 with ..., -- missing parentheses
12082 -- (State_2 with ...),
12083 -- State_3) -- ok state declaration
12085 elsif Missing_Parentheses then
12088 -- Otherwise the option is not allowed. Note that it
12089 -- is not possible to distinguish between an option
12090 -- and a state declaration when a previous state with
12091 -- options not properly parentheses.
12093 -- with Abstract_State
12094 -- (State_1 with ..., -- missing parentheses
12095 -- State_2); -- could be an option
12099 ("simple option not allowed in state declaration",
12103 -- Catch a case where missing parentheses around a state
12104 -- declaration with options cause a subsequent state
12105 -- declaration with options to be treated as an option.
12107 -- with Abstract_State
12108 -- (State_1 with ..., -- missing parentheses
12109 -- (State_2 with ...))
12111 elsif Nkind (Opt) = N_Extension_Aggregate then
12112 Missing_Parentheses := True;
12114 ("state declaration must be parenthesized",
12115 Ancestor_Part (State));
12117 -- Otherwise the option is malformed
12120 SPARK_Msg_N ("malformed option", Opt);
12126 -- Options External and Part_Of appear as component
12129 Opt := First (Component_Associations (State));
12130 while Present (Opt) loop
12131 Opt_Nam := First (Choices (Opt));
12133 if Nkind (Opt_Nam) = N_Identifier then
12134 if Chars (Opt_Nam) = Name_External then
12135 Analyze_External_Option (Opt);
12137 elsif Chars (Opt_Nam) = Name_Part_Of then
12138 Analyze_Part_Of_Option (Opt);
12141 SPARK_Msg_N ("invalid state option", Opt);
12144 SPARK_Msg_N ("invalid state option", Opt);
12150 -- Any other attempt to declare a state is illegal
12153 Malformed_State_Error (State);
12157 -- Guard against a junk state. In such cases no entity is
12158 -- generated and the subsequent checks cannot be applied.
12160 if Present (State_Id) then
12162 -- Verify whether the state does not introduce an illegal
12163 -- hidden state within a package subject to a null abstract
12166 Check_No_Hidden_State (State_Id);
12168 -- Check whether the lack of option Part_Of agrees with the
12169 -- placement of the abstract state with respect to the state
12172 if not Part_Of_Seen then
12173 Check_Missing_Part_Of (State_Id);
12176 -- Associate the state with its related package
12178 if No (Abstract_States (Pack_Id)) then
12179 Set_Abstract_States (Pack_Id, New_Elmt_List);
12182 Append_Elmt (State_Id, Abstract_States (Pack_Id));
12184 end Analyze_Abstract_State;
12186 ---------------------------
12187 -- Malformed_State_Error --
12188 ---------------------------
12190 procedure Malformed_State_Error (State : Node_Id) is
12192 Error_Msg_N ("malformed abstract state declaration", State);
12194 -- An abstract state with a simple option is being declared
12195 -- with "=>" rather than the legal "with". The state appears
12196 -- as a component association.
12198 if Nkind (State) = N_Component_Association then
12199 Error_Msg_N ("\use WITH to specify simple option", State);
12201 end Malformed_State_Error;
12205 Pack_Decl : Node_Id;
12206 Pack_Id : Entity_Id;
12210 -- Start of processing for Abstract_State
12214 Check_No_Identifiers;
12215 Check_Arg_Count (1);
12217 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
12219 if not Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
12220 N_Package_Declaration)
12226 Pack_Id := Defining_Entity (Pack_Decl);
12228 -- A pragma that applies to a Ghost entity becomes Ghost for the
12229 -- purposes of legality checks and removal of ignored Ghost code.
12231 Mark_Ghost_Pragma (N, Pack_Id);
12232 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
12234 -- Chain the pragma on the contract for completeness
12236 Add_Contract_Item (N, Pack_Id);
12238 -- The legality checks of pragmas Abstract_State, Initializes, and
12239 -- Initial_Condition are affected by the SPARK mode in effect. In
12240 -- addition, these three pragmas are subject to an inherent order:
12242 -- 1) Abstract_State
12244 -- 3) Initial_Condition
12246 -- Analyze all these pragmas in the order outlined above
12248 Analyze_If_Present (Pragma_SPARK_Mode);
12249 States := Expression (Get_Argument (N, Pack_Id));
12251 -- Multiple non-null abstract states appear as an aggregate
12253 if Nkind (States) = N_Aggregate then
12254 State := First (Expressions (States));
12255 while Present (State) loop
12256 Analyze_Abstract_State (State, Pack_Id);
12260 -- An abstract state with a simple option is being illegaly
12261 -- declared with "=>" rather than "with". In this case the
12262 -- state declaration appears as a component association.
12264 if Present (Component_Associations (States)) then
12265 State := First (Component_Associations (States));
12266 while Present (State) loop
12267 Malformed_State_Error (State);
12272 -- Various forms of a single abstract state. Note that these may
12273 -- include malformed state declarations.
12276 Analyze_Abstract_State (States, Pack_Id);
12279 Analyze_If_Present (Pragma_Initializes);
12280 Analyze_If_Present (Pragma_Initial_Condition);
12281 end Abstract_State;
12289 -- Note: this pragma also has some specific processing in Par.Prag
12290 -- because we want to set the Ada version mode during parsing.
12292 when Pragma_Ada_83 =>
12294 Check_Arg_Count (0);
12296 -- We really should check unconditionally for proper configuration
12297 -- pragma placement, since we really don't want mixed Ada modes
12298 -- within a single unit, and the GNAT reference manual has always
12299 -- said this was a configuration pragma, but we did not check and
12300 -- are hesitant to add the check now.
12302 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
12303 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
12304 -- or Ada 2012 mode.
12306 if Ada_Version >= Ada_2005 then
12307 Check_Valid_Configuration_Pragma;
12310 -- Now set Ada 83 mode
12312 if Latest_Ada_Only then
12313 Error_Pragma ("??pragma% ignored");
12315 Ada_Version := Ada_83;
12316 Ada_Version_Explicit := Ada_83;
12317 Ada_Version_Pragma := N;
12326 -- Note: this pragma also has some specific processing in Par.Prag
12327 -- because we want to set the Ada 83 version mode during parsing.
12329 when Pragma_Ada_95 =>
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 with Ada 83
12340 -- or Ada 95, so we must check if we are in Ada 2005 mode.
12342 if Ada_Version >= Ada_2005 then
12343 Check_Valid_Configuration_Pragma;
12346 -- Now set Ada 95 mode
12348 if Latest_Ada_Only then
12349 Error_Pragma ("??pragma% ignored");
12351 Ada_Version := Ada_95;
12352 Ada_Version_Explicit := Ada_95;
12353 Ada_Version_Pragma := N;
12356 ---------------------
12357 -- Ada_05/Ada_2005 --
12358 ---------------------
12361 -- pragma Ada_05 (LOCAL_NAME);
12363 -- pragma Ada_2005;
12364 -- pragma Ada_2005 (LOCAL_NAME):
12366 -- Note: these pragmas also have some specific processing in Par.Prag
12367 -- because we want to set the Ada 2005 version mode during parsing.
12369 -- The one argument form is used for managing the transition from
12370 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
12371 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
12372 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
12373 -- mode, a preference rule is established which does not choose
12374 -- such an entity unless it is unambiguously specified. This avoids
12375 -- extra subprograms marked this way from generating ambiguities in
12376 -- otherwise legal pre-Ada_2005 programs. The one argument form is
12377 -- intended for exclusive use in the GNAT run-time library.
12388 if Arg_Count = 1 then
12389 Check_Arg_Is_Local_Name (Arg1);
12390 E_Id := Get_Pragma_Arg (Arg1);
12392 if Etype (E_Id) = Any_Type then
12396 Set_Is_Ada_2005_Only (Entity (E_Id));
12397 Record_Rep_Item (Entity (E_Id), N);
12400 Check_Arg_Count (0);
12402 -- For Ada_2005 we unconditionally enforce the documented
12403 -- configuration pragma placement, since we do not want to
12404 -- tolerate mixed modes in a unit involving Ada 2005. That
12405 -- would cause real difficulties for those cases where there
12406 -- are incompatibilities between Ada 95 and Ada 2005.
12408 Check_Valid_Configuration_Pragma;
12410 -- Now set appropriate Ada mode
12412 if Latest_Ada_Only then
12413 Error_Pragma ("??pragma% ignored");
12415 Ada_Version := Ada_2005;
12416 Ada_Version_Explicit := Ada_2005;
12417 Ada_Version_Pragma := N;
12422 ---------------------
12423 -- Ada_12/Ada_2012 --
12424 ---------------------
12427 -- pragma Ada_12 (LOCAL_NAME);
12429 -- pragma Ada_2012;
12430 -- pragma Ada_2012 (LOCAL_NAME):
12432 -- Note: these pragmas also have some specific processing in Par.Prag
12433 -- because we want to set the Ada 2012 version mode during parsing.
12435 -- The one argument form is used for managing the transition from Ada
12436 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
12437 -- as Ada_2012 only, then referencing the entity in any pre-Ada_2012
12438 -- mode will generate a warning. In addition, in any pre-Ada_2012
12439 -- mode, a preference rule is established which does not choose
12440 -- such an entity unless it is unambiguously specified. This avoids
12441 -- extra subprograms marked this way from generating ambiguities in
12442 -- otherwise legal pre-Ada_2012 programs. The one argument form is
12443 -- intended for exclusive use in the GNAT run-time library.
12454 if Arg_Count = 1 then
12455 Check_Arg_Is_Local_Name (Arg1);
12456 E_Id := Get_Pragma_Arg (Arg1);
12458 if Etype (E_Id) = Any_Type then
12462 Set_Is_Ada_2012_Only (Entity (E_Id));
12463 Record_Rep_Item (Entity (E_Id), N);
12466 Check_Arg_Count (0);
12468 -- For Ada_2012 we unconditionally enforce the documented
12469 -- configuration pragma placement, since we do not want to
12470 -- tolerate mixed modes in a unit involving Ada 2012. That
12471 -- would cause real difficulties for those cases where there
12472 -- are incompatibilities between Ada 95 and Ada 2012. We could
12473 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
12475 Check_Valid_Configuration_Pragma;
12477 -- Now set appropriate Ada mode
12479 Ada_Version := Ada_2012;
12480 Ada_Version_Explicit := Ada_2012;
12481 Ada_Version_Pragma := N;
12489 -- pragma Ada_2020;
12491 -- Note: this pragma also has some specific processing in Par.Prag
12492 -- because we want to set the Ada 2020 version mode during parsing.
12494 when Pragma_Ada_2020 =>
12497 Check_Arg_Count (0);
12499 Check_Valid_Configuration_Pragma;
12501 -- Now set appropriate Ada mode
12503 Ada_Version := Ada_2020;
12504 Ada_Version_Explicit := Ada_2020;
12505 Ada_Version_Pragma := N;
12507 -------------------------------------
12508 -- Aggregate_Individually_Assign --
12509 -------------------------------------
12511 -- pragma Aggregate_Individually_Assign;
12513 when Pragma_Aggregate_Individually_Assign =>
12515 Check_Arg_Count (0);
12516 Check_Valid_Configuration_Pragma;
12517 Aggregate_Individually_Assign := True;
12519 ----------------------
12520 -- All_Calls_Remote --
12521 ----------------------
12523 -- pragma All_Calls_Remote [(library_package_NAME)];
12525 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
12526 Lib_Entity : Entity_Id;
12529 Check_Ada_83_Warning;
12530 Check_Valid_Library_Unit_Pragma;
12532 if Nkind (N) = N_Null_Statement then
12536 Lib_Entity := Find_Lib_Unit_Name;
12538 -- A pragma that applies to a Ghost entity becomes Ghost for the
12539 -- purposes of legality checks and removal of ignored Ghost code.
12541 Mark_Ghost_Pragma (N, Lib_Entity);
12543 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
12545 if Present (Lib_Entity) and then not Debug_Flag_U then
12546 if not Is_Remote_Call_Interface (Lib_Entity) then
12547 Error_Pragma ("pragma% only apply to rci unit");
12549 -- Set flag for entity of the library unit
12552 Set_Has_All_Calls_Remote (Lib_Entity);
12555 end All_Calls_Remote;
12557 ---------------------------
12558 -- Allow_Integer_Address --
12559 ---------------------------
12561 -- pragma Allow_Integer_Address;
12563 when Pragma_Allow_Integer_Address =>
12565 Check_Valid_Configuration_Pragma;
12566 Check_Arg_Count (0);
12568 -- If Address is a private type, then set the flag to allow
12569 -- integer address values. If Address is not private, then this
12570 -- pragma has no purpose, so it is simply ignored. Not clear if
12571 -- there are any such targets now.
12573 if Opt.Address_Is_Private then
12574 Opt.Allow_Integer_Address := True;
12582 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
12583 -- ARG ::= NAME | EXPRESSION
12585 -- The first two arguments are by convention intended to refer to an
12586 -- external tool and a tool-specific function. These arguments are
12589 when Pragma_Annotate => Annotate : declare
12594 --------------------------
12595 -- Inferred_String_Type --
12596 --------------------------
12598 function Preferred_String_Type (Expr : Node_Id) return Entity_Id;
12599 -- Infer the type to use for a string literal or a concatentation
12600 -- of operands whose types can be inferred. For such expressions,
12601 -- returns the "narrowest" of the three predefined string types
12602 -- that can represent the characters occurring in the expression.
12603 -- For other expressions, returns Empty.
12605 function Preferred_String_Type (Expr : Node_Id) return Entity_Id is
12607 case Nkind (Expr) is
12608 when N_String_Literal =>
12609 if Has_Wide_Wide_Character (Expr) then
12610 return Standard_Wide_Wide_String;
12611 elsif Has_Wide_Character (Expr) then
12612 return Standard_Wide_String;
12614 return Standard_String;
12617 when N_Op_Concat =>
12619 L_Type : constant Entity_Id
12620 := Preferred_String_Type (Left_Opnd (Expr));
12621 R_Type : constant Entity_Id
12622 := Preferred_String_Type (Right_Opnd (Expr));
12624 Type_Table : constant array (1 .. 4) of Entity_Id
12626 Standard_Wide_Wide_String,
12627 Standard_Wide_String,
12630 for Idx in Type_Table'Range loop
12631 if (L_Type = Type_Table (Idx)) or
12632 (R_Type = Type_Table (Idx))
12634 return Type_Table (Idx);
12637 raise Program_Error;
12643 end Preferred_String_Type;
12646 Check_At_Least_N_Arguments (1);
12648 Nam_Arg := Last (Pragma_Argument_Associations (N));
12650 -- Determine whether the last argument is "Entity => local_NAME"
12651 -- and if it is, perform the required semantic checks. Remove the
12652 -- argument from further processing.
12654 if Nkind (Nam_Arg) = N_Pragma_Argument_Association
12655 and then Chars (Nam_Arg) = Name_Entity
12657 Check_Arg_Is_Local_Name (Nam_Arg);
12658 Arg_Count := Arg_Count - 1;
12660 -- A pragma that applies to a Ghost entity becomes Ghost for
12661 -- the purposes of legality checks and removal of ignored Ghost
12664 if Is_Entity_Name (Get_Pragma_Arg (Nam_Arg))
12665 and then Present (Entity (Get_Pragma_Arg (Nam_Arg)))
12667 Mark_Ghost_Pragma (N, Entity (Get_Pragma_Arg (Nam_Arg)));
12670 -- Not allowed in compiler units (bootstrap issues)
12672 Check_Compiler_Unit ("Entity for pragma Annotate", N);
12675 -- Continue the processing with last argument removed for now
12677 Check_Arg_Is_Identifier (Arg1);
12678 Check_No_Identifiers;
12681 -- The second parameter is optional, it is never analyzed
12686 -- Otherwise there is a second parameter
12689 -- The second parameter must be an identifier
12691 Check_Arg_Is_Identifier (Arg2);
12693 -- Process the remaining parameters (if any)
12695 Arg := Next (Arg2);
12696 while Present (Arg) loop
12697 Expr := Get_Pragma_Arg (Arg);
12700 if Is_Entity_Name (Expr) then
12703 -- For string literals and concatenations of string literals
12704 -- we assume Standard_String as the type, unless the string
12705 -- contains wide or wide_wide characters.
12707 elsif Present (Preferred_String_Type (Expr)) then
12708 Resolve (Expr, Preferred_String_Type (Expr));
12710 elsif Is_Overloaded (Expr) then
12711 Error_Pragma_Arg ("ambiguous argument for pragma%", Expr);
12722 -------------------------------------------------
12723 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
12724 -------------------------------------------------
12727 -- ( [Check => ] Boolean_EXPRESSION
12728 -- [, [Message =>] Static_String_EXPRESSION]);
12730 -- pragma Assert_And_Cut
12731 -- ( [Check => ] Boolean_EXPRESSION
12732 -- [, [Message =>] Static_String_EXPRESSION]);
12735 -- ( [Check => ] Boolean_EXPRESSION
12736 -- [, [Message =>] Static_String_EXPRESSION]);
12738 -- pragma Loop_Invariant
12739 -- ( [Check => ] Boolean_EXPRESSION
12740 -- [, [Message =>] Static_String_EXPRESSION]);
12743 | Pragma_Assert_And_Cut
12745 | Pragma_Loop_Invariant
12748 function Contains_Loop_Entry (Expr : Node_Id) return Boolean;
12749 -- Determine whether expression Expr contains a Loop_Entry
12750 -- attribute reference.
12752 -------------------------
12753 -- Contains_Loop_Entry --
12754 -------------------------
12756 function Contains_Loop_Entry (Expr : Node_Id) return Boolean is
12757 Has_Loop_Entry : Boolean := False;
12759 function Process (N : Node_Id) return Traverse_Result;
12760 -- Process function for traversal to look for Loop_Entry
12766 function Process (N : Node_Id) return Traverse_Result is
12768 if Nkind (N) = N_Attribute_Reference
12769 and then Attribute_Name (N) = Name_Loop_Entry
12771 Has_Loop_Entry := True;
12778 procedure Traverse is new Traverse_Proc (Process);
12780 -- Start of processing for Contains_Loop_Entry
12784 return Has_Loop_Entry;
12785 end Contains_Loop_Entry;
12790 New_Args : List_Id;
12792 -- Start of processing for Assert
12795 -- Assert is an Ada 2005 RM-defined pragma
12797 if Prag_Id = Pragma_Assert then
12800 -- The remaining ones are GNAT pragmas
12806 Check_At_Least_N_Arguments (1);
12807 Check_At_Most_N_Arguments (2);
12808 Check_Arg_Order ((Name_Check, Name_Message));
12809 Check_Optional_Identifier (Arg1, Name_Check);
12810 Expr := Get_Pragma_Arg (Arg1);
12812 -- Special processing for Loop_Invariant, Loop_Variant or for
12813 -- other cases where a Loop_Entry attribute is present. If the
12814 -- assertion pragma contains attribute Loop_Entry, ensure that
12815 -- the related pragma is within a loop.
12817 if Prag_Id = Pragma_Loop_Invariant
12818 or else Prag_Id = Pragma_Loop_Variant
12819 or else Contains_Loop_Entry (Expr)
12821 Check_Loop_Pragma_Placement;
12823 -- Perform preanalysis to deal with embedded Loop_Entry
12826 Preanalyze_Assert_Expression (Expr, Any_Boolean);
12829 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
12830 -- a corresponding Check pragma:
12832 -- pragma Check (name, condition [, msg]);
12834 -- Where name is the identifier matching the pragma name. So
12835 -- rewrite pragma in this manner, transfer the message argument
12836 -- if present, and analyze the result
12838 -- Note: When dealing with a semantically analyzed tree, the
12839 -- information that a Check node N corresponds to a source Assert,
12840 -- Assume, or Assert_And_Cut pragma can be retrieved from the
12841 -- pragma kind of Original_Node(N).
12843 New_Args := New_List (
12844 Make_Pragma_Argument_Association (Loc,
12845 Expression => Make_Identifier (Loc, Pname)),
12846 Make_Pragma_Argument_Association (Sloc (Expr),
12847 Expression => Expr));
12849 if Arg_Count > 1 then
12850 Check_Optional_Identifier (Arg2, Name_Message);
12852 -- Provide semantic annotations for optional argument, for
12853 -- ASIS use, before rewriting.
12854 -- Is this still needed???
12856 Preanalyze_And_Resolve (Expression (Arg2), Standard_String);
12857 Append_To (New_Args, New_Copy_Tree (Arg2));
12860 -- Rewrite as Check pragma
12864 Chars => Name_Check,
12865 Pragma_Argument_Associations => New_Args));
12870 ----------------------
12871 -- Assertion_Policy --
12872 ----------------------
12874 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
12876 -- The following form is Ada 2012 only, but we allow it in all modes
12878 -- Pragma Assertion_Policy (
12879 -- ASSERTION_KIND => POLICY_IDENTIFIER
12880 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
12882 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
12884 -- RM_ASSERTION_KIND ::= Assert |
12885 -- Static_Predicate |
12886 -- Dynamic_Predicate |
12891 -- Type_Invariant |
12892 -- Type_Invariant'Class
12894 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
12896 -- Contract_Cases |
12898 -- Default_Initial_Condition |
12900 -- Initial_Condition |
12901 -- Loop_Invariant |
12907 -- Statement_Assertions
12909 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
12910 -- ID_ASSERTION_KIND list contains implementation-defined additions
12911 -- recognized by GNAT. The effect is to control the behavior of
12912 -- identically named aspects and pragmas, depending on the specified
12913 -- policy identifier:
12915 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
12917 -- Note: Check and Ignore are language-defined. Disable is a GNAT
12918 -- implementation-defined addition that results in totally ignoring
12919 -- the corresponding assertion. If Disable is specified, then the
12920 -- argument of the assertion is not even analyzed. This is useful
12921 -- when the aspect/pragma argument references entities in a with'ed
12922 -- package that is replaced by a dummy package in the final build.
12924 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
12925 -- and Type_Invariant'Class were recognized by the parser and
12926 -- transformed into references to the special internal identifiers
12927 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
12928 -- processing is required here.
12930 when Pragma_Assertion_Policy => Assertion_Policy : declare
12931 procedure Resolve_Suppressible (Policy : Node_Id);
12932 -- Converts the assertion policy 'Suppressible' to either Check or
12933 -- Ignore based on whether checks are suppressed via -gnatp.
12935 --------------------------
12936 -- Resolve_Suppressible --
12937 --------------------------
12939 procedure Resolve_Suppressible (Policy : Node_Id) is
12940 Arg : constant Node_Id := Get_Pragma_Arg (Policy);
12944 -- Transform policy argument Suppressible into either Ignore or
12945 -- Check depending on whether checks are enabled or suppressed.
12947 if Chars (Arg) = Name_Suppressible then
12948 if Suppress_Checks then
12949 Nam := Name_Ignore;
12954 Rewrite (Arg, Make_Identifier (Sloc (Arg), Nam));
12956 end Resolve_Suppressible;
12968 -- This can always appear as a configuration pragma
12970 if Is_Configuration_Pragma then
12973 -- It can also appear in a declarative part or package spec in Ada
12974 -- 2012 mode. We allow this in other modes, but in that case we
12975 -- consider that we have an Ada 2012 pragma on our hands.
12978 Check_Is_In_Decl_Part_Or_Package_Spec;
12982 -- One argument case with no identifier (first form above)
12985 and then (Nkind (Arg1) /= N_Pragma_Argument_Association
12986 or else Chars (Arg1) = No_Name)
12988 Check_Arg_Is_One_Of (Arg1,
12989 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
12991 Resolve_Suppressible (Arg1);
12993 -- Treat one argument Assertion_Policy as equivalent to:
12995 -- pragma Check_Policy (Assertion, policy)
12997 -- So rewrite pragma in that manner and link on to the chain
12998 -- of Check_Policy pragmas, marking the pragma as analyzed.
13000 Policy := Get_Pragma_Arg (Arg1);
13004 Chars => Name_Check_Policy,
13005 Pragma_Argument_Associations => New_List (
13006 Make_Pragma_Argument_Association (Loc,
13007 Expression => Make_Identifier (Loc, Name_Assertion)),
13009 Make_Pragma_Argument_Association (Loc,
13011 Make_Identifier (Sloc (Policy), Chars (Policy))))));
13014 -- Here if we have two or more arguments
13017 Check_At_Least_N_Arguments (1);
13020 -- Loop through arguments
13023 while Present (Arg) loop
13024 LocP := Sloc (Arg);
13026 -- Kind must be specified
13028 if Nkind (Arg) /= N_Pragma_Argument_Association
13029 or else Chars (Arg) = No_Name
13032 ("missing assertion kind for pragma%", Arg);
13035 -- Check Kind and Policy have allowed forms
13037 Kind := Chars (Arg);
13038 Policy := Get_Pragma_Arg (Arg);
13040 if not Is_Valid_Assertion_Kind (Kind) then
13042 ("invalid assertion kind for pragma%", Arg);
13045 Check_Arg_Is_One_Of (Arg,
13046 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
13048 Resolve_Suppressible (Arg);
13050 if Kind = Name_Ghost then
13052 -- The Ghost policy must be either Check or Ignore
13053 -- (SPARK RM 6.9(6)).
13055 if not Nam_In (Chars (Policy), Name_Check,
13059 ("argument of pragma % Ghost must be Check or "
13060 & "Ignore", Policy);
13063 -- Pragma Assertion_Policy specifying a Ghost policy
13064 -- cannot occur within a Ghost subprogram or package
13065 -- (SPARK RM 6.9(14)).
13067 if Ghost_Mode > None then
13069 ("pragma % cannot appear within ghost subprogram or "
13074 -- Rewrite the Assertion_Policy pragma as a series of
13075 -- Check_Policy pragmas of the form:
13077 -- Check_Policy (Kind, Policy);
13079 -- Note: the insertion of the pragmas cannot be done with
13080 -- Insert_Action because in the configuration case, there
13081 -- are no scopes on the scope stack and the mechanism will
13084 Insert_Before_And_Analyze (N,
13086 Chars => Name_Check_Policy,
13087 Pragma_Argument_Associations => New_List (
13088 Make_Pragma_Argument_Association (LocP,
13089 Expression => Make_Identifier (LocP, Kind)),
13090 Make_Pragma_Argument_Association (LocP,
13091 Expression => Policy))));
13096 -- Rewrite the Assertion_Policy pragma as null since we have
13097 -- now inserted all the equivalent Check pragmas.
13099 Rewrite (N, Make_Null_Statement (Loc));
13102 end Assertion_Policy;
13104 ------------------------------
13105 -- Assume_No_Invalid_Values --
13106 ------------------------------
13108 -- pragma Assume_No_Invalid_Values (On | Off);
13110 when Pragma_Assume_No_Invalid_Values =>
13112 Check_Valid_Configuration_Pragma;
13113 Check_Arg_Count (1);
13114 Check_No_Identifiers;
13115 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
13117 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
13118 Assume_No_Invalid_Values := True;
13120 Assume_No_Invalid_Values := False;
13123 --------------------------
13124 -- Attribute_Definition --
13125 --------------------------
13127 -- pragma Attribute_Definition
13128 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
13129 -- [Entity =>] LOCAL_NAME,
13130 -- [Expression =>] EXPRESSION | NAME);
13132 when Pragma_Attribute_Definition => Attribute_Definition : declare
13133 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
13138 Check_Arg_Count (3);
13139 Check_Optional_Identifier (Arg1, "attribute");
13140 Check_Optional_Identifier (Arg2, "entity");
13141 Check_Optional_Identifier (Arg3, "expression");
13143 if Nkind (Attribute_Designator) /= N_Identifier then
13144 Error_Msg_N ("attribute name expected", Attribute_Designator);
13148 Check_Arg_Is_Local_Name (Arg2);
13150 -- If the attribute is not recognized, then issue a warning (not
13151 -- an error), and ignore the pragma.
13153 Aname := Chars (Attribute_Designator);
13155 if not Is_Attribute_Name (Aname) then
13156 Bad_Attribute (Attribute_Designator, Aname, Warn => True);
13160 -- Otherwise, rewrite the pragma as an attribute definition clause
13163 Make_Attribute_Definition_Clause (Loc,
13164 Name => Get_Pragma_Arg (Arg2),
13166 Expression => Get_Pragma_Arg (Arg3)));
13168 end Attribute_Definition;
13170 ------------------------------------------------------------------
13171 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
13173 ------------------------------------------------------------------
13175 -- pragma Async_Readers [ (boolean_EXPRESSION) ];
13176 -- pragma Async_Writers [ (boolean_EXPRESSION) ];
13177 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
13178 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
13179 -- pragma No_Caching [ (boolean_EXPRESSION) ];
13181 when Pragma_Async_Readers
13182 | Pragma_Async_Writers
13183 | Pragma_Effective_Reads
13184 | Pragma_Effective_Writes
13185 | Pragma_No_Caching
13187 Async_Effective : declare
13188 Obj_Decl : Node_Id;
13189 Obj_Id : Entity_Id;
13193 Check_No_Identifiers;
13194 Check_At_Most_N_Arguments (1);
13196 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
13198 -- Object declaration
13200 if Nkind (Obj_Decl) /= N_Object_Declaration then
13205 Obj_Id := Defining_Entity (Obj_Decl);
13207 -- Perform minimal verification to ensure that the argument is at
13208 -- least a variable. Subsequent finer grained checks will be done
13209 -- at the end of the declarative region the contains the pragma.
13211 if Ekind (Obj_Id) = E_Variable then
13213 -- A pragma that applies to a Ghost entity becomes Ghost for
13214 -- the purposes of legality checks and removal of ignored Ghost
13217 Mark_Ghost_Pragma (N, Obj_Id);
13219 -- Chain the pragma on the contract for further processing by
13220 -- Analyze_External_Property_In_Decl_Part.
13222 Add_Contract_Item (N, Obj_Id);
13224 -- Analyze the Boolean expression (if any)
13226 if Present (Arg1) then
13227 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
13230 -- Otherwise the external property applies to a constant
13233 Error_Pragma ("pragma % must apply to a volatile object");
13235 end Async_Effective;
13241 -- pragma Asynchronous (LOCAL_NAME);
13243 when Pragma_Asynchronous => Asynchronous : declare
13246 Formal : Entity_Id;
13251 procedure Process_Async_Pragma;
13252 -- Common processing for procedure and access-to-procedure case
13254 --------------------------
13255 -- Process_Async_Pragma --
13256 --------------------------
13258 procedure Process_Async_Pragma is
13261 Set_Is_Asynchronous (Nm);
13265 -- The formals should be of mode IN (RM E.4.1(6))
13268 while Present (S) loop
13269 Formal := Defining_Identifier (S);
13271 if Nkind (Formal) = N_Defining_Identifier
13272 and then Ekind (Formal) /= E_In_Parameter
13275 ("pragma% procedure can only have IN parameter",
13282 Set_Is_Asynchronous (Nm);
13283 end Process_Async_Pragma;
13285 -- Start of processing for pragma Asynchronous
13288 Check_Ada_83_Warning;
13289 Check_No_Identifiers;
13290 Check_Arg_Count (1);
13291 Check_Arg_Is_Local_Name (Arg1);
13293 if Debug_Flag_U then
13297 C_Ent := Cunit_Entity (Current_Sem_Unit);
13298 Analyze (Get_Pragma_Arg (Arg1));
13299 Nm := Entity (Get_Pragma_Arg (Arg1));
13301 -- A pragma that applies to a Ghost entity becomes Ghost for the
13302 -- purposes of legality checks and removal of ignored Ghost code.
13304 Mark_Ghost_Pragma (N, Nm);
13306 if not Is_Remote_Call_Interface (C_Ent)
13307 and then not Is_Remote_Types (C_Ent)
13309 -- This pragma should only appear in an RCI or Remote Types
13310 -- unit (RM E.4.1(4)).
13313 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
13316 if Ekind (Nm) = E_Procedure
13317 and then Nkind (Parent (Nm)) = N_Procedure_Specification
13319 if not Is_Remote_Call_Interface (Nm) then
13321 ("pragma% cannot be applied on non-remote procedure",
13325 L := Parameter_Specifications (Parent (Nm));
13326 Process_Async_Pragma;
13329 elsif Ekind (Nm) = E_Function then
13331 ("pragma% cannot be applied to function", Arg1);
13333 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
13334 if Is_Record_Type (Nm) then
13336 -- A record type that is the Equivalent_Type for a remote
13337 -- access-to-subprogram type.
13339 Decl := Declaration_Node (Corresponding_Remote_Type (Nm));
13342 -- A non-expanded RAS type (distribution is not enabled)
13344 Decl := Declaration_Node (Nm);
13347 if Nkind (Decl) = N_Full_Type_Declaration
13348 and then Nkind (Type_Definition (Decl)) =
13349 N_Access_Procedure_Definition
13351 L := Parameter_Specifications (Type_Definition (Decl));
13352 Process_Async_Pragma;
13354 if Is_Asynchronous (Nm)
13355 and then Expander_Active
13356 and then Get_PCS_Name /= Name_No_DSA
13358 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
13363 ("pragma% cannot reference access-to-function type",
13367 -- Only other possibility is Access-to-class-wide type
13369 elsif Is_Access_Type (Nm)
13370 and then Is_Class_Wide_Type (Designated_Type (Nm))
13372 Check_First_Subtype (Arg1);
13373 Set_Is_Asynchronous (Nm);
13374 if Expander_Active then
13375 RACW_Type_Is_Asynchronous (Nm);
13379 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
13387 -- pragma Atomic (LOCAL_NAME);
13389 when Pragma_Atomic =>
13390 Process_Atomic_Independent_Shared_Volatile;
13392 -----------------------
13393 -- Atomic_Components --
13394 -----------------------
13396 -- pragma Atomic_Components (array_LOCAL_NAME);
13398 -- This processing is shared by Volatile_Components
13400 when Pragma_Atomic_Components
13401 | Pragma_Volatile_Components
13403 Atomic_Components : declare
13409 Check_Ada_83_Warning;
13410 Check_No_Identifiers;
13411 Check_Arg_Count (1);
13412 Check_Arg_Is_Local_Name (Arg1);
13413 E_Id := Get_Pragma_Arg (Arg1);
13415 if Etype (E_Id) = Any_Type then
13419 E := Entity (E_Id);
13421 -- A pragma that applies to a Ghost entity becomes Ghost for the
13422 -- purposes of legality checks and removal of ignored Ghost code.
13424 Mark_Ghost_Pragma (N, E);
13425 Check_Duplicate_Pragma (E);
13427 if Rep_Item_Too_Early (E, N)
13429 Rep_Item_Too_Late (E, N)
13434 D := Declaration_Node (E);
13436 if (Nkind (D) = N_Full_Type_Declaration and then Is_Array_Type (E))
13438 (Nkind (D) = N_Object_Declaration
13439 and then (Ekind (E) = E_Constant
13441 Ekind (E) = E_Variable)
13442 and then Nkind (Object_Definition (D)) =
13443 N_Constrained_Array_Definition)
13445 (Ada_Version >= Ada_2020
13446 and then Nkind (D) = N_Formal_Type_Declaration)
13448 -- The flag is set on the base type, or on the object
13450 if Nkind (D) = N_Full_Type_Declaration then
13451 E := Base_Type (E);
13454 -- Atomic implies both Independent and Volatile
13456 if Prag_Id = Pragma_Atomic_Components then
13457 if Ada_Version >= Ada_2020 then
13459 (Component_Type (Etype (E)), VFA => False);
13462 Set_Has_Atomic_Components (E);
13463 Set_Has_Independent_Components (E);
13466 Set_Has_Volatile_Components (E);
13469 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
13471 end Atomic_Components;
13473 --------------------
13474 -- Attach_Handler --
13475 --------------------
13477 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
13479 when Pragma_Attach_Handler =>
13480 Check_Ada_83_Warning;
13481 Check_No_Identifiers;
13482 Check_Arg_Count (2);
13484 if No_Run_Time_Mode then
13485 Error_Msg_CRT ("Attach_Handler pragma", N);
13487 Check_Interrupt_Or_Attach_Handler;
13489 -- The expression that designates the attribute may depend on a
13490 -- discriminant, and is therefore a per-object expression, to
13491 -- be expanded in the init proc. If expansion is enabled, then
13492 -- perform semantic checks on a copy only.
13497 Parg2 : constant Node_Id := Get_Pragma_Arg (Arg2);
13500 -- In Relaxed_RM_Semantics mode, we allow any static
13501 -- integer value, for compatibility with other compilers.
13503 if Relaxed_RM_Semantics
13504 and then Nkind (Parg2) = N_Integer_Literal
13506 Typ := Standard_Integer;
13508 Typ := RTE (RE_Interrupt_ID);
13511 if Expander_Active then
13512 Temp := New_Copy_Tree (Parg2);
13513 Set_Parent (Temp, N);
13514 Preanalyze_And_Resolve (Temp, Typ);
13517 Resolve (Parg2, Typ);
13521 Process_Interrupt_Or_Attach_Handler;
13524 --------------------
13525 -- C_Pass_By_Copy --
13526 --------------------
13528 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
13530 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
13536 Check_Valid_Configuration_Pragma;
13537 Check_Arg_Count (1);
13538 Check_Optional_Identifier (Arg1, "max_size");
13540 Arg := Get_Pragma_Arg (Arg1);
13541 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
13543 Val := Expr_Value (Arg);
13547 ("maximum size for pragma% must be positive", Arg1);
13549 elsif UI_Is_In_Int_Range (Val) then
13550 Default_C_Record_Mechanism := UI_To_Int (Val);
13552 -- If a giant value is given, Int'Last will do well enough.
13553 -- If sometime someone complains that a record larger than
13554 -- two gigabytes is not copied, we will worry about it then.
13557 Default_C_Record_Mechanism := Mechanism_Type'Last;
13559 end C_Pass_By_Copy;
13565 -- pragma Check ([Name =>] CHECK_KIND,
13566 -- [Check =>] Boolean_EXPRESSION
13567 -- [,[Message =>] String_EXPRESSION]);
13569 -- CHECK_KIND ::= IDENTIFIER |
13572 -- Invariant'Class |
13573 -- Type_Invariant'Class
13575 -- The identifiers Assertions and Statement_Assertions are not
13576 -- allowed, since they have special meaning for Check_Policy.
13578 -- WARNING: The code below manages Ghost regions. Return statements
13579 -- must be replaced by gotos which jump to the end of the code and
13580 -- restore the Ghost mode.
13582 when Pragma_Check => Check : declare
13583 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
13584 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
13585 -- Save the Ghost-related attributes to restore on exit
13591 pragma Warnings (Off, Str);
13594 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
13595 -- the mode now to ensure that any nodes generated during analysis
13596 -- and expansion are marked as Ghost.
13598 Set_Ghost_Mode (N);
13601 Check_At_Least_N_Arguments (2);
13602 Check_At_Most_N_Arguments (3);
13603 Check_Optional_Identifier (Arg1, Name_Name);
13604 Check_Optional_Identifier (Arg2, Name_Check);
13606 if Arg_Count = 3 then
13607 Check_Optional_Identifier (Arg3, Name_Message);
13608 Str := Get_Pragma_Arg (Arg3);
13611 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
13612 Check_Arg_Is_Identifier (Arg1);
13613 Cname := Chars (Get_Pragma_Arg (Arg1));
13615 -- Check forbidden name Assertions or Statement_Assertions
13618 when Name_Assertions =>
13620 ("""Assertions"" is not allowed as a check kind for "
13621 & "pragma%", Arg1);
13623 when Name_Statement_Assertions =>
13625 ("""Statement_Assertions"" is not allowed as a check kind "
13626 & "for pragma%", Arg1);
13632 -- Check applicable policy. We skip this if Checked/Ignored status
13633 -- is already set (e.g. in the case of a pragma from an aspect).
13635 if Is_Checked (N) or else Is_Ignored (N) then
13638 -- For a non-source pragma that is a rewriting of another pragma,
13639 -- copy the Is_Checked/Ignored status from the rewritten pragma.
13641 elsif Is_Rewrite_Substitution (N)
13642 and then Nkind (Original_Node (N)) = N_Pragma
13644 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
13645 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
13647 -- Otherwise query the applicable policy at this point
13650 case Check_Kind (Cname) is
13651 when Name_Ignore =>
13652 Set_Is_Ignored (N, True);
13653 Set_Is_Checked (N, False);
13656 Set_Is_Ignored (N, False);
13657 Set_Is_Checked (N, True);
13659 -- For disable, rewrite pragma as null statement and skip
13660 -- rest of the analysis of the pragma.
13662 when Name_Disable =>
13663 Rewrite (N, Make_Null_Statement (Loc));
13667 -- No other possibilities
13670 raise Program_Error;
13674 -- If check kind was not Disable, then continue pragma analysis
13676 Expr := Get_Pragma_Arg (Arg2);
13678 -- Mark the pragma (or, if rewritten from an aspect, the original
13679 -- aspect) as enabled. Nothing to do for an internally generated
13680 -- check for a dynamic predicate.
13683 and then not Split_PPC (N)
13684 and then Cname /= Name_Dynamic_Predicate
13686 Set_SCO_Pragma_Enabled (Loc);
13689 -- Deal with analyzing the string argument. If checks are not
13690 -- on we don't want any expansion (since such expansion would
13691 -- not get properly deleted) but we do want to analyze (to get
13692 -- proper references). The Preanalyze_And_Resolve routine does
13693 -- just what we want. Ditto if pragma is active, because it will
13694 -- be rewritten as an if-statement whose analysis will complete
13695 -- analysis and expansion of the string message. This makes a
13696 -- difference in the unusual case where the expression for the
13697 -- string may have a side effect, such as raising an exception.
13698 -- This is mandated by RM 11.4.2, which specifies that the string
13699 -- expression is only evaluated if the check fails and
13700 -- Assertion_Error is to be raised.
13702 if Arg_Count = 3 then
13703 Preanalyze_And_Resolve (Str, Standard_String);
13706 -- Now you might think we could just do the same with the Boolean
13707 -- expression if checks are off (and expansion is on) and then
13708 -- rewrite the check as a null statement. This would work but we
13709 -- would lose the useful warnings about an assertion being bound
13710 -- to fail even if assertions are turned off.
13712 -- So instead we wrap the boolean expression in an if statement
13713 -- that looks like:
13715 -- if False and then condition then
13719 -- The reason we do this rewriting during semantic analysis rather
13720 -- than as part of normal expansion is that we cannot analyze and
13721 -- expand the code for the boolean expression directly, or it may
13722 -- cause insertion of actions that would escape the attempt to
13723 -- suppress the check code.
13725 -- Note that the Sloc for the if statement corresponds to the
13726 -- argument condition, not the pragma itself. The reason for
13727 -- this is that we may generate a warning if the condition is
13728 -- False at compile time, and we do not want to delete this
13729 -- warning when we delete the if statement.
13731 if Expander_Active and Is_Ignored (N) then
13732 Eloc := Sloc (Expr);
13735 Make_If_Statement (Eloc,
13737 Make_And_Then (Eloc,
13738 Left_Opnd => Make_Identifier (Eloc, Name_False),
13739 Right_Opnd => Expr),
13740 Then_Statements => New_List (
13741 Make_Null_Statement (Eloc))));
13743 -- Now go ahead and analyze the if statement
13745 In_Assertion_Expr := In_Assertion_Expr + 1;
13747 -- One rather special treatment. If we are now in Eliminated
13748 -- overflow mode, then suppress overflow checking since we do
13749 -- not want to drag in the bignum stuff if we are in Ignore
13750 -- mode anyway. This is particularly important if we are using
13751 -- a configurable run time that does not support bignum ops.
13753 if Scope_Suppress.Overflow_Mode_Assertions = Eliminated then
13755 Svo : constant Boolean :=
13756 Scope_Suppress.Suppress (Overflow_Check);
13758 Scope_Suppress.Overflow_Mode_Assertions := Strict;
13759 Scope_Suppress.Suppress (Overflow_Check) := True;
13761 Scope_Suppress.Suppress (Overflow_Check) := Svo;
13762 Scope_Suppress.Overflow_Mode_Assertions := Eliminated;
13765 -- Not that special case
13771 -- All done with this check
13773 In_Assertion_Expr := In_Assertion_Expr - 1;
13775 -- Check is active or expansion not active. In these cases we can
13776 -- just go ahead and analyze the boolean with no worries.
13779 In_Assertion_Expr := In_Assertion_Expr + 1;
13780 Analyze_And_Resolve (Expr, Any_Boolean);
13781 In_Assertion_Expr := In_Assertion_Expr - 1;
13784 Restore_Ghost_Region (Saved_GM, Saved_IGR);
13787 --------------------------
13788 -- Check_Float_Overflow --
13789 --------------------------
13791 -- pragma Check_Float_Overflow;
13793 when Pragma_Check_Float_Overflow =>
13795 Check_Valid_Configuration_Pragma;
13796 Check_Arg_Count (0);
13797 Check_Float_Overflow := not Machine_Overflows_On_Target;
13803 -- pragma Check_Name (check_IDENTIFIER);
13805 when Pragma_Check_Name =>
13807 Check_No_Identifiers;
13808 Check_Valid_Configuration_Pragma;
13809 Check_Arg_Count (1);
13810 Check_Arg_Is_Identifier (Arg1);
13813 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
13816 for J in Check_Names.First .. Check_Names.Last loop
13817 if Check_Names.Table (J) = Nam then
13822 Check_Names.Append (Nam);
13829 -- This is the old style syntax, which is still allowed in all modes:
13831 -- pragma Check_Policy ([Name =>] CHECK_KIND
13832 -- [Policy =>] POLICY_IDENTIFIER);
13834 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
13836 -- CHECK_KIND ::= IDENTIFIER |
13839 -- Type_Invariant'Class |
13842 -- This is the new style syntax, compatible with Assertion_Policy
13843 -- and also allowed in all modes.
13845 -- Pragma Check_Policy (
13846 -- CHECK_KIND => POLICY_IDENTIFIER
13847 -- {, CHECK_KIND => POLICY_IDENTIFIER});
13849 -- Note: the identifiers Name and Policy are not allowed as
13850 -- Check_Kind values. This avoids ambiguities between the old and
13851 -- new form syntax.
13853 when Pragma_Check_Policy => Check_Policy : declare
13858 Check_At_Least_N_Arguments (1);
13860 -- A Check_Policy pragma can appear either as a configuration
13861 -- pragma, or in a declarative part or a package spec (see RM
13862 -- 11.5(5) for rules for Suppress/Unsuppress which are also
13863 -- followed for Check_Policy).
13865 if not Is_Configuration_Pragma then
13866 Check_Is_In_Decl_Part_Or_Package_Spec;
13869 -- Figure out if we have the old or new syntax. We have the
13870 -- old syntax if the first argument has no identifier, or the
13871 -- identifier is Name.
13873 if Nkind (Arg1) /= N_Pragma_Argument_Association
13874 or else Nam_In (Chars (Arg1), No_Name, Name_Name)
13878 Check_Arg_Count (2);
13879 Check_Optional_Identifier (Arg1, Name_Name);
13880 Kind := Get_Pragma_Arg (Arg1);
13881 Rewrite_Assertion_Kind (Kind,
13882 From_Policy => Comes_From_Source (N));
13883 Check_Arg_Is_Identifier (Arg1);
13885 -- Check forbidden check kind
13887 if Nam_In (Chars (Kind), Name_Name, Name_Policy) then
13888 Error_Msg_Name_2 := Chars (Kind);
13890 ("pragma% does not allow% as check name", Arg1);
13895 Check_Optional_Identifier (Arg2, Name_Policy);
13896 Check_Arg_Is_One_Of
13898 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
13900 -- And chain pragma on the Check_Policy_List for search
13902 Set_Next_Pragma (N, Opt.Check_Policy_List);
13903 Opt.Check_Policy_List := N;
13905 -- For the new syntax, what we do is to convert each argument to
13906 -- an old syntax equivalent. We do that because we want to chain
13907 -- old style Check_Policy pragmas for the search (we don't want
13908 -- to have to deal with multiple arguments in the search).
13919 while Present (Arg) loop
13920 LocP := Sloc (Arg);
13921 Argx := Get_Pragma_Arg (Arg);
13923 -- Kind must be specified
13925 if Nkind (Arg) /= N_Pragma_Argument_Association
13926 or else Chars (Arg) = No_Name
13929 ("missing assertion kind for pragma%", Arg);
13932 -- Construct equivalent old form syntax Check_Policy
13933 -- pragma and insert it to get remaining checks.
13937 Chars => Name_Check_Policy,
13938 Pragma_Argument_Associations => New_List (
13939 Make_Pragma_Argument_Association (LocP,
13941 Make_Identifier (LocP, Chars (Arg))),
13942 Make_Pragma_Argument_Association (Sloc (Argx),
13943 Expression => Argx)));
13947 -- For a configuration pragma, insert old form in
13948 -- the corresponding file.
13950 if Is_Configuration_Pragma then
13951 Insert_After (N, New_P);
13955 Insert_Action (N, New_P);
13959 -- Rewrite original Check_Policy pragma to null, since we
13960 -- have converted it into a series of old syntax pragmas.
13962 Rewrite (N, Make_Null_Statement (Loc));
13972 -- pragma Comment (static_string_EXPRESSION)
13974 -- Processing for pragma Comment shares the circuitry for pragma
13975 -- Ident. The only differences are that Ident enforces a limit of 31
13976 -- characters on its argument, and also enforces limitations on
13977 -- placement for DEC compatibility. Pragma Comment shares neither of
13978 -- these restrictions.
13980 -------------------
13981 -- Common_Object --
13982 -------------------
13984 -- pragma Common_Object (
13985 -- [Internal =>] LOCAL_NAME
13986 -- [, [External =>] EXTERNAL_SYMBOL]
13987 -- [, [Size =>] EXTERNAL_SYMBOL]);
13989 -- Processing for this pragma is shared with Psect_Object
13991 ----------------------------------------------
13992 -- Compile_Time_Error, Compile_Time_Warning --
13993 ----------------------------------------------
13995 -- pragma Compile_Time_Error
13996 -- (boolean_EXPRESSION, static_string_EXPRESSION);
13998 -- pragma Compile_Time_Warning
13999 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14001 when Pragma_Compile_Time_Error | Pragma_Compile_Time_Warning =>
14003 Process_Compile_Time_Warning_Or_Error;
14005 ---------------------------
14006 -- Compiler_Unit_Warning --
14007 ---------------------------
14009 -- pragma Compiler_Unit_Warning;
14013 -- Originally, we had only pragma Compiler_Unit, and it resulted in
14014 -- errors not warnings. This means that we had introduced a big extra
14015 -- inertia to compiler changes, since even if we implemented a new
14016 -- feature, and even if all versions to be used for bootstrapping
14017 -- implemented this new feature, we could not use it, since old
14018 -- compilers would give errors for using this feature in units
14019 -- having Compiler_Unit pragmas.
14021 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
14022 -- problem. We no longer have any units mentioning Compiler_Unit,
14023 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
14024 -- and thus generates a warning which can be ignored. So that deals
14025 -- with the problem of old compilers not implementing the newer form
14028 -- Newer compilers recognize the new pragma, but generate warning
14029 -- messages instead of errors, which again can be ignored in the
14030 -- case of an old compiler which implements a wanted new feature
14031 -- but at the time felt like warning about it for older compilers.
14033 -- We retain Compiler_Unit so that new compilers can be used to build
14034 -- older run-times that use this pragma. That's an unusual case, but
14035 -- it's easy enough to handle, so why not?
14037 when Pragma_Compiler_Unit
14038 | Pragma_Compiler_Unit_Warning
14041 Check_Arg_Count (0);
14043 -- Only recognized in main unit
14045 if Current_Sem_Unit = Main_Unit then
14046 Compiler_Unit := True;
14049 -----------------------------
14050 -- Complete_Representation --
14051 -----------------------------
14053 -- pragma Complete_Representation;
14055 when Pragma_Complete_Representation =>
14057 Check_Arg_Count (0);
14059 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
14061 ("pragma & must appear within record representation clause");
14064 ----------------------------
14065 -- Complex_Representation --
14066 ----------------------------
14068 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
14070 when Pragma_Complex_Representation => Complex_Representation : declare
14077 Check_Arg_Count (1);
14078 Check_Optional_Identifier (Arg1, Name_Entity);
14079 Check_Arg_Is_Local_Name (Arg1);
14080 E_Id := Get_Pragma_Arg (Arg1);
14082 if Etype (E_Id) = Any_Type then
14086 E := Entity (E_Id);
14088 if not Is_Record_Type (E) then
14090 ("argument for pragma% must be record type", Arg1);
14093 Ent := First_Entity (E);
14096 or else No (Next_Entity (Ent))
14097 or else Present (Next_Entity (Next_Entity (Ent)))
14098 or else not Is_Floating_Point_Type (Etype (Ent))
14099 or else Etype (Ent) /= Etype (Next_Entity (Ent))
14102 ("record for pragma% must have two fields of the same "
14103 & "floating-point type", Arg1);
14106 Set_Has_Complex_Representation (Base_Type (E));
14108 -- We need to treat the type has having a non-standard
14109 -- representation, for back-end purposes, even though in
14110 -- general a complex will have the default representation
14111 -- of a record with two real components.
14113 Set_Has_Non_Standard_Rep (Base_Type (E));
14115 end Complex_Representation;
14117 -------------------------
14118 -- Component_Alignment --
14119 -------------------------
14121 -- pragma Component_Alignment (
14122 -- [Form =>] ALIGNMENT_CHOICE
14123 -- [, [Name =>] type_LOCAL_NAME]);
14125 -- ALIGNMENT_CHOICE ::=
14127 -- | Component_Size_4
14131 when Pragma_Component_Alignment => Component_AlignmentP : declare
14132 Args : Args_List (1 .. 2);
14133 Names : constant Name_List (1 .. 2) := (
14137 Form : Node_Id renames Args (1);
14138 Name : Node_Id renames Args (2);
14140 Atype : Component_Alignment_Kind;
14145 Gather_Associations (Names, Args);
14148 Error_Pragma ("missing Form argument for pragma%");
14151 Check_Arg_Is_Identifier (Form);
14153 -- Get proper alignment, note that Default = Component_Size on all
14154 -- machines we have so far, and we want to set this value rather
14155 -- than the default value to indicate that it has been explicitly
14156 -- set (and thus will not get overridden by the default component
14157 -- alignment for the current scope)
14159 if Chars (Form) = Name_Component_Size then
14160 Atype := Calign_Component_Size;
14162 elsif Chars (Form) = Name_Component_Size_4 then
14163 Atype := Calign_Component_Size_4;
14165 elsif Chars (Form) = Name_Default then
14166 Atype := Calign_Component_Size;
14168 elsif Chars (Form) = Name_Storage_Unit then
14169 Atype := Calign_Storage_Unit;
14173 ("invalid Form parameter for pragma%", Form);
14176 -- The pragma appears in a configuration file
14178 if No (Parent (N)) then
14179 Check_Valid_Configuration_Pragma;
14181 -- Capture the component alignment in a global variable when
14182 -- the pragma appears in a configuration file. Note that the
14183 -- scope stack is empty at this point and cannot be used to
14184 -- store the alignment value.
14186 Configuration_Component_Alignment := Atype;
14188 -- Case with no name, supplied, affects scope table entry
14190 elsif No (Name) then
14192 (Scope_Stack.Last).Component_Alignment_Default := Atype;
14194 -- Case of name supplied
14197 Check_Arg_Is_Local_Name (Name);
14199 Typ := Entity (Name);
14202 or else Rep_Item_Too_Early (Typ, N)
14206 Typ := Underlying_Type (Typ);
14209 if not Is_Record_Type (Typ)
14210 and then not Is_Array_Type (Typ)
14213 ("Name parameter of pragma% must identify record or "
14214 & "array type", Name);
14217 -- An explicit Component_Alignment pragma overrides an
14218 -- implicit pragma Pack, but not an explicit one.
14220 if not Has_Pragma_Pack (Base_Type (Typ)) then
14221 Set_Is_Packed (Base_Type (Typ), False);
14222 Set_Component_Alignment (Base_Type (Typ), Atype);
14225 end Component_AlignmentP;
14227 --------------------------------
14228 -- Constant_After_Elaboration --
14229 --------------------------------
14231 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
14233 when Pragma_Constant_After_Elaboration => Constant_After_Elaboration :
14235 Obj_Decl : Node_Id;
14236 Obj_Id : Entity_Id;
14240 Check_No_Identifiers;
14241 Check_At_Most_N_Arguments (1);
14243 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
14245 if Nkind (Obj_Decl) /= N_Object_Declaration then
14250 Obj_Id := Defining_Entity (Obj_Decl);
14252 -- The object declaration must be a library-level variable which
14253 -- is either explicitly initialized or obtains a value during the
14254 -- elaboration of a package body (SPARK RM 3.3.1).
14256 if Ekind (Obj_Id) = E_Variable then
14257 if not Is_Library_Level_Entity (Obj_Id) then
14259 ("pragma % must apply to a library level variable");
14263 -- Otherwise the pragma applies to a constant, which is illegal
14266 Error_Pragma ("pragma % must apply to a variable declaration");
14270 -- A pragma that applies to a Ghost entity becomes Ghost for the
14271 -- purposes of legality checks and removal of ignored Ghost code.
14273 Mark_Ghost_Pragma (N, Obj_Id);
14275 -- Chain the pragma on the contract for completeness
14277 Add_Contract_Item (N, Obj_Id);
14279 -- Analyze the Boolean expression (if any)
14281 if Present (Arg1) then
14282 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
14284 end Constant_After_Elaboration;
14286 --------------------
14287 -- Contract_Cases --
14288 --------------------
14290 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
14292 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
14294 -- CASE_GUARD ::= boolean_EXPRESSION | others
14296 -- CONSEQUENCE ::= boolean_EXPRESSION
14298 -- Characteristics:
14300 -- * Analysis - The annotation undergoes initial checks to verify
14301 -- the legal placement and context. Secondary checks preanalyze the
14304 -- Analyze_Contract_Cases_In_Decl_Part
14306 -- * Expansion - The annotation is expanded during the expansion of
14307 -- the related subprogram [body] contract as performed in:
14309 -- Expand_Subprogram_Contract
14311 -- * Template - The annotation utilizes the generic template of the
14312 -- related subprogram [body] when it is:
14314 -- aspect on subprogram declaration
14315 -- aspect on stand-alone subprogram body
14316 -- pragma on stand-alone subprogram body
14318 -- The annotation must prepare its own template when it is:
14320 -- pragma on subprogram declaration
14322 -- * Globals - Capture of global references must occur after full
14325 -- * Instance - The annotation is instantiated automatically when
14326 -- the related generic subprogram [body] is instantiated except for
14327 -- the "pragma on subprogram declaration" case. In that scenario
14328 -- the annotation must instantiate itself.
14330 when Pragma_Contract_Cases => Contract_Cases : declare
14331 Spec_Id : Entity_Id;
14332 Subp_Decl : Node_Id;
14333 Subp_Spec : Node_Id;
14337 Check_No_Identifiers;
14338 Check_Arg_Count (1);
14340 -- Ensure the proper placement of the pragma. Contract_Cases must
14341 -- be associated with a subprogram declaration or a body that acts
14345 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
14349 if Nkind (Subp_Decl) = N_Entry_Declaration then
14352 -- Generic subprogram
14354 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
14357 -- Body acts as spec
14359 elsif Nkind (Subp_Decl) = N_Subprogram_Body
14360 and then No (Corresponding_Spec (Subp_Decl))
14364 -- Body stub acts as spec
14366 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
14367 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
14373 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
14374 Subp_Spec := Specification (Subp_Decl);
14376 -- Pragma Contract_Cases is forbidden on null procedures, as
14377 -- this may lead to potential ambiguities in behavior when
14378 -- interface null procedures are involved.
14380 if Nkind (Subp_Spec) = N_Procedure_Specification
14381 and then Null_Present (Subp_Spec)
14383 Error_Msg_N (Fix_Error
14384 ("pragma % cannot apply to null procedure"), N);
14393 Spec_Id := Unique_Defining_Entity (Subp_Decl);
14395 -- A pragma that applies to a Ghost entity becomes Ghost for the
14396 -- purposes of legality checks and removal of ignored Ghost code.
14398 Mark_Ghost_Pragma (N, Spec_Id);
14399 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
14401 -- Chain the pragma on the contract for further processing by
14402 -- Analyze_Contract_Cases_In_Decl_Part.
14404 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
14406 -- Fully analyze the pragma when it appears inside an entry
14407 -- or subprogram body because it cannot benefit from forward
14410 if Nkind_In (Subp_Decl, N_Entry_Body,
14412 N_Subprogram_Body_Stub)
14414 -- The legality checks of pragma Contract_Cases are affected by
14415 -- the SPARK mode in effect and the volatility of the context.
14416 -- Analyze all pragmas in a specific order.
14418 Analyze_If_Present (Pragma_SPARK_Mode);
14419 Analyze_If_Present (Pragma_Volatile_Function);
14420 Analyze_Contract_Cases_In_Decl_Part (N);
14422 end Contract_Cases;
14428 -- pragma Controlled (first_subtype_LOCAL_NAME);
14430 when Pragma_Controlled => Controlled : declare
14434 Check_No_Identifiers;
14435 Check_Arg_Count (1);
14436 Check_Arg_Is_Local_Name (Arg1);
14437 Arg := Get_Pragma_Arg (Arg1);
14439 if not Is_Entity_Name (Arg)
14440 or else not Is_Access_Type (Entity (Arg))
14442 Error_Pragma_Arg ("pragma% requires access type", Arg1);
14444 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
14452 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
14453 -- [Entity =>] LOCAL_NAME);
14455 when Pragma_Convention => Convention : declare
14458 pragma Warnings (Off, C);
14459 pragma Warnings (Off, E);
14462 Check_Arg_Order ((Name_Convention, Name_Entity));
14463 Check_Ada_83_Warning;
14464 Check_Arg_Count (2);
14465 Process_Convention (C, E);
14467 -- A pragma that applies to a Ghost entity becomes Ghost for the
14468 -- purposes of legality checks and removal of ignored Ghost code.
14470 Mark_Ghost_Pragma (N, E);
14473 ---------------------------
14474 -- Convention_Identifier --
14475 ---------------------------
14477 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
14478 -- [Convention =>] convention_IDENTIFIER);
14480 when Pragma_Convention_Identifier => Convention_Identifier : declare
14486 Check_Arg_Order ((Name_Name, Name_Convention));
14487 Check_Arg_Count (2);
14488 Check_Optional_Identifier (Arg1, Name_Name);
14489 Check_Optional_Identifier (Arg2, Name_Convention);
14490 Check_Arg_Is_Identifier (Arg1);
14491 Check_Arg_Is_Identifier (Arg2);
14492 Idnam := Chars (Get_Pragma_Arg (Arg1));
14493 Cname := Chars (Get_Pragma_Arg (Arg2));
14495 if Is_Convention_Name (Cname) then
14496 Record_Convention_Identifier
14497 (Idnam, Get_Convention_Id (Cname));
14500 ("second arg for % pragma must be convention", Arg2);
14502 end Convention_Identifier;
14508 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
14510 when Pragma_CPP_Class =>
14513 if Warn_On_Obsolescent_Feature then
14515 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
14516 & "effect; replace it by pragma import?j?", N);
14519 Check_Arg_Count (1);
14523 Chars => Name_Import,
14524 Pragma_Argument_Associations => New_List (
14525 Make_Pragma_Argument_Association (Loc,
14526 Expression => Make_Identifier (Loc, Name_CPP)),
14527 New_Copy (First (Pragma_Argument_Associations (N))))));
14530 ---------------------
14531 -- CPP_Constructor --
14532 ---------------------
14534 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
14535 -- [, [External_Name =>] static_string_EXPRESSION ]
14536 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14538 when Pragma_CPP_Constructor => CPP_Constructor : declare
14541 Def_Id : Entity_Id;
14542 Tag_Typ : Entity_Id;
14546 Check_At_Least_N_Arguments (1);
14547 Check_At_Most_N_Arguments (3);
14548 Check_Optional_Identifier (Arg1, Name_Entity);
14549 Check_Arg_Is_Local_Name (Arg1);
14551 Id := Get_Pragma_Arg (Arg1);
14552 Find_Program_Unit_Name (Id);
14554 -- If we did not find the name, we are done
14556 if Etype (Id) = Any_Type then
14560 Def_Id := Entity (Id);
14562 -- Check if already defined as constructor
14564 if Is_Constructor (Def_Id) then
14566 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
14570 if Ekind (Def_Id) = E_Function
14571 and then (Is_CPP_Class (Etype (Def_Id))
14572 or else (Is_Class_Wide_Type (Etype (Def_Id))
14574 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
14576 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
14578 ("'C'P'P constructor must be defined in the scope of "
14579 & "its returned type", Arg1);
14582 if Arg_Count >= 2 then
14583 Set_Imported (Def_Id);
14584 Set_Is_Public (Def_Id);
14585 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
14588 Set_Has_Completion (Def_Id);
14589 Set_Is_Constructor (Def_Id);
14590 Set_Convention (Def_Id, Convention_CPP);
14592 -- Imported C++ constructors are not dispatching primitives
14593 -- because in C++ they don't have a dispatch table slot.
14594 -- However, in Ada the constructor has the profile of a
14595 -- function that returns a tagged type and therefore it has
14596 -- been treated as a primitive operation during semantic
14597 -- analysis. We now remove it from the list of primitive
14598 -- operations of the type.
14600 if Is_Tagged_Type (Etype (Def_Id))
14601 and then not Is_Class_Wide_Type (Etype (Def_Id))
14602 and then Is_Dispatching_Operation (Def_Id)
14604 Tag_Typ := Etype (Def_Id);
14606 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
14607 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
14611 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
14612 Set_Is_Dispatching_Operation (Def_Id, False);
14615 -- For backward compatibility, if the constructor returns a
14616 -- class wide type, and we internally change the return type to
14617 -- the corresponding root type.
14619 if Is_Class_Wide_Type (Etype (Def_Id)) then
14620 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
14624 ("pragma% requires function returning a 'C'P'P_Class type",
14627 end CPP_Constructor;
14633 when Pragma_CPP_Virtual =>
14636 if Warn_On_Obsolescent_Feature then
14638 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
14646 when Pragma_CPP_Vtable =>
14649 if Warn_On_Obsolescent_Feature then
14651 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
14659 -- pragma CPU (EXPRESSION);
14661 when Pragma_CPU => CPU : declare
14662 P : constant Node_Id := Parent (N);
14668 Check_No_Identifiers;
14669 Check_Arg_Count (1);
14673 if Nkind (P) = N_Subprogram_Body then
14674 Check_In_Main_Program;
14676 Arg := Get_Pragma_Arg (Arg1);
14677 Analyze_And_Resolve (Arg, Any_Integer);
14679 Ent := Defining_Unit_Name (Specification (P));
14681 if Nkind (Ent) = N_Defining_Program_Unit_Name then
14682 Ent := Defining_Identifier (Ent);
14687 if not Is_OK_Static_Expression (Arg) then
14688 Flag_Non_Static_Expr
14689 ("main subprogram affinity is not static!", Arg);
14692 -- If constraint error, then we already signalled an error
14694 elsif Raises_Constraint_Error (Arg) then
14697 -- Otherwise check in range
14701 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
14702 -- This is the entity System.Multiprocessors.CPU_Range;
14704 Val : constant Uint := Expr_Value (Arg);
14707 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
14709 Val > Expr_Value (Type_High_Bound (CPU_Id))
14712 ("main subprogram CPU is out of range", Arg1);
14718 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
14722 elsif Nkind (P) = N_Task_Definition then
14723 Arg := Get_Pragma_Arg (Arg1);
14724 Ent := Defining_Identifier (Parent (P));
14726 -- The expression must be analyzed in the special manner
14727 -- described in "Handling of Default and Per-Object
14728 -- Expressions" in sem.ads.
14730 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
14732 -- Anything else is incorrect
14738 -- Check duplicate pragma before we chain the pragma in the Rep
14739 -- Item chain of Ent.
14741 Check_Duplicate_Pragma (Ent);
14742 Record_Rep_Item (Ent, N);
14745 --------------------
14746 -- Deadline_Floor --
14747 --------------------
14749 -- pragma Deadline_Floor (time_span_EXPRESSION);
14751 when Pragma_Deadline_Floor => Deadline_Floor : declare
14752 P : constant Node_Id := Parent (N);
14758 Check_No_Identifiers;
14759 Check_Arg_Count (1);
14761 Arg := Get_Pragma_Arg (Arg1);
14763 -- The expression must be analyzed in the special manner described
14764 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
14766 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
14768 -- Only protected types allowed
14770 if Nkind (P) /= N_Protected_Definition then
14774 Ent := Defining_Identifier (Parent (P));
14776 -- Check duplicate pragma before we chain the pragma in the Rep
14777 -- Item chain of Ent.
14779 Check_Duplicate_Pragma (Ent);
14780 Record_Rep_Item (Ent, N);
14782 end Deadline_Floor;
14788 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
14790 when Pragma_Debug => Debug : declare
14797 -- The condition for executing the call is that the expander
14798 -- is active and that we are not ignoring this debug pragma.
14803 (Expander_Active and then not Is_Ignored (N)),
14806 if not Is_Ignored (N) then
14807 Set_SCO_Pragma_Enabled (Loc);
14810 if Arg_Count = 2 then
14812 Make_And_Then (Loc,
14813 Left_Opnd => Relocate_Node (Cond),
14814 Right_Opnd => Get_Pragma_Arg (Arg1));
14815 Call := Get_Pragma_Arg (Arg2);
14817 Call := Get_Pragma_Arg (Arg1);
14820 if Nkind_In (Call, N_Expanded_Name,
14823 N_Indexed_Component,
14824 N_Selected_Component)
14826 -- If this pragma Debug comes from source, its argument was
14827 -- parsed as a name form (which is syntactically identical).
14828 -- In a generic context a parameterless call will be left as
14829 -- an expanded name (if global) or selected_component if local.
14830 -- Change it to a procedure call statement now.
14832 Change_Name_To_Procedure_Call_Statement (Call);
14834 elsif Nkind (Call) = N_Procedure_Call_Statement then
14836 -- Already in the form of a procedure call statement: nothing
14837 -- to do (could happen in case of an internally generated
14843 -- All other cases: diagnose error
14846 ("argument of pragma ""Debug"" is not procedure call",
14851 -- Rewrite into a conditional with an appropriate condition. We
14852 -- wrap the procedure call in a block so that overhead from e.g.
14853 -- use of the secondary stack does not generate execution overhead
14854 -- for suppressed conditions.
14856 -- Normally the analysis that follows will freeze the subprogram
14857 -- being called. However, if the call is to a null procedure,
14858 -- we want to freeze it before creating the block, because the
14859 -- analysis that follows may be done with expansion disabled, in
14860 -- which case the body will not be generated, leading to spurious
14863 if Nkind (Call) = N_Procedure_Call_Statement
14864 and then Is_Entity_Name (Name (Call))
14866 Analyze (Name (Call));
14867 Freeze_Before (N, Entity (Name (Call)));
14871 Make_Implicit_If_Statement (N,
14873 Then_Statements => New_List (
14874 Make_Block_Statement (Loc,
14875 Handled_Statement_Sequence =>
14876 Make_Handled_Sequence_Of_Statements (Loc,
14877 Statements => New_List (Relocate_Node (Call)))))));
14880 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
14881 -- after analysis of the normally rewritten node, to capture all
14882 -- references to entities, which avoids issuing wrong warnings
14883 -- about unused entities.
14885 if GNATprove_Mode then
14886 Rewrite (N, Make_Null_Statement (Loc));
14894 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
14896 when Pragma_Debug_Policy =>
14898 Check_Arg_Count (1);
14899 Check_No_Identifiers;
14900 Check_Arg_Is_Identifier (Arg1);
14902 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
14903 -- rewrite it that way, and let the rest of the checking come
14904 -- from analyzing the rewritten pragma.
14908 Chars => Name_Check_Policy,
14909 Pragma_Argument_Associations => New_List (
14910 Make_Pragma_Argument_Association (Loc,
14911 Expression => Make_Identifier (Loc, Name_Debug)),
14913 Make_Pragma_Argument_Association (Loc,
14914 Expression => Get_Pragma_Arg (Arg1)))));
14917 -------------------------------
14918 -- Default_Initial_Condition --
14919 -------------------------------
14921 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
14923 when Pragma_Default_Initial_Condition => DIC : declare
14930 Check_No_Identifiers;
14931 Check_At_Most_N_Arguments (1);
14935 while Present (Stmt) loop
14937 -- Skip prior pragmas, but check for duplicates
14939 if Nkind (Stmt) = N_Pragma then
14940 if Pragma_Name (Stmt) = Pname then
14947 -- Skip internally generated code. Note that derived type
14948 -- declarations of untagged types with discriminants are
14949 -- rewritten as private type declarations.
14951 elsif not Comes_From_Source (Stmt)
14952 and then Nkind (Stmt) /= N_Private_Type_Declaration
14956 -- The associated private type [extension] has been found, stop
14959 elsif Nkind_In (Stmt, N_Private_Extension_Declaration,
14960 N_Private_Type_Declaration)
14962 Typ := Defining_Entity (Stmt);
14965 -- The pragma does not apply to a legal construct, issue an
14966 -- error and stop the analysis.
14973 Stmt := Prev (Stmt);
14976 -- The pragma does not apply to a legal construct, issue an error
14977 -- and stop the analysis.
14984 -- A pragma that applies to a Ghost entity becomes Ghost for the
14985 -- purposes of legality checks and removal of ignored Ghost code.
14987 Mark_Ghost_Pragma (N, Typ);
14989 -- The pragma signals that the type defines its own DIC assertion
14992 Set_Has_Own_DIC (Typ);
14994 -- Chain the pragma on the rep item chain for further processing
14996 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
14998 -- Create the declaration of the procedure which verifies the
14999 -- assertion expression of pragma DIC at runtime.
15001 Build_DIC_Procedure_Declaration (Typ);
15004 ----------------------------------
15005 -- Default_Scalar_Storage_Order --
15006 ----------------------------------
15008 -- pragma Default_Scalar_Storage_Order
15009 -- (High_Order_First | Low_Order_First);
15011 when Pragma_Default_Scalar_Storage_Order => DSSO : declare
15012 Default : Character;
15016 Check_Arg_Count (1);
15018 -- Default_Scalar_Storage_Order can appear as a configuration
15019 -- pragma, or in a declarative part of a package spec.
15021 if not Is_Configuration_Pragma then
15022 Check_Is_In_Decl_Part_Or_Package_Spec;
15025 Check_No_Identifiers;
15026 Check_Arg_Is_One_Of
15027 (Arg1, Name_High_Order_First, Name_Low_Order_First);
15028 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
15029 Default := Fold_Upper (Name_Buffer (1));
15031 if not Support_Nondefault_SSO_On_Target
15032 and then (Ttypes.Bytes_Big_Endian /= (Default = 'H'))
15034 if Warn_On_Unrecognized_Pragma then
15036 ("non-default Scalar_Storage_Order not supported "
15037 & "on target?g?", N);
15039 ("\pragma Default_Scalar_Storage_Order ignored?g?", N);
15042 -- Here set the specified default
15045 Opt.Default_SSO := Default;
15049 --------------------------
15050 -- Default_Storage_Pool --
15051 --------------------------
15053 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
15055 when Pragma_Default_Storage_Pool => Default_Storage_Pool : declare
15060 Check_Arg_Count (1);
15062 -- Default_Storage_Pool can appear as a configuration pragma, or
15063 -- in a declarative part of a package spec.
15065 if not Is_Configuration_Pragma then
15066 Check_Is_In_Decl_Part_Or_Package_Spec;
15069 if From_Aspect_Specification (N) then
15071 E : constant Entity_Id := Entity (Corresponding_Aspect (N));
15073 if not In_Open_Scopes (E) then
15075 ("aspect must apply to package or subprogram", N);
15080 if Present (Arg1) then
15081 Pool := Get_Pragma_Arg (Arg1);
15083 -- Case of Default_Storage_Pool (null);
15085 if Nkind (Pool) = N_Null then
15088 -- This is an odd case, this is not really an expression,
15089 -- so we don't have a type for it. So just set the type to
15092 Set_Etype (Pool, Empty);
15094 -- Case of Default_Storage_Pool (storage_pool_NAME);
15097 -- If it's a configuration pragma, then the only allowed
15098 -- argument is "null".
15100 if Is_Configuration_Pragma then
15101 Error_Pragma_Arg ("NULL expected", Arg1);
15104 -- The expected type for a non-"null" argument is
15105 -- Root_Storage_Pool'Class, and the pool must be a variable.
15107 Analyze_And_Resolve
15108 (Pool, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
15110 if Is_Variable (Pool) then
15112 -- A pragma that applies to a Ghost entity becomes Ghost
15113 -- for the purposes of legality checks and removal of
15114 -- ignored Ghost code.
15116 Mark_Ghost_Pragma (N, Entity (Pool));
15120 ("default storage pool must be a variable", Arg1);
15124 -- Record the pool name (or null). Freeze.Freeze_Entity for an
15125 -- access type will use this information to set the appropriate
15126 -- attributes of the access type. If the pragma appears in a
15127 -- generic unit it is ignored, given that it may refer to a
15130 if not Inside_A_Generic then
15131 Default_Pool := Pool;
15134 end Default_Storage_Pool;
15140 -- pragma Depends (DEPENDENCY_RELATION);
15142 -- DEPENDENCY_RELATION ::=
15144 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
15146 -- DEPENDENCY_CLAUSE ::=
15147 -- OUTPUT_LIST =>[+] INPUT_LIST
15148 -- | NULL_DEPENDENCY_CLAUSE
15150 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
15152 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
15154 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
15156 -- OUTPUT ::= NAME | FUNCTION_RESULT
15159 -- where FUNCTION_RESULT is a function Result attribute_reference
15161 -- Characteristics:
15163 -- * Analysis - The annotation undergoes initial checks to verify
15164 -- the legal placement and context. Secondary checks fully analyze
15165 -- the dependency clauses in:
15167 -- Analyze_Depends_In_Decl_Part
15169 -- * Expansion - None.
15171 -- * Template - The annotation utilizes the generic template of the
15172 -- related subprogram [body] when it is:
15174 -- aspect on subprogram declaration
15175 -- aspect on stand-alone subprogram body
15176 -- pragma on stand-alone subprogram body
15178 -- The annotation must prepare its own template when it is:
15180 -- pragma on subprogram declaration
15182 -- * Globals - Capture of global references must occur after full
15185 -- * Instance - The annotation is instantiated automatically when
15186 -- the related generic subprogram [body] is instantiated except for
15187 -- the "pragma on subprogram declaration" case. In that scenario
15188 -- the annotation must instantiate itself.
15190 when Pragma_Depends => Depends : declare
15192 Spec_Id : Entity_Id;
15193 Subp_Decl : Node_Id;
15196 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
15200 -- Chain the pragma on the contract for further processing by
15201 -- Analyze_Depends_In_Decl_Part.
15203 Add_Contract_Item (N, Spec_Id);
15205 -- Fully analyze the pragma when it appears inside an entry
15206 -- or subprogram body because it cannot benefit from forward
15209 if Nkind_In (Subp_Decl, N_Entry_Body,
15211 N_Subprogram_Body_Stub)
15213 -- The legality checks of pragmas Depends and Global are
15214 -- affected by the SPARK mode in effect and the volatility
15215 -- of the context. In addition these two pragmas are subject
15216 -- to an inherent order:
15221 -- Analyze all these pragmas in the order outlined above
15223 Analyze_If_Present (Pragma_SPARK_Mode);
15224 Analyze_If_Present (Pragma_Volatile_Function);
15225 Analyze_If_Present (Pragma_Global);
15226 Analyze_Depends_In_Decl_Part (N);
15231 ---------------------
15232 -- Detect_Blocking --
15233 ---------------------
15235 -- pragma Detect_Blocking;
15237 when Pragma_Detect_Blocking =>
15239 Check_Arg_Count (0);
15240 Check_Valid_Configuration_Pragma;
15241 Detect_Blocking := True;
15243 ------------------------------------
15244 -- Disable_Atomic_Synchronization --
15245 ------------------------------------
15247 -- pragma Disable_Atomic_Synchronization [(Entity)];
15249 when Pragma_Disable_Atomic_Synchronization =>
15251 Process_Disable_Enable_Atomic_Sync (Name_Suppress);
15253 -------------------
15254 -- Discard_Names --
15255 -------------------
15257 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
15259 when Pragma_Discard_Names => Discard_Names : declare
15264 Check_Ada_83_Warning;
15266 -- Deal with configuration pragma case
15268 if Arg_Count = 0 and then Is_Configuration_Pragma then
15269 Global_Discard_Names := True;
15272 -- Otherwise, check correct appropriate context
15275 Check_Is_In_Decl_Part_Or_Package_Spec;
15277 if Arg_Count = 0 then
15279 -- If there is no parameter, then from now on this pragma
15280 -- applies to any enumeration, exception or tagged type
15281 -- defined in the current declarative part, and recursively
15282 -- to any nested scope.
15284 Set_Discard_Names (Current_Scope);
15288 Check_Arg_Count (1);
15289 Check_Optional_Identifier (Arg1, Name_On);
15290 Check_Arg_Is_Local_Name (Arg1);
15292 E_Id := Get_Pragma_Arg (Arg1);
15294 if Etype (E_Id) = Any_Type then
15298 E := Entity (E_Id);
15300 -- A pragma that applies to a Ghost entity becomes Ghost for
15301 -- the purposes of legality checks and removal of ignored
15304 Mark_Ghost_Pragma (N, E);
15306 if (Is_First_Subtype (E)
15308 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
15309 or else Ekind (E) = E_Exception
15311 Set_Discard_Names (E);
15312 Record_Rep_Item (E, N);
15316 ("inappropriate entity for pragma%", Arg1);
15322 ------------------------
15323 -- Dispatching_Domain --
15324 ------------------------
15326 -- pragma Dispatching_Domain (EXPRESSION);
15328 when Pragma_Dispatching_Domain => Dispatching_Domain : declare
15329 P : constant Node_Id := Parent (N);
15335 Check_No_Identifiers;
15336 Check_Arg_Count (1);
15338 -- This pragma is born obsolete, but not the aspect
15340 if not From_Aspect_Specification (N) then
15342 (No_Obsolescent_Features, Pragma_Identifier (N));
15345 if Nkind (P) = N_Task_Definition then
15346 Arg := Get_Pragma_Arg (Arg1);
15347 Ent := Defining_Identifier (Parent (P));
15349 -- A pragma that applies to a Ghost entity becomes Ghost for
15350 -- the purposes of legality checks and removal of ignored Ghost
15353 Mark_Ghost_Pragma (N, Ent);
15355 -- The expression must be analyzed in the special manner
15356 -- described in "Handling of Default and Per-Object
15357 -- Expressions" in sem.ads.
15359 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
15361 -- Check duplicate pragma before we chain the pragma in the Rep
15362 -- Item chain of Ent.
15364 Check_Duplicate_Pragma (Ent);
15365 Record_Rep_Item (Ent, N);
15367 -- Anything else is incorrect
15372 end Dispatching_Domain;
15378 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
15380 when Pragma_Elaborate => Elaborate : declare
15385 -- Pragma must be in context items list of a compilation unit
15387 if not Is_In_Context_Clause then
15391 -- Must be at least one argument
15393 if Arg_Count = 0 then
15394 Error_Pragma ("pragma% requires at least one argument");
15397 -- In Ada 83 mode, there can be no items following it in the
15398 -- context list except other pragmas and implicit with clauses
15399 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
15400 -- placement rule does not apply.
15402 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
15404 while Present (Citem) loop
15405 if Nkind (Citem) = N_Pragma
15406 or else (Nkind (Citem) = N_With_Clause
15407 and then Implicit_With (Citem))
15412 ("(Ada 83) pragma% must be at end of context clause");
15419 -- Finally, the arguments must all be units mentioned in a with
15420 -- clause in the same context clause. Note we already checked (in
15421 -- Par.Prag) that the arguments are all identifiers or selected
15425 Outer : while Present (Arg) loop
15426 Citem := First (List_Containing (N));
15427 Inner : while Citem /= N loop
15428 if Nkind (Citem) = N_With_Clause
15429 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
15431 Set_Elaborate_Present (Citem, True);
15432 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
15434 -- With the pragma present, elaboration calls on
15435 -- subprograms from the named unit need no further
15436 -- checks, as long as the pragma appears in the current
15437 -- compilation unit. If the pragma appears in some unit
15438 -- in the context, there might still be a need for an
15439 -- Elaborate_All_Desirable from the current compilation
15440 -- to the named unit, so we keep the check enabled. This
15441 -- does not apply in SPARK mode, where we allow pragma
15442 -- Elaborate, but we don't trust it to be right so we
15443 -- will still insist on the Elaborate_All.
15445 if Legacy_Elaboration_Checks
15446 and then In_Extended_Main_Source_Unit (N)
15447 and then SPARK_Mode /= On
15449 Set_Suppress_Elaboration_Warnings
15450 (Entity (Name (Citem)));
15461 ("argument of pragma% is not withed unit", Arg);
15468 -------------------
15469 -- Elaborate_All --
15470 -------------------
15472 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
15474 when Pragma_Elaborate_All => Elaborate_All : declare
15479 Check_Ada_83_Warning;
15481 -- Pragma must be in context items list of a compilation unit
15483 if not Is_In_Context_Clause then
15487 -- Must be at least one argument
15489 if Arg_Count = 0 then
15490 Error_Pragma ("pragma% requires at least one argument");
15493 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
15494 -- have to appear at the end of the context clause, but may
15495 -- appear mixed in with other items, even in Ada 83 mode.
15497 -- Final check: the arguments must all be units mentioned in
15498 -- a with clause in the same context clause. Note that we
15499 -- already checked (in Par.Prag) that all the arguments are
15500 -- either identifiers or selected components.
15503 Outr : while Present (Arg) loop
15504 Citem := First (List_Containing (N));
15505 Innr : while Citem /= N loop
15506 if Nkind (Citem) = N_With_Clause
15507 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
15509 Set_Elaborate_All_Present (Citem, True);
15510 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
15512 -- Suppress warnings and elaboration checks on the named
15513 -- unit if the pragma is in the current compilation, as
15514 -- for pragma Elaborate.
15516 if Legacy_Elaboration_Checks
15517 and then In_Extended_Main_Source_Unit (N)
15519 Set_Suppress_Elaboration_Warnings
15520 (Entity (Name (Citem)));
15530 Set_Error_Posted (N);
15532 ("argument of pragma% is not withed unit", Arg);
15539 --------------------
15540 -- Elaborate_Body --
15541 --------------------
15543 -- pragma Elaborate_Body [( library_unit_NAME )];
15545 when Pragma_Elaborate_Body => Elaborate_Body : declare
15546 Cunit_Node : Node_Id;
15547 Cunit_Ent : Entity_Id;
15550 Check_Ada_83_Warning;
15551 Check_Valid_Library_Unit_Pragma;
15553 if Nkind (N) = N_Null_Statement then
15557 Cunit_Node := Cunit (Current_Sem_Unit);
15558 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
15560 -- A pragma that applies to a Ghost entity becomes Ghost for the
15561 -- purposes of legality checks and removal of ignored Ghost code.
15563 Mark_Ghost_Pragma (N, Cunit_Ent);
15565 if Nkind_In (Unit (Cunit_Node), N_Package_Body,
15568 Error_Pragma ("pragma% must refer to a spec, not a body");
15570 Set_Body_Required (Cunit_Node);
15571 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
15573 -- If we are in dynamic elaboration mode, then we suppress
15574 -- elaboration warnings for the unit, since it is definitely
15575 -- fine NOT to do dynamic checks at the first level (and such
15576 -- checks will be suppressed because no elaboration boolean
15577 -- is created for Elaborate_Body packages).
15579 -- But in the static model of elaboration, Elaborate_Body is
15580 -- definitely NOT good enough to ensure elaboration safety on
15581 -- its own, since the body may WITH other units that are not
15582 -- safe from an elaboration point of view, so a client must
15583 -- still do an Elaborate_All on such units.
15585 -- Debug flag -gnatdD restores the old behavior of 3.13, where
15586 -- Elaborate_Body always suppressed elab warnings.
15588 if Legacy_Elaboration_Checks
15589 and then (Dynamic_Elaboration_Checks or Debug_Flag_DD)
15591 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
15594 end Elaborate_Body;
15596 ------------------------
15597 -- Elaboration_Checks --
15598 ------------------------
15600 -- pragma Elaboration_Checks (Static | Dynamic);
15602 when Pragma_Elaboration_Checks => Elaboration_Checks : declare
15603 procedure Check_Duplicate_Elaboration_Checks_Pragma;
15604 -- Emit an error if the current context list already contains
15605 -- a previous Elaboration_Checks pragma. This routine raises
15606 -- Pragma_Exit if a duplicate is found.
15608 procedure Ignore_Elaboration_Checks_Pragma;
15609 -- Warn that the effects of the pragma are ignored. This routine
15610 -- raises Pragma_Exit.
15612 -----------------------------------------------
15613 -- Check_Duplicate_Elaboration_Checks_Pragma --
15614 -----------------------------------------------
15616 procedure Check_Duplicate_Elaboration_Checks_Pragma is
15621 while Present (Item) loop
15622 if Nkind (Item) = N_Pragma
15623 and then Pragma_Name (Item) = Name_Elaboration_Checks
15633 end Check_Duplicate_Elaboration_Checks_Pragma;
15635 --------------------------------------
15636 -- Ignore_Elaboration_Checks_Pragma --
15637 --------------------------------------
15639 procedure Ignore_Elaboration_Checks_Pragma is
15641 Error_Msg_Name_1 := Pname;
15642 Error_Msg_N ("??effects of pragma % are ignored", N);
15644 ("\place pragma on initial declaration of library unit", N);
15647 end Ignore_Elaboration_Checks_Pragma;
15651 Context : constant Node_Id := Parent (N);
15654 -- Start of processing for Elaboration_Checks
15658 Check_Arg_Count (1);
15659 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
15661 -- The pragma appears in a configuration file
15663 if No (Context) then
15664 Check_Valid_Configuration_Pragma;
15665 Check_Duplicate_Elaboration_Checks_Pragma;
15667 -- The pragma acts as a configuration pragma in a compilation unit
15669 -- pragma Elaboration_Checks (...);
15670 -- package Pack is ...;
15672 elsif Nkind (Context) = N_Compilation_Unit
15673 and then List_Containing (N) = Context_Items (Context)
15675 Check_Valid_Configuration_Pragma;
15676 Check_Duplicate_Elaboration_Checks_Pragma;
15678 Unt := Unit (Context);
15680 -- The pragma must appear on the initial declaration of a unit.
15681 -- If this is not the case, warn that the effects of the pragma
15684 if Nkind (Unt) = N_Package_Body then
15685 Ignore_Elaboration_Checks_Pragma;
15687 -- Check the Acts_As_Spec flag of the compilation units itself
15688 -- to determine whether the subprogram body completes since it
15689 -- has not been analyzed yet. This is safe because compilation
15690 -- units are not overloadable.
15692 elsif Nkind (Unt) = N_Subprogram_Body
15693 and then not Acts_As_Spec (Context)
15695 Ignore_Elaboration_Checks_Pragma;
15697 elsif Nkind (Unt) = N_Subunit then
15698 Ignore_Elaboration_Checks_Pragma;
15701 -- Otherwise the pragma does not appear at the configuration level
15708 -- At this point the pragma is not a duplicate, and appears in the
15709 -- proper context. Set the elaboration model in effect.
15711 Dynamic_Elaboration_Checks :=
15712 Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic;
15713 end Elaboration_Checks;
15719 -- pragma Eliminate (
15720 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
15721 -- [Entity =>] IDENTIFIER |
15722 -- SELECTED_COMPONENT |
15724 -- [, Source_Location => SOURCE_TRACE]);
15726 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
15727 -- SOURCE_TRACE ::= STRING_LITERAL
15729 when Pragma_Eliminate => Eliminate : declare
15730 Args : Args_List (1 .. 5);
15731 Names : constant Name_List (1 .. 5) := (
15734 Name_Parameter_Types,
15736 Name_Source_Location);
15738 -- Note : Parameter_Types and Result_Type are leftovers from
15739 -- prior implementations of the pragma. They are not generated
15740 -- by the gnatelim tool, and play no role in selecting which
15741 -- of a set of overloaded names is chosen for elimination.
15743 Unit_Name : Node_Id renames Args (1);
15744 Entity : Node_Id renames Args (2);
15745 Parameter_Types : Node_Id renames Args (3);
15746 Result_Type : Node_Id renames Args (4);
15747 Source_Location : Node_Id renames Args (5);
15751 Check_Valid_Configuration_Pragma;
15752 Gather_Associations (Names, Args);
15754 if No (Unit_Name) then
15755 Error_Pragma ("missing Unit_Name argument for pragma%");
15759 and then (Present (Parameter_Types)
15761 Present (Result_Type)
15763 Present (Source_Location))
15765 Error_Pragma ("missing Entity argument for pragma%");
15768 if (Present (Parameter_Types)
15770 Present (Result_Type))
15772 Present (Source_Location)
15775 ("parameter profile and source location cannot be used "
15776 & "together in pragma%");
15779 Process_Eliminate_Pragma
15788 -----------------------------------
15789 -- Enable_Atomic_Synchronization --
15790 -----------------------------------
15792 -- pragma Enable_Atomic_Synchronization [(Entity)];
15794 when Pragma_Enable_Atomic_Synchronization =>
15796 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
15803 -- [ Convention =>] convention_IDENTIFIER,
15804 -- [ Entity =>] LOCAL_NAME
15805 -- [, [External_Name =>] static_string_EXPRESSION ]
15806 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15808 when Pragma_Export => Export : declare
15810 Def_Id : Entity_Id;
15812 pragma Warnings (Off, C);
15815 Check_Ada_83_Warning;
15819 Name_External_Name,
15822 Check_At_Least_N_Arguments (2);
15823 Check_At_Most_N_Arguments (4);
15825 -- In Relaxed_RM_Semantics, support old Ada 83 style:
15826 -- pragma Export (Entity, "external name");
15828 if Relaxed_RM_Semantics
15829 and then Arg_Count = 2
15830 and then Nkind (Expression (Arg2)) = N_String_Literal
15833 Def_Id := Get_Pragma_Arg (Arg1);
15836 if not Is_Entity_Name (Def_Id) then
15837 Error_Pragma_Arg ("entity name required", Arg1);
15840 Def_Id := Entity (Def_Id);
15841 Set_Exported (Def_Id, Arg1);
15844 Process_Convention (C, Def_Id);
15846 -- A pragma that applies to a Ghost entity becomes Ghost for
15847 -- the purposes of legality checks and removal of ignored Ghost
15850 Mark_Ghost_Pragma (N, Def_Id);
15852 if Ekind (Def_Id) /= E_Constant then
15853 Note_Possible_Modification
15854 (Get_Pragma_Arg (Arg2), Sure => False);
15857 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
15858 Set_Exported (Def_Id, Arg2);
15861 -- If the entity is a deferred constant, propagate the information
15862 -- to the full view, because gigi elaborates the full view only.
15864 if Ekind (Def_Id) = E_Constant
15865 and then Present (Full_View (Def_Id))
15868 Id2 : constant Entity_Id := Full_View (Def_Id);
15870 Set_Is_Exported (Id2, Is_Exported (Def_Id));
15871 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
15872 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
15877 ---------------------
15878 -- Export_Function --
15879 ---------------------
15881 -- pragma Export_Function (
15882 -- [Internal =>] LOCAL_NAME
15883 -- [, [External =>] EXTERNAL_SYMBOL]
15884 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15885 -- [, [Result_Type =>] TYPE_DESIGNATOR]
15886 -- [, [Mechanism =>] MECHANISM]
15887 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
15889 -- EXTERNAL_SYMBOL ::=
15891 -- | static_string_EXPRESSION
15893 -- PARAMETER_TYPES ::=
15895 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15897 -- TYPE_DESIGNATOR ::=
15899 -- | subtype_Name ' Access
15903 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15905 -- MECHANISM_ASSOCIATION ::=
15906 -- [formal_parameter_NAME =>] MECHANISM_NAME
15908 -- MECHANISM_NAME ::=
15912 when Pragma_Export_Function => Export_Function : declare
15913 Args : Args_List (1 .. 6);
15914 Names : constant Name_List (1 .. 6) := (
15917 Name_Parameter_Types,
15920 Name_Result_Mechanism);
15922 Internal : Node_Id renames Args (1);
15923 External : Node_Id renames Args (2);
15924 Parameter_Types : Node_Id renames Args (3);
15925 Result_Type : Node_Id renames Args (4);
15926 Mechanism : Node_Id renames Args (5);
15927 Result_Mechanism : Node_Id renames Args (6);
15931 Gather_Associations (Names, Args);
15932 Process_Extended_Import_Export_Subprogram_Pragma (
15933 Arg_Internal => Internal,
15934 Arg_External => External,
15935 Arg_Parameter_Types => Parameter_Types,
15936 Arg_Result_Type => Result_Type,
15937 Arg_Mechanism => Mechanism,
15938 Arg_Result_Mechanism => Result_Mechanism);
15939 end Export_Function;
15941 -------------------
15942 -- Export_Object --
15943 -------------------
15945 -- pragma Export_Object (
15946 -- [Internal =>] LOCAL_NAME
15947 -- [, [External =>] EXTERNAL_SYMBOL]
15948 -- [, [Size =>] EXTERNAL_SYMBOL]);
15950 -- EXTERNAL_SYMBOL ::=
15952 -- | static_string_EXPRESSION
15954 -- PARAMETER_TYPES ::=
15956 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15958 -- TYPE_DESIGNATOR ::=
15960 -- | subtype_Name ' Access
15964 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15966 -- MECHANISM_ASSOCIATION ::=
15967 -- [formal_parameter_NAME =>] MECHANISM_NAME
15969 -- MECHANISM_NAME ::=
15973 when Pragma_Export_Object => Export_Object : declare
15974 Args : Args_List (1 .. 3);
15975 Names : constant Name_List (1 .. 3) := (
15980 Internal : Node_Id renames Args (1);
15981 External : Node_Id renames Args (2);
15982 Size : Node_Id renames Args (3);
15986 Gather_Associations (Names, Args);
15987 Process_Extended_Import_Export_Object_Pragma (
15988 Arg_Internal => Internal,
15989 Arg_External => External,
15993 ----------------------
15994 -- Export_Procedure --
15995 ----------------------
15997 -- pragma Export_Procedure (
15998 -- [Internal =>] LOCAL_NAME
15999 -- [, [External =>] EXTERNAL_SYMBOL]
16000 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16001 -- [, [Mechanism =>] MECHANISM]);
16003 -- EXTERNAL_SYMBOL ::=
16005 -- | static_string_EXPRESSION
16007 -- PARAMETER_TYPES ::=
16009 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16011 -- TYPE_DESIGNATOR ::=
16013 -- | subtype_Name ' Access
16017 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16019 -- MECHANISM_ASSOCIATION ::=
16020 -- [formal_parameter_NAME =>] MECHANISM_NAME
16022 -- MECHANISM_NAME ::=
16026 when Pragma_Export_Procedure => Export_Procedure : declare
16027 Args : Args_List (1 .. 4);
16028 Names : constant Name_List (1 .. 4) := (
16031 Name_Parameter_Types,
16034 Internal : Node_Id renames Args (1);
16035 External : Node_Id renames Args (2);
16036 Parameter_Types : Node_Id renames Args (3);
16037 Mechanism : Node_Id renames Args (4);
16041 Gather_Associations (Names, Args);
16042 Process_Extended_Import_Export_Subprogram_Pragma (
16043 Arg_Internal => Internal,
16044 Arg_External => External,
16045 Arg_Parameter_Types => Parameter_Types,
16046 Arg_Mechanism => Mechanism);
16047 end Export_Procedure;
16053 -- pragma Export_Value (
16054 -- [Value =>] static_integer_EXPRESSION,
16055 -- [Link_Name =>] static_string_EXPRESSION);
16057 when Pragma_Export_Value =>
16059 Check_Arg_Order ((Name_Value, Name_Link_Name));
16060 Check_Arg_Count (2);
16062 Check_Optional_Identifier (Arg1, Name_Value);
16063 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
16065 Check_Optional_Identifier (Arg2, Name_Link_Name);
16066 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
16068 -----------------------------
16069 -- Export_Valued_Procedure --
16070 -----------------------------
16072 -- pragma Export_Valued_Procedure (
16073 -- [Internal =>] LOCAL_NAME
16074 -- [, [External =>] EXTERNAL_SYMBOL,]
16075 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16076 -- [, [Mechanism =>] MECHANISM]);
16078 -- EXTERNAL_SYMBOL ::=
16080 -- | static_string_EXPRESSION
16082 -- PARAMETER_TYPES ::=
16084 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16086 -- TYPE_DESIGNATOR ::=
16088 -- | subtype_Name ' Access
16092 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16094 -- MECHANISM_ASSOCIATION ::=
16095 -- [formal_parameter_NAME =>] MECHANISM_NAME
16097 -- MECHANISM_NAME ::=
16101 when Pragma_Export_Valued_Procedure =>
16102 Export_Valued_Procedure : declare
16103 Args : Args_List (1 .. 4);
16104 Names : constant Name_List (1 .. 4) := (
16107 Name_Parameter_Types,
16110 Internal : Node_Id renames Args (1);
16111 External : Node_Id renames Args (2);
16112 Parameter_Types : Node_Id renames Args (3);
16113 Mechanism : Node_Id renames Args (4);
16117 Gather_Associations (Names, Args);
16118 Process_Extended_Import_Export_Subprogram_Pragma (
16119 Arg_Internal => Internal,
16120 Arg_External => External,
16121 Arg_Parameter_Types => Parameter_Types,
16122 Arg_Mechanism => Mechanism);
16123 end Export_Valued_Procedure;
16125 -------------------
16126 -- Extend_System --
16127 -------------------
16129 -- pragma Extend_System ([Name =>] Identifier);
16131 when Pragma_Extend_System =>
16133 Check_Valid_Configuration_Pragma;
16134 Check_Arg_Count (1);
16135 Check_Optional_Identifier (Arg1, Name_Name);
16136 Check_Arg_Is_Identifier (Arg1);
16138 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
16141 and then Name_Buffer (1 .. 4) = "aux_"
16143 if Present (System_Extend_Pragma_Arg) then
16144 if Chars (Get_Pragma_Arg (Arg1)) =
16145 Chars (Expression (System_Extend_Pragma_Arg))
16149 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
16150 Error_Pragma ("pragma% conflicts with that #");
16154 System_Extend_Pragma_Arg := Arg1;
16156 if not GNAT_Mode then
16157 System_Extend_Unit := Arg1;
16161 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
16164 ------------------------
16165 -- Extensions_Allowed --
16166 ------------------------
16168 -- pragma Extensions_Allowed (ON | OFF);
16170 when Pragma_Extensions_Allowed =>
16172 Check_Arg_Count (1);
16173 Check_No_Identifiers;
16174 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
16176 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
16177 Extensions_Allowed := True;
16178 Ada_Version := Ada_Version_Type'Last;
16181 Extensions_Allowed := False;
16182 Ada_Version := Ada_Version_Explicit;
16183 Ada_Version_Pragma := Empty;
16186 ------------------------
16187 -- Extensions_Visible --
16188 ------------------------
16190 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
16192 -- Characteristics:
16194 -- * Analysis - The annotation is fully analyzed immediately upon
16195 -- elaboration as its expression must be static.
16197 -- * Expansion - None.
16199 -- * Template - The annotation utilizes the generic template of the
16200 -- related subprogram [body] when it is:
16202 -- aspect on subprogram declaration
16203 -- aspect on stand-alone subprogram body
16204 -- pragma on stand-alone subprogram body
16206 -- The annotation must prepare its own template when it is:
16208 -- pragma on subprogram declaration
16210 -- * Globals - Capture of global references must occur after full
16213 -- * Instance - The annotation is instantiated automatically when
16214 -- the related generic subprogram [body] is instantiated except for
16215 -- the "pragma on subprogram declaration" case. In that scenario
16216 -- the annotation must instantiate itself.
16218 when Pragma_Extensions_Visible => Extensions_Visible : declare
16219 Formal : Entity_Id;
16220 Has_OK_Formal : Boolean := False;
16221 Spec_Id : Entity_Id;
16222 Subp_Decl : Node_Id;
16226 Check_No_Identifiers;
16227 Check_At_Most_N_Arguments (1);
16230 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
16232 -- Abstract subprogram declaration
16234 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
16237 -- Generic subprogram declaration
16239 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
16242 -- Body acts as spec
16244 elsif Nkind (Subp_Decl) = N_Subprogram_Body
16245 and then No (Corresponding_Spec (Subp_Decl))
16249 -- Body stub acts as spec
16251 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
16252 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
16256 -- Subprogram declaration
16258 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
16261 -- Otherwise the pragma is associated with an illegal construct
16264 Error_Pragma ("pragma % must apply to a subprogram");
16268 -- Mark the pragma as Ghost if the related subprogram is also
16269 -- Ghost. This also ensures that any expansion performed further
16270 -- below will produce Ghost nodes.
16272 Spec_Id := Unique_Defining_Entity (Subp_Decl);
16273 Mark_Ghost_Pragma (N, Spec_Id);
16275 -- Chain the pragma on the contract for completeness
16277 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
16279 -- The legality checks of pragma Extension_Visible are affected
16280 -- by the SPARK mode in effect. Analyze all pragmas in specific
16283 Analyze_If_Present (Pragma_SPARK_Mode);
16285 -- Examine the formals of the related subprogram
16287 Formal := First_Formal (Spec_Id);
16288 while Present (Formal) loop
16290 -- At least one of the formals is of a specific tagged type,
16291 -- the pragma is legal.
16293 if Is_Specific_Tagged_Type (Etype (Formal)) then
16294 Has_OK_Formal := True;
16297 -- A generic subprogram with at least one formal of a private
16298 -- type ensures the legality of the pragma because the actual
16299 -- may be specifically tagged. Note that this is verified by
16300 -- the check above at instantiation time.
16302 elsif Is_Private_Type (Etype (Formal))
16303 and then Is_Generic_Type (Etype (Formal))
16305 Has_OK_Formal := True;
16309 Next_Formal (Formal);
16312 if not Has_OK_Formal then
16313 Error_Msg_Name_1 := Pname;
16314 Error_Msg_N (Fix_Error ("incorrect placement of pragma %"), N);
16316 ("\subprogram & lacks parameter of specific tagged or "
16317 & "generic private type", N, Spec_Id);
16322 -- Analyze the Boolean expression (if any)
16324 if Present (Arg1) then
16325 Check_Static_Boolean_Expression
16326 (Expression (Get_Argument (N, Spec_Id)));
16328 end Extensions_Visible;
16334 -- pragma External (
16335 -- [ Convention =>] convention_IDENTIFIER,
16336 -- [ Entity =>] LOCAL_NAME
16337 -- [, [External_Name =>] static_string_EXPRESSION ]
16338 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16340 when Pragma_External => External : declare
16343 pragma Warnings (Off, C);
16350 Name_External_Name,
16352 Check_At_Least_N_Arguments (2);
16353 Check_At_Most_N_Arguments (4);
16354 Process_Convention (C, E);
16356 -- A pragma that applies to a Ghost entity becomes Ghost for the
16357 -- purposes of legality checks and removal of ignored Ghost code.
16359 Mark_Ghost_Pragma (N, E);
16361 Note_Possible_Modification
16362 (Get_Pragma_Arg (Arg2), Sure => False);
16363 Process_Interface_Name (E, Arg3, Arg4, N);
16364 Set_Exported (E, Arg2);
16367 --------------------------
16368 -- External_Name_Casing --
16369 --------------------------
16371 -- pragma External_Name_Casing (
16372 -- UPPERCASE | LOWERCASE
16373 -- [, AS_IS | UPPERCASE | LOWERCASE]);
16375 when Pragma_External_Name_Casing =>
16377 Check_No_Identifiers;
16379 if Arg_Count = 2 then
16380 Check_Arg_Is_One_Of
16381 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
16383 case Chars (Get_Pragma_Arg (Arg2)) is
16385 Opt.External_Name_Exp_Casing := As_Is;
16387 when Name_Uppercase =>
16388 Opt.External_Name_Exp_Casing := Uppercase;
16390 when Name_Lowercase =>
16391 Opt.External_Name_Exp_Casing := Lowercase;
16398 Check_Arg_Count (1);
16401 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
16403 case Chars (Get_Pragma_Arg (Arg1)) is
16404 when Name_Uppercase =>
16405 Opt.External_Name_Imp_Casing := Uppercase;
16407 when Name_Lowercase =>
16408 Opt.External_Name_Imp_Casing := Lowercase;
16418 -- pragma Fast_Math;
16420 when Pragma_Fast_Math =>
16422 Check_No_Identifiers;
16423 Check_Valid_Configuration_Pragma;
16426 --------------------------
16427 -- Favor_Top_Level --
16428 --------------------------
16430 -- pragma Favor_Top_Level (type_NAME);
16432 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
16437 Check_No_Identifiers;
16438 Check_Arg_Count (1);
16439 Check_Arg_Is_Local_Name (Arg1);
16440 Typ := Entity (Get_Pragma_Arg (Arg1));
16442 -- A pragma that applies to a Ghost entity becomes Ghost for the
16443 -- purposes of legality checks and removal of ignored Ghost code.
16445 Mark_Ghost_Pragma (N, Typ);
16447 -- If it's an access-to-subprogram type (in particular, not a
16448 -- subtype), set the flag on that type.
16450 if Is_Access_Subprogram_Type (Typ) then
16451 Set_Can_Use_Internal_Rep (Typ, False);
16453 -- Otherwise it's an error (name denotes the wrong sort of entity)
16457 ("access-to-subprogram type expected",
16458 Get_Pragma_Arg (Arg1));
16460 end Favor_Top_Level;
16462 ---------------------------
16463 -- Finalize_Storage_Only --
16464 ---------------------------
16466 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
16468 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
16469 Assoc : constant Node_Id := Arg1;
16470 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
16475 Check_No_Identifiers;
16476 Check_Arg_Count (1);
16477 Check_Arg_Is_Local_Name (Arg1);
16479 Find_Type (Type_Id);
16480 Typ := Entity (Type_Id);
16483 or else Rep_Item_Too_Early (Typ, N)
16487 Typ := Underlying_Type (Typ);
16490 if not Is_Controlled (Typ) then
16491 Error_Pragma ("pragma% must specify controlled type");
16494 Check_First_Subtype (Arg1);
16496 if Finalize_Storage_Only (Typ) then
16497 Error_Pragma ("duplicate pragma%, only one allowed");
16499 elsif not Rep_Item_Too_Late (Typ, N) then
16500 Set_Finalize_Storage_Only (Base_Type (Typ), True);
16502 end Finalize_Storage;
16508 -- pragma Ghost [ (boolean_EXPRESSION) ];
16510 when Pragma_Ghost => Ghost : declare
16514 Orig_Stmt : Node_Id;
16515 Prev_Id : Entity_Id;
16520 Check_No_Identifiers;
16521 Check_At_Most_N_Arguments (1);
16525 while Present (Stmt) loop
16527 -- Skip prior pragmas, but check for duplicates
16529 if Nkind (Stmt) = N_Pragma then
16530 if Pragma_Name (Stmt) = Pname then
16537 -- Task unit declared without a definition cannot be subject to
16538 -- pragma Ghost (SPARK RM 6.9(19)).
16540 elsif Nkind_In (Stmt, N_Single_Task_Declaration,
16541 N_Task_Type_Declaration)
16543 Error_Pragma ("pragma % cannot apply to a task type");
16546 -- Skip internally generated code
16548 elsif not Comes_From_Source (Stmt) then
16549 Orig_Stmt := Original_Node (Stmt);
16551 -- When pragma Ghost applies to an untagged derivation, the
16552 -- derivation is transformed into a [sub]type declaration.
16554 if Nkind_In (Stmt, N_Full_Type_Declaration,
16555 N_Subtype_Declaration)
16556 and then Comes_From_Source (Orig_Stmt)
16557 and then Nkind (Orig_Stmt) = N_Full_Type_Declaration
16558 and then Nkind (Type_Definition (Orig_Stmt)) =
16559 N_Derived_Type_Definition
16561 Id := Defining_Entity (Stmt);
16564 -- When pragma Ghost applies to an object declaration which
16565 -- is initialized by means of a function call that returns
16566 -- on the secondary stack, the object declaration becomes a
16569 elsif Nkind (Stmt) = N_Object_Renaming_Declaration
16570 and then Comes_From_Source (Orig_Stmt)
16571 and then Nkind (Orig_Stmt) = N_Object_Declaration
16573 Id := Defining_Entity (Stmt);
16576 -- When pragma Ghost applies to an expression function, the
16577 -- expression function is transformed into a subprogram.
16579 elsif Nkind (Stmt) = N_Subprogram_Declaration
16580 and then Comes_From_Source (Orig_Stmt)
16581 and then Nkind (Orig_Stmt) = N_Expression_Function
16583 Id := Defining_Entity (Stmt);
16587 -- The pragma applies to a legal construct, stop the traversal
16589 elsif Nkind_In (Stmt, N_Abstract_Subprogram_Declaration,
16590 N_Full_Type_Declaration,
16591 N_Generic_Subprogram_Declaration,
16592 N_Object_Declaration,
16593 N_Private_Extension_Declaration,
16594 N_Private_Type_Declaration,
16595 N_Subprogram_Declaration,
16596 N_Subtype_Declaration)
16598 Id := Defining_Entity (Stmt);
16601 -- The pragma does not apply to a legal construct, issue an
16602 -- error and stop the analysis.
16606 ("pragma % must apply to an object, package, subprogram "
16611 Stmt := Prev (Stmt);
16614 Context := Parent (N);
16616 -- Handle compilation units
16618 if Nkind (Context) = N_Compilation_Unit_Aux then
16619 Context := Unit (Parent (Context));
16622 -- Protected and task types cannot be subject to pragma Ghost
16623 -- (SPARK RM 6.9(19)).
16625 if Nkind_In (Context, N_Protected_Body, N_Protected_Definition)
16627 Error_Pragma ("pragma % cannot apply to a protected type");
16630 elsif Nkind_In (Context, N_Task_Body, N_Task_Definition) then
16631 Error_Pragma ("pragma % cannot apply to a task type");
16637 -- When pragma Ghost is associated with a [generic] package, it
16638 -- appears in the visible declarations.
16640 if Nkind (Context) = N_Package_Specification
16641 and then Present (Visible_Declarations (Context))
16642 and then List_Containing (N) = Visible_Declarations (Context)
16644 Id := Defining_Entity (Context);
16646 -- Pragma Ghost applies to a stand-alone subprogram body
16648 elsif Nkind (Context) = N_Subprogram_Body
16649 and then No (Corresponding_Spec (Context))
16651 Id := Defining_Entity (Context);
16653 -- Pragma Ghost applies to a subprogram declaration that acts
16654 -- as a compilation unit.
16656 elsif Nkind (Context) = N_Subprogram_Declaration then
16657 Id := Defining_Entity (Context);
16659 -- Pragma Ghost applies to a generic subprogram
16661 elsif Nkind (Context) = N_Generic_Subprogram_Declaration then
16662 Id := Defining_Entity (Specification (Context));
16668 ("pragma % must apply to an object, package, subprogram or "
16673 -- Handle completions of types and constants that are subject to
16676 if Is_Record_Type (Id) or else Ekind (Id) = E_Constant then
16677 Prev_Id := Incomplete_Or_Partial_View (Id);
16679 if Present (Prev_Id) and then not Is_Ghost_Entity (Prev_Id) then
16680 Error_Msg_Name_1 := Pname;
16682 -- The full declaration of a deferred constant cannot be
16683 -- subject to pragma Ghost unless the deferred declaration
16684 -- is also Ghost (SPARK RM 6.9(9)).
16686 if Ekind (Prev_Id) = E_Constant then
16687 Error_Msg_Name_1 := Pname;
16688 Error_Msg_NE (Fix_Error
16689 ("pragma % must apply to declaration of deferred "
16690 & "constant &"), N, Id);
16693 -- Pragma Ghost may appear on the full view of an incomplete
16694 -- type because the incomplete declaration lacks aspects and
16695 -- cannot be subject to pragma Ghost.
16697 elsif Ekind (Prev_Id) = E_Incomplete_Type then
16700 -- The full declaration of a type cannot be subject to
16701 -- pragma Ghost unless the partial view is also Ghost
16702 -- (SPARK RM 6.9(9)).
16705 Error_Msg_NE (Fix_Error
16706 ("pragma % must apply to partial view of type &"),
16712 -- A synchronized object cannot be subject to pragma Ghost
16713 -- (SPARK RM 6.9(19)).
16715 elsif Ekind (Id) = E_Variable then
16716 if Is_Protected_Type (Etype (Id)) then
16717 Error_Pragma ("pragma % cannot apply to a protected object");
16720 elsif Is_Task_Type (Etype (Id)) then
16721 Error_Pragma ("pragma % cannot apply to a task object");
16726 -- Analyze the Boolean expression (if any)
16728 if Present (Arg1) then
16729 Expr := Get_Pragma_Arg (Arg1);
16731 Analyze_And_Resolve (Expr, Standard_Boolean);
16733 if Is_OK_Static_Expression (Expr) then
16735 -- "Ghostness" cannot be turned off once enabled within a
16736 -- region (SPARK RM 6.9(6)).
16738 if Is_False (Expr_Value (Expr))
16739 and then Ghost_Mode > None
16742 ("pragma % with value False cannot appear in enabled "
16747 -- Otherwie the expression is not static
16751 ("expression of pragma % must be static", Expr);
16756 Set_Is_Ghost_Entity (Id);
16763 -- pragma Global (GLOBAL_SPECIFICATION);
16765 -- GLOBAL_SPECIFICATION ::=
16768 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
16770 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
16772 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
16773 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
16774 -- GLOBAL_ITEM ::= NAME
16776 -- Characteristics:
16778 -- * Analysis - The annotation undergoes initial checks to verify
16779 -- the legal placement and context. Secondary checks fully analyze
16780 -- the dependency clauses in:
16782 -- Analyze_Global_In_Decl_Part
16784 -- * Expansion - None.
16786 -- * Template - The annotation utilizes the generic template of the
16787 -- related subprogram [body] when it is:
16789 -- aspect on subprogram declaration
16790 -- aspect on stand-alone subprogram body
16791 -- pragma on stand-alone subprogram body
16793 -- The annotation must prepare its own template when it is:
16795 -- pragma on subprogram declaration
16797 -- * Globals - Capture of global references must occur after full
16800 -- * Instance - The annotation is instantiated automatically when
16801 -- the related generic subprogram [body] is instantiated except for
16802 -- the "pragma on subprogram declaration" case. In that scenario
16803 -- the annotation must instantiate itself.
16805 when Pragma_Global => Global : declare
16807 Spec_Id : Entity_Id;
16808 Subp_Decl : Node_Id;
16811 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
16815 -- Chain the pragma on the contract for further processing by
16816 -- Analyze_Global_In_Decl_Part.
16818 Add_Contract_Item (N, Spec_Id);
16820 -- Fully analyze the pragma when it appears inside an entry
16821 -- or subprogram body because it cannot benefit from forward
16824 if Nkind_In (Subp_Decl, N_Entry_Body,
16826 N_Subprogram_Body_Stub)
16828 -- The legality checks of pragmas Depends and Global are
16829 -- affected by the SPARK mode in effect and the volatility
16830 -- of the context. In addition these two pragmas are subject
16831 -- to an inherent order:
16836 -- Analyze all these pragmas in the order outlined above
16838 Analyze_If_Present (Pragma_SPARK_Mode);
16839 Analyze_If_Present (Pragma_Volatile_Function);
16840 Analyze_Global_In_Decl_Part (N);
16841 Analyze_If_Present (Pragma_Depends);
16850 -- pragma Ident (static_string_EXPRESSION)
16852 -- Note: pragma Comment shares this processing. Pragma Ident is
16853 -- identical in effect to pragma Commment.
16855 when Pragma_Comment
16863 Check_Arg_Count (1);
16864 Check_No_Identifiers;
16865 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
16868 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
16875 GP := Parent (Parent (N));
16877 if Nkind_In (GP, N_Package_Declaration,
16878 N_Generic_Package_Declaration)
16883 -- If we have a compilation unit, then record the ident value,
16884 -- checking for improper duplication.
16886 if Nkind (GP) = N_Compilation_Unit then
16887 CS := Ident_String (Current_Sem_Unit);
16889 if Present (CS) then
16891 -- If we have multiple instances, concatenate them.
16893 Start_String (Strval (CS));
16894 Store_String_Char (' ');
16895 Store_String_Chars (Strval (Str));
16896 Set_Strval (CS, End_String);
16899 Set_Ident_String (Current_Sem_Unit, Str);
16902 -- For subunits, we just ignore the Ident, since in GNAT these
16903 -- are not separate object files, and hence not separate units
16904 -- in the unit table.
16906 elsif Nkind (GP) = N_Subunit then
16912 -------------------
16913 -- Ignore_Pragma --
16914 -------------------
16916 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
16918 -- Entirely handled in the parser, nothing to do here
16920 when Pragma_Ignore_Pragma =>
16923 ----------------------------
16924 -- Implementation_Defined --
16925 ----------------------------
16927 -- pragma Implementation_Defined (LOCAL_NAME);
16929 -- Marks previously declared entity as implementation defined. For
16930 -- an overloaded entity, applies to the most recent homonym.
16932 -- pragma Implementation_Defined;
16934 -- The form with no arguments appears anywhere within a scope, most
16935 -- typically a package spec, and indicates that all entities that are
16936 -- defined within the package spec are Implementation_Defined.
16938 when Pragma_Implementation_Defined => Implementation_Defined : declare
16943 Check_No_Identifiers;
16945 -- Form with no arguments
16947 if Arg_Count = 0 then
16948 Set_Is_Implementation_Defined (Current_Scope);
16950 -- Form with one argument
16953 Check_Arg_Count (1);
16954 Check_Arg_Is_Local_Name (Arg1);
16955 Ent := Entity (Get_Pragma_Arg (Arg1));
16956 Set_Is_Implementation_Defined (Ent);
16958 end Implementation_Defined;
16964 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
16966 -- IMPLEMENTATION_KIND ::=
16967 -- By_Entry | By_Protected_Procedure | By_Any | Optional
16969 -- "By_Any" and "Optional" are treated as synonyms in order to
16970 -- support Ada 2012 aspect Synchronization.
16972 when Pragma_Implemented => Implemented : declare
16973 Proc_Id : Entity_Id;
16978 Check_Arg_Count (2);
16979 Check_No_Identifiers;
16980 Check_Arg_Is_Identifier (Arg1);
16981 Check_Arg_Is_Local_Name (Arg1);
16982 Check_Arg_Is_One_Of (Arg2,
16985 Name_By_Protected_Procedure,
16988 -- Extract the name of the local procedure
16990 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
16992 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
16993 -- primitive procedure of a synchronized tagged type.
16995 if Ekind (Proc_Id) = E_Procedure
16996 and then Is_Primitive (Proc_Id)
16997 and then Present (First_Formal (Proc_Id))
16999 Typ := Etype (First_Formal (Proc_Id));
17001 if Is_Tagged_Type (Typ)
17004 -- Check for a protected, a synchronized or a task interface
17006 ((Is_Interface (Typ)
17007 and then Is_Synchronized_Interface (Typ))
17009 -- Check for a protected type or a task type that implements
17013 (Is_Concurrent_Record_Type (Typ)
17014 and then Present (Interfaces (Typ)))
17016 -- In analysis-only mode, examine original protected type
17019 (Nkind (Parent (Typ)) = N_Protected_Type_Declaration
17020 and then Present (Interface_List (Parent (Typ))))
17022 -- Check for a private record extension with keyword
17026 (Ekind_In (Typ, E_Record_Type_With_Private,
17027 E_Record_Subtype_With_Private)
17028 and then Synchronized_Present (Parent (Typ))))
17033 ("controlling formal must be of synchronized tagged type",
17038 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
17039 -- By_Protected_Procedure to the primitive procedure of a task
17042 if Chars (Arg2) = Name_By_Protected_Procedure
17043 and then Is_Interface (Typ)
17044 and then Is_Task_Interface (Typ)
17047 ("implementation kind By_Protected_Procedure cannot be "
17048 & "applied to a task interface primitive", Arg2);
17052 -- Procedures declared inside a protected type must be accepted
17054 elsif Ekind (Proc_Id) = E_Procedure
17055 and then Is_Protected_Type (Scope (Proc_Id))
17059 -- The first argument is not a primitive procedure
17063 ("pragma % must be applied to a primitive procedure", Arg1);
17067 Record_Rep_Item (Proc_Id, N);
17070 ----------------------
17071 -- Implicit_Packing --
17072 ----------------------
17074 -- pragma Implicit_Packing;
17076 when Pragma_Implicit_Packing =>
17078 Check_Arg_Count (0);
17079 Implicit_Packing := True;
17086 -- [Convention =>] convention_IDENTIFIER,
17087 -- [Entity =>] LOCAL_NAME
17088 -- [, [External_Name =>] static_string_EXPRESSION ]
17089 -- [, [Link_Name =>] static_string_EXPRESSION ]);
17091 when Pragma_Import =>
17092 Check_Ada_83_Warning;
17096 Name_External_Name,
17099 Check_At_Least_N_Arguments (2);
17100 Check_At_Most_N_Arguments (4);
17101 Process_Import_Or_Interface;
17103 ---------------------
17104 -- Import_Function --
17105 ---------------------
17107 -- pragma Import_Function (
17108 -- [Internal =>] LOCAL_NAME,
17109 -- [, [External =>] EXTERNAL_SYMBOL]
17110 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17111 -- [, [Result_Type =>] SUBTYPE_MARK]
17112 -- [, [Mechanism =>] MECHANISM]
17113 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
17115 -- EXTERNAL_SYMBOL ::=
17117 -- | static_string_EXPRESSION
17119 -- PARAMETER_TYPES ::=
17121 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17123 -- TYPE_DESIGNATOR ::=
17125 -- | subtype_Name ' Access
17129 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17131 -- MECHANISM_ASSOCIATION ::=
17132 -- [formal_parameter_NAME =>] MECHANISM_NAME
17134 -- MECHANISM_NAME ::=
17138 when Pragma_Import_Function => Import_Function : declare
17139 Args : Args_List (1 .. 6);
17140 Names : constant Name_List (1 .. 6) := (
17143 Name_Parameter_Types,
17146 Name_Result_Mechanism);
17148 Internal : Node_Id renames Args (1);
17149 External : Node_Id renames Args (2);
17150 Parameter_Types : Node_Id renames Args (3);
17151 Result_Type : Node_Id renames Args (4);
17152 Mechanism : Node_Id renames Args (5);
17153 Result_Mechanism : Node_Id renames Args (6);
17157 Gather_Associations (Names, Args);
17158 Process_Extended_Import_Export_Subprogram_Pragma (
17159 Arg_Internal => Internal,
17160 Arg_External => External,
17161 Arg_Parameter_Types => Parameter_Types,
17162 Arg_Result_Type => Result_Type,
17163 Arg_Mechanism => Mechanism,
17164 Arg_Result_Mechanism => Result_Mechanism);
17165 end Import_Function;
17167 -------------------
17168 -- Import_Object --
17169 -------------------
17171 -- pragma Import_Object (
17172 -- [Internal =>] LOCAL_NAME
17173 -- [, [External =>] EXTERNAL_SYMBOL]
17174 -- [, [Size =>] EXTERNAL_SYMBOL]);
17176 -- EXTERNAL_SYMBOL ::=
17178 -- | static_string_EXPRESSION
17180 when Pragma_Import_Object => Import_Object : declare
17181 Args : Args_List (1 .. 3);
17182 Names : constant Name_List (1 .. 3) := (
17187 Internal : Node_Id renames Args (1);
17188 External : Node_Id renames Args (2);
17189 Size : Node_Id renames Args (3);
17193 Gather_Associations (Names, Args);
17194 Process_Extended_Import_Export_Object_Pragma (
17195 Arg_Internal => Internal,
17196 Arg_External => External,
17200 ----------------------
17201 -- Import_Procedure --
17202 ----------------------
17204 -- pragma Import_Procedure (
17205 -- [Internal =>] LOCAL_NAME
17206 -- [, [External =>] EXTERNAL_SYMBOL]
17207 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17208 -- [, [Mechanism =>] MECHANISM]);
17210 -- EXTERNAL_SYMBOL ::=
17212 -- | static_string_EXPRESSION
17214 -- PARAMETER_TYPES ::=
17216 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17218 -- TYPE_DESIGNATOR ::=
17220 -- | subtype_Name ' Access
17224 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17226 -- MECHANISM_ASSOCIATION ::=
17227 -- [formal_parameter_NAME =>] MECHANISM_NAME
17229 -- MECHANISM_NAME ::=
17233 when Pragma_Import_Procedure => Import_Procedure : declare
17234 Args : Args_List (1 .. 4);
17235 Names : constant Name_List (1 .. 4) := (
17238 Name_Parameter_Types,
17241 Internal : Node_Id renames Args (1);
17242 External : Node_Id renames Args (2);
17243 Parameter_Types : Node_Id renames Args (3);
17244 Mechanism : Node_Id renames Args (4);
17248 Gather_Associations (Names, Args);
17249 Process_Extended_Import_Export_Subprogram_Pragma (
17250 Arg_Internal => Internal,
17251 Arg_External => External,
17252 Arg_Parameter_Types => Parameter_Types,
17253 Arg_Mechanism => Mechanism);
17254 end Import_Procedure;
17256 -----------------------------
17257 -- Import_Valued_Procedure --
17258 -----------------------------
17260 -- pragma Import_Valued_Procedure (
17261 -- [Internal =>] LOCAL_NAME
17262 -- [, [External =>] EXTERNAL_SYMBOL]
17263 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17264 -- [, [Mechanism =>] MECHANISM]);
17266 -- EXTERNAL_SYMBOL ::=
17268 -- | static_string_EXPRESSION
17270 -- PARAMETER_TYPES ::=
17272 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17274 -- TYPE_DESIGNATOR ::=
17276 -- | subtype_Name ' Access
17280 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17282 -- MECHANISM_ASSOCIATION ::=
17283 -- [formal_parameter_NAME =>] MECHANISM_NAME
17285 -- MECHANISM_NAME ::=
17289 when Pragma_Import_Valued_Procedure =>
17290 Import_Valued_Procedure : declare
17291 Args : Args_List (1 .. 4);
17292 Names : constant Name_List (1 .. 4) := (
17295 Name_Parameter_Types,
17298 Internal : Node_Id renames Args (1);
17299 External : Node_Id renames Args (2);
17300 Parameter_Types : Node_Id renames Args (3);
17301 Mechanism : Node_Id renames Args (4);
17305 Gather_Associations (Names, Args);
17306 Process_Extended_Import_Export_Subprogram_Pragma (
17307 Arg_Internal => Internal,
17308 Arg_External => External,
17309 Arg_Parameter_Types => Parameter_Types,
17310 Arg_Mechanism => Mechanism);
17311 end Import_Valued_Procedure;
17317 -- pragma Independent (LOCAL_NAME);
17319 when Pragma_Independent =>
17320 Process_Atomic_Independent_Shared_Volatile;
17322 ----------------------------
17323 -- Independent_Components --
17324 ----------------------------
17326 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
17328 when Pragma_Independent_Components => Independent_Components : declare
17335 Check_Ada_83_Warning;
17337 Check_No_Identifiers;
17338 Check_Arg_Count (1);
17339 Check_Arg_Is_Local_Name (Arg1);
17340 E_Id := Get_Pragma_Arg (Arg1);
17342 if Etype (E_Id) = Any_Type then
17346 E := Entity (E_Id);
17348 -- A record type with a self-referential component of anonymous
17349 -- access type is given an incomplete view in order to handle the
17352 -- type Rec is record
17353 -- Self : access Rec;
17359 -- type Ptr is access Rec;
17360 -- type Rec is record
17364 -- Since the incomplete view is now the initial view of the type,
17365 -- the argument of the pragma will reference the incomplete view,
17366 -- but this view is illegal according to the semantics of the
17369 -- Obtain the full view of an internally-generated incomplete type
17370 -- only. This way an attempt to associate the pragma with a source
17371 -- incomplete type is still caught.
17373 if Ekind (E) = E_Incomplete_Type
17374 and then not Comes_From_Source (E)
17375 and then Present (Full_View (E))
17377 E := Full_View (E);
17380 -- A pragma that applies to a Ghost entity becomes Ghost for the
17381 -- purposes of legality checks and removal of ignored Ghost code.
17383 Mark_Ghost_Pragma (N, E);
17385 -- Check duplicate before we chain ourselves
17387 Check_Duplicate_Pragma (E);
17389 -- Check appropriate entity
17391 if Rep_Item_Too_Early (E, N)
17393 Rep_Item_Too_Late (E, N)
17398 D := Declaration_Node (E);
17400 -- The flag is set on the base type, or on the object
17402 if Nkind (D) = N_Full_Type_Declaration
17403 and then (Is_Array_Type (E) or else Is_Record_Type (E))
17405 Set_Has_Independent_Components (Base_Type (E));
17406 Record_Independence_Check (N, Base_Type (E));
17408 -- For record type, set all components independent
17410 if Is_Record_Type (E) then
17411 C := First_Component (E);
17412 while Present (C) loop
17413 Set_Is_Independent (C);
17414 Next_Component (C);
17418 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
17419 and then Nkind (D) = N_Object_Declaration
17420 and then Nkind (Object_Definition (D)) =
17421 N_Constrained_Array_Definition
17423 Set_Has_Independent_Components (E);
17424 Record_Independence_Check (N, E);
17427 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
17429 end Independent_Components;
17431 -----------------------
17432 -- Initial_Condition --
17433 -----------------------
17435 -- pragma Initial_Condition (boolean_EXPRESSION);
17437 -- Characteristics:
17439 -- * Analysis - The annotation undergoes initial checks to verify
17440 -- the legal placement and context. Secondary checks preanalyze the
17443 -- Analyze_Initial_Condition_In_Decl_Part
17445 -- * Expansion - The annotation is expanded during the expansion of
17446 -- the package body whose declaration is subject to the annotation
17449 -- Expand_Pragma_Initial_Condition
17451 -- * Template - The annotation utilizes the generic template of the
17452 -- related package declaration.
17454 -- * Globals - Capture of global references must occur after full
17457 -- * Instance - The annotation is instantiated automatically when
17458 -- the related generic package is instantiated.
17460 when Pragma_Initial_Condition => Initial_Condition : declare
17461 Pack_Decl : Node_Id;
17462 Pack_Id : Entity_Id;
17466 Check_No_Identifiers;
17467 Check_Arg_Count (1);
17469 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
17471 if not Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
17472 N_Package_Declaration)
17478 Pack_Id := Defining_Entity (Pack_Decl);
17480 -- A pragma that applies to a Ghost entity becomes Ghost for the
17481 -- purposes of legality checks and removal of ignored Ghost code.
17483 Mark_Ghost_Pragma (N, Pack_Id);
17485 -- Chain the pragma on the contract for further processing by
17486 -- Analyze_Initial_Condition_In_Decl_Part.
17488 Add_Contract_Item (N, Pack_Id);
17490 -- The legality checks of pragmas Abstract_State, Initializes, and
17491 -- Initial_Condition are affected by the SPARK mode in effect. In
17492 -- addition, these three pragmas are subject to an inherent order:
17494 -- 1) Abstract_State
17496 -- 3) Initial_Condition
17498 -- Analyze all these pragmas in the order outlined above
17500 Analyze_If_Present (Pragma_SPARK_Mode);
17501 Analyze_If_Present (Pragma_Abstract_State);
17502 Analyze_If_Present (Pragma_Initializes);
17503 end Initial_Condition;
17505 ------------------------
17506 -- Initialize_Scalars --
17507 ------------------------
17509 -- pragma Initialize_Scalars
17510 -- [ ( TYPE_VALUE_PAIR {, TYPE_VALUE_PAIR} ) ];
17512 -- TYPE_VALUE_PAIR ::=
17513 -- SCALAR_TYPE => static_EXPRESSION
17519 -- | Long_Long_Flat
17529 when Pragma_Initialize_Scalars => Do_Initialize_Scalars : declare
17530 Seen : array (Scalar_Id) of Node_Id := (others => Empty);
17531 -- This collection holds the individual pairs which specify the
17532 -- invalid values of their respective scalar types.
17534 procedure Analyze_Float_Value
17535 (Scal_Typ : Float_Scalar_Id;
17536 Val_Expr : Node_Id);
17537 -- Analyze a type value pair associated with float type Scal_Typ
17538 -- and expression Val_Expr.
17540 procedure Analyze_Integer_Value
17541 (Scal_Typ : Integer_Scalar_Id;
17542 Val_Expr : Node_Id);
17543 -- Analyze a type value pair associated with integer type Scal_Typ
17544 -- and expression Val_Expr.
17546 procedure Analyze_Type_Value_Pair (Pair : Node_Id);
17547 -- Analyze type value pair Pair
17549 -------------------------
17550 -- Analyze_Float_Value --
17551 -------------------------
17553 procedure Analyze_Float_Value
17554 (Scal_Typ : Float_Scalar_Id;
17555 Val_Expr : Node_Id)
17558 Analyze_And_Resolve (Val_Expr, Any_Real);
17560 if Is_OK_Static_Expression (Val_Expr) then
17561 Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value_R (Val_Expr));
17564 Error_Msg_Name_1 := Scal_Typ;
17565 Error_Msg_N ("value for type % must be static", Val_Expr);
17567 end Analyze_Float_Value;
17569 ---------------------------
17570 -- Analyze_Integer_Value --
17571 ---------------------------
17573 procedure Analyze_Integer_Value
17574 (Scal_Typ : Integer_Scalar_Id;
17575 Val_Expr : Node_Id)
17578 Analyze_And_Resolve (Val_Expr, Any_Integer);
17580 if Is_OK_Static_Expression (Val_Expr) then
17581 Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value (Val_Expr));
17584 Error_Msg_Name_1 := Scal_Typ;
17585 Error_Msg_N ("value for type % must be static", Val_Expr);
17587 end Analyze_Integer_Value;
17589 -----------------------------
17590 -- Analyze_Type_Value_Pair --
17591 -----------------------------
17593 procedure Analyze_Type_Value_Pair (Pair : Node_Id) is
17594 Scal_Typ : constant Name_Id := Chars (Pair);
17595 Val_Expr : constant Node_Id := Expression (Pair);
17596 Prev_Pair : Node_Id;
17599 if Scal_Typ in Scalar_Id then
17600 Prev_Pair := Seen (Scal_Typ);
17602 -- Prevent multiple attempts to set a value for a scalar
17605 if Present (Prev_Pair) then
17606 Error_Msg_Name_1 := Scal_Typ;
17608 ("cannot specify multiple invalid values for type %",
17611 Error_Msg_Sloc := Sloc (Prev_Pair);
17612 Error_Msg_N ("previous value set #", Pair);
17614 -- Ignore the effects of the pair, but do not halt the
17615 -- analysis of the pragma altogether.
17619 -- Otherwise capture the first pair for this scalar type
17622 Seen (Scal_Typ) := Pair;
17625 if Scal_Typ in Float_Scalar_Id then
17626 Analyze_Float_Value (Scal_Typ, Val_Expr);
17628 else pragma Assert (Scal_Typ in Integer_Scalar_Id);
17629 Analyze_Integer_Value (Scal_Typ, Val_Expr);
17632 -- Otherwise the scalar family is illegal
17635 Error_Msg_Name_1 := Pname;
17637 ("argument of pragma % must denote valid scalar family",
17640 end Analyze_Type_Value_Pair;
17644 Pairs : constant List_Id := Pragma_Argument_Associations (N);
17647 -- Start of processing for Do_Initialize_Scalars
17651 Check_Valid_Configuration_Pragma;
17652 Check_Restriction (No_Initialize_Scalars, N);
17654 -- Ignore the effects of the pragma when No_Initialize_Scalars is
17657 if Restriction_Active (No_Initialize_Scalars) then
17660 -- Initialize_Scalars creates false positives in CodePeer, and
17661 -- incorrect negative results in GNATprove mode, so ignore this
17662 -- pragma in these modes.
17664 elsif CodePeer_Mode or GNATprove_Mode then
17667 -- Otherwise analyze the pragma
17670 if Present (Pairs) then
17672 -- Install Standard in order to provide access to primitive
17673 -- types in case the expressions contain attributes such as
17676 Push_Scope (Standard_Standard);
17678 Pair := First (Pairs);
17679 while Present (Pair) loop
17680 Analyze_Type_Value_Pair (Pair);
17689 Init_Or_Norm_Scalars := True;
17690 Initialize_Scalars := True;
17692 end Do_Initialize_Scalars;
17698 -- pragma Initializes (INITIALIZATION_LIST);
17700 -- INITIALIZATION_LIST ::=
17702 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
17704 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
17709 -- | (INPUT {, INPUT})
17713 -- Characteristics:
17715 -- * Analysis - The annotation undergoes initial checks to verify
17716 -- the legal placement and context. Secondary checks preanalyze the
17719 -- Analyze_Initializes_In_Decl_Part
17721 -- * Expansion - None.
17723 -- * Template - The annotation utilizes the generic template of the
17724 -- related package declaration.
17726 -- * Globals - Capture of global references must occur after full
17729 -- * Instance - The annotation is instantiated automatically when
17730 -- the related generic package is instantiated.
17732 when Pragma_Initializes => Initializes : declare
17733 Pack_Decl : Node_Id;
17734 Pack_Id : Entity_Id;
17738 Check_No_Identifiers;
17739 Check_Arg_Count (1);
17741 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
17743 if not Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
17744 N_Package_Declaration)
17750 Pack_Id := Defining_Entity (Pack_Decl);
17752 -- A pragma that applies to a Ghost entity becomes Ghost for the
17753 -- purposes of legality checks and removal of ignored Ghost code.
17755 Mark_Ghost_Pragma (N, Pack_Id);
17756 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
17758 -- Chain the pragma on the contract for further processing by
17759 -- Analyze_Initializes_In_Decl_Part.
17761 Add_Contract_Item (N, Pack_Id);
17763 -- The legality checks of pragmas Abstract_State, Initializes, and
17764 -- Initial_Condition are affected by the SPARK mode in effect. In
17765 -- addition, these three pragmas are subject to an inherent order:
17767 -- 1) Abstract_State
17769 -- 3) Initial_Condition
17771 -- Analyze all these pragmas in the order outlined above
17773 Analyze_If_Present (Pragma_SPARK_Mode);
17774 Analyze_If_Present (Pragma_Abstract_State);
17775 Analyze_If_Present (Pragma_Initial_Condition);
17782 -- pragma Inline ( NAME {, NAME} );
17784 when Pragma_Inline =>
17786 -- Pragma always active unless in GNATprove mode. It is disabled
17787 -- in GNATprove mode because frontend inlining is applied
17788 -- independently of pragmas Inline and Inline_Always for
17789 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
17792 if not GNATprove_Mode then
17794 -- Inline status is Enabled if option -gnatn is specified.
17795 -- However this status determines only the value of the
17796 -- Is_Inlined flag on the subprogram and does not prevent
17797 -- the pragma itself from being recorded for later use,
17798 -- in particular for a later modification of Is_Inlined
17799 -- independently of the -gnatn option.
17801 -- In other words, if -gnatn is specified for a unit, then
17802 -- all Inline pragmas processed for the compilation of this
17803 -- unit, including those in the spec of other units, are
17804 -- activated, so subprograms will be inlined across units.
17806 -- If -gnatn is not specified, no Inline pragma is activated
17807 -- here, which means that subprograms will not be inlined
17808 -- across units. The Is_Inlined flag will nevertheless be
17809 -- set later when bodies are analyzed, so subprograms will
17810 -- be inlined within the unit.
17812 if Inline_Active then
17813 Process_Inline (Enabled);
17815 Process_Inline (Disabled);
17819 -------------------
17820 -- Inline_Always --
17821 -------------------
17823 -- pragma Inline_Always ( NAME {, NAME} );
17825 when Pragma_Inline_Always =>
17828 -- Pragma always active unless in CodePeer mode or GNATprove
17829 -- mode. It is disabled in CodePeer mode because inlining is
17830 -- not helpful, and enabling it caused walk order issues. It
17831 -- is disabled in GNATprove mode because frontend inlining is
17832 -- applied independently of pragmas Inline and Inline_Always for
17833 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
17836 if not CodePeer_Mode and not GNATprove_Mode then
17837 Process_Inline (Enabled);
17840 --------------------
17841 -- Inline_Generic --
17842 --------------------
17844 -- pragma Inline_Generic (NAME {, NAME});
17846 when Pragma_Inline_Generic =>
17848 Process_Generic_List;
17850 ----------------------
17851 -- Inspection_Point --
17852 ----------------------
17854 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
17856 when Pragma_Inspection_Point => Inspection_Point : declare
17863 if Arg_Count > 0 then
17866 Exp := Get_Pragma_Arg (Arg);
17869 if not Is_Entity_Name (Exp)
17870 or else not Is_Object (Entity (Exp))
17872 Error_Pragma_Arg ("object name required", Arg);
17876 exit when No (Arg);
17879 end Inspection_Point;
17885 -- pragma Interface (
17886 -- [ Convention =>] convention_IDENTIFIER,
17887 -- [ Entity =>] LOCAL_NAME
17888 -- [, [External_Name =>] static_string_EXPRESSION ]
17889 -- [, [Link_Name =>] static_string_EXPRESSION ]);
17891 when Pragma_Interface =>
17896 Name_External_Name,
17898 Check_At_Least_N_Arguments (2);
17899 Check_At_Most_N_Arguments (4);
17900 Process_Import_Or_Interface;
17902 -- In Ada 2005, the permission to use Interface (a reserved word)
17903 -- as a pragma name is considered an obsolescent feature, and this
17904 -- pragma was already obsolescent in Ada 95.
17906 if Ada_Version >= Ada_95 then
17908 (No_Obsolescent_Features, Pragma_Identifier (N));
17910 if Warn_On_Obsolescent_Feature then
17912 ("pragma Interface is an obsolescent feature?j?", N);
17914 ("|use pragma Import instead?j?", N);
17918 --------------------
17919 -- Interface_Name --
17920 --------------------
17922 -- pragma Interface_Name (
17923 -- [ Entity =>] LOCAL_NAME
17924 -- [,[External_Name =>] static_string_EXPRESSION ]
17925 -- [,[Link_Name =>] static_string_EXPRESSION ]);
17927 when Pragma_Interface_Name => Interface_Name : declare
17929 Def_Id : Entity_Id;
17930 Hom_Id : Entity_Id;
17936 ((Name_Entity, Name_External_Name, Name_Link_Name));
17937 Check_At_Least_N_Arguments (2);
17938 Check_At_Most_N_Arguments (3);
17939 Id := Get_Pragma_Arg (Arg1);
17942 -- This is obsolete from Ada 95 on, but it is an implementation
17943 -- defined pragma, so we do not consider that it violates the
17944 -- restriction (No_Obsolescent_Features).
17946 if Ada_Version >= Ada_95 then
17947 if Warn_On_Obsolescent_Feature then
17949 ("pragma Interface_Name is an obsolescent feature?j?", N);
17951 ("|use pragma Import instead?j?", N);
17955 if not Is_Entity_Name (Id) then
17957 ("first argument for pragma% must be entity name", Arg1);
17958 elsif Etype (Id) = Any_Type then
17961 Def_Id := Entity (Id);
17964 -- Special DEC-compatible processing for the object case, forces
17965 -- object to be imported.
17967 if Ekind (Def_Id) = E_Variable then
17968 Kill_Size_Check_Code (Def_Id);
17969 Note_Possible_Modification (Id, Sure => False);
17971 -- Initialization is not allowed for imported variable
17973 if Present (Expression (Parent (Def_Id)))
17974 and then Comes_From_Source (Expression (Parent (Def_Id)))
17976 Error_Msg_Sloc := Sloc (Def_Id);
17978 ("no initialization allowed for declaration of& #",
17982 -- For compatibility, support VADS usage of providing both
17983 -- pragmas Interface and Interface_Name to obtain the effect
17984 -- of a single Import pragma.
17986 if Is_Imported (Def_Id)
17987 and then Present (First_Rep_Item (Def_Id))
17988 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
17989 and then Pragma_Name (First_Rep_Item (Def_Id)) =
17994 Set_Imported (Def_Id);
17997 Set_Is_Public (Def_Id);
17998 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
18001 -- Otherwise must be subprogram
18003 elsif not Is_Subprogram (Def_Id) then
18005 ("argument of pragma% is not subprogram", Arg1);
18008 Check_At_Most_N_Arguments (3);
18012 -- Loop through homonyms
18015 Def_Id := Get_Base_Subprogram (Hom_Id);
18017 if Is_Imported (Def_Id) then
18018 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
18022 exit when From_Aspect_Specification (N);
18023 Hom_Id := Homonym (Hom_Id);
18025 exit when No (Hom_Id)
18026 or else Scope (Hom_Id) /= Current_Scope;
18031 ("argument of pragma% is not imported subprogram",
18035 end Interface_Name;
18037 -----------------------
18038 -- Interrupt_Handler --
18039 -----------------------
18041 -- pragma Interrupt_Handler (handler_NAME);
18043 when Pragma_Interrupt_Handler =>
18044 Check_Ada_83_Warning;
18045 Check_Arg_Count (1);
18046 Check_No_Identifiers;
18048 if No_Run_Time_Mode then
18049 Error_Msg_CRT ("Interrupt_Handler pragma", N);
18051 Check_Interrupt_Or_Attach_Handler;
18052 Process_Interrupt_Or_Attach_Handler;
18055 ------------------------
18056 -- Interrupt_Priority --
18057 ------------------------
18059 -- pragma Interrupt_Priority [(EXPRESSION)];
18061 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
18062 P : constant Node_Id := Parent (N);
18067 Check_Ada_83_Warning;
18069 if Arg_Count /= 0 then
18070 Arg := Get_Pragma_Arg (Arg1);
18071 Check_Arg_Count (1);
18072 Check_No_Identifiers;
18074 -- The expression must be analyzed in the special manner
18075 -- described in "Handling of Default and Per-Object
18076 -- Expressions" in sem.ads.
18078 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
18081 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
18086 Ent := Defining_Identifier (Parent (P));
18088 -- Check duplicate pragma before we chain the pragma in the Rep
18089 -- Item chain of Ent.
18091 Check_Duplicate_Pragma (Ent);
18092 Record_Rep_Item (Ent, N);
18094 -- Check the No_Task_At_Interrupt_Priority restriction
18096 if Nkind (P) = N_Task_Definition then
18097 Check_Restriction (No_Task_At_Interrupt_Priority, N);
18100 end Interrupt_Priority;
18102 ---------------------
18103 -- Interrupt_State --
18104 ---------------------
18106 -- pragma Interrupt_State (
18107 -- [Name =>] INTERRUPT_ID,
18108 -- [State =>] INTERRUPT_STATE);
18110 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
18111 -- INTERRUPT_STATE => System | Runtime | User
18113 -- Note: if the interrupt id is given as an identifier, then it must
18114 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
18115 -- given as a static integer expression which must be in the range of
18116 -- Ada.Interrupts.Interrupt_ID.
18118 when Pragma_Interrupt_State => Interrupt_State : declare
18119 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
18120 -- This is the entity Ada.Interrupts.Interrupt_ID;
18122 State_Type : Character;
18123 -- Set to 's'/'r'/'u' for System/Runtime/User
18126 -- Index to entry in Interrupt_States table
18129 -- Value of interrupt
18131 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
18132 -- The first argument to the pragma
18134 Int_Ent : Entity_Id;
18135 -- Interrupt entity in Ada.Interrupts.Names
18139 Check_Arg_Order ((Name_Name, Name_State));
18140 Check_Arg_Count (2);
18142 Check_Optional_Identifier (Arg1, Name_Name);
18143 Check_Optional_Identifier (Arg2, Name_State);
18144 Check_Arg_Is_Identifier (Arg2);
18146 -- First argument is identifier
18148 if Nkind (Arg1X) = N_Identifier then
18150 -- Search list of names in Ada.Interrupts.Names
18152 Int_Ent := First_Entity (RTE (RE_Names));
18154 if No (Int_Ent) then
18155 Error_Pragma_Arg ("invalid interrupt name", Arg1);
18157 elsif Chars (Int_Ent) = Chars (Arg1X) then
18158 Int_Val := Expr_Value (Constant_Value (Int_Ent));
18162 Next_Entity (Int_Ent);
18165 -- First argument is not an identifier, so it must be a static
18166 -- expression of type Ada.Interrupts.Interrupt_ID.
18169 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
18170 Int_Val := Expr_Value (Arg1X);
18172 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
18174 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
18177 ("value not in range of type "
18178 & """Ada.Interrupts.Interrupt_'I'D""", Arg1);
18184 case Chars (Get_Pragma_Arg (Arg2)) is
18185 when Name_Runtime => State_Type := 'r';
18186 when Name_System => State_Type := 's';
18187 when Name_User => State_Type := 'u';
18190 Error_Pragma_Arg ("invalid interrupt state", Arg2);
18193 -- Check if entry is already stored
18195 IST_Num := Interrupt_States.First;
18197 -- If entry not found, add it
18199 if IST_Num > Interrupt_States.Last then
18200 Interrupt_States.Append
18201 ((Interrupt_Number => UI_To_Int (Int_Val),
18202 Interrupt_State => State_Type,
18203 Pragma_Loc => Loc));
18206 -- Case of entry for the same entry
18208 elsif Int_Val = Interrupt_States.Table (IST_Num).
18211 -- If state matches, done, no need to make redundant entry
18214 State_Type = Interrupt_States.Table (IST_Num).
18217 -- Otherwise if state does not match, error
18220 Interrupt_States.Table (IST_Num).Pragma_Loc;
18222 ("state conflicts with that given #", Arg2);
18226 IST_Num := IST_Num + 1;
18228 end Interrupt_State;
18234 -- pragma Invariant
18235 -- ([Entity =>] type_LOCAL_NAME,
18236 -- [Check =>] EXPRESSION
18237 -- [,[Message =>] String_Expression]);
18239 when Pragma_Invariant => Invariant : declare
18246 Check_At_Least_N_Arguments (2);
18247 Check_At_Most_N_Arguments (3);
18248 Check_Optional_Identifier (Arg1, Name_Entity);
18249 Check_Optional_Identifier (Arg2, Name_Check);
18251 if Arg_Count = 3 then
18252 Check_Optional_Identifier (Arg3, Name_Message);
18253 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
18256 Check_Arg_Is_Local_Name (Arg1);
18258 Typ_Arg := Get_Pragma_Arg (Arg1);
18259 Find_Type (Typ_Arg);
18260 Typ := Entity (Typ_Arg);
18262 -- Nothing to do of the related type is erroneous in some way
18264 if Typ = Any_Type then
18267 -- AI12-0041: Invariants are allowed in interface types
18269 elsif Is_Interface (Typ) then
18272 -- An invariant must apply to a private type, or appear in the
18273 -- private part of a package spec and apply to a completion.
18274 -- a class-wide invariant can only appear on a private declaration
18275 -- or private extension, not a completion.
18277 -- A [class-wide] invariant may be associated a [limited] private
18278 -- type or a private extension.
18280 elsif Ekind_In (Typ, E_Limited_Private_Type,
18282 E_Record_Type_With_Private)
18286 -- A non-class-wide invariant may be associated with the full view
18287 -- of a [limited] private type or a private extension.
18289 elsif Has_Private_Declaration (Typ)
18290 and then not Class_Present (N)
18294 -- A class-wide invariant may appear on the partial view only
18296 elsif Class_Present (N) then
18298 ("pragma % only allowed for private type", Arg1);
18301 -- A regular invariant may appear on both views
18305 ("pragma % only allowed for private type or corresponding "
18306 & "full view", Arg1);
18310 -- An invariant associated with an abstract type (this includes
18311 -- interfaces) must be class-wide.
18313 if Is_Abstract_Type (Typ) and then not Class_Present (N) then
18315 ("pragma % not allowed for abstract type", Arg1);
18319 -- A pragma that applies to a Ghost entity becomes Ghost for the
18320 -- purposes of legality checks and removal of ignored Ghost code.
18322 Mark_Ghost_Pragma (N, Typ);
18324 -- The pragma defines a type-specific invariant, the type is said
18325 -- to have invariants of its "own".
18327 Set_Has_Own_Invariants (Typ);
18329 -- Set the Invariants_Ignored flag if that policy is in effect
18331 Set_Invariants_Ignored (Typ,
18332 Present (Check_Policy_List)
18334 (Policy_In_Effect (Name_Invariant) = Name_Ignore
18336 Policy_In_Effect (Name_Type_Invariant) = Name_Ignore));
18338 -- If the invariant is class-wide, then it can be inherited by
18339 -- derived or interface implementing types. The type is said to
18340 -- have "inheritable" invariants.
18342 if Class_Present (N) then
18343 Set_Has_Inheritable_Invariants (Typ);
18346 -- Chain the pragma on to the rep item chain, for processing when
18347 -- the type is frozen.
18349 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
18351 -- Create the declaration of the invariant procedure that will
18352 -- verify the invariant at run time. Interfaces are treated as the
18353 -- partial view of a private type in order to achieve uniformity
18354 -- with the general case. As a result, an interface receives only
18355 -- a "partial" invariant procedure, which is never called.
18357 Build_Invariant_Procedure_Declaration
18359 Partial_Invariant => Is_Interface (Typ));
18366 -- pragma Keep_Names ([On => ] LOCAL_NAME);
18368 when Pragma_Keep_Names => Keep_Names : declare
18373 Check_Arg_Count (1);
18374 Check_Optional_Identifier (Arg1, Name_On);
18375 Check_Arg_Is_Local_Name (Arg1);
18377 Arg := Get_Pragma_Arg (Arg1);
18380 if Etype (Arg) = Any_Type then
18384 if not Is_Entity_Name (Arg)
18385 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
18388 ("pragma% requires a local enumeration type", Arg1);
18391 Set_Discard_Names (Entity (Arg), False);
18398 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
18400 when Pragma_License =>
18403 -- Do not analyze pragma any further in CodePeer mode, to avoid
18404 -- extraneous errors in this implementation-dependent pragma,
18405 -- which has a different profile on other compilers.
18407 if CodePeer_Mode then
18411 Check_Arg_Count (1);
18412 Check_No_Identifiers;
18413 Check_Valid_Configuration_Pragma;
18414 Check_Arg_Is_Identifier (Arg1);
18417 Sind : constant Source_File_Index :=
18418 Source_Index (Current_Sem_Unit);
18421 case Chars (Get_Pragma_Arg (Arg1)) is
18423 Set_License (Sind, GPL);
18425 when Name_Modified_GPL =>
18426 Set_License (Sind, Modified_GPL);
18428 when Name_Restricted =>
18429 Set_License (Sind, Restricted);
18431 when Name_Unrestricted =>
18432 Set_License (Sind, Unrestricted);
18435 Error_Pragma_Arg ("invalid license name", Arg1);
18443 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
18445 when Pragma_Link_With => Link_With : declare
18451 if Operating_Mode = Generate_Code
18452 and then In_Extended_Main_Source_Unit (N)
18454 Check_At_Least_N_Arguments (1);
18455 Check_No_Identifiers;
18456 Check_Is_In_Decl_Part_Or_Package_Spec;
18457 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
18461 while Present (Arg) loop
18462 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
18464 -- Store argument, converting sequences of spaces to a
18465 -- single null character (this is one of the differences
18466 -- in processing between Link_With and Linker_Options).
18468 Arg_Store : declare
18469 C : constant Char_Code := Get_Char_Code (' ');
18470 S : constant String_Id :=
18471 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
18472 L : constant Nat := String_Length (S);
18475 procedure Skip_Spaces;
18476 -- Advance F past any spaces
18482 procedure Skip_Spaces is
18484 while F <= L and then Get_String_Char (S, F) = C loop
18489 -- Start of processing for Arg_Store
18492 Skip_Spaces; -- skip leading spaces
18494 -- Loop through characters, changing any embedded
18495 -- sequence of spaces to a single null character (this
18496 -- is how Link_With/Linker_Options differ)
18499 if Get_String_Char (S, F) = C then
18502 Store_String_Char (ASCII.NUL);
18505 Store_String_Char (Get_String_Char (S, F));
18513 if Present (Arg) then
18514 Store_String_Char (ASCII.NUL);
18518 Store_Linker_Option_String (End_String);
18526 -- pragma Linker_Alias (
18527 -- [Entity =>] LOCAL_NAME
18528 -- [Target =>] static_string_EXPRESSION);
18530 when Pragma_Linker_Alias =>
18532 Check_Arg_Order ((Name_Entity, Name_Target));
18533 Check_Arg_Count (2);
18534 Check_Optional_Identifier (Arg1, Name_Entity);
18535 Check_Optional_Identifier (Arg2, Name_Target);
18536 Check_Arg_Is_Library_Level_Local_Name (Arg1);
18537 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
18539 -- The only processing required is to link this item on to the
18540 -- list of rep items for the given entity. This is accomplished
18541 -- by the call to Rep_Item_Too_Late (when no error is detected
18542 -- and False is returned).
18544 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
18547 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
18550 ------------------------
18551 -- Linker_Constructor --
18552 ------------------------
18554 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
18556 -- Code is shared with Linker_Destructor
18558 -----------------------
18559 -- Linker_Destructor --
18560 -----------------------
18562 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
18564 when Pragma_Linker_Constructor
18565 | Pragma_Linker_Destructor
18567 Linker_Constructor : declare
18573 Check_Arg_Count (1);
18574 Check_No_Identifiers;
18575 Check_Arg_Is_Local_Name (Arg1);
18576 Arg1_X := Get_Pragma_Arg (Arg1);
18578 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
18580 if not Is_Library_Level_Entity (Proc) then
18582 ("argument for pragma% must be library level entity", Arg1);
18585 -- The only processing required is to link this item on to the
18586 -- list of rep items for the given entity. This is accomplished
18587 -- by the call to Rep_Item_Too_Late (when no error is detected
18588 -- and False is returned).
18590 if Rep_Item_Too_Late (Proc, N) then
18593 Set_Has_Gigi_Rep_Item (Proc);
18595 end Linker_Constructor;
18597 --------------------
18598 -- Linker_Options --
18599 --------------------
18601 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
18603 when Pragma_Linker_Options => Linker_Options : declare
18607 Check_Ada_83_Warning;
18608 Check_No_Identifiers;
18609 Check_Arg_Count (1);
18610 Check_Is_In_Decl_Part_Or_Package_Spec;
18611 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
18612 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
18615 while Present (Arg) loop
18616 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
18617 Store_String_Char (ASCII.NUL);
18619 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
18623 if Operating_Mode = Generate_Code
18624 and then In_Extended_Main_Source_Unit (N)
18626 Store_Linker_Option_String (End_String);
18628 end Linker_Options;
18630 --------------------
18631 -- Linker_Section --
18632 --------------------
18634 -- pragma Linker_Section (
18635 -- [Entity =>] LOCAL_NAME
18636 -- [Section =>] static_string_EXPRESSION);
18638 when Pragma_Linker_Section => Linker_Section : declare
18643 Ghost_Error_Posted : Boolean := False;
18644 -- Flag set when an error concerning the illegal mix of Ghost and
18645 -- non-Ghost subprograms is emitted.
18647 Ghost_Id : Entity_Id := Empty;
18648 -- The entity of the first Ghost subprogram encountered while
18649 -- processing the arguments of the pragma.
18653 Check_Arg_Order ((Name_Entity, Name_Section));
18654 Check_Arg_Count (2);
18655 Check_Optional_Identifier (Arg1, Name_Entity);
18656 Check_Optional_Identifier (Arg2, Name_Section);
18657 Check_Arg_Is_Library_Level_Local_Name (Arg1);
18658 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
18660 -- Check kind of entity
18662 Arg := Get_Pragma_Arg (Arg1);
18663 Ent := Entity (Arg);
18665 case Ekind (Ent) is
18667 -- Objects (constants and variables) and types. For these cases
18668 -- all we need to do is to set the Linker_Section_pragma field,
18669 -- checking that we do not have a duplicate.
18675 LPE := Linker_Section_Pragma (Ent);
18677 if Present (LPE) then
18678 Error_Msg_Sloc := Sloc (LPE);
18680 ("Linker_Section already specified for &#", Arg1, Ent);
18683 Set_Linker_Section_Pragma (Ent, N);
18685 -- A pragma that applies to a Ghost entity becomes Ghost for
18686 -- the purposes of legality checks and removal of ignored
18689 Mark_Ghost_Pragma (N, Ent);
18693 when Subprogram_Kind =>
18695 -- Aspect case, entity already set
18697 if From_Aspect_Specification (N) then
18698 Set_Linker_Section_Pragma
18699 (Entity (Corresponding_Aspect (N)), N);
18701 -- Propagate it to its ultimate aliased entity to
18702 -- facilitate the backend processing this attribute
18703 -- in instantiations of generic subprograms.
18705 if Present (Alias (Entity (Corresponding_Aspect (N))))
18707 Set_Linker_Section_Pragma
18709 (Entity (Corresponding_Aspect (N))), N);
18712 -- Pragma case, we must climb the homonym chain, but skip
18713 -- any for which the linker section is already set.
18717 if No (Linker_Section_Pragma (Ent)) then
18718 Set_Linker_Section_Pragma (Ent, N);
18720 -- Propagate it to its ultimate aliased entity to
18721 -- facilitate the backend processing this attribute
18722 -- in instantiations of generic subprograms.
18724 if Present (Alias (Ent)) then
18725 Set_Linker_Section_Pragma
18726 (Ultimate_Alias (Ent), N);
18729 -- A pragma that applies to a Ghost entity becomes
18730 -- Ghost for the purposes of legality checks and
18731 -- removal of ignored Ghost code.
18733 Mark_Ghost_Pragma (N, Ent);
18735 -- Capture the entity of the first Ghost subprogram
18736 -- being processed for error detection purposes.
18738 if Is_Ghost_Entity (Ent) then
18739 if No (Ghost_Id) then
18743 -- Otherwise the subprogram is non-Ghost. It is
18744 -- illegal to mix references to Ghost and non-Ghost
18745 -- entities (SPARK RM 6.9).
18747 elsif Present (Ghost_Id)
18748 and then not Ghost_Error_Posted
18750 Ghost_Error_Posted := True;
18752 Error_Msg_Name_1 := Pname;
18754 ("pragma % cannot mention ghost and "
18755 & "non-ghost subprograms", N);
18757 Error_Msg_Sloc := Sloc (Ghost_Id);
18759 ("\& # declared as ghost", N, Ghost_Id);
18761 Error_Msg_Sloc := Sloc (Ent);
18763 ("\& # declared as non-ghost", N, Ent);
18767 Ent := Homonym (Ent);
18769 or else Scope (Ent) /= Current_Scope;
18773 -- All other cases are illegal
18777 ("pragma% applies only to objects, subprograms, and types",
18780 end Linker_Section;
18786 -- pragma List (On | Off)
18788 -- There is nothing to do here, since we did all the processing for
18789 -- this pragma in Par.Prag (so that it works properly even in syntax
18792 when Pragma_List =>
18799 -- pragma Lock_Free [(Boolean_EXPRESSION)];
18801 when Pragma_Lock_Free => Lock_Free : declare
18802 P : constant Node_Id := Parent (N);
18808 Check_No_Identifiers;
18809 Check_At_Most_N_Arguments (1);
18811 -- Protected definition case
18813 if Nkind (P) = N_Protected_Definition then
18814 Ent := Defining_Identifier (Parent (P));
18818 if Arg_Count = 1 then
18819 Arg := Get_Pragma_Arg (Arg1);
18820 Val := Is_True (Static_Boolean (Arg));
18822 -- No arguments (expression is considered to be True)
18828 -- Check duplicate pragma before we chain the pragma in the Rep
18829 -- Item chain of Ent.
18831 Check_Duplicate_Pragma (Ent);
18832 Record_Rep_Item (Ent, N);
18833 Set_Uses_Lock_Free (Ent, Val);
18835 -- Anything else is incorrect placement
18842 --------------------
18843 -- Locking_Policy --
18844 --------------------
18846 -- pragma Locking_Policy (policy_IDENTIFIER);
18848 when Pragma_Locking_Policy => declare
18849 subtype LP_Range is Name_Id
18850 range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
18855 Check_Ada_83_Warning;
18856 Check_Arg_Count (1);
18857 Check_No_Identifiers;
18858 Check_Arg_Is_Locking_Policy (Arg1);
18859 Check_Valid_Configuration_Pragma;
18860 LP_Val := Chars (Get_Pragma_Arg (Arg1));
18863 when Name_Ceiling_Locking => LP := 'C';
18864 when Name_Concurrent_Readers_Locking => LP := 'R';
18865 when Name_Inheritance_Locking => LP := 'I';
18868 if Locking_Policy /= ' '
18869 and then Locking_Policy /= LP
18871 Error_Msg_Sloc := Locking_Policy_Sloc;
18872 Error_Pragma ("locking policy incompatible with policy#");
18874 -- Set new policy, but always preserve System_Location since we
18875 -- like the error message with the run time name.
18878 Locking_Policy := LP;
18880 if Locking_Policy_Sloc /= System_Location then
18881 Locking_Policy_Sloc := Loc;
18886 -------------------
18887 -- Loop_Optimize --
18888 -------------------
18890 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
18892 -- OPTIMIZATION_HINT ::=
18893 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
18895 when Pragma_Loop_Optimize => Loop_Optimize : declare
18900 Check_At_Least_N_Arguments (1);
18901 Check_No_Identifiers;
18903 Hint := First (Pragma_Argument_Associations (N));
18904 while Present (Hint) loop
18905 Check_Arg_Is_One_Of (Hint, Name_Ivdep,
18913 Check_Loop_Pragma_Placement;
18920 -- pragma Loop_Variant
18921 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
18923 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
18925 -- CHANGE_DIRECTION ::= Increases | Decreases
18927 when Pragma_Loop_Variant => Loop_Variant : declare
18932 Check_At_Least_N_Arguments (1);
18933 Check_Loop_Pragma_Placement;
18935 -- Process all increasing / decreasing expressions
18937 Variant := First (Pragma_Argument_Associations (N));
18938 while Present (Variant) loop
18939 if Chars (Variant) = No_Name then
18940 Error_Pragma_Arg_Ident ("expect name `Increases`", Variant);
18942 elsif not Nam_In (Chars (Variant), Name_Decreases,
18946 Name : String := Get_Name_String (Chars (Variant));
18949 -- It is a common mistake to write "Increasing" for
18950 -- "Increases" or "Decreasing" for "Decreases". Recognize
18951 -- specially names starting with "incr" or "decr" to
18952 -- suggest the corresponding name.
18954 System.Case_Util.To_Lower (Name);
18956 if Name'Length >= 4
18957 and then Name (1 .. 4) = "incr"
18959 Error_Pragma_Arg_Ident
18960 ("expect name `Increases`", Variant);
18962 elsif Name'Length >= 4
18963 and then Name (1 .. 4) = "decr"
18965 Error_Pragma_Arg_Ident
18966 ("expect name `Decreases`", Variant);
18969 Error_Pragma_Arg_Ident
18970 ("expect name `Increases` or `Decreases`", Variant);
18975 Preanalyze_Assert_Expression
18976 (Expression (Variant), Any_Discrete);
18982 -----------------------
18983 -- Machine_Attribute --
18984 -----------------------
18986 -- pragma Machine_Attribute (
18987 -- [Entity =>] LOCAL_NAME,
18988 -- [Attribute_Name =>] static_string_EXPRESSION
18989 -- [, [Info =>] static_EXPRESSION {, static_EXPRESSION}] );
18991 when Pragma_Machine_Attribute => Machine_Attribute : declare
18993 Def_Id : Entity_Id;
18997 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
18999 if Arg_Count >= 3 then
19000 Check_Optional_Identifier (Arg3, Name_Info);
19002 while Present (Arg) loop
19003 Check_Arg_Is_OK_Static_Expression (Arg);
19007 Check_Arg_Count (2);
19010 Check_Optional_Identifier (Arg1, Name_Entity);
19011 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
19012 Check_Arg_Is_Local_Name (Arg1);
19013 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
19014 Def_Id := Entity (Get_Pragma_Arg (Arg1));
19016 if Is_Access_Type (Def_Id) then
19017 Def_Id := Designated_Type (Def_Id);
19020 if Rep_Item_Too_Early (Def_Id, N) then
19024 Def_Id := Underlying_Type (Def_Id);
19026 -- The only processing required is to link this item on to the
19027 -- list of rep items for the given entity. This is accomplished
19028 -- by the call to Rep_Item_Too_Late (when no error is detected
19029 -- and False is returned).
19031 if Rep_Item_Too_Late (Def_Id, N) then
19034 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
19036 end Machine_Attribute;
19043 -- (MAIN_OPTION [, MAIN_OPTION]);
19046 -- [STACK_SIZE =>] static_integer_EXPRESSION
19047 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
19048 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
19050 when Pragma_Main => Main : declare
19051 Args : Args_List (1 .. 3);
19052 Names : constant Name_List (1 .. 3) := (
19054 Name_Task_Stack_Size_Default,
19055 Name_Time_Slicing_Enabled);
19061 Gather_Associations (Names, Args);
19063 for J in 1 .. 2 loop
19064 if Present (Args (J)) then
19065 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
19069 if Present (Args (3)) then
19070 Check_Arg_Is_OK_Static_Expression (Args (3), Standard_Boolean);
19074 while Present (Nod) loop
19075 if Nkind (Nod) = N_Pragma
19076 and then Pragma_Name (Nod) = Name_Main
19078 Error_Msg_Name_1 := Pname;
19079 Error_Msg_N ("duplicate pragma% not permitted", Nod);
19090 -- pragma Main_Storage
19091 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
19093 -- MAIN_STORAGE_OPTION ::=
19094 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
19095 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
19097 when Pragma_Main_Storage => Main_Storage : declare
19098 Args : Args_List (1 .. 2);
19099 Names : constant Name_List (1 .. 2) := (
19100 Name_Working_Storage,
19107 Gather_Associations (Names, Args);
19109 for J in 1 .. 2 loop
19110 if Present (Args (J)) then
19111 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
19115 Check_In_Main_Program;
19118 while Present (Nod) loop
19119 if Nkind (Nod) = N_Pragma
19120 and then Pragma_Name (Nod) = Name_Main_Storage
19122 Error_Msg_Name_1 := Pname;
19123 Error_Msg_N ("duplicate pragma% not permitted", Nod);
19130 ----------------------------
19131 -- Max_Entry_Queue_Length --
19132 ----------------------------
19134 -- pragma Max_Entry_Queue_Length (static_integer_EXPRESSION);
19136 -- This processing is shared by Pragma_Max_Entry_Queue_Depth and
19137 -- Pragma_Max_Queue_Length.
19139 when Pragma_Max_Entry_Queue_Length
19140 | Pragma_Max_Entry_Queue_Depth
19141 | Pragma_Max_Queue_Length
19143 Max_Entry_Queue_Length : declare
19145 Entry_Decl : Node_Id;
19146 Entry_Id : Entity_Id;
19150 if Prag_Id = Pragma_Max_Entry_Queue_Depth
19151 or else Prag_Id = Pragma_Max_Queue_Length
19156 Check_Arg_Count (1);
19159 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
19161 -- Entry declaration
19163 if Nkind (Entry_Decl) = N_Entry_Declaration then
19165 -- Entry illegally within a task
19167 if Nkind (Parent (N)) = N_Task_Definition then
19168 Error_Pragma ("pragma % cannot apply to task entries");
19172 Entry_Id := Defining_Entity (Entry_Decl);
19174 -- Otherwise the pragma is associated with an illegal construct
19177 Error_Pragma ("pragma % must apply to a protected entry");
19181 -- Mark the pragma as Ghost if the related subprogram is also
19182 -- Ghost. This also ensures that any expansion performed further
19183 -- below will produce Ghost nodes.
19185 Mark_Ghost_Pragma (N, Entry_Id);
19187 -- Analyze the Integer expression
19189 Arg := Get_Pragma_Arg (Arg1);
19190 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
19192 Val := Expr_Value (Arg);
19196 ("argument for pragma% cannot be less than -1", Arg1);
19198 elsif not UI_Is_In_Int_Range (Val) then
19200 ("argument for pragma% out of range of Integer", Arg1);
19204 Record_Rep_Item (Entry_Id, N);
19205 end Max_Entry_Queue_Length;
19211 -- pragma Memory_Size (NUMERIC_LITERAL)
19213 when Pragma_Memory_Size =>
19216 -- Memory size is simply ignored
19218 Check_No_Identifiers;
19219 Check_Arg_Count (1);
19220 Check_Arg_Is_Integer_Literal (Arg1);
19228 -- The only correct use of this pragma is on its own in a file, in
19229 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
19230 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
19231 -- check for a file containing nothing but a No_Body pragma). If we
19232 -- attempt to process it during normal semantics processing, it means
19233 -- it was misplaced.
19235 when Pragma_No_Body =>
19239 -----------------------------
19240 -- No_Elaboration_Code_All --
19241 -----------------------------
19243 -- pragma No_Elaboration_Code_All;
19245 when Pragma_No_Elaboration_Code_All =>
19247 Check_Valid_Library_Unit_Pragma;
19249 if Nkind (N) = N_Null_Statement then
19253 -- Must appear for a spec or generic spec
19255 if not Nkind_In (Unit (Cunit (Current_Sem_Unit)),
19256 N_Generic_Package_Declaration,
19257 N_Generic_Subprogram_Declaration,
19258 N_Package_Declaration,
19259 N_Subprogram_Declaration)
19263 ("pragma% can only occur for package "
19264 & "or subprogram spec"));
19267 -- Set flag in unit table
19269 Set_No_Elab_Code_All (Current_Sem_Unit);
19271 -- Set restriction No_Elaboration_Code if this is the main unit
19273 if Current_Sem_Unit = Main_Unit then
19274 Set_Restriction (No_Elaboration_Code, N);
19277 -- If we are in the main unit or in an extended main source unit,
19278 -- then we also add it to the configuration restrictions so that
19279 -- it will apply to all units in the extended main source.
19281 if Current_Sem_Unit = Main_Unit
19282 or else In_Extended_Main_Source_Unit (N)
19284 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
19287 -- If in main extended unit, activate transitive with test
19289 if In_Extended_Main_Source_Unit (N) then
19290 Opt.No_Elab_Code_All_Pragma := N;
19293 -----------------------------
19294 -- No_Component_Reordering --
19295 -----------------------------
19297 -- pragma No_Component_Reordering [([Entity =>] type_LOCAL_NAME)];
19299 when Pragma_No_Component_Reordering => No_Comp_Reordering : declare
19305 Check_At_Most_N_Arguments (1);
19307 if Arg_Count = 0 then
19308 Check_Valid_Configuration_Pragma;
19309 Opt.No_Component_Reordering := True;
19312 Check_Optional_Identifier (Arg2, Name_Entity);
19313 Check_Arg_Is_Local_Name (Arg1);
19314 E_Id := Get_Pragma_Arg (Arg1);
19316 if Etype (E_Id) = Any_Type then
19320 E := Entity (E_Id);
19322 if not Is_Record_Type (E) then
19323 Error_Pragma_Arg ("pragma% requires record type", Arg1);
19326 Set_No_Reordering (Base_Type (E));
19328 end No_Comp_Reordering;
19330 --------------------------
19331 -- No_Heap_Finalization --
19332 --------------------------
19334 -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];
19336 when Pragma_No_Heap_Finalization => No_Heap_Finalization : declare
19337 Context : constant Node_Id := Parent (N);
19338 Typ_Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
19344 Check_No_Identifiers;
19346 -- The pragma appears in a configuration file
19348 if No (Context) then
19349 Check_Arg_Count (0);
19350 Check_Valid_Configuration_Pragma;
19352 -- Detect a duplicate pragma
19354 if Present (No_Heap_Finalization_Pragma) then
19357 Prev => No_Heap_Finalization_Pragma);
19361 No_Heap_Finalization_Pragma := N;
19363 -- Otherwise the pragma should be associated with a library-level
19364 -- named access-to-object type.
19367 Check_Arg_Count (1);
19368 Check_Arg_Is_Local_Name (Arg1);
19370 Find_Type (Typ_Arg);
19371 Typ := Entity (Typ_Arg);
19373 -- The type being subjected to the pragma is erroneous
19375 if Typ = Any_Type then
19376 Error_Pragma ("cannot find type referenced by pragma %");
19378 -- The pragma is applied to an incomplete or generic formal
19379 -- type way too early.
19381 elsif Rep_Item_Too_Early (Typ, N) then
19385 Typ := Underlying_Type (Typ);
19388 -- The pragma must apply to an access-to-object type
19390 if Ekind_In (Typ, E_Access_Type, E_General_Access_Type) then
19393 -- Give a detailed error message on all other access type kinds
19395 elsif Ekind (Typ) = E_Access_Protected_Subprogram_Type then
19397 ("pragma % cannot apply to access protected subprogram "
19400 elsif Ekind (Typ) = E_Access_Subprogram_Type then
19402 ("pragma % cannot apply to access subprogram type");
19404 elsif Is_Anonymous_Access_Type (Typ) then
19406 ("pragma % cannot apply to anonymous access type");
19408 -- Give a general error message in case the pragma applies to a
19409 -- non-access type.
19413 ("pragma % must apply to library level access type");
19416 -- At this point the argument denotes an access-to-object type.
19417 -- Ensure that the type is declared at the library level.
19419 if Is_Library_Level_Entity (Typ) then
19422 -- Quietly ignore an access-to-object type originally declared
19423 -- at the library level within a generic, but instantiated at
19424 -- a non-library level. As a result the access-to-object type
19425 -- "loses" its No_Heap_Finalization property.
19427 elsif In_Instance then
19432 ("pragma % must apply to library level access type");
19435 -- Detect a duplicate pragma
19437 if Present (No_Heap_Finalization_Pragma) then
19440 Prev => No_Heap_Finalization_Pragma);
19444 Prev := Get_Pragma (Typ, Pragma_No_Heap_Finalization);
19446 if Present (Prev) then
19454 Record_Rep_Item (Typ, N);
19456 end No_Heap_Finalization;
19462 -- pragma No_Inline ( NAME {, NAME} );
19464 when Pragma_No_Inline =>
19466 Process_Inline (Suppressed);
19472 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
19474 when Pragma_No_Return => No_Return : declare
19480 Ghost_Error_Posted : Boolean := False;
19481 -- Flag set when an error concerning the illegal mix of Ghost and
19482 -- non-Ghost subprograms is emitted.
19484 Ghost_Id : Entity_Id := Empty;
19485 -- The entity of the first Ghost procedure encountered while
19486 -- processing the arguments of the pragma.
19490 Check_At_Least_N_Arguments (1);
19492 -- Loop through arguments of pragma
19495 while Present (Arg) loop
19496 Check_Arg_Is_Local_Name (Arg);
19497 Id := Get_Pragma_Arg (Arg);
19500 if not Is_Entity_Name (Id) then
19501 Error_Pragma_Arg ("entity name required", Arg);
19504 if Etype (Id) = Any_Type then
19508 -- Loop to find matching procedures
19514 and then Scope (E) = Current_Scope
19516 if Ekind_In (E, E_Generic_Procedure, E_Procedure) then
19518 -- Check that the pragma is not applied to a body.
19519 -- First check the specless body case, to give a
19520 -- different error message. These checks do not apply
19521 -- if Relaxed_RM_Semantics, to accommodate other Ada
19522 -- compilers. Disable these checks under -gnatd.J.
19524 if not Debug_Flag_Dot_JJ then
19525 if Nkind (Parent (Declaration_Node (E))) =
19527 and then not Relaxed_RM_Semantics
19530 ("pragma% requires separate spec and must come "
19534 -- Now the "specful" body case
19536 if Rep_Item_Too_Late (E, N) then
19543 -- A pragma that applies to a Ghost entity becomes Ghost
19544 -- for the purposes of legality checks and removal of
19545 -- ignored Ghost code.
19547 Mark_Ghost_Pragma (N, E);
19549 -- Capture the entity of the first Ghost procedure being
19550 -- processed for error detection purposes.
19552 if Is_Ghost_Entity (E) then
19553 if No (Ghost_Id) then
19557 -- Otherwise the subprogram is non-Ghost. It is illegal
19558 -- to mix references to Ghost and non-Ghost entities
19561 elsif Present (Ghost_Id)
19562 and then not Ghost_Error_Posted
19564 Ghost_Error_Posted := True;
19566 Error_Msg_Name_1 := Pname;
19568 ("pragma % cannot mention ghost and non-ghost "
19569 & "procedures", N);
19571 Error_Msg_Sloc := Sloc (Ghost_Id);
19572 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
19574 Error_Msg_Sloc := Sloc (E);
19575 Error_Msg_NE ("\& # declared as non-ghost", N, E);
19578 -- Set flag on any alias as well
19580 if Is_Overloadable (E) and then Present (Alias (E)) then
19581 Set_No_Return (Alias (E));
19587 exit when From_Aspect_Specification (N);
19591 -- If entity in not in current scope it may be the enclosing
19592 -- suprogram body to which the aspect applies.
19595 if Entity (Id) = Current_Scope
19596 and then From_Aspect_Specification (N)
19598 Set_No_Return (Entity (Id));
19600 Error_Pragma_Arg ("no procedure& found for pragma%", Arg);
19612 -- pragma No_Run_Time;
19614 -- Note: this pragma is retained for backwards compatibility. See
19615 -- body of Rtsfind for full details on its handling.
19617 when Pragma_No_Run_Time =>
19619 Check_Valid_Configuration_Pragma;
19620 Check_Arg_Count (0);
19622 -- Remove backward compatibility if Build_Type is FSF or GPL and
19623 -- generate a warning.
19626 Ignore : constant Boolean := Build_Type in FSF .. GPL;
19629 Error_Pragma ("pragma% is ignored, has no effect??");
19631 No_Run_Time_Mode := True;
19632 Configurable_Run_Time_Mode := True;
19634 -- Set Duration to 32 bits if word size is 32
19636 if Ttypes.System_Word_Size = 32 then
19637 Duration_32_Bits_On_Target := True;
19640 -- Set appropriate restrictions
19642 Set_Restriction (No_Finalization, N);
19643 Set_Restriction (No_Exception_Handlers, N);
19644 Set_Restriction (Max_Tasks, N, 0);
19645 Set_Restriction (No_Tasking, N);
19649 -----------------------
19650 -- No_Tagged_Streams --
19651 -----------------------
19653 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
19655 when Pragma_No_Tagged_Streams => No_Tagged_Strms : declare
19661 Check_At_Most_N_Arguments (1);
19663 -- One argument case
19665 if Arg_Count = 1 then
19666 Check_Optional_Identifier (Arg1, Name_Entity);
19667 Check_Arg_Is_Local_Name (Arg1);
19668 E_Id := Get_Pragma_Arg (Arg1);
19670 if Etype (E_Id) = Any_Type then
19674 E := Entity (E_Id);
19676 Check_Duplicate_Pragma (E);
19678 if not Is_Tagged_Type (E) or else Is_Derived_Type (E) then
19680 ("argument for pragma% must be root tagged type", Arg1);
19683 if Rep_Item_Too_Early (E, N)
19685 Rep_Item_Too_Late (E, N)
19689 Set_No_Tagged_Streams_Pragma (E, N);
19692 -- Zero argument case
19695 Check_Is_In_Decl_Part_Or_Package_Spec;
19696 No_Tagged_Streams := N;
19698 end No_Tagged_Strms;
19700 ------------------------
19701 -- No_Strict_Aliasing --
19702 ------------------------
19704 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
19706 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
19712 Check_At_Most_N_Arguments (1);
19714 if Arg_Count = 0 then
19715 Check_Valid_Configuration_Pragma;
19716 Opt.No_Strict_Aliasing := True;
19719 Check_Optional_Identifier (Arg2, Name_Entity);
19720 Check_Arg_Is_Local_Name (Arg1);
19721 E_Id := Get_Pragma_Arg (Arg1);
19723 if Etype (E_Id) = Any_Type then
19727 E := Entity (E_Id);
19729 if not Is_Access_Type (E) then
19730 Error_Pragma_Arg ("pragma% requires access type", Arg1);
19733 Set_No_Strict_Aliasing (Base_Type (E));
19735 end No_Strict_Aliasing;
19737 -----------------------
19738 -- Normalize_Scalars --
19739 -----------------------
19741 -- pragma Normalize_Scalars;
19743 when Pragma_Normalize_Scalars =>
19744 Check_Ada_83_Warning;
19745 Check_Arg_Count (0);
19746 Check_Valid_Configuration_Pragma;
19748 -- Normalize_Scalars creates false positives in CodePeer, and
19749 -- incorrect negative results in GNATprove mode, so ignore this
19750 -- pragma in these modes.
19752 if not (CodePeer_Mode or GNATprove_Mode) then
19753 Normalize_Scalars := True;
19754 Init_Or_Norm_Scalars := True;
19761 -- pragma Obsolescent;
19763 -- pragma Obsolescent (
19764 -- [Message =>] static_string_EXPRESSION
19765 -- [,[Version =>] Ada_05]]);
19767 -- pragma Obsolescent (
19768 -- [Entity =>] NAME
19769 -- [,[Message =>] static_string_EXPRESSION
19770 -- [,[Version =>] Ada_05]] );
19772 when Pragma_Obsolescent => Obsolescent : declare
19776 procedure Set_Obsolescent (E : Entity_Id);
19777 -- Given an entity Ent, mark it as obsolescent if appropriate
19779 ---------------------
19780 -- Set_Obsolescent --
19781 ---------------------
19783 procedure Set_Obsolescent (E : Entity_Id) is
19792 -- A pragma that applies to a Ghost entity becomes Ghost for
19793 -- the purposes of legality checks and removal of ignored Ghost
19796 Mark_Ghost_Pragma (N, E);
19798 -- Entity name was given
19800 if Present (Ename) then
19802 -- If entity name matches, we are fine.
19804 if Chars (Ename) = Chars (Ent) then
19805 Set_Entity (Ename, Ent);
19806 Generate_Reference (Ent, Ename);
19808 -- If entity name does not match, only possibility is an
19809 -- enumeration literal from an enumeration type declaration.
19811 elsif Ekind (Ent) /= E_Enumeration_Type then
19813 ("pragma % entity name does not match declaration");
19816 Ent := First_Literal (E);
19820 ("pragma % entity name does not match any "
19821 & "enumeration literal");
19823 elsif Chars (Ent) = Chars (Ename) then
19824 Set_Entity (Ename, Ent);
19825 Generate_Reference (Ent, Ename);
19829 Next_Literal (Ent);
19835 -- Ent points to entity to be marked
19837 if Arg_Count >= 1 then
19839 -- Deal with static string argument
19841 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
19842 S := Strval (Get_Pragma_Arg (Arg1));
19844 for J in 1 .. String_Length (S) loop
19845 if not In_Character_Range (Get_String_Char (S, J)) then
19847 ("pragma% argument does not allow wide characters",
19852 Obsolescent_Warnings.Append
19853 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
19855 -- Check for Ada_05 parameter
19857 if Arg_Count /= 1 then
19858 Check_Arg_Count (2);
19861 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
19864 Check_Arg_Is_Identifier (Argx);
19866 if Chars (Argx) /= Name_Ada_05 then
19867 Error_Msg_Name_2 := Name_Ada_05;
19869 ("only allowed argument for pragma% is %", Argx);
19872 if Ada_Version_Explicit < Ada_2005
19873 or else not Warn_On_Ada_2005_Compatibility
19881 -- Set flag if pragma active
19884 Set_Is_Obsolescent (Ent);
19888 end Set_Obsolescent;
19890 -- Start of processing for pragma Obsolescent
19895 Check_At_Most_N_Arguments (3);
19897 -- See if first argument specifies an entity name
19901 (Chars (Arg1) = Name_Entity
19903 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
19905 N_Operator_Symbol))
19907 Ename := Get_Pragma_Arg (Arg1);
19909 -- Eliminate first argument, so we can share processing
19913 Arg_Count := Arg_Count - 1;
19915 -- No Entity name argument given
19921 if Arg_Count >= 1 then
19922 Check_Optional_Identifier (Arg1, Name_Message);
19924 if Arg_Count = 2 then
19925 Check_Optional_Identifier (Arg2, Name_Version);
19929 -- Get immediately preceding declaration
19932 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
19936 -- Cases where we do not follow anything other than another pragma
19940 -- First case: library level compilation unit declaration with
19941 -- the pragma immediately following the declaration.
19943 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
19945 (Defining_Entity (Unit (Parent (Parent (N)))));
19948 -- Case 2: library unit placement for package
19952 Ent : constant Entity_Id := Find_Lib_Unit_Name;
19954 if Is_Package_Or_Generic_Package (Ent) then
19955 Set_Obsolescent (Ent);
19961 -- Cases where we must follow a declaration, including an
19962 -- abstract subprogram declaration, which is not in the
19963 -- other node subtypes.
19966 if Nkind (Decl) not in N_Declaration
19967 and then Nkind (Decl) not in N_Later_Decl_Item
19968 and then Nkind (Decl) not in N_Generic_Declaration
19969 and then Nkind (Decl) not in N_Renaming_Declaration
19970 and then Nkind (Decl) /= N_Abstract_Subprogram_Declaration
19973 ("pragma% misplaced, "
19974 & "must immediately follow a declaration");
19977 Set_Obsolescent (Defining_Entity (Decl));
19987 -- pragma Optimize (Time | Space | Off);
19989 -- The actual check for optimize is done in Gigi. Note that this
19990 -- pragma does not actually change the optimization setting, it
19991 -- simply checks that it is consistent with the pragma.
19993 when Pragma_Optimize =>
19994 Check_No_Identifiers;
19995 Check_Arg_Count (1);
19996 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
19998 ------------------------
19999 -- Optimize_Alignment --
20000 ------------------------
20002 -- pragma Optimize_Alignment (Time | Space | Off);
20004 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
20006 Check_No_Identifiers;
20007 Check_Arg_Count (1);
20008 Check_Valid_Configuration_Pragma;
20011 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
20014 when Name_Off => Opt.Optimize_Alignment := 'O';
20015 when Name_Space => Opt.Optimize_Alignment := 'S';
20016 when Name_Time => Opt.Optimize_Alignment := 'T';
20019 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
20023 -- Set indication that mode is set locally. If we are in fact in a
20024 -- configuration pragma file, this setting is harmless since the
20025 -- switch will get reset anyway at the start of each unit.
20027 Optimize_Alignment_Local := True;
20028 end Optimize_Alignment;
20034 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
20036 when Pragma_Ordered => Ordered : declare
20037 Assoc : constant Node_Id := Arg1;
20043 Check_No_Identifiers;
20044 Check_Arg_Count (1);
20045 Check_Arg_Is_Local_Name (Arg1);
20047 Type_Id := Get_Pragma_Arg (Assoc);
20048 Find_Type (Type_Id);
20049 Typ := Entity (Type_Id);
20051 if Typ = Any_Type then
20054 Typ := Underlying_Type (Typ);
20057 if not Is_Enumeration_Type (Typ) then
20058 Error_Pragma ("pragma% must specify enumeration type");
20061 Check_First_Subtype (Arg1);
20062 Set_Has_Pragma_Ordered (Base_Type (Typ));
20065 -------------------
20066 -- Overflow_Mode --
20067 -------------------
20069 -- pragma Overflow_Mode
20070 -- ([General => ] MODE [, [Assertions => ] MODE]);
20072 -- MODE := STRICT | MINIMIZED | ELIMINATED
20074 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
20075 -- since System.Bignums makes this assumption. This is true of nearly
20076 -- all (all?) targets.
20078 when Pragma_Overflow_Mode => Overflow_Mode : declare
20079 function Get_Overflow_Mode
20081 Arg : Node_Id) return Overflow_Mode_Type;
20082 -- Function to process one pragma argument, Arg. If an identifier
20083 -- is present, it must be Name. Mode type is returned if a valid
20084 -- argument exists, otherwise an error is signalled.
20086 -----------------------
20087 -- Get_Overflow_Mode --
20088 -----------------------
20090 function Get_Overflow_Mode
20092 Arg : Node_Id) return Overflow_Mode_Type
20094 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
20097 Check_Optional_Identifier (Arg, Name);
20098 Check_Arg_Is_Identifier (Argx);
20100 if Chars (Argx) = Name_Strict then
20103 elsif Chars (Argx) = Name_Minimized then
20106 elsif Chars (Argx) = Name_Eliminated then
20107 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then
20109 ("Eliminated not implemented on this target", Argx);
20115 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
20117 end Get_Overflow_Mode;
20119 -- Start of processing for Overflow_Mode
20123 Check_At_Least_N_Arguments (1);
20124 Check_At_Most_N_Arguments (2);
20126 -- Process first argument
20128 Scope_Suppress.Overflow_Mode_General :=
20129 Get_Overflow_Mode (Name_General, Arg1);
20131 -- Case of only one argument
20133 if Arg_Count = 1 then
20134 Scope_Suppress.Overflow_Mode_Assertions :=
20135 Scope_Suppress.Overflow_Mode_General;
20137 -- Case of two arguments present
20140 Scope_Suppress.Overflow_Mode_Assertions :=
20141 Get_Overflow_Mode (Name_Assertions, Arg2);
20145 --------------------------
20146 -- Overriding Renamings --
20147 --------------------------
20149 -- pragma Overriding_Renamings;
20151 when Pragma_Overriding_Renamings =>
20153 Check_Arg_Count (0);
20154 Check_Valid_Configuration_Pragma;
20155 Overriding_Renamings := True;
20161 -- pragma Pack (first_subtype_LOCAL_NAME);
20163 when Pragma_Pack => Pack : declare
20164 Assoc : constant Node_Id := Arg1;
20166 Ignore : Boolean := False;
20171 Check_No_Identifiers;
20172 Check_Arg_Count (1);
20173 Check_Arg_Is_Local_Name (Arg1);
20174 Type_Id := Get_Pragma_Arg (Assoc);
20176 if not Is_Entity_Name (Type_Id)
20177 or else not Is_Type (Entity (Type_Id))
20180 ("argument for pragma% must be type or subtype", Arg1);
20183 Find_Type (Type_Id);
20184 Typ := Entity (Type_Id);
20187 or else Rep_Item_Too_Early (Typ, N)
20191 Typ := Underlying_Type (Typ);
20194 -- A pragma that applies to a Ghost entity becomes Ghost for the
20195 -- purposes of legality checks and removal of ignored Ghost code.
20197 Mark_Ghost_Pragma (N, Typ);
20199 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
20200 Error_Pragma ("pragma% must specify array or record type");
20203 Check_First_Subtype (Arg1);
20204 Check_Duplicate_Pragma (Typ);
20208 if Is_Array_Type (Typ) then
20209 Ctyp := Component_Type (Typ);
20211 -- Ignore pack that does nothing
20213 if Known_Static_Esize (Ctyp)
20214 and then Known_Static_RM_Size (Ctyp)
20215 and then Esize (Ctyp) = RM_Size (Ctyp)
20216 and then Addressable (Esize (Ctyp))
20221 -- Process OK pragma Pack. Note that if there is a separate
20222 -- component clause present, the Pack will be cancelled. This
20223 -- processing is in Freeze.
20225 if not Rep_Item_Too_Late (Typ, N) then
20227 -- In CodePeer mode, we do not need complex front-end
20228 -- expansions related to pragma Pack, so disable handling
20231 if CodePeer_Mode then
20234 -- Normal case where we do the pack action
20238 Set_Is_Packed (Base_Type (Typ));
20239 Set_Has_Non_Standard_Rep (Base_Type (Typ));
20242 Set_Has_Pragma_Pack (Base_Type (Typ));
20246 -- For record types, the pack is always effective
20248 else pragma Assert (Is_Record_Type (Typ));
20249 if not Rep_Item_Too_Late (Typ, N) then
20250 Set_Is_Packed (Base_Type (Typ));
20251 Set_Has_Pragma_Pack (Base_Type (Typ));
20252 Set_Has_Non_Standard_Rep (Base_Type (Typ));
20263 -- There is nothing to do here, since we did all the processing for
20264 -- this pragma in Par.Prag (so that it works properly even in syntax
20267 when Pragma_Page =>
20274 -- pragma Part_Of (ABSTRACT_STATE);
20276 -- ABSTRACT_STATE ::= NAME
20278 when Pragma_Part_Of => Part_Of : declare
20279 procedure Propagate_Part_Of
20280 (Pack_Id : Entity_Id;
20281 State_Id : Entity_Id;
20282 Instance : Node_Id);
20283 -- Propagate the Part_Of indicator to all abstract states and
20284 -- objects declared in the visible state space of a package
20285 -- denoted by Pack_Id. State_Id is the encapsulating state.
20286 -- Instance is the package instantiation node.
20288 -----------------------
20289 -- Propagate_Part_Of --
20290 -----------------------
20292 procedure Propagate_Part_Of
20293 (Pack_Id : Entity_Id;
20294 State_Id : Entity_Id;
20295 Instance : Node_Id)
20297 Has_Item : Boolean := False;
20298 -- Flag set when the visible state space contains at least one
20299 -- abstract state or variable.
20301 procedure Propagate_Part_Of (Pack_Id : Entity_Id);
20302 -- Propagate the Part_Of indicator to all abstract states and
20303 -- objects declared in the visible state space of a package
20304 -- denoted by Pack_Id.
20306 -----------------------
20307 -- Propagate_Part_Of --
20308 -----------------------
20310 procedure Propagate_Part_Of (Pack_Id : Entity_Id) is
20311 Constits : Elist_Id;
20312 Item_Id : Entity_Id;
20315 -- Traverse the entity chain of the package and set relevant
20316 -- attributes of abstract states and objects declared in the
20317 -- visible state space of the package.
20319 Item_Id := First_Entity (Pack_Id);
20320 while Present (Item_Id)
20321 and then not In_Private_Part (Item_Id)
20323 -- Do not consider internally generated items
20325 if not Comes_From_Source (Item_Id) then
20328 -- Do not consider generic formals or their corresponding
20329 -- actuals because they are not part of a visible state.
20330 -- Note that both entities are marked as hidden.
20332 elsif Is_Hidden (Item_Id) then
20335 -- The Part_Of indicator turns an abstract state or an
20336 -- object into a constituent of the encapsulating state.
20337 -- Note that constants are considered here even though
20338 -- they may not depend on variable input. This check is
20339 -- left to the SPARK prover.
20341 elsif Ekind_In (Item_Id, E_Abstract_State,
20346 Constits := Part_Of_Constituents (State_Id);
20348 if No (Constits) then
20349 Constits := New_Elmt_List;
20350 Set_Part_Of_Constituents (State_Id, Constits);
20353 Append_Elmt (Item_Id, Constits);
20354 Set_Encapsulating_State (Item_Id, State_Id);
20356 -- Recursively handle nested packages and instantiations
20358 elsif Ekind (Item_Id) = E_Package then
20359 Propagate_Part_Of (Item_Id);
20362 Next_Entity (Item_Id);
20364 end Propagate_Part_Of;
20366 -- Start of processing for Propagate_Part_Of
20369 Propagate_Part_Of (Pack_Id);
20371 -- Detect a package instantiation that is subject to a Part_Of
20372 -- indicator, but has no visible state.
20374 if not Has_Item then
20376 ("package instantiation & has Part_Of indicator but "
20377 & "lacks visible state", Instance, Pack_Id);
20379 end Propagate_Part_Of;
20383 Constits : Elist_Id;
20385 Encap_Id : Entity_Id;
20386 Item_Id : Entity_Id;
20390 -- Start of processing for Part_Of
20394 Check_No_Identifiers;
20395 Check_Arg_Count (1);
20397 Stmt := Find_Related_Context (N, Do_Checks => True);
20399 -- Object declaration
20401 if Nkind (Stmt) = N_Object_Declaration then
20404 -- Package instantiation
20406 elsif Nkind (Stmt) = N_Package_Instantiation then
20409 -- Single concurrent type declaration
20411 elsif Is_Single_Concurrent_Type_Declaration (Stmt) then
20414 -- Otherwise the pragma is associated with an illegal construct
20421 -- Extract the entity of the related object declaration or package
20422 -- instantiation. In the case of the instantiation, use the entity
20423 -- of the instance spec.
20425 if Nkind (Stmt) = N_Package_Instantiation then
20426 Stmt := Instance_Spec (Stmt);
20429 Item_Id := Defining_Entity (Stmt);
20431 -- A pragma that applies to a Ghost entity becomes Ghost for the
20432 -- purposes of legality checks and removal of ignored Ghost code.
20434 Mark_Ghost_Pragma (N, Item_Id);
20436 -- Chain the pragma on the contract for further processing by
20437 -- Analyze_Part_Of_In_Decl_Part or for completeness.
20439 Add_Contract_Item (N, Item_Id);
20441 -- A variable may act as constituent of a single concurrent type
20442 -- which in turn could be declared after the variable. Due to this
20443 -- discrepancy, the full analysis of indicator Part_Of is delayed
20444 -- until the end of the enclosing declarative region (see routine
20445 -- Analyze_Part_Of_In_Decl_Part).
20447 if Ekind (Item_Id) = E_Variable then
20450 -- Otherwise indicator Part_Of applies to a constant or a package
20454 Encap := Get_Pragma_Arg (Arg1);
20456 -- Detect any discrepancies between the placement of the
20457 -- constant or package instantiation with respect to state
20458 -- space and the encapsulating state.
20462 Item_Id => Item_Id,
20464 Encap_Id => Encap_Id,
20468 pragma Assert (Present (Encap_Id));
20470 if Ekind (Item_Id) = E_Constant then
20471 Constits := Part_Of_Constituents (Encap_Id);
20473 if No (Constits) then
20474 Constits := New_Elmt_List;
20475 Set_Part_Of_Constituents (Encap_Id, Constits);
20478 Append_Elmt (Item_Id, Constits);
20479 Set_Encapsulating_State (Item_Id, Encap_Id);
20481 -- Propagate the Part_Of indicator to the visible state
20482 -- space of the package instantiation.
20486 (Pack_Id => Item_Id,
20487 State_Id => Encap_Id,
20494 ----------------------------------
20495 -- Partition_Elaboration_Policy --
20496 ----------------------------------
20498 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
20500 when Pragma_Partition_Elaboration_Policy => PEP : declare
20501 subtype PEP_Range is Name_Id
20502 range First_Partition_Elaboration_Policy_Name
20503 .. Last_Partition_Elaboration_Policy_Name;
20504 PEP_Val : PEP_Range;
20509 Check_Arg_Count (1);
20510 Check_No_Identifiers;
20511 Check_Arg_Is_Partition_Elaboration_Policy (Arg1);
20512 Check_Valid_Configuration_Pragma;
20513 PEP_Val := Chars (Get_Pragma_Arg (Arg1));
20516 when Name_Concurrent => PEP := 'C';
20517 when Name_Sequential => PEP := 'S';
20520 if Partition_Elaboration_Policy /= ' '
20521 and then Partition_Elaboration_Policy /= PEP
20523 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc;
20525 ("partition elaboration policy incompatible with policy#");
20527 -- Set new policy, but always preserve System_Location since we
20528 -- like the error message with the run time name.
20531 Partition_Elaboration_Policy := PEP;
20533 if Partition_Elaboration_Policy_Sloc /= System_Location then
20534 Partition_Elaboration_Policy_Sloc := Loc;
20543 -- pragma Passive [(PASSIVE_FORM)];
20545 -- PASSIVE_FORM ::= Semaphore | No
20547 when Pragma_Passive =>
20550 if Nkind (Parent (N)) /= N_Task_Definition then
20551 Error_Pragma ("pragma% must be within task definition");
20554 if Arg_Count /= 0 then
20555 Check_Arg_Count (1);
20556 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
20559 ----------------------------------
20560 -- Preelaborable_Initialization --
20561 ----------------------------------
20563 -- pragma Preelaborable_Initialization (DIRECT_NAME);
20565 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
20570 Check_Arg_Count (1);
20571 Check_No_Identifiers;
20572 Check_Arg_Is_Identifier (Arg1);
20573 Check_Arg_Is_Local_Name (Arg1);
20574 Check_First_Subtype (Arg1);
20575 Ent := Entity (Get_Pragma_Arg (Arg1));
20577 -- A pragma that applies to a Ghost entity becomes Ghost for the
20578 -- purposes of legality checks and removal of ignored Ghost code.
20580 Mark_Ghost_Pragma (N, Ent);
20582 -- The pragma may come from an aspect on a private declaration,
20583 -- even if the freeze point at which this is analyzed in the
20584 -- private part after the full view.
20586 if Has_Private_Declaration (Ent)
20587 and then From_Aspect_Specification (N)
20591 -- Check appropriate type argument
20593 elsif Is_Private_Type (Ent)
20594 or else Is_Protected_Type (Ent)
20595 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))
20597 -- AI05-0028: The pragma applies to all composite types. Note
20598 -- that we apply this binding interpretation to earlier versions
20599 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
20600 -- choice since there are other compilers that do the same.
20602 or else Is_Composite_Type (Ent)
20608 ("pragma % can only be applied to private, formal derived, "
20609 & "protected, or composite type", Arg1);
20612 -- Give an error if the pragma is applied to a protected type that
20613 -- does not qualify (due to having entries, or due to components
20614 -- that do not qualify).
20616 if Is_Protected_Type (Ent)
20617 and then not Has_Preelaborable_Initialization (Ent)
20620 ("protected type & does not have preelaborable "
20621 & "initialization", Ent);
20623 -- Otherwise mark the type as definitely having preelaborable
20627 Set_Known_To_Have_Preelab_Init (Ent);
20630 if Has_Pragma_Preelab_Init (Ent)
20631 and then Warn_On_Redundant_Constructs
20633 Error_Pragma ("?r?duplicate pragma%!");
20635 Set_Has_Pragma_Preelab_Init (Ent);
20639 --------------------
20640 -- Persistent_BSS --
20641 --------------------
20643 -- pragma Persistent_BSS [(object_NAME)];
20645 when Pragma_Persistent_BSS => Persistent_BSS : declare
20652 Check_At_Most_N_Arguments (1);
20654 -- Case of application to specific object (one argument)
20656 if Arg_Count = 1 then
20657 Check_Arg_Is_Library_Level_Local_Name (Arg1);
20659 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
20661 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
20664 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
20667 Ent := Entity (Get_Pragma_Arg (Arg1));
20669 -- A pragma that applies to a Ghost entity becomes Ghost for
20670 -- the purposes of legality checks and removal of ignored Ghost
20673 Mark_Ghost_Pragma (N, Ent);
20675 -- Check for duplication before inserting in list of
20676 -- representation items.
20678 Check_Duplicate_Pragma (Ent);
20680 if Rep_Item_Too_Late (Ent, N) then
20684 Decl := Parent (Ent);
20686 if Present (Expression (Decl)) then
20687 -- Variables in Persistent_BSS cannot be initialized, so
20688 -- turn off any initialization that might be caused by
20689 -- pragmas Initialize_Scalars or Normalize_Scalars.
20691 if Kill_Range_Check (Expression (Decl)) then
20694 Name_Suppress_Initialization,
20695 Pragma_Argument_Associations => New_List (
20696 Make_Pragma_Argument_Association (Loc,
20697 Expression => New_Occurrence_Of (Ent, Loc))));
20698 Insert_Before (N, Prag);
20703 ("object for pragma% cannot have initialization", Arg1);
20707 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
20709 ("object type for pragma% is not potentially persistent",
20714 Make_Linker_Section_Pragma
20715 (Ent, Loc, ".persistent.bss");
20716 Insert_After (N, Prag);
20719 -- Case of use as configuration pragma with no arguments
20722 Check_Valid_Configuration_Pragma;
20723 Persistent_BSS_Mode := True;
20725 end Persistent_BSS;
20727 --------------------
20728 -- Rename_Pragma --
20729 --------------------
20731 -- pragma Rename_Pragma (
20732 -- [New_Name =>] IDENTIFIER,
20733 -- [Renamed =>] pragma_IDENTIFIER);
20735 when Pragma_Rename_Pragma => Rename_Pragma : declare
20736 New_Name : constant Node_Id := Get_Pragma_Arg (Arg1);
20737 Old_Name : constant Node_Id := Get_Pragma_Arg (Arg2);
20741 Check_Valid_Configuration_Pragma;
20742 Check_Arg_Count (2);
20743 Check_Optional_Identifier (Arg1, Name_New_Name);
20744 Check_Optional_Identifier (Arg2, Name_Renamed);
20746 if Nkind (New_Name) /= N_Identifier then
20747 Error_Pragma_Arg ("identifier expected", Arg1);
20750 if Nkind (Old_Name) /= N_Identifier then
20751 Error_Pragma_Arg ("identifier expected", Arg2);
20754 -- The New_Name arg should not be an existing pragma (but we allow
20755 -- it; it's just a warning). The Old_Name arg must be an existing
20758 if Is_Pragma_Name (Chars (New_Name)) then
20759 Error_Pragma_Arg ("??pragma is already defined", Arg1);
20762 if not Is_Pragma_Name (Chars (Old_Name)) then
20763 Error_Pragma_Arg ("existing pragma name expected", Arg1);
20766 Map_Pragma_Name (From => Chars (New_Name), To => Chars (Old_Name));
20773 -- pragma Polling (ON | OFF);
20775 when Pragma_Polling =>
20777 Check_Arg_Count (1);
20778 Check_No_Identifiers;
20779 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
20780 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
20782 -----------------------------------
20783 -- Post/Post_Class/Postcondition --
20784 -----------------------------------
20786 -- pragma Post (Boolean_EXPRESSION);
20787 -- pragma Post_Class (Boolean_EXPRESSION);
20788 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
20789 -- [,[Message =>] String_EXPRESSION]);
20791 -- Characteristics:
20793 -- * Analysis - The annotation undergoes initial checks to verify
20794 -- the legal placement and context. Secondary checks preanalyze the
20797 -- Analyze_Pre_Post_Condition_In_Decl_Part
20799 -- * Expansion - The annotation is expanded during the expansion of
20800 -- the related subprogram [body] contract as performed in:
20802 -- Expand_Subprogram_Contract
20804 -- * Template - The annotation utilizes the generic template of the
20805 -- related subprogram [body] when it is:
20807 -- aspect on subprogram declaration
20808 -- aspect on stand-alone subprogram body
20809 -- pragma on stand-alone subprogram body
20811 -- The annotation must prepare its own template when it is:
20813 -- pragma on subprogram declaration
20815 -- * Globals - Capture of global references must occur after full
20818 -- * Instance - The annotation is instantiated automatically when
20819 -- the related generic subprogram [body] is instantiated except for
20820 -- the "pragma on subprogram declaration" case. In that scenario
20821 -- the annotation must instantiate itself.
20824 | Pragma_Post_Class
20825 | Pragma_Postcondition
20827 Analyze_Pre_Post_Condition;
20829 --------------------------------
20830 -- Pre/Pre_Class/Precondition --
20831 --------------------------------
20833 -- pragma Pre (Boolean_EXPRESSION);
20834 -- pragma Pre_Class (Boolean_EXPRESSION);
20835 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
20836 -- [,[Message =>] String_EXPRESSION]);
20838 -- Characteristics:
20840 -- * Analysis - The annotation undergoes initial checks to verify
20841 -- the legal placement and context. Secondary checks preanalyze the
20844 -- Analyze_Pre_Post_Condition_In_Decl_Part
20846 -- * Expansion - The annotation is expanded during the expansion of
20847 -- the related subprogram [body] contract as performed in:
20849 -- Expand_Subprogram_Contract
20851 -- * Template - The annotation utilizes the generic template of the
20852 -- related subprogram [body] when it is:
20854 -- aspect on subprogram declaration
20855 -- aspect on stand-alone subprogram body
20856 -- pragma on stand-alone subprogram body
20858 -- The annotation must prepare its own template when it is:
20860 -- pragma on subprogram declaration
20862 -- * Globals - Capture of global references must occur after full
20865 -- * Instance - The annotation is instantiated automatically when
20866 -- the related generic subprogram [body] is instantiated except for
20867 -- the "pragma on subprogram declaration" case. In that scenario
20868 -- the annotation must instantiate itself.
20872 | Pragma_Precondition
20874 Analyze_Pre_Post_Condition;
20880 -- pragma Predicate
20881 -- ([Entity =>] type_LOCAL_NAME,
20882 -- [Check =>] boolean_EXPRESSION);
20884 when Pragma_Predicate => Predicate : declare
20891 Check_Arg_Count (2);
20892 Check_Optional_Identifier (Arg1, Name_Entity);
20893 Check_Optional_Identifier (Arg2, Name_Check);
20895 Check_Arg_Is_Local_Name (Arg1);
20897 Type_Id := Get_Pragma_Arg (Arg1);
20898 Find_Type (Type_Id);
20899 Typ := Entity (Type_Id);
20901 if Typ = Any_Type then
20905 -- A pragma that applies to a Ghost entity becomes Ghost for the
20906 -- purposes of legality checks and removal of ignored Ghost code.
20908 Mark_Ghost_Pragma (N, Typ);
20910 -- The remaining processing is simply to link the pragma on to
20911 -- the rep item chain, for processing when the type is frozen.
20912 -- This is accomplished by a call to Rep_Item_Too_Late. We also
20913 -- mark the type as having predicates.
20915 -- If the current policy for predicate checking is Ignore mark the
20916 -- subtype accordingly. In the case of predicates we consider them
20917 -- enabled unless Ignore is specified (either directly or with a
20918 -- general Assertion_Policy pragma) to preserve existing warnings.
20920 Set_Has_Predicates (Typ);
20922 -- Indicate that the pragma must be processed at the point the
20923 -- type is frozen, as is done for the corresponding aspect.
20925 Set_Has_Delayed_Aspects (Typ);
20926 Set_Has_Delayed_Freeze (Typ);
20928 Set_Predicates_Ignored (Typ,
20929 Present (Check_Policy_List)
20931 Policy_In_Effect (Name_Dynamic_Predicate) = Name_Ignore);
20932 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
20935 -----------------------
20936 -- Predicate_Failure --
20937 -----------------------
20939 -- pragma Predicate_Failure
20940 -- ([Entity =>] type_LOCAL_NAME,
20941 -- [Message =>] string_EXPRESSION);
20943 when Pragma_Predicate_Failure => Predicate_Failure : declare
20950 Check_Arg_Count (2);
20951 Check_Optional_Identifier (Arg1, Name_Entity);
20952 Check_Optional_Identifier (Arg2, Name_Message);
20954 Check_Arg_Is_Local_Name (Arg1);
20956 Type_Id := Get_Pragma_Arg (Arg1);
20957 Find_Type (Type_Id);
20958 Typ := Entity (Type_Id);
20960 if Typ = Any_Type then
20964 -- A pragma that applies to a Ghost entity becomes Ghost for the
20965 -- purposes of legality checks and removal of ignored Ghost code.
20967 Mark_Ghost_Pragma (N, Typ);
20969 -- The remaining processing is simply to link the pragma on to
20970 -- the rep item chain, for processing when the type is frozen.
20971 -- This is accomplished by a call to Rep_Item_Too_Late.
20973 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
20974 end Predicate_Failure;
20980 -- pragma Preelaborate [(library_unit_NAME)];
20982 -- Set the flag Is_Preelaborated of program unit name entity
20984 when Pragma_Preelaborate => Preelaborate : declare
20985 Pa : constant Node_Id := Parent (N);
20986 Pk : constant Node_Kind := Nkind (Pa);
20990 Check_Ada_83_Warning;
20991 Check_Valid_Library_Unit_Pragma;
20993 if Nkind (N) = N_Null_Statement then
20997 Ent := Find_Lib_Unit_Name;
20999 -- A pragma that applies to a Ghost entity becomes Ghost for the
21000 -- purposes of legality checks and removal of ignored Ghost code.
21002 Mark_Ghost_Pragma (N, Ent);
21003 Check_Duplicate_Pragma (Ent);
21005 -- This filters out pragmas inside generic parents that show up
21006 -- inside instantiations. Pragmas that come from aspects in the
21007 -- unit are not ignored.
21009 if Present (Ent) then
21010 if Pk = N_Package_Specification
21011 and then Present (Generic_Parent (Pa))
21012 and then not From_Aspect_Specification (N)
21017 if not Debug_Flag_U then
21018 Set_Is_Preelaborated (Ent);
21020 if Legacy_Elaboration_Checks then
21021 Set_Suppress_Elaboration_Warnings (Ent);
21028 -------------------------------
21029 -- Prefix_Exception_Messages --
21030 -------------------------------
21032 -- pragma Prefix_Exception_Messages;
21034 when Pragma_Prefix_Exception_Messages =>
21036 Check_Valid_Configuration_Pragma;
21037 Check_Arg_Count (0);
21038 Prefix_Exception_Messages := True;
21044 -- pragma Priority (EXPRESSION);
21046 when Pragma_Priority => Priority : declare
21047 P : constant Node_Id := Parent (N);
21052 Check_No_Identifiers;
21053 Check_Arg_Count (1);
21057 if Nkind (P) = N_Subprogram_Body then
21058 Check_In_Main_Program;
21060 Ent := Defining_Unit_Name (Specification (P));
21062 if Nkind (Ent) = N_Defining_Program_Unit_Name then
21063 Ent := Defining_Identifier (Ent);
21066 Arg := Get_Pragma_Arg (Arg1);
21067 Analyze_And_Resolve (Arg, Standard_Integer);
21071 if not Is_OK_Static_Expression (Arg) then
21072 Flag_Non_Static_Expr
21073 ("main subprogram priority is not static!", Arg);
21076 -- If constraint error, then we already signalled an error
21078 elsif Raises_Constraint_Error (Arg) then
21081 -- Otherwise check in range except if Relaxed_RM_Semantics
21082 -- where we ignore the value if out of range.
21085 if not Relaxed_RM_Semantics
21086 and then not Is_In_Range (Arg, RTE (RE_Priority))
21089 ("main subprogram priority is out of range", Arg1);
21092 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
21096 -- Load an arbitrary entity from System.Tasking.Stages or
21097 -- System.Tasking.Restricted.Stages (depending on the
21098 -- supported profile) to make sure that one of these packages
21099 -- is implicitly with'ed, since we need to have the tasking
21100 -- run time active for the pragma Priority to have any effect.
21101 -- Previously we with'ed the package System.Tasking, but this
21102 -- package does not trigger the required initialization of the
21103 -- run-time library.
21106 Discard : Entity_Id;
21107 pragma Warnings (Off, Discard);
21109 if Restricted_Profile then
21110 Discard := RTE (RE_Activate_Restricted_Tasks);
21112 Discard := RTE (RE_Activate_Tasks);
21116 -- Task or Protected, must be of type Integer
21118 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
21119 Arg := Get_Pragma_Arg (Arg1);
21120 Ent := Defining_Identifier (Parent (P));
21122 -- The expression must be analyzed in the special manner
21123 -- described in "Handling of Default and Per-Object
21124 -- Expressions" in sem.ads.
21126 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority));
21128 if not Is_OK_Static_Expression (Arg) then
21129 Check_Restriction (Static_Priorities, Arg);
21132 -- Anything else is incorrect
21138 -- Check duplicate pragma before we chain the pragma in the Rep
21139 -- Item chain of Ent.
21141 Check_Duplicate_Pragma (Ent);
21142 Record_Rep_Item (Ent, N);
21145 -----------------------------------
21146 -- Priority_Specific_Dispatching --
21147 -----------------------------------
21149 -- pragma Priority_Specific_Dispatching (
21150 -- policy_IDENTIFIER,
21151 -- first_priority_EXPRESSION,
21152 -- last_priority_EXPRESSION);
21154 when Pragma_Priority_Specific_Dispatching =>
21155 Priority_Specific_Dispatching : declare
21156 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
21157 -- This is the entity System.Any_Priority;
21160 Lower_Bound : Node_Id;
21161 Upper_Bound : Node_Id;
21167 Check_Arg_Count (3);
21168 Check_No_Identifiers;
21169 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
21170 Check_Valid_Configuration_Pragma;
21171 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
21172 DP := Fold_Upper (Name_Buffer (1));
21174 Lower_Bound := Get_Pragma_Arg (Arg2);
21175 Check_Arg_Is_OK_Static_Expression (Lower_Bound, Standard_Integer);
21176 Lower_Val := Expr_Value (Lower_Bound);
21178 Upper_Bound := Get_Pragma_Arg (Arg3);
21179 Check_Arg_Is_OK_Static_Expression (Upper_Bound, Standard_Integer);
21180 Upper_Val := Expr_Value (Upper_Bound);
21182 -- It is not allowed to use Task_Dispatching_Policy and
21183 -- Priority_Specific_Dispatching in the same partition.
21185 if Task_Dispatching_Policy /= ' ' then
21186 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
21188 ("pragma% incompatible with Task_Dispatching_Policy#");
21190 -- Check lower bound in range
21192 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
21194 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
21197 ("first_priority is out of range", Arg2);
21199 -- Check upper bound in range
21201 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
21203 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
21206 ("last_priority is out of range", Arg3);
21208 -- Check that the priority range is valid
21210 elsif Lower_Val > Upper_Val then
21212 ("last_priority_expression must be greater than or equal to "
21213 & "first_priority_expression");
21215 -- Store the new policy, but always preserve System_Location since
21216 -- we like the error message with the run-time name.
21219 -- Check overlapping in the priority ranges specified in other
21220 -- Priority_Specific_Dispatching pragmas within the same
21221 -- partition. We can only check those we know about.
21224 Specific_Dispatching.First .. Specific_Dispatching.Last
21226 if Specific_Dispatching.Table (J).First_Priority in
21227 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
21228 or else Specific_Dispatching.Table (J).Last_Priority in
21229 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
21232 Specific_Dispatching.Table (J).Pragma_Loc;
21234 ("priority range overlaps with "
21235 & "Priority_Specific_Dispatching#");
21239 -- The use of Priority_Specific_Dispatching is incompatible
21240 -- with Task_Dispatching_Policy.
21242 if Task_Dispatching_Policy /= ' ' then
21243 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
21245 ("Priority_Specific_Dispatching incompatible "
21246 & "with Task_Dispatching_Policy#");
21249 -- The use of Priority_Specific_Dispatching forces ceiling
21252 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
21253 Error_Msg_Sloc := Locking_Policy_Sloc;
21255 ("Priority_Specific_Dispatching incompatible "
21256 & "with Locking_Policy#");
21258 -- Set the Ceiling_Locking policy, but preserve System_Location
21259 -- since we like the error message with the run time name.
21262 Locking_Policy := 'C';
21264 if Locking_Policy_Sloc /= System_Location then
21265 Locking_Policy_Sloc := Loc;
21269 -- Add entry in the table
21271 Specific_Dispatching.Append
21272 ((Dispatching_Policy => DP,
21273 First_Priority => UI_To_Int (Lower_Val),
21274 Last_Priority => UI_To_Int (Upper_Val),
21275 Pragma_Loc => Loc));
21277 end Priority_Specific_Dispatching;
21283 -- pragma Profile (profile_IDENTIFIER);
21285 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
21287 when Pragma_Profile =>
21289 Check_Arg_Count (1);
21290 Check_Valid_Configuration_Pragma;
21291 Check_No_Identifiers;
21294 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21297 if Chars (Argx) = Name_Ravenscar then
21298 Set_Ravenscar_Profile (Ravenscar, N);
21300 elsif Chars (Argx) = Name_Gnat_Extended_Ravenscar then
21301 Set_Ravenscar_Profile (GNAT_Extended_Ravenscar, N);
21303 elsif Chars (Argx) = Name_Gnat_Ravenscar_EDF then
21304 Set_Ravenscar_Profile (GNAT_Ravenscar_EDF, N);
21306 elsif Chars (Argx) = Name_Restricted then
21307 Set_Profile_Restrictions
21309 N, Warn => Treat_Restrictions_As_Warnings);
21311 elsif Chars (Argx) = Name_Rational then
21312 Set_Rational_Profile;
21314 elsif Chars (Argx) = Name_No_Implementation_Extensions then
21315 Set_Profile_Restrictions
21316 (No_Implementation_Extensions,
21317 N, Warn => Treat_Restrictions_As_Warnings);
21320 Error_Pragma_Arg ("& is not a valid profile", Argx);
21324 ----------------------
21325 -- Profile_Warnings --
21326 ----------------------
21328 -- pragma Profile_Warnings (profile_IDENTIFIER);
21330 -- profile_IDENTIFIER => Restricted | Ravenscar
21332 when Pragma_Profile_Warnings =>
21334 Check_Arg_Count (1);
21335 Check_Valid_Configuration_Pragma;
21336 Check_No_Identifiers;
21339 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21342 if Chars (Argx) = Name_Ravenscar then
21343 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
21345 elsif Chars (Argx) = Name_Restricted then
21346 Set_Profile_Restrictions (Restricted, N, Warn => True);
21348 elsif Chars (Argx) = Name_No_Implementation_Extensions then
21349 Set_Profile_Restrictions
21350 (No_Implementation_Extensions, N, Warn => True);
21353 Error_Pragma_Arg ("& is not a valid profile", Argx);
21357 --------------------------
21358 -- Propagate_Exceptions --
21359 --------------------------
21361 -- pragma Propagate_Exceptions;
21363 -- Note: this pragma is obsolete and has no effect
21365 when Pragma_Propagate_Exceptions =>
21367 Check_Arg_Count (0);
21369 if Warn_On_Obsolescent_Feature then
21371 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
21372 "and has no effect?j?", N);
21375 -----------------------------
21376 -- Provide_Shift_Operators --
21377 -----------------------------
21379 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
21381 when Pragma_Provide_Shift_Operators =>
21382 Provide_Shift_Operators : declare
21385 procedure Declare_Shift_Operator (Nam : Name_Id);
21386 -- Insert declaration and pragma Instrinsic for named shift op
21388 ----------------------------
21389 -- Declare_Shift_Operator --
21390 ----------------------------
21392 procedure Declare_Shift_Operator (Nam : Name_Id) is
21398 Make_Subprogram_Declaration (Loc,
21399 Make_Function_Specification (Loc,
21400 Defining_Unit_Name =>
21401 Make_Defining_Identifier (Loc, Chars => Nam),
21403 Result_Definition =>
21404 Make_Identifier (Loc, Chars => Chars (Ent)),
21406 Parameter_Specifications => New_List (
21407 Make_Parameter_Specification (Loc,
21408 Defining_Identifier =>
21409 Make_Defining_Identifier (Loc, Name_Value),
21411 Make_Identifier (Loc, Chars => Chars (Ent))),
21413 Make_Parameter_Specification (Loc,
21414 Defining_Identifier =>
21415 Make_Defining_Identifier (Loc, Name_Amount),
21417 New_Occurrence_Of (Standard_Natural, Loc)))));
21421 Chars => Name_Import,
21422 Pragma_Argument_Associations => New_List (
21423 Make_Pragma_Argument_Association (Loc,
21424 Expression => Make_Identifier (Loc, Name_Intrinsic)),
21425 Make_Pragma_Argument_Association (Loc,
21426 Expression => Make_Identifier (Loc, Nam))));
21428 Insert_After (N, Import);
21429 Insert_After (N, Func);
21430 end Declare_Shift_Operator;
21432 -- Start of processing for Provide_Shift_Operators
21436 Check_Arg_Count (1);
21437 Check_Arg_Is_Local_Name (Arg1);
21439 Arg1 := Get_Pragma_Arg (Arg1);
21441 -- We must have an entity name
21443 if not Is_Entity_Name (Arg1) then
21445 ("pragma % must apply to integer first subtype", Arg1);
21448 -- If no Entity, means there was a prior error so ignore
21450 if Present (Entity (Arg1)) then
21451 Ent := Entity (Arg1);
21453 -- Apply error checks
21455 if not Is_First_Subtype (Ent) then
21457 ("cannot apply pragma %",
21458 "\& is not a first subtype",
21461 elsif not Is_Integer_Type (Ent) then
21463 ("cannot apply pragma %",
21464 "\& is not an integer type",
21467 elsif Has_Shift_Operator (Ent) then
21469 ("cannot apply pragma %",
21470 "\& already has declared shift operators",
21473 elsif Is_Frozen (Ent) then
21475 ("pragma % appears too late",
21476 "\& is already frozen",
21480 -- Now declare the operators. We do this during analysis rather
21481 -- than expansion, since we want the operators available if we
21482 -- are operating in -gnatc mode.
21484 Declare_Shift_Operator (Name_Rotate_Left);
21485 Declare_Shift_Operator (Name_Rotate_Right);
21486 Declare_Shift_Operator (Name_Shift_Left);
21487 Declare_Shift_Operator (Name_Shift_Right);
21488 Declare_Shift_Operator (Name_Shift_Right_Arithmetic);
21490 end Provide_Shift_Operators;
21496 -- pragma Psect_Object (
21497 -- [Internal =>] LOCAL_NAME,
21498 -- [, [External =>] EXTERNAL_SYMBOL]
21499 -- [, [Size =>] EXTERNAL_SYMBOL]);
21501 when Pragma_Common_Object
21502 | Pragma_Psect_Object
21504 Psect_Object : declare
21505 Args : Args_List (1 .. 3);
21506 Names : constant Name_List (1 .. 3) := (
21511 Internal : Node_Id renames Args (1);
21512 External : Node_Id renames Args (2);
21513 Size : Node_Id renames Args (3);
21515 Def_Id : Entity_Id;
21517 procedure Check_Arg (Arg : Node_Id);
21518 -- Checks that argument is either a string literal or an
21519 -- identifier, and posts error message if not.
21525 procedure Check_Arg (Arg : Node_Id) is
21527 if not Nkind_In (Original_Node (Arg),
21532 ("inappropriate argument for pragma %", Arg);
21536 -- Start of processing for Common_Object/Psect_Object
21540 Gather_Associations (Names, Args);
21541 Process_Extended_Import_Export_Internal_Arg (Internal);
21543 Def_Id := Entity (Internal);
21545 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
21547 ("pragma% must designate an object", Internal);
21550 Check_Arg (Internal);
21552 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
21554 ("cannot use pragma% for imported/exported object",
21558 if Is_Concurrent_Type (Etype (Internal)) then
21560 ("cannot specify pragma % for task/protected object",
21564 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
21566 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
21568 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N);
21571 if Ekind (Def_Id) = E_Constant then
21573 ("cannot specify pragma % for a constant", Internal);
21576 if Is_Record_Type (Etype (Internal)) then
21582 Ent := First_Entity (Etype (Internal));
21583 while Present (Ent) loop
21584 Decl := Declaration_Node (Ent);
21586 if Ekind (Ent) = E_Component
21587 and then Nkind (Decl) = N_Component_Declaration
21588 and then Present (Expression (Decl))
21589 and then Warn_On_Export_Import
21592 ("?x?object for pragma % has defaults", Internal);
21602 if Present (Size) then
21606 if Present (External) then
21607 Check_Arg_Is_External_Name (External);
21610 -- If all error tests pass, link pragma on to the rep item chain
21612 Record_Rep_Item (Def_Id, N);
21619 -- pragma Pure [(library_unit_NAME)];
21621 when Pragma_Pure => Pure : declare
21625 Check_Ada_83_Warning;
21627 -- If the pragma comes from a subprogram instantiation, nothing to
21628 -- check, this can happen at any level of nesting.
21630 if Is_Wrapper_Package (Current_Scope) then
21633 Check_Valid_Library_Unit_Pragma;
21636 if Nkind (N) = N_Null_Statement then
21640 Ent := Find_Lib_Unit_Name;
21642 -- A pragma that applies to a Ghost entity becomes Ghost for the
21643 -- purposes of legality checks and removal of ignored Ghost code.
21645 Mark_Ghost_Pragma (N, Ent);
21647 if not Debug_Flag_U then
21649 Set_Has_Pragma_Pure (Ent);
21651 if Legacy_Elaboration_Checks then
21652 Set_Suppress_Elaboration_Warnings (Ent);
21657 -------------------
21658 -- Pure_Function --
21659 -------------------
21661 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
21663 when Pragma_Pure_Function => Pure_Function : declare
21664 Def_Id : Entity_Id;
21667 Effective : Boolean := False;
21668 Orig_Def : Entity_Id;
21669 Same_Decl : Boolean := False;
21673 Check_Arg_Count (1);
21674 Check_Optional_Identifier (Arg1, Name_Entity);
21675 Check_Arg_Is_Local_Name (Arg1);
21676 E_Id := Get_Pragma_Arg (Arg1);
21678 if Etype (E_Id) = Any_Type then
21682 -- Loop through homonyms (overloadings) of referenced entity
21684 E := Entity (E_Id);
21686 -- A pragma that applies to a Ghost entity becomes Ghost for the
21687 -- purposes of legality checks and removal of ignored Ghost code.
21689 Mark_Ghost_Pragma (N, E);
21691 if Present (E) then
21693 Def_Id := Get_Base_Subprogram (E);
21695 if not Ekind_In (Def_Id, E_Function,
21696 E_Generic_Function,
21700 ("pragma% requires a function name", Arg1);
21703 -- When we have a generic function we must jump up a level
21704 -- to the declaration of the wrapper package itself.
21706 Orig_Def := Def_Id;
21708 if Is_Generic_Instance (Def_Id) then
21709 while Nkind (Orig_Def) /= N_Package_Declaration loop
21710 Orig_Def := Parent (Orig_Def);
21714 if In_Same_Declarative_Part (Parent (N), Orig_Def) then
21716 Set_Is_Pure (Def_Id);
21718 if not Has_Pragma_Pure_Function (Def_Id) then
21719 Set_Has_Pragma_Pure_Function (Def_Id);
21724 exit when From_Aspect_Specification (N);
21726 exit when No (E) or else Scope (E) /= Current_Scope;
21730 and then Warn_On_Redundant_Constructs
21733 ("pragma Pure_Function on& is redundant?r?",
21736 elsif not Same_Decl then
21738 ("pragma% argument must be in same declarative part",
21744 --------------------
21745 -- Queuing_Policy --
21746 --------------------
21748 -- pragma Queuing_Policy (policy_IDENTIFIER);
21750 when Pragma_Queuing_Policy => declare
21754 Check_Ada_83_Warning;
21755 Check_Arg_Count (1);
21756 Check_No_Identifiers;
21757 Check_Arg_Is_Queuing_Policy (Arg1);
21758 Check_Valid_Configuration_Pragma;
21759 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
21760 QP := Fold_Upper (Name_Buffer (1));
21762 if Queuing_Policy /= ' '
21763 and then Queuing_Policy /= QP
21765 Error_Msg_Sloc := Queuing_Policy_Sloc;
21766 Error_Pragma ("queuing policy incompatible with policy#");
21768 -- Set new policy, but always preserve System_Location since we
21769 -- like the error message with the run time name.
21772 Queuing_Policy := QP;
21774 if Queuing_Policy_Sloc /= System_Location then
21775 Queuing_Policy_Sloc := Loc;
21784 -- pragma Rational, for compatibility with foreign compiler
21786 when Pragma_Rational =>
21787 Set_Rational_Profile;
21789 ---------------------
21790 -- Refined_Depends --
21791 ---------------------
21793 -- pragma Refined_Depends (DEPENDENCY_RELATION);
21795 -- DEPENDENCY_RELATION ::=
21797 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
21799 -- DEPENDENCY_CLAUSE ::=
21800 -- OUTPUT_LIST =>[+] INPUT_LIST
21801 -- | NULL_DEPENDENCY_CLAUSE
21803 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
21805 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
21807 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
21809 -- OUTPUT ::= NAME | FUNCTION_RESULT
21812 -- where FUNCTION_RESULT is a function Result attribute_reference
21814 -- Characteristics:
21816 -- * Analysis - The annotation undergoes initial checks to verify
21817 -- the legal placement and context. Secondary checks fully analyze
21818 -- the dependency clauses/global list in:
21820 -- Analyze_Refined_Depends_In_Decl_Part
21822 -- * Expansion - None.
21824 -- * Template - The annotation utilizes the generic template of the
21825 -- related subprogram body.
21827 -- * Globals - Capture of global references must occur after full
21830 -- * Instance - The annotation is instantiated automatically when
21831 -- the related generic subprogram body is instantiated.
21833 when Pragma_Refined_Depends => Refined_Depends : declare
21834 Body_Id : Entity_Id;
21836 Spec_Id : Entity_Id;
21839 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
21843 -- Chain the pragma on the contract for further processing by
21844 -- Analyze_Refined_Depends_In_Decl_Part.
21846 Add_Contract_Item (N, Body_Id);
21848 -- The legality checks of pragmas Refined_Depends and
21849 -- Refined_Global are affected by the SPARK mode in effect and
21850 -- the volatility of the context. In addition these two pragmas
21851 -- are subject to an inherent order:
21853 -- 1) Refined_Global
21854 -- 2) Refined_Depends
21856 -- Analyze all these pragmas in the order outlined above
21858 Analyze_If_Present (Pragma_SPARK_Mode);
21859 Analyze_If_Present (Pragma_Volatile_Function);
21860 Analyze_If_Present (Pragma_Refined_Global);
21861 Analyze_Refined_Depends_In_Decl_Part (N);
21863 end Refined_Depends;
21865 --------------------
21866 -- Refined_Global --
21867 --------------------
21869 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
21871 -- GLOBAL_SPECIFICATION ::=
21874 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
21876 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
21878 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
21879 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
21880 -- GLOBAL_ITEM ::= NAME
21882 -- Characteristics:
21884 -- * Analysis - The annotation undergoes initial checks to verify
21885 -- the legal placement and context. Secondary checks fully analyze
21886 -- the dependency clauses/global list in:
21888 -- Analyze_Refined_Global_In_Decl_Part
21890 -- * Expansion - None.
21892 -- * Template - The annotation utilizes the generic template of the
21893 -- related subprogram body.
21895 -- * Globals - Capture of global references must occur after full
21898 -- * Instance - The annotation is instantiated automatically when
21899 -- the related generic subprogram body is instantiated.
21901 when Pragma_Refined_Global => Refined_Global : declare
21902 Body_Id : Entity_Id;
21904 Spec_Id : Entity_Id;
21907 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
21911 -- Chain the pragma on the contract for further processing by
21912 -- Analyze_Refined_Global_In_Decl_Part.
21914 Add_Contract_Item (N, Body_Id);
21916 -- The legality checks of pragmas Refined_Depends and
21917 -- Refined_Global are affected by the SPARK mode in effect and
21918 -- the volatility of the context. In addition these two pragmas
21919 -- are subject to an inherent order:
21921 -- 1) Refined_Global
21922 -- 2) Refined_Depends
21924 -- Analyze all these pragmas in the order outlined above
21926 Analyze_If_Present (Pragma_SPARK_Mode);
21927 Analyze_If_Present (Pragma_Volatile_Function);
21928 Analyze_Refined_Global_In_Decl_Part (N);
21929 Analyze_If_Present (Pragma_Refined_Depends);
21931 end Refined_Global;
21937 -- pragma Refined_Post (boolean_EXPRESSION);
21939 -- Characteristics:
21941 -- * Analysis - The annotation is fully analyzed immediately upon
21942 -- elaboration as it cannot forward reference entities.
21944 -- * Expansion - The annotation is expanded during the expansion of
21945 -- the related subprogram body contract as performed in:
21947 -- Expand_Subprogram_Contract
21949 -- * Template - The annotation utilizes the generic template of the
21950 -- related subprogram body.
21952 -- * Globals - Capture of global references must occur after full
21955 -- * Instance - The annotation is instantiated automatically when
21956 -- the related generic subprogram body is instantiated.
21958 when Pragma_Refined_Post => Refined_Post : declare
21959 Body_Id : Entity_Id;
21961 Spec_Id : Entity_Id;
21964 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
21966 -- Fully analyze the pragma when it appears inside a subprogram
21967 -- body because it cannot benefit from forward references.
21971 -- Chain the pragma on the contract for completeness
21973 Add_Contract_Item (N, Body_Id);
21975 -- The legality checks of pragma Refined_Post are affected by
21976 -- the SPARK mode in effect and the volatility of the context.
21977 -- Analyze all pragmas in a specific order.
21979 Analyze_If_Present (Pragma_SPARK_Mode);
21980 Analyze_If_Present (Pragma_Volatile_Function);
21981 Analyze_Pre_Post_Condition_In_Decl_Part (N);
21983 -- Currently it is not possible to inline pre/postconditions on
21984 -- a subprogram subject to pragma Inline_Always.
21986 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
21990 -------------------
21991 -- Refined_State --
21992 -------------------
21994 -- pragma Refined_State (REFINEMENT_LIST);
21996 -- REFINEMENT_LIST ::=
21997 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
21999 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
22001 -- CONSTITUENT_LIST ::=
22004 -- | (CONSTITUENT {, CONSTITUENT})
22006 -- CONSTITUENT ::= object_NAME | state_NAME
22008 -- Characteristics:
22010 -- * Analysis - The annotation undergoes initial checks to verify
22011 -- the legal placement and context. Secondary checks preanalyze the
22012 -- refinement clauses in:
22014 -- Analyze_Refined_State_In_Decl_Part
22016 -- * Expansion - None.
22018 -- * Template - The annotation utilizes the template of the related
22021 -- * Globals - Capture of global references must occur after full
22024 -- * Instance - The annotation is instantiated automatically when
22025 -- the related generic package body is instantiated.
22027 when Pragma_Refined_State => Refined_State : declare
22028 Pack_Decl : Node_Id;
22029 Spec_Id : Entity_Id;
22033 Check_No_Identifiers;
22034 Check_Arg_Count (1);
22036 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
22038 if Nkind (Pack_Decl) /= N_Package_Body then
22043 Spec_Id := Corresponding_Spec (Pack_Decl);
22045 -- A pragma that applies to a Ghost entity becomes Ghost for the
22046 -- purposes of legality checks and removal of ignored Ghost code.
22048 Mark_Ghost_Pragma (N, Spec_Id);
22050 -- Chain the pragma on the contract for further processing by
22051 -- Analyze_Refined_State_In_Decl_Part.
22053 Add_Contract_Item (N, Defining_Entity (Pack_Decl));
22055 -- The legality checks of pragma Refined_State are affected by the
22056 -- SPARK mode in effect. Analyze all pragmas in a specific order.
22058 Analyze_If_Present (Pragma_SPARK_Mode);
22060 -- State refinement is allowed only when the corresponding package
22061 -- declaration has non-null pragma Abstract_State. Refinement not
22062 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
22064 if SPARK_Mode /= Off
22066 (No (Abstract_States (Spec_Id))
22067 or else Has_Null_Abstract_State (Spec_Id))
22070 ("useless refinement, package & does not define abstract "
22071 & "states", N, Spec_Id);
22076 -----------------------
22077 -- Relative_Deadline --
22078 -----------------------
22080 -- pragma Relative_Deadline (time_span_EXPRESSION);
22082 when Pragma_Relative_Deadline => Relative_Deadline : declare
22083 P : constant Node_Id := Parent (N);
22088 Check_No_Identifiers;
22089 Check_Arg_Count (1);
22091 Arg := Get_Pragma_Arg (Arg1);
22093 -- The expression must be analyzed in the special manner described
22094 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
22096 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
22100 if Nkind (P) = N_Subprogram_Body then
22101 Check_In_Main_Program;
22103 -- Only Task and subprogram cases allowed
22105 elsif Nkind (P) /= N_Task_Definition then
22109 -- Check duplicate pragma before we set the corresponding flag
22111 if Has_Relative_Deadline_Pragma (P) then
22112 Error_Pragma ("duplicate pragma% not allowed");
22115 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
22116 -- Relative_Deadline pragma node cannot be inserted in the Rep
22117 -- Item chain of Ent since it is rewritten by the expander as a
22118 -- procedure call statement that will break the chain.
22120 Set_Has_Relative_Deadline_Pragma (P);
22121 end Relative_Deadline;
22123 ------------------------
22124 -- Remote_Access_Type --
22125 ------------------------
22127 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
22129 when Pragma_Remote_Access_Type => Remote_Access_Type : declare
22134 Check_Arg_Count (1);
22135 Check_Optional_Identifier (Arg1, Name_Entity);
22136 Check_Arg_Is_Local_Name (Arg1);
22138 E := Entity (Get_Pragma_Arg (Arg1));
22140 -- A pragma that applies to a Ghost entity becomes Ghost for the
22141 -- purposes of legality checks and removal of ignored Ghost code.
22143 Mark_Ghost_Pragma (N, E);
22145 if Nkind (Parent (E)) = N_Formal_Type_Declaration
22146 and then Ekind (E) = E_General_Access_Type
22147 and then Is_Class_Wide_Type (Directly_Designated_Type (E))
22148 and then Scope (Root_Type (Directly_Designated_Type (E)))
22150 and then Is_Valid_Remote_Object_Type
22151 (Root_Type (Directly_Designated_Type (E)))
22153 Set_Is_Remote_Types (E);
22157 ("pragma% applies only to formal access-to-class-wide types",
22160 end Remote_Access_Type;
22162 ---------------------------
22163 -- Remote_Call_Interface --
22164 ---------------------------
22166 -- pragma Remote_Call_Interface [(library_unit_NAME)];
22168 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
22169 Cunit_Node : Node_Id;
22170 Cunit_Ent : Entity_Id;
22174 Check_Ada_83_Warning;
22175 Check_Valid_Library_Unit_Pragma;
22177 if Nkind (N) = N_Null_Statement then
22181 Cunit_Node := Cunit (Current_Sem_Unit);
22182 K := Nkind (Unit (Cunit_Node));
22183 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
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, Cunit_Ent);
22190 if K = N_Package_Declaration
22191 or else K = N_Generic_Package_Declaration
22192 or else K = N_Subprogram_Declaration
22193 or else K = N_Generic_Subprogram_Declaration
22194 or else (K = N_Subprogram_Body
22195 and then Acts_As_Spec (Unit (Cunit_Node)))
22200 "pragma% must apply to package or subprogram declaration");
22203 Set_Is_Remote_Call_Interface (Cunit_Ent);
22204 end Remote_Call_Interface;
22210 -- pragma Remote_Types [(library_unit_NAME)];
22212 when Pragma_Remote_Types => Remote_Types : declare
22213 Cunit_Node : Node_Id;
22214 Cunit_Ent : Entity_Id;
22217 Check_Ada_83_Warning;
22218 Check_Valid_Library_Unit_Pragma;
22220 if Nkind (N) = N_Null_Statement then
22224 Cunit_Node := Cunit (Current_Sem_Unit);
22225 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22227 -- A pragma that applies to a Ghost entity becomes Ghost for the
22228 -- purposes of legality checks and removal of ignored Ghost code.
22230 Mark_Ghost_Pragma (N, Cunit_Ent);
22232 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
22233 N_Generic_Package_Declaration)
22236 ("pragma% can only apply to a package declaration");
22239 Set_Is_Remote_Types (Cunit_Ent);
22246 -- pragma Ravenscar;
22248 when Pragma_Ravenscar =>
22250 Check_Arg_Count (0);
22251 Check_Valid_Configuration_Pragma;
22252 Set_Ravenscar_Profile (Ravenscar, N);
22254 if Warn_On_Obsolescent_Feature then
22256 ("pragma Ravenscar is an obsolescent feature?j?", N);
22258 ("|use pragma Profile (Ravenscar) instead?j?", N);
22261 -------------------------
22262 -- Restricted_Run_Time --
22263 -------------------------
22265 -- pragma Restricted_Run_Time;
22267 when Pragma_Restricted_Run_Time =>
22269 Check_Arg_Count (0);
22270 Check_Valid_Configuration_Pragma;
22271 Set_Profile_Restrictions
22272 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
22274 if Warn_On_Obsolescent_Feature then
22276 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
22279 ("|use pragma Profile (Restricted) instead?j?", N);
22286 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
22289 -- restriction_IDENTIFIER
22290 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22292 when Pragma_Restrictions =>
22293 Process_Restrictions_Or_Restriction_Warnings
22294 (Warn => Treat_Restrictions_As_Warnings);
22296 --------------------------
22297 -- Restriction_Warnings --
22298 --------------------------
22300 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
22303 -- restriction_IDENTIFIER
22304 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22306 when Pragma_Restriction_Warnings =>
22308 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
22314 -- pragma Reviewable;
22316 when Pragma_Reviewable =>
22317 Check_Ada_83_Warning;
22318 Check_Arg_Count (0);
22320 -- Call dummy debugging function rv. This is done to assist front
22321 -- end debugging. By placing a Reviewable pragma in the source
22322 -- program, a breakpoint on rv catches this place in the source,
22323 -- allowing convenient stepping to the point of interest.
22327 --------------------------
22328 -- Secondary_Stack_Size --
22329 --------------------------
22331 -- pragma Secondary_Stack_Size (EXPRESSION);
22333 when Pragma_Secondary_Stack_Size => Secondary_Stack_Size : declare
22334 P : constant Node_Id := Parent (N);
22340 Check_No_Identifiers;
22341 Check_Arg_Count (1);
22343 if Nkind (P) = N_Task_Definition then
22344 Arg := Get_Pragma_Arg (Arg1);
22345 Ent := Defining_Identifier (Parent (P));
22347 -- The expression must be analyzed in the special manner
22348 -- described in "Handling of Default Expressions" in sem.ads.
22350 Preanalyze_Spec_Expression (Arg, Any_Integer);
22352 -- The pragma cannot appear if the No_Secondary_Stack
22353 -- restriction is in effect.
22355 Check_Restriction (No_Secondary_Stack, Arg);
22357 -- Anything else is incorrect
22363 -- Check duplicate pragma before we chain the pragma in the Rep
22364 -- Item chain of Ent.
22366 Check_Duplicate_Pragma (Ent);
22367 Record_Rep_Item (Ent, N);
22368 end Secondary_Stack_Size;
22370 --------------------------
22371 -- Short_Circuit_And_Or --
22372 --------------------------
22374 -- pragma Short_Circuit_And_Or;
22376 when Pragma_Short_Circuit_And_Or =>
22378 Check_Arg_Count (0);
22379 Check_Valid_Configuration_Pragma;
22380 Short_Circuit_And_Or := True;
22382 -------------------
22383 -- Share_Generic --
22384 -------------------
22386 -- pragma Share_Generic (GNAME {, GNAME});
22388 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
22390 when Pragma_Share_Generic =>
22392 Process_Generic_List;
22398 -- pragma Shared (LOCAL_NAME);
22400 when Pragma_Shared =>
22402 Process_Atomic_Independent_Shared_Volatile;
22404 --------------------
22405 -- Shared_Passive --
22406 --------------------
22408 -- pragma Shared_Passive [(library_unit_NAME)];
22410 -- Set the flag Is_Shared_Passive of program unit name entity
22412 when Pragma_Shared_Passive => Shared_Passive : declare
22413 Cunit_Node : Node_Id;
22414 Cunit_Ent : Entity_Id;
22417 Check_Ada_83_Warning;
22418 Check_Valid_Library_Unit_Pragma;
22420 if Nkind (N) = N_Null_Statement then
22424 Cunit_Node := Cunit (Current_Sem_Unit);
22425 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22427 -- A pragma that applies to a Ghost entity becomes Ghost for the
22428 -- purposes of legality checks and removal of ignored Ghost code.
22430 Mark_Ghost_Pragma (N, Cunit_Ent);
22432 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
22433 N_Generic_Package_Declaration)
22436 ("pragma% can only apply to a package declaration");
22439 Set_Is_Shared_Passive (Cunit_Ent);
22440 end Shared_Passive;
22442 -----------------------
22443 -- Short_Descriptors --
22444 -----------------------
22446 -- pragma Short_Descriptors;
22448 -- Recognize and validate, but otherwise ignore
22450 when Pragma_Short_Descriptors =>
22452 Check_Arg_Count (0);
22453 Check_Valid_Configuration_Pragma;
22455 ------------------------------
22456 -- Simple_Storage_Pool_Type --
22457 ------------------------------
22459 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
22461 when Pragma_Simple_Storage_Pool_Type =>
22462 Simple_Storage_Pool_Type : declare
22468 Check_Arg_Count (1);
22469 Check_Arg_Is_Library_Level_Local_Name (Arg1);
22471 Type_Id := Get_Pragma_Arg (Arg1);
22472 Find_Type (Type_Id);
22473 Typ := Entity (Type_Id);
22475 if Typ = Any_Type then
22479 -- A pragma that applies to a Ghost entity becomes Ghost for the
22480 -- purposes of legality checks and removal of ignored Ghost code.
22482 Mark_Ghost_Pragma (N, Typ);
22484 -- We require the pragma to apply to a type declared in a package
22485 -- declaration, but not (immediately) within a package body.
22487 if Ekind (Current_Scope) /= E_Package
22488 or else In_Package_Body (Current_Scope)
22491 ("pragma% can only apply to type declared immediately "
22492 & "within a package declaration");
22495 -- A simple storage pool type must be an immutably limited record
22496 -- or private type. If the pragma is given for a private type,
22497 -- the full type is similarly restricted (which is checked later
22498 -- in Freeze_Entity).
22500 if Is_Record_Type (Typ)
22501 and then not Is_Limited_View (Typ)
22504 ("pragma% can only apply to explicitly limited record type");
22506 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
22508 ("pragma% can only apply to a private type that is limited");
22510 elsif not Is_Record_Type (Typ)
22511 and then not Is_Private_Type (Typ)
22514 ("pragma% can only apply to limited record or private type");
22517 Record_Rep_Item (Typ, N);
22518 end Simple_Storage_Pool_Type;
22520 ----------------------
22521 -- Source_File_Name --
22522 ----------------------
22524 -- There are five forms for this pragma:
22526 -- pragma Source_File_Name (
22527 -- [UNIT_NAME =>] unit_NAME,
22528 -- BODY_FILE_NAME => STRING_LITERAL
22529 -- [, [INDEX =>] INTEGER_LITERAL]);
22531 -- pragma Source_File_Name (
22532 -- [UNIT_NAME =>] unit_NAME,
22533 -- SPEC_FILE_NAME => STRING_LITERAL
22534 -- [, [INDEX =>] INTEGER_LITERAL]);
22536 -- pragma Source_File_Name (
22537 -- BODY_FILE_NAME => STRING_LITERAL
22538 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22539 -- [, CASING => CASING_SPEC]);
22541 -- pragma Source_File_Name (
22542 -- SPEC_FILE_NAME => STRING_LITERAL
22543 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22544 -- [, CASING => CASING_SPEC]);
22546 -- pragma Source_File_Name (
22547 -- SUBUNIT_FILE_NAME => STRING_LITERAL
22548 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22549 -- [, CASING => CASING_SPEC]);
22551 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
22553 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
22554 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
22555 -- only be used when no project file is used, while SFNP can only be
22556 -- used when a project file is used.
22558 -- No processing here. Processing was completed during parsing, since
22559 -- we need to have file names set as early as possible. Units are
22560 -- loaded well before semantic processing starts.
22562 -- The only processing we defer to this point is the check for
22563 -- correct placement.
22565 when Pragma_Source_File_Name =>
22567 Check_Valid_Configuration_Pragma;
22569 ------------------------------
22570 -- Source_File_Name_Project --
22571 ------------------------------
22573 -- See Source_File_Name for syntax
22575 -- No processing here. Processing was completed during parsing, since
22576 -- we need to have file names set as early as possible. Units are
22577 -- loaded well before semantic processing starts.
22579 -- The only processing we defer to this point is the check for
22580 -- correct placement.
22582 when Pragma_Source_File_Name_Project =>
22584 Check_Valid_Configuration_Pragma;
22586 -- Check that a pragma Source_File_Name_Project is used only in a
22587 -- configuration pragmas file.
22589 -- Pragmas Source_File_Name_Project should only be generated by
22590 -- the Project Manager in configuration pragmas files.
22592 -- This is really an ugly test. It seems to depend on some
22593 -- accidental and undocumented property. At the very least it
22594 -- needs to be documented, but it would be better to have a
22595 -- clean way of testing if we are in a configuration file???
22597 if Present (Parent (N)) then
22599 ("pragma% can only appear in a configuration pragmas file");
22602 ----------------------
22603 -- Source_Reference --
22604 ----------------------
22606 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
22608 -- Nothing to do, all processing completed in Par.Prag, since we need
22609 -- the information for possible parser messages that are output.
22611 when Pragma_Source_Reference =>
22618 -- pragma SPARK_Mode [(On | Off)];
22620 when Pragma_SPARK_Mode => Do_SPARK_Mode : declare
22621 Mode_Id : SPARK_Mode_Type;
22623 procedure Check_Pragma_Conformance
22624 (Context_Pragma : Node_Id;
22625 Entity : Entity_Id;
22626 Entity_Pragma : Node_Id);
22627 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
22628 -- conformance of pragma N depending the following scenarios:
22630 -- If pragma Context_Pragma is not Empty, verify that pragma N is
22631 -- compatible with the pragma Context_Pragma that was inherited
22632 -- from the context:
22633 -- * If the mode of Context_Pragma is ON, then the new mode can
22635 -- * If the mode of Context_Pragma is OFF, then the only allowed
22636 -- new mode is also OFF. Emit error if this is not the case.
22638 -- If Entity is not Empty, verify that pragma N is compatible with
22639 -- pragma Entity_Pragma that belongs to Entity.
22640 -- * If Entity_Pragma is Empty, always issue an error as this
22641 -- corresponds to the case where a previous section of Entity
22642 -- has no SPARK_Mode set.
22643 -- * If the mode of Entity_Pragma is ON, then the new mode can
22645 -- * If the mode of Entity_Pragma is OFF, then the only allowed
22646 -- new mode is also OFF. Emit error if this is not the case.
22648 procedure Check_Library_Level_Entity (E : Entity_Id);
22649 -- Subsidiary to routines Process_xxx. Verify that the related
22650 -- entity E subject to pragma SPARK_Mode is library-level.
22652 procedure Process_Body (Decl : Node_Id);
22653 -- Verify the legality of pragma SPARK_Mode when it appears as the
22654 -- top of the body declarations of entry, package, protected unit,
22655 -- subprogram or task unit body denoted by Decl.
22657 procedure Process_Overloadable (Decl : Node_Id);
22658 -- Verify the legality of pragma SPARK_Mode when it applies to an
22659 -- entry or [generic] subprogram declaration denoted by Decl.
22661 procedure Process_Private_Part (Decl : Node_Id);
22662 -- Verify the legality of pragma SPARK_Mode when it appears at the
22663 -- top of the private declarations of a package spec, protected or
22664 -- task unit declaration denoted by Decl.
22666 procedure Process_Statement_Part (Decl : Node_Id);
22667 -- Verify the legality of pragma SPARK_Mode when it appears at the
22668 -- top of the statement sequence of a package body denoted by node
22671 procedure Process_Visible_Part (Decl : Node_Id);
22672 -- Verify the legality of pragma SPARK_Mode when it appears at the
22673 -- top of the visible declarations of a package spec, protected or
22674 -- task unit declaration denoted by Decl. The routine is also used
22675 -- on protected or task units declared without a definition.
22677 procedure Set_SPARK_Context;
22678 -- Subsidiary to routines Process_xxx. Set the global variables
22679 -- which represent the mode of the context from pragma N. Ensure
22680 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
22682 ------------------------------
22683 -- Check_Pragma_Conformance --
22684 ------------------------------
22686 procedure Check_Pragma_Conformance
22687 (Context_Pragma : Node_Id;
22688 Entity : Entity_Id;
22689 Entity_Pragma : Node_Id)
22691 Err_Id : Entity_Id;
22695 -- The current pragma may appear without an argument. If this
22696 -- is the case, associate all error messages with the pragma
22699 if Present (Arg1) then
22705 -- The mode of the current pragma is compared against that of
22706 -- an enclosing context.
22708 if Present (Context_Pragma) then
22709 pragma Assert (Nkind (Context_Pragma) = N_Pragma);
22711 -- Issue an error if the new mode is less restrictive than
22712 -- that of the context.
22714 if Get_SPARK_Mode_From_Annotation (Context_Pragma) = Off
22715 and then Get_SPARK_Mode_From_Annotation (N) = On
22718 ("cannot change SPARK_Mode from Off to On", Err_N);
22719 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
22720 Error_Msg_N ("\SPARK_Mode was set to Off#", Err_N);
22725 -- The mode of the current pragma is compared against that of
22726 -- an initial package, protected type, subprogram or task type
22729 if Present (Entity) then
22731 -- A simple protected or task type is transformed into an
22732 -- anonymous type whose name cannot be used to issue error
22733 -- messages. Recover the original entity of the type.
22735 if Ekind_In (Entity, E_Protected_Type, E_Task_Type) then
22738 (Original_Node (Unit_Declaration_Node (Entity)));
22743 -- Both the initial declaration and the completion carry
22744 -- SPARK_Mode pragmas.
22746 if Present (Entity_Pragma) then
22747 pragma Assert (Nkind (Entity_Pragma) = N_Pragma);
22749 -- Issue an error if the new mode is less restrictive
22750 -- than that of the initial declaration.
22752 if Get_SPARK_Mode_From_Annotation (Entity_Pragma) = Off
22753 and then Get_SPARK_Mode_From_Annotation (N) = On
22755 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
22756 Error_Msg_Sloc := Sloc (Entity_Pragma);
22758 ("\value Off was set for SPARK_Mode on&#",
22763 -- Otherwise the initial declaration lacks a SPARK_Mode
22764 -- pragma in which case the current pragma is illegal as
22765 -- it cannot "complete".
22767 elsif Get_SPARK_Mode_From_Annotation (N) = Off
22768 and then (Is_Generic_Unit (Entity) or else In_Instance)
22773 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
22774 Error_Msg_Sloc := Sloc (Err_Id);
22776 ("\no value was set for SPARK_Mode on&#",
22781 end Check_Pragma_Conformance;
22783 --------------------------------
22784 -- Check_Library_Level_Entity --
22785 --------------------------------
22787 procedure Check_Library_Level_Entity (E : Entity_Id) is
22788 procedure Add_Entity_To_Name_Buffer;
22789 -- Add the E_Kind of entity E to the name buffer
22791 -------------------------------
22792 -- Add_Entity_To_Name_Buffer --
22793 -------------------------------
22795 procedure Add_Entity_To_Name_Buffer is
22797 if Ekind_In (E, E_Entry, E_Entry_Family) then
22798 Add_Str_To_Name_Buffer ("entry");
22800 elsif Ekind_In (E, E_Generic_Package,
22804 Add_Str_To_Name_Buffer ("package");
22806 elsif Ekind_In (E, E_Protected_Body, E_Protected_Type) then
22807 Add_Str_To_Name_Buffer ("protected type");
22809 elsif Ekind_In (E, E_Function,
22810 E_Generic_Function,
22811 E_Generic_Procedure,
22815 Add_Str_To_Name_Buffer ("subprogram");
22818 pragma Assert (Ekind_In (E, E_Task_Body, E_Task_Type));
22819 Add_Str_To_Name_Buffer ("task type");
22821 end Add_Entity_To_Name_Buffer;
22825 Msg_1 : constant String := "incorrect placement of pragma%";
22828 -- Start of processing for Check_Library_Level_Entity
22831 -- A SPARK_Mode of On shall only apply to library-level
22832 -- entities, except for those in generic instances, which are
22833 -- ignored (even if the entity gets SPARK_Mode pragma attached
22834 -- in the AST, its effect is not taken into account unless the
22835 -- context already provides SPARK_Mode of On in GNATprove).
22837 if Get_SPARK_Mode_From_Annotation (N) = On
22838 and then not Is_Library_Level_Entity (E)
22839 and then Instantiation_Location (Sloc (N)) = No_Location
22841 Error_Msg_Name_1 := Pname;
22842 Error_Msg_N (Fix_Error (Msg_1), N);
22845 Add_Str_To_Name_Buffer ("\& is not a library-level ");
22846 Add_Entity_To_Name_Buffer;
22848 Msg_2 := Name_Find;
22849 Error_Msg_NE (Get_Name_String (Msg_2), N, E);
22853 end Check_Library_Level_Entity;
22859 procedure Process_Body (Decl : Node_Id) is
22860 Body_Id : constant Entity_Id := Defining_Entity (Decl);
22861 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl);
22864 -- Ignore pragma when applied to the special body created for
22865 -- inlining, recognized by its internal name _Parent.
22867 if Chars (Body_Id) = Name_uParent then
22871 Check_Library_Level_Entity (Body_Id);
22873 -- For entry bodies, verify the legality against:
22874 -- * The mode of the context
22875 -- * The mode of the spec (if any)
22877 if Nkind_In (Decl, N_Entry_Body, N_Subprogram_Body) then
22879 -- A stand-alone subprogram body
22881 if Body_Id = Spec_Id then
22882 Check_Pragma_Conformance
22883 (Context_Pragma => SPARK_Pragma (Body_Id),
22885 Entity_Pragma => Empty);
22887 -- An entry or subprogram body that completes a previous
22891 Check_Pragma_Conformance
22892 (Context_Pragma => SPARK_Pragma (Body_Id),
22894 Entity_Pragma => SPARK_Pragma (Spec_Id));
22898 Set_SPARK_Pragma (Body_Id, N);
22899 Set_SPARK_Pragma_Inherited (Body_Id, False);
22901 -- For package bodies, verify the legality against:
22902 -- * The mode of the context
22903 -- * The mode of the private part
22905 -- This case is separated from protected and task bodies
22906 -- because the statement part of the package body inherits
22907 -- the mode of the body declarations.
22909 elsif Nkind (Decl) = N_Package_Body then
22910 Check_Pragma_Conformance
22911 (Context_Pragma => SPARK_Pragma (Body_Id),
22913 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
22916 Set_SPARK_Pragma (Body_Id, N);
22917 Set_SPARK_Pragma_Inherited (Body_Id, False);
22918 Set_SPARK_Aux_Pragma (Body_Id, N);
22919 Set_SPARK_Aux_Pragma_Inherited (Body_Id, True);
22921 -- For protected and task bodies, verify the legality against:
22922 -- * The mode of the context
22923 -- * The mode of the private part
22927 (Nkind_In (Decl, N_Protected_Body, N_Task_Body));
22929 Check_Pragma_Conformance
22930 (Context_Pragma => SPARK_Pragma (Body_Id),
22932 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
22935 Set_SPARK_Pragma (Body_Id, N);
22936 Set_SPARK_Pragma_Inherited (Body_Id, False);
22940 --------------------------
22941 -- Process_Overloadable --
22942 --------------------------
22944 procedure Process_Overloadable (Decl : Node_Id) is
22945 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
22946 Spec_Typ : constant Entity_Id := Etype (Spec_Id);
22949 Check_Library_Level_Entity (Spec_Id);
22951 -- Verify the legality against:
22952 -- * The mode of the context
22954 Check_Pragma_Conformance
22955 (Context_Pragma => SPARK_Pragma (Spec_Id),
22957 Entity_Pragma => Empty);
22959 Set_SPARK_Pragma (Spec_Id, N);
22960 Set_SPARK_Pragma_Inherited (Spec_Id, False);
22962 -- When the pragma applies to the anonymous object created for
22963 -- a single task type, decorate the type as well. This scenario
22964 -- arises when the single task type lacks a task definition,
22965 -- therefore there is no issue with respect to a potential
22966 -- pragma SPARK_Mode in the private part.
22968 -- task type Anon_Task_Typ;
22969 -- Obj : Anon_Task_Typ;
22970 -- pragma SPARK_Mode ...;
22972 if Is_Single_Task_Object (Spec_Id) then
22973 Set_SPARK_Pragma (Spec_Typ, N);
22974 Set_SPARK_Pragma_Inherited (Spec_Typ, False);
22975 Set_SPARK_Aux_Pragma (Spec_Typ, N);
22976 Set_SPARK_Aux_Pragma_Inherited (Spec_Typ, True);
22978 end Process_Overloadable;
22980 --------------------------
22981 -- Process_Private_Part --
22982 --------------------------
22984 procedure Process_Private_Part (Decl : Node_Id) is
22985 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
22988 Check_Library_Level_Entity (Spec_Id);
22990 -- Verify the legality against:
22991 -- * The mode of the visible declarations
22993 Check_Pragma_Conformance
22994 (Context_Pragma => Empty,
22996 Entity_Pragma => SPARK_Pragma (Spec_Id));
22999 Set_SPARK_Aux_Pragma (Spec_Id, N);
23000 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False);
23001 end Process_Private_Part;
23003 ----------------------------
23004 -- Process_Statement_Part --
23005 ----------------------------
23007 procedure Process_Statement_Part (Decl : Node_Id) is
23008 Body_Id : constant Entity_Id := Defining_Entity (Decl);
23011 Check_Library_Level_Entity (Body_Id);
23013 -- Verify the legality against:
23014 -- * The mode of the body declarations
23016 Check_Pragma_Conformance
23017 (Context_Pragma => Empty,
23019 Entity_Pragma => SPARK_Pragma (Body_Id));
23022 Set_SPARK_Aux_Pragma (Body_Id, N);
23023 Set_SPARK_Aux_Pragma_Inherited (Body_Id, False);
23024 end Process_Statement_Part;
23026 --------------------------
23027 -- Process_Visible_Part --
23028 --------------------------
23030 procedure Process_Visible_Part (Decl : Node_Id) is
23031 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
23032 Obj_Id : Entity_Id;
23035 Check_Library_Level_Entity (Spec_Id);
23037 -- Verify the legality against:
23038 -- * The mode of the context
23040 Check_Pragma_Conformance
23041 (Context_Pragma => SPARK_Pragma (Spec_Id),
23043 Entity_Pragma => Empty);
23045 -- A task unit declared without a definition does not set the
23046 -- SPARK_Mode of the context because the task does not have any
23047 -- entries that could inherit the mode.
23049 if not Nkind_In (Decl, N_Single_Task_Declaration,
23050 N_Task_Type_Declaration)
23055 Set_SPARK_Pragma (Spec_Id, N);
23056 Set_SPARK_Pragma_Inherited (Spec_Id, False);
23057 Set_SPARK_Aux_Pragma (Spec_Id, N);
23058 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True);
23060 -- When the pragma applies to a single protected or task type,
23061 -- decorate the corresponding anonymous object as well.
23063 -- protected Anon_Prot_Typ is
23064 -- pragma SPARK_Mode ...;
23066 -- end Anon_Prot_Typ;
23068 -- Obj : Anon_Prot_Typ;
23070 if Is_Single_Concurrent_Type (Spec_Id) then
23071 Obj_Id := Anonymous_Object (Spec_Id);
23073 Set_SPARK_Pragma (Obj_Id, N);
23074 Set_SPARK_Pragma_Inherited (Obj_Id, False);
23076 end Process_Visible_Part;
23078 -----------------------
23079 -- Set_SPARK_Context --
23080 -----------------------
23082 procedure Set_SPARK_Context is
23084 SPARK_Mode := Mode_Id;
23085 SPARK_Mode_Pragma := N;
23086 end Set_SPARK_Context;
23094 -- Start of processing for Do_SPARK_Mode
23098 Check_No_Identifiers;
23099 Check_At_Most_N_Arguments (1);
23101 -- Check the legality of the mode (no argument = ON)
23103 if Arg_Count = 1 then
23104 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23105 Mode := Chars (Get_Pragma_Arg (Arg1));
23110 Mode_Id := Get_SPARK_Mode_Type (Mode);
23111 Context := Parent (N);
23113 -- When a SPARK_Mode pragma appears inside an instantiation whose
23114 -- enclosing context has SPARK_Mode set to "off", the pragma has
23115 -- no semantic effect.
23117 if Ignore_SPARK_Mode_Pragmas_In_Instance
23118 and then Mode_Id /= Off
23120 Rewrite (N, Make_Null_Statement (Loc));
23125 -- The pragma appears in a configuration file
23127 if No (Context) then
23128 Check_Valid_Configuration_Pragma;
23130 if Present (SPARK_Mode_Pragma) then
23133 Prev => SPARK_Mode_Pragma);
23139 -- The pragma acts as a configuration pragma in a compilation unit
23141 -- pragma SPARK_Mode ...;
23142 -- package Pack is ...;
23144 elsif Nkind (Context) = N_Compilation_Unit
23145 and then List_Containing (N) = Context_Items (Context)
23147 Check_Valid_Configuration_Pragma;
23150 -- Otherwise the placement of the pragma within the tree dictates
23151 -- its associated construct. Inspect the declarative list where
23152 -- the pragma resides to find a potential construct.
23156 while Present (Stmt) loop
23158 -- Skip prior pragmas, but check for duplicates. Note that
23159 -- this also takes care of pragmas generated for aspects.
23161 if Nkind (Stmt) = N_Pragma then
23162 if Pragma_Name (Stmt) = Pname then
23169 -- The pragma applies to an expression function that has
23170 -- already been rewritten into a subprogram declaration.
23172 -- function Expr_Func return ... is (...);
23173 -- pragma SPARK_Mode ...;
23175 elsif Nkind (Stmt) = N_Subprogram_Declaration
23176 and then Nkind (Original_Node (Stmt)) =
23177 N_Expression_Function
23179 Process_Overloadable (Stmt);
23182 -- The pragma applies to the anonymous object created for a
23183 -- single concurrent type.
23185 -- protected type Anon_Prot_Typ ...;
23186 -- Obj : Anon_Prot_Typ;
23187 -- pragma SPARK_Mode ...;
23189 elsif Nkind (Stmt) = N_Object_Declaration
23190 and then Is_Single_Concurrent_Object
23191 (Defining_Entity (Stmt))
23193 Process_Overloadable (Stmt);
23196 -- Skip internally generated code
23198 elsif not Comes_From_Source (Stmt) then
23201 -- The pragma applies to an entry or [generic] subprogram
23205 -- pragma SPARK_Mode ...;
23208 -- procedure Proc ...;
23209 -- pragma SPARK_Mode ...;
23211 elsif Nkind_In (Stmt, N_Generic_Subprogram_Declaration,
23212 N_Subprogram_Declaration)
23213 or else (Nkind (Stmt) = N_Entry_Declaration
23214 and then Is_Protected_Type
23215 (Scope (Defining_Entity (Stmt))))
23217 Process_Overloadable (Stmt);
23220 -- Otherwise the pragma does not apply to a legal construct
23221 -- or it does not appear at the top of a declarative or a
23222 -- statement list. Issue an error and stop the analysis.
23232 -- The pragma applies to a package or a subprogram that acts as
23233 -- a compilation unit.
23235 -- procedure Proc ...;
23236 -- pragma SPARK_Mode ...;
23238 if Nkind (Context) = N_Compilation_Unit_Aux then
23239 Context := Unit (Parent (Context));
23242 -- The pragma appears at the top of entry, package, protected
23243 -- unit, subprogram or task unit body declarations.
23245 -- entry Ent when ... is
23246 -- pragma SPARK_Mode ...;
23248 -- package body Pack is
23249 -- pragma SPARK_Mode ...;
23251 -- procedure Proc ... is
23252 -- pragma SPARK_Mode;
23254 -- protected body Prot is
23255 -- pragma SPARK_Mode ...;
23257 if Nkind_In (Context, N_Entry_Body,
23263 Process_Body (Context);
23265 -- The pragma appears at the top of the visible or private
23266 -- declaration of a package spec, protected or task unit.
23269 -- pragma SPARK_Mode ...;
23271 -- pragma SPARK_Mode ...;
23273 -- protected [type] Prot is
23274 -- pragma SPARK_Mode ...;
23276 -- pragma SPARK_Mode ...;
23278 elsif Nkind_In (Context, N_Package_Specification,
23279 N_Protected_Definition,
23282 if List_Containing (N) = Visible_Declarations (Context) then
23283 Process_Visible_Part (Parent (Context));
23285 Process_Private_Part (Parent (Context));
23288 -- The pragma appears at the top of package body statements
23290 -- package body Pack is
23292 -- pragma SPARK_Mode;
23294 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
23295 and then Nkind (Parent (Context)) = N_Package_Body
23297 Process_Statement_Part (Parent (Context));
23299 -- The pragma appeared as an aspect of a [generic] subprogram
23300 -- declaration that acts as a compilation unit.
23303 -- procedure Proc ...;
23304 -- pragma SPARK_Mode ...;
23306 elsif Nkind_In (Context, N_Generic_Subprogram_Declaration,
23307 N_Subprogram_Declaration)
23309 Process_Overloadable (Context);
23311 -- The pragma does not apply to a legal construct, issue error
23319 --------------------------------
23320 -- Static_Elaboration_Desired --
23321 --------------------------------
23323 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
23325 when Pragma_Static_Elaboration_Desired =>
23327 Check_At_Most_N_Arguments (1);
23329 if Is_Compilation_Unit (Current_Scope)
23330 and then Ekind (Current_Scope) = E_Package
23332 Set_Static_Elaboration_Desired (Current_Scope, True);
23334 Error_Pragma ("pragma% must apply to a library-level package");
23341 -- pragma Storage_Size (EXPRESSION);
23343 when Pragma_Storage_Size => Storage_Size : declare
23344 P : constant Node_Id := Parent (N);
23348 Check_No_Identifiers;
23349 Check_Arg_Count (1);
23351 -- The expression must be analyzed in the special manner described
23352 -- in "Handling of Default Expressions" in sem.ads.
23354 Arg := Get_Pragma_Arg (Arg1);
23355 Preanalyze_Spec_Expression (Arg, Any_Integer);
23357 if not Is_OK_Static_Expression (Arg) then
23358 Check_Restriction (Static_Storage_Size, Arg);
23361 if Nkind (P) /= N_Task_Definition then
23366 if Has_Storage_Size_Pragma (P) then
23367 Error_Pragma ("duplicate pragma% not allowed");
23369 Set_Has_Storage_Size_Pragma (P, True);
23372 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
23380 -- pragma Storage_Unit (NUMERIC_LITERAL);
23382 -- Only permitted argument is System'Storage_Unit value
23384 when Pragma_Storage_Unit =>
23385 Check_No_Identifiers;
23386 Check_Arg_Count (1);
23387 Check_Arg_Is_Integer_Literal (Arg1);
23389 if Intval (Get_Pragma_Arg (Arg1)) /=
23390 UI_From_Int (Ttypes.System_Storage_Unit)
23392 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
23394 ("the only allowed argument for pragma% is ^", Arg1);
23397 --------------------
23398 -- Stream_Convert --
23399 --------------------
23401 -- pragma Stream_Convert (
23402 -- [Entity =>] type_LOCAL_NAME,
23403 -- [Read =>] function_NAME,
23404 -- [Write =>] function NAME);
23406 when Pragma_Stream_Convert => Stream_Convert : declare
23407 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
23408 -- Check that the given argument is the name of a local function
23409 -- of one argument that is not overloaded earlier in the current
23410 -- local scope. A check is also made that the argument is a
23411 -- function with one parameter.
23413 --------------------------------------
23414 -- Check_OK_Stream_Convert_Function --
23415 --------------------------------------
23417 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
23421 Check_Arg_Is_Local_Name (Arg);
23422 Ent := Entity (Get_Pragma_Arg (Arg));
23424 if Has_Homonym (Ent) then
23426 ("argument for pragma% may not be overloaded", Arg);
23429 if Ekind (Ent) /= E_Function
23430 or else No (First_Formal (Ent))
23431 or else Present (Next_Formal (First_Formal (Ent)))
23434 ("argument for pragma% must be function of one argument",
23437 end Check_OK_Stream_Convert_Function;
23439 -- Start of processing for Stream_Convert
23443 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
23444 Check_Arg_Count (3);
23445 Check_Optional_Identifier (Arg1, Name_Entity);
23446 Check_Optional_Identifier (Arg2, Name_Read);
23447 Check_Optional_Identifier (Arg3, Name_Write);
23448 Check_Arg_Is_Local_Name (Arg1);
23449 Check_OK_Stream_Convert_Function (Arg2);
23450 Check_OK_Stream_Convert_Function (Arg3);
23453 Typ : constant Entity_Id :=
23454 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
23455 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
23456 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
23459 Check_First_Subtype (Arg1);
23461 -- Check for too early or too late. Note that we don't enforce
23462 -- the rule about primitive operations in this case, since, as
23463 -- is the case for explicit stream attributes themselves, these
23464 -- restrictions are not appropriate. Note that the chaining of
23465 -- the pragma by Rep_Item_Too_Late is actually the critical
23466 -- processing done for this pragma.
23468 if Rep_Item_Too_Early (Typ, N)
23470 Rep_Item_Too_Late (Typ, N, FOnly => True)
23475 -- Return if previous error
23477 if Etype (Typ) = Any_Type
23479 Etype (Read) = Any_Type
23481 Etype (Write) = Any_Type
23488 if Underlying_Type (Etype (Read)) /= Typ then
23490 ("incorrect return type for function&", Arg2);
23493 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
23495 ("incorrect parameter type for function&", Arg3);
23498 if Underlying_Type (Etype (First_Formal (Read))) /=
23499 Underlying_Type (Etype (Write))
23502 ("result type of & does not match Read parameter type",
23506 end Stream_Convert;
23512 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
23514 -- This is processed by the parser since some of the style checks
23515 -- take place during source scanning and parsing. This means that
23516 -- we don't need to issue error messages here.
23518 when Pragma_Style_Checks => Style_Checks : declare
23519 A : constant Node_Id := Get_Pragma_Arg (Arg1);
23525 Check_No_Identifiers;
23527 -- Two argument form
23529 if Arg_Count = 2 then
23530 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23537 E_Id := Get_Pragma_Arg (Arg2);
23540 if not Is_Entity_Name (E_Id) then
23542 ("second argument of pragma% must be entity name",
23546 E := Entity (E_Id);
23548 if not Ignore_Style_Checks_Pragmas then
23553 Set_Suppress_Style_Checks
23554 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off);
23555 exit when No (Homonym (E));
23562 -- One argument form
23565 Check_Arg_Count (1);
23567 if Nkind (A) = N_String_Literal then
23571 Slen : constant Natural := Natural (String_Length (S));
23572 Options : String (1 .. Slen);
23578 C := Get_String_Char (S, Pos (J));
23579 exit when not In_Character_Range (C);
23580 Options (J) := Get_Character (C);
23582 -- If at end of string, set options. As per discussion
23583 -- above, no need to check for errors, since we issued
23584 -- them in the parser.
23587 if not Ignore_Style_Checks_Pragmas then
23588 Set_Style_Check_Options (Options);
23598 elsif Nkind (A) = N_Identifier then
23599 if Chars (A) = Name_All_Checks then
23600 if not Ignore_Style_Checks_Pragmas then
23602 Set_GNAT_Style_Check_Options;
23604 Set_Default_Style_Check_Options;
23608 elsif Chars (A) = Name_On then
23609 if not Ignore_Style_Checks_Pragmas then
23610 Style_Check := True;
23613 elsif Chars (A) = Name_Off then
23614 if not Ignore_Style_Checks_Pragmas then
23615 Style_Check := False;
23626 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
23628 when Pragma_Subtitle =>
23630 Check_Arg_Count (1);
23631 Check_Optional_Identifier (Arg1, Name_Subtitle);
23632 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
23639 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
23641 when Pragma_Suppress =>
23642 Process_Suppress_Unsuppress (Suppress_Case => True);
23648 -- pragma Suppress_All;
23650 -- The only check made here is that the pragma has no arguments.
23651 -- There are no placement rules, and the processing required (setting
23652 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
23653 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
23654 -- then creates and inserts a pragma Suppress (All_Checks).
23656 when Pragma_Suppress_All =>
23658 Check_Arg_Count (0);
23660 -------------------------
23661 -- Suppress_Debug_Info --
23662 -------------------------
23664 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
23666 when Pragma_Suppress_Debug_Info => Suppress_Debug_Info : declare
23667 Nam_Id : Entity_Id;
23671 Check_Arg_Count (1);
23672 Check_Optional_Identifier (Arg1, Name_Entity);
23673 Check_Arg_Is_Local_Name (Arg1);
23675 Nam_Id := Entity (Get_Pragma_Arg (Arg1));
23677 -- A pragma that applies to a Ghost entity becomes Ghost for the
23678 -- purposes of legality checks and removal of ignored Ghost code.
23680 Mark_Ghost_Pragma (N, Nam_Id);
23681 Set_Debug_Info_Off (Nam_Id);
23682 end Suppress_Debug_Info;
23684 ----------------------------------
23685 -- Suppress_Exception_Locations --
23686 ----------------------------------
23688 -- pragma Suppress_Exception_Locations;
23690 when Pragma_Suppress_Exception_Locations =>
23692 Check_Arg_Count (0);
23693 Check_Valid_Configuration_Pragma;
23694 Exception_Locations_Suppressed := True;
23696 -----------------------------
23697 -- Suppress_Initialization --
23698 -----------------------------
23700 -- pragma Suppress_Initialization ([Entity =>] type_Name);
23702 when Pragma_Suppress_Initialization => Suppress_Init : declare
23708 Check_Arg_Count (1);
23709 Check_Optional_Identifier (Arg1, Name_Entity);
23710 Check_Arg_Is_Local_Name (Arg1);
23712 E_Id := Get_Pragma_Arg (Arg1);
23714 if Etype (E_Id) = Any_Type then
23718 E := Entity (E_Id);
23720 -- A pragma that applies to a Ghost entity becomes Ghost for the
23721 -- purposes of legality checks and removal of ignored Ghost code.
23723 Mark_Ghost_Pragma (N, E);
23725 if not Is_Type (E) and then Ekind (E) /= E_Variable then
23727 ("pragma% requires variable, type or subtype", Arg1);
23730 if Rep_Item_Too_Early (E, N)
23732 Rep_Item_Too_Late (E, N, FOnly => True)
23737 -- For incomplete/private type, set flag on full view
23739 if Is_Incomplete_Or_Private_Type (E) then
23740 if No (Full_View (Base_Type (E))) then
23742 ("argument of pragma% cannot be an incomplete type", Arg1);
23744 Set_Suppress_Initialization (Full_View (E));
23747 -- For first subtype, set flag on base type
23749 elsif Is_First_Subtype (E) then
23750 Set_Suppress_Initialization (Base_Type (E));
23752 -- For other than first subtype, set flag on subtype or variable
23755 Set_Suppress_Initialization (E);
23763 -- pragma System_Name (DIRECT_NAME);
23765 -- Syntax check: one argument, which must be the identifier GNAT or
23766 -- the identifier GCC, no other identifiers are acceptable.
23768 when Pragma_System_Name =>
23770 Check_No_Identifiers;
23771 Check_Arg_Count (1);
23772 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
23774 -----------------------------
23775 -- Task_Dispatching_Policy --
23776 -----------------------------
23778 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
23780 when Pragma_Task_Dispatching_Policy => declare
23784 Check_Ada_83_Warning;
23785 Check_Arg_Count (1);
23786 Check_No_Identifiers;
23787 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
23788 Check_Valid_Configuration_Pragma;
23789 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
23790 DP := Fold_Upper (Name_Buffer (1));
23792 if Task_Dispatching_Policy /= ' '
23793 and then Task_Dispatching_Policy /= DP
23795 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
23797 ("task dispatching policy incompatible with policy#");
23799 -- Set new policy, but always preserve System_Location since we
23800 -- like the error message with the run time name.
23803 Task_Dispatching_Policy := DP;
23805 if Task_Dispatching_Policy_Sloc /= System_Location then
23806 Task_Dispatching_Policy_Sloc := Loc;
23815 -- pragma Task_Info (EXPRESSION);
23817 when Pragma_Task_Info => Task_Info : declare
23818 P : constant Node_Id := Parent (N);
23824 if Warn_On_Obsolescent_Feature then
23826 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
23827 & "instead?j?", N);
23830 if Nkind (P) /= N_Task_Definition then
23831 Error_Pragma ("pragma% must appear in task definition");
23834 Check_No_Identifiers;
23835 Check_Arg_Count (1);
23837 Analyze_And_Resolve
23838 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
23840 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
23844 Ent := Defining_Identifier (Parent (P));
23846 -- Check duplicate pragma before we chain the pragma in the Rep
23847 -- Item chain of Ent.
23850 (Ent, Name_Task_Info, Check_Parents => False)
23852 Error_Pragma ("duplicate pragma% not allowed");
23855 Record_Rep_Item (Ent, N);
23862 -- pragma Task_Name (string_EXPRESSION);
23864 when Pragma_Task_Name => Task_Name : declare
23865 P : constant Node_Id := Parent (N);
23870 Check_No_Identifiers;
23871 Check_Arg_Count (1);
23873 Arg := Get_Pragma_Arg (Arg1);
23875 -- The expression is used in the call to Create_Task, and must be
23876 -- expanded there, not in the context of the current spec. It must
23877 -- however be analyzed to capture global references, in case it
23878 -- appears in a generic context.
23880 Preanalyze_And_Resolve (Arg, Standard_String);
23882 if Nkind (P) /= N_Task_Definition then
23886 Ent := Defining_Identifier (Parent (P));
23888 -- Check duplicate pragma before we chain the pragma in the Rep
23889 -- Item chain of Ent.
23892 (Ent, Name_Task_Name, Check_Parents => False)
23894 Error_Pragma ("duplicate pragma% not allowed");
23897 Record_Rep_Item (Ent, N);
23904 -- pragma Task_Storage (
23905 -- [Task_Type =>] LOCAL_NAME,
23906 -- [Top_Guard =>] static_integer_EXPRESSION);
23908 when Pragma_Task_Storage => Task_Storage : declare
23909 Args : Args_List (1 .. 2);
23910 Names : constant Name_List (1 .. 2) := (
23914 Task_Type : Node_Id renames Args (1);
23915 Top_Guard : Node_Id renames Args (2);
23921 Gather_Associations (Names, Args);
23923 if No (Task_Type) then
23925 ("missing task_type argument for pragma%");
23928 Check_Arg_Is_Local_Name (Task_Type);
23930 Ent := Entity (Task_Type);
23932 if not Is_Task_Type (Ent) then
23934 ("argument for pragma% must be task type", Task_Type);
23937 if No (Top_Guard) then
23939 ("pragma% takes two arguments", Task_Type);
23941 Check_Arg_Is_OK_Static_Expression (Top_Guard, Any_Integer);
23944 Check_First_Subtype (Task_Type);
23946 if Rep_Item_Too_Late (Ent, N) then
23955 -- pragma Test_Case
23956 -- ([Name =>] Static_String_EXPRESSION
23957 -- ,[Mode =>] MODE_TYPE
23958 -- [, Requires => Boolean_EXPRESSION]
23959 -- [, Ensures => Boolean_EXPRESSION]);
23961 -- MODE_TYPE ::= Nominal | Robustness
23963 -- Characteristics:
23965 -- * Analysis - The annotation undergoes initial checks to verify
23966 -- the legal placement and context. Secondary checks preanalyze the
23969 -- Analyze_Test_Case_In_Decl_Part
23971 -- * Expansion - None.
23973 -- * Template - The annotation utilizes the generic template of the
23974 -- related subprogram when it is:
23976 -- aspect on subprogram declaration
23978 -- The annotation must prepare its own template when it is:
23980 -- pragma on subprogram declaration
23982 -- * Globals - Capture of global references must occur after full
23985 -- * Instance - The annotation is instantiated automatically when
23986 -- the related generic subprogram is instantiated except for the
23987 -- "pragma on subprogram declaration" case. In that scenario the
23988 -- annotation must instantiate itself.
23990 when Pragma_Test_Case => Test_Case : declare
23991 procedure Check_Distinct_Name (Subp_Id : Entity_Id);
23992 -- Ensure that the contract of subprogram Subp_Id does not contain
23993 -- another Test_Case pragma with the same Name as the current one.
23995 -------------------------
23996 -- Check_Distinct_Name --
23997 -------------------------
23999 procedure Check_Distinct_Name (Subp_Id : Entity_Id) is
24000 Items : constant Node_Id := Contract (Subp_Id);
24001 Name : constant String_Id := Get_Name_From_CTC_Pragma (N);
24005 -- Inspect all Test_Case pragma of the related subprogram
24006 -- looking for one with a duplicate "Name" argument.
24008 if Present (Items) then
24009 Prag := Contract_Test_Cases (Items);
24010 while Present (Prag) loop
24011 if Pragma_Name (Prag) = Name_Test_Case
24013 and then String_Equal
24014 (Name, Get_Name_From_CTC_Pragma (Prag))
24016 Error_Msg_Sloc := Sloc (Prag);
24017 Error_Pragma ("name for pragma % is already used #");
24020 Prag := Next_Pragma (Prag);
24023 end Check_Distinct_Name;
24027 Pack_Decl : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
24030 Subp_Decl : Node_Id;
24031 Subp_Id : Entity_Id;
24033 -- Start of processing for Test_Case
24037 Check_At_Least_N_Arguments (2);
24038 Check_At_Most_N_Arguments (4);
24040 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
24044 Check_Optional_Identifier (Arg1, Name_Name);
24045 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
24049 Check_Optional_Identifier (Arg2, Name_Mode);
24050 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
24052 -- Arguments "Requires" and "Ensures"
24054 if Present (Arg3) then
24055 if Present (Arg4) then
24056 Check_Identifier (Arg3, Name_Requires);
24057 Check_Identifier (Arg4, Name_Ensures);
24059 Check_Identifier_Is_One_Of
24060 (Arg3, Name_Requires, Name_Ensures);
24064 -- Pragma Test_Case must be associated with a subprogram declared
24065 -- in a library-level package. First determine whether the current
24066 -- compilation unit is a legal context.
24068 if Nkind_In (Pack_Decl, N_Package_Declaration,
24069 N_Generic_Package_Declaration)
24073 -- Otherwise the placement is illegal
24077 ("pragma % must be specified within a package declaration");
24081 Subp_Decl := Find_Related_Declaration_Or_Body (N);
24083 -- Find the enclosing context
24085 Context := Parent (Subp_Decl);
24087 if Present (Context) then
24088 Context := Parent (Context);
24091 -- Verify the placement of the pragma
24093 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
24095 ("pragma % cannot be applied to abstract subprogram");
24098 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
24099 Error_Pragma ("pragma % cannot be applied to entry");
24102 -- The context is a [generic] subprogram declared at the top level
24103 -- of the [generic] package unit.
24105 elsif Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration,
24106 N_Subprogram_Declaration)
24107 and then Present (Context)
24108 and then Nkind_In (Context, N_Generic_Package_Declaration,
24109 N_Package_Declaration)
24113 -- Otherwise the placement is illegal
24117 ("pragma % must be applied to a library-level subprogram "
24122 Subp_Id := Defining_Entity (Subp_Decl);
24124 -- A pragma that applies to a Ghost entity becomes Ghost for the
24125 -- purposes of legality checks and removal of ignored Ghost code.
24127 Mark_Ghost_Pragma (N, Subp_Id);
24129 -- Chain the pragma on the contract for further processing by
24130 -- Analyze_Test_Case_In_Decl_Part.
24132 Add_Contract_Item (N, Subp_Id);
24134 -- Preanalyze the original aspect argument "Name" for a generic
24135 -- subprogram to properly capture global references.
24137 if Is_Generic_Subprogram (Subp_Id) then
24138 Asp_Arg := Test_Case_Arg (N, Name_Name, From_Aspect => True);
24140 if Present (Asp_Arg) then
24142 -- The argument appears with an identifier in association
24145 if Nkind (Asp_Arg) = N_Component_Association then
24146 Asp_Arg := Expression (Asp_Arg);
24149 Check_Expr_Is_OK_Static_Expression
24150 (Asp_Arg, Standard_String);
24154 -- Ensure that the all Test_Case pragmas of the related subprogram
24155 -- have distinct names.
24157 Check_Distinct_Name (Subp_Id);
24159 -- Fully analyze the pragma when it appears inside an entry
24160 -- or subprogram body because it cannot benefit from forward
24163 if Nkind_In (Subp_Decl, N_Entry_Body,
24165 N_Subprogram_Body_Stub)
24167 -- The legality checks of pragma Test_Case are affected by the
24168 -- SPARK mode in effect and the volatility of the context.
24169 -- Analyze all pragmas in a specific order.
24171 Analyze_If_Present (Pragma_SPARK_Mode);
24172 Analyze_If_Present (Pragma_Volatile_Function);
24173 Analyze_Test_Case_In_Decl_Part (N);
24177 --------------------------
24178 -- Thread_Local_Storage --
24179 --------------------------
24181 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
24183 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
24189 Check_Arg_Count (1);
24190 Check_Optional_Identifier (Arg1, Name_Entity);
24191 Check_Arg_Is_Library_Level_Local_Name (Arg1);
24193 Id := Get_Pragma_Arg (Arg1);
24196 if not Is_Entity_Name (Id)
24197 or else Ekind (Entity (Id)) /= E_Variable
24199 Error_Pragma_Arg ("local variable name required", Arg1);
24204 -- A pragma that applies to a Ghost entity becomes Ghost for the
24205 -- purposes of legality checks and removal of ignored Ghost code.
24207 Mark_Ghost_Pragma (N, E);
24209 if Rep_Item_Too_Early (E, N)
24211 Rep_Item_Too_Late (E, N)
24216 Set_Has_Pragma_Thread_Local_Storage (E);
24217 Set_Has_Gigi_Rep_Item (E);
24218 end Thread_Local_Storage;
24224 -- pragma Time_Slice (static_duration_EXPRESSION);
24226 when Pragma_Time_Slice => Time_Slice : declare
24232 Check_Arg_Count (1);
24233 Check_No_Identifiers;
24234 Check_In_Main_Program;
24235 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_Duration);
24237 if not Error_Posted (Arg1) then
24239 while Present (Nod) loop
24240 if Nkind (Nod) = N_Pragma
24241 and then Pragma_Name (Nod) = Name_Time_Slice
24243 Error_Msg_Name_1 := Pname;
24244 Error_Msg_N ("duplicate pragma% not permitted", Nod);
24251 -- Process only if in main unit
24253 if Get_Source_Unit (Loc) = Main_Unit then
24254 Opt.Time_Slice_Set := True;
24255 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
24257 if Val <= Ureal_0 then
24258 Opt.Time_Slice_Value := 0;
24260 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
24261 Opt.Time_Slice_Value := 1_000_000_000;
24264 Opt.Time_Slice_Value :=
24265 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
24274 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
24276 -- TITLING_OPTION ::=
24277 -- [Title =>] STRING_LITERAL
24278 -- | [Subtitle =>] STRING_LITERAL
24280 when Pragma_Title => Title : declare
24281 Args : Args_List (1 .. 2);
24282 Names : constant Name_List (1 .. 2) := (
24288 Gather_Associations (Names, Args);
24291 for J in 1 .. 2 loop
24292 if Present (Args (J)) then
24293 Check_Arg_Is_OK_Static_Expression
24294 (Args (J), Standard_String);
24299 ----------------------------
24300 -- Type_Invariant[_Class] --
24301 ----------------------------
24303 -- pragma Type_Invariant[_Class]
24304 -- ([Entity =>] type_LOCAL_NAME,
24305 -- [Check =>] EXPRESSION);
24307 when Pragma_Type_Invariant
24308 | Pragma_Type_Invariant_Class
24310 Type_Invariant : declare
24311 I_Pragma : Node_Id;
24314 Check_Arg_Count (2);
24316 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
24317 -- setting Class_Present for the Type_Invariant_Class case.
24319 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class);
24320 I_Pragma := New_Copy (N);
24321 Set_Pragma_Identifier
24322 (I_Pragma, Make_Identifier (Loc, Name_Invariant));
24323 Rewrite (N, I_Pragma);
24324 Set_Analyzed (N, False);
24326 end Type_Invariant;
24328 ---------------------
24329 -- Unchecked_Union --
24330 ---------------------
24332 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
24334 when Pragma_Unchecked_Union => Unchecked_Union : declare
24335 Assoc : constant Node_Id := Arg1;
24336 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
24346 Check_No_Identifiers;
24347 Check_Arg_Count (1);
24348 Check_Arg_Is_Local_Name (Arg1);
24350 Find_Type (Type_Id);
24352 Typ := Entity (Type_Id);
24354 -- A pragma that applies to a Ghost entity becomes Ghost for the
24355 -- purposes of legality checks and removal of ignored Ghost code.
24357 Mark_Ghost_Pragma (N, Typ);
24360 or else Rep_Item_Too_Early (Typ, N)
24364 Typ := Underlying_Type (Typ);
24367 if Rep_Item_Too_Late (Typ, N) then
24371 Check_First_Subtype (Arg1);
24373 -- Note remaining cases are references to a type in the current
24374 -- declarative part. If we find an error, we post the error on
24375 -- the relevant type declaration at an appropriate point.
24377 if not Is_Record_Type (Typ) then
24378 Error_Msg_N ("unchecked union must be record type", Typ);
24381 elsif Is_Tagged_Type (Typ) then
24382 Error_Msg_N ("unchecked union must not be tagged", Typ);
24385 elsif not Has_Discriminants (Typ) then
24387 ("unchecked union must have one discriminant", Typ);
24390 -- Note: in previous versions of GNAT we used to check for limited
24391 -- types and give an error, but in fact the standard does allow
24392 -- Unchecked_Union on limited types, so this check was removed.
24394 -- Similarly, GNAT used to require that all discriminants have
24395 -- default values, but this is not mandated by the RM.
24397 -- Proceed with basic error checks completed
24400 Tdef := Type_Definition (Declaration_Node (Typ));
24401 Clist := Component_List (Tdef);
24403 -- Check presence of component list and variant part
24405 if No (Clist) or else No (Variant_Part (Clist)) then
24407 ("unchecked union must have variant part", Tdef);
24411 -- Check components
24413 Comp := First_Non_Pragma (Component_Items (Clist));
24414 while Present (Comp) loop
24415 Check_Component (Comp, Typ);
24416 Next_Non_Pragma (Comp);
24419 -- Check variant part
24421 Vpart := Variant_Part (Clist);
24423 Variant := First_Non_Pragma (Variants (Vpart));
24424 while Present (Variant) loop
24425 Check_Variant (Variant, Typ);
24426 Next_Non_Pragma (Variant);
24430 Set_Is_Unchecked_Union (Typ);
24431 Set_Convention (Typ, Convention_C);
24432 Set_Has_Unchecked_Union (Base_Type (Typ));
24433 Set_Is_Unchecked_Union (Base_Type (Typ));
24434 end Unchecked_Union;
24436 ----------------------------
24437 -- Unevaluated_Use_Of_Old --
24438 ----------------------------
24440 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
24442 when Pragma_Unevaluated_Use_Of_Old =>
24444 Check_Arg_Count (1);
24445 Check_No_Identifiers;
24446 Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow);
24448 -- Suppress/Unsuppress can appear as a configuration pragma, or in
24449 -- a declarative part or a package spec.
24451 if not Is_Configuration_Pragma then
24452 Check_Is_In_Decl_Part_Or_Package_Spec;
24455 -- Store proper setting of Uneval_Old
24457 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
24458 Uneval_Old := Fold_Upper (Name_Buffer (1));
24460 ------------------------
24461 -- Unimplemented_Unit --
24462 ------------------------
24464 -- pragma Unimplemented_Unit;
24466 -- Note: this only gives an error if we are generating code, or if
24467 -- we are in a generic library unit (where the pragma appears in the
24468 -- body, not in the spec).
24470 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
24471 Cunitent : constant Entity_Id :=
24472 Cunit_Entity (Get_Source_Unit (Loc));
24473 Ent_Kind : constant Entity_Kind := Ekind (Cunitent);
24477 Check_Arg_Count (0);
24479 if Operating_Mode = Generate_Code
24480 or else Ent_Kind = E_Generic_Function
24481 or else Ent_Kind = E_Generic_Procedure
24482 or else Ent_Kind = E_Generic_Package
24484 Get_Name_String (Chars (Cunitent));
24485 Set_Casing (Mixed_Case);
24486 Write_Str (Name_Buffer (1 .. Name_Len));
24487 Write_Str (" is not supported in this configuration");
24489 raise Unrecoverable_Error;
24491 end Unimplemented_Unit;
24493 ------------------------
24494 -- Universal_Aliasing --
24495 ------------------------
24497 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
24499 when Pragma_Universal_Aliasing => Universal_Alias : declare
24505 Check_Arg_Count (1);
24506 Check_Optional_Identifier (Arg2, Name_Entity);
24507 Check_Arg_Is_Local_Name (Arg1);
24508 E_Id := Get_Pragma_Arg (Arg1);
24510 if Etype (E_Id) = Any_Type then
24514 E := Entity (E_Id);
24516 if not Is_Type (E) then
24517 Error_Pragma_Arg ("pragma% requires type", Arg1);
24520 -- A pragma that applies to a Ghost entity becomes Ghost for the
24521 -- purposes of legality checks and removal of ignored Ghost code.
24523 Mark_Ghost_Pragma (N, E);
24524 Set_Universal_Aliasing (Base_Type (E));
24525 Record_Rep_Item (E, N);
24526 end Universal_Alias;
24528 --------------------
24529 -- Universal_Data --
24530 --------------------
24532 -- pragma Universal_Data [(library_unit_NAME)];
24534 when Pragma_Universal_Data =>
24536 Error_Pragma ("??pragma% ignored (applies only to AAMP)");
24542 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
24544 when Pragma_Unmodified =>
24545 Analyze_Unmodified_Or_Unused;
24551 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
24553 -- or when used in a context clause:
24555 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
24557 when Pragma_Unreferenced =>
24558 Analyze_Unreferenced_Or_Unused;
24560 --------------------------
24561 -- Unreferenced_Objects --
24562 --------------------------
24564 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
24566 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
24568 Arg_Expr : Node_Id;
24569 Arg_Id : Entity_Id;
24571 Ghost_Error_Posted : Boolean := False;
24572 -- Flag set when an error concerning the illegal mix of Ghost and
24573 -- non-Ghost types is emitted.
24575 Ghost_Id : Entity_Id := Empty;
24576 -- The entity of the first Ghost type encountered while processing
24577 -- the arguments of the pragma.
24581 Check_At_Least_N_Arguments (1);
24584 while Present (Arg) loop
24585 Check_No_Identifier (Arg);
24586 Check_Arg_Is_Local_Name (Arg);
24587 Arg_Expr := Get_Pragma_Arg (Arg);
24589 if Is_Entity_Name (Arg_Expr) then
24590 Arg_Id := Entity (Arg_Expr);
24592 if Is_Type (Arg_Id) then
24593 Set_Has_Pragma_Unreferenced_Objects (Arg_Id);
24595 -- A pragma that applies to a Ghost entity becomes Ghost
24596 -- for the purposes of legality checks and removal of
24597 -- ignored Ghost code.
24599 Mark_Ghost_Pragma (N, Arg_Id);
24601 -- Capture the entity of the first Ghost type being
24602 -- processed for error detection purposes.
24604 if Is_Ghost_Entity (Arg_Id) then
24605 if No (Ghost_Id) then
24606 Ghost_Id := Arg_Id;
24609 -- Otherwise the type is non-Ghost. It is illegal to mix
24610 -- references to Ghost and non-Ghost entities
24613 elsif Present (Ghost_Id)
24614 and then not Ghost_Error_Posted
24616 Ghost_Error_Posted := True;
24618 Error_Msg_Name_1 := Pname;
24620 ("pragma % cannot mention ghost and non-ghost types",
24623 Error_Msg_Sloc := Sloc (Ghost_Id);
24624 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
24626 Error_Msg_Sloc := Sloc (Arg_Id);
24627 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
24631 ("argument for pragma% must be type or subtype", Arg);
24635 ("argument for pragma% must be type or subtype", Arg);
24640 end Unreferenced_Objects;
24642 ------------------------------
24643 -- Unreserve_All_Interrupts --
24644 ------------------------------
24646 -- pragma Unreserve_All_Interrupts;
24648 when Pragma_Unreserve_All_Interrupts =>
24650 Check_Arg_Count (0);
24652 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
24653 Unreserve_All_Interrupts := True;
24660 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
24662 when Pragma_Unsuppress =>
24664 Process_Suppress_Unsuppress (Suppress_Case => False);
24670 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
24672 when Pragma_Unused =>
24673 Analyze_Unmodified_Or_Unused (Is_Unused => True);
24674 Analyze_Unreferenced_Or_Unused (Is_Unused => True);
24676 -------------------
24677 -- Use_VADS_Size --
24678 -------------------
24680 -- pragma Use_VADS_Size;
24682 when Pragma_Use_VADS_Size =>
24684 Check_Arg_Count (0);
24685 Check_Valid_Configuration_Pragma;
24686 Use_VADS_Size := True;
24688 ---------------------
24689 -- Validity_Checks --
24690 ---------------------
24692 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
24694 when Pragma_Validity_Checks => Validity_Checks : declare
24695 A : constant Node_Id := Get_Pragma_Arg (Arg1);
24701 Check_Arg_Count (1);
24702 Check_No_Identifiers;
24704 -- Pragma always active unless in CodePeer or GNATprove modes,
24705 -- which use a fixed configuration of validity checks.
24707 if not (CodePeer_Mode or GNATprove_Mode) then
24708 if Nkind (A) = N_String_Literal then
24712 Slen : constant Natural := Natural (String_Length (S));
24713 Options : String (1 .. Slen);
24717 -- Couldn't we use a for loop here over Options'Range???
24721 C := Get_String_Char (S, Pos (J));
24723 -- This is a weird test, it skips setting validity
24724 -- checks entirely if any element of S is out of
24725 -- range of Character, what is that about ???
24727 exit when not In_Character_Range (C);
24728 Options (J) := Get_Character (C);
24731 Set_Validity_Check_Options (Options);
24739 elsif Nkind (A) = N_Identifier then
24740 if Chars (A) = Name_All_Checks then
24741 Set_Validity_Check_Options ("a");
24742 elsif Chars (A) = Name_On then
24743 Validity_Checks_On := True;
24744 elsif Chars (A) = Name_Off then
24745 Validity_Checks_On := False;
24749 end Validity_Checks;
24755 -- pragma Volatile (LOCAL_NAME);
24757 when Pragma_Volatile =>
24758 Process_Atomic_Independent_Shared_Volatile;
24760 -------------------------
24761 -- Volatile_Components --
24762 -------------------------
24764 -- pragma Volatile_Components (array_LOCAL_NAME);
24766 -- Volatile is handled by the same circuit as Atomic_Components
24768 --------------------------
24769 -- Volatile_Full_Access --
24770 --------------------------
24772 -- pragma Volatile_Full_Access (LOCAL_NAME);
24774 when Pragma_Volatile_Full_Access =>
24776 Process_Atomic_Independent_Shared_Volatile;
24778 -----------------------
24779 -- Volatile_Function --
24780 -----------------------
24782 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
24784 when Pragma_Volatile_Function => Volatile_Function : declare
24785 Over_Id : Entity_Id;
24786 Spec_Id : Entity_Id;
24787 Subp_Decl : Node_Id;
24791 Check_No_Identifiers;
24792 Check_At_Most_N_Arguments (1);
24795 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
24797 -- Generic subprogram
24799 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
24802 -- Body acts as spec
24804 elsif Nkind (Subp_Decl) = N_Subprogram_Body
24805 and then No (Corresponding_Spec (Subp_Decl))
24809 -- Body stub acts as spec
24811 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
24812 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
24818 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
24826 Spec_Id := Unique_Defining_Entity (Subp_Decl);
24828 if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
24833 -- A pragma that applies to a Ghost entity becomes Ghost for the
24834 -- purposes of legality checks and removal of ignored Ghost code.
24836 Mark_Ghost_Pragma (N, Spec_Id);
24838 -- Chain the pragma on the contract for completeness
24840 Add_Contract_Item (N, Spec_Id);
24842 -- The legality checks of pragma Volatile_Function are affected by
24843 -- the SPARK mode in effect. Analyze all pragmas in a specific
24846 Analyze_If_Present (Pragma_SPARK_Mode);
24848 -- A volatile function cannot override a non-volatile function
24849 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
24850 -- in New_Overloaded_Entity, however at that point the pragma has
24851 -- not been processed yet.
24853 Over_Id := Overridden_Operation (Spec_Id);
24855 if Present (Over_Id)
24856 and then not Is_Volatile_Function (Over_Id)
24859 ("incompatible volatile function values in effect", Spec_Id);
24861 Error_Msg_Sloc := Sloc (Over_Id);
24863 ("\& declared # with Volatile_Function value False",
24866 Error_Msg_Sloc := Sloc (Spec_Id);
24868 ("\overridden # with Volatile_Function value True",
24872 -- Analyze the Boolean expression (if any)
24874 if Present (Arg1) then
24875 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
24877 end Volatile_Function;
24879 ----------------------
24880 -- Warning_As_Error --
24881 ----------------------
24883 -- pragma Warning_As_Error (static_string_EXPRESSION);
24885 when Pragma_Warning_As_Error =>
24887 Check_Arg_Count (1);
24888 Check_No_Identifiers;
24889 Check_Valid_Configuration_Pragma;
24891 if not Is_Static_String_Expression (Arg1) then
24893 ("argument of pragma% must be static string expression",
24896 -- OK static string expression
24899 Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1;
24900 Warnings_As_Errors (Warnings_As_Errors_Count) :=
24901 new String'(Acquire_Warning_Match_String
24902 (Expr_Value_S (Get_Pragma_Arg (Arg1))));
24909 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
24911 -- DETAILS ::= On | Off
24912 -- DETAILS ::= On | Off, local_NAME
24913 -- DETAILS ::= static_string_EXPRESSION
24914 -- DETAILS ::= On | Off, static_string_EXPRESSION
24916 -- TOOL_NAME ::= GNAT | GNATProve
24918 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
24920 -- Note: If the first argument matches an allowed tool name, it is
24921 -- always considered to be a tool name, even if there is a string
24922 -- variable of that name.
24924 -- Note if the second argument of DETAILS is a local_NAME then the
24925 -- second form is always understood. If the intention is to use
24926 -- the fourth form, then you can write NAME & "" to force the
24927 -- intepretation as a static_string_EXPRESSION.
24929 when Pragma_Warnings => Warnings : declare
24930 Reason : String_Id;
24934 Check_At_Least_N_Arguments (1);
24936 -- See if last argument is labeled Reason. If so, make sure we
24937 -- have a string literal or a concatenation of string literals,
24938 -- and acquire the REASON string. Then remove the REASON argument
24939 -- by decreasing Num_Args by one; Remaining processing looks only
24940 -- at first Num_Args arguments).
24943 Last_Arg : constant Node_Id :=
24944 Last (Pragma_Argument_Associations (N));
24947 if Nkind (Last_Arg) = N_Pragma_Argument_Association
24948 and then Chars (Last_Arg) = Name_Reason
24951 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
24952 Reason := End_String;
24953 Arg_Count := Arg_Count - 1;
24955 -- Not allowed in compiler units (bootstrap issues)
24957 Check_Compiler_Unit ("Reason for pragma Warnings", N);
24959 -- No REASON string, set null string as reason
24962 Reason := Null_String_Id;
24966 -- Now proceed with REASON taken care of and eliminated
24968 Check_No_Identifiers;
24970 -- If debug flag -gnatd.i is set, pragma is ignored
24972 if Debug_Flag_Dot_I then
24976 -- Process various forms of the pragma
24979 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
24980 Shifted_Args : List_Id;
24983 -- See if first argument is a tool name, currently either
24984 -- GNAT or GNATprove. If so, either ignore the pragma if the
24985 -- tool used does not match, or continue as if no tool name
24986 -- was given otherwise, by shifting the arguments.
24988 if Nkind (Argx) = N_Identifier
24989 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
24991 if Chars (Argx) = Name_Gnat then
24992 if CodePeer_Mode or GNATprove_Mode then
24993 Rewrite (N, Make_Null_Statement (Loc));
24998 elsif Chars (Argx) = Name_Gnatprove then
24999 if not GNATprove_Mode then
25000 Rewrite (N, Make_Null_Statement (Loc));
25006 raise Program_Error;
25009 -- At this point, the pragma Warnings applies to the tool,
25010 -- so continue with shifted arguments.
25012 Arg_Count := Arg_Count - 1;
25014 if Arg_Count = 1 then
25015 Shifted_Args := New_List (New_Copy (Arg2));
25016 elsif Arg_Count = 2 then
25017 Shifted_Args := New_List (New_Copy (Arg2),
25019 elsif Arg_Count = 3 then
25020 Shifted_Args := New_List (New_Copy (Arg2),
25024 raise Program_Error;
25029 Chars => Name_Warnings,
25030 Pragma_Argument_Associations => Shifted_Args));
25035 -- One argument case
25037 if Arg_Count = 1 then
25039 -- On/Off one argument case was processed by parser
25041 if Nkind (Argx) = N_Identifier
25042 and then Nam_In (Chars (Argx), Name_On, Name_Off)
25046 -- One argument case must be ON/OFF or static string expr
25048 elsif not Is_Static_String_Expression (Arg1) then
25050 ("argument of pragma% must be On/Off or static string "
25051 & "expression", Arg1);
25053 -- One argument string expression case
25057 Lit : constant Node_Id := Expr_Value_S (Argx);
25058 Str : constant String_Id := Strval (Lit);
25059 Len : constant Nat := String_Length (Str);
25067 while J <= Len loop
25068 C := Get_String_Char (Str, J);
25069 OK := In_Character_Range (C);
25072 Chr := Get_Character (C);
25074 -- Dash case: only -Wxxx is accepted
25081 C := Get_String_Char (Str, J);
25082 Chr := Get_Character (C);
25083 exit when Chr = 'W';
25088 elsif J < Len and then Chr = '.' then
25090 C := Get_String_Char (Str, J);
25091 Chr := Get_Character (C);
25093 if not Set_Dot_Warning_Switch (Chr) then
25095 ("invalid warning switch character "
25096 & '.' & Chr, Arg1);
25102 OK := Set_Warning_Switch (Chr);
25107 ("invalid warning switch character " & Chr,
25113 ("invalid wide character in warning switch ",
25122 -- Two or more arguments (must be two)
25125 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
25126 Check_Arg_Count (2);
25134 E_Id := Get_Pragma_Arg (Arg2);
25137 -- In the expansion of an inlined body, a reference to
25138 -- the formal may be wrapped in a conversion if the
25139 -- actual is a conversion. Retrieve the real entity name.
25141 if (In_Instance_Body or In_Inlined_Body)
25142 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
25144 E_Id := Expression (E_Id);
25147 -- Entity name case
25149 if Is_Entity_Name (E_Id) then
25150 E := Entity (E_Id);
25157 (E, (Chars (Get_Pragma_Arg (Arg1)) =
25160 -- Suppress elaboration warnings if the entity
25161 -- denotes an elaboration target.
25163 if Is_Elaboration_Target (E) then
25164 Set_Is_Elaboration_Warnings_OK_Id (E, False);
25167 -- For OFF case, make entry in warnings off
25168 -- pragma table for later processing. But we do
25169 -- not do that within an instance, since these
25170 -- warnings are about what is needed in the
25171 -- template, not an instance of it.
25173 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
25174 and then Warn_On_Warnings_Off
25175 and then not In_Instance
25177 Warnings_Off_Pragmas.Append ((N, E, Reason));
25180 if Is_Enumeration_Type (E) then
25184 Lit := First_Literal (E);
25185 while Present (Lit) loop
25186 Set_Warnings_Off (Lit);
25187 Next_Literal (Lit);
25192 exit when No (Homonym (E));
25197 -- Error if not entity or static string expression case
25199 elsif not Is_Static_String_Expression (Arg2) then
25201 ("second argument of pragma% must be entity name "
25202 & "or static string expression", Arg2);
25204 -- Static string expression case
25207 -- Note on configuration pragma case: If this is a
25208 -- configuration pragma, then for an OFF pragma, we
25209 -- just set Config True in the call, which is all
25210 -- that needs to be done. For the case of ON, this
25211 -- is normally an error, unless it is canceling the
25212 -- effect of a previous OFF pragma in the same file.
25213 -- In any other case, an error will be signalled (ON
25214 -- with no matching OFF).
25216 -- Note: We set Used if we are inside a generic to
25217 -- disable the test that the non-config case actually
25218 -- cancels a warning. That's because we can't be sure
25219 -- there isn't an instantiation in some other unit
25220 -- where a warning is suppressed.
25222 -- We could do a little better here by checking if the
25223 -- generic unit we are inside is public, but for now
25224 -- we don't bother with that refinement.
25227 Message : constant String :=
25228 Acquire_Warning_Match_String
25229 (Expr_Value_S (Get_Pragma_Arg (Arg2)));
25231 if Chars (Argx) = Name_Off then
25232 Set_Specific_Warning_Off
25233 (Loc, Message, Reason,
25234 Config => Is_Configuration_Pragma,
25235 Used => Inside_A_Generic or else In_Instance);
25237 elsif Chars (Argx) = Name_On then
25238 Set_Specific_Warning_On (Loc, Message, Err);
25242 ("??pragma Warnings On with no matching "
25243 & "Warnings Off", Loc);
25253 -------------------
25254 -- Weak_External --
25255 -------------------
25257 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
25259 when Pragma_Weak_External => Weak_External : declare
25264 Check_Arg_Count (1);
25265 Check_Optional_Identifier (Arg1, Name_Entity);
25266 Check_Arg_Is_Library_Level_Local_Name (Arg1);
25267 Ent := Entity (Get_Pragma_Arg (Arg1));
25269 if Rep_Item_Too_Early (Ent, N) then
25272 Ent := Underlying_Type (Ent);
25275 -- The pragma applies to entities with addresses
25277 if Is_Type (Ent) then
25278 Error_Pragma ("pragma applies to objects and subprograms");
25281 -- The only processing required is to link this item on to the
25282 -- list of rep items for the given entity. This is accomplished
25283 -- by the call to Rep_Item_Too_Late (when no error is detected
25284 -- and False is returned).
25286 if Rep_Item_Too_Late (Ent, N) then
25289 Set_Has_Gigi_Rep_Item (Ent);
25293 -----------------------------
25294 -- Wide_Character_Encoding --
25295 -----------------------------
25297 -- pragma Wide_Character_Encoding (IDENTIFIER);
25299 when Pragma_Wide_Character_Encoding =>
25302 -- Nothing to do, handled in parser. Note that we do not enforce
25303 -- configuration pragma placement, this pragma can appear at any
25304 -- place in the source, allowing mixed encodings within a single
25309 --------------------
25310 -- Unknown_Pragma --
25311 --------------------
25313 -- Should be impossible, since the case of an unknown pragma is
25314 -- separately processed before the case statement is entered.
25316 when Unknown_Pragma =>
25317 raise Program_Error;
25320 -- AI05-0144: detect dangerous order dependence. Disabled for now,
25321 -- until AI is formally approved.
25323 -- Check_Order_Dependence;
25326 when Pragma_Exit => null;
25327 end Analyze_Pragma;
25329 ---------------------------------------------
25330 -- Analyze_Pre_Post_Condition_In_Decl_Part --
25331 ---------------------------------------------
25333 -- WARNING: This routine manages Ghost regions. Return statements must be
25334 -- replaced by gotos which jump to the end of the routine and restore the
25337 procedure Analyze_Pre_Post_Condition_In_Decl_Part
25339 Freeze_Id : Entity_Id := Empty)
25341 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
25342 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
25344 Disp_Typ : Entity_Id;
25345 -- The dispatching type of the subprogram subject to the pre- or
25348 function Check_References (Nod : Node_Id) return Traverse_Result;
25349 -- Check that expression Nod does not mention non-primitives of the
25350 -- type, global objects of the type, or other illegalities described
25351 -- and implied by AI12-0113.
25353 ----------------------
25354 -- Check_References --
25355 ----------------------
25357 function Check_References (Nod : Node_Id) return Traverse_Result is
25359 if Nkind (Nod) = N_Function_Call
25360 and then Is_Entity_Name (Name (Nod))
25363 Func : constant Entity_Id := Entity (Name (Nod));
25367 -- An operation of the type must be a primitive
25369 if No (Find_Dispatching_Type (Func)) then
25370 Form := First_Formal (Func);
25371 while Present (Form) loop
25372 if Etype (Form) = Disp_Typ then
25374 ("operation in class-wide condition must be "
25375 & "primitive of &", Nod, Disp_Typ);
25378 Next_Formal (Form);
25381 -- A return object of the type is illegal as well
25383 if Etype (Func) = Disp_Typ
25384 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
25387 ("operation in class-wide condition must be primitive "
25388 & "of &", Nod, Disp_Typ);
25391 -- Otherwise we have a call to an overridden primitive, and we
25392 -- will create a common class-wide clone for the body of
25393 -- original operation and its eventual inherited versions. If
25394 -- the original operation dispatches on result it is never
25395 -- inherited and there is no need for a clone. There is not
25396 -- need for a clone either in GNATprove mode, as cases that
25397 -- would require it are rejected (when an inherited primitive
25398 -- calls an overridden operation in a class-wide contract), and
25399 -- the clone would make proof impossible in some cases.
25401 elsif not Is_Abstract_Subprogram (Spec_Id)
25402 and then No (Class_Wide_Clone (Spec_Id))
25403 and then not Has_Controlling_Result (Spec_Id)
25404 and then not GNATprove_Mode
25406 Build_Class_Wide_Clone_Decl (Spec_Id);
25410 elsif Is_Entity_Name (Nod)
25412 (Etype (Nod) = Disp_Typ
25413 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
25414 and then Ekind_In (Entity (Nod), E_Constant, E_Variable)
25417 ("object in class-wide condition must be formal of type &",
25420 elsif Nkind (Nod) = N_Explicit_Dereference
25421 and then (Etype (Nod) = Disp_Typ
25422 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
25423 and then (not Is_Entity_Name (Prefix (Nod))
25424 or else not Is_Formal (Entity (Prefix (Nod))))
25427 ("operation in class-wide condition must be primitive of &",
25432 end Check_References;
25434 procedure Check_Class_Wide_Condition is
25435 new Traverse_Proc (Check_References);
25439 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
25441 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
25442 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
25443 -- Save the Ghost-related attributes to restore on exit
25446 Restore_Scope : Boolean := False;
25448 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
25451 -- Do not analyze the pragma multiple times
25453 if Is_Analyzed_Pragma (N) then
25457 -- Set the Ghost mode in effect from the pragma. Due to the delayed
25458 -- analysis of the pragma, the Ghost mode at point of declaration and
25459 -- point of analysis may not necessarily be the same. Use the mode in
25460 -- effect at the point of declaration.
25462 Set_Ghost_Mode (N);
25464 -- Ensure that the subprogram and its formals are visible when analyzing
25465 -- the expression of the pragma.
25467 if not In_Open_Scopes (Spec_Id) then
25468 Restore_Scope := True;
25469 Push_Scope (Spec_Id);
25471 if Is_Generic_Subprogram (Spec_Id) then
25472 Install_Generic_Formals (Spec_Id);
25474 Install_Formals (Spec_Id);
25478 Errors := Serious_Errors_Detected;
25479 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
25481 -- Emit a clarification message when the expression contains at least
25482 -- one undefined reference, possibly due to contract freezing.
25484 if Errors /= Serious_Errors_Detected
25485 and then Present (Freeze_Id)
25486 and then Has_Undefined_Reference (Expr)
25488 Contract_Freeze_Error (Spec_Id, Freeze_Id);
25491 if Class_Present (N) then
25493 -- Verify that a class-wide condition is legal, i.e. the operation is
25494 -- a primitive of a tagged type. Note that a generic subprogram is
25495 -- not a primitive operation.
25497 Disp_Typ := Find_Dispatching_Type (Spec_Id);
25499 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
25500 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
25502 if From_Aspect_Specification (N) then
25504 ("aspect % can only be specified for a primitive operation "
25505 & "of a tagged type", Corresponding_Aspect (N));
25507 -- The pragma is a source construct
25511 ("pragma % can only be specified for a primitive operation "
25512 & "of a tagged type", N);
25515 -- Remaining semantic checks require a full tree traversal
25518 Check_Class_Wide_Condition (Expr);
25523 if Restore_Scope then
25527 -- If analysis of the condition indicates that a class-wide clone
25528 -- has been created, build and analyze its declaration.
25530 if Is_Subprogram (Spec_Id)
25531 and then Present (Class_Wide_Clone (Spec_Id))
25533 Analyze (Unit_Declaration_Node (Class_Wide_Clone (Spec_Id)));
25536 -- Currently it is not possible to inline pre/postconditions on a
25537 -- subprogram subject to pragma Inline_Always.
25539 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
25540 Set_Is_Analyzed_Pragma (N);
25542 Restore_Ghost_Region (Saved_GM, Saved_IGR);
25543 end Analyze_Pre_Post_Condition_In_Decl_Part;
25545 ------------------------------------------
25546 -- Analyze_Refined_Depends_In_Decl_Part --
25547 ------------------------------------------
25549 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
25550 procedure Check_Dependency_Clause
25551 (Spec_Id : Entity_Id;
25552 Dep_Clause : Node_Id;
25553 Dep_States : Elist_Id;
25554 Refinements : List_Id;
25555 Matched_Items : in out Elist_Id);
25556 -- Try to match a single dependency clause Dep_Clause against one or
25557 -- more refinement clauses found in list Refinements. Each successful
25558 -- match eliminates at least one refinement clause from Refinements.
25559 -- Spec_Id denotes the entity of the related subprogram. Dep_States
25560 -- denotes the entities of all abstract states which appear in pragma
25561 -- Depends. Matched_Items contains the entities of all successfully
25562 -- matched items found in pragma Depends.
25564 procedure Check_Output_States
25565 (Spec_Inputs : Elist_Id;
25566 Spec_Outputs : Elist_Id;
25567 Body_Inputs : Elist_Id;
25568 Body_Outputs : Elist_Id);
25569 -- Determine whether pragma Depends contains an output state with a
25570 -- visible refinement and if so, ensure that pragma Refined_Depends
25571 -- mentions all its constituents as outputs. Spec_Inputs and
25572 -- Spec_Outputs denote the inputs and outputs of the subprogram spec
25573 -- synthesized from pragma Depends. Body_Inputs and Body_Outputs denote
25574 -- the inputs and outputs of the subprogram body synthesized from pragma
25575 -- Refined_Depends.
25577 function Collect_States (Clauses : List_Id) return Elist_Id;
25578 -- Given a normalized list of dependencies obtained from calling
25579 -- Normalize_Clauses, return a list containing the entities of all
25580 -- states appearing in dependencies. It helps in checking refinements
25581 -- involving a state and a corresponding constituent which is not a
25582 -- direct constituent of the state.
25584 procedure Normalize_Clauses (Clauses : List_Id);
25585 -- Given a list of dependence or refinement clauses Clauses, normalize
25586 -- each clause by creating multiple dependencies with exactly one input
25589 procedure Remove_Extra_Clauses
25590 (Clauses : List_Id;
25591 Matched_Items : Elist_Id);
25592 -- Given a list of refinement clauses Clauses, remove all clauses whose
25593 -- inputs and/or outputs have been previously matched. See the body for
25594 -- all special cases. Matched_Items contains the entities of all matched
25595 -- items found in pragma Depends.
25597 procedure Report_Extra_Clauses (Clauses : List_Id);
25598 -- Emit an error for each extra clause found in list Clauses
25600 -----------------------------
25601 -- Check_Dependency_Clause --
25602 -----------------------------
25604 procedure Check_Dependency_Clause
25605 (Spec_Id : Entity_Id;
25606 Dep_Clause : Node_Id;
25607 Dep_States : Elist_Id;
25608 Refinements : List_Id;
25609 Matched_Items : in out Elist_Id)
25611 Dep_Input : constant Node_Id := Expression (Dep_Clause);
25612 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
25614 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
25615 -- Determine whether dependency item Dep_Item has been matched in a
25616 -- previous clause.
25618 function Is_In_Out_State_Clause return Boolean;
25619 -- Determine whether dependence clause Dep_Clause denotes an abstract
25620 -- state that depends on itself (State => State).
25622 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
25623 -- Determine whether item Item denotes an abstract state with visible
25624 -- null refinement.
25626 procedure Match_Items
25627 (Dep_Item : Node_Id;
25628 Ref_Item : Node_Id;
25629 Matched : out Boolean);
25630 -- Try to match dependence item Dep_Item against refinement item
25631 -- Ref_Item. To match against a possible null refinement (see 2, 9),
25632 -- set Ref_Item to Empty. Flag Matched is set to True when one of
25633 -- the following conformance scenarios is in effect:
25634 -- 1) Both items denote null
25635 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
25636 -- 3) Both items denote attribute 'Result
25637 -- 4) Both items denote the same object
25638 -- 5) Both items denote the same formal parameter
25639 -- 6) Both items denote the same current instance of a type
25640 -- 7) Both items denote the same discriminant
25641 -- 8) Dep_Item is an abstract state with visible null refinement
25642 -- and Ref_Item denotes null.
25643 -- 9) Dep_Item is an abstract state with visible null refinement
25644 -- and Ref_Item is Empty (special case).
25645 -- 10) Dep_Item is an abstract state with full or partial visible
25646 -- non-null refinement and Ref_Item denotes one of its
25648 -- 11) Dep_Item is an abstract state without a full visible
25649 -- refinement and Ref_Item denotes the same state.
25650 -- When scenario 10 is in effect, the entity of the abstract state
25651 -- denoted by Dep_Item is added to list Refined_States.
25653 procedure Record_Item (Item_Id : Entity_Id);
25654 -- Store the entity of an item denoted by Item_Id in Matched_Items
25656 ------------------------
25657 -- Is_Already_Matched --
25658 ------------------------
25660 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean is
25661 Item_Id : Entity_Id := Empty;
25664 -- When the dependency item denotes attribute 'Result, check for
25665 -- the entity of the related subprogram.
25667 if Is_Attribute_Result (Dep_Item) then
25668 Item_Id := Spec_Id;
25670 elsif Is_Entity_Name (Dep_Item) then
25671 Item_Id := Available_View (Entity_Of (Dep_Item));
25675 Present (Item_Id) and then Contains (Matched_Items, Item_Id);
25676 end Is_Already_Matched;
25678 ----------------------------
25679 -- Is_In_Out_State_Clause --
25680 ----------------------------
25682 function Is_In_Out_State_Clause return Boolean is
25683 Dep_Input_Id : Entity_Id;
25684 Dep_Output_Id : Entity_Id;
25687 -- Detect the following clause:
25690 if Is_Entity_Name (Dep_Input)
25691 and then Is_Entity_Name (Dep_Output)
25693 -- Handle abstract views generated for limited with clauses
25695 Dep_Input_Id := Available_View (Entity_Of (Dep_Input));
25696 Dep_Output_Id := Available_View (Entity_Of (Dep_Output));
25699 Ekind (Dep_Input_Id) = E_Abstract_State
25700 and then Dep_Input_Id = Dep_Output_Id;
25704 end Is_In_Out_State_Clause;
25706 ---------------------------
25707 -- Is_Null_Refined_State --
25708 ---------------------------
25710 function Is_Null_Refined_State (Item : Node_Id) return Boolean is
25711 Item_Id : Entity_Id;
25714 if Is_Entity_Name (Item) then
25716 -- Handle abstract views generated for limited with clauses
25718 Item_Id := Available_View (Entity_Of (Item));
25721 Ekind (Item_Id) = E_Abstract_State
25722 and then Has_Null_Visible_Refinement (Item_Id);
25726 end Is_Null_Refined_State;
25732 procedure Match_Items
25733 (Dep_Item : Node_Id;
25734 Ref_Item : Node_Id;
25735 Matched : out Boolean)
25737 Dep_Item_Id : Entity_Id;
25738 Ref_Item_Id : Entity_Id;
25741 -- Assume that the two items do not match
25745 -- A null matches null or Empty (special case)
25747 if Nkind (Dep_Item) = N_Null
25748 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
25752 -- Attribute 'Result matches attribute 'Result
25754 elsif Is_Attribute_Result (Dep_Item)
25755 and then Is_Attribute_Result (Ref_Item)
25757 -- Put the entity of the related function on the list of
25758 -- matched items because attribute 'Result does not carry
25759 -- an entity similar to states and constituents.
25761 Record_Item (Spec_Id);
25764 -- Abstract states, current instances of concurrent types,
25765 -- discriminants, formal parameters and objects.
25767 elsif Is_Entity_Name (Dep_Item) then
25769 -- Handle abstract views generated for limited with clauses
25771 Dep_Item_Id := Available_View (Entity_Of (Dep_Item));
25773 if Ekind (Dep_Item_Id) = E_Abstract_State then
25775 -- An abstract state with visible null refinement matches
25776 -- null or Empty (special case).
25778 if Has_Null_Visible_Refinement (Dep_Item_Id)
25779 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
25781 Record_Item (Dep_Item_Id);
25784 -- An abstract state with visible non-null refinement
25785 -- matches one of its constituents, or itself for an
25786 -- abstract state with partial visible refinement.
25788 elsif Has_Non_Null_Visible_Refinement (Dep_Item_Id) then
25789 if Is_Entity_Name (Ref_Item) then
25790 Ref_Item_Id := Entity_Of (Ref_Item);
25792 if Ekind_In (Ref_Item_Id, E_Abstract_State,
25795 and then Present (Encapsulating_State (Ref_Item_Id))
25796 and then Find_Encapsulating_State
25797 (Dep_States, Ref_Item_Id) = Dep_Item_Id
25799 Record_Item (Dep_Item_Id);
25802 elsif not Has_Visible_Refinement (Dep_Item_Id)
25803 and then Ref_Item_Id = Dep_Item_Id
25805 Record_Item (Dep_Item_Id);
25810 -- An abstract state without a visible refinement matches
25813 elsif Is_Entity_Name (Ref_Item)
25814 and then Entity_Of (Ref_Item) = Dep_Item_Id
25816 Record_Item (Dep_Item_Id);
25820 -- A current instance of a concurrent type, discriminant,
25821 -- formal parameter or an object matches itself.
25823 elsif Is_Entity_Name (Ref_Item)
25824 and then Entity_Of (Ref_Item) = Dep_Item_Id
25826 Record_Item (Dep_Item_Id);
25836 procedure Record_Item (Item_Id : Entity_Id) is
25838 if No (Matched_Items) then
25839 Matched_Items := New_Elmt_List;
25842 Append_Unique_Elmt (Item_Id, Matched_Items);
25847 Clause_Matched : Boolean := False;
25848 Dummy : Boolean := False;
25849 Inputs_Match : Boolean;
25850 Next_Ref_Clause : Node_Id;
25851 Outputs_Match : Boolean;
25852 Ref_Clause : Node_Id;
25853 Ref_Input : Node_Id;
25854 Ref_Output : Node_Id;
25856 -- Start of processing for Check_Dependency_Clause
25859 -- Do not perform this check in an instance because it was already
25860 -- performed successfully in the generic template.
25862 if In_Instance then
25866 -- Examine all refinement clauses and compare them against the
25867 -- dependence clause.
25869 Ref_Clause := First (Refinements);
25870 while Present (Ref_Clause) loop
25871 Next_Ref_Clause := Next (Ref_Clause);
25873 -- Obtain the attributes of the current refinement clause
25875 Ref_Input := Expression (Ref_Clause);
25876 Ref_Output := First (Choices (Ref_Clause));
25878 -- The current refinement clause matches the dependence clause
25879 -- when both outputs match and both inputs match. See routine
25880 -- Match_Items for all possible conformance scenarios.
25882 -- Depends Dep_Output => Dep_Input
25886 -- Refined_Depends Ref_Output => Ref_Input
25889 (Dep_Item => Dep_Input,
25890 Ref_Item => Ref_Input,
25891 Matched => Inputs_Match);
25894 (Dep_Item => Dep_Output,
25895 Ref_Item => Ref_Output,
25896 Matched => Outputs_Match);
25898 -- An In_Out state clause may be matched against a refinement with
25899 -- a null input or null output as long as the non-null side of the
25900 -- relation contains a valid constituent of the In_Out_State.
25902 if Is_In_Out_State_Clause then
25904 -- Depends => (State => State)
25905 -- Refined_Depends => (null => Constit) -- OK
25908 and then not Outputs_Match
25909 and then Nkind (Ref_Output) = N_Null
25911 Outputs_Match := True;
25914 -- Depends => (State => State)
25915 -- Refined_Depends => (Constit => null) -- OK
25917 if not Inputs_Match
25918 and then Outputs_Match
25919 and then Nkind (Ref_Input) = N_Null
25921 Inputs_Match := True;
25925 -- The current refinement clause is legally constructed following
25926 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
25927 -- the pool of candidates. The seach continues because a single
25928 -- dependence clause may have multiple matching refinements.
25930 if Inputs_Match and Outputs_Match then
25931 Clause_Matched := True;
25932 Remove (Ref_Clause);
25935 Ref_Clause := Next_Ref_Clause;
25938 -- Depending on the order or composition of refinement clauses, an
25939 -- In_Out state clause may not be directly refinable.
25941 -- Refined_State => (State => (Constit_1, Constit_2))
25942 -- Depends => ((Output, State) => (Input, State))
25943 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
25945 -- Matching normalized clause (State => State) fails because there is
25946 -- no direct refinement capable of satisfying this relation. Another
25947 -- similar case arises when clauses (Constit_1 => Input) and (Output
25948 -- => Constit_2) are matched first, leaving no candidates for clause
25949 -- (State => State). Both scenarios are legal as long as one of the
25950 -- previous clauses mentioned a valid constituent of State.
25952 if not Clause_Matched
25953 and then Is_In_Out_State_Clause
25954 and then Is_Already_Matched (Dep_Input)
25956 Clause_Matched := True;
25959 -- A clause where the input is an abstract state with visible null
25960 -- refinement or a 'Result attribute is implicitly matched when the
25961 -- output has already been matched in a previous clause.
25963 -- Refined_State => (State => null)
25964 -- Depends => (Output => State) -- implicitly OK
25965 -- Refined_Depends => (Output => ...)
25966 -- Depends => (...'Result => State) -- implicitly OK
25967 -- Refined_Depends => (...'Result => ...)
25969 if not Clause_Matched
25970 and then Is_Null_Refined_State (Dep_Input)
25971 and then Is_Already_Matched (Dep_Output)
25973 Clause_Matched := True;
25976 -- A clause where the output is an abstract state with visible null
25977 -- refinement is implicitly matched when the input has already been
25978 -- matched in a previous clause.
25980 -- Refined_State => (State => null)
25981 -- Depends => (State => Input) -- implicitly OK
25982 -- Refined_Depends => (... => Input)
25984 if not Clause_Matched
25985 and then Is_Null_Refined_State (Dep_Output)
25986 and then Is_Already_Matched (Dep_Input)
25988 Clause_Matched := True;
25991 -- At this point either all refinement clauses have been examined or
25992 -- pragma Refined_Depends contains a solitary null. Only an abstract
25993 -- state with null refinement can possibly match these cases.
25995 -- Refined_State => (State => null)
25996 -- Depends => (State => null)
25997 -- Refined_Depends => null -- OK
25999 if not Clause_Matched then
26001 (Dep_Item => Dep_Input,
26003 Matched => Inputs_Match);
26006 (Dep_Item => Dep_Output,
26008 Matched => Outputs_Match);
26010 Clause_Matched := Inputs_Match and Outputs_Match;
26013 -- If the contents of Refined_Depends are legal, then the current
26014 -- dependence clause should be satisfied either by an explicit match
26015 -- or by one of the special cases.
26017 if not Clause_Matched then
26019 (Fix_Msg (Spec_Id, "dependence clause of subprogram & has no "
26020 & "matching refinement in body"), Dep_Clause, Spec_Id);
26022 end Check_Dependency_Clause;
26024 -------------------------
26025 -- Check_Output_States --
26026 -------------------------
26028 procedure Check_Output_States
26029 (Spec_Inputs : Elist_Id;
26030 Spec_Outputs : Elist_Id;
26031 Body_Inputs : Elist_Id;
26032 Body_Outputs : Elist_Id)
26034 procedure Check_Constituent_Usage (State_Id : Entity_Id);
26035 -- Determine whether all constituents of state State_Id with full
26036 -- visible refinement are used as outputs in pragma Refined_Depends.
26037 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
26039 -----------------------------
26040 -- Check_Constituent_Usage --
26041 -----------------------------
26043 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
26044 Constits : constant Elist_Id :=
26045 Partial_Refinement_Constituents (State_Id);
26046 Constit_Elmt : Elmt_Id;
26047 Constit_Id : Entity_Id;
26048 Only_Partial : constant Boolean :=
26049 not Has_Visible_Refinement (State_Id);
26050 Posted : Boolean := False;
26053 if Present (Constits) then
26054 Constit_Elmt := First_Elmt (Constits);
26055 while Present (Constit_Elmt) loop
26056 Constit_Id := Node (Constit_Elmt);
26058 -- Issue an error when a constituent of State_Id is used,
26059 -- and State_Id has only partial visible refinement
26060 -- (SPARK RM 7.2.4(3d)).
26062 if Only_Partial then
26063 if (Present (Body_Inputs)
26064 and then Appears_In (Body_Inputs, Constit_Id))
26066 (Present (Body_Outputs)
26067 and then Appears_In (Body_Outputs, Constit_Id))
26069 Error_Msg_Name_1 := Chars (State_Id);
26071 ("constituent & of state % cannot be used in "
26072 & "dependence refinement", N, Constit_Id);
26073 Error_Msg_Name_1 := Chars (State_Id);
26074 SPARK_Msg_N ("\use state % instead", N);
26077 -- The constituent acts as an input (SPARK RM 7.2.5(3))
26079 elsif Present (Body_Inputs)
26080 and then Appears_In (Body_Inputs, Constit_Id)
26082 Error_Msg_Name_1 := Chars (State_Id);
26084 ("constituent & of state % must act as output in "
26085 & "dependence refinement", N, Constit_Id);
26087 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
26089 elsif No (Body_Outputs)
26090 or else not Appears_In (Body_Outputs, Constit_Id)
26095 ("output state & must be replaced by all its "
26096 & "constituents in dependence refinement",
26101 ("\constituent & is missing in output list",
26105 Next_Elmt (Constit_Elmt);
26108 end Check_Constituent_Usage;
26113 Item_Elmt : Elmt_Id;
26114 Item_Id : Entity_Id;
26116 -- Start of processing for Check_Output_States
26119 -- Do not perform this check in an instance because it was already
26120 -- performed successfully in the generic template.
26122 if In_Instance then
26125 -- Inspect the outputs of pragma Depends looking for a state with a
26126 -- visible refinement.
26128 elsif Present (Spec_Outputs) then
26129 Item_Elmt := First_Elmt (Spec_Outputs);
26130 while Present (Item_Elmt) loop
26131 Item := Node (Item_Elmt);
26133 -- Deal with the mixed nature of the input and output lists
26135 if Nkind (Item) = N_Defining_Identifier then
26138 Item_Id := Available_View (Entity_Of (Item));
26141 if Ekind (Item_Id) = E_Abstract_State then
26143 -- The state acts as an input-output, skip it
26145 if Present (Spec_Inputs)
26146 and then Appears_In (Spec_Inputs, Item_Id)
26150 -- Ensure that all of the constituents are utilized as
26151 -- outputs in pragma Refined_Depends.
26153 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
26154 Check_Constituent_Usage (Item_Id);
26158 Next_Elmt (Item_Elmt);
26161 end Check_Output_States;
26163 --------------------
26164 -- Collect_States --
26165 --------------------
26167 function Collect_States (Clauses : List_Id) return Elist_Id is
26168 procedure Collect_State
26170 States : in out Elist_Id);
26171 -- Add the entity of Item to list States when it denotes to a state
26173 -------------------
26174 -- Collect_State --
26175 -------------------
26177 procedure Collect_State
26179 States : in out Elist_Id)
26184 if Is_Entity_Name (Item) then
26185 Id := Entity_Of (Item);
26187 if Ekind (Id) = E_Abstract_State then
26188 if No (States) then
26189 States := New_Elmt_List;
26192 Append_Unique_Elmt (Id, States);
26202 States : Elist_Id := No_Elist;
26204 -- Start of processing for Collect_States
26207 Clause := First (Clauses);
26208 while Present (Clause) loop
26209 Input := Expression (Clause);
26210 Output := First (Choices (Clause));
26212 Collect_State (Input, States);
26213 Collect_State (Output, States);
26219 end Collect_States;
26221 -----------------------
26222 -- Normalize_Clauses --
26223 -----------------------
26225 procedure Normalize_Clauses (Clauses : List_Id) is
26226 procedure Normalize_Inputs (Clause : Node_Id);
26227 -- Normalize clause Clause by creating multiple clauses for each
26228 -- input item of Clause. It is assumed that Clause has exactly one
26229 -- output. The transformation is as follows:
26231 -- Output => (Input_1, Input_2) -- original
26233 -- Output => Input_1 -- normalizations
26234 -- Output => Input_2
26236 procedure Normalize_Outputs (Clause : Node_Id);
26237 -- Normalize clause Clause by creating multiple clause for each
26238 -- output item of Clause. The transformation is as follows:
26240 -- (Output_1, Output_2) => Input -- original
26242 -- Output_1 => Input -- normalization
26243 -- Output_2 => Input
26245 ----------------------
26246 -- Normalize_Inputs --
26247 ----------------------
26249 procedure Normalize_Inputs (Clause : Node_Id) is
26250 Inputs : constant Node_Id := Expression (Clause);
26251 Loc : constant Source_Ptr := Sloc (Clause);
26252 Output : constant List_Id := Choices (Clause);
26253 Last_Input : Node_Id;
26255 New_Clause : Node_Id;
26256 Next_Input : Node_Id;
26259 -- Normalization is performed only when the original clause has
26260 -- more than one input. Multiple inputs appear as an aggregate.
26262 if Nkind (Inputs) = N_Aggregate then
26263 Last_Input := Last (Expressions (Inputs));
26265 -- Create a new clause for each input
26267 Input := First (Expressions (Inputs));
26268 while Present (Input) loop
26269 Next_Input := Next (Input);
26271 -- Unhook the current input from the original input list
26272 -- because it will be relocated to a new clause.
26276 -- Special processing for the last input. At this point the
26277 -- original aggregate has been stripped down to one element.
26278 -- Replace the aggregate by the element itself.
26280 if Input = Last_Input then
26281 Rewrite (Inputs, Input);
26283 -- Generate a clause of the form:
26288 Make_Component_Association (Loc,
26289 Choices => New_Copy_List_Tree (Output),
26290 Expression => Input);
26292 -- The new clause contains replicated content that has
26293 -- already been analyzed, mark the clause as analyzed.
26295 Set_Analyzed (New_Clause);
26296 Insert_After (Clause, New_Clause);
26299 Input := Next_Input;
26302 end Normalize_Inputs;
26304 -----------------------
26305 -- Normalize_Outputs --
26306 -----------------------
26308 procedure Normalize_Outputs (Clause : Node_Id) is
26309 Inputs : constant Node_Id := Expression (Clause);
26310 Loc : constant Source_Ptr := Sloc (Clause);
26311 Outputs : constant Node_Id := First (Choices (Clause));
26312 Last_Output : Node_Id;
26313 New_Clause : Node_Id;
26314 Next_Output : Node_Id;
26318 -- Multiple outputs appear as an aggregate. Nothing to do when
26319 -- the clause has exactly one output.
26321 if Nkind (Outputs) = N_Aggregate then
26322 Last_Output := Last (Expressions (Outputs));
26324 -- Create a clause for each output. Note that each time a new
26325 -- clause is created, the original output list slowly shrinks
26326 -- until there is one item left.
26328 Output := First (Expressions (Outputs));
26329 while Present (Output) loop
26330 Next_Output := Next (Output);
26332 -- Unhook the output from the original output list as it
26333 -- will be relocated to a new clause.
26337 -- Special processing for the last output. At this point
26338 -- the original aggregate has been stripped down to one
26339 -- element. Replace the aggregate by the element itself.
26341 if Output = Last_Output then
26342 Rewrite (Outputs, Output);
26345 -- Generate a clause of the form:
26346 -- (Output => Inputs)
26349 Make_Component_Association (Loc,
26350 Choices => New_List (Output),
26351 Expression => New_Copy_Tree (Inputs));
26353 -- The new clause contains replicated content that has
26354 -- already been analyzed. There is not need to reanalyze
26357 Set_Analyzed (New_Clause);
26358 Insert_After (Clause, New_Clause);
26361 Output := Next_Output;
26364 end Normalize_Outputs;
26370 -- Start of processing for Normalize_Clauses
26373 Clause := First (Clauses);
26374 while Present (Clause) loop
26375 Normalize_Outputs (Clause);
26379 Clause := First (Clauses);
26380 while Present (Clause) loop
26381 Normalize_Inputs (Clause);
26384 end Normalize_Clauses;
26386 --------------------------
26387 -- Remove_Extra_Clauses --
26388 --------------------------
26390 procedure Remove_Extra_Clauses
26391 (Clauses : List_Id;
26392 Matched_Items : Elist_Id)
26396 Input_Id : Entity_Id;
26397 Next_Clause : Node_Id;
26399 State_Id : Entity_Id;
26402 Clause := First (Clauses);
26403 while Present (Clause) loop
26404 Next_Clause := Next (Clause);
26406 Input := Expression (Clause);
26407 Output := First (Choices (Clause));
26409 -- Recognize a clause of the form
26413 -- where Input is a constituent of a state which was already
26414 -- successfully matched. This clause must be removed because it
26415 -- simply indicates that some of the constituents of the state
26418 -- Refined_State => (State => (Constit_1, Constit_2))
26419 -- Depends => (Output => State)
26420 -- Refined_Depends => ((Output => Constit_1), -- State matched
26421 -- (null => Constit_2)) -- OK
26423 if Nkind (Output) = N_Null and then Is_Entity_Name (Input) then
26425 -- Handle abstract views generated for limited with clauses
26427 Input_Id := Available_View (Entity_Of (Input));
26429 -- The input must be a constituent of a state
26431 if Ekind_In (Input_Id, E_Abstract_State,
26434 and then Present (Encapsulating_State (Input_Id))
26436 State_Id := Encapsulating_State (Input_Id);
26438 -- The state must have a non-null visible refinement and be
26439 -- matched in a previous clause.
26441 if Has_Non_Null_Visible_Refinement (State_Id)
26442 and then Contains (Matched_Items, State_Id)
26448 -- Recognize a clause of the form
26452 -- where Output is an arbitrary item. This clause must be removed
26453 -- because a null input legitimately matches anything.
26455 elsif Nkind (Input) = N_Null then
26459 Clause := Next_Clause;
26461 end Remove_Extra_Clauses;
26463 --------------------------
26464 -- Report_Extra_Clauses --
26465 --------------------------
26467 procedure Report_Extra_Clauses (Clauses : List_Id) is
26471 -- Do not perform this check in an instance because it was already
26472 -- performed successfully in the generic template.
26474 if In_Instance then
26477 elsif Present (Clauses) then
26478 Clause := First (Clauses);
26479 while Present (Clause) loop
26481 ("unmatched or extra clause in dependence refinement",
26487 end Report_Extra_Clauses;
26491 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
26492 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
26493 Errors : constant Nat := Serious_Errors_Detected;
26500 Body_Inputs : Elist_Id := No_Elist;
26501 Body_Outputs : Elist_Id := No_Elist;
26502 -- The inputs and outputs of the subprogram body synthesized from pragma
26503 -- Refined_Depends.
26505 Dependencies : List_Id := No_List;
26507 -- The corresponding Depends pragma along with its clauses
26509 Matched_Items : Elist_Id := No_Elist;
26510 -- A list containing the entities of all successfully matched items
26511 -- found in pragma Depends.
26513 Refinements : List_Id := No_List;
26514 -- The clauses of pragma Refined_Depends
26516 Spec_Id : Entity_Id;
26517 -- The entity of the subprogram subject to pragma Refined_Depends
26519 Spec_Inputs : Elist_Id := No_Elist;
26520 Spec_Outputs : Elist_Id := No_Elist;
26521 -- The inputs and outputs of the subprogram spec synthesized from pragma
26524 States : Elist_Id := No_Elist;
26525 -- A list containing the entities of all states whose constituents
26526 -- appear in pragma Depends.
26528 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
26531 -- Do not analyze the pragma multiple times
26533 if Is_Analyzed_Pragma (N) then
26537 Spec_Id := Unique_Defining_Entity (Body_Decl);
26539 -- Use the anonymous object as the proper spec when Refined_Depends
26540 -- applies to the body of a single task type. The object carries the
26541 -- proper Chars as well as all non-refined versions of pragmas.
26543 if Is_Single_Concurrent_Type (Spec_Id) then
26544 Spec_Id := Anonymous_Object (Spec_Id);
26547 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
26549 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
26550 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
26552 if No (Depends) then
26554 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
26555 & "& lacks aspect or pragma Depends"), N, Spec_Id);
26559 Deps := Expression (Get_Argument (Depends, Spec_Id));
26561 -- A null dependency relation renders the refinement useless because it
26562 -- cannot possibly mention abstract states with visible refinement. Note
26563 -- that the inverse is not true as states may be refined to null
26564 -- (SPARK RM 7.2.5(2)).
26566 if Nkind (Deps) = N_Null then
26568 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
26569 & "depend on abstract state with visible refinement"), N, Spec_Id);
26573 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
26574 -- This ensures that the categorization of all refined dependency items
26575 -- is consistent with their role.
26577 Analyze_Depends_In_Decl_Part (N);
26579 -- Do not match dependencies against refinements if Refined_Depends is
26580 -- illegal to avoid emitting misleading error.
26582 if Serious_Errors_Detected = Errors then
26584 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
26585 -- the inputs and outputs of the subprogram spec and body to verify
26586 -- the use of states with visible refinement and their constituents.
26588 if No (Get_Pragma (Spec_Id, Pragma_Global))
26589 or else No (Get_Pragma (Body_Id, Pragma_Refined_Global))
26591 Collect_Subprogram_Inputs_Outputs
26592 (Subp_Id => Spec_Id,
26593 Synthesize => True,
26594 Subp_Inputs => Spec_Inputs,
26595 Subp_Outputs => Spec_Outputs,
26596 Global_Seen => Dummy);
26598 Collect_Subprogram_Inputs_Outputs
26599 (Subp_Id => Body_Id,
26600 Synthesize => True,
26601 Subp_Inputs => Body_Inputs,
26602 Subp_Outputs => Body_Outputs,
26603 Global_Seen => Dummy);
26605 -- For an output state with a visible refinement, ensure that all
26606 -- constituents appear as outputs in the dependency refinement.
26608 Check_Output_States
26609 (Spec_Inputs => Spec_Inputs,
26610 Spec_Outputs => Spec_Outputs,
26611 Body_Inputs => Body_Inputs,
26612 Body_Outputs => Body_Outputs);
26615 -- Multiple dependency clauses appear as component associations of an
26616 -- aggregate. Note that the clauses are copied because the algorithm
26617 -- modifies them and this should not be visible in Depends.
26619 pragma Assert (Nkind (Deps) = N_Aggregate);
26620 Dependencies := New_Copy_List_Tree (Component_Associations (Deps));
26621 Normalize_Clauses (Dependencies);
26623 -- Gather all states which appear in Depends
26625 States := Collect_States (Dependencies);
26627 Refs := Expression (Get_Argument (N, Spec_Id));
26629 if Nkind (Refs) = N_Null then
26630 Refinements := No_List;
26632 -- Multiple dependency clauses appear as component associations of an
26633 -- aggregate. Note that the clauses are copied because the algorithm
26634 -- modifies them and this should not be visible in Refined_Depends.
26636 else pragma Assert (Nkind (Refs) = N_Aggregate);
26637 Refinements := New_Copy_List_Tree (Component_Associations (Refs));
26638 Normalize_Clauses (Refinements);
26641 -- At this point the clauses of pragmas Depends and Refined_Depends
26642 -- have been normalized into simple dependencies between one output
26643 -- and one input. Examine all clauses of pragma Depends looking for
26644 -- matching clauses in pragma Refined_Depends.
26646 Clause := First (Dependencies);
26647 while Present (Clause) loop
26648 Check_Dependency_Clause
26649 (Spec_Id => Spec_Id,
26650 Dep_Clause => Clause,
26651 Dep_States => States,
26652 Refinements => Refinements,
26653 Matched_Items => Matched_Items);
26658 -- Pragma Refined_Depends may contain multiple clarification clauses
26659 -- which indicate that certain constituents do not influence the data
26660 -- flow in any way. Such clauses must be removed as long as the state
26661 -- has been matched, otherwise they will be incorrectly flagged as
26664 -- Refined_State => (State => (Constit_1, Constit_2))
26665 -- Depends => (Output => State)
26666 -- Refined_Depends => ((Output => Constit_1), -- State matched
26667 -- (null => Constit_2)) -- must be removed
26669 Remove_Extra_Clauses (Refinements, Matched_Items);
26671 if Serious_Errors_Detected = Errors then
26672 Report_Extra_Clauses (Refinements);
26677 Set_Is_Analyzed_Pragma (N);
26678 end Analyze_Refined_Depends_In_Decl_Part;
26680 -----------------------------------------
26681 -- Analyze_Refined_Global_In_Decl_Part --
26682 -----------------------------------------
26684 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is
26686 -- The corresponding Global pragma
26688 Has_In_State : Boolean := False;
26689 Has_In_Out_State : Boolean := False;
26690 Has_Out_State : Boolean := False;
26691 Has_Proof_In_State : Boolean := False;
26692 -- These flags are set when the corresponding Global pragma has a state
26693 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
26696 Has_Null_State : Boolean := False;
26697 -- This flag is set when the corresponding Global pragma has at least
26698 -- one state with a null refinement.
26700 In_Constits : Elist_Id := No_Elist;
26701 In_Out_Constits : Elist_Id := No_Elist;
26702 Out_Constits : Elist_Id := No_Elist;
26703 Proof_In_Constits : Elist_Id := No_Elist;
26704 -- These lists contain the entities of all Input, In_Out, Output and
26705 -- Proof_In constituents that appear in Refined_Global and participate
26706 -- in state refinement.
26708 In_Items : Elist_Id := No_Elist;
26709 In_Out_Items : Elist_Id := No_Elist;
26710 Out_Items : Elist_Id := No_Elist;
26711 Proof_In_Items : Elist_Id := No_Elist;
26712 -- These lists contain the entities of all Input, In_Out, Output and
26713 -- Proof_In items defined in the corresponding Global pragma.
26715 Repeat_Items : Elist_Id := No_Elist;
26716 -- A list of all global items without full visible refinement found
26717 -- in pragma Global. These states should be repeated in the global
26718 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
26719 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
26721 Spec_Id : Entity_Id;
26722 -- The entity of the subprogram subject to pragma Refined_Global
26724 States : Elist_Id := No_Elist;
26725 -- A list of all states with full or partial visible refinement found in
26728 procedure Check_In_Out_States;
26729 -- Determine whether the corresponding Global pragma mentions In_Out
26730 -- states with visible refinement and if so, ensure that one of the
26731 -- following completions apply to the constituents of the state:
26732 -- 1) there is at least one constituent of mode In_Out
26733 -- 2) there is at least one Input and one Output constituent
26734 -- 3) not all constituents are present and one of them is of mode
26736 -- This routine may remove elements from In_Constits, In_Out_Constits,
26737 -- Out_Constits and Proof_In_Constits.
26739 procedure Check_Input_States;
26740 -- Determine whether the corresponding Global pragma mentions Input
26741 -- states with visible refinement and if so, ensure that at least one of
26742 -- its constituents appears as an Input item in Refined_Global.
26743 -- This routine may remove elements from In_Constits, In_Out_Constits,
26744 -- Out_Constits and Proof_In_Constits.
26746 procedure Check_Output_States;
26747 -- Determine whether the corresponding Global pragma mentions Output
26748 -- states with visible refinement and if so, ensure that all of its
26749 -- constituents appear as Output items in Refined_Global.
26750 -- This routine may remove elements from In_Constits, In_Out_Constits,
26751 -- Out_Constits and Proof_In_Constits.
26753 procedure Check_Proof_In_States;
26754 -- Determine whether the corresponding Global pragma mentions Proof_In
26755 -- states with visible refinement and if so, ensure that at least one of
26756 -- its constituents appears as a Proof_In item in Refined_Global.
26757 -- This routine may remove elements from In_Constits, In_Out_Constits,
26758 -- Out_Constits and Proof_In_Constits.
26760 procedure Check_Refined_Global_List
26762 Global_Mode : Name_Id := Name_Input);
26763 -- Verify the legality of a single global list declaration. Global_Mode
26764 -- denotes the current mode in effect.
26766 procedure Collect_Global_Items
26768 Mode : Name_Id := Name_Input);
26769 -- Gather all Input, In_Out, Output and Proof_In items from node List
26770 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
26771 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
26772 -- and Has_Proof_In_State are set when there is at least one abstract
26773 -- state with full or partial visible refinement available in the
26774 -- corresponding mode. Flag Has_Null_State is set when at least state
26775 -- has a null refinement. Mode denotes the current global mode in
26778 function Present_Then_Remove
26780 Item : Entity_Id) return Boolean;
26781 -- Search List for a particular entity Item. If Item has been found,
26782 -- remove it from List. This routine is used to strip lists In_Constits,
26783 -- In_Out_Constits and Out_Constits of valid constituents.
26785 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id);
26786 -- Same as function Present_Then_Remove, but do not report the presence
26787 -- of Item in List.
26789 procedure Report_Extra_Constituents;
26790 -- Emit an error for each constituent found in lists In_Constits,
26791 -- In_Out_Constits and Out_Constits.
26793 procedure Report_Missing_Items;
26794 -- Emit an error for each global item not repeated found in list
26797 -------------------------
26798 -- Check_In_Out_States --
26799 -------------------------
26801 procedure Check_In_Out_States is
26802 procedure Check_Constituent_Usage (State_Id : Entity_Id);
26803 -- Determine whether one of the following coverage scenarios is in
26805 -- 1) there is at least one constituent of mode In_Out or Output
26806 -- 2) there is at least one pair of constituents with modes Input
26807 -- and Output, or Proof_In and Output.
26808 -- 3) there is at least one constituent of mode Output and not all
26809 -- constituents are present.
26810 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
26812 -----------------------------
26813 -- Check_Constituent_Usage --
26814 -----------------------------
26816 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
26817 Constits : constant Elist_Id :=
26818 Partial_Refinement_Constituents (State_Id);
26819 Constit_Elmt : Elmt_Id;
26820 Constit_Id : Entity_Id;
26821 Has_Missing : Boolean := False;
26822 In_Out_Seen : Boolean := False;
26823 Input_Seen : Boolean := False;
26824 Output_Seen : Boolean := False;
26825 Proof_In_Seen : Boolean := False;
26828 -- Process all the constituents of the state and note their modes
26829 -- within the global refinement.
26831 if Present (Constits) then
26832 Constit_Elmt := First_Elmt (Constits);
26833 while Present (Constit_Elmt) loop
26834 Constit_Id := Node (Constit_Elmt);
26836 if Present_Then_Remove (In_Constits, Constit_Id) then
26837 Input_Seen := True;
26839 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then
26840 In_Out_Seen := True;
26842 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
26843 Output_Seen := True;
26845 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
26847 Proof_In_Seen := True;
26850 Has_Missing := True;
26853 Next_Elmt (Constit_Elmt);
26857 -- An In_Out constituent is a valid completion
26859 if In_Out_Seen then
26862 -- A pair of one Input/Proof_In and one Output constituent is a
26863 -- valid completion.
26865 elsif (Input_Seen or Proof_In_Seen) and Output_Seen then
26868 elsif Output_Seen then
26870 -- A single Output constituent is a valid completion only when
26871 -- some of the other constituents are missing.
26873 if Has_Missing then
26876 -- Otherwise all constituents are of mode Output
26880 ("global refinement of state & must include at least one "
26881 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
26885 -- The state lacks a completion. When full refinement is visible,
26886 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
26887 -- refinement is visible, emit an error if the abstract state
26888 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
26889 -- both are utilized, Check_State_And_Constituent_Use. will issue
26892 elsif not Input_Seen
26893 and then not In_Out_Seen
26894 and then not Output_Seen
26895 and then not Proof_In_Seen
26897 if Has_Visible_Refinement (State_Id)
26898 or else Contains (Repeat_Items, State_Id)
26901 ("missing global refinement of state &", N, State_Id);
26904 -- Otherwise the state has a malformed completion where at least
26905 -- one of the constituents has a different mode.
26909 ("global refinement of state & redefines the mode of its "
26910 & "constituents", N, State_Id);
26912 end Check_Constituent_Usage;
26916 Item_Elmt : Elmt_Id;
26917 Item_Id : Entity_Id;
26919 -- Start of processing for Check_In_Out_States
26922 -- Do not perform this check in an instance because it was already
26923 -- performed successfully in the generic template.
26925 if In_Instance then
26928 -- Inspect the In_Out items of the corresponding Global pragma
26929 -- looking for a state with a visible refinement.
26931 elsif Has_In_Out_State and then Present (In_Out_Items) then
26932 Item_Elmt := First_Elmt (In_Out_Items);
26933 while Present (Item_Elmt) loop
26934 Item_Id := Node (Item_Elmt);
26936 -- Ensure that one of the three coverage variants is satisfied
26938 if Ekind (Item_Id) = E_Abstract_State
26939 and then Has_Non_Null_Visible_Refinement (Item_Id)
26941 Check_Constituent_Usage (Item_Id);
26944 Next_Elmt (Item_Elmt);
26947 end Check_In_Out_States;
26949 ------------------------
26950 -- Check_Input_States --
26951 ------------------------
26953 procedure Check_Input_States is
26954 procedure Check_Constituent_Usage (State_Id : Entity_Id);
26955 -- Determine whether at least one constituent of state State_Id with
26956 -- full or partial visible refinement is used and has mode Input.
26957 -- Ensure that the remaining constituents do not have In_Out or
26958 -- Output modes. Emit an error if this is not the case
26959 -- (SPARK RM 7.2.4(5)).
26961 -----------------------------
26962 -- Check_Constituent_Usage --
26963 -----------------------------
26965 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
26966 Constits : constant Elist_Id :=
26967 Partial_Refinement_Constituents (State_Id);
26968 Constit_Elmt : Elmt_Id;
26969 Constit_Id : Entity_Id;
26970 In_Seen : Boolean := False;
26973 if Present (Constits) then
26974 Constit_Elmt := First_Elmt (Constits);
26975 while Present (Constit_Elmt) loop
26976 Constit_Id := Node (Constit_Elmt);
26978 -- At least one of the constituents appears as an Input
26980 if Present_Then_Remove (In_Constits, Constit_Id) then
26983 -- A Proof_In constituent can refine an Input state as long
26984 -- as there is at least one Input constituent present.
26986 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
26990 -- The constituent appears in the global refinement, but has
26991 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
26993 elsif Present_Then_Remove (In_Out_Constits, Constit_Id)
26994 or else Present_Then_Remove (Out_Constits, Constit_Id)
26996 Error_Msg_Name_1 := Chars (State_Id);
26998 ("constituent & of state % must have mode `Input` in "
26999 & "global refinement", N, Constit_Id);
27002 Next_Elmt (Constit_Elmt);
27006 -- Not one of the constituents appeared as Input. Always emit an
27007 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
27008 -- When only partial refinement is visible, emit an error if the
27009 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27010 -- the case where both are utilized, an error will be issued in
27011 -- Check_State_And_Constituent_Use.
27014 and then (Has_Visible_Refinement (State_Id)
27015 or else Contains (Repeat_Items, State_Id))
27018 ("global refinement of state & must include at least one "
27019 & "constituent of mode `Input`", N, State_Id);
27021 end Check_Constituent_Usage;
27025 Item_Elmt : Elmt_Id;
27026 Item_Id : Entity_Id;
27028 -- Start of processing for Check_Input_States
27031 -- Do not perform this check in an instance because it was already
27032 -- performed successfully in the generic template.
27034 if In_Instance then
27037 -- Inspect the Input items of the corresponding Global pragma looking
27038 -- for a state with a visible refinement.
27040 elsif Has_In_State and then Present (In_Items) then
27041 Item_Elmt := First_Elmt (In_Items);
27042 while Present (Item_Elmt) loop
27043 Item_Id := Node (Item_Elmt);
27045 -- When full refinement is visible, ensure that at least one of
27046 -- the constituents is utilized and is of mode Input. When only
27047 -- partial refinement is visible, ensure that either one of
27048 -- the constituents is utilized and is of mode Input, or the
27049 -- abstract state is repeated and no constituent is utilized.
27051 if Ekind (Item_Id) = E_Abstract_State
27052 and then Has_Non_Null_Visible_Refinement (Item_Id)
27054 Check_Constituent_Usage (Item_Id);
27057 Next_Elmt (Item_Elmt);
27060 end Check_Input_States;
27062 -------------------------
27063 -- Check_Output_States --
27064 -------------------------
27066 procedure Check_Output_States is
27067 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27068 -- Determine whether all constituents of state State_Id with full
27069 -- visible refinement are used and have mode Output. Emit an error
27070 -- if this is not the case (SPARK RM 7.2.4(5)).
27072 -----------------------------
27073 -- Check_Constituent_Usage --
27074 -----------------------------
27076 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27077 Constits : constant Elist_Id :=
27078 Partial_Refinement_Constituents (State_Id);
27079 Only_Partial : constant Boolean :=
27080 not Has_Visible_Refinement (State_Id);
27081 Constit_Elmt : Elmt_Id;
27082 Constit_Id : Entity_Id;
27083 Posted : Boolean := False;
27086 if Present (Constits) then
27087 Constit_Elmt := First_Elmt (Constits);
27088 while Present (Constit_Elmt) loop
27089 Constit_Id := Node (Constit_Elmt);
27091 -- Issue an error when a constituent of State_Id is utilized
27092 -- and State_Id has only partial visible refinement
27093 -- (SPARK RM 7.2.4(3d)).
27095 if Only_Partial then
27096 if Present_Then_Remove (Out_Constits, Constit_Id)
27097 or else Present_Then_Remove (In_Constits, Constit_Id)
27099 Present_Then_Remove (In_Out_Constits, Constit_Id)
27101 Present_Then_Remove (Proof_In_Constits, Constit_Id)
27103 Error_Msg_Name_1 := Chars (State_Id);
27105 ("constituent & of state % cannot be used in global "
27106 & "refinement", N, Constit_Id);
27107 Error_Msg_Name_1 := Chars (State_Id);
27108 SPARK_Msg_N ("\use state % instead", N);
27111 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
27114 -- The constituent appears in the global refinement, but has
27115 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
27117 elsif Present_Then_Remove (In_Constits, Constit_Id)
27118 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
27119 or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
27121 Error_Msg_Name_1 := Chars (State_Id);
27123 ("constituent & of state % must have mode `Output` in "
27124 & "global refinement", N, Constit_Id);
27126 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
27132 ("`Output` state & must be replaced by all its "
27133 & "constituents in global refinement", N, State_Id);
27137 ("\constituent & is missing in output list",
27141 Next_Elmt (Constit_Elmt);
27144 end Check_Constituent_Usage;
27148 Item_Elmt : Elmt_Id;
27149 Item_Id : Entity_Id;
27151 -- Start of processing for Check_Output_States
27154 -- Do not perform this check in an instance because it was already
27155 -- performed successfully in the generic template.
27157 if In_Instance then
27160 -- Inspect the Output items of the corresponding Global pragma
27161 -- looking for a state with a visible refinement.
27163 elsif Has_Out_State and then Present (Out_Items) then
27164 Item_Elmt := First_Elmt (Out_Items);
27165 while Present (Item_Elmt) loop
27166 Item_Id := Node (Item_Elmt);
27168 -- When full refinement is visible, ensure that all of the
27169 -- constituents are utilized and they have mode Output. When
27170 -- only partial refinement is visible, ensure that no
27171 -- constituent is utilized.
27173 if Ekind (Item_Id) = E_Abstract_State
27174 and then Has_Non_Null_Visible_Refinement (Item_Id)
27176 Check_Constituent_Usage (Item_Id);
27179 Next_Elmt (Item_Elmt);
27182 end Check_Output_States;
27184 ---------------------------
27185 -- Check_Proof_In_States --
27186 ---------------------------
27188 procedure Check_Proof_In_States is
27189 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27190 -- Determine whether at least one constituent of state State_Id with
27191 -- full or partial visible refinement is used and has mode Proof_In.
27192 -- Ensure that the remaining constituents do not have Input, In_Out,
27193 -- or Output modes. Emit an error if this is not the case
27194 -- (SPARK RM 7.2.4(5)).
27196 -----------------------------
27197 -- Check_Constituent_Usage --
27198 -----------------------------
27200 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27201 Constits : constant Elist_Id :=
27202 Partial_Refinement_Constituents (State_Id);
27203 Constit_Elmt : Elmt_Id;
27204 Constit_Id : Entity_Id;
27205 Proof_In_Seen : Boolean := False;
27208 if Present (Constits) then
27209 Constit_Elmt := First_Elmt (Constits);
27210 while Present (Constit_Elmt) loop
27211 Constit_Id := Node (Constit_Elmt);
27213 -- At least one of the constituents appears as Proof_In
27215 if Present_Then_Remove (Proof_In_Constits, Constit_Id) then
27216 Proof_In_Seen := True;
27218 -- The constituent appears in the global refinement, but has
27219 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
27221 elsif Present_Then_Remove (In_Constits, Constit_Id)
27222 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
27223 or else Present_Then_Remove (Out_Constits, Constit_Id)
27225 Error_Msg_Name_1 := Chars (State_Id);
27227 ("constituent & of state % must have mode `Proof_In` "
27228 & "in global refinement", N, Constit_Id);
27231 Next_Elmt (Constit_Elmt);
27235 -- Not one of the constituents appeared as Proof_In. Always emit
27236 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
27237 -- When only partial refinement is visible, emit an error if the
27238 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27239 -- the case where both are utilized, an error will be issued by
27240 -- Check_State_And_Constituent_Use.
27242 if not Proof_In_Seen
27243 and then (Has_Visible_Refinement (State_Id)
27244 or else Contains (Repeat_Items, State_Id))
27247 ("global refinement of state & must include at least one "
27248 & "constituent of mode `Proof_In`", N, State_Id);
27250 end Check_Constituent_Usage;
27254 Item_Elmt : Elmt_Id;
27255 Item_Id : Entity_Id;
27257 -- Start of processing for Check_Proof_In_States
27260 -- Do not perform this check in an instance because it was already
27261 -- performed successfully in the generic template.
27263 if In_Instance then
27266 -- Inspect the Proof_In items of the corresponding Global pragma
27267 -- looking for a state with a visible refinement.
27269 elsif Has_Proof_In_State and then Present (Proof_In_Items) then
27270 Item_Elmt := First_Elmt (Proof_In_Items);
27271 while Present (Item_Elmt) loop
27272 Item_Id := Node (Item_Elmt);
27274 -- Ensure that at least one of the constituents is utilized
27275 -- and is of mode Proof_In. When only partial refinement is
27276 -- visible, ensure that either one of the constituents is
27277 -- utilized and is of mode Proof_In, or the abstract state
27278 -- is repeated and no constituent is utilized.
27280 if Ekind (Item_Id) = E_Abstract_State
27281 and then Has_Non_Null_Visible_Refinement (Item_Id)
27283 Check_Constituent_Usage (Item_Id);
27286 Next_Elmt (Item_Elmt);
27289 end Check_Proof_In_States;
27291 -------------------------------
27292 -- Check_Refined_Global_List --
27293 -------------------------------
27295 procedure Check_Refined_Global_List
27297 Global_Mode : Name_Id := Name_Input)
27299 procedure Check_Refined_Global_Item
27301 Global_Mode : Name_Id);
27302 -- Verify the legality of a single global item declaration. Parameter
27303 -- Global_Mode denotes the current mode in effect.
27305 -------------------------------
27306 -- Check_Refined_Global_Item --
27307 -------------------------------
27309 procedure Check_Refined_Global_Item
27311 Global_Mode : Name_Id)
27313 Item_Id : constant Entity_Id := Entity_Of (Item);
27315 procedure Inconsistent_Mode_Error (Expect : Name_Id);
27316 -- Issue a common error message for all mode mismatches. Expect
27317 -- denotes the expected mode.
27319 -----------------------------
27320 -- Inconsistent_Mode_Error --
27321 -----------------------------
27323 procedure Inconsistent_Mode_Error (Expect : Name_Id) is
27326 ("global item & has inconsistent modes", Item, Item_Id);
27328 Error_Msg_Name_1 := Global_Mode;
27329 Error_Msg_Name_2 := Expect;
27330 SPARK_Msg_N ("\expected mode %, found mode %", Item);
27331 end Inconsistent_Mode_Error;
27335 Enc_State : Entity_Id := Empty;
27336 -- Encapsulating state for constituent, Empty otherwise
27338 -- Start of processing for Check_Refined_Global_Item
27341 if Ekind_In (Item_Id, E_Abstract_State,
27345 Enc_State := Find_Encapsulating_State (States, Item_Id);
27348 -- When the state or object acts as a constituent of another
27349 -- state with a visible refinement, collect it for the state
27350 -- completeness checks performed later on. Note that the item
27351 -- acts as a constituent only when the encapsulating state is
27352 -- present in pragma Global.
27354 if Present (Enc_State)
27355 and then (Has_Visible_Refinement (Enc_State)
27356 or else Has_Partial_Visible_Refinement (Enc_State))
27357 and then Contains (States, Enc_State)
27359 -- If the state has only partial visible refinement, remove it
27360 -- from the list of items that should be repeated from pragma
27363 if not Has_Visible_Refinement (Enc_State) then
27364 Present_Then_Remove (Repeat_Items, Enc_State);
27367 if Global_Mode = Name_Input then
27368 Append_New_Elmt (Item_Id, In_Constits);
27370 elsif Global_Mode = Name_In_Out then
27371 Append_New_Elmt (Item_Id, In_Out_Constits);
27373 elsif Global_Mode = Name_Output then
27374 Append_New_Elmt (Item_Id, Out_Constits);
27376 elsif Global_Mode = Name_Proof_In then
27377 Append_New_Elmt (Item_Id, Proof_In_Constits);
27380 -- When not a constituent, ensure that both occurrences of the
27381 -- item in pragmas Global and Refined_Global match. Also remove
27382 -- it when present from the list of items that should be repeated
27383 -- from pragma Global.
27386 Present_Then_Remove (Repeat_Items, Item_Id);
27388 if Contains (In_Items, Item_Id) then
27389 if Global_Mode /= Name_Input then
27390 Inconsistent_Mode_Error (Name_Input);
27393 elsif Contains (In_Out_Items, Item_Id) then
27394 if Global_Mode /= Name_In_Out then
27395 Inconsistent_Mode_Error (Name_In_Out);
27398 elsif Contains (Out_Items, Item_Id) then
27399 if Global_Mode /= Name_Output then
27400 Inconsistent_Mode_Error (Name_Output);
27403 elsif Contains (Proof_In_Items, Item_Id) then
27406 -- The item does not appear in the corresponding Global pragma,
27407 -- it must be an extra (SPARK RM 7.2.4(3)).
27410 pragma Assert (Present (Global));
27411 Error_Msg_Sloc := Sloc (Global);
27413 ("extra global item & does not refine or repeat any "
27414 & "global item #", Item, Item_Id);
27417 end Check_Refined_Global_Item;
27423 -- Start of processing for Check_Refined_Global_List
27426 -- Do not perform this check in an instance because it was already
27427 -- performed successfully in the generic template.
27429 if In_Instance then
27432 elsif Nkind (List) = N_Null then
27435 -- Single global item declaration
27437 elsif Nkind_In (List, N_Expanded_Name,
27439 N_Selected_Component)
27441 Check_Refined_Global_Item (List, Global_Mode);
27443 -- Simple global list or moded global list declaration
27445 elsif Nkind (List) = N_Aggregate then
27447 -- The declaration of a simple global list appear as a collection
27450 if Present (Expressions (List)) then
27451 Item := First (Expressions (List));
27452 while Present (Item) loop
27453 Check_Refined_Global_Item (Item, Global_Mode);
27457 -- The declaration of a moded global list appears as a collection
27458 -- of component associations where individual choices denote
27461 elsif Present (Component_Associations (List)) then
27462 Item := First (Component_Associations (List));
27463 while Present (Item) loop
27464 Check_Refined_Global_List
27465 (List => Expression (Item),
27466 Global_Mode => Chars (First (Choices (Item))));
27474 raise Program_Error;
27480 raise Program_Error;
27482 end Check_Refined_Global_List;
27484 --------------------------
27485 -- Collect_Global_Items --
27486 --------------------------
27488 procedure Collect_Global_Items
27490 Mode : Name_Id := Name_Input)
27492 procedure Collect_Global_Item
27494 Item_Mode : Name_Id);
27495 -- Add a single item to the appropriate list. Item_Mode denotes the
27496 -- current mode in effect.
27498 -------------------------
27499 -- Collect_Global_Item --
27500 -------------------------
27502 procedure Collect_Global_Item
27504 Item_Mode : Name_Id)
27506 Item_Id : constant Entity_Id := Available_View (Entity_Of (Item));
27507 -- The above handles abstract views of variables and states built
27508 -- for limited with clauses.
27511 -- Signal that the global list contains at least one abstract
27512 -- state with a visible refinement. Note that the refinement may
27513 -- be null in which case there are no constituents.
27515 if Ekind (Item_Id) = E_Abstract_State then
27516 if Has_Null_Visible_Refinement (Item_Id) then
27517 Has_Null_State := True;
27519 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
27520 Append_New_Elmt (Item_Id, States);
27522 if Item_Mode = Name_Input then
27523 Has_In_State := True;
27524 elsif Item_Mode = Name_In_Out then
27525 Has_In_Out_State := True;
27526 elsif Item_Mode = Name_Output then
27527 Has_Out_State := True;
27528 elsif Item_Mode = Name_Proof_In then
27529 Has_Proof_In_State := True;
27534 -- Record global items without full visible refinement found in
27535 -- pragma Global which should be repeated in the global refinement
27536 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
27538 if Ekind (Item_Id) /= E_Abstract_State
27539 or else not Has_Visible_Refinement (Item_Id)
27541 Append_New_Elmt (Item_Id, Repeat_Items);
27544 -- Add the item to the proper list
27546 if Item_Mode = Name_Input then
27547 Append_New_Elmt (Item_Id, In_Items);
27548 elsif Item_Mode = Name_In_Out then
27549 Append_New_Elmt (Item_Id, In_Out_Items);
27550 elsif Item_Mode = Name_Output then
27551 Append_New_Elmt (Item_Id, Out_Items);
27552 elsif Item_Mode = Name_Proof_In then
27553 Append_New_Elmt (Item_Id, Proof_In_Items);
27555 end Collect_Global_Item;
27561 -- Start of processing for Collect_Global_Items
27564 if Nkind (List) = N_Null then
27567 -- Single global item declaration
27569 elsif Nkind_In (List, N_Expanded_Name,
27571 N_Selected_Component)
27573 Collect_Global_Item (List, Mode);
27575 -- Single global list or moded global list declaration
27577 elsif Nkind (List) = N_Aggregate then
27579 -- The declaration of a simple global list appear as a collection
27582 if Present (Expressions (List)) then
27583 Item := First (Expressions (List));
27584 while Present (Item) loop
27585 Collect_Global_Item (Item, Mode);
27589 -- The declaration of a moded global list appears as a collection
27590 -- of component associations where individual choices denote mode.
27592 elsif Present (Component_Associations (List)) then
27593 Item := First (Component_Associations (List));
27594 while Present (Item) loop
27595 Collect_Global_Items
27596 (List => Expression (Item),
27597 Mode => Chars (First (Choices (Item))));
27605 raise Program_Error;
27608 -- To accommodate partial decoration of disabled SPARK features, this
27609 -- routine may be called with illegal input. If this is the case, do
27610 -- not raise Program_Error.
27615 end Collect_Global_Items;
27617 -------------------------
27618 -- Present_Then_Remove --
27619 -------------------------
27621 function Present_Then_Remove
27623 Item : Entity_Id) return Boolean
27628 if Present (List) then
27629 Elmt := First_Elmt (List);
27630 while Present (Elmt) loop
27631 if Node (Elmt) = Item then
27632 Remove_Elmt (List, Elmt);
27641 end Present_Then_Remove;
27643 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id) is
27646 Ignore := Present_Then_Remove (List, Item);
27647 end Present_Then_Remove;
27649 -------------------------------
27650 -- Report_Extra_Constituents --
27651 -------------------------------
27653 procedure Report_Extra_Constituents is
27654 procedure Report_Extra_Constituents_In_List (List : Elist_Id);
27655 -- Emit an error for every element of List
27657 ---------------------------------------
27658 -- Report_Extra_Constituents_In_List --
27659 ---------------------------------------
27661 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is
27662 Constit_Elmt : Elmt_Id;
27665 if Present (List) then
27666 Constit_Elmt := First_Elmt (List);
27667 while Present (Constit_Elmt) loop
27668 SPARK_Msg_NE ("extra constituent &", N, Node (Constit_Elmt));
27669 Next_Elmt (Constit_Elmt);
27672 end Report_Extra_Constituents_In_List;
27674 -- Start of processing for Report_Extra_Constituents
27677 -- Do not perform this check in an instance because it was already
27678 -- performed successfully in the generic template.
27680 if In_Instance then
27684 Report_Extra_Constituents_In_List (In_Constits);
27685 Report_Extra_Constituents_In_List (In_Out_Constits);
27686 Report_Extra_Constituents_In_List (Out_Constits);
27687 Report_Extra_Constituents_In_List (Proof_In_Constits);
27689 end Report_Extra_Constituents;
27691 --------------------------
27692 -- Report_Missing_Items --
27693 --------------------------
27695 procedure Report_Missing_Items is
27696 Item_Elmt : Elmt_Id;
27697 Item_Id : Entity_Id;
27700 -- Do not perform this check in an instance because it was already
27701 -- performed successfully in the generic template.
27703 if In_Instance then
27707 if Present (Repeat_Items) then
27708 Item_Elmt := First_Elmt (Repeat_Items);
27709 while Present (Item_Elmt) loop
27710 Item_Id := Node (Item_Elmt);
27711 SPARK_Msg_NE ("missing global item &", N, Item_Id);
27712 Next_Elmt (Item_Elmt);
27716 end Report_Missing_Items;
27720 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
27721 Errors : constant Nat := Serious_Errors_Detected;
27723 No_Constit : Boolean;
27725 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
27728 -- Do not analyze the pragma multiple times
27730 if Is_Analyzed_Pragma (N) then
27734 Spec_Id := Unique_Defining_Entity (Body_Decl);
27736 -- Use the anonymous object as the proper spec when Refined_Global
27737 -- applies to the body of a single task type. The object carries the
27738 -- proper Chars as well as all non-refined versions of pragmas.
27740 if Is_Single_Concurrent_Type (Spec_Id) then
27741 Spec_Id := Anonymous_Object (Spec_Id);
27744 Global := Get_Pragma (Spec_Id, Pragma_Global);
27745 Items := Expression (Get_Argument (N, Spec_Id));
27747 -- The subprogram declaration lacks pragma Global. This renders
27748 -- Refined_Global useless as there is nothing to refine.
27750 if No (Global) then
27752 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
27753 & "& lacks aspect or pragma Global"), N, Spec_Id);
27757 -- Extract all relevant items from the corresponding Global pragma
27759 Collect_Global_Items (Expression (Get_Argument (Global, Spec_Id)));
27761 -- Package and subprogram bodies are instantiated individually in
27762 -- a separate compiler pass. Due to this mode of instantiation, the
27763 -- refinement of a state may no longer be visible when a subprogram
27764 -- body contract is instantiated. Since the generic template is legal,
27765 -- do not perform this check in the instance to circumvent this oddity.
27767 if In_Instance then
27770 -- Non-instance case
27773 -- The corresponding Global pragma must mention at least one
27774 -- state with a visible refinement at the point Refined_Global
27775 -- is processed. States with null refinements need Refined_Global
27776 -- pragma (SPARK RM 7.2.4(2)).
27778 if not Has_In_State
27779 and then not Has_In_Out_State
27780 and then not Has_Out_State
27781 and then not Has_Proof_In_State
27782 and then not Has_Null_State
27785 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
27786 & "depend on abstract state with visible refinement"),
27790 -- The global refinement of inputs and outputs cannot be null when
27791 -- the corresponding Global pragma contains at least one item except
27792 -- in the case where we have states with null refinements.
27794 elsif Nkind (Items) = N_Null
27796 (Present (In_Items)
27797 or else Present (In_Out_Items)
27798 or else Present (Out_Items)
27799 or else Present (Proof_In_Items))
27800 and then not Has_Null_State
27803 (Fix_Msg (Spec_Id, "refinement cannot be null, subprogram & has "
27804 & "global items"), N, Spec_Id);
27809 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
27810 -- This ensures that the categorization of all refined global items is
27811 -- consistent with their role.
27813 Analyze_Global_In_Decl_Part (N);
27815 -- Perform all refinement checks with respect to completeness and mode
27818 if Serious_Errors_Detected = Errors then
27819 Check_Refined_Global_List (Items);
27822 -- Store the information that no constituent is used in the global
27823 -- refinement, prior to calling checking procedures which remove items
27824 -- from the list of constituents.
27828 and then No (In_Out_Constits)
27829 and then No (Out_Constits)
27830 and then No (Proof_In_Constits);
27832 -- For Input states with visible refinement, at least one constituent
27833 -- must be used as an Input in the global refinement.
27835 if Serious_Errors_Detected = Errors then
27836 Check_Input_States;
27839 -- Verify all possible completion variants for In_Out states with
27840 -- visible refinement.
27842 if Serious_Errors_Detected = Errors then
27843 Check_In_Out_States;
27846 -- For Output states with visible refinement, all constituents must be
27847 -- used as Outputs in the global refinement.
27849 if Serious_Errors_Detected = Errors then
27850 Check_Output_States;
27853 -- For Proof_In states with visible refinement, at least one constituent
27854 -- must be used as Proof_In in the global refinement.
27856 if Serious_Errors_Detected = Errors then
27857 Check_Proof_In_States;
27860 -- Emit errors for all constituents that belong to other states with
27861 -- visible refinement that do not appear in Global.
27863 if Serious_Errors_Detected = Errors then
27864 Report_Extra_Constituents;
27867 -- Emit errors for all items in Global that are not repeated in the
27868 -- global refinement and for which there is no full visible refinement
27869 -- and, in the case of states with partial visible refinement, no
27870 -- constituent is mentioned in the global refinement.
27872 if Serious_Errors_Detected = Errors then
27873 Report_Missing_Items;
27876 -- Emit an error if no constituent is used in the global refinement
27877 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
27878 -- one may be issued by the checking procedures. Do not perform this
27879 -- check in an instance because it was already performed successfully
27880 -- in the generic template.
27882 if Serious_Errors_Detected = Errors
27883 and then not In_Instance
27884 and then not Has_Null_State
27885 and then No_Constit
27887 SPARK_Msg_N ("missing refinement", N);
27891 Set_Is_Analyzed_Pragma (N);
27892 end Analyze_Refined_Global_In_Decl_Part;
27894 ----------------------------------------
27895 -- Analyze_Refined_State_In_Decl_Part --
27896 ----------------------------------------
27898 procedure Analyze_Refined_State_In_Decl_Part
27900 Freeze_Id : Entity_Id := Empty)
27902 Body_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
27903 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
27904 Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl);
27906 Available_States : Elist_Id := No_Elist;
27907 -- A list of all abstract states defined in the package declaration that
27908 -- are available for refinement. The list is used to report unrefined
27911 Body_States : Elist_Id := No_Elist;
27912 -- A list of all hidden states that appear in the body of the related
27913 -- package. The list is used to report unused hidden states.
27915 Constituents_Seen : Elist_Id := No_Elist;
27916 -- A list that contains all constituents processed so far. The list is
27917 -- used to detect multiple uses of the same constituent.
27919 Freeze_Posted : Boolean := False;
27920 -- A flag that controls the output of a freezing-related error (see use
27923 Refined_States_Seen : Elist_Id := No_Elist;
27924 -- A list that contains all refined states processed so far. The list is
27925 -- used to detect duplicate refinements.
27927 procedure Analyze_Refinement_Clause (Clause : Node_Id);
27928 -- Perform full analysis of a single refinement clause
27930 procedure Report_Unrefined_States (States : Elist_Id);
27931 -- Emit errors for all unrefined abstract states found in list States
27933 -------------------------------
27934 -- Analyze_Refinement_Clause --
27935 -------------------------------
27937 procedure Analyze_Refinement_Clause (Clause : Node_Id) is
27938 AR_Constit : Entity_Id := Empty;
27939 AW_Constit : Entity_Id := Empty;
27940 ER_Constit : Entity_Id := Empty;
27941 EW_Constit : Entity_Id := Empty;
27942 -- The entities of external constituents that contain one of the
27943 -- following enabled properties: Async_Readers, Async_Writers,
27944 -- Effective_Reads and Effective_Writes.
27946 External_Constit_Seen : Boolean := False;
27947 -- Flag used to mark when at least one external constituent is part
27948 -- of the state refinement.
27950 Non_Null_Seen : Boolean := False;
27951 Null_Seen : Boolean := False;
27952 -- Flags used to detect multiple uses of null in a single clause or a
27953 -- mixture of null and non-null constituents.
27955 Part_Of_Constits : Elist_Id := No_Elist;
27956 -- A list of all candidate constituents subject to indicator Part_Of
27957 -- where the encapsulating state is the current state.
27960 State_Id : Entity_Id;
27961 -- The current state being refined
27963 procedure Analyze_Constituent (Constit : Node_Id);
27964 -- Perform full analysis of a single constituent
27966 procedure Check_External_Property
27967 (Prop_Nam : Name_Id;
27969 Constit : Entity_Id);
27970 -- Determine whether a property denoted by name Prop_Nam is present
27971 -- in the refined state. Emit an error if this is not the case. Flag
27972 -- Enabled should be set when the property applies to the refined
27973 -- state. Constit denotes the constituent (if any) which introduces
27974 -- the property in the refinement.
27976 procedure Match_State;
27977 -- Determine whether the state being refined appears in list
27978 -- Available_States. Emit an error when attempting to re-refine the
27979 -- state or when the state is not defined in the package declaration,
27980 -- otherwise remove the state from Available_States.
27982 procedure Report_Unused_Constituents (Constits : Elist_Id);
27983 -- Emit errors for all unused Part_Of constituents in list Constits
27985 -------------------------
27986 -- Analyze_Constituent --
27987 -------------------------
27989 procedure Analyze_Constituent (Constit : Node_Id) is
27990 procedure Match_Constituent (Constit_Id : Entity_Id);
27991 -- Determine whether constituent Constit denoted by its entity
27992 -- Constit_Id appears in Body_States. Emit an error when the
27993 -- constituent is not a valid hidden state of the related package
27994 -- or when it is used more than once. Otherwise remove the
27995 -- constituent from Body_States.
27997 -----------------------
27998 -- Match_Constituent --
27999 -----------------------
28001 procedure Match_Constituent (Constit_Id : Entity_Id) is
28002 procedure Collect_Constituent;
28003 -- Verify the legality of constituent Constit_Id and add it to
28004 -- the refinements of State_Id.
28006 -------------------------
28007 -- Collect_Constituent --
28008 -------------------------
28010 procedure Collect_Constituent is
28011 Constits : Elist_Id;
28014 -- The Ghost policy in effect at the point of abstract state
28015 -- declaration and constituent must match (SPARK RM 6.9(15))
28017 Check_Ghost_Refinement
28018 (State, State_Id, Constit, Constit_Id);
28020 -- A synchronized state must be refined by a synchronized
28021 -- object or another synchronized state (SPARK RM 9.6).
28023 if Is_Synchronized_State (State_Id)
28024 and then not Is_Synchronized_Object (Constit_Id)
28025 and then not Is_Synchronized_State (Constit_Id)
28028 ("constituent of synchronized state & must be "
28029 & "synchronized", Constit, State_Id);
28032 -- Add the constituent to the list of processed items to aid
28033 -- with the detection of duplicates.
28035 Append_New_Elmt (Constit_Id, Constituents_Seen);
28037 -- Collect the constituent in the list of refinement items
28038 -- and establish a relation between the refined state and
28041 Constits := Refinement_Constituents (State_Id);
28043 if No (Constits) then
28044 Constits := New_Elmt_List;
28045 Set_Refinement_Constituents (State_Id, Constits);
28048 Append_Elmt (Constit_Id, Constits);
28049 Set_Encapsulating_State (Constit_Id, State_Id);
28051 -- The state has at least one legal constituent, mark the
28052 -- start of the refinement region. The region ends when the
28053 -- body declarations end (see routine Analyze_Declarations).
28055 Set_Has_Visible_Refinement (State_Id);
28057 -- When the constituent is external, save its relevant
28058 -- property for further checks.
28060 if Async_Readers_Enabled (Constit_Id) then
28061 AR_Constit := Constit_Id;
28062 External_Constit_Seen := True;
28065 if Async_Writers_Enabled (Constit_Id) then
28066 AW_Constit := Constit_Id;
28067 External_Constit_Seen := True;
28070 if Effective_Reads_Enabled (Constit_Id) then
28071 ER_Constit := Constit_Id;
28072 External_Constit_Seen := True;
28075 if Effective_Writes_Enabled (Constit_Id) then
28076 EW_Constit := Constit_Id;
28077 External_Constit_Seen := True;
28079 end Collect_Constituent;
28083 State_Elmt : Elmt_Id;
28085 -- Start of processing for Match_Constituent
28088 -- Detect a duplicate use of a constituent
28090 if Contains (Constituents_Seen, Constit_Id) then
28092 ("duplicate use of constituent &", Constit, Constit_Id);
28096 -- The constituent is subject to a Part_Of indicator
28098 if Present (Encapsulating_State (Constit_Id)) then
28099 if Encapsulating_State (Constit_Id) = State_Id then
28100 Remove (Part_Of_Constits, Constit_Id);
28101 Collect_Constituent;
28103 -- The constituent is part of another state and is used
28104 -- incorrectly in the refinement of the current state.
28107 Error_Msg_Name_1 := Chars (State_Id);
28109 ("& cannot act as constituent of state %",
28110 Constit, Constit_Id);
28112 ("\Part_Of indicator specifies encapsulator &",
28113 Constit, Encapsulating_State (Constit_Id));
28116 -- The only other source of legal constituents is the body
28117 -- state space of the related package.
28120 if Present (Body_States) then
28121 State_Elmt := First_Elmt (Body_States);
28122 while Present (State_Elmt) loop
28124 -- Consume a valid constituent to signal that it has
28125 -- been encountered.
28127 if Node (State_Elmt) = Constit_Id then
28128 Remove_Elmt (Body_States, State_Elmt);
28129 Collect_Constituent;
28133 Next_Elmt (State_Elmt);
28137 -- At this point it is known that the constituent is not
28138 -- part of the package hidden state and cannot be used in
28139 -- a refinement (SPARK RM 7.2.2(9)).
28141 Error_Msg_Name_1 := Chars (Spec_Id);
28143 ("cannot use & in refinement, constituent is not a hidden "
28144 & "state of package %", Constit, Constit_Id);
28146 end Match_Constituent;
28150 Constit_Id : Entity_Id;
28151 Constits : Elist_Id;
28153 -- Start of processing for Analyze_Constituent
28156 -- Detect multiple uses of null in a single refinement clause or a
28157 -- mixture of null and non-null constituents.
28159 if Nkind (Constit) = N_Null then
28162 ("multiple null constituents not allowed", Constit);
28164 elsif Non_Null_Seen then
28166 ("cannot mix null and non-null constituents", Constit);
28171 -- Collect the constituent in the list of refinement items
28173 Constits := Refinement_Constituents (State_Id);
28175 if No (Constits) then
28176 Constits := New_Elmt_List;
28177 Set_Refinement_Constituents (State_Id, Constits);
28180 Append_Elmt (Constit, Constits);
28182 -- The state has at least one legal constituent, mark the
28183 -- start of the refinement region. The region ends when the
28184 -- body declarations end (see Analyze_Declarations).
28186 Set_Has_Visible_Refinement (State_Id);
28189 -- Non-null constituents
28192 Non_Null_Seen := True;
28196 ("cannot mix null and non-null constituents", Constit);
28200 Resolve_State (Constit);
28202 -- Ensure that the constituent denotes a valid state or a
28203 -- whole object (SPARK RM 7.2.2(5)).
28205 if Is_Entity_Name (Constit) then
28206 Constit_Id := Entity_Of (Constit);
28208 -- When a constituent is declared after a subprogram body
28209 -- that caused freezing of the related contract where
28210 -- pragma Refined_State resides, the constituent appears
28211 -- undefined and carries Any_Id as its entity.
28213 -- package body Pack
28214 -- with Refined_State => (State => Constit)
28217 -- with Refined_Global => (Input => Constit)
28225 if Constit_Id = Any_Id then
28226 SPARK_Msg_NE ("& is undefined", Constit, Constit_Id);
28228 -- Emit a specialized info message when the contract of
28229 -- the related package body was "frozen" by another body.
28230 -- Note that it is not possible to precisely identify why
28231 -- the constituent is undefined because it is not visible
28232 -- when pragma Refined_State is analyzed. This message is
28233 -- a reasonable approximation.
28235 if Present (Freeze_Id) and then not Freeze_Posted then
28236 Freeze_Posted := True;
28238 Error_Msg_Name_1 := Chars (Body_Id);
28239 Error_Msg_Sloc := Sloc (Freeze_Id);
28241 ("body & declared # freezes the contract of %",
28244 ("\all constituents must be declared before body #",
28247 -- A misplaced constituent is a critical error because
28248 -- pragma Refined_Depends or Refined_Global depends on
28249 -- the proper link between a state and a constituent.
28250 -- Stop the compilation, as this leads to a multitude
28251 -- of misleading cascaded errors.
28253 raise Unrecoverable_Error;
28256 -- The constituent is a valid state or object
28258 elsif Ekind_In (Constit_Id, E_Abstract_State,
28262 Match_Constituent (Constit_Id);
28264 -- The variable may eventually become a constituent of a
28265 -- single protected/task type. Record the reference now
28266 -- and verify its legality when analyzing the contract of
28267 -- the variable (SPARK RM 9.3).
28269 if Ekind (Constit_Id) = E_Variable then
28270 Record_Possible_Part_Of_Reference
28271 (Var_Id => Constit_Id,
28275 -- Otherwise the constituent is illegal
28279 ("constituent & must denote object or state",
28280 Constit, Constit_Id);
28283 -- The constituent is illegal
28286 SPARK_Msg_N ("malformed constituent", Constit);
28289 end Analyze_Constituent;
28291 -----------------------------
28292 -- Check_External_Property --
28293 -----------------------------
28295 procedure Check_External_Property
28296 (Prop_Nam : Name_Id;
28298 Constit : Entity_Id)
28301 -- The property is missing in the declaration of the state, but
28302 -- a constituent is introducing it in the state refinement
28303 -- (SPARK RM 7.2.8(2)).
28305 if not Enabled and then Present (Constit) then
28306 Error_Msg_Name_1 := Prop_Nam;
28307 Error_Msg_Name_2 := Chars (State_Id);
28309 ("constituent & introduces external property % in refinement "
28310 & "of state %", State, Constit);
28312 Error_Msg_Sloc := Sloc (State_Id);
28314 ("\property is missing in abstract state declaration #",
28317 end Check_External_Property;
28323 procedure Match_State is
28324 State_Elmt : Elmt_Id;
28327 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
28329 if Contains (Refined_States_Seen, State_Id) then
28331 ("duplicate refinement of state &", State, State_Id);
28335 -- Inspect the abstract states defined in the package declaration
28336 -- looking for a match.
28338 State_Elmt := First_Elmt (Available_States);
28339 while Present (State_Elmt) loop
28341 -- A valid abstract state is being refined in the body. Add
28342 -- the state to the list of processed refined states to aid
28343 -- with the detection of duplicate refinements. Remove the
28344 -- state from Available_States to signal that it has already
28347 if Node (State_Elmt) = State_Id then
28348 Append_New_Elmt (State_Id, Refined_States_Seen);
28349 Remove_Elmt (Available_States, State_Elmt);
28353 Next_Elmt (State_Elmt);
28356 -- If we get here, we are refining a state that is not defined in
28357 -- the package declaration.
28359 Error_Msg_Name_1 := Chars (Spec_Id);
28361 ("cannot refine state, & is not defined in package %",
28365 --------------------------------
28366 -- Report_Unused_Constituents --
28367 --------------------------------
28369 procedure Report_Unused_Constituents (Constits : Elist_Id) is
28370 Constit_Elmt : Elmt_Id;
28371 Constit_Id : Entity_Id;
28372 Posted : Boolean := False;
28375 if Present (Constits) then
28376 Constit_Elmt := First_Elmt (Constits);
28377 while Present (Constit_Elmt) loop
28378 Constit_Id := Node (Constit_Elmt);
28380 -- Generate an error message of the form:
28382 -- state ... has unused Part_Of constituents
28383 -- abstract state ... defined at ...
28384 -- constant ... defined at ...
28385 -- variable ... defined at ...
28390 ("state & has unused Part_Of constituents",
28394 Error_Msg_Sloc := Sloc (Constit_Id);
28396 if Ekind (Constit_Id) = E_Abstract_State then
28398 ("\abstract state & defined #", State, Constit_Id);
28400 elsif Ekind (Constit_Id) = E_Constant then
28402 ("\constant & defined #", State, Constit_Id);
28405 pragma Assert (Ekind (Constit_Id) = E_Variable);
28406 SPARK_Msg_NE ("\variable & defined #", State, Constit_Id);
28409 Next_Elmt (Constit_Elmt);
28412 end Report_Unused_Constituents;
28414 -- Local declarations
28416 Body_Ref : Node_Id;
28417 Body_Ref_Elmt : Elmt_Id;
28419 Extra_State : Node_Id;
28421 -- Start of processing for Analyze_Refinement_Clause
28424 -- A refinement clause appears as a component association where the
28425 -- sole choice is the state and the expressions are the constituents.
28426 -- This is a syntax error, always report.
28428 if Nkind (Clause) /= N_Component_Association then
28429 Error_Msg_N ("malformed state refinement clause", Clause);
28433 -- Analyze the state name of a refinement clause
28435 State := First (Choices (Clause));
28438 Resolve_State (State);
28440 -- Ensure that the state name denotes a valid abstract state that is
28441 -- defined in the spec of the related package.
28443 if Is_Entity_Name (State) then
28444 State_Id := Entity_Of (State);
28446 -- When the abstract state is undefined, it appears as Any_Id. Do
28447 -- not continue with the analysis of the clause.
28449 if State_Id = Any_Id then
28452 -- Catch any attempts to re-refine a state or refine a state that
28453 -- is not defined in the package declaration.
28455 elsif Ekind (State_Id) = E_Abstract_State then
28459 SPARK_Msg_NE ("& must denote abstract state", State, State_Id);
28463 -- References to a state with visible refinement are illegal.
28464 -- When nested packages are involved, detecting such references is
28465 -- tricky because pragma Refined_State is analyzed later than the
28466 -- offending pragma Depends or Global. References that occur in
28467 -- such nested context are stored in a list. Emit errors for all
28468 -- references found in Body_References (SPARK RM 6.1.4(8)).
28470 if Present (Body_References (State_Id)) then
28471 Body_Ref_Elmt := First_Elmt (Body_References (State_Id));
28472 while Present (Body_Ref_Elmt) loop
28473 Body_Ref := Node (Body_Ref_Elmt);
28475 SPARK_Msg_N ("reference to & not allowed", Body_Ref);
28476 Error_Msg_Sloc := Sloc (State);
28477 SPARK_Msg_N ("\refinement of & is visible#", Body_Ref);
28479 Next_Elmt (Body_Ref_Elmt);
28483 -- The state name is illegal. This is a syntax error, always report.
28486 Error_Msg_N ("malformed state name in refinement clause", State);
28490 -- A refinement clause may only refine one state at a time
28492 Extra_State := Next (State);
28494 if Present (Extra_State) then
28496 ("refinement clause cannot cover multiple states", Extra_State);
28499 -- Replicate the Part_Of constituents of the refined state because
28500 -- the algorithm will consume items.
28502 Part_Of_Constits := New_Copy_Elist (Part_Of_Constituents (State_Id));
28504 -- Analyze all constituents of the refinement. Multiple constituents
28505 -- appear as an aggregate.
28507 Constit := Expression (Clause);
28509 if Nkind (Constit) = N_Aggregate then
28510 if Present (Component_Associations (Constit)) then
28512 ("constituents of refinement clause must appear in "
28513 & "positional form", Constit);
28515 else pragma Assert (Present (Expressions (Constit)));
28516 Constit := First (Expressions (Constit));
28517 while Present (Constit) loop
28518 Analyze_Constituent (Constit);
28523 -- Various forms of a single constituent. Note that these may include
28524 -- malformed constituents.
28527 Analyze_Constituent (Constit);
28530 -- Verify that external constituents do not introduce new external
28531 -- property in the state refinement (SPARK RM 7.2.8(2)).
28533 if Is_External_State (State_Id) then
28534 Check_External_Property
28535 (Prop_Nam => Name_Async_Readers,
28536 Enabled => Async_Readers_Enabled (State_Id),
28537 Constit => AR_Constit);
28539 Check_External_Property
28540 (Prop_Nam => Name_Async_Writers,
28541 Enabled => Async_Writers_Enabled (State_Id),
28542 Constit => AW_Constit);
28544 Check_External_Property
28545 (Prop_Nam => Name_Effective_Reads,
28546 Enabled => Effective_Reads_Enabled (State_Id),
28547 Constit => ER_Constit);
28549 Check_External_Property
28550 (Prop_Nam => Name_Effective_Writes,
28551 Enabled => Effective_Writes_Enabled (State_Id),
28552 Constit => EW_Constit);
28554 -- When a refined state is not external, it should not have external
28555 -- constituents (SPARK RM 7.2.8(1)).
28557 elsif External_Constit_Seen then
28559 ("non-external state & cannot contain external constituents in "
28560 & "refinement", State, State_Id);
28563 -- Ensure that all Part_Of candidate constituents have been mentioned
28564 -- in the refinement clause.
28566 Report_Unused_Constituents (Part_Of_Constits);
28567 end Analyze_Refinement_Clause;
28569 -----------------------------
28570 -- Report_Unrefined_States --
28571 -----------------------------
28573 procedure Report_Unrefined_States (States : Elist_Id) is
28574 State_Elmt : Elmt_Id;
28577 if Present (States) then
28578 State_Elmt := First_Elmt (States);
28579 while Present (State_Elmt) loop
28581 ("abstract state & must be refined", Node (State_Elmt));
28583 Next_Elmt (State_Elmt);
28586 end Report_Unrefined_States;
28588 -- Local declarations
28590 Clauses : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
28593 -- Start of processing for Analyze_Refined_State_In_Decl_Part
28596 -- Do not analyze the pragma multiple times
28598 if Is_Analyzed_Pragma (N) then
28602 -- Save the scenario for examination by the ABE Processing phase
28604 Record_Elaboration_Scenario (N);
28606 -- Replicate the abstract states declared by the package because the
28607 -- matching algorithm will consume states.
28609 Available_States := New_Copy_Elist (Abstract_States (Spec_Id));
28611 -- Gather all abstract states and objects declared in the visible
28612 -- state space of the package body. These items must be utilized as
28613 -- constituents in a state refinement.
28615 Body_States := Collect_Body_States (Body_Id);
28617 -- Multiple non-null state refinements appear as an aggregate
28619 if Nkind (Clauses) = N_Aggregate then
28620 if Present (Expressions (Clauses)) then
28622 ("state refinements must appear as component associations",
28625 else pragma Assert (Present (Component_Associations (Clauses)));
28626 Clause := First (Component_Associations (Clauses));
28627 while Present (Clause) loop
28628 Analyze_Refinement_Clause (Clause);
28633 -- Various forms of a single state refinement. Note that these may
28634 -- include malformed refinements.
28637 Analyze_Refinement_Clause (Clauses);
28640 -- List all abstract states that were left unrefined
28642 Report_Unrefined_States (Available_States);
28644 Set_Is_Analyzed_Pragma (N);
28645 end Analyze_Refined_State_In_Decl_Part;
28647 ------------------------------------
28648 -- Analyze_Test_Case_In_Decl_Part --
28649 ------------------------------------
28651 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id) is
28652 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
28653 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
28655 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id);
28656 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
28657 -- denoted by Arg_Nam.
28659 ------------------------------
28660 -- Preanalyze_Test_Case_Arg --
28661 ------------------------------
28663 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id) is
28667 -- Preanalyze the original aspect argument for a generic subprogram
28668 -- to properly capture global references.
28670 if Is_Generic_Subprogram (Spec_Id) then
28674 Arg_Nam => Arg_Nam,
28675 From_Aspect => True);
28677 if Present (Arg) then
28678 Preanalyze_Assert_Expression
28679 (Expression (Arg), Standard_Boolean);
28683 Arg := Test_Case_Arg (N, Arg_Nam);
28685 if Present (Arg) then
28686 Preanalyze_Assert_Expression (Expression (Arg), Standard_Boolean);
28688 end Preanalyze_Test_Case_Arg;
28692 Restore_Scope : Boolean := False;
28694 -- Start of processing for Analyze_Test_Case_In_Decl_Part
28697 -- Do not analyze the pragma multiple times
28699 if Is_Analyzed_Pragma (N) then
28703 -- Ensure that the formal parameters are visible when analyzing all
28704 -- clauses. This falls out of the general rule of aspects pertaining
28705 -- to subprogram declarations.
28707 if not In_Open_Scopes (Spec_Id) then
28708 Restore_Scope := True;
28709 Push_Scope (Spec_Id);
28711 if Is_Generic_Subprogram (Spec_Id) then
28712 Install_Generic_Formals (Spec_Id);
28714 Install_Formals (Spec_Id);
28718 Preanalyze_Test_Case_Arg (Name_Requires);
28719 Preanalyze_Test_Case_Arg (Name_Ensures);
28721 if Restore_Scope then
28725 -- Currently it is not possible to inline pre/postconditions on a
28726 -- subprogram subject to pragma Inline_Always.
28728 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
28730 Set_Is_Analyzed_Pragma (N);
28731 end Analyze_Test_Case_In_Decl_Part;
28737 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is
28742 if Present (List) then
28743 Elmt := First_Elmt (List);
28744 while Present (Elmt) loop
28745 if Nkind (Node (Elmt)) = N_Defining_Identifier then
28748 Id := Entity_Of (Node (Elmt));
28751 if Id = Item_Id then
28762 -----------------------------------
28763 -- Build_Pragma_Check_Equivalent --
28764 -----------------------------------
28766 function Build_Pragma_Check_Equivalent
28768 Subp_Id : Entity_Id := Empty;
28769 Inher_Id : Entity_Id := Empty;
28770 Keep_Pragma_Id : Boolean := False) return Node_Id
28772 function Suppress_Reference (N : Node_Id) return Traverse_Result;
28773 -- Detect whether node N references a formal parameter subject to
28774 -- pragma Unreferenced. If this is the case, set Comes_From_Source
28775 -- to False to suppress the generation of a reference when analyzing
28778 ------------------------
28779 -- Suppress_Reference --
28780 ------------------------
28782 function Suppress_Reference (N : Node_Id) return Traverse_Result is
28783 Formal : Entity_Id;
28786 if Is_Entity_Name (N) and then Present (Entity (N)) then
28787 Formal := Entity (N);
28789 -- The formal parameter is subject to pragma Unreferenced. Prevent
28790 -- the generation of references by resetting the Comes_From_Source
28793 if Is_Formal (Formal)
28794 and then Has_Pragma_Unreferenced (Formal)
28796 Set_Comes_From_Source (N, False);
28801 end Suppress_Reference;
28803 procedure Suppress_References is
28804 new Traverse_Proc (Suppress_Reference);
28808 Loc : constant Source_Ptr := Sloc (Prag);
28809 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
28810 Check_Prag : Node_Id;
28814 Needs_Wrapper : Boolean;
28815 pragma Unreferenced (Needs_Wrapper);
28817 -- Start of processing for Build_Pragma_Check_Equivalent
28820 -- When the pre- or postcondition is inherited, map the formals of the
28821 -- inherited subprogram to those of the current subprogram. In addition,
28822 -- map primitive operations of the parent type into the corresponding
28823 -- primitive operations of the descendant.
28825 if Present (Inher_Id) then
28826 pragma Assert (Present (Subp_Id));
28828 Update_Primitives_Mapping (Inher_Id, Subp_Id);
28830 -- Use generic machinery to copy inherited pragma, as if it were an
28831 -- instantiation, resetting source locations appropriately, so that
28832 -- expressions inside the inherited pragma use chained locations.
28833 -- This is used in particular in GNATprove to locate precisely
28834 -- messages on a given inherited pragma.
28836 Set_Copied_Sloc_For_Inherited_Pragma
28837 (Unit_Declaration_Node (Subp_Id), Inher_Id);
28838 Check_Prag := New_Copy_Tree (Source => Prag);
28840 -- Build the inherited class-wide condition
28842 Build_Class_Wide_Expression
28843 (Prag => Check_Prag,
28845 Par_Subp => Inher_Id,
28846 Adjust_Sloc => True,
28847 Needs_Wrapper => Needs_Wrapper);
28849 -- If not an inherited condition simply copy the original pragma
28852 Check_Prag := New_Copy_Tree (Source => Prag);
28855 -- Mark the pragma as being internally generated and reset the Analyzed
28858 Set_Analyzed (Check_Prag, False);
28859 Set_Comes_From_Source (Check_Prag, False);
28861 -- The tree of the original pragma may contain references to the
28862 -- formal parameters of the related subprogram. At the same time
28863 -- the corresponding body may mark the formals as unreferenced:
28865 -- procedure Proc (Formal : ...)
28866 -- with Pre => Formal ...;
28868 -- procedure Proc (Formal : ...) is
28869 -- pragma Unreferenced (Formal);
28872 -- This creates problems because all pragma Check equivalents are
28873 -- analyzed at the end of the body declarations. Since all source
28874 -- references have already been accounted for, reset any references
28875 -- to such formals in the generated pragma Check equivalent.
28877 Suppress_References (Check_Prag);
28879 if Present (Corresponding_Aspect (Prag)) then
28880 Nam := Chars (Identifier (Corresponding_Aspect (Prag)));
28885 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
28886 -- the copied pragma in the newly created pragma, convert the copy into
28887 -- pragma Check by correcting the name and adding a check_kind argument.
28889 if not Keep_Pragma_Id then
28890 Set_Class_Present (Check_Prag, False);
28892 Set_Pragma_Identifier
28893 (Check_Prag, Make_Identifier (Loc, Name_Check));
28895 Prepend_To (Pragma_Argument_Associations (Check_Prag),
28896 Make_Pragma_Argument_Association (Loc,
28897 Expression => Make_Identifier (Loc, Nam)));
28900 -- Update the error message when the pragma is inherited
28902 if Present (Inher_Id) then
28903 Msg_Arg := Last (Pragma_Argument_Associations (Check_Prag));
28905 if Chars (Msg_Arg) = Name_Message then
28906 String_To_Name_Buffer (Strval (Expression (Msg_Arg)));
28908 -- Insert "inherited" to improve the error message
28910 if Name_Buffer (1 .. 8) = "failed p" then
28911 Insert_Str_In_Name_Buffer ("inherited ", 8);
28912 Set_Strval (Expression (Msg_Arg), String_From_Name_Buffer);
28918 end Build_Pragma_Check_Equivalent;
28920 -----------------------------
28921 -- Check_Applicable_Policy --
28922 -----------------------------
28924 procedure Check_Applicable_Policy (N : Node_Id) is
28928 Ename : constant Name_Id := Original_Aspect_Pragma_Name (N);
28931 -- No effect if not valid assertion kind name
28933 if not Is_Valid_Assertion_Kind (Ename) then
28937 -- Loop through entries in check policy list
28939 PP := Opt.Check_Policy_List;
28940 while Present (PP) loop
28942 PPA : constant List_Id := Pragma_Argument_Associations (PP);
28943 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
28947 or else Pnm = Name_Assertion
28948 or else (Pnm = Name_Statement_Assertions
28949 and then Nam_In (Ename, Name_Assert,
28950 Name_Assert_And_Cut,
28952 Name_Loop_Invariant,
28953 Name_Loop_Variant))
28955 Policy := Chars (Get_Pragma_Arg (Last (PPA)));
28961 -- In CodePeer mode and GNATprove mode, we need to
28962 -- consider all assertions, unless they are disabled.
28963 -- Force Is_Checked on ignored assertions, in particular
28964 -- because transformations of the AST may depend on
28965 -- assertions being checked (e.g. the translation of
28966 -- attribute 'Loop_Entry).
28968 if CodePeer_Mode or GNATprove_Mode then
28969 Set_Is_Checked (N, True);
28970 Set_Is_Ignored (N, False);
28972 Set_Is_Checked (N, False);
28973 Set_Is_Ignored (N, True);
28979 Set_Is_Checked (N, True);
28980 Set_Is_Ignored (N, False);
28982 when Name_Disable =>
28983 Set_Is_Ignored (N, True);
28984 Set_Is_Checked (N, False);
28985 Set_Is_Disabled (N, True);
28987 -- That should be exhaustive, the null here is a defence
28988 -- against a malformed tree from previous errors.
28997 PP := Next_Pragma (PP);
29001 -- If there are no specific entries that matched, then we let the
29002 -- setting of assertions govern. Note that this provides the needed
29003 -- compatibility with the RM for the cases of assertion, invariant,
29004 -- precondition, predicate, and postcondition. Note also that
29005 -- Assertions_Enabled is forced in CodePeer mode and GNATprove mode.
29007 if Assertions_Enabled then
29008 Set_Is_Checked (N, True);
29009 Set_Is_Ignored (N, False);
29011 Set_Is_Checked (N, False);
29012 Set_Is_Ignored (N, True);
29014 end Check_Applicable_Policy;
29016 -------------------------------
29017 -- Check_External_Properties --
29018 -------------------------------
29020 procedure Check_External_Properties
29028 -- All properties enabled
29030 if AR and AW and ER and EW then
29033 -- Async_Readers + Effective_Writes
29034 -- Async_Readers + Async_Writers + Effective_Writes
29036 elsif AR and EW and not ER then
29039 -- Async_Writers + Effective_Reads
29040 -- Async_Readers + Async_Writers + Effective_Reads
29042 elsif AW and ER and not EW then
29045 -- Async_Readers + Async_Writers
29047 elsif AR and AW and not ER and not EW then
29052 elsif AR and not AW and not ER and not EW then
29057 elsif AW and not AR and not ER and not EW then
29062 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
29065 end Check_External_Properties;
29071 function Check_Kind (Nam : Name_Id) return Name_Id is
29075 -- Loop through entries in check policy list
29077 PP := Opt.Check_Policy_List;
29078 while Present (PP) loop
29080 PPA : constant List_Id := Pragma_Argument_Associations (PP);
29081 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
29085 or else (Pnm = Name_Assertion
29086 and then Is_Valid_Assertion_Kind (Nam))
29087 or else (Pnm = Name_Statement_Assertions
29088 and then Nam_In (Nam, Name_Assert,
29089 Name_Assert_And_Cut,
29091 Name_Loop_Invariant,
29092 Name_Loop_Variant))
29094 case (Chars (Get_Pragma_Arg (Last (PPA)))) is
29103 return Name_Ignore;
29105 when Name_Disable =>
29106 return Name_Disable;
29109 raise Program_Error;
29113 PP := Next_Pragma (PP);
29118 -- If there are no specific entries that matched, then we let the
29119 -- setting of assertions govern. Note that this provides the needed
29120 -- compatibility with the RM for the cases of assertion, invariant,
29121 -- precondition, predicate, and postcondition.
29123 if Assertions_Enabled then
29126 return Name_Ignore;
29130 ---------------------------
29131 -- Check_Missing_Part_Of --
29132 ---------------------------
29134 procedure Check_Missing_Part_Of (Item_Id : Entity_Id) is
29135 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean;
29136 -- Determine whether a package denoted by Pack_Id declares at least one
29139 -----------------------
29140 -- Has_Visible_State --
29141 -----------------------
29143 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean is
29144 Item_Id : Entity_Id;
29147 -- Traverse the entity chain of the package trying to find at least
29148 -- one visible abstract state, variable or a package [instantiation]
29149 -- that declares a visible state.
29151 Item_Id := First_Entity (Pack_Id);
29152 while Present (Item_Id)
29153 and then not In_Private_Part (Item_Id)
29155 -- Do not consider internally generated items
29157 if not Comes_From_Source (Item_Id) then
29160 -- Do not consider generic formals or their corresponding actuals
29161 -- because they are not part of a visible state. Note that both
29162 -- entities are marked as hidden.
29164 elsif Is_Hidden (Item_Id) then
29167 -- A visible state has been found. Note that constants are not
29168 -- considered here because it is not possible to determine whether
29169 -- they depend on variable input. This check is left to the SPARK
29172 elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
29175 -- Recursively peek into nested packages and instantiations
29177 elsif Ekind (Item_Id) = E_Package
29178 and then Has_Visible_State (Item_Id)
29183 Next_Entity (Item_Id);
29187 end Has_Visible_State;
29191 Pack_Id : Entity_Id;
29192 Placement : State_Space_Kind;
29194 -- Start of processing for Check_Missing_Part_Of
29197 -- Do not consider abstract states, variables or package instantiations
29198 -- coming from an instance as those always inherit the Part_Of indicator
29199 -- of the instance itself.
29201 if In_Instance then
29204 -- Do not consider internally generated entities as these can never
29205 -- have a Part_Of indicator.
29207 elsif not Comes_From_Source (Item_Id) then
29210 -- Perform these checks only when SPARK_Mode is enabled as they will
29211 -- interfere with standard Ada rules and produce false positives.
29213 elsif SPARK_Mode /= On then
29216 -- Do not consider constants, because the compiler cannot accurately
29217 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
29218 -- act as a hidden state of a package.
29220 elsif Ekind (Item_Id) = E_Constant then
29224 -- Find where the abstract state, variable or package instantiation
29225 -- lives with respect to the state space.
29227 Find_Placement_In_State_Space
29228 (Item_Id => Item_Id,
29229 Placement => Placement,
29230 Pack_Id => Pack_Id);
29232 -- Items that appear in a non-package construct (subprogram, block, etc)
29233 -- do not require a Part_Of indicator because they can never act as a
29236 if Placement = Not_In_Package then
29239 -- An item declared in the body state space of a package always act as a
29240 -- constituent and does not need explicit Part_Of indicator.
29242 elsif Placement = Body_State_Space then
29245 -- In general an item declared in the visible state space of a package
29246 -- does not require a Part_Of indicator. The only exception is when the
29247 -- related package is a nongeneric private child unit, in which case
29248 -- Part_Of must denote a state in the parent unit or in one of its
29251 elsif Placement = Visible_State_Space then
29252 if Is_Child_Unit (Pack_Id)
29253 and then not Is_Generic_Unit (Pack_Id)
29254 and then Is_Private_Descendant (Pack_Id)
29256 -- A package instantiation does not need a Part_Of indicator when
29257 -- the related generic template has no visible state.
29259 if Ekind (Item_Id) = E_Package
29260 and then Is_Generic_Instance (Item_Id)
29261 and then not Has_Visible_State (Item_Id)
29265 -- All other cases require Part_Of
29269 ("indicator Part_Of is required in this context "
29270 & "(SPARK RM 7.2.6(3))", Item_Id);
29271 Error_Msg_Name_1 := Chars (Pack_Id);
29273 ("\& is declared in the visible part of private child "
29274 & "unit %", Item_Id);
29278 -- When the item appears in the private state space of a package, it
29279 -- must be a part of some state declared by the said package.
29281 else pragma Assert (Placement = Private_State_Space);
29283 -- The related package does not declare a state, the item cannot act
29284 -- as a Part_Of constituent.
29286 if No (Get_Pragma (Pack_Id, Pragma_Abstract_State)) then
29289 -- A package instantiation does not need a Part_Of indicator when the
29290 -- related generic template has no visible state.
29292 elsif Ekind (Item_Id) = E_Package
29293 and then Is_Generic_Instance (Item_Id)
29294 and then not Has_Visible_State (Item_Id)
29298 -- All other cases require Part_Of
29302 ("indicator Part_Of is required in this context "
29303 & "(SPARK RM 7.2.6(2))", Item_Id);
29304 Error_Msg_Name_1 := Chars (Pack_Id);
29306 ("\& is declared in the private part of package %", Item_Id);
29309 end Check_Missing_Part_Of;
29311 ---------------------------------------------------
29312 -- Check_Postcondition_Use_In_Inlined_Subprogram --
29313 ---------------------------------------------------
29315 procedure Check_Postcondition_Use_In_Inlined_Subprogram
29317 Spec_Id : Entity_Id)
29320 if Warn_On_Redundant_Constructs
29321 and then Has_Pragma_Inline_Always (Spec_Id)
29322 and then Assertions_Enabled
29324 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
29326 if From_Aspect_Specification (Prag) then
29328 ("aspect % not enforced on inlined subprogram &?r?",
29329 Corresponding_Aspect (Prag), Spec_Id);
29332 ("pragma % not enforced on inlined subprogram &?r?",
29336 end Check_Postcondition_Use_In_Inlined_Subprogram;
29338 -------------------------------------
29339 -- Check_State_And_Constituent_Use --
29340 -------------------------------------
29342 procedure Check_State_And_Constituent_Use
29343 (States : Elist_Id;
29344 Constits : Elist_Id;
29347 Constit_Elmt : Elmt_Id;
29348 Constit_Id : Entity_Id;
29349 State_Id : Entity_Id;
29352 -- Nothing to do if there are no states or constituents
29354 if No (States) or else No (Constits) then
29358 -- Inspect the list of constituents and try to determine whether its
29359 -- encapsulating state is in list States.
29361 Constit_Elmt := First_Elmt (Constits);
29362 while Present (Constit_Elmt) loop
29363 Constit_Id := Node (Constit_Elmt);
29365 -- Determine whether the constituent is part of an encapsulating
29366 -- state that appears in the same context and if this is the case,
29367 -- emit an error (SPARK RM 7.2.6(7)).
29369 State_Id := Find_Encapsulating_State (States, Constit_Id);
29371 if Present (State_Id) then
29372 Error_Msg_Name_1 := Chars (Constit_Id);
29374 ("cannot mention state & and its constituent % in the same "
29375 & "context", Context, State_Id);
29379 Next_Elmt (Constit_Elmt);
29381 end Check_State_And_Constituent_Use;
29383 ---------------------------------------------
29384 -- Collect_Inherited_Class_Wide_Conditions --
29385 ---------------------------------------------
29387 procedure Collect_Inherited_Class_Wide_Conditions (Subp : Entity_Id) is
29388 Parent_Subp : constant Entity_Id :=
29389 Ultimate_Alias (Overridden_Operation (Subp));
29390 -- The Overridden_Operation may itself be inherited and as such have no
29391 -- explicit contract.
29393 Prags : constant Node_Id := Contract (Parent_Subp);
29394 In_Spec_Expr : Boolean := In_Spec_Expression;
29395 Installed : Boolean;
29397 New_Prag : Node_Id;
29400 Installed := False;
29402 -- Iterate over the contract of the overridden subprogram to find all
29403 -- inherited class-wide pre- and postconditions.
29405 if Present (Prags) then
29406 Prag := Pre_Post_Conditions (Prags);
29408 while Present (Prag) loop
29409 if Nam_In (Pragma_Name_Unmapped (Prag),
29410 Name_Precondition, Name_Postcondition)
29411 and then Class_Present (Prag)
29413 -- The generated pragma must be analyzed in the context of
29414 -- the subprogram, to make its formals visible. In addition,
29415 -- we must inhibit freezing and full analysis because the
29416 -- controlling type of the subprogram is not frozen yet, and
29417 -- may have further primitives.
29419 if not Installed then
29422 Install_Formals (Subp);
29423 In_Spec_Expr := In_Spec_Expression;
29424 In_Spec_Expression := True;
29428 Build_Pragma_Check_Equivalent
29429 (Prag, Subp, Parent_Subp, Keep_Pragma_Id => True);
29431 Insert_After (Unit_Declaration_Node (Subp), New_Prag);
29432 Preanalyze (New_Prag);
29434 -- Prevent further analysis in subsequent processing of the
29435 -- current list of declarations
29437 Set_Analyzed (New_Prag);
29440 Prag := Next_Pragma (Prag);
29444 In_Spec_Expression := In_Spec_Expr;
29448 end Collect_Inherited_Class_Wide_Conditions;
29450 ---------------------------------------
29451 -- Collect_Subprogram_Inputs_Outputs --
29452 ---------------------------------------
29454 procedure Collect_Subprogram_Inputs_Outputs
29455 (Subp_Id : Entity_Id;
29456 Synthesize : Boolean := False;
29457 Subp_Inputs : in out Elist_Id;
29458 Subp_Outputs : in out Elist_Id;
29459 Global_Seen : out Boolean)
29461 procedure Collect_Dependency_Clause (Clause : Node_Id);
29462 -- Collect all relevant items from a dependency clause
29464 procedure Collect_Global_List
29466 Mode : Name_Id := Name_Input);
29467 -- Collect all relevant items from a global list
29469 -------------------------------
29470 -- Collect_Dependency_Clause --
29471 -------------------------------
29473 procedure Collect_Dependency_Clause (Clause : Node_Id) is
29474 procedure Collect_Dependency_Item
29476 Is_Input : Boolean);
29477 -- Add an item to the proper subprogram input or output collection
29479 -----------------------------
29480 -- Collect_Dependency_Item --
29481 -----------------------------
29483 procedure Collect_Dependency_Item
29485 Is_Input : Boolean)
29490 -- Nothing to collect when the item is null
29492 if Nkind (Item) = N_Null then
29495 -- Ditto for attribute 'Result
29497 elsif Is_Attribute_Result (Item) then
29500 -- Multiple items appear as an aggregate
29502 elsif Nkind (Item) = N_Aggregate then
29503 Extra := First (Expressions (Item));
29504 while Present (Extra) loop
29505 Collect_Dependency_Item (Extra, Is_Input);
29509 -- Otherwise this is a solitary item
29513 Append_New_Elmt (Item, Subp_Inputs);
29515 Append_New_Elmt (Item, Subp_Outputs);
29518 end Collect_Dependency_Item;
29520 -- Start of processing for Collect_Dependency_Clause
29523 if Nkind (Clause) = N_Null then
29526 -- A dependency clause appears as component association
29528 elsif Nkind (Clause) = N_Component_Association then
29529 Collect_Dependency_Item
29530 (Item => Expression (Clause),
29533 Collect_Dependency_Item
29534 (Item => First (Choices (Clause)),
29535 Is_Input => False);
29537 -- To accommodate partial decoration of disabled SPARK features, this
29538 -- routine may be called with illegal input. If this is the case, do
29539 -- not raise Program_Error.
29544 end Collect_Dependency_Clause;
29546 -------------------------
29547 -- Collect_Global_List --
29548 -------------------------
29550 procedure Collect_Global_List
29552 Mode : Name_Id := Name_Input)
29554 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id);
29555 -- Add an item to the proper subprogram input or output collection
29557 -------------------------
29558 -- Collect_Global_Item --
29559 -------------------------
29561 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is
29563 if Nam_In (Mode, Name_In_Out, Name_Input) then
29564 Append_New_Elmt (Item, Subp_Inputs);
29567 if Nam_In (Mode, Name_In_Out, Name_Output) then
29568 Append_New_Elmt (Item, Subp_Outputs);
29570 end Collect_Global_Item;
29577 -- Start of processing for Collect_Global_List
29580 if Nkind (List) = N_Null then
29583 -- Single global item declaration
29585 elsif Nkind_In (List, N_Expanded_Name,
29587 N_Selected_Component)
29589 Collect_Global_Item (List, Mode);
29591 -- Simple global list or moded global list declaration
29593 elsif Nkind (List) = N_Aggregate then
29594 if Present (Expressions (List)) then
29595 Item := First (Expressions (List));
29596 while Present (Item) loop
29597 Collect_Global_Item (Item, Mode);
29602 Assoc := First (Component_Associations (List));
29603 while Present (Assoc) loop
29604 Collect_Global_List
29605 (List => Expression (Assoc),
29606 Mode => Chars (First (Choices (Assoc))));
29611 -- To accommodate partial decoration of disabled SPARK features, this
29612 -- routine may be called with illegal input. If this is the case, do
29613 -- not raise Program_Error.
29618 end Collect_Global_List;
29625 Formal : Entity_Id;
29627 Spec_Id : Entity_Id := Empty;
29628 Subp_Decl : Node_Id;
29631 -- Start of processing for Collect_Subprogram_Inputs_Outputs
29634 Global_Seen := False;
29636 -- Process all formal parameters of entries, [generic] subprograms, and
29639 if Ekind_In (Subp_Id, E_Entry,
29642 E_Generic_Function,
29643 E_Generic_Procedure,
29647 Subp_Decl := Unit_Declaration_Node (Subp_Id);
29648 Spec_Id := Unique_Defining_Entity (Subp_Decl);
29650 -- Process all formal parameters
29652 Formal := First_Entity (Spec_Id);
29653 while Present (Formal) loop
29654 if Ekind_In (Formal, E_In_Out_Parameter, E_In_Parameter) then
29655 Append_New_Elmt (Formal, Subp_Inputs);
29658 if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then
29659 Append_New_Elmt (Formal, Subp_Outputs);
29661 -- Out parameters can act as inputs when the related type is
29662 -- tagged, unconstrained array, unconstrained record, or record
29663 -- with unconstrained components.
29665 if Ekind (Formal) = E_Out_Parameter
29666 and then Is_Unconstrained_Or_Tagged_Item (Formal)
29668 Append_New_Elmt (Formal, Subp_Inputs);
29672 Next_Entity (Formal);
29675 -- Otherwise the input denotes a task type, a task body, or the
29676 -- anonymous object created for a single task type.
29678 elsif Ekind_In (Subp_Id, E_Task_Type, E_Task_Body)
29679 or else Is_Single_Task_Object (Subp_Id)
29681 Subp_Decl := Declaration_Node (Subp_Id);
29682 Spec_Id := Unique_Defining_Entity (Subp_Decl);
29685 -- When processing an entry, subprogram or task body, look for pragmas
29686 -- Refined_Depends and Refined_Global as they specify the inputs and
29689 if Is_Entry_Body (Subp_Id)
29690 or else Ekind_In (Subp_Id, E_Subprogram_Body, E_Task_Body)
29692 Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends);
29693 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global);
29695 -- Subprogram declaration or stand-alone body case, look for pragmas
29696 -- Depends and Global
29699 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
29700 Global := Get_Pragma (Spec_Id, Pragma_Global);
29703 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
29704 -- because it provides finer granularity of inputs and outputs.
29706 if Present (Global) then
29707 Global_Seen := True;
29708 Collect_Global_List (Expression (Get_Argument (Global, Spec_Id)));
29710 -- When the related subprogram lacks pragma [Refined_]Global, fall back
29711 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
29712 -- the inputs and outputs from [Refined_]Depends.
29714 elsif Synthesize and then Present (Depends) then
29715 Clauses := Expression (Get_Argument (Depends, Spec_Id));
29717 -- Multiple dependency clauses appear as an aggregate
29719 if Nkind (Clauses) = N_Aggregate then
29720 Clause := First (Component_Associations (Clauses));
29721 while Present (Clause) loop
29722 Collect_Dependency_Clause (Clause);
29726 -- Otherwise this is a single dependency clause
29729 Collect_Dependency_Clause (Clauses);
29733 -- The current instance of a protected type acts as a formal parameter
29734 -- of mode IN for functions and IN OUT for entries and procedures
29735 -- (SPARK RM 6.1.4).
29737 if Ekind (Scope (Spec_Id)) = E_Protected_Type then
29738 Typ := Scope (Spec_Id);
29740 -- Use the anonymous object when the type is single protected
29742 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
29743 Typ := Anonymous_Object (Typ);
29746 Append_New_Elmt (Typ, Subp_Inputs);
29748 if Ekind_In (Spec_Id, E_Entry, E_Entry_Family, E_Procedure) then
29749 Append_New_Elmt (Typ, Subp_Outputs);
29752 -- The current instance of a task type acts as a formal parameter of
29753 -- mode IN OUT (SPARK RM 6.1.4).
29755 elsif Ekind (Spec_Id) = E_Task_Type then
29758 -- Use the anonymous object when the type is single task
29760 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
29761 Typ := Anonymous_Object (Typ);
29764 Append_New_Elmt (Typ, Subp_Inputs);
29765 Append_New_Elmt (Typ, Subp_Outputs);
29767 elsif Is_Single_Task_Object (Spec_Id) then
29768 Append_New_Elmt (Spec_Id, Subp_Inputs);
29769 Append_New_Elmt (Spec_Id, Subp_Outputs);
29771 end Collect_Subprogram_Inputs_Outputs;
29773 ---------------------------
29774 -- Contract_Freeze_Error --
29775 ---------------------------
29777 procedure Contract_Freeze_Error
29778 (Contract_Id : Entity_Id;
29779 Freeze_Id : Entity_Id)
29782 Error_Msg_Name_1 := Chars (Contract_Id);
29783 Error_Msg_Sloc := Sloc (Freeze_Id);
29786 ("body & declared # freezes the contract of%", Contract_Id, Freeze_Id);
29788 ("\all contractual items must be declared before body #", Contract_Id);
29789 end Contract_Freeze_Error;
29791 ---------------------------------
29792 -- Delay_Config_Pragma_Analyze --
29793 ---------------------------------
29795 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
29797 return Nam_In (Pragma_Name_Unmapped (N),
29798 Name_Interrupt_State, Name_Priority_Specific_Dispatching);
29799 end Delay_Config_Pragma_Analyze;
29801 -----------------------
29802 -- Duplication_Error --
29803 -----------------------
29805 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id) is
29806 Prag_From_Asp : constant Boolean := From_Aspect_Specification (Prag);
29807 Prev_From_Asp : constant Boolean := From_Aspect_Specification (Prev);
29810 Error_Msg_Sloc := Sloc (Prev);
29811 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
29813 -- Emit a precise message to distinguish between source pragmas and
29814 -- pragmas generated from aspects. The ordering of the two pragmas is
29818 -- Prag -- duplicate
29820 -- No error is emitted when both pragmas come from aspects because this
29821 -- is already detected by the general aspect analysis mechanism.
29823 if Prag_From_Asp and Prev_From_Asp then
29825 elsif Prag_From_Asp then
29826 Error_Msg_N ("aspect % duplicates pragma declared #", Prag);
29827 elsif Prev_From_Asp then
29828 Error_Msg_N ("pragma % duplicates aspect declared #", Prag);
29830 Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
29832 end Duplication_Error;
29834 ------------------------------
29835 -- Find_Encapsulating_State --
29836 ------------------------------
29838 function Find_Encapsulating_State
29839 (States : Elist_Id;
29840 Constit_Id : Entity_Id) return Entity_Id
29842 State_Id : Entity_Id;
29845 -- Since a constituent may be part of a larger constituent set, climb
29846 -- the encapsulating state chain looking for a state that appears in
29849 State_Id := Encapsulating_State (Constit_Id);
29850 while Present (State_Id) loop
29851 if Contains (States, State_Id) then
29855 State_Id := Encapsulating_State (State_Id);
29859 end Find_Encapsulating_State;
29861 --------------------------
29862 -- Find_Related_Context --
29863 --------------------------
29865 function Find_Related_Context
29867 Do_Checks : Boolean := False) return Node_Id
29872 Stmt := Prev (Prag);
29873 while Present (Stmt) loop
29875 -- Skip prior pragmas, but check for duplicates
29877 if Nkind (Stmt) = N_Pragma then
29879 and then Pragma_Name (Stmt) = Pragma_Name (Prag)
29886 -- Skip internally generated code
29888 elsif not Comes_From_Source (Stmt) then
29890 -- The anonymous object created for a single concurrent type is a
29891 -- suitable context.
29893 if Nkind (Stmt) = N_Object_Declaration
29894 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
29899 -- Return the current source construct
29909 end Find_Related_Context;
29911 --------------------------------------
29912 -- Find_Related_Declaration_Or_Body --
29913 --------------------------------------
29915 function Find_Related_Declaration_Or_Body
29917 Do_Checks : Boolean := False) return Node_Id
29919 Prag_Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
29921 procedure Expression_Function_Error;
29922 -- Emit an error concerning pragma Prag that illegaly applies to an
29923 -- expression function.
29925 -------------------------------
29926 -- Expression_Function_Error --
29927 -------------------------------
29929 procedure Expression_Function_Error is
29931 Error_Msg_Name_1 := Prag_Nam;
29933 -- Emit a precise message to distinguish between source pragmas and
29934 -- pragmas generated from aspects.
29936 if From_Aspect_Specification (Prag) then
29938 ("aspect % cannot apply to a stand alone expression function",
29942 ("pragma % cannot apply to a stand alone expression function",
29945 end Expression_Function_Error;
29949 Context : constant Node_Id := Parent (Prag);
29952 Look_For_Body : constant Boolean :=
29953 Nam_In (Prag_Nam, Name_Refined_Depends,
29954 Name_Refined_Global,
29956 Name_Refined_State);
29957 -- Refinement pragmas must be associated with a subprogram body [stub]
29959 -- Start of processing for Find_Related_Declaration_Or_Body
29962 Stmt := Prev (Prag);
29963 while Present (Stmt) loop
29965 -- Skip prior pragmas, but check for duplicates. Pragmas produced
29966 -- by splitting a complex pre/postcondition are not considered to
29969 if Nkind (Stmt) = N_Pragma then
29971 and then not Split_PPC (Stmt)
29972 and then Original_Aspect_Pragma_Name (Stmt) = Prag_Nam
29979 -- Emit an error when a refinement pragma appears on an expression
29980 -- function without a completion.
29983 and then Look_For_Body
29984 and then Nkind (Stmt) = N_Subprogram_Declaration
29985 and then Nkind (Original_Node (Stmt)) = N_Expression_Function
29986 and then not Has_Completion (Defining_Entity (Stmt))
29988 Expression_Function_Error;
29991 -- The refinement pragma applies to a subprogram body stub
29993 elsif Look_For_Body
29994 and then Nkind (Stmt) = N_Subprogram_Body_Stub
29998 -- Skip internally generated code
30000 elsif not Comes_From_Source (Stmt) then
30002 -- The anonymous object created for a single concurrent type is a
30003 -- suitable context.
30005 if Nkind (Stmt) = N_Object_Declaration
30006 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
30010 elsif Nkind (Stmt) = N_Subprogram_Declaration then
30012 -- The subprogram declaration is an internally generated spec
30013 -- for an expression function.
30015 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
30018 -- The subprogram declaration is an internally generated spec
30019 -- for a stand-alone subrogram body declared inside a protected
30022 elsif Present (Corresponding_Body (Stmt))
30023 and then Comes_From_Source (Corresponding_Body (Stmt))
30024 and then Is_Protected_Type (Current_Scope)
30028 -- The subprogram is actually an instance housed within an
30029 -- anonymous wrapper package.
30031 elsif Present (Generic_Parent (Specification (Stmt))) then
30034 -- Ada 2020: contract on formal subprogram
30036 elsif Is_Generic_Actual_Subprogram (Defining_Entity (Stmt))
30037 and then Ada_Version >= Ada_2020
30043 -- Return the current construct which is either a subprogram body,
30044 -- a subprogram declaration or is illegal.
30053 -- If we fall through, then the pragma was either the first declaration
30054 -- or it was preceded by other pragmas and no source constructs.
30056 -- The pragma is associated with a library-level subprogram
30058 if Nkind (Context) = N_Compilation_Unit_Aux then
30059 return Unit (Parent (Context));
30061 -- The pragma appears inside the declarations of an entry body
30063 elsif Nkind (Context) = N_Entry_Body then
30066 -- The pragma appears inside the statements of a subprogram body. This
30067 -- placement is the result of subprogram contract expansion.
30069 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then
30070 return Parent (Context);
30072 -- The pragma appears inside the declarative part of a package body
30074 elsif Nkind (Context) = N_Package_Body then
30077 -- The pragma appears inside the declarative part of a subprogram body
30079 elsif Nkind (Context) = N_Subprogram_Body then
30082 -- The pragma appears inside the declarative part of a task body
30084 elsif Nkind (Context) = N_Task_Body then
30087 -- The pragma appears inside the visible part of a package specification
30089 elsif Nkind (Context) = N_Package_Specification then
30090 return Parent (Context);
30092 -- The pragma is a byproduct of aspect expansion, return the related
30093 -- context of the original aspect. This case has a lower priority as
30094 -- the above circuitry pinpoints precisely the related context.
30096 elsif Present (Corresponding_Aspect (Prag)) then
30097 return Parent (Corresponding_Aspect (Prag));
30099 -- No candidate subprogram [body] found
30104 end Find_Related_Declaration_Or_Body;
30106 ----------------------------------
30107 -- Find_Related_Package_Or_Body --
30108 ----------------------------------
30110 function Find_Related_Package_Or_Body
30112 Do_Checks : Boolean := False) return Node_Id
30114 Context : constant Node_Id := Parent (Prag);
30115 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
30119 Stmt := Prev (Prag);
30120 while Present (Stmt) loop
30122 -- Skip prior pragmas, but check for duplicates
30124 if Nkind (Stmt) = N_Pragma then
30125 if Do_Checks and then Pragma_Name (Stmt) = Prag_Nam then
30131 -- Skip internally generated code
30133 elsif not Comes_From_Source (Stmt) then
30134 if Nkind (Stmt) = N_Subprogram_Declaration then
30136 -- The subprogram declaration is an internally generated spec
30137 -- for an expression function.
30139 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
30142 -- The subprogram is actually an instance housed within an
30143 -- anonymous wrapper package.
30145 elsif Present (Generic_Parent (Specification (Stmt))) then
30150 -- Return the current source construct which is illegal
30159 -- If we fall through, then the pragma was either the first declaration
30160 -- or it was preceded by other pragmas and no source constructs.
30162 -- The pragma is associated with a package. The immediate context in
30163 -- this case is the specification of the package.
30165 if Nkind (Context) = N_Package_Specification then
30166 return Parent (Context);
30168 -- The pragma appears in the declarations of a package body
30170 elsif Nkind (Context) = N_Package_Body then
30173 -- The pragma appears in the statements of a package body
30175 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
30176 and then Nkind (Parent (Context)) = N_Package_Body
30178 return Parent (Context);
30180 -- The pragma is a byproduct of aspect expansion, return the related
30181 -- context of the original aspect. This case has a lower priority as
30182 -- the above circuitry pinpoints precisely the related context.
30184 elsif Present (Corresponding_Aspect (Prag)) then
30185 return Parent (Corresponding_Aspect (Prag));
30187 -- No candidate package [body] found
30192 end Find_Related_Package_Or_Body;
30198 function Get_Argument
30200 Context_Id : Entity_Id := Empty) return Node_Id
30202 Args : constant List_Id := Pragma_Argument_Associations (Prag);
30205 -- Use the expression of the original aspect when analyzing the template
30206 -- of a generic unit. In both cases the aspect's tree must be decorated
30207 -- to allow for ASIS queries or to save the global references in the
30208 -- generic context.
30210 if From_Aspect_Specification (Prag)
30211 and then (Present (Context_Id) and then Is_Generic_Unit (Context_Id))
30213 return Corresponding_Aspect (Prag);
30215 -- Otherwise use the expression of the pragma
30217 elsif Present (Args) then
30218 return First (Args);
30225 -------------------------
30226 -- Get_Base_Subprogram --
30227 -------------------------
30229 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
30231 -- Follow subprogram renaming chain
30233 if Is_Subprogram (Def_Id)
30234 and then Nkind (Parent (Declaration_Node (Def_Id))) =
30235 N_Subprogram_Renaming_Declaration
30236 and then Present (Alias (Def_Id))
30238 return Alias (Def_Id);
30242 end Get_Base_Subprogram;
30244 -----------------------
30245 -- Get_SPARK_Mode_Type --
30246 -----------------------
30248 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is
30250 if N = Name_On then
30252 elsif N = Name_Off then
30255 -- Any other argument is illegal. Assume that no SPARK mode applies to
30256 -- avoid potential cascaded errors.
30261 end Get_SPARK_Mode_Type;
30263 ------------------------------------
30264 -- Get_SPARK_Mode_From_Annotation --
30265 ------------------------------------
30267 function Get_SPARK_Mode_From_Annotation
30268 (N : Node_Id) return SPARK_Mode_Type
30273 if Nkind (N) = N_Aspect_Specification then
30274 Mode := Expression (N);
30276 else pragma Assert (Nkind (N) = N_Pragma);
30277 Mode := First (Pragma_Argument_Associations (N));
30279 if Present (Mode) then
30280 Mode := Get_Pragma_Arg (Mode);
30284 -- Aspect or pragma SPARK_Mode specifies an explicit mode
30286 if Present (Mode) then
30287 if Nkind (Mode) = N_Identifier then
30288 return Get_SPARK_Mode_Type (Chars (Mode));
30290 -- In case of a malformed aspect or pragma, return the default None
30296 -- Otherwise the lack of an expression defaults SPARK_Mode to On
30301 end Get_SPARK_Mode_From_Annotation;
30303 ---------------------------
30304 -- Has_Extra_Parentheses --
30305 ---------------------------
30307 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean is
30311 -- The aggregate should not have an expression list because a clause
30312 -- is always interpreted as a component association. The only way an
30313 -- expression list can sneak in is by adding extra parentheses around
30314 -- the individual clauses:
30316 -- Depends (Output => Input) -- proper form
30317 -- Depends ((Output => Input)) -- extra parentheses
30319 -- Since the extra parentheses are not allowed by the syntax of the
30320 -- pragma, flag them now to avoid emitting misleading errors down the
30323 if Nkind (Clause) = N_Aggregate
30324 and then Present (Expressions (Clause))
30326 Expr := First (Expressions (Clause));
30327 while Present (Expr) loop
30329 -- A dependency clause surrounded by extra parentheses appears
30330 -- as an aggregate of component associations with an optional
30331 -- Paren_Count set.
30333 if Nkind (Expr) = N_Aggregate
30334 and then Present (Component_Associations (Expr))
30337 ("dependency clause contains extra parentheses", Expr);
30339 -- Otherwise the expression is a malformed construct
30342 SPARK_Msg_N ("malformed dependency clause", Expr);
30352 end Has_Extra_Parentheses;
30358 procedure Initialize is
30361 Compile_Time_Warnings_Errors.Init;
30370 Dummy := Dummy + 1;
30373 -----------------------------
30374 -- Is_Config_Static_String --
30375 -----------------------------
30377 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
30379 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
30380 -- This is an internal recursive function that is just like the outer
30381 -- function except that it adds the string to the name buffer rather
30382 -- than placing the string in the name buffer.
30384 ------------------------------
30385 -- Add_Config_Static_String --
30386 ------------------------------
30388 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
30395 if Nkind (N) = N_Op_Concat then
30396 if Add_Config_Static_String (Left_Opnd (N)) then
30397 N := Right_Opnd (N);
30403 if Nkind (N) /= N_String_Literal then
30404 Error_Msg_N ("string literal expected for pragma argument", N);
30408 for J in 1 .. String_Length (Strval (N)) loop
30409 C := Get_String_Char (Strval (N), J);
30411 if not In_Character_Range (C) then
30413 ("string literal contains invalid wide character",
30414 Sloc (N) + 1 + Source_Ptr (J));
30418 Add_Char_To_Name_Buffer (Get_Character (C));
30423 end Add_Config_Static_String;
30425 -- Start of processing for Is_Config_Static_String
30430 return Add_Config_Static_String (Arg);
30431 end Is_Config_Static_String;
30433 -------------------------------
30434 -- Is_Elaboration_SPARK_Mode --
30435 -------------------------------
30437 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is
30440 (Nkind (N) = N_Pragma
30441 and then Pragma_Name (N) = Name_SPARK_Mode
30442 and then Is_List_Member (N));
30444 -- Pragma SPARK_Mode affects the elaboration of a package body when it
30445 -- appears in the statement part of the body.
30448 Present (Parent (N))
30449 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
30450 and then List_Containing (N) = Statements (Parent (N))
30451 and then Present (Parent (Parent (N)))
30452 and then Nkind (Parent (Parent (N))) = N_Package_Body;
30453 end Is_Elaboration_SPARK_Mode;
30455 -----------------------
30456 -- Is_Enabled_Pragma --
30457 -----------------------
30459 function Is_Enabled_Pragma (Prag : Node_Id) return Boolean is
30463 if Present (Prag) then
30464 Arg := First (Pragma_Argument_Associations (Prag));
30466 if Present (Arg) then
30467 return Is_True (Expr_Value (Get_Pragma_Arg (Arg)));
30469 -- The lack of a Boolean argument automatically enables the pragma
30475 -- The pragma is missing, therefore it is not enabled
30480 end Is_Enabled_Pragma;
30482 -----------------------------------------
30483 -- Is_Non_Significant_Pragma_Reference --
30484 -----------------------------------------
30486 -- This function makes use of the following static table which indicates
30487 -- whether appearance of some name in a given pragma is to be considered
30488 -- as a reference for the purposes of warnings about unreferenced objects.
30490 -- -1 indicates that appearence in any argument is significant
30491 -- 0 indicates that appearance in any argument is not significant
30492 -- +n indicates that appearance as argument n is significant, but all
30493 -- other arguments are not significant
30494 -- 9n arguments from n on are significant, before n insignificant
30496 Sig_Flags : constant array (Pragma_Id) of Int :=
30497 (Pragma_Abort_Defer => -1,
30498 Pragma_Abstract_State => -1,
30499 Pragma_Ada_83 => -1,
30500 Pragma_Ada_95 => -1,
30501 Pragma_Ada_05 => -1,
30502 Pragma_Ada_2005 => -1,
30503 Pragma_Ada_12 => -1,
30504 Pragma_Ada_2012 => -1,
30505 Pragma_Ada_2020 => -1,
30506 Pragma_Aggregate_Individually_Assign => 0,
30507 Pragma_All_Calls_Remote => -1,
30508 Pragma_Allow_Integer_Address => -1,
30509 Pragma_Annotate => 93,
30510 Pragma_Assert => -1,
30511 Pragma_Assert_And_Cut => -1,
30512 Pragma_Assertion_Policy => 0,
30513 Pragma_Assume => -1,
30514 Pragma_Assume_No_Invalid_Values => 0,
30515 Pragma_Async_Readers => 0,
30516 Pragma_Async_Writers => 0,
30517 Pragma_Asynchronous => 0,
30518 Pragma_Atomic => 0,
30519 Pragma_Atomic_Components => 0,
30520 Pragma_Attach_Handler => -1,
30521 Pragma_Attribute_Definition => 92,
30522 Pragma_Check => -1,
30523 Pragma_Check_Float_Overflow => 0,
30524 Pragma_Check_Name => 0,
30525 Pragma_Check_Policy => 0,
30526 Pragma_CPP_Class => 0,
30527 Pragma_CPP_Constructor => 0,
30528 Pragma_CPP_Virtual => 0,
30529 Pragma_CPP_Vtable => 0,
30531 Pragma_C_Pass_By_Copy => 0,
30532 Pragma_Comment => -1,
30533 Pragma_Common_Object => 0,
30534 Pragma_Compile_Time_Error => -1,
30535 Pragma_Compile_Time_Warning => -1,
30536 Pragma_Compiler_Unit => -1,
30537 Pragma_Compiler_Unit_Warning => -1,
30538 Pragma_Complete_Representation => 0,
30539 Pragma_Complex_Representation => 0,
30540 Pragma_Component_Alignment => 0,
30541 Pragma_Constant_After_Elaboration => 0,
30542 Pragma_Contract_Cases => -1,
30543 Pragma_Controlled => 0,
30544 Pragma_Convention => 0,
30545 Pragma_Convention_Identifier => 0,
30546 Pragma_Deadline_Floor => -1,
30547 Pragma_Debug => -1,
30548 Pragma_Debug_Policy => 0,
30549 Pragma_Detect_Blocking => 0,
30550 Pragma_Default_Initial_Condition => -1,
30551 Pragma_Default_Scalar_Storage_Order => 0,
30552 Pragma_Default_Storage_Pool => 0,
30553 Pragma_Depends => -1,
30554 Pragma_Disable_Atomic_Synchronization => 0,
30555 Pragma_Discard_Names => 0,
30556 Pragma_Dispatching_Domain => -1,
30557 Pragma_Effective_Reads => 0,
30558 Pragma_Effective_Writes => 0,
30559 Pragma_Elaborate => 0,
30560 Pragma_Elaborate_All => 0,
30561 Pragma_Elaborate_Body => 0,
30562 Pragma_Elaboration_Checks => 0,
30563 Pragma_Eliminate => 0,
30564 Pragma_Enable_Atomic_Synchronization => 0,
30565 Pragma_Export => -1,
30566 Pragma_Export_Function => -1,
30567 Pragma_Export_Object => -1,
30568 Pragma_Export_Procedure => -1,
30569 Pragma_Export_Value => -1,
30570 Pragma_Export_Valued_Procedure => -1,
30571 Pragma_Extend_System => -1,
30572 Pragma_Extensions_Allowed => 0,
30573 Pragma_Extensions_Visible => 0,
30574 Pragma_External => -1,
30575 Pragma_Favor_Top_Level => 0,
30576 Pragma_External_Name_Casing => 0,
30577 Pragma_Fast_Math => 0,
30578 Pragma_Finalize_Storage_Only => 0,
30580 Pragma_Global => -1,
30581 Pragma_Ident => -1,
30582 Pragma_Ignore_Pragma => 0,
30583 Pragma_Implementation_Defined => -1,
30584 Pragma_Implemented => -1,
30585 Pragma_Implicit_Packing => 0,
30586 Pragma_Import => 93,
30587 Pragma_Import_Function => 0,
30588 Pragma_Import_Object => 0,
30589 Pragma_Import_Procedure => 0,
30590 Pragma_Import_Valued_Procedure => 0,
30591 Pragma_Independent => 0,
30592 Pragma_Independent_Components => 0,
30593 Pragma_Initial_Condition => -1,
30594 Pragma_Initialize_Scalars => 0,
30595 Pragma_Initializes => -1,
30596 Pragma_Inline => 0,
30597 Pragma_Inline_Always => 0,
30598 Pragma_Inline_Generic => 0,
30599 Pragma_Inspection_Point => -1,
30600 Pragma_Interface => 92,
30601 Pragma_Interface_Name => 0,
30602 Pragma_Interrupt_Handler => -1,
30603 Pragma_Interrupt_Priority => -1,
30604 Pragma_Interrupt_State => -1,
30605 Pragma_Invariant => -1,
30606 Pragma_Keep_Names => 0,
30607 Pragma_License => 0,
30608 Pragma_Link_With => -1,
30609 Pragma_Linker_Alias => -1,
30610 Pragma_Linker_Constructor => -1,
30611 Pragma_Linker_Destructor => -1,
30612 Pragma_Linker_Options => -1,
30613 Pragma_Linker_Section => -1,
30615 Pragma_Lock_Free => 0,
30616 Pragma_Locking_Policy => 0,
30617 Pragma_Loop_Invariant => -1,
30618 Pragma_Loop_Optimize => 0,
30619 Pragma_Loop_Variant => -1,
30620 Pragma_Machine_Attribute => -1,
30622 Pragma_Main_Storage => -1,
30623 Pragma_Max_Entry_Queue_Depth => 0,
30624 Pragma_Max_Entry_Queue_Length => 0,
30625 Pragma_Max_Queue_Length => 0,
30626 Pragma_Memory_Size => 0,
30627 Pragma_No_Body => 0,
30628 Pragma_No_Caching => 0,
30629 Pragma_No_Component_Reordering => -1,
30630 Pragma_No_Elaboration_Code_All => 0,
30631 Pragma_No_Heap_Finalization => 0,
30632 Pragma_No_Inline => 0,
30633 Pragma_No_Return => 0,
30634 Pragma_No_Run_Time => -1,
30635 Pragma_No_Strict_Aliasing => -1,
30636 Pragma_No_Tagged_Streams => 0,
30637 Pragma_Normalize_Scalars => 0,
30638 Pragma_Obsolescent => 0,
30639 Pragma_Optimize => 0,
30640 Pragma_Optimize_Alignment => 0,
30641 Pragma_Overflow_Mode => 0,
30642 Pragma_Overriding_Renamings => 0,
30643 Pragma_Ordered => 0,
30646 Pragma_Part_Of => 0,
30647 Pragma_Partition_Elaboration_Policy => 0,
30648 Pragma_Passive => 0,
30649 Pragma_Persistent_BSS => 0,
30650 Pragma_Polling => 0,
30651 Pragma_Prefix_Exception_Messages => 0,
30653 Pragma_Postcondition => -1,
30654 Pragma_Post_Class => -1,
30656 Pragma_Precondition => -1,
30657 Pragma_Predicate => -1,
30658 Pragma_Predicate_Failure => -1,
30659 Pragma_Preelaborable_Initialization => -1,
30660 Pragma_Preelaborate => 0,
30661 Pragma_Pre_Class => -1,
30662 Pragma_Priority => -1,
30663 Pragma_Priority_Specific_Dispatching => 0,
30664 Pragma_Profile => 0,
30665 Pragma_Profile_Warnings => 0,
30666 Pragma_Propagate_Exceptions => 0,
30667 Pragma_Provide_Shift_Operators => 0,
30668 Pragma_Psect_Object => 0,
30670 Pragma_Pure_Function => 0,
30671 Pragma_Queuing_Policy => 0,
30672 Pragma_Rational => 0,
30673 Pragma_Ravenscar => 0,
30674 Pragma_Refined_Depends => -1,
30675 Pragma_Refined_Global => -1,
30676 Pragma_Refined_Post => -1,
30677 Pragma_Refined_State => -1,
30678 Pragma_Relative_Deadline => 0,
30679 Pragma_Rename_Pragma => 0,
30680 Pragma_Remote_Access_Type => -1,
30681 Pragma_Remote_Call_Interface => -1,
30682 Pragma_Remote_Types => -1,
30683 Pragma_Restricted_Run_Time => 0,
30684 Pragma_Restriction_Warnings => 0,
30685 Pragma_Restrictions => 0,
30686 Pragma_Reviewable => -1,
30687 Pragma_Secondary_Stack_Size => -1,
30688 Pragma_Short_Circuit_And_Or => 0,
30689 Pragma_Share_Generic => 0,
30690 Pragma_Shared => 0,
30691 Pragma_Shared_Passive => 0,
30692 Pragma_Short_Descriptors => 0,
30693 Pragma_Simple_Storage_Pool_Type => 0,
30694 Pragma_Source_File_Name => 0,
30695 Pragma_Source_File_Name_Project => 0,
30696 Pragma_Source_Reference => 0,
30697 Pragma_SPARK_Mode => 0,
30698 Pragma_Storage_Size => -1,
30699 Pragma_Storage_Unit => 0,
30700 Pragma_Static_Elaboration_Desired => 0,
30701 Pragma_Stream_Convert => 0,
30702 Pragma_Style_Checks => 0,
30703 Pragma_Subtitle => 0,
30704 Pragma_Suppress => 0,
30705 Pragma_Suppress_Exception_Locations => 0,
30706 Pragma_Suppress_All => 0,
30707 Pragma_Suppress_Debug_Info => 0,
30708 Pragma_Suppress_Initialization => 0,
30709 Pragma_System_Name => 0,
30710 Pragma_Task_Dispatching_Policy => 0,
30711 Pragma_Task_Info => -1,
30712 Pragma_Task_Name => -1,
30713 Pragma_Task_Storage => -1,
30714 Pragma_Test_Case => -1,
30715 Pragma_Thread_Local_Storage => -1,
30716 Pragma_Time_Slice => -1,
30718 Pragma_Type_Invariant => -1,
30719 Pragma_Type_Invariant_Class => -1,
30720 Pragma_Unchecked_Union => 0,
30721 Pragma_Unevaluated_Use_Of_Old => 0,
30722 Pragma_Unimplemented_Unit => 0,
30723 Pragma_Universal_Aliasing => 0,
30724 Pragma_Universal_Data => 0,
30725 Pragma_Unmodified => 0,
30726 Pragma_Unreferenced => 0,
30727 Pragma_Unreferenced_Objects => 0,
30728 Pragma_Unreserve_All_Interrupts => 0,
30729 Pragma_Unsuppress => 0,
30730 Pragma_Unused => 0,
30731 Pragma_Use_VADS_Size => 0,
30732 Pragma_Validity_Checks => 0,
30733 Pragma_Volatile => 0,
30734 Pragma_Volatile_Components => 0,
30735 Pragma_Volatile_Full_Access => 0,
30736 Pragma_Volatile_Function => 0,
30737 Pragma_Warning_As_Error => 0,
30738 Pragma_Warnings => 0,
30739 Pragma_Weak_External => 0,
30740 Pragma_Wide_Character_Encoding => 0,
30741 Unknown_Pragma => 0);
30743 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
30749 function Arg_No return Nat;
30750 -- Returns an integer showing what argument we are in. A value of
30751 -- zero means we are not in any of the arguments.
30757 function Arg_No return Nat is
30762 A := First (Pragma_Argument_Associations (Parent (P)));
30776 -- Start of processing for Non_Significant_Pragma_Reference
30781 if Nkind (P) /= N_Pragma_Argument_Association then
30785 Id := Get_Pragma_Id (Parent (P));
30786 C := Sig_Flags (Id);
30801 return AN < (C - 90);
30807 end Is_Non_Significant_Pragma_Reference;
30809 ------------------------------
30810 -- Is_Pragma_String_Literal --
30811 ------------------------------
30813 -- This function returns true if the corresponding pragma argument is a
30814 -- static string expression. These are the only cases in which string
30815 -- literals can appear as pragma arguments. We also allow a string literal
30816 -- as the first argument to pragma Assert (although it will of course
30817 -- always generate a type error).
30819 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
30820 Pragn : constant Node_Id := Parent (Par);
30821 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
30822 Pname : constant Name_Id := Pragma_Name (Pragn);
30828 N := First (Assoc);
30835 if Pname = Name_Assert then
30838 elsif Pname = Name_Export then
30841 elsif Pname = Name_Ident then
30844 elsif Pname = Name_Import then
30847 elsif Pname = Name_Interface_Name then
30850 elsif Pname = Name_Linker_Alias then
30853 elsif Pname = Name_Linker_Section then
30856 elsif Pname = Name_Machine_Attribute then
30859 elsif Pname = Name_Source_File_Name then
30862 elsif Pname = Name_Source_Reference then
30865 elsif Pname = Name_Title then
30868 elsif Pname = Name_Subtitle then
30874 end Is_Pragma_String_Literal;
30876 ---------------------------
30877 -- Is_Private_SPARK_Mode --
30878 ---------------------------
30880 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is
30883 (Nkind (N) = N_Pragma
30884 and then Pragma_Name (N) = Name_SPARK_Mode
30885 and then Is_List_Member (N));
30887 -- For pragma SPARK_Mode to be private, it has to appear in the private
30888 -- declarations of a package.
30891 Present (Parent (N))
30892 and then Nkind (Parent (N)) = N_Package_Specification
30893 and then List_Containing (N) = Private_Declarations (Parent (N));
30894 end Is_Private_SPARK_Mode;
30896 -------------------------------------
30897 -- Is_Unconstrained_Or_Tagged_Item --
30898 -------------------------------------
30900 function Is_Unconstrained_Or_Tagged_Item
30901 (Item : Entity_Id) return Boolean
30903 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean;
30904 -- Determine whether record type Typ has at least one unconstrained
30907 ---------------------------------
30908 -- Has_Unconstrained_Component --
30909 ---------------------------------
30911 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is
30915 Comp := First_Component (Typ);
30916 while Present (Comp) loop
30917 if Is_Unconstrained_Or_Tagged_Item (Comp) then
30921 Next_Component (Comp);
30925 end Has_Unconstrained_Component;
30929 Typ : constant Entity_Id := Etype (Item);
30931 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
30934 if Is_Tagged_Type (Typ) then
30937 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
30940 elsif Is_Record_Type (Typ) then
30941 if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then
30944 return Has_Unconstrained_Component (Typ);
30947 elsif Is_Private_Type (Typ) and then Has_Discriminants (Typ) then
30953 end Is_Unconstrained_Or_Tagged_Item;
30955 -----------------------------
30956 -- Is_Valid_Assertion_Kind --
30957 -----------------------------
30959 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is
30966 | Name_Assertion_Policy
30967 | Name_Static_Predicate
30968 | Name_Dynamic_Predicate
30973 | Name_Type_Invariant
30974 | Name_uType_Invariant
30978 | Name_Assert_And_Cut
30980 | Name_Contract_Cases
30982 | Name_Default_Initial_Condition
30984 | Name_Initial_Condition
30987 | Name_Loop_Invariant
30988 | Name_Loop_Variant
30989 | Name_Postcondition
30990 | Name_Precondition
30992 | Name_Refined_Post
30993 | Name_Statement_Assertions
31000 end Is_Valid_Assertion_Kind;
31002 --------------------------------------
31003 -- Process_Compilation_Unit_Pragmas --
31004 --------------------------------------
31006 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
31008 -- A special check for pragma Suppress_All, a very strange DEC pragma,
31009 -- strange because it comes at the end of the unit. Rational has the
31010 -- same name for a pragma, but treats it as a program unit pragma, In
31011 -- GNAT we just decide to allow it anywhere at all. If it appeared then
31012 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
31013 -- node, and we insert a pragma Suppress (All_Checks) at the start of
31014 -- the context clause to ensure the correct processing.
31016 if Has_Pragma_Suppress_All (N) then
31017 Prepend_To (Context_Items (N),
31018 Make_Pragma (Sloc (N),
31019 Chars => Name_Suppress,
31020 Pragma_Argument_Associations => New_List (
31021 Make_Pragma_Argument_Association (Sloc (N),
31022 Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
31025 -- Nothing else to do at the current time
31027 end Process_Compilation_Unit_Pragmas;
31029 --------------------------------------------
31030 -- Validate_Compile_Time_Warning_Or_Error --
31031 --------------------------------------------
31033 procedure Validate_Compile_Time_Warning_Or_Error
31037 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
31038 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
31039 Arg2 : constant Node_Id := Next (Arg1);
31041 Pname : constant Name_Id := Pragma_Name_Unmapped (N);
31042 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
31045 Analyze_And_Resolve (Arg1x, Standard_Boolean);
31047 if Compile_Time_Known_Value (Arg1x) then
31048 if Is_True (Expr_Value (Arg1x)) then
31050 -- We have already verified that the second argument is a static
31051 -- string expression. Its string value must be retrieved
31052 -- explicitly if it is a declared constant, otherwise it has
31053 -- been constant-folded previously.
31056 Cent : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
31057 Str : constant String_Id :=
31058 Strval (Expr_Value_S (Get_Pragma_Arg (Arg2)));
31059 Str_Len : constant Nat := String_Length (Str);
31061 Force : constant Boolean :=
31062 Prag_Id = Pragma_Compile_Time_Warning
31063 and then Is_Spec_Name (Unit_Name (Current_Sem_Unit))
31064 and then (Ekind (Cent) /= E_Package
31065 or else not In_Private_Part (Cent));
31066 -- Set True if this is the warning case, and we are in the
31067 -- visible part of a package spec, or in a subprogram spec,
31068 -- in which case we want to force the client to see the
31069 -- warning, even though it is not in the main unit.
31077 -- Loop through segments of message separated by line feeds.
31078 -- We output these segments as separate messages with
31079 -- continuation marks for all but the first.
31084 Error_Msg_Strlen := 0;
31086 -- Loop to copy characters from argument to error message
31090 exit when Ptr > Str_Len;
31091 CC := Get_String_Char (Str, Ptr);
31094 -- Ignore wide chars ??? else store character
31096 if In_Character_Range (CC) then
31097 C := Get_Character (CC);
31098 exit when C = ASCII.LF;
31099 Error_Msg_Strlen := Error_Msg_Strlen + 1;
31100 Error_Msg_String (Error_Msg_Strlen) := C;
31104 -- Here with one line ready to go
31106 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
31108 -- If this is a warning in a spec, then we want clients
31109 -- to see the warning, so mark the message with the
31110 -- special sequence !! to force the warning. In the case
31111 -- of a package spec, we do not force this if we are in
31112 -- the private part of the spec.
31115 if Cont = False then
31116 Error_Msg ("<<~!!", Eloc);
31119 Error_Msg ("\<<~!!", Eloc);
31122 -- Error, rather than warning, or in a body, so we do not
31123 -- need to force visibility for client (error will be
31124 -- output in any case, and this is the situation in which
31125 -- we do not want a client to get a warning, since the
31126 -- warning is in the body or the spec private part).
31129 if Cont = False then
31130 Error_Msg ("<<~", Eloc);
31133 Error_Msg ("\<<~", Eloc);
31137 exit when Ptr > Str_Len;
31142 -- Arg1x is not known at compile time, so possibly issue an error
31143 -- or warning. This can happen only if the pragma's processing
31144 -- was deferred until after the back end is run (see
31145 -- Process_Compile_Time_Warning_Or_Error). Note that the warning
31146 -- control switch applies to only the warning case.
31148 elsif Prag_Id = Pragma_Compile_Time_Error then
31149 Error_Msg_N ("condition is not known at compile time", Arg1x);
31151 elsif Warn_On_Unknown_Compile_Time_Warning then
31152 Error_Msg_N ("?condition is not known at compile time", Arg1x);
31154 end Validate_Compile_Time_Warning_Or_Error;
31156 ------------------------------------
31157 -- Record_Possible_Body_Reference --
31158 ------------------------------------
31160 procedure Record_Possible_Body_Reference
31161 (State_Id : Entity_Id;
31165 Spec_Id : Entity_Id;
31168 -- Ensure that we are dealing with a reference to a state
31170 pragma Assert (Ekind (State_Id) = E_Abstract_State);
31172 -- Climb the tree starting from the reference looking for a package body
31173 -- whose spec declares the referenced state. This criteria automatically
31174 -- excludes references in package specs which are legal. Note that it is
31175 -- not wise to emit an error now as the package body may lack pragma
31176 -- Refined_State or the referenced state may not be mentioned in the
31177 -- refinement. This approach avoids the generation of misleading errors.
31180 while Present (Context) loop
31181 if Nkind (Context) = N_Package_Body then
31182 Spec_Id := Corresponding_Spec (Context);
31184 if Present (Abstract_States (Spec_Id))
31185 and then Contains (Abstract_States (Spec_Id), State_Id)
31187 if No (Body_References (State_Id)) then
31188 Set_Body_References (State_Id, New_Elmt_List);
31191 Append_Elmt (Ref, To => Body_References (State_Id));
31196 Context := Parent (Context);
31198 end Record_Possible_Body_Reference;
31200 ------------------------------------------
31201 -- Relocate_Pragmas_To_Anonymous_Object --
31202 ------------------------------------------
31204 procedure Relocate_Pragmas_To_Anonymous_Object
31205 (Typ_Decl : Node_Id;
31206 Obj_Decl : Node_Id)
31210 Next_Decl : Node_Id;
31213 if Nkind (Typ_Decl) = N_Protected_Type_Declaration then
31214 Def := Protected_Definition (Typ_Decl);
31216 pragma Assert (Nkind (Typ_Decl) = N_Task_Type_Declaration);
31217 Def := Task_Definition (Typ_Decl);
31220 -- The concurrent definition has a visible declaration list. Inspect it
31221 -- and relocate all canidate pragmas.
31223 if Present (Def) and then Present (Visible_Declarations (Def)) then
31224 Decl := First (Visible_Declarations (Def));
31225 while Present (Decl) loop
31227 -- Preserve the following declaration for iteration purposes due
31228 -- to possible relocation of a pragma.
31230 Next_Decl := Next (Decl);
31232 if Nkind (Decl) = N_Pragma
31233 and then Pragma_On_Anonymous_Object_OK (Get_Pragma_Id (Decl))
31236 Insert_After (Obj_Decl, Decl);
31238 -- Skip internally generated code
31240 elsif not Comes_From_Source (Decl) then
31243 -- No candidate pragmas are available for relocation
31252 end Relocate_Pragmas_To_Anonymous_Object;
31254 ------------------------------
31255 -- Relocate_Pragmas_To_Body --
31256 ------------------------------
31258 procedure Relocate_Pragmas_To_Body
31259 (Subp_Body : Node_Id;
31260 Target_Body : Node_Id := Empty)
31262 procedure Relocate_Pragma (Prag : Node_Id);
31263 -- Remove a single pragma from its current list and add it to the
31264 -- declarations of the proper body (either Subp_Body or Target_Body).
31266 ---------------------
31267 -- Relocate_Pragma --
31268 ---------------------
31270 procedure Relocate_Pragma (Prag : Node_Id) is
31275 -- When subprogram stubs or expression functions are involves, the
31276 -- destination declaration list belongs to the proper body.
31278 if Present (Target_Body) then
31279 Target := Target_Body;
31281 Target := Subp_Body;
31284 Decls := Declarations (Target);
31288 Set_Declarations (Target, Decls);
31291 -- Unhook the pragma from its current list
31294 Prepend (Prag, Decls);
31295 end Relocate_Pragma;
31299 Body_Id : constant Entity_Id :=
31300 Defining_Unit_Name (Specification (Subp_Body));
31301 Next_Stmt : Node_Id;
31304 -- Start of processing for Relocate_Pragmas_To_Body
31307 -- Do not process a body that comes from a separate unit as no construct
31308 -- can possibly follow it.
31310 if not Is_List_Member (Subp_Body) then
31313 -- Do not relocate pragmas that follow a stub if the stub does not have
31316 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub
31317 and then No (Target_Body)
31321 -- Do not process internally generated routine _Postconditions
31323 elsif Ekind (Body_Id) = E_Procedure
31324 and then Chars (Body_Id) = Name_uPostconditions
31329 -- Look at what is following the body. We are interested in certain kind
31330 -- of pragmas (either from source or byproducts of expansion) that can
31331 -- apply to a body [stub].
31333 Stmt := Next (Subp_Body);
31334 while Present (Stmt) loop
31336 -- Preserve the following statement for iteration purposes due to a
31337 -- possible relocation of a pragma.
31339 Next_Stmt := Next (Stmt);
31341 -- Move a candidate pragma following the body to the declarations of
31344 if Nkind (Stmt) = N_Pragma
31345 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt))
31348 -- If a source pragma Warnings follows the body, it applies to
31349 -- following statements and does not belong in the body.
31351 if Get_Pragma_Id (Stmt) = Pragma_Warnings
31352 and then Comes_From_Source (Stmt)
31356 Relocate_Pragma (Stmt);
31359 -- Skip internally generated code
31361 elsif not Comes_From_Source (Stmt) then
31364 -- No candidate pragmas are available for relocation
31372 end Relocate_Pragmas_To_Body;
31374 -------------------
31375 -- Resolve_State --
31376 -------------------
31378 procedure Resolve_State (N : Node_Id) is
31383 if Is_Entity_Name (N) and then Present (Entity (N)) then
31384 Func := Entity (N);
31386 -- Handle overloading of state names by functions. Traverse the
31387 -- homonym chain looking for an abstract state.
31389 if Ekind (Func) = E_Function and then Has_Homonym (Func) then
31390 pragma Assert (Is_Overloaded (N));
31392 State := Homonym (Func);
31393 while Present (State) loop
31394 if Ekind (State) = E_Abstract_State then
31396 -- Resolve the overloading by setting the proper entity of
31397 -- the reference to that of the state.
31399 Set_Etype (N, Standard_Void_Type);
31400 Set_Entity (N, State);
31401 Set_Is_Overloaded (N, False);
31403 Generate_Reference (State, N);
31407 State := Homonym (State);
31410 -- A function can never act as a state. If the homonym chain does
31411 -- not contain a corresponding state, then something went wrong in
31412 -- the overloading mechanism.
31414 raise Program_Error;
31419 ----------------------------
31420 -- Rewrite_Assertion_Kind --
31421 ----------------------------
31423 procedure Rewrite_Assertion_Kind
31425 From_Policy : Boolean := False)
31431 if Nkind (N) = N_Attribute_Reference
31432 and then Attribute_Name (N) = Name_Class
31433 and then Nkind (Prefix (N)) = N_Identifier
31435 case Chars (Prefix (N)) is
31442 when Name_Type_Invariant =>
31443 Nam := Name_uType_Invariant;
31445 when Name_Invariant =>
31446 Nam := Name_uInvariant;
31452 -- Recommend standard use of aspect names Pre/Post
31454 elsif Nkind (N) = N_Identifier
31455 and then From_Policy
31456 and then Serious_Errors_Detected = 0
31458 if Chars (N) = Name_Precondition
31459 or else Chars (N) = Name_Postcondition
31461 Error_Msg_N ("Check_Policy is a non-standard pragma??", N);
31463 ("\use Assertion_Policy and aspect names Pre/Post for "
31464 & "Ada2012 conformance?", N);
31470 if Nam /= No_Name then
31471 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam));
31473 end Rewrite_Assertion_Kind;
31481 Dummy := Dummy + 1;
31484 --------------------------------
31485 -- Set_Encoded_Interface_Name --
31486 --------------------------------
31488 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
31489 Str : constant String_Id := Strval (S);
31490 Len : constant Nat := String_Length (Str);
31495 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
31498 -- Stores encoded value of character code CC. The encoding we use an
31499 -- underscore followed by four lower case hex digits.
31505 procedure Encode is
31507 Store_String_Char (Get_Char_Code ('_'));
31509 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
31511 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
31513 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
31515 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
31518 -- Start of processing for Set_Encoded_Interface_Name
31521 -- If first character is asterisk, this is a link name, and we leave it
31522 -- completely unmodified. We also ignore null strings (the latter case
31523 -- happens only in error cases).
31526 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
31528 Set_Interface_Name (E, S);
31533 CC := Get_String_Char (Str, J);
31535 exit when not In_Character_Range (CC);
31537 C := Get_Character (CC);
31539 exit when C /= '_' and then C /= '$'
31540 and then C not in '0' .. '9'
31541 and then C not in 'a' .. 'z'
31542 and then C not in 'A' .. 'Z';
31545 Set_Interface_Name (E, S);
31553 -- Here we need to encode. The encoding we use as follows:
31554 -- three underscores + four hex digits (lower case)
31558 for J in 1 .. String_Length (Str) loop
31559 CC := Get_String_Char (Str, J);
31561 if not In_Character_Range (CC) then
31564 C := Get_Character (CC);
31566 if C = '_' or else C = '$'
31567 or else C in '0' .. '9'
31568 or else C in 'a' .. 'z'
31569 or else C in 'A' .. 'Z'
31571 Store_String_Char (CC);
31578 Set_Interface_Name (E,
31579 Make_String_Literal (Sloc (S),
31580 Strval => End_String));
31582 end Set_Encoded_Interface_Name;
31584 ------------------------
31585 -- Set_Elab_Unit_Name --
31586 ------------------------
31588 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id) is
31593 if Nkind (N) = N_Identifier
31594 and then Nkind (With_Item) = N_Identifier
31596 Set_Entity (N, Entity (With_Item));
31598 elsif Nkind (N) = N_Selected_Component then
31599 Change_Selected_Component_To_Expanded_Name (N);
31600 Set_Entity (N, Entity (With_Item));
31601 Set_Entity (Selector_Name (N), Entity (N));
31603 Pref := Prefix (N);
31604 Scop := Scope (Entity (N));
31605 while Nkind (Pref) = N_Selected_Component loop
31606 Change_Selected_Component_To_Expanded_Name (Pref);
31607 Set_Entity (Selector_Name (Pref), Scop);
31608 Set_Entity (Pref, Scop);
31609 Pref := Prefix (Pref);
31610 Scop := Scope (Scop);
31613 Set_Entity (Pref, Scop);
31616 Generate_Reference (Entity (With_Item), N, Set_Ref => False);
31617 end Set_Elab_Unit_Name;
31619 -----------------------
31620 -- Set_Overflow_Mode --
31621 -----------------------
31623 procedure Set_Overflow_Mode (N : Node_Id) is
31625 function Get_Overflow_Mode (Arg : Node_Id) return Overflow_Mode_Type;
31626 -- Function to process one pragma argument, Arg
31628 -----------------------
31629 -- Get_Overflow_Mode --
31630 -----------------------
31632 function Get_Overflow_Mode (Arg : Node_Id) return Overflow_Mode_Type is
31633 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
31636 if Chars (Argx) = Name_Strict then
31639 elsif Chars (Argx) = Name_Minimized then
31642 elsif Chars (Argx) = Name_Eliminated then
31646 raise Program_Error;
31648 end Get_Overflow_Mode;
31652 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
31653 Arg2 : constant Node_Id := Next (Arg1);
31655 -- Start of processing for Set_Overflow_Mode
31658 -- Process first argument
31660 Scope_Suppress.Overflow_Mode_General :=
31661 Get_Overflow_Mode (Arg1);
31663 -- Case of only one argument
31666 Scope_Suppress.Overflow_Mode_Assertions :=
31667 Scope_Suppress.Overflow_Mode_General;
31669 -- Case of two arguments present
31672 Scope_Suppress.Overflow_Mode_Assertions :=
31673 Get_Overflow_Mode (Arg2);
31675 end Set_Overflow_Mode;
31677 -------------------
31678 -- Test_Case_Arg --
31679 -------------------
31681 function Test_Case_Arg
31684 From_Aspect : Boolean := False) return Node_Id
31686 Aspect : constant Node_Id := Corresponding_Aspect (Prag);
31691 pragma Assert (Nam_In (Arg_Nam, Name_Ensures,
31696 -- The caller requests the aspect argument
31698 if From_Aspect then
31699 if Present (Aspect)
31700 and then Nkind (Expression (Aspect)) = N_Aggregate
31702 Args := Expression (Aspect);
31704 -- "Name" and "Mode" may appear without an identifier as a
31705 -- positional association.
31707 if Present (Expressions (Args)) then
31708 Arg := First (Expressions (Args));
31710 if Present (Arg) and then Arg_Nam = Name_Name then
31718 if Present (Arg) and then Arg_Nam = Name_Mode then
31723 -- Some or all arguments may appear as component associatons
31725 if Present (Component_Associations (Args)) then
31726 Arg := First (Component_Associations (Args));
31727 while Present (Arg) loop
31728 if Chars (First (Choices (Arg))) = Arg_Nam then
31737 -- Otherwise retrieve the argument directly from the pragma
31740 Arg := First (Pragma_Argument_Associations (Prag));
31742 if Present (Arg) and then Arg_Nam = Name_Name then
31746 -- Skip argument "Name"
31750 if Present (Arg) and then Arg_Nam = Name_Mode then
31754 -- Skip argument "Mode"
31758 -- Arguments "Requires" and "Ensures" are optional and may not be
31761 while Present (Arg) loop
31762 if Chars (Arg) = Arg_Nam then
31773 --------------------------------------------
31774 -- Defer_Compile_Time_Warning_Error_To_BE --
31775 --------------------------------------------
31777 procedure Defer_Compile_Time_Warning_Error_To_BE (N : Node_Id) is
31778 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
31780 Compile_Time_Warnings_Errors.Append
31781 (New_Val => CTWE_Entry'(Eloc => Sloc (Arg1),
31782 Scope => Current_Scope,
31785 -- If the Boolean expression contains T'Size, and we're not in the main
31786 -- unit being compiled, then we need to copy the pragma into the main
31787 -- unit, because otherwise T'Size might never be computed, leaving it
31790 if not In_Extended_Main_Code_Unit (N) then
31791 Insert_Library_Level_Action (New_Copy_Tree (N));
31793 end Defer_Compile_Time_Warning_Error_To_BE;
31795 ------------------------------------------
31796 -- Validate_Compile_Time_Warning_Errors --
31797 ------------------------------------------
31799 procedure Validate_Compile_Time_Warning_Errors is
31800 procedure Set_Scope (S : Entity_Id);
31801 -- Install all enclosing scopes of S along with S itself
31803 procedure Unset_Scope (S : Entity_Id);
31804 -- Uninstall all enclosing scopes of S along with S itself
31810 procedure Set_Scope (S : Entity_Id) is
31812 if S /= Standard_Standard then
31813 Set_Scope (Scope (S));
31823 procedure Unset_Scope (S : Entity_Id) is
31825 if S /= Standard_Standard then
31826 Unset_Scope (Scope (S));
31832 -- Start of processing for Validate_Compile_Time_Warning_Errors
31835 Expander_Mode_Save_And_Set (False);
31836 In_Compile_Time_Warning_Or_Error := True;
31838 for N in Compile_Time_Warnings_Errors.First ..
31839 Compile_Time_Warnings_Errors.Last
31842 T : CTWE_Entry renames Compile_Time_Warnings_Errors.Table (N);
31845 Set_Scope (T.Scope);
31846 Reset_Analyzed_Flags (T.Prag);
31847 Validate_Compile_Time_Warning_Or_Error (T.Prag, T.Eloc);
31848 Unset_Scope (T.Scope);
31852 In_Compile_Time_Warning_Or_Error := False;
31853 Expander_Mode_Restore;
31854 end Validate_Compile_Time_Warning_Errors;