1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2019, 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. Normalization is disabled
2035 -- in ASIS mode as it alters the tree by introducing new nodes
2036 -- similar to expansion.
2038 if Serious_Errors_Detected = Errors and then not ASIS_Mode then
2039 Normalize_Clause (Clause);
2045 if Restore_Scope then
2049 -- Verify that every input or output of the subprogram appear in a
2052 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
2053 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
2054 Check_Function_Return;
2056 -- The dependency list is malformed. This is a syntax error, always
2060 Error_Msg_N ("malformed dependency relation", Deps);
2064 -- The top level dependency relation is malformed. This is a syntax
2065 -- error, always report.
2068 Error_Msg_N ("malformed dependency relation", Deps);
2072 -- Ensure that a state and a corresponding constituent do not appear
2073 -- together in pragma [Refined_]Depends.
2075 Check_State_And_Constituent_Use
2076 (States => States_Seen,
2077 Constits => Constits_Seen,
2081 Set_Is_Analyzed_Pragma (N);
2082 end Analyze_Depends_In_Decl_Part;
2084 --------------------------------------------
2085 -- Analyze_External_Property_In_Decl_Part --
2086 --------------------------------------------
2088 procedure Analyze_External_Property_In_Decl_Part
2090 Expr_Val : out Boolean)
2092 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pragma_Name (N));
2093 Arg1 : constant Node_Id :=
2094 First (Pragma_Argument_Associations (N));
2095 Obj_Decl : constant Node_Id := Find_Related_Context (N);
2096 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
2102 -- Do not analyze the pragma multiple times
2104 if Is_Analyzed_Pragma (N) then
2108 Error_Msg_Name_1 := Pragma_Name (N);
2110 -- An external property pragma must apply to an effectively volatile
2111 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
2112 -- The check is performed at the end of the declarative region due to a
2113 -- possible out-of-order arrangement of pragmas:
2116 -- pragma Async_Readers (Obj);
2117 -- pragma Volatile (Obj);
2119 if Prag_Id /= Pragma_No_Caching
2120 and then not Is_Effectively_Volatile (Obj_Id)
2122 if No_Caching_Enabled (Obj_Id) then
2124 ("illegal combination of external property % and property "
2125 & """No_Caching"" (SPARK RM 7.1.2(6))", N);
2128 ("external property % must apply to a volatile object", N);
2131 -- Pragma No_Caching should only apply to volatile variables of
2132 -- a non-effectively volatile type (SPARK RM 7.1.2).
2134 elsif Prag_Id = Pragma_No_Caching then
2135 if Is_Effectively_Volatile (Etype (Obj_Id)) then
2136 SPARK_Msg_N ("property % must not apply to an object of "
2137 & "an effectively volatile type", N);
2138 elsif not Is_Volatile (Obj_Id) then
2139 SPARK_Msg_N ("property % must apply to a volatile object", N);
2143 -- Ensure that the Boolean expression (if present) is static. A missing
2144 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
2148 if Present (Arg1) then
2149 Expr := Get_Pragma_Arg (Arg1);
2151 if Is_OK_Static_Expression (Expr) then
2152 Expr_Val := Is_True (Expr_Value (Expr));
2156 Set_Is_Analyzed_Pragma (N);
2157 end Analyze_External_Property_In_Decl_Part;
2159 ---------------------------------
2160 -- Analyze_Global_In_Decl_Part --
2161 ---------------------------------
2163 procedure Analyze_Global_In_Decl_Part (N : Node_Id) is
2164 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
2165 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
2166 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
2168 Constits_Seen : Elist_Id := No_Elist;
2169 -- A list containing the entities of all constituents processed so far.
2170 -- It aids in detecting illegal usage of a state and a corresponding
2171 -- constituent in pragma [Refinde_]Global.
2173 Seen : Elist_Id := No_Elist;
2174 -- A list containing the entities of all the items processed so far. It
2175 -- plays a role in detecting distinct entities.
2177 States_Seen : Elist_Id := No_Elist;
2178 -- A list containing the entities of all states processed so far. It
2179 -- helps in detecting illegal usage of a state and a corresponding
2180 -- constituent in pragma [Refined_]Global.
2182 In_Out_Seen : Boolean := False;
2183 Input_Seen : Boolean := False;
2184 Output_Seen : Boolean := False;
2185 Proof_Seen : Boolean := False;
2186 -- Flags used to verify the consistency of modes
2188 procedure Analyze_Global_List
2190 Global_Mode : Name_Id := Name_Input);
2191 -- Verify the legality of a single global list declaration. Global_Mode
2192 -- denotes the current mode in effect.
2194 -------------------------
2195 -- Analyze_Global_List --
2196 -------------------------
2198 procedure Analyze_Global_List
2200 Global_Mode : Name_Id := Name_Input)
2202 procedure Analyze_Global_Item
2204 Global_Mode : Name_Id);
2205 -- Verify the legality of a single global item declaration denoted by
2206 -- Item. Global_Mode denotes the current mode in effect.
2208 procedure Check_Duplicate_Mode
2210 Status : in out Boolean);
2211 -- Flag Status denotes whether a particular mode has been seen while
2212 -- processing a global list. This routine verifies that Mode is not a
2213 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2215 procedure Check_Mode_Restriction_In_Enclosing_Context
2217 Item_Id : Entity_Id);
2218 -- Verify that an item of mode In_Out or Output does not appear as
2219 -- an input in the Global aspect of an enclosing subprogram or task
2220 -- unit. If this is the case, emit an error. Item and Item_Id are
2221 -- respectively the item and its entity.
2223 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id);
2224 -- Mode denotes either In_Out or Output. Depending on the kind of the
2225 -- related subprogram, emit an error if those two modes apply to a
2226 -- function (SPARK RM 6.1.4(10)).
2228 -------------------------
2229 -- Analyze_Global_Item --
2230 -------------------------
2232 procedure Analyze_Global_Item
2234 Global_Mode : Name_Id)
2236 Item_Id : Entity_Id;
2239 -- Detect one of the following cases
2241 -- with Global => (null, Name)
2242 -- with Global => (Name_1, null, Name_2)
2243 -- with Global => (Name, null)
2245 if Nkind (Item) = N_Null then
2246 SPARK_Msg_N ("cannot mix null and non-null global items", Item);
2251 Resolve_State (Item);
2253 -- Find the entity of the item. If this is a renaming, climb the
2254 -- renaming chain to reach the root object. Renamings of non-
2255 -- entire objects do not yield an entity (Empty).
2257 Item_Id := Entity_Of (Item);
2259 if Present (Item_Id) then
2261 -- A global item may denote a formal parameter of an enclosing
2262 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2263 -- provide a better error diagnostic.
2265 if Is_Formal (Item_Id) then
2266 if Scope (Item_Id) = Spec_Id then
2268 (Fix_Msg (Spec_Id, "global item cannot reference "
2269 & "parameter of subprogram &"), Item, Spec_Id);
2273 -- A global item may denote a concurrent type as long as it is
2274 -- the current instance of an enclosing protected or task type
2275 -- (SPARK RM 6.1.4).
2277 elsif Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then
2278 if Is_CCT_Instance (Item_Id, Spec_Id) then
2280 -- Pragma [Refined_]Global associated with a protected
2281 -- subprogram cannot mention the current instance of a
2282 -- protected type because the instance behaves as a
2283 -- formal parameter.
2285 if Ekind (Item_Id) = E_Protected_Type then
2286 if Scope (Spec_Id) = Item_Id then
2287 Error_Msg_Name_1 := Chars (Item_Id);
2289 (Fix_Msg (Spec_Id, "global item of subprogram & "
2290 & "cannot reference current instance of "
2291 & "protected type %"), Item, Spec_Id);
2295 -- Pragma [Refined_]Global associated with a task type
2296 -- cannot mention the current instance of a task type
2297 -- because the instance behaves as a formal parameter.
2299 else pragma Assert (Ekind (Item_Id) = E_Task_Type);
2300 if Spec_Id = Item_Id then
2301 Error_Msg_Name_1 := Chars (Item_Id);
2303 (Fix_Msg (Spec_Id, "global item of subprogram & "
2304 & "cannot reference current instance of task "
2305 & "type %"), Item, Spec_Id);
2310 -- Otherwise the global item denotes a subtype mark that is
2311 -- not a current instance.
2315 ("invalid use of subtype mark in global list", Item);
2319 -- A global item may denote the anonymous object created for a
2320 -- single protected/task type as long as the current instance
2321 -- is the same single type (SPARK RM 6.1.4).
2323 elsif Is_Single_Concurrent_Object (Item_Id)
2324 and then Is_CCT_Instance (Etype (Item_Id), Spec_Id)
2326 -- Pragma [Refined_]Global associated with a protected
2327 -- subprogram cannot mention the current instance of a
2328 -- protected type because the instance behaves as a formal
2331 if Is_Single_Protected_Object (Item_Id) then
2332 if Scope (Spec_Id) = Etype (Item_Id) then
2333 Error_Msg_Name_1 := Chars (Item_Id);
2335 (Fix_Msg (Spec_Id, "global item of subprogram & "
2336 & "cannot reference current instance of protected "
2337 & "type %"), Item, Spec_Id);
2341 -- Pragma [Refined_]Global associated with a task type
2342 -- cannot mention the current instance of a task type
2343 -- because the instance behaves as a formal parameter.
2345 else pragma Assert (Is_Single_Task_Object (Item_Id));
2346 if Spec_Id = Item_Id then
2347 Error_Msg_Name_1 := Chars (Item_Id);
2349 (Fix_Msg (Spec_Id, "global item of subprogram & "
2350 & "cannot reference current instance of task "
2351 & "type %"), Item, Spec_Id);
2356 -- A formal object may act as a global item inside a generic
2358 elsif Is_Formal_Object (Item_Id) then
2361 -- The only legal references are those to abstract states,
2362 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2364 elsif not Ekind_In (Item_Id, E_Abstract_State,
2370 ("global item must denote object, state or current "
2371 & "instance of concurrent type", Item);
2373 if Ekind (Item_Id) in Named_Kind then
2375 ("\named number & is not an object", Item, Item);
2381 -- State related checks
2383 if Ekind (Item_Id) = E_Abstract_State then
2385 -- Package and subprogram bodies are instantiated
2386 -- individually in a separate compiler pass. Due to this
2387 -- mode of instantiation, the refinement of a state may
2388 -- no longer be visible when a subprogram body contract
2389 -- is instantiated. Since the generic template is legal,
2390 -- do not perform this check in the instance to circumvent
2396 -- An abstract state with visible refinement cannot appear
2397 -- in pragma [Refined_]Global as its place must be taken by
2398 -- some of its constituents (SPARK RM 6.1.4(7)).
2400 elsif Has_Visible_Refinement (Item_Id) then
2402 ("cannot mention state & in global refinement",
2404 SPARK_Msg_N ("\use its constituents instead", Item);
2407 -- An external state cannot appear as a global item of a
2408 -- nonvolatile function (SPARK RM 7.1.3(8)).
2410 elsif Is_External_State (Item_Id)
2411 and then Ekind_In (Spec_Id, E_Function, E_Generic_Function)
2412 and then not Is_Volatile_Function (Spec_Id)
2415 ("external state & cannot act as global item of "
2416 & "nonvolatile function", Item, Item_Id);
2419 -- If the reference to the abstract state appears in an
2420 -- enclosing package body that will eventually refine the
2421 -- state, record the reference for future checks.
2424 Record_Possible_Body_Reference
2425 (State_Id => Item_Id,
2429 -- Constant related checks
2431 elsif Ekind (Item_Id) = E_Constant
2432 and then not Is_Access_Type (Etype (Item_Id))
2435 -- Unless it is of an access type, a constant is a read-only
2436 -- item, therefore it cannot act as an output.
2438 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2440 ("constant & cannot act as output", Item, Item_Id);
2444 -- Loop parameter related checks
2446 elsif Ekind (Item_Id) = E_Loop_Parameter then
2448 -- A loop parameter is a read-only item, therefore it cannot
2449 -- act as an output.
2451 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2453 ("loop parameter & cannot act as output",
2458 -- Variable related checks. These are only relevant when
2459 -- SPARK_Mode is on as they are not standard Ada legality
2462 elsif SPARK_Mode = On
2463 and then Ekind (Item_Id) = E_Variable
2464 and then Is_Effectively_Volatile (Item_Id)
2466 -- An effectively volatile object cannot appear as a global
2467 -- item of a nonvolatile function (SPARK RM 7.1.3(8)).
2469 if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
2470 and then not Is_Volatile_Function (Spec_Id)
2473 ("volatile object & cannot act as global item of a "
2474 & "function", Item, Item_Id);
2477 -- An effectively volatile object with external property
2478 -- Effective_Reads set to True must have mode Output or
2479 -- In_Out (SPARK RM 7.1.3(10)).
2481 elsif Effective_Reads_Enabled (Item_Id)
2482 and then Global_Mode = Name_Input
2485 ("volatile object & with property Effective_Reads must "
2486 & "have mode In_Out or Output", Item, Item_Id);
2491 -- When the item renames an entire object, replace the item
2492 -- with a reference to the object.
2494 if Entity (Item) /= Item_Id then
2495 Rewrite (Item, New_Occurrence_Of (Item_Id, Sloc (Item)));
2499 -- Some form of illegal construct masquerading as a name
2500 -- (SPARK RM 6.1.4(4)).
2504 ("global item must denote object, state or current instance "
2505 & "of concurrent type", Item);
2509 -- Verify that an output does not appear as an input in an
2510 -- enclosing subprogram.
2512 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2513 Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id);
2516 -- The same entity might be referenced through various way.
2517 -- Check the entity of the item rather than the item itself
2518 -- (SPARK RM 6.1.4(10)).
2520 if Contains (Seen, Item_Id) then
2521 SPARK_Msg_N ("duplicate global item", Item);
2523 -- Add the entity of the current item to the list of processed
2527 Append_New_Elmt (Item_Id, Seen);
2529 if Ekind (Item_Id) = E_Abstract_State then
2530 Append_New_Elmt (Item_Id, States_Seen);
2532 -- The variable may eventually become a constituent of a single
2533 -- protected/task type. Record the reference now and verify its
2534 -- legality when analyzing the contract of the variable
2537 elsif Ekind (Item_Id) = E_Variable then
2538 Record_Possible_Part_Of_Reference
2543 if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable)
2544 and then Present (Encapsulating_State (Item_Id))
2546 Append_New_Elmt (Item_Id, Constits_Seen);
2549 end Analyze_Global_Item;
2551 --------------------------
2552 -- Check_Duplicate_Mode --
2553 --------------------------
2555 procedure Check_Duplicate_Mode
2557 Status : in out Boolean)
2561 SPARK_Msg_N ("duplicate global mode", Mode);
2565 end Check_Duplicate_Mode;
2567 -------------------------------------------------
2568 -- Check_Mode_Restriction_In_Enclosing_Context --
2569 -------------------------------------------------
2571 procedure Check_Mode_Restriction_In_Enclosing_Context
2573 Item_Id : Entity_Id)
2575 Context : Entity_Id;
2577 Inputs : Elist_Id := No_Elist;
2578 Outputs : Elist_Id := No_Elist;
2581 -- Traverse the scope stack looking for enclosing subprograms or
2582 -- tasks subject to pragma [Refined_]Global.
2584 Context := Scope (Subp_Id);
2585 while Present (Context) and then Context /= Standard_Standard loop
2587 -- For a single task type, retrieve the corresponding object to
2588 -- which pragma [Refined_]Global is attached.
2590 if Ekind (Context) = E_Task_Type
2591 and then Is_Single_Concurrent_Type (Context)
2593 Context := Anonymous_Object (Context);
2596 if (Is_Subprogram (Context)
2597 or else Ekind (Context) = E_Task_Type
2598 or else Is_Single_Task_Object (Context))
2600 (Present (Get_Pragma (Context, Pragma_Global))
2602 Present (Get_Pragma (Context, Pragma_Refined_Global)))
2604 Collect_Subprogram_Inputs_Outputs
2605 (Subp_Id => Context,
2606 Subp_Inputs => Inputs,
2607 Subp_Outputs => Outputs,
2608 Global_Seen => Dummy);
2610 -- The item is classified as In_Out or Output but appears as
2611 -- an Input in an enclosing subprogram or task unit (SPARK
2614 if Appears_In (Inputs, Item_Id)
2615 and then not Appears_In (Outputs, Item_Id)
2618 ("global item & cannot have mode In_Out or Output",
2621 if Is_Subprogram (Context) then
2623 (Fix_Msg (Subp_Id, "\item already appears as input "
2624 & "of subprogram &"), Item, Context);
2627 (Fix_Msg (Subp_Id, "\item already appears as input "
2628 & "of task &"), Item, Context);
2631 -- Stop the traversal once an error has been detected
2637 Context := Scope (Context);
2639 end Check_Mode_Restriction_In_Enclosing_Context;
2641 ----------------------------------------
2642 -- Check_Mode_Restriction_In_Function --
2643 ----------------------------------------
2645 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
2647 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
2649 ("global mode & is not applicable to functions", Mode);
2651 end Check_Mode_Restriction_In_Function;
2659 -- Start of processing for Analyze_Global_List
2662 if Nkind (List) = N_Null then
2663 Set_Analyzed (List);
2665 -- Single global item declaration
2667 elsif Nkind_In (List, N_Expanded_Name,
2669 N_Selected_Component)
2671 Analyze_Global_Item (List, Global_Mode);
2673 -- Simple global list or moded global list declaration
2675 elsif Nkind (List) = N_Aggregate then
2676 Set_Analyzed (List);
2678 -- The declaration of a simple global list appear as a collection
2681 if Present (Expressions (List)) then
2682 if Present (Component_Associations (List)) then
2684 ("cannot mix moded and non-moded global lists", List);
2687 Item := First (Expressions (List));
2688 while Present (Item) loop
2689 Analyze_Global_Item (Item, Global_Mode);
2693 -- The declaration of a moded global list appears as a collection
2694 -- of component associations where individual choices denote
2697 elsif Present (Component_Associations (List)) then
2698 if Present (Expressions (List)) then
2700 ("cannot mix moded and non-moded global lists", List);
2703 Assoc := First (Component_Associations (List));
2704 while Present (Assoc) loop
2705 Mode := First (Choices (Assoc));
2707 if Nkind (Mode) = N_Identifier then
2708 if Chars (Mode) = Name_In_Out then
2709 Check_Duplicate_Mode (Mode, In_Out_Seen);
2710 Check_Mode_Restriction_In_Function (Mode);
2712 elsif Chars (Mode) = Name_Input then
2713 Check_Duplicate_Mode (Mode, Input_Seen);
2715 elsif Chars (Mode) = Name_Output then
2716 Check_Duplicate_Mode (Mode, Output_Seen);
2717 Check_Mode_Restriction_In_Function (Mode);
2719 elsif Chars (Mode) = Name_Proof_In then
2720 Check_Duplicate_Mode (Mode, Proof_Seen);
2723 SPARK_Msg_N ("invalid mode selector", Mode);
2727 SPARK_Msg_N ("invalid mode selector", Mode);
2730 -- Items in a moded list appear as a collection of
2731 -- expressions. Reuse the existing machinery to analyze
2735 (List => Expression (Assoc),
2736 Global_Mode => Chars (Mode));
2744 raise Program_Error;
2747 -- Any other attempt to declare a global item is illegal. This is a
2748 -- syntax error, always report.
2751 Error_Msg_N ("malformed global list", List);
2753 end Analyze_Global_List;
2757 Items : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
2759 Restore_Scope : Boolean := False;
2761 -- Start of processing for Analyze_Global_In_Decl_Part
2764 -- Do not analyze the pragma multiple times
2766 if Is_Analyzed_Pragma (N) then
2770 -- There is nothing to be done for a null global list
2772 if Nkind (Items) = N_Null then
2773 Set_Analyzed (Items);
2775 -- Analyze the various forms of global lists and items. Note that some
2776 -- of these may be malformed in which case the analysis emits error
2780 -- When pragma [Refined_]Global appears on a single concurrent type,
2781 -- it is relocated to the anonymous object.
2783 if Is_Single_Concurrent_Object (Spec_Id) then
2786 -- Ensure that the formal parameters are visible when processing an
2787 -- item. This falls out of the general rule of aspects pertaining to
2788 -- subprogram declarations.
2790 elsif not In_Open_Scopes (Spec_Id) then
2791 Restore_Scope := True;
2792 Push_Scope (Spec_Id);
2794 if Ekind (Spec_Id) = E_Task_Type then
2795 if Has_Discriminants (Spec_Id) then
2796 Install_Discriminants (Spec_Id);
2799 elsif Is_Generic_Subprogram (Spec_Id) then
2800 Install_Generic_Formals (Spec_Id);
2803 Install_Formals (Spec_Id);
2807 Analyze_Global_List (Items);
2809 if Restore_Scope then
2814 -- Ensure that a state and a corresponding constituent do not appear
2815 -- together in pragma [Refined_]Global.
2817 Check_State_And_Constituent_Use
2818 (States => States_Seen,
2819 Constits => Constits_Seen,
2822 Set_Is_Analyzed_Pragma (N);
2823 end Analyze_Global_In_Decl_Part;
2825 --------------------------------------------
2826 -- Analyze_Initial_Condition_In_Decl_Part --
2827 --------------------------------------------
2829 -- WARNING: This routine manages Ghost regions. Return statements must be
2830 -- replaced by gotos which jump to the end of the routine and restore the
2833 procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is
2834 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2835 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2836 Expr : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
2838 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
2839 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
2840 -- Save the Ghost-related attributes to restore on exit
2843 -- Do not analyze the pragma multiple times
2845 if Is_Analyzed_Pragma (N) then
2849 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2850 -- analysis of the pragma, the Ghost mode at point of declaration and
2851 -- point of analysis may not necessarily be the same. Use the mode in
2852 -- effect at the point of declaration.
2856 -- The expression is preanalyzed because it has not been moved to its
2857 -- final place yet. A direct analysis may generate side effects and this
2858 -- is not desired at this point.
2860 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
2861 Set_Is_Analyzed_Pragma (N);
2863 Restore_Ghost_Region (Saved_GM, Saved_IGR);
2864 end Analyze_Initial_Condition_In_Decl_Part;
2866 --------------------------------------
2867 -- Analyze_Initializes_In_Decl_Part --
2868 --------------------------------------
2870 procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is
2871 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2872 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2874 Constits_Seen : Elist_Id := No_Elist;
2875 -- A list containing the entities of all constituents processed so far.
2876 -- It aids in detecting illegal usage of a state and a corresponding
2877 -- constituent in pragma Initializes.
2879 Items_Seen : Elist_Id := No_Elist;
2880 -- A list of all initialization items processed so far. This list is
2881 -- used to detect duplicate items.
2883 States_And_Objs : Elist_Id := No_Elist;
2884 -- A list of all abstract states and objects declared in the visible
2885 -- declarations of the related package. This list is used to detect the
2886 -- legality of initialization items.
2888 States_Seen : Elist_Id := No_Elist;
2889 -- A list containing the entities of all states processed so far. It
2890 -- helps in detecting illegal usage of a state and a corresponding
2891 -- constituent in pragma Initializes.
2893 procedure Analyze_Initialization_Item (Item : Node_Id);
2894 -- Verify the legality of a single initialization item
2896 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id);
2897 -- Verify the legality of a single initialization item followed by a
2898 -- list of input items.
2900 procedure Collect_States_And_Objects;
2901 -- Inspect the visible declarations of the related package and gather
2902 -- the entities of all abstract states and objects in States_And_Objs.
2904 ---------------------------------
2905 -- Analyze_Initialization_Item --
2906 ---------------------------------
2908 procedure Analyze_Initialization_Item (Item : Node_Id) is
2909 Item_Id : Entity_Id;
2913 Resolve_State (Item);
2915 if Is_Entity_Name (Item) then
2916 Item_Id := Entity_Of (Item);
2918 if Present (Item_Id)
2919 and then Ekind_In (Item_Id, E_Abstract_State,
2923 -- When the initialization item is undefined, it appears as
2924 -- Any_Id. Do not continue with the analysis of the item.
2926 if Item_Id = Any_Id then
2929 -- The state or variable must be declared in the visible
2930 -- declarations of the package (SPARK RM 7.1.5(7)).
2932 elsif not Contains (States_And_Objs, Item_Id) then
2933 Error_Msg_Name_1 := Chars (Pack_Id);
2935 ("initialization item & must appear in the visible "
2936 & "declarations of package %", Item, Item_Id);
2938 -- Detect a duplicate use of the same initialization item
2939 -- (SPARK RM 7.1.5(5)).
2941 elsif Contains (Items_Seen, Item_Id) then
2942 SPARK_Msg_N ("duplicate initialization item", Item);
2944 -- The item is legal, add it to the list of processed states
2948 Append_New_Elmt (Item_Id, Items_Seen);
2950 if Ekind (Item_Id) = E_Abstract_State then
2951 Append_New_Elmt (Item_Id, States_Seen);
2954 if Present (Encapsulating_State (Item_Id)) then
2955 Append_New_Elmt (Item_Id, Constits_Seen);
2959 -- The item references something that is not a state or object
2960 -- (SPARK RM 7.1.5(3)).
2964 ("initialization item must denote object or state", Item);
2967 -- Some form of illegal construct masquerading as a name
2968 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2972 ("initialization item must denote object or state", Item);
2974 end Analyze_Initialization_Item;
2976 ---------------------------------------------
2977 -- Analyze_Initialization_Item_With_Inputs --
2978 ---------------------------------------------
2980 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is
2981 Inputs_Seen : Elist_Id := No_Elist;
2982 -- A list of all inputs processed so far. This list is used to detect
2983 -- duplicate uses of an input.
2985 Non_Null_Seen : Boolean := False;
2986 Null_Seen : Boolean := False;
2987 -- Flags used to check the legality of an input list
2989 procedure Analyze_Input_Item (Input : Node_Id);
2990 -- Verify the legality of a single input item
2992 ------------------------
2993 -- Analyze_Input_Item --
2994 ------------------------
2996 procedure Analyze_Input_Item (Input : Node_Id) is
2997 Input_Id : Entity_Id;
3002 if Nkind (Input) = N_Null then
3005 ("multiple null initializations not allowed", Item);
3007 elsif Non_Null_Seen then
3009 ("cannot mix null and non-null initialization item", Item);
3017 Non_Null_Seen := True;
3021 ("cannot mix null and non-null initialization item", Item);
3025 Resolve_State (Input);
3027 if Is_Entity_Name (Input) then
3028 Input_Id := Entity_Of (Input);
3030 if Present (Input_Id)
3031 and then Ekind_In (Input_Id, E_Abstract_State,
3033 E_Generic_In_Out_Parameter,
3034 E_Generic_In_Parameter,
3042 -- The input cannot denote states or objects declared
3043 -- within the related package (SPARK RM 7.1.5(4)).
3045 if Within_Scope (Input_Id, Current_Scope) then
3047 -- Do not consider generic formal parameters or their
3048 -- respective mappings to generic formals. Even though
3049 -- the formals appear within the scope of the package,
3050 -- it is allowed for an initialization item to depend
3051 -- on an input item.
3053 if Ekind_In (Input_Id, E_Generic_In_Out_Parameter,
3054 E_Generic_In_Parameter)
3058 elsif Ekind_In (Input_Id, E_Constant, E_Variable)
3059 and then Present (Corresponding_Generic_Association
3060 (Declaration_Node (Input_Id)))
3065 Error_Msg_Name_1 := Chars (Pack_Id);
3067 ("input item & cannot denote a visible object or "
3068 & "state of package %", Input, Input_Id);
3073 -- Detect a duplicate use of the same input item
3074 -- (SPARK RM 7.1.5(5)).
3076 if Contains (Inputs_Seen, Input_Id) then
3077 SPARK_Msg_N ("duplicate input item", Input);
3081 -- At this point it is known that the input is legal. Add
3082 -- it to the list of processed inputs.
3084 Append_New_Elmt (Input_Id, Inputs_Seen);
3086 if Ekind (Input_Id) = E_Abstract_State then
3087 Append_New_Elmt (Input_Id, States_Seen);
3090 if Ekind_In (Input_Id, E_Abstract_State,
3093 and then Present (Encapsulating_State (Input_Id))
3095 Append_New_Elmt (Input_Id, Constits_Seen);
3098 -- The input references something that is not a state or an
3099 -- object (SPARK RM 7.1.5(3)).
3103 ("input item must denote object or state", Input);
3106 -- Some form of illegal construct masquerading as a name
3107 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
3111 ("input item must denote object or state", Input);
3114 end Analyze_Input_Item;
3118 Inputs : constant Node_Id := Expression (Item);
3122 Name_Seen : Boolean := False;
3123 -- A flag used to detect multiple item names
3125 -- Start of processing for Analyze_Initialization_Item_With_Inputs
3128 -- Inspect the name of an item with inputs
3130 Elmt := First (Choices (Item));
3131 while Present (Elmt) loop
3133 SPARK_Msg_N ("only one item allowed in initialization", Elmt);
3136 Analyze_Initialization_Item (Elmt);
3142 -- Multiple input items appear as an aggregate
3144 if Nkind (Inputs) = N_Aggregate then
3145 if Present (Expressions (Inputs)) then
3146 Input := First (Expressions (Inputs));
3147 while Present (Input) loop
3148 Analyze_Input_Item (Input);
3153 if Present (Component_Associations (Inputs)) then
3155 ("inputs must appear in named association form", Inputs);
3158 -- Single input item
3161 Analyze_Input_Item (Inputs);
3163 end Analyze_Initialization_Item_With_Inputs;
3165 --------------------------------
3166 -- Collect_States_And_Objects --
3167 --------------------------------
3169 procedure Collect_States_And_Objects is
3170 Pack_Spec : constant Node_Id := Specification (Pack_Decl);
3174 -- Collect the abstract states defined in the package (if any)
3176 if Present (Abstract_States (Pack_Id)) then
3177 States_And_Objs := New_Copy_Elist (Abstract_States (Pack_Id));
3180 -- Collect all objects that appear in the visible declarations of the
3183 if Present (Visible_Declarations (Pack_Spec)) then
3184 Decl := First (Visible_Declarations (Pack_Spec));
3185 while Present (Decl) loop
3186 if Comes_From_Source (Decl)
3187 and then Nkind_In (Decl, N_Object_Declaration,
3188 N_Object_Renaming_Declaration)
3190 Append_New_Elmt (Defining_Entity (Decl), States_And_Objs);
3192 elsif Is_Single_Concurrent_Type_Declaration (Decl) then
3194 (Anonymous_Object (Defining_Entity (Decl)),
3201 end Collect_States_And_Objects;
3205 Inits : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
3208 -- Start of processing for Analyze_Initializes_In_Decl_Part
3211 -- Do not analyze the pragma multiple times
3213 if Is_Analyzed_Pragma (N) then
3217 -- Nothing to do when the initialization list is empty
3219 if Nkind (Inits) = N_Null then
3223 -- Single and multiple initialization clauses appear as an aggregate. If
3224 -- this is not the case, then either the parser or the analysis of the
3225 -- pragma failed to produce an aggregate.
3227 pragma Assert (Nkind (Inits) = N_Aggregate);
3229 -- Initialize the various lists used during analysis
3231 Collect_States_And_Objects;
3233 if Present (Expressions (Inits)) then
3234 Init := First (Expressions (Inits));
3235 while Present (Init) loop
3236 Analyze_Initialization_Item (Init);
3241 if Present (Component_Associations (Inits)) then
3242 Init := First (Component_Associations (Inits));
3243 while Present (Init) loop
3244 Analyze_Initialization_Item_With_Inputs (Init);
3249 -- Ensure that a state and a corresponding constituent do not appear
3250 -- together in pragma Initializes.
3252 Check_State_And_Constituent_Use
3253 (States => States_Seen,
3254 Constits => Constits_Seen,
3257 Set_Is_Analyzed_Pragma (N);
3258 end Analyze_Initializes_In_Decl_Part;
3260 ---------------------
3261 -- Analyze_Part_Of --
3262 ---------------------
3264 procedure Analyze_Part_Of
3266 Item_Id : Entity_Id;
3268 Encap_Id : out Entity_Id;
3269 Legal : out Boolean)
3271 procedure Check_Part_Of_Abstract_State;
3272 pragma Inline (Check_Part_Of_Abstract_State);
3273 -- Verify the legality of indicator Part_Of when the encapsulator is an
3276 procedure Check_Part_Of_Concurrent_Type;
3277 pragma Inline (Check_Part_Of_Concurrent_Type);
3278 -- Verify the legality of indicator Part_Of when the encapsulator is a
3279 -- single concurrent type.
3281 ----------------------------------
3282 -- Check_Part_Of_Abstract_State --
3283 ----------------------------------
3285 procedure Check_Part_Of_Abstract_State is
3286 Pack_Id : Entity_Id;
3287 Placement : State_Space_Kind;
3288 Parent_Unit : Entity_Id;
3291 -- Determine where the object, package instantiation or state lives
3292 -- with respect to the enclosing packages or package bodies.
3294 Find_Placement_In_State_Space
3295 (Item_Id => Item_Id,
3296 Placement => Placement,
3297 Pack_Id => Pack_Id);
3299 -- The item appears in a non-package construct with a declarative
3300 -- part (subprogram, block, etc). As such, the item is not allowed
3301 -- to be a part of an encapsulating state because the item is not
3304 if Placement = Not_In_Package then
3306 ("indicator Part_Of cannot appear in this context "
3307 & "(SPARK RM 7.2.6(5))", Indic);
3309 Error_Msg_Name_1 := Chars (Scope (Encap_Id));
3311 ("\& is not part of the hidden state of package %",
3315 -- The item appears in the visible state space of some package. In
3316 -- general this scenario does not warrant Part_Of except when the
3317 -- package is a nongeneric private child unit and the encapsulating
3318 -- state is declared in a parent unit or a public descendant of that
3321 elsif Placement = Visible_State_Space then
3322 if Is_Child_Unit (Pack_Id)
3323 and then not Is_Generic_Unit (Pack_Id)
3324 and then Is_Private_Descendant (Pack_Id)
3326 -- A variable or state abstraction which is part of the visible
3327 -- state of a nongeneric private child unit or its public
3328 -- descendants must have its Part_Of indicator specified. The
3329 -- Part_Of indicator must denote a state declared by either the
3330 -- parent unit of the private unit or by a public descendant of
3331 -- that parent unit.
3333 -- Find the nearest private ancestor (which can be the current
3336 Parent_Unit := Pack_Id;
3337 while Present (Parent_Unit) loop
3340 (Parent (Unit_Declaration_Node (Parent_Unit)));
3341 Parent_Unit := Scope (Parent_Unit);
3344 Parent_Unit := Scope (Parent_Unit);
3346 if not Is_Child_Or_Sibling (Pack_Id, Scope (Encap_Id)) then
3348 ("indicator Part_Of must denote abstract state of & or of "
3349 & "its public descendant (SPARK RM 7.2.6(3))",
3350 Indic, Parent_Unit);
3353 elsif Scope (Encap_Id) = Parent_Unit
3355 (Is_Ancestor_Package (Parent_Unit, Scope (Encap_Id))
3356 and then not Is_Private_Descendant (Scope (Encap_Id)))
3362 ("indicator Part_Of must denote abstract state of & or of "
3363 & "its public descendant (SPARK RM 7.2.6(3))",
3364 Indic, Parent_Unit);
3368 -- Indicator Part_Of is not needed when the related package is
3369 -- not a nongeneric private child unit or a public descendant
3374 ("indicator Part_Of cannot appear in this context "
3375 & "(SPARK RM 7.2.6(5))", Indic);
3377 Error_Msg_Name_1 := Chars (Pack_Id);
3379 ("\& is declared in the visible part of package %",
3384 -- When the item appears in the private state space of a package, the
3385 -- encapsulating state must be declared in the same package.
3387 elsif Placement = Private_State_Space then
3388 if Scope (Encap_Id) /= Pack_Id then
3390 ("indicator Part_Of must denote an abstract state of "
3391 & "package & (SPARK RM 7.2.6(2))", Indic, Pack_Id);
3393 Error_Msg_Name_1 := Chars (Pack_Id);
3395 ("\& is declared in the private part of package %",
3400 -- Items declared in the body state space of a package do not need
3401 -- Part_Of indicators as the refinement has already been seen.
3405 ("indicator Part_Of cannot appear in this context "
3406 & "(SPARK RM 7.2.6(5))", Indic);
3408 if Scope (Encap_Id) = Pack_Id then
3409 Error_Msg_Name_1 := Chars (Pack_Id);
3411 ("\& is declared in the body of package %", Indic, Item_Id);
3417 -- At this point it is known that the Part_Of indicator is legal
3420 end Check_Part_Of_Abstract_State;
3422 -----------------------------------
3423 -- Check_Part_Of_Concurrent_Type --
3424 -----------------------------------
3426 procedure Check_Part_Of_Concurrent_Type is
3427 function In_Proper_Order
3429 Second : Node_Id) return Boolean;
3430 pragma Inline (In_Proper_Order);
3431 -- Determine whether node First precedes node Second
3433 procedure Placement_Error;
3434 pragma Inline (Placement_Error);
3435 -- Emit an error concerning the illegal placement of the item with
3436 -- respect to the single concurrent type.
3438 ---------------------
3439 -- In_Proper_Order --
3440 ---------------------
3442 function In_Proper_Order
3444 Second : Node_Id) return Boolean
3449 if List_Containing (First) = List_Containing (Second) then
3451 while Present (N) loop
3461 end In_Proper_Order;
3463 ---------------------
3464 -- Placement_Error --
3465 ---------------------
3467 procedure Placement_Error is
3470 ("indicator Part_Of must denote a previously declared single "
3471 & "protected type or single task type", Encap);
3472 end Placement_Error;
3476 Conc_Typ : constant Entity_Id := Etype (Encap_Id);
3477 Encap_Decl : constant Node_Id := Declaration_Node (Encap_Id);
3478 Encap_Context : constant Node_Id := Parent (Encap_Decl);
3480 Item_Context : Node_Id;
3481 Item_Decl : Node_Id;
3482 Prv_Decls : List_Id;
3483 Vis_Decls : List_Id;
3485 -- Start of processing for Check_Part_Of_Concurrent_Type
3488 -- Only abstract states and variables can act as constituents of an
3489 -- encapsulating single concurrent type.
3491 if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
3494 -- The constituent is a constant
3496 elsif Ekind (Item_Id) = E_Constant then
3497 Error_Msg_Name_1 := Chars (Encap_Id);
3499 (Fix_Msg (Conc_Typ, "constant & cannot act as constituent of "
3500 & "single protected type %"), Indic, Item_Id);
3503 -- The constituent is a package instantiation
3506 Error_Msg_Name_1 := Chars (Encap_Id);
3508 (Fix_Msg (Conc_Typ, "package instantiation & cannot act as "
3509 & "constituent of single protected type %"), Indic, Item_Id);
3513 -- When the item denotes an abstract state of a nested package, use
3514 -- the declaration of the package to detect proper placement.
3519 -- with Abstract_State => (State with Part_Of => T)
3521 if Ekind (Item_Id) = E_Abstract_State then
3522 Item_Decl := Unit_Declaration_Node (Scope (Item_Id));
3524 Item_Decl := Declaration_Node (Item_Id);
3527 Item_Context := Parent (Item_Decl);
3529 -- The item and the single concurrent type must appear in the same
3530 -- declarative region, with the item following the declaration of
3531 -- the single concurrent type (SPARK RM 9(3)).
3533 if Item_Context = Encap_Context then
3534 if Nkind_In (Item_Context, N_Package_Specification,
3535 N_Protected_Definition,
3538 Prv_Decls := Private_Declarations (Item_Context);
3539 Vis_Decls := Visible_Declarations (Item_Context);
3541 -- The placement is OK when the single concurrent type appears
3542 -- within the visible declarations and the item in the private
3548 -- Constit : ... with Part_Of => PO;
3551 if List_Containing (Encap_Decl) = Vis_Decls
3552 and then List_Containing (Item_Decl) = Prv_Decls
3556 -- The placement is illegal when the item appears within the
3557 -- visible declarations and the single concurrent type is in
3558 -- the private declarations.
3561 -- Constit : ... with Part_Of => PO;
3566 elsif List_Containing (Item_Decl) = Vis_Decls
3567 and then List_Containing (Encap_Decl) = Prv_Decls
3572 -- Otherwise both the item and the single concurrent type are
3573 -- in the same list. Ensure that the declaration of the single
3574 -- concurrent type precedes that of the item.
3576 elsif not In_Proper_Order
3577 (First => Encap_Decl,
3578 Second => Item_Decl)
3584 -- Otherwise both the item and the single concurrent type are
3585 -- in the same list. Ensure that the declaration of the single
3586 -- concurrent type precedes that of the item.
3588 elsif not In_Proper_Order
3589 (First => Encap_Decl,
3590 Second => Item_Decl)
3596 -- Otherwise the item and the single concurrent type reside within
3597 -- unrelated regions.
3600 Error_Msg_Name_1 := Chars (Encap_Id);
3602 (Fix_Msg (Conc_Typ, "constituent & must be declared "
3603 & "immediately within the same region as single protected "
3604 & "type %"), Indic, Item_Id);
3608 -- At this point it is known that the Part_Of indicator is legal
3611 end Check_Part_Of_Concurrent_Type;
3613 -- Start of processing for Analyze_Part_Of
3616 -- Assume that the indicator is illegal
3621 if Nkind_In (Encap, N_Expanded_Name,
3623 N_Selected_Component)
3626 Resolve_State (Encap);
3628 Encap_Id := Entity (Encap);
3630 -- The encapsulator is an abstract state
3632 if Ekind (Encap_Id) = E_Abstract_State then
3635 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
3637 elsif Is_Single_Concurrent_Object (Encap_Id) then
3640 -- Otherwise the encapsulator is not a legal choice
3644 ("indicator Part_Of must denote abstract state, single "
3645 & "protected type or single task type", Encap);
3649 -- This is a syntax error, always report
3653 ("indicator Part_Of must denote abstract state, single protected "
3654 & "type or single task type", Encap);
3658 -- Catch a case where indicator Part_Of denotes the abstract view of a
3659 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3661 if From_Limited_With (Encap_Id)
3662 and then Present (Non_Limited_View (Encap_Id))
3663 and then Ekind (Non_Limited_View (Encap_Id)) = E_Variable
3665 SPARK_Msg_N ("indicator Part_Of must denote abstract state", Encap);
3666 SPARK_Msg_N ("\& denotes abstract view of object", Encap);
3670 -- The encapsulator is an abstract state
3672 if Ekind (Encap_Id) = E_Abstract_State then
3673 Check_Part_Of_Abstract_State;
3675 -- The encapsulator is a single concurrent type
3678 Check_Part_Of_Concurrent_Type;
3680 end Analyze_Part_Of;
3682 ----------------------------------
3683 -- Analyze_Part_Of_In_Decl_Part --
3684 ----------------------------------
3686 procedure Analyze_Part_Of_In_Decl_Part
3688 Freeze_Id : Entity_Id := Empty)
3690 Encap : constant Node_Id :=
3691 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
3692 Errors : constant Nat := Serious_Errors_Detected;
3693 Var_Decl : constant Node_Id := Find_Related_Context (N);
3694 Var_Id : constant Entity_Id := Defining_Entity (Var_Decl);
3695 Constits : Elist_Id;
3696 Encap_Id : Entity_Id;
3700 -- Detect any discrepancies between the placement of the variable with
3701 -- respect to general state space and the encapsulating state or single
3708 Encap_Id => Encap_Id,
3711 -- The Part_Of indicator turns the variable into a constituent of the
3712 -- encapsulating state or single concurrent type.
3715 pragma Assert (Present (Encap_Id));
3716 Constits := Part_Of_Constituents (Encap_Id);
3718 if No (Constits) then
3719 Constits := New_Elmt_List;
3720 Set_Part_Of_Constituents (Encap_Id, Constits);
3723 Append_Elmt (Var_Id, Constits);
3724 Set_Encapsulating_State (Var_Id, Encap_Id);
3726 -- A Part_Of constituent partially refines an abstract state. This
3727 -- property does not apply to protected or task units.
3729 if Ekind (Encap_Id) = E_Abstract_State then
3730 Set_Has_Partial_Visible_Refinement (Encap_Id);
3734 -- Emit a clarification message when the encapsulator is undefined,
3735 -- possibly due to contract freezing.
3737 if Errors /= Serious_Errors_Detected
3738 and then Present (Freeze_Id)
3739 and then Has_Undefined_Reference (Encap)
3741 Contract_Freeze_Error (Var_Id, Freeze_Id);
3743 end Analyze_Part_Of_In_Decl_Part;
3745 --------------------
3746 -- Analyze_Pragma --
3747 --------------------
3749 procedure Analyze_Pragma (N : Node_Id) is
3750 Loc : constant Source_Ptr := Sloc (N);
3752 Pname : Name_Id := Pragma_Name (N);
3753 -- Name of the source pragma, or name of the corresponding aspect for
3754 -- pragmas which originate in a source aspect. In the latter case, the
3755 -- name may be different from the pragma name.
3757 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
3759 Pragma_Exit : exception;
3760 -- This exception is used to exit pragma processing completely. It
3761 -- is used when an error is detected, and no further processing is
3762 -- required. It is also used if an earlier error has left the tree in
3763 -- a state where the pragma should not be processed.
3766 -- Number of pragma argument associations
3772 -- First four pragma arguments (pragma argument association nodes, or
3773 -- Empty if the corresponding argument does not exist).
3775 type Name_List is array (Natural range <>) of Name_Id;
3776 type Args_List is array (Natural range <>) of Node_Id;
3777 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3779 -----------------------
3780 -- Local Subprograms --
3781 -----------------------
3783 function Acc_First (N : Node_Id) return Node_Id;
3784 -- Helper function to iterate over arguments given to OpenAcc pragmas
3786 function Acc_Next (N : Node_Id) return Node_Id;
3787 -- Helper function to iterate over arguments given to OpenAcc pragmas
3789 procedure Ada_2005_Pragma;
3790 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3791 -- Ada 95 mode, these are implementation defined pragmas, so should be
3792 -- caught by the No_Implementation_Pragmas restriction.
3794 procedure Ada_2012_Pragma;
3795 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3796 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3797 -- should be caught by the No_Implementation_Pragmas restriction.
3799 procedure Analyze_Depends_Global
3800 (Spec_Id : out Entity_Id;
3801 Subp_Decl : out Node_Id;
3802 Legal : out Boolean);
3803 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3804 -- legality of the placement and related context of the pragma. Spec_Id
3805 -- is the entity of the related subprogram. Subp_Decl is the declaration
3806 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3808 procedure Analyze_If_Present (Id : Pragma_Id);
3809 -- Inspect the remainder of the list containing pragma N and look for
3810 -- a pragma that matches Id. If found, analyze the pragma.
3812 procedure Analyze_Pre_Post_Condition;
3813 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3815 procedure Analyze_Refined_Depends_Global_Post
3816 (Spec_Id : out Entity_Id;
3817 Body_Id : out Entity_Id;
3818 Legal : out Boolean);
3819 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3820 -- Refined_Global and Refined_Post. Verify the legality of the placement
3821 -- and related context of the pragma. Spec_Id is the entity of the
3822 -- related subprogram. Body_Id is the entity of the subprogram body.
3823 -- Flag Legal is set when the pragma is legal.
3825 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False);
3826 -- Perform full analysis of pragma Unmodified and the write aspect of
3827 -- pragma Unused. Flag Is_Unused should be set when verifying the
3828 -- semantics of pragma Unused.
3830 procedure Analyze_Unreferenced_Or_Unused (Is_Unused : Boolean := False);
3831 -- Perform full analysis of pragma Unreferenced and the read aspect of
3832 -- pragma Unused. Flag Is_Unused should be set when verifying the
3833 -- semantics of pragma Unused.
3835 procedure Check_Ada_83_Warning;
3836 -- Issues a warning message for the current pragma if operating in Ada
3837 -- 83 mode (used for language pragmas that are not a standard part of
3838 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3841 procedure Check_Arg_Count (Required : Nat);
3842 -- Check argument count for pragma is equal to given parameter. If not,
3843 -- then issue an error message and raise Pragma_Exit.
3845 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3846 -- Arg which can either be a pragma argument association, in which case
3847 -- the check is applied to the expression of the association or an
3848 -- expression directly.
3850 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
3851 -- Check that an argument has the right form for an EXTERNAL_NAME
3852 -- parameter of an extended import/export pragma. The rule is that the
3853 -- name must be an identifier or string literal (in Ada 83 mode) or a
3854 -- static string expression (in Ada 95 mode).
3856 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
3857 -- Check the specified argument Arg to make sure that it is an
3858 -- identifier. If not give error and raise Pragma_Exit.
3860 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
3861 -- Check the specified argument Arg to make sure that it is an integer
3862 -- literal. If not give error and raise Pragma_Exit.
3864 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
3865 -- Check the specified argument Arg to make sure that it has the proper
3866 -- syntactic form for a local name and meets the semantic requirements
3867 -- for a local name. The local name is analyzed as part of the
3868 -- processing for this call. In addition, the local name is required
3869 -- to represent an entity at the library level.
3871 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
3872 -- Check the specified argument Arg to make sure that it has the proper
3873 -- syntactic form for a local name and meets the semantic requirements
3874 -- for a local name. The local name is analyzed as part of the
3875 -- processing for this call.
3877 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
3878 -- Check the specified argument Arg to make sure that it is a valid
3879 -- locking policy name. If not give error and raise Pragma_Exit.
3881 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
3882 -- Check the specified argument Arg to make sure that it is a valid
3883 -- elaboration policy name. If not give error and raise Pragma_Exit.
3885 procedure Check_Arg_Is_One_Of
3888 procedure Check_Arg_Is_One_Of
3890 N1, N2, N3 : Name_Id);
3891 procedure Check_Arg_Is_One_Of
3893 N1, N2, N3, N4 : Name_Id);
3894 procedure Check_Arg_Is_One_Of
3896 N1, N2, N3, N4, N5 : Name_Id);
3897 -- Check the specified argument Arg to make sure that it is an
3898 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3899 -- present). If not then give error and raise Pragma_Exit.
3901 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
3902 -- Check the specified argument Arg to make sure that it is a valid
3903 -- queuing policy name. If not give error and raise Pragma_Exit.
3905 procedure Check_Arg_Is_OK_Static_Expression
3907 Typ : Entity_Id := Empty);
3908 -- Check the specified argument Arg to make sure that it is a static
3909 -- expression of the given type (i.e. it will be analyzed and resolved
3910 -- using this type, which can be any valid argument to Resolve, e.g.
3911 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3912 -- Typ is left Empty, then any static expression is allowed. Includes
3913 -- checking that the argument does not raise Constraint_Error.
3915 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
3916 -- Check the specified argument Arg to make sure that it is a valid task
3917 -- dispatching policy name. If not give error and raise Pragma_Exit.
3919 procedure Check_Arg_Order (Names : Name_List);
3920 -- Checks for an instance of two arguments with identifiers for the
3921 -- current pragma which are not in the sequence indicated by Names,
3922 -- and if so, generates a fatal message about bad order of arguments.
3924 procedure Check_At_Least_N_Arguments (N : Nat);
3925 -- Check there are at least N arguments present
3927 procedure Check_At_Most_N_Arguments (N : Nat);
3928 -- Check there are no more than N arguments present
3930 procedure Check_Atomic_VFA (E : Entity_Id; VFA : Boolean);
3931 -- Apply legality checks to type or object E subject to an Atomic aspect
3932 -- in Ada 2020 (RM C.6(13)) or to a Volatile_Full_Access aspect.
3934 procedure Check_Component
3937 In_Variant_Part : Boolean := False);
3938 -- Examine an Unchecked_Union component for correct use of per-object
3939 -- constrained subtypes, and for restrictions on finalizable components.
3940 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3941 -- should be set when Comp comes from a record variant.
3943 procedure Check_Duplicate_Pragma (E : Entity_Id);
3944 -- Check if a rep item of the same name as the current pragma is already
3945 -- chained as a rep pragma to the given entity. If so give a message
3946 -- about the duplicate, and then raise Pragma_Exit so does not return.
3947 -- Note that if E is a type, then this routine avoids flagging a pragma
3948 -- which applies to a parent type from which E is derived.
3950 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
3951 -- Nam is an N_String_Literal node containing the external name set by
3952 -- an Import or Export pragma (or extended Import or Export pragma).
3953 -- This procedure checks for possible duplications if this is the export
3954 -- case, and if found, issues an appropriate error message.
3956 procedure Check_Expr_Is_OK_Static_Expression
3958 Typ : Entity_Id := Empty);
3959 -- Check the specified expression Expr to make sure that it is a static
3960 -- expression of the given type (i.e. it will be analyzed and resolved
3961 -- using this type, which can be any valid argument to Resolve, e.g.
3962 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3963 -- Typ is left Empty, then any static expression is allowed. Includes
3964 -- checking that the expression does not raise Constraint_Error.
3966 procedure Check_First_Subtype (Arg : Node_Id);
3967 -- Checks that Arg, whose expression is an entity name, references a
3970 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
3971 -- Checks that the given argument has an identifier, and if so, requires
3972 -- it to match the given identifier name. If there is no identifier, or
3973 -- a non-matching identifier, then an error message is given and
3974 -- Pragma_Exit is raised.
3976 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
3977 -- Checks that the given argument has an identifier, and if so, requires
3978 -- it to match one of the given identifier names. If there is no
3979 -- identifier, or a non-matching identifier, then an error message is
3980 -- given and Pragma_Exit is raised.
3982 procedure Check_In_Main_Program;
3983 -- Common checks for pragmas that appear within a main program
3984 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3986 procedure Check_Interrupt_Or_Attach_Handler;
3987 -- Common processing for first argument of pragma Interrupt_Handler or
3988 -- pragma Attach_Handler.
3990 procedure Check_Loop_Pragma_Placement;
3991 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3992 -- appear immediately within a construct restricted to loops, and that
3993 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
3995 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
3996 -- Check that pragma appears in a declarative part, or in a package
3997 -- specification, i.e. that it does not occur in a statement sequence
4000 procedure Check_No_Identifier (Arg : Node_Id);
4001 -- Checks that the given argument does not have an identifier. If
4002 -- an identifier is present, then an error message is issued, and
4003 -- Pragma_Exit is raised.
4005 procedure Check_No_Identifiers;
4006 -- Checks that none of the arguments to the pragma has an identifier.
4007 -- If any argument has an identifier, then an error message is issued,
4008 -- and Pragma_Exit is raised.
4010 procedure Check_No_Link_Name;
4011 -- Checks that no link name is specified
4013 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
4014 -- Checks if the given argument has an identifier, and if so, requires
4015 -- it to match the given identifier name. If there is a non-matching
4016 -- identifier, then an error message is given and Pragma_Exit is raised.
4018 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
4019 -- Checks if the given argument has an identifier, and if so, requires
4020 -- it to match the given identifier name. If there is a non-matching
4021 -- identifier, then an error message is given and Pragma_Exit is raised.
4022 -- In this version of the procedure, the identifier name is given as
4023 -- a string with lower case letters.
4025 procedure Check_Static_Boolean_Expression (Expr : Node_Id);
4026 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
4027 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
4028 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
4029 -- is an OK static boolean expression. Emit an error if this is not the
4032 procedure Check_Static_Constraint (Constr : Node_Id);
4033 -- Constr is a constraint from an N_Subtype_Indication node from a
4034 -- component constraint in an Unchecked_Union type. This routine checks
4035 -- that the constraint is static as required by the restrictions for
4038 procedure Check_Valid_Configuration_Pragma;
4039 -- Legality checks for placement of a configuration pragma
4041 procedure Check_Valid_Library_Unit_Pragma;
4042 -- Legality checks for library unit pragmas. A special case arises for
4043 -- pragmas in generic instances that come from copies of the original
4044 -- library unit pragmas in the generic templates. In the case of other
4045 -- than library level instantiations these can appear in contexts which
4046 -- would normally be invalid (they only apply to the original template
4047 -- and to library level instantiations), and they are simply ignored,
4048 -- which is implemented by rewriting them as null statements.
4050 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
4051 -- Check an Unchecked_Union variant for lack of nested variants and
4052 -- presence of at least one component. UU_Typ is the related Unchecked_
4055 procedure Ensure_Aggregate_Form (Arg : Node_Id);
4056 -- Subsidiary routine to the processing of pragmas Abstract_State,
4057 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
4058 -- Refined_Global and Refined_State. Transform argument Arg into
4059 -- an aggregate if not one already. N_Null is never transformed.
4060 -- Arg may denote an aspect specification or a pragma argument
4063 procedure Error_Pragma (Msg : String);
4064 pragma No_Return (Error_Pragma);
4065 -- Outputs error message for current pragma. The message contains a %
4066 -- that will be replaced with the pragma name, and the flag is placed
4067 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
4068 -- calls Fix_Error (see spec of that procedure for details).
4070 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
4071 pragma No_Return (Error_Pragma_Arg);
4072 -- Outputs error message for current pragma. The message may contain
4073 -- a % that will be replaced with the pragma name. The parameter Arg
4074 -- may either be a pragma argument association, in which case the flag
4075 -- is placed on the expression of this association, or an expression,
4076 -- in which case the flag is placed directly on the expression. The
4077 -- message is placed using Error_Msg_N, so the message may also contain
4078 -- an & insertion character which will reference the given Arg value.
4079 -- After placing the message, Pragma_Exit is raised. Note: this routine
4080 -- calls Fix_Error (see spec of that procedure for details).
4082 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
4083 pragma No_Return (Error_Pragma_Arg);
4084 -- Similar to above form of Error_Pragma_Arg except that two messages
4085 -- are provided, the second is a continuation comment starting with \.
4087 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
4088 pragma No_Return (Error_Pragma_Arg_Ident);
4089 -- Outputs error message for current pragma. The message may contain a %
4090 -- that will be replaced with the pragma name. The parameter Arg must be
4091 -- a pragma argument association with a non-empty identifier (i.e. its
4092 -- Chars field must be set), and the error message is placed on the
4093 -- identifier. The message is placed using Error_Msg_N so the message
4094 -- may also contain an & insertion character which will reference
4095 -- the identifier. After placing the message, Pragma_Exit is raised.
4096 -- Note: this routine calls Fix_Error (see spec of that procedure for
4099 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
4100 pragma No_Return (Error_Pragma_Ref);
4101 -- Outputs error message for current pragma. The message may contain
4102 -- a % that will be replaced with the pragma name. The parameter Ref
4103 -- must be an entity whose name can be referenced by & and sloc by #.
4104 -- After placing the message, Pragma_Exit is raised. Note: this routine
4105 -- calls Fix_Error (see spec of that procedure for details).
4107 function Find_Lib_Unit_Name return Entity_Id;
4108 -- Used for a library unit pragma to find the entity to which the
4109 -- library unit pragma applies, returns the entity found.
4111 procedure Find_Program_Unit_Name (Id : Node_Id);
4112 -- If the pragma is a compilation unit pragma, the id must denote the
4113 -- compilation unit in the same compilation, and the pragma must appear
4114 -- in the list of preceding or trailing pragmas. If it is a program
4115 -- unit pragma that is not a compilation unit pragma, then the
4116 -- identifier must be visible.
4118 function Find_Unique_Parameterless_Procedure
4120 Arg : Node_Id) return Entity_Id;
4121 -- Used for a procedure pragma to find the unique parameterless
4122 -- procedure identified by Name, returns it if it exists, otherwise
4123 -- errors out and uses Arg as the pragma argument for the message.
4125 function Fix_Error (Msg : String) return String;
4126 -- This is called prior to issuing an error message. Msg is the normal
4127 -- error message issued in the pragma case. This routine checks for the
4128 -- case of a pragma coming from an aspect in the source, and returns a
4129 -- message suitable for the aspect case as follows:
4131 -- Each substring "pragma" is replaced by "aspect"
4133 -- If "argument of" is at the start of the error message text, it is
4134 -- replaced by "entity for".
4136 -- If "argument" is at the start of the error message text, it is
4137 -- replaced by "entity".
4139 -- So for example, "argument of pragma X must be discrete type"
4140 -- returns "entity for aspect X must be a discrete type".
4142 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
4143 -- be different from the pragma name). If the current pragma results
4144 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
4145 -- original pragma name.
4147 procedure Gather_Associations
4149 Args : out Args_List);
4150 -- This procedure is used to gather the arguments for a pragma that
4151 -- permits arbitrary ordering of parameters using the normal rules
4152 -- for named and positional parameters. The Names argument is a list
4153 -- of Name_Id values that corresponds to the allowed pragma argument
4154 -- association identifiers in order. The result returned in Args is
4155 -- a list of corresponding expressions that are the pragma arguments.
4156 -- Note that this is a list of expressions, not of pragma argument
4157 -- associations (Gather_Associations has completely checked all the
4158 -- optional identifiers when it returns). An entry in Args is Empty
4159 -- on return if the corresponding argument is not present.
4161 procedure GNAT_Pragma;
4162 -- Called for all GNAT defined pragmas to check the relevant restriction
4163 -- (No_Implementation_Pragmas).
4165 function Is_Before_First_Decl
4166 (Pragma_Node : Node_Id;
4167 Decls : List_Id) return Boolean;
4168 -- Return True if Pragma_Node is before the first declarative item in
4169 -- Decls where Decls is the list of declarative items.
4171 function Is_Configuration_Pragma return Boolean;
4172 -- Determines if the placement of the current pragma is appropriate
4173 -- for a configuration pragma.
4175 function Is_In_Context_Clause return Boolean;
4176 -- Returns True if pragma appears within the context clause of a unit,
4177 -- and False for any other placement (does not generate any messages).
4179 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
4180 -- Analyzes the argument, and determines if it is a static string
4181 -- expression, returns True if so, False if non-static or not String.
4182 -- A special case is that a string literal returns True in Ada 83 mode
4183 -- (which has no such thing as static string expressions). Note that
4184 -- the call analyzes its argument, so this cannot be used for the case
4185 -- where an identifier might not be declared.
4187 procedure Pragma_Misplaced;
4188 pragma No_Return (Pragma_Misplaced);
4189 -- Issue fatal error message for misplaced pragma
4191 procedure Process_Atomic_Independent_Shared_Volatile;
4192 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
4193 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
4194 -- and treated as being identical in effect to pragma Atomic.
4196 procedure Process_Compile_Time_Warning_Or_Error;
4197 -- Common processing for Compile_Time_Error and Compile_Time_Warning
4199 procedure Process_Convention
4200 (C : out Convention_Id;
4201 Ent : out Entity_Id);
4202 -- Common processing for Convention, Interface, Import and Export.
4203 -- Checks first two arguments of pragma, and sets the appropriate
4204 -- convention value in the specified entity or entities. On return
4205 -- C is the convention, Ent is the referenced entity.
4207 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
4208 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
4209 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
4211 procedure Process_Extended_Import_Export_Object_Pragma
4212 (Arg_Internal : Node_Id;
4213 Arg_External : Node_Id;
4214 Arg_Size : Node_Id);
4215 -- Common processing for the pragmas Import/Export_Object. The three
4216 -- arguments correspond to the three named parameters of the pragmas. An
4217 -- argument is empty if the corresponding parameter is not present in
4220 procedure Process_Extended_Import_Export_Internal_Arg
4221 (Arg_Internal : Node_Id := Empty);
4222 -- Common processing for all extended Import and Export pragmas. The
4223 -- argument is the pragma parameter for the Internal argument. If
4224 -- Arg_Internal is empty or inappropriate, an error message is posted.
4225 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
4226 -- set to identify the referenced entity.
4228 procedure Process_Extended_Import_Export_Subprogram_Pragma
4229 (Arg_Internal : Node_Id;
4230 Arg_External : Node_Id;
4231 Arg_Parameter_Types : Node_Id;
4232 Arg_Result_Type : Node_Id := Empty;
4233 Arg_Mechanism : Node_Id;
4234 Arg_Result_Mechanism : Node_Id := Empty);
4235 -- Common processing for all extended Import and Export pragmas applying
4236 -- to subprograms. The caller omits any arguments that do not apply to
4237 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
4238 -- only in the Import_Function and Export_Function cases). The argument
4239 -- names correspond to the allowed pragma association identifiers.
4241 procedure Process_Generic_List;
4242 -- Common processing for Share_Generic and Inline_Generic
4244 procedure Process_Import_Or_Interface;
4245 -- Common processing for Import or Interface
4247 procedure Process_Import_Predefined_Type;
4248 -- Processing for completing a type with pragma Import. This is used
4249 -- to declare types that match predefined C types, especially for cases
4250 -- without corresponding Ada predefined type.
4252 type Inline_Status is (Suppressed, Disabled, Enabled);
4253 -- Inline status of a subprogram, indicated as follows:
4254 -- Suppressed: inlining is suppressed for the subprogram
4255 -- Disabled: no inlining is requested for the subprogram
4256 -- Enabled: inlining is requested/required for the subprogram
4258 procedure Process_Inline (Status : Inline_Status);
4259 -- Common processing for No_Inline, Inline and Inline_Always. Parameter
4260 -- indicates the inline status specified by the pragma.
4262 procedure Process_Interface_Name
4263 (Subprogram_Def : Entity_Id;
4267 -- Given the last two arguments of pragma Import, pragma Export, or
4268 -- pragma Interface_Name, performs validity checks and sets the
4269 -- Interface_Name field of the given subprogram entity to the
4270 -- appropriate external or link name, depending on the arguments given.
4271 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
4272 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
4273 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
4274 -- nor Link_Arg is present, the interface name is set to the default
4275 -- from the subprogram name. In addition, the pragma itself is passed
4276 -- to analyze any expressions in the case the pragma came from an aspect
4279 procedure Process_Interrupt_Or_Attach_Handler;
4280 -- Common processing for Interrupt and Attach_Handler pragmas
4282 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
4283 -- Common processing for Restrictions and Restriction_Warnings pragmas.
4284 -- Warn is True for Restriction_Warnings, or for Restrictions if the
4285 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
4286 -- is not set in the Restrictions case.
4288 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
4289 -- Common processing for Suppress and Unsuppress. The boolean parameter
4290 -- Suppress_Case is True for the Suppress case, and False for the
4293 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id);
4294 -- Subsidiary to the analysis of pragmas Independent[_Components].
4295 -- Record such a pragma N applied to entity E for future checks.
4297 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
4298 -- This procedure sets the Is_Exported flag for the given entity,
4299 -- checking that the entity was not previously imported. Arg is
4300 -- the argument that specified the entity. A check is also made
4301 -- for exporting inappropriate entities.
4303 procedure Set_Extended_Import_Export_External_Name
4304 (Internal_Ent : Entity_Id;
4305 Arg_External : Node_Id);
4306 -- Common processing for all extended import export pragmas. The first
4307 -- argument, Internal_Ent, is the internal entity, which has already
4308 -- been checked for validity by the caller. Arg_External is from the
4309 -- Import or Export pragma, and may be null if no External parameter
4310 -- was present. If Arg_External is present and is a non-null string
4311 -- (a null string is treated as the default), then the Interface_Name
4312 -- field of Internal_Ent is set appropriately.
4314 procedure Set_Imported (E : Entity_Id);
4315 -- This procedure sets the Is_Imported flag for the given entity,
4316 -- checking that it is not previously exported or imported.
4318 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
4319 -- Mech is a parameter passing mechanism (see Import_Function syntax
4320 -- for MECHANISM_NAME). This routine checks that the mechanism argument
4321 -- has the right form, and if not issues an error message. If the
4322 -- argument has the right form then the Mechanism field of Ent is
4323 -- set appropriately.
4325 procedure Set_Rational_Profile;
4326 -- Activate the set of configuration pragmas and permissions that make
4327 -- up the Rational profile.
4329 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id);
4330 -- Activate the set of configuration pragmas and restrictions that make
4331 -- up the Profile. Profile must be either GNAT_Extended_Ravenscar,
4332 -- GNAT_Ravenscar_EDF, or Ravenscar. N is the corresponding pragma node,
4333 -- which is used for error messages on any constructs violating the
4336 procedure Validate_Acc_Condition_Clause (Clause : Node_Id);
4337 -- Make sure the argument of a given Acc_If clause is a Boolean
4339 procedure Validate_Acc_Data_Clause (Clause : Node_Id);
4340 -- Make sure the argument of an OpenAcc data clause (e.g. Copy, Copyin,
4341 -- Copyout...) is an identifier or an aggregate of identifiers.
4343 procedure Validate_Acc_Int_Expr_Clause (Clause : Node_Id);
4344 -- Make sure the argument of an OpenAcc clause is an Integer expression
4346 procedure Validate_Acc_Int_Expr_List_Clause (Clause : Node_Id);
4347 -- Make sure the argument of an OpenAcc clause is an Integer expression
4348 -- or a list of Integer expressions.
4350 procedure Validate_Acc_Loop_Collapse (Clause : Node_Id);
4351 -- Make sure that the parent loop of the Acc_Loop(Collapse => N) pragma
4352 -- contains at least N-1 nested loops.
4354 procedure Validate_Acc_Loop_Gang (Clause : Node_Id);
4355 -- Make sure the argument of the Gang clause of a Loop directive is
4356 -- either an integer expression or a (Static => integer expressions)
4359 procedure Validate_Acc_Loop_Vector (Clause : Node_Id);
4360 -- When this procedure is called in a construct offloaded by an
4361 -- Acc_Kernels pragma, makes sure that a Vector_Length clause does
4362 -- not exist on said pragma. In all cases, make sure the argument
4363 -- is an Integer expression.
4365 procedure Validate_Acc_Loop_Worker (Clause : Node_Id);
4366 -- When this procedure is called in a construct offloaded by an
4367 -- Acc_Parallel pragma, makes sure that no argument has been given.
4368 -- When this procedure is called in a construct offloaded by an
4369 -- Acc_Kernels pragma and if Loop_Worker was given an argument,
4370 -- makes sure that the Num_Workers clause does not appear on the
4371 -- Acc_Kernels pragma and that the argument is an integer.
4373 procedure Validate_Acc_Name_Reduction (Clause : Node_Id);
4374 -- Make sure the reduction clause is an aggregate made of a string
4375 -- representing a supported reduction operation (i.e. "+", "*", "and",
4376 -- "or", "min" or "max") and either an identifier or aggregate of
4379 procedure Validate_Acc_Size_Expressions (Clause : Node_Id);
4380 -- Makes sure that Clause is either an integer expression or an
4381 -- association with a Static as name and a list of integer expressions
4382 -- or "*" strings on the right hand side.
4388 function Acc_First (N : Node_Id) return Node_Id is
4390 if Nkind (N) = N_Aggregate then
4391 if Present (Expressions (N)) then
4392 return First (Expressions (N));
4394 elsif Present (Component_Associations (N)) then
4395 return Expression (First (Component_Associations (N)));
4406 function Acc_Next (N : Node_Id) return Node_Id is
4408 if Nkind (Parent (N)) = N_Component_Association then
4409 return Expression (Next (Parent (N)));
4411 elsif Nkind (Parent (N)) = N_Aggregate then
4419 ---------------------
4420 -- Ada_2005_Pragma --
4421 ---------------------
4423 procedure Ada_2005_Pragma is
4425 if Ada_Version <= Ada_95 then
4426 Check_Restriction (No_Implementation_Pragmas, N);
4428 end Ada_2005_Pragma;
4430 ---------------------
4431 -- Ada_2012_Pragma --
4432 ---------------------
4434 procedure Ada_2012_Pragma is
4436 if Ada_Version <= Ada_2005 then
4437 Check_Restriction (No_Implementation_Pragmas, N);
4439 end Ada_2012_Pragma;
4441 ----------------------------
4442 -- Analyze_Depends_Global --
4443 ----------------------------
4445 procedure Analyze_Depends_Global
4446 (Spec_Id : out Entity_Id;
4447 Subp_Decl : out Node_Id;
4448 Legal : out Boolean)
4451 -- Assume that the pragma is illegal
4458 Check_Arg_Count (1);
4460 -- Ensure the proper placement of the pragma. Depends/Global must be
4461 -- associated with a subprogram declaration or a body that acts as a
4464 Subp_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4468 if Nkind (Subp_Decl) = N_Entry_Declaration then
4471 -- Generic subprogram
4473 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4476 -- Object declaration of a single concurrent type
4478 elsif Nkind (Subp_Decl) = N_Object_Declaration
4479 and then Is_Single_Concurrent_Object
4480 (Unique_Defining_Entity (Subp_Decl))
4486 elsif Nkind (Subp_Decl) = N_Single_Task_Declaration then
4489 -- Subprogram body acts as spec
4491 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4492 and then No (Corresponding_Spec (Subp_Decl))
4496 -- Subprogram body stub acts as spec
4498 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4499 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
4503 -- Subprogram declaration
4505 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4510 elsif Nkind (Subp_Decl) = N_Task_Type_Declaration then
4518 -- If we get here, then the pragma is legal
4521 Spec_Id := Unique_Defining_Entity (Subp_Decl);
4523 -- When the related context is an entry, the entry must belong to a
4524 -- protected unit (SPARK RM 6.1.4(6)).
4526 if Is_Entry_Declaration (Spec_Id)
4527 and then Ekind (Scope (Spec_Id)) /= E_Protected_Type
4532 -- When the related context is an anonymous object created for a
4533 -- simple concurrent type, the type must be a task
4534 -- (SPARK RM 6.1.4(6)).
4536 elsif Is_Single_Concurrent_Object (Spec_Id)
4537 and then Ekind (Etype (Spec_Id)) /= E_Task_Type
4543 -- A pragma that applies to a Ghost entity becomes Ghost for the
4544 -- purposes of legality checks and removal of ignored Ghost code.
4546 Mark_Ghost_Pragma (N, Spec_Id);
4547 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4548 end Analyze_Depends_Global;
4550 ------------------------
4551 -- Analyze_If_Present --
4552 ------------------------
4554 procedure Analyze_If_Present (Id : Pragma_Id) is
4558 pragma Assert (Is_List_Member (N));
4560 -- Inspect the declarations or statements following pragma N looking
4561 -- for another pragma whose Id matches the caller's request. If it is
4562 -- available, analyze it.
4565 while Present (Stmt) loop
4566 if Nkind (Stmt) = N_Pragma and then Get_Pragma_Id (Stmt) = Id then
4567 Analyze_Pragma (Stmt);
4570 -- The first source declaration or statement immediately following
4571 -- N ends the region where a pragma may appear.
4573 elsif Comes_From_Source (Stmt) then
4579 end Analyze_If_Present;
4581 --------------------------------
4582 -- Analyze_Pre_Post_Condition --
4583 --------------------------------
4585 procedure Analyze_Pre_Post_Condition is
4586 Prag_Iden : constant Node_Id := Pragma_Identifier (N);
4587 Subp_Decl : Node_Id;
4588 Subp_Id : Entity_Id;
4590 Duplicates_OK : Boolean := False;
4591 -- Flag set when a pre/postcondition allows multiple pragmas of the
4594 In_Body_OK : Boolean := False;
4595 -- Flag set when a pre/postcondition is allowed to appear on a body
4596 -- even though the subprogram may have a spec.
4598 Is_Pre_Post : Boolean := False;
4599 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4602 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean;
4603 -- Implement rules in AI12-0131: an overriding operation can have
4604 -- a class-wide precondition only if one of its ancestors has an
4605 -- explicit class-wide precondition.
4607 -----------------------------
4608 -- Inherits_Class_Wide_Pre --
4609 -----------------------------
4611 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean is
4612 Typ : constant Entity_Id := Find_Dispatching_Type (E);
4615 Prev : Entity_Id := Overridden_Operation (E);
4618 -- Check ancestors on the overriding operation to examine the
4619 -- preconditions that may apply to them.
4621 while Present (Prev) loop
4622 Cont := Contract (Prev);
4623 if Present (Cont) then
4624 Prag := Pre_Post_Conditions (Cont);
4625 while Present (Prag) loop
4626 if Pragma_Name (Prag) = Name_Precondition
4627 and then Class_Present (Prag)
4632 Prag := Next_Pragma (Prag);
4636 -- For a type derived from a generic formal type, the operation
4637 -- inheriting the condition is a renaming, not an overriding of
4638 -- the operation of the formal. Ditto for an inherited
4639 -- operation which has no explicit contracts.
4641 if Is_Generic_Type (Find_Dispatching_Type (Prev))
4642 or else not Comes_From_Source (Prev)
4644 Prev := Alias (Prev);
4646 Prev := Overridden_Operation (Prev);
4650 -- If the controlling type of the subprogram has progenitors, an
4651 -- interface operation implemented by the current operation may
4652 -- have a class-wide precondition.
4654 if Has_Interfaces (Typ) then
4659 Prim_Elmt : Elmt_Id;
4660 Prim_List : Elist_Id;
4663 Collect_Interfaces (Typ, Ints);
4664 Elmt := First_Elmt (Ints);
4666 -- Iterate over the primitive operations of each interface
4668 while Present (Elmt) loop
4669 Prim_List := Direct_Primitive_Operations (Node (Elmt));
4670 Prim_Elmt := First_Elmt (Prim_List);
4671 while Present (Prim_Elmt) loop
4672 Prim := Node (Prim_Elmt);
4673 if Chars (Prim) = Chars (E)
4674 and then Present (Contract (Prim))
4675 and then Class_Present
4676 (Pre_Post_Conditions (Contract (Prim)))
4681 Next_Elmt (Prim_Elmt);
4690 end Inherits_Class_Wide_Pre;
4692 -- Start of processing for Analyze_Pre_Post_Condition
4695 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4696 -- offer uniformity among the various kinds of pre/postconditions by
4697 -- rewriting the pragma identifier. This allows the retrieval of the
4698 -- original pragma name by routine Original_Aspect_Pragma_Name.
4700 if Comes_From_Source (N) then
4701 if Nam_In (Pname, Name_Pre, Name_Pre_Class) then
4702 Is_Pre_Post := True;
4703 Set_Class_Present (N, Pname = Name_Pre_Class);
4704 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Precondition));
4706 elsif Nam_In (Pname, Name_Post, Name_Post_Class) then
4707 Is_Pre_Post := True;
4708 Set_Class_Present (N, Pname = Name_Post_Class);
4709 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Postcondition));
4713 -- Determine the semantics with respect to duplicates and placement
4714 -- in a body. Pragmas Precondition and Postcondition were introduced
4715 -- before aspects and are not subject to the same aspect-like rules.
4717 if Nam_In (Pname, Name_Precondition, Name_Postcondition) then
4718 Duplicates_OK := True;
4724 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4725 -- argument without an identifier.
4728 Check_Arg_Count (1);
4729 Check_No_Identifiers;
4731 -- Pragmas Precondition and Postcondition have complex argument
4735 Check_At_Least_N_Arguments (1);
4736 Check_At_Most_N_Arguments (2);
4737 Check_Optional_Identifier (Arg1, Name_Check);
4739 if Present (Arg2) then
4740 Check_Optional_Identifier (Arg2, Name_Message);
4741 Preanalyze_Spec_Expression
4742 (Get_Pragma_Arg (Arg2), Standard_String);
4746 -- For a pragma PPC in the extended main source unit, record enabled
4748 -- ??? nothing checks that the pragma is in the main source unit
4750 if Is_Checked (N) and then not Split_PPC (N) then
4751 Set_SCO_Pragma_Enabled (Loc);
4754 -- Ensure the proper placement of the pragma
4757 Find_Related_Declaration_Or_Body
4758 (N, Do_Checks => not Duplicates_OK);
4760 -- When a pre/postcondition pragma applies to an abstract subprogram,
4761 -- its original form must be an aspect with 'Class.
4763 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
4764 if not From_Aspect_Specification (N) then
4766 ("pragma % cannot be applied to abstract subprogram");
4768 elsif not Class_Present (N) then
4770 ("aspect % requires ''Class for abstract subprogram");
4773 -- Entry declaration
4775 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
4778 -- Generic subprogram declaration
4780 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4785 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4786 and then (No (Corresponding_Spec (Subp_Decl)) or In_Body_OK)
4790 -- Subprogram body stub
4792 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4793 and then (No (Corresponding_Spec_Of_Stub (Subp_Decl)) or In_Body_OK)
4797 -- Subprogram declaration
4799 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4801 -- AI05-0230: When a pre/postcondition pragma applies to a null
4802 -- procedure, its original form must be an aspect with 'Class.
4804 if Nkind (Specification (Subp_Decl)) = N_Procedure_Specification
4805 and then Null_Present (Specification (Subp_Decl))
4806 and then From_Aspect_Specification (N)
4807 and then not Class_Present (N)
4809 Error_Pragma ("aspect % requires ''Class for null procedure");
4812 -- Implement the legality checks mandated by AI12-0131:
4813 -- Pre'Class shall not be specified for an overriding primitive
4814 -- subprogram of a tagged type T unless the Pre'Class aspect is
4815 -- specified for the corresponding primitive subprogram of some
4819 E : constant Entity_Id := Defining_Entity (Subp_Decl);
4822 if Class_Present (N)
4823 and then Pragma_Name (N) = Name_Precondition
4824 and then Present (Overridden_Operation (E))
4825 and then not Inherits_Class_Wide_Pre (E)
4828 ("illegal class-wide precondition on overriding operation",
4829 Corresponding_Aspect (N));
4833 -- A renaming declaration may inherit a generated pragma, its
4834 -- placement comes from expansion, not from source.
4836 elsif Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration
4837 and then not Comes_From_Source (N)
4841 -- Otherwise the placement is illegal
4848 Subp_Id := Defining_Entity (Subp_Decl);
4850 -- A pragma that applies to a Ghost entity becomes Ghost for the
4851 -- purposes of legality checks and removal of ignored Ghost code.
4853 Mark_Ghost_Pragma (N, Subp_Id);
4855 -- Chain the pragma on the contract for further processing by
4856 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4858 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
4860 -- Fully analyze the pragma when it appears inside an entry or
4861 -- subprogram body because it cannot benefit from forward references.
4863 if Nkind_In (Subp_Decl, N_Entry_Body,
4865 N_Subprogram_Body_Stub)
4867 -- The legality checks of pragmas Precondition and Postcondition
4868 -- are affected by the SPARK mode in effect and the volatility of
4869 -- the context. Analyze all pragmas in a specific order.
4871 Analyze_If_Present (Pragma_SPARK_Mode);
4872 Analyze_If_Present (Pragma_Volatile_Function);
4873 Analyze_Pre_Post_Condition_In_Decl_Part (N);
4875 end Analyze_Pre_Post_Condition;
4877 -----------------------------------------
4878 -- Analyze_Refined_Depends_Global_Post --
4879 -----------------------------------------
4881 procedure Analyze_Refined_Depends_Global_Post
4882 (Spec_Id : out Entity_Id;
4883 Body_Id : out Entity_Id;
4884 Legal : out Boolean)
4886 Body_Decl : Node_Id;
4887 Spec_Decl : Node_Id;
4890 -- Assume that the pragma is illegal
4897 Check_Arg_Count (1);
4898 Check_No_Identifiers;
4900 -- Verify the placement of the pragma and check for duplicates. The
4901 -- pragma must apply to a subprogram body [stub].
4903 Body_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4905 if not Nkind_In (Body_Decl, N_Entry_Body,
4907 N_Subprogram_Body_Stub,
4915 Body_Id := Defining_Entity (Body_Decl);
4916 Spec_Id := Unique_Defining_Entity (Body_Decl);
4918 -- The pragma must apply to the second declaration of a subprogram.
4919 -- In other words, the body [stub] cannot acts as a spec.
4921 if No (Spec_Id) then
4922 Error_Pragma ("pragma % cannot apply to a stand alone body");
4925 -- Catch the case where the subprogram body is a subunit and acts as
4926 -- the third declaration of the subprogram.
4928 elsif Nkind (Parent (Body_Decl)) = N_Subunit then
4929 Error_Pragma ("pragma % cannot apply to a subunit");
4933 -- A refined pragma can only apply to the body [stub] of a subprogram
4934 -- declared in the visible part of a package. Retrieve the context of
4935 -- the subprogram declaration.
4937 Spec_Decl := Unit_Declaration_Node (Spec_Id);
4939 -- When dealing with protected entries or protected subprograms, use
4940 -- the enclosing protected type as the proper context.
4942 if Ekind_In (Spec_Id, E_Entry,
4946 and then Ekind (Scope (Spec_Id)) = E_Protected_Type
4948 Spec_Decl := Declaration_Node (Scope (Spec_Id));
4951 if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then
4953 (Fix_Msg (Spec_Id, "pragma % must apply to the body of "
4954 & "subprogram declared in a package specification"));
4958 -- If we get here, then the pragma is legal
4962 -- A pragma that applies to a Ghost entity becomes Ghost for the
4963 -- purposes of legality checks and removal of ignored Ghost code.
4965 Mark_Ghost_Pragma (N, Spec_Id);
4967 if Nam_In (Pname, Name_Refined_Depends, Name_Refined_Global) then
4968 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4970 end Analyze_Refined_Depends_Global_Post;
4972 ----------------------------------
4973 -- Analyze_Unmodified_Or_Unused --
4974 ----------------------------------
4976 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False) is
4981 Ghost_Error_Posted : Boolean := False;
4982 -- Flag set when an error concerning the illegal mix of Ghost and
4983 -- non-Ghost variables is emitted.
4985 Ghost_Id : Entity_Id := Empty;
4986 -- The entity of the first Ghost variable encountered while
4987 -- processing the arguments of the pragma.
4991 Check_At_Least_N_Arguments (1);
4993 -- Loop through arguments
4996 while Present (Arg) loop
4997 Check_No_Identifier (Arg);
4999 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
5000 -- in fact generate reference, so that the entity will have a
5001 -- reference, which will inhibit any warnings about it not
5002 -- being referenced, and also properly show up in the ali file
5003 -- as a reference. But this reference is recorded before the
5004 -- Has_Pragma_Unreferenced flag is set, so that no warning is
5005 -- generated for this reference.
5007 Check_Arg_Is_Local_Name (Arg);
5008 Arg_Expr := Get_Pragma_Arg (Arg);
5010 if Is_Entity_Name (Arg_Expr) then
5011 Arg_Id := Entity (Arg_Expr);
5013 -- Skip processing the argument if already flagged
5015 if Is_Assignable (Arg_Id)
5016 and then not Has_Pragma_Unmodified (Arg_Id)
5017 and then not Has_Pragma_Unused (Arg_Id)
5019 Set_Has_Pragma_Unmodified (Arg_Id);
5022 Set_Has_Pragma_Unused (Arg_Id);
5025 -- A pragma that applies to a Ghost entity becomes Ghost for
5026 -- the purposes of legality checks and removal of ignored
5029 Mark_Ghost_Pragma (N, Arg_Id);
5031 -- Capture the entity of the first Ghost variable being
5032 -- processed for error detection purposes.
5034 if Is_Ghost_Entity (Arg_Id) then
5035 if No (Ghost_Id) then
5039 -- Otherwise the variable is non-Ghost. It is illegal to mix
5040 -- references to Ghost and non-Ghost entities
5043 elsif Present (Ghost_Id)
5044 and then not Ghost_Error_Posted
5046 Ghost_Error_Posted := True;
5048 Error_Msg_Name_1 := Pname;
5050 ("pragma % cannot mention ghost and non-ghost "
5053 Error_Msg_Sloc := Sloc (Ghost_Id);
5054 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
5056 Error_Msg_Sloc := Sloc (Arg_Id);
5057 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
5060 -- Warn if already flagged as Unused or Unmodified
5062 elsif Has_Pragma_Unmodified (Arg_Id) then
5063 if Has_Pragma_Unused (Arg_Id) then
5065 ("??pragma Unused already given for &!", Arg_Expr,
5069 ("??pragma Unmodified already given for &!", Arg_Expr,
5073 -- Otherwise the pragma referenced an illegal entity
5077 ("pragma% can only be applied to a variable", Arg_Expr);
5083 end Analyze_Unmodified_Or_Unused;
5085 ------------------------------------
5086 -- Analyze_Unreferenced_Or_Unused --
5087 ------------------------------------
5089 procedure Analyze_Unreferenced_Or_Unused
5090 (Is_Unused : Boolean := False)
5097 Ghost_Error_Posted : Boolean := False;
5098 -- Flag set when an error concerning the illegal mix of Ghost and
5099 -- non-Ghost names is emitted.
5101 Ghost_Id : Entity_Id := Empty;
5102 -- The entity of the first Ghost name encountered while processing
5103 -- the arguments of the pragma.
5107 Check_At_Least_N_Arguments (1);
5109 -- Check case of appearing within context clause
5111 if not Is_Unused and then Is_In_Context_Clause then
5113 -- The arguments must all be units mentioned in a with clause in
5114 -- the same context clause. Note that Par.Prag already checked
5115 -- that the arguments are either identifiers or selected
5119 while Present (Arg) loop
5120 Citem := First (List_Containing (N));
5121 while Citem /= N loop
5122 Arg_Expr := Get_Pragma_Arg (Arg);
5124 if Nkind (Citem) = N_With_Clause
5125 and then Same_Name (Name (Citem), Arg_Expr)
5127 Set_Has_Pragma_Unreferenced
5130 (Library_Unit (Citem))));
5131 Set_Elab_Unit_Name (Arg_Expr, Name (Citem));
5140 ("argument of pragma% is not withed unit", Arg);
5146 -- Case of not in list of context items
5150 while Present (Arg) loop
5151 Check_No_Identifier (Arg);
5153 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
5154 -- in fact generate reference, so that the entity will have a
5155 -- reference, which will inhibit any warnings about it not
5156 -- being referenced, and also properly show up in the ali file
5157 -- as a reference. But this reference is recorded before the
5158 -- Has_Pragma_Unreferenced flag is set, so that no warning is
5159 -- generated for this reference.
5161 Check_Arg_Is_Local_Name (Arg);
5162 Arg_Expr := Get_Pragma_Arg (Arg);
5164 if Is_Entity_Name (Arg_Expr) then
5165 Arg_Id := Entity (Arg_Expr);
5167 -- Warn if already flagged as Unused or Unreferenced and
5168 -- skip processing the argument.
5170 if Has_Pragma_Unreferenced (Arg_Id) then
5171 if Has_Pragma_Unused (Arg_Id) then
5173 ("??pragma Unused already given for &!", Arg_Expr,
5177 ("??pragma Unreferenced already given for &!",
5181 -- Apply Unreferenced to the entity
5184 -- If the entity is overloaded, the pragma applies to the
5185 -- most recent overloading, as documented. In this case,
5186 -- name resolution does not generate a reference, so it
5187 -- must be done here explicitly.
5189 if Is_Overloaded (Arg_Expr) then
5190 Generate_Reference (Arg_Id, N);
5193 Set_Has_Pragma_Unreferenced (Arg_Id);
5196 Set_Has_Pragma_Unused (Arg_Id);
5199 -- A pragma that applies to a Ghost entity becomes Ghost
5200 -- for the purposes of legality checks and removal of
5201 -- ignored Ghost code.
5203 Mark_Ghost_Pragma (N, Arg_Id);
5205 -- Capture the entity of the first Ghost name being
5206 -- processed for error detection purposes.
5208 if Is_Ghost_Entity (Arg_Id) then
5209 if No (Ghost_Id) then
5213 -- Otherwise the name is non-Ghost. It is illegal to mix
5214 -- references to Ghost and non-Ghost entities
5217 elsif Present (Ghost_Id)
5218 and then not Ghost_Error_Posted
5220 Ghost_Error_Posted := True;
5222 Error_Msg_Name_1 := Pname;
5224 ("pragma % cannot mention ghost and non-ghost "
5227 Error_Msg_Sloc := Sloc (Ghost_Id);
5229 ("\& # declared as ghost", N, Ghost_Id);
5231 Error_Msg_Sloc := Sloc (Arg_Id);
5233 ("\& # declared as non-ghost", N, Arg_Id);
5241 end Analyze_Unreferenced_Or_Unused;
5243 --------------------------
5244 -- Check_Ada_83_Warning --
5245 --------------------------
5247 procedure Check_Ada_83_Warning is
5249 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
5250 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
5252 end Check_Ada_83_Warning;
5254 ---------------------
5255 -- Check_Arg_Count --
5256 ---------------------
5258 procedure Check_Arg_Count (Required : Nat) is
5260 if Arg_Count /= Required then
5261 Error_Pragma ("wrong number of arguments for pragma%");
5263 end Check_Arg_Count;
5265 --------------------------------
5266 -- Check_Arg_Is_External_Name --
5267 --------------------------------
5269 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
5270 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5273 if Nkind (Argx) = N_Identifier then
5277 Analyze_And_Resolve (Argx, Standard_String);
5279 if Is_OK_Static_Expression (Argx) then
5282 elsif Etype (Argx) = Any_Type then
5285 -- An interesting special case, if we have a string literal and
5286 -- we are in Ada 83 mode, then we allow it even though it will
5287 -- not be flagged as static. This allows expected Ada 83 mode
5288 -- use of external names which are string literals, even though
5289 -- technically these are not static in Ada 83.
5291 elsif Ada_Version = Ada_83
5292 and then Nkind (Argx) = N_String_Literal
5296 -- Here we have a real error (non-static expression)
5299 Error_Msg_Name_1 := Pname;
5300 Flag_Non_Static_Expr
5301 (Fix_Error ("argument for pragma% must be a identifier or "
5302 & "static string expression!"), Argx);
5307 end Check_Arg_Is_External_Name;
5309 -----------------------------
5310 -- Check_Arg_Is_Identifier --
5311 -----------------------------
5313 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
5314 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5316 if Nkind (Argx) /= N_Identifier then
5317 Error_Pragma_Arg ("argument for pragma% must be identifier", Argx);
5319 end Check_Arg_Is_Identifier;
5321 ----------------------------------
5322 -- Check_Arg_Is_Integer_Literal --
5323 ----------------------------------
5325 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
5326 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5328 if Nkind (Argx) /= N_Integer_Literal then
5330 ("argument for pragma% must be integer literal", Argx);
5332 end Check_Arg_Is_Integer_Literal;
5334 -------------------------------------------
5335 -- Check_Arg_Is_Library_Level_Local_Name --
5336 -------------------------------------------
5340 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5341 -- | library_unit_NAME
5343 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
5345 Check_Arg_Is_Local_Name (Arg);
5347 -- If it came from an aspect, we want to give the error just as if it
5348 -- came from source.
5350 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
5351 and then (Comes_From_Source (N)
5352 or else Present (Corresponding_Aspect (Parent (Arg))))
5355 ("argument for pragma% must be library level entity", Arg);
5357 end Check_Arg_Is_Library_Level_Local_Name;
5359 -----------------------------
5360 -- Check_Arg_Is_Local_Name --
5361 -----------------------------
5365 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5366 -- | library_unit_NAME
5368 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
5369 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5372 -- If this pragma came from an aspect specification, we don't want to
5373 -- check for this error, because that would cause spurious errors, in
5374 -- case a type is frozen in a scope more nested than the type. The
5375 -- aspect itself of course can't be anywhere but on the declaration
5378 if Nkind (Arg) = N_Pragma_Argument_Association then
5379 if From_Aspect_Specification (Parent (Arg)) then
5383 -- Arg is the Expression of an N_Pragma_Argument_Association
5386 if From_Aspect_Specification (Parent (Parent (Arg))) then
5393 if Nkind (Argx) not in N_Direct_Name
5394 and then (Nkind (Argx) /= N_Attribute_Reference
5395 or else Present (Expressions (Argx))
5396 or else Nkind (Prefix (Argx)) /= N_Identifier)
5397 and then (not Is_Entity_Name (Argx)
5398 or else not Is_Compilation_Unit (Entity (Argx)))
5400 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
5403 -- No further check required if not an entity name
5405 if not Is_Entity_Name (Argx) then
5411 Ent : constant Entity_Id := Entity (Argx);
5412 Scop : constant Entity_Id := Scope (Ent);
5415 -- Case of a pragma applied to a compilation unit: pragma must
5416 -- occur immediately after the program unit in the compilation.
5418 if Is_Compilation_Unit (Ent) then
5420 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
5423 -- Case of pragma placed immediately after spec
5425 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
5428 -- Case of pragma placed immediately after body
5430 elsif Nkind (Decl) = N_Subprogram_Declaration
5431 and then Present (Corresponding_Body (Decl))
5435 (Parent (Unit_Declaration_Node
5436 (Corresponding_Body (Decl))));
5438 -- All other cases are illegal
5445 -- Special restricted placement rule from 10.2.1(11.8/2)
5447 elsif Is_Generic_Formal (Ent)
5448 and then Prag_Id = Pragma_Preelaborable_Initialization
5450 OK := List_Containing (N) =
5451 Generic_Formal_Declarations
5452 (Unit_Declaration_Node (Scop));
5454 -- If this is an aspect applied to a subprogram body, the
5455 -- pragma is inserted in its declarative part.
5457 elsif From_Aspect_Specification (N)
5458 and then Ent = Current_Scope
5460 Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body
5464 -- If the aspect is a predicate (possibly others ???) and the
5465 -- context is a record type, this is a discriminant expression
5466 -- within a type declaration, that freezes the predicated
5469 elsif From_Aspect_Specification (N)
5470 and then Prag_Id = Pragma_Predicate
5471 and then Ekind (Current_Scope) = E_Record_Type
5472 and then Scop = Scope (Current_Scope)
5476 -- Default case, just check that the pragma occurs in the scope
5477 -- of the entity denoted by the name.
5480 OK := Current_Scope = Scop;
5485 ("pragma% argument must be in same declarative part", Arg);
5489 end Check_Arg_Is_Local_Name;
5491 ---------------------------------
5492 -- Check_Arg_Is_Locking_Policy --
5493 ---------------------------------
5495 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
5496 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5499 Check_Arg_Is_Identifier (Argx);
5501 if not Is_Locking_Policy_Name (Chars (Argx)) then
5502 Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
5504 end Check_Arg_Is_Locking_Policy;
5506 -----------------------------------------------
5507 -- Check_Arg_Is_Partition_Elaboration_Policy --
5508 -----------------------------------------------
5510 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
5511 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5514 Check_Arg_Is_Identifier (Argx);
5516 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
5518 ("& is not a valid partition elaboration policy name", Argx);
5520 end Check_Arg_Is_Partition_Elaboration_Policy;
5522 -------------------------
5523 -- Check_Arg_Is_One_Of --
5524 -------------------------
5526 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5527 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5530 Check_Arg_Is_Identifier (Argx);
5532 if not Nam_In (Chars (Argx), N1, N2) then
5533 Error_Msg_Name_2 := N1;
5534 Error_Msg_Name_3 := N2;
5535 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
5537 end Check_Arg_Is_One_Of;
5539 procedure Check_Arg_Is_One_Of
5541 N1, N2, N3 : Name_Id)
5543 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5546 Check_Arg_Is_Identifier (Argx);
5548 if not Nam_In (Chars (Argx), N1, N2, N3) then
5549 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5551 end Check_Arg_Is_One_Of;
5553 procedure Check_Arg_Is_One_Of
5555 N1, N2, N3, N4 : Name_Id)
5557 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5560 Check_Arg_Is_Identifier (Argx);
5562 if not Nam_In (Chars (Argx), N1, N2, N3, N4) then
5563 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5565 end Check_Arg_Is_One_Of;
5567 procedure Check_Arg_Is_One_Of
5569 N1, N2, N3, N4, N5 : Name_Id)
5571 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5574 Check_Arg_Is_Identifier (Argx);
5576 if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then
5577 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5579 end Check_Arg_Is_One_Of;
5581 ---------------------------------
5582 -- Check_Arg_Is_Queuing_Policy --
5583 ---------------------------------
5585 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
5586 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5589 Check_Arg_Is_Identifier (Argx);
5591 if not Is_Queuing_Policy_Name (Chars (Argx)) then
5592 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
5594 end Check_Arg_Is_Queuing_Policy;
5596 ---------------------------------------
5597 -- Check_Arg_Is_OK_Static_Expression --
5598 ---------------------------------------
5600 procedure Check_Arg_Is_OK_Static_Expression
5602 Typ : Entity_Id := Empty)
5605 Check_Expr_Is_OK_Static_Expression (Get_Pragma_Arg (Arg), Typ);
5606 end Check_Arg_Is_OK_Static_Expression;
5608 ------------------------------------------
5609 -- Check_Arg_Is_Task_Dispatching_Policy --
5610 ------------------------------------------
5612 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
5613 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5616 Check_Arg_Is_Identifier (Argx);
5618 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
5620 ("& is not an allowed task dispatching policy name", Argx);
5622 end Check_Arg_Is_Task_Dispatching_Policy;
5624 ---------------------
5625 -- Check_Arg_Order --
5626 ---------------------
5628 procedure Check_Arg_Order (Names : Name_List) is
5631 Highest_So_Far : Natural := 0;
5632 -- Highest index in Names seen do far
5636 for J in 1 .. Arg_Count loop
5637 if Chars (Arg) /= No_Name then
5638 for K in Names'Range loop
5639 if Chars (Arg) = Names (K) then
5640 if K < Highest_So_Far then
5641 Error_Msg_Name_1 := Pname;
5643 ("parameters out of order for pragma%", Arg);
5644 Error_Msg_Name_1 := Names (K);
5645 Error_Msg_Name_2 := Names (Highest_So_Far);
5646 Error_Msg_N ("\% must appear before %", Arg);
5650 Highest_So_Far := K;
5658 end Check_Arg_Order;
5660 --------------------------------
5661 -- Check_At_Least_N_Arguments --
5662 --------------------------------
5664 procedure Check_At_Least_N_Arguments (N : Nat) is
5666 if Arg_Count < N then
5667 Error_Pragma ("too few arguments for pragma%");
5669 end Check_At_Least_N_Arguments;
5671 -------------------------------
5672 -- Check_At_Most_N_Arguments --
5673 -------------------------------
5675 procedure Check_At_Most_N_Arguments (N : Nat) is
5678 if Arg_Count > N then
5680 for J in 1 .. N loop
5682 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
5685 end Check_At_Most_N_Arguments;
5687 ------------------------
5688 -- Check_Atomic_VFA --
5689 ------------------------
5691 procedure Check_Atomic_VFA (E : Entity_Id; VFA : Boolean) is
5693 Aliased_Subcomponent : exception;
5694 -- Exception raised if an aliased subcomponent is found in E
5696 Independent_Subcomponent : exception;
5697 -- Exception raised if an independent subcomponent is found in E
5699 procedure Check_Subcomponents (Typ : Entity_Id);
5700 -- Apply checks to subcomponents for Atomic and Volatile_Full_Access
5702 -------------------------
5703 -- Check_Subcomponents --
5704 -------------------------
5706 procedure Check_Subcomponents (Typ : Entity_Id) is
5710 if Is_Array_Type (Typ) then
5711 Comp := Component_Type (Typ);
5713 -- For Atomic we accept any atomic subcomponents
5716 and then (Has_Atomic_Components (Typ)
5717 or else Is_Atomic (Comp))
5721 -- Give an error if the components are aliased
5723 elsif Has_Aliased_Components (Typ)
5724 or else Is_Aliased (Comp)
5726 raise Aliased_Subcomponent;
5728 -- For VFA we accept non-aliased VFA subcomponents
5731 and then Is_Volatile_Full_Access (Comp)
5735 -- Give an error if the components are independent
5737 elsif Has_Independent_Components (Typ)
5738 or else Is_Independent (Comp)
5740 raise Independent_Subcomponent;
5743 -- Recurse on the component type
5745 Check_Subcomponents (Comp);
5747 -- Note: Has_Aliased_Components, like Has_Atomic_Components,
5748 -- and Has_Independent_Components, applies only to arrays.
5749 -- However, this flag does not have a corresponding pragma, so
5750 -- perhaps it should be possible to apply it to record types as
5751 -- well. Should this be done ???
5753 elsif Is_Record_Type (Typ) then
5754 -- It is possible to have an aliased discriminant, so they
5755 -- must be checked along with normal components.
5757 Comp := First_Component_Or_Discriminant (Typ);
5758 while Present (Comp) loop
5760 -- For Atomic we accept any atomic subcomponents
5763 and then (Is_Atomic (Comp)
5764 or else Is_Atomic (Etype (Comp)))
5768 -- Give an error if the component is aliased
5770 elsif Is_Aliased (Comp)
5771 or else Is_Aliased (Etype (Comp))
5773 raise Aliased_Subcomponent;
5775 -- For VFA we accept non-aliased VFA subcomponents
5778 and then (Is_Volatile_Full_Access (Comp)
5779 or else Is_Volatile_Full_Access (Etype (Comp)))
5783 -- Give an error if the component is independent
5785 elsif Is_Independent (Comp)
5786 or else Is_Independent (Etype (Comp))
5788 raise Independent_Subcomponent;
5791 -- Recurse on the component type
5793 Check_Subcomponents (Etype (Comp));
5795 Next_Component_Or_Discriminant (Comp);
5798 end Check_Subcomponents;
5803 -- Fetch the type in case we are dealing with an object or component
5808 pragma Assert (Is_Object (E)
5810 Nkind (Declaration_Node (E)) = N_Component_Declaration);
5815 -- Check all the subcomponents of the type recursively, if any
5817 Check_Subcomponents (Typ);
5820 when Aliased_Subcomponent =>
5823 ("cannot apply Volatile_Full_Access with aliased "
5827 ("cannot apply Atomic with aliased subcomponent "
5831 when Independent_Subcomponent =>
5834 ("cannot apply Volatile_Full_Access with independent "
5838 ("cannot apply Atomic with independent subcomponent "
5843 raise Program_Error;
5844 end Check_Atomic_VFA;
5846 ---------------------
5847 -- Check_Component --
5848 ---------------------
5850 procedure Check_Component
5853 In_Variant_Part : Boolean := False)
5855 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
5856 Sindic : constant Node_Id :=
5857 Subtype_Indication (Component_Definition (Comp));
5858 Typ : constant Entity_Id := Etype (Comp_Id);
5861 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
5862 -- object constraint, then the component type shall be an Unchecked_
5865 if Nkind (Sindic) = N_Subtype_Indication
5866 and then Has_Per_Object_Constraint (Comp_Id)
5867 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
5870 ("component subtype subject to per-object constraint "
5871 & "must be an Unchecked_Union", Comp);
5873 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
5874 -- the body of a generic unit, or within the body of any of its
5875 -- descendant library units, no part of the type of a component
5876 -- declared in a variant_part of the unchecked union type shall be of
5877 -- a formal private type or formal private extension declared within
5878 -- the formal part of the generic unit.
5880 elsif Ada_Version >= Ada_2012
5881 and then In_Generic_Body (UU_Typ)
5882 and then In_Variant_Part
5883 and then Is_Private_Type (Typ)
5884 and then Is_Generic_Type (Typ)
5887 ("component of unchecked union cannot be of generic type", Comp);
5889 elsif Needs_Finalization (Typ) then
5891 ("component of unchecked union cannot be controlled", Comp);
5893 elsif Has_Task (Typ) then
5895 ("component of unchecked union cannot have tasks", Comp);
5897 end Check_Component;
5899 ----------------------------
5900 -- Check_Duplicate_Pragma --
5901 ----------------------------
5903 procedure Check_Duplicate_Pragma (E : Entity_Id) is
5904 Id : Entity_Id := E;
5908 -- Nothing to do if this pragma comes from an aspect specification,
5909 -- since we could not be duplicating a pragma, and we dealt with the
5910 -- case of duplicated aspects in Analyze_Aspect_Specifications.
5912 if From_Aspect_Specification (N) then
5916 -- Otherwise current pragma may duplicate previous pragma or a
5917 -- previously given aspect specification or attribute definition
5918 -- clause for the same pragma.
5920 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
5924 -- If the entity is a type, then we have to make sure that the
5925 -- ostensible duplicate is not for a parent type from which this
5929 if Nkind (P) = N_Pragma then
5931 Args : constant List_Id :=
5932 Pragma_Argument_Associations (P);
5935 and then Is_Entity_Name (Expression (First (Args)))
5936 and then Is_Type (Entity (Expression (First (Args))))
5937 and then Entity (Expression (First (Args))) /= E
5943 elsif Nkind (P) = N_Aspect_Specification
5944 and then Is_Type (Entity (P))
5945 and then Entity (P) /= E
5951 -- Here we have a definite duplicate
5953 Error_Msg_Name_1 := Pragma_Name (N);
5954 Error_Msg_Sloc := Sloc (P);
5956 -- For a single protected or a single task object, the error is
5957 -- issued on the original entity.
5959 if Ekind_In (Id, E_Task_Type, E_Protected_Type) then
5960 Id := Defining_Identifier (Original_Node (Parent (Id)));
5963 if Nkind (P) = N_Aspect_Specification
5964 or else From_Aspect_Specification (P)
5966 Error_Msg_NE ("aspect% for & previously given#", N, Id);
5968 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
5973 end Check_Duplicate_Pragma;
5975 ----------------------------------
5976 -- Check_Duplicated_Export_Name --
5977 ----------------------------------
5979 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
5980 String_Val : constant String_Id := Strval (Nam);
5983 -- We are only interested in the export case, and in the case of
5984 -- generics, it is the instance, not the template, that is the
5985 -- problem (the template will generate a warning in any case).
5987 if not Inside_A_Generic
5988 and then (Prag_Id = Pragma_Export
5990 Prag_Id = Pragma_Export_Procedure
5992 Prag_Id = Pragma_Export_Valued_Procedure
5994 Prag_Id = Pragma_Export_Function)
5996 for J in Externals.First .. Externals.Last loop
5997 if String_Equal (String_Val, Strval (Externals.Table (J))) then
5998 Error_Msg_Sloc := Sloc (Externals.Table (J));
5999 Error_Msg_N ("external name duplicates name given#", Nam);
6004 Externals.Append (Nam);
6006 end Check_Duplicated_Export_Name;
6008 ----------------------------------------
6009 -- Check_Expr_Is_OK_Static_Expression --
6010 ----------------------------------------
6012 procedure Check_Expr_Is_OK_Static_Expression
6014 Typ : Entity_Id := Empty)
6017 if Present (Typ) then
6018 Analyze_And_Resolve (Expr, Typ);
6020 Analyze_And_Resolve (Expr);
6023 -- An expression cannot be considered static if its resolution failed
6024 -- or if it's erroneous. Stop the analysis of the related pragma.
6026 if Etype (Expr) = Any_Type or else Error_Posted (Expr) then
6029 elsif Is_OK_Static_Expression (Expr) then
6032 -- An interesting special case, if we have a string literal and we
6033 -- are in Ada 83 mode, then we allow it even though it will not be
6034 -- flagged as static. This allows the use of Ada 95 pragmas like
6035 -- Import in Ada 83 mode. They will of course be flagged with
6036 -- warnings as usual, but will not cause errors.
6038 elsif Ada_Version = Ada_83
6039 and then Nkind (Expr) = N_String_Literal
6043 -- Finally, we have a real error
6046 Error_Msg_Name_1 := Pname;
6047 Flag_Non_Static_Expr
6048 (Fix_Error ("argument for pragma% must be a static expression!"),
6052 end Check_Expr_Is_OK_Static_Expression;
6054 -------------------------
6055 -- Check_First_Subtype --
6056 -------------------------
6058 procedure Check_First_Subtype (Arg : Node_Id) is
6059 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
6060 Ent : constant Entity_Id := Entity (Argx);
6063 if Is_First_Subtype (Ent) then
6066 elsif Is_Type (Ent) then
6068 ("pragma% cannot apply to subtype", Argx);
6070 elsif Is_Object (Ent) then
6072 ("pragma% cannot apply to object, requires a type", Argx);
6076 ("pragma% cannot apply to&, requires a type", Argx);
6078 end Check_First_Subtype;
6080 ----------------------
6081 -- Check_Identifier --
6082 ----------------------
6084 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
6087 and then Nkind (Arg) = N_Pragma_Argument_Association
6089 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
6090 Error_Msg_Name_1 := Pname;
6091 Error_Msg_Name_2 := Id;
6092 Error_Msg_N ("pragma% argument expects identifier%", Arg);
6096 end Check_Identifier;
6098 --------------------------------
6099 -- Check_Identifier_Is_One_Of --
6100 --------------------------------
6102 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
6105 and then Nkind (Arg) = N_Pragma_Argument_Association
6107 if Chars (Arg) = No_Name then
6108 Error_Msg_Name_1 := Pname;
6109 Error_Msg_N ("pragma% argument expects an identifier", Arg);
6112 elsif Chars (Arg) /= N1
6113 and then Chars (Arg) /= N2
6115 Error_Msg_Name_1 := Pname;
6116 Error_Msg_N ("invalid identifier for pragma% argument", Arg);
6120 end Check_Identifier_Is_One_Of;
6122 ---------------------------
6123 -- Check_In_Main_Program --
6124 ---------------------------
6126 procedure Check_In_Main_Program is
6127 P : constant Node_Id := Parent (N);
6130 -- Must be in subprogram body
6132 if Nkind (P) /= N_Subprogram_Body then
6133 Error_Pragma ("% pragma allowed only in subprogram");
6135 -- Otherwise warn if obviously not main program
6137 elsif Present (Parameter_Specifications (Specification (P)))
6138 or else not Is_Compilation_Unit (Defining_Entity (P))
6140 Error_Msg_Name_1 := Pname;
6142 ("??pragma% is only effective in main program", N);
6144 end Check_In_Main_Program;
6146 ---------------------------------------
6147 -- Check_Interrupt_Or_Attach_Handler --
6148 ---------------------------------------
6150 procedure Check_Interrupt_Or_Attach_Handler is
6151 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
6152 Handler_Proc, Proc_Scope : Entity_Id;
6157 if Prag_Id = Pragma_Interrupt_Handler then
6158 Check_Restriction (No_Dynamic_Attachment, N);
6161 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
6162 Proc_Scope := Scope (Handler_Proc);
6164 if Ekind (Proc_Scope) /= E_Protected_Type then
6166 ("argument of pragma% must be protected procedure", Arg1);
6169 -- For pragma case (as opposed to access case), check placement.
6170 -- We don't need to do that for aspects, because we have the
6171 -- check that they aspect applies an appropriate procedure.
6173 if not From_Aspect_Specification (N)
6174 and then Parent (N) /= Protected_Definition (Parent (Proc_Scope))
6176 Error_Pragma ("pragma% must be in protected definition");
6179 if not Is_Library_Level_Entity (Proc_Scope) then
6181 ("argument for pragma% must be library level entity", Arg1);
6184 -- AI05-0033: A pragma cannot appear within a generic body, because
6185 -- instance can be in a nested scope. The check that protected type
6186 -- is itself a library-level declaration is done elsewhere.
6188 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
6189 -- handle code prior to AI-0033. Analysis tools typically are not
6190 -- interested in this pragma in any case, so no need to worry too
6191 -- much about its placement.
6193 if Inside_A_Generic then
6194 if Ekind (Scope (Current_Scope)) = E_Generic_Package
6195 and then In_Package_Body (Scope (Current_Scope))
6196 and then not Relaxed_RM_Semantics
6198 Error_Pragma ("pragma% cannot be used inside a generic");
6201 end Check_Interrupt_Or_Attach_Handler;
6203 ---------------------------------
6204 -- Check_Loop_Pragma_Placement --
6205 ---------------------------------
6207 procedure Check_Loop_Pragma_Placement is
6208 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id);
6209 -- Verify whether the current pragma is properly grouped with other
6210 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
6211 -- related loop where the pragma appears.
6213 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean;
6214 -- Determine whether an arbitrary statement Stmt denotes pragma
6215 -- Loop_Invariant or Loop_Variant.
6217 procedure Placement_Error (Constr : Node_Id);
6218 pragma No_Return (Placement_Error);
6219 -- Node Constr denotes the last loop restricted construct before we
6220 -- encountered an illegal relation between enclosing constructs. Emit
6221 -- an error depending on what Constr was.
6223 --------------------------------
6224 -- Check_Loop_Pragma_Grouping --
6225 --------------------------------
6227 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is
6228 Stop_Search : exception;
6229 -- This exception is used to terminate the recursive descent of
6230 -- routine Check_Grouping.
6232 procedure Check_Grouping (L : List_Id);
6233 -- Find the first group of pragmas in list L and if successful,
6234 -- ensure that the current pragma is part of that group. The
6235 -- routine raises Stop_Search once such a check is performed to
6236 -- halt the recursive descent.
6238 procedure Grouping_Error (Prag : Node_Id);
6239 pragma No_Return (Grouping_Error);
6240 -- Emit an error concerning the current pragma indicating that it
6241 -- should be placed after pragma Prag.
6243 --------------------
6244 -- Check_Grouping --
6245 --------------------
6247 procedure Check_Grouping (L : List_Id) is
6250 Prag : Node_Id := Empty; -- init to avoid warning
6253 -- Inspect the list of declarations or statements looking for
6254 -- the first grouping of pragmas:
6257 -- pragma Loop_Invariant ...;
6258 -- pragma Loop_Variant ...;
6260 -- pragma Loop_Variant ...; -- current pragma
6262 -- If the current pragma is not in the grouping, then it must
6263 -- either appear in a different declarative or statement list
6264 -- or the construct at (1) is separating the pragma from the
6268 while Present (Stmt) loop
6270 -- First pragma of the first topmost grouping has been found
6272 if Is_Loop_Pragma (Stmt) then
6274 -- The group and the current pragma are not in the same
6275 -- declarative or statement list.
6277 if List_Containing (Stmt) /= List_Containing (N) then
6278 Grouping_Error (Stmt);
6280 -- Try to reach the current pragma from the first pragma
6281 -- of the grouping while skipping other members:
6283 -- pragma Loop_Invariant ...; -- first pragma
6284 -- pragma Loop_Variant ...; -- member
6286 -- pragma Loop_Variant ...; -- current pragma
6289 while Present (Stmt) loop
6290 -- The current pragma is either the first pragma
6291 -- of the group or is a member of the group.
6292 -- Stop the search as the placement is legal.
6297 -- Skip group members, but keep track of the
6298 -- last pragma in the group.
6300 elsif Is_Loop_Pragma (Stmt) then
6303 -- Skip declarations and statements generated by
6304 -- the compiler during expansion. Note that some
6305 -- source statements (e.g. pragma Assert) may have
6306 -- been transformed so that they do not appear as
6307 -- coming from source anymore, so we instead look
6308 -- at their Original_Node.
6310 elsif not Comes_From_Source (Original_Node (Stmt))
6314 -- A non-pragma is separating the group from the
6315 -- current pragma, the placement is illegal.
6318 Grouping_Error (Prag);
6324 -- If the traversal did not reach the current pragma,
6325 -- then the list must be malformed.
6327 raise Program_Error;
6330 -- Pragmas Loop_Invariant and Loop_Variant may only appear
6331 -- inside a loop or a block housed inside a loop. Inspect
6332 -- the declarations and statements of the block as they may
6333 -- contain the first grouping. This case follows the one for
6334 -- loop pragmas, as block statements which originate in a
6335 -- loop pragma (and so Is_Loop_Pragma will return True on
6336 -- that block statement) should be treated in the previous
6339 elsif Nkind (Stmt) = N_Block_Statement then
6340 HSS := Handled_Statement_Sequence (Stmt);
6342 Check_Grouping (Declarations (Stmt));
6344 if Present (HSS) then
6345 Check_Grouping (Statements (HSS));
6353 --------------------
6354 -- Grouping_Error --
6355 --------------------
6357 procedure Grouping_Error (Prag : Node_Id) is
6359 Error_Msg_Sloc := Sloc (Prag);
6360 Error_Pragma ("pragma% must appear next to pragma#");
6363 -- Start of processing for Check_Loop_Pragma_Grouping
6366 -- Inspect the statements of the loop or nested blocks housed
6367 -- within to determine whether the current pragma is part of the
6368 -- first topmost grouping of Loop_Invariant and Loop_Variant.
6370 Check_Grouping (Statements (Loop_Stmt));
6373 when Stop_Search => null;
6374 end Check_Loop_Pragma_Grouping;
6376 --------------------
6377 -- Is_Loop_Pragma --
6378 --------------------
6380 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean is
6382 -- Inspect the original node as Loop_Invariant and Loop_Variant
6383 -- pragmas are rewritten to null when assertions are disabled.
6385 if Nkind (Original_Node (Stmt)) = N_Pragma then
6387 Nam_In (Pragma_Name_Unmapped (Original_Node (Stmt)),
6388 Name_Loop_Invariant,
6395 ---------------------
6396 -- Placement_Error --
6397 ---------------------
6399 procedure Placement_Error (Constr : Node_Id) is
6400 LA : constant String := " with Loop_Entry";
6403 if Prag_Id = Pragma_Assert then
6404 Error_Msg_String (1 .. LA'Length) := LA;
6405 Error_Msg_Strlen := LA'Length;
6407 Error_Msg_Strlen := 0;
6410 if Nkind (Constr) = N_Pragma then
6412 ("pragma %~ must appear immediately within the statements "
6416 ("block containing pragma %~ must appear immediately within "
6417 & "the statements of a loop", Constr);
6419 end Placement_Error;
6421 -- Local declarations
6426 -- Start of processing for Check_Loop_Pragma_Placement
6429 -- Check that pragma appears immediately within a loop statement,
6430 -- ignoring intervening block statements.
6434 while Present (Stmt) loop
6436 -- The pragma or previous block must appear immediately within the
6437 -- current block's declarative or statement part.
6439 if Nkind (Stmt) = N_Block_Statement then
6440 if (No (Declarations (Stmt))
6441 or else List_Containing (Prev) /= Declarations (Stmt))
6443 List_Containing (Prev) /=
6444 Statements (Handled_Statement_Sequence (Stmt))
6446 Placement_Error (Prev);
6449 -- Keep inspecting the parents because we are now within a
6450 -- chain of nested blocks.
6454 Stmt := Parent (Stmt);
6457 -- The pragma or previous block must appear immediately within the
6458 -- statements of the loop.
6460 elsif Nkind (Stmt) = N_Loop_Statement then
6461 if List_Containing (Prev) /= Statements (Stmt) then
6462 Placement_Error (Prev);
6465 -- Stop the traversal because we reached the innermost loop
6466 -- regardless of whether we encountered an error or not.
6470 -- Ignore a handled statement sequence. Note that this node may
6471 -- be related to a subprogram body in which case we will emit an
6472 -- error on the next iteration of the search.
6474 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then
6475 Stmt := Parent (Stmt);
6477 -- Any other statement breaks the chain from the pragma to the
6481 Placement_Error (Prev);
6486 -- Check that the current pragma Loop_Invariant or Loop_Variant is
6487 -- grouped together with other such pragmas.
6489 if Is_Loop_Pragma (N) then
6491 -- The previous check should have located the related loop
6493 pragma Assert (Nkind (Stmt) = N_Loop_Statement);
6494 Check_Loop_Pragma_Grouping (Stmt);
6496 end Check_Loop_Pragma_Placement;
6498 -------------------------------------------
6499 -- Check_Is_In_Decl_Part_Or_Package_Spec --
6500 -------------------------------------------
6502 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
6511 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
6514 elsif Nkind_In (P, N_Package_Specification,
6519 -- Note: the following tests seem a little peculiar, because
6520 -- they test for bodies, but if we were in the statement part
6521 -- of the body, we would already have hit the handled statement
6522 -- sequence, so the only way we get here is by being in the
6523 -- declarative part of the body.
6525 elsif Nkind_In (P, N_Subprogram_Body,
6536 Error_Pragma ("pragma% is not in declarative part or package spec");
6537 end Check_Is_In_Decl_Part_Or_Package_Spec;
6539 -------------------------
6540 -- Check_No_Identifier --
6541 -------------------------
6543 procedure Check_No_Identifier (Arg : Node_Id) is
6545 if Nkind (Arg) = N_Pragma_Argument_Association
6546 and then Chars (Arg) /= No_Name
6548 Error_Pragma_Arg_Ident
6549 ("pragma% does not permit identifier& here", Arg);
6551 end Check_No_Identifier;
6553 --------------------------
6554 -- Check_No_Identifiers --
6555 --------------------------
6557 procedure Check_No_Identifiers is
6561 for J in 1 .. Arg_Count loop
6562 Check_No_Identifier (Arg_Node);
6565 end Check_No_Identifiers;
6567 ------------------------
6568 -- Check_No_Link_Name --
6569 ------------------------
6571 procedure Check_No_Link_Name is
6573 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then
6577 if Present (Arg4) then
6579 ("Link_Name argument not allowed for Import Intrinsic", Arg4);
6581 end Check_No_Link_Name;
6583 -------------------------------
6584 -- Check_Optional_Identifier --
6585 -------------------------------
6587 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
6590 and then Nkind (Arg) = N_Pragma_Argument_Association
6591 and then Chars (Arg) /= No_Name
6593 if Chars (Arg) /= Id then
6594 Error_Msg_Name_1 := Pname;
6595 Error_Msg_Name_2 := Id;
6596 Error_Msg_N ("pragma% argument expects identifier%", Arg);
6600 end Check_Optional_Identifier;
6602 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
6604 Check_Optional_Identifier (Arg, Name_Find (Id));
6605 end Check_Optional_Identifier;
6607 -------------------------------------
6608 -- Check_Static_Boolean_Expression --
6609 -------------------------------------
6611 procedure Check_Static_Boolean_Expression (Expr : Node_Id) is
6613 if Present (Expr) then
6614 Analyze_And_Resolve (Expr, Standard_Boolean);
6616 if not Is_OK_Static_Expression (Expr) then
6618 ("expression of pragma % must be static", Expr);
6621 end Check_Static_Boolean_Expression;
6623 -----------------------------
6624 -- Check_Static_Constraint --
6625 -----------------------------
6627 -- Note: for convenience in writing this procedure, in addition to
6628 -- the officially (i.e. by spec) allowed argument which is always a
6629 -- constraint, it also allows ranges and discriminant associations.
6630 -- Above is not clear ???
6632 procedure Check_Static_Constraint (Constr : Node_Id) is
6634 procedure Require_Static (E : Node_Id);
6635 -- Require given expression to be static expression
6637 --------------------
6638 -- Require_Static --
6639 --------------------
6641 procedure Require_Static (E : Node_Id) is
6643 if not Is_OK_Static_Expression (E) then
6644 Flag_Non_Static_Expr
6645 ("non-static constraint not allowed in Unchecked_Union!", E);
6650 -- Start of processing for Check_Static_Constraint
6653 case Nkind (Constr) is
6654 when N_Discriminant_Association =>
6655 Require_Static (Expression (Constr));
6658 Require_Static (Low_Bound (Constr));
6659 Require_Static (High_Bound (Constr));
6661 when N_Attribute_Reference =>
6662 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
6663 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
6665 when N_Range_Constraint =>
6666 Check_Static_Constraint (Range_Expression (Constr));
6668 when N_Index_Or_Discriminant_Constraint =>
6672 IDC := First (Constraints (Constr));
6673 while Present (IDC) loop
6674 Check_Static_Constraint (IDC);
6682 end Check_Static_Constraint;
6684 --------------------------------------
6685 -- Check_Valid_Configuration_Pragma --
6686 --------------------------------------
6688 -- A configuration pragma must appear in the context clause of a
6689 -- compilation unit, and only other pragmas may precede it. Note that
6690 -- the test also allows use in a configuration pragma file.
6692 procedure Check_Valid_Configuration_Pragma is
6694 if not Is_Configuration_Pragma then
6695 Error_Pragma ("incorrect placement for configuration pragma%");
6697 end Check_Valid_Configuration_Pragma;
6699 -------------------------------------
6700 -- Check_Valid_Library_Unit_Pragma --
6701 -------------------------------------
6703 procedure Check_Valid_Library_Unit_Pragma is
6705 Parent_Node : Node_Id;
6706 Unit_Name : Entity_Id;
6707 Unit_Kind : Node_Kind;
6708 Unit_Node : Node_Id;
6709 Sindex : Source_File_Index;
6712 if not Is_List_Member (N) then
6716 Plist := List_Containing (N);
6717 Parent_Node := Parent (Plist);
6719 if Parent_Node = Empty then
6722 -- Case of pragma appearing after a compilation unit. In this case
6723 -- it must have an argument with the corresponding name and must
6724 -- be part of the following pragmas of its parent.
6726 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
6727 if Plist /= Pragmas_After (Parent_Node) then
6730 elsif Arg_Count = 0 then
6732 ("argument required if outside compilation unit");
6735 Check_No_Identifiers;
6736 Check_Arg_Count (1);
6737 Unit_Node := Unit (Parent (Parent_Node));
6738 Unit_Kind := Nkind (Unit_Node);
6740 Analyze (Get_Pragma_Arg (Arg1));
6742 if Unit_Kind = N_Generic_Subprogram_Declaration
6743 or else Unit_Kind = N_Subprogram_Declaration
6745 Unit_Name := Defining_Entity (Unit_Node);
6747 elsif Unit_Kind in N_Generic_Instantiation then
6748 Unit_Name := Defining_Entity (Unit_Node);
6751 Unit_Name := Cunit_Entity (Current_Sem_Unit);
6754 if Chars (Unit_Name) /=
6755 Chars (Entity (Get_Pragma_Arg (Arg1)))
6758 ("pragma% argument is not current unit name", Arg1);
6761 if Ekind (Unit_Name) = E_Package
6762 and then Present (Renamed_Entity (Unit_Name))
6764 Error_Pragma ("pragma% not allowed for renamed package");
6768 -- Pragma appears other than after a compilation unit
6771 -- Here we check for the generic instantiation case and also
6772 -- for the case of processing a generic formal package. We
6773 -- detect these cases by noting that the Sloc on the node
6774 -- does not belong to the current compilation unit.
6776 Sindex := Source_Index (Current_Sem_Unit);
6778 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
6779 Rewrite (N, Make_Null_Statement (Loc));
6782 -- If before first declaration, the pragma applies to the
6783 -- enclosing unit, and the name if present must be this name.
6785 elsif Is_Before_First_Decl (N, Plist) then
6786 Unit_Node := Unit_Declaration_Node (Current_Scope);
6787 Unit_Kind := Nkind (Unit_Node);
6789 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
6792 elsif Unit_Kind = N_Subprogram_Body
6793 and then not Acts_As_Spec (Unit_Node)
6797 elsif Nkind (Parent_Node) = N_Package_Body then
6800 elsif Nkind (Parent_Node) = N_Package_Specification
6801 and then Plist = Private_Declarations (Parent_Node)
6805 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
6806 or else Nkind (Parent_Node) =
6807 N_Generic_Subprogram_Declaration)
6808 and then Plist = Generic_Formal_Declarations (Parent_Node)
6812 elsif Arg_Count > 0 then
6813 Analyze (Get_Pragma_Arg (Arg1));
6815 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
6817 ("name in pragma% must be enclosing unit", Arg1);
6820 -- It is legal to have no argument in this context
6826 -- Error if not before first declaration. This is because a
6827 -- library unit pragma argument must be the name of a library
6828 -- unit (RM 10.1.5(7)), but the only names permitted in this
6829 -- context are (RM 10.1.5(6)) names of subprogram declarations,
6830 -- generic subprogram declarations or generic instantiations.
6834 ("pragma% misplaced, must be before first declaration");
6838 end Check_Valid_Library_Unit_Pragma;
6844 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
6845 Clist : constant Node_Id := Component_List (Variant);
6849 Comp := First_Non_Pragma (Component_Items (Clist));
6850 while Present (Comp) loop
6851 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
6852 Next_Non_Pragma (Comp);
6856 ---------------------------
6857 -- Ensure_Aggregate_Form --
6858 ---------------------------
6860 procedure Ensure_Aggregate_Form (Arg : Node_Id) is
6861 CFSD : constant Boolean := Get_Comes_From_Source_Default;
6862 Expr : constant Node_Id := Expression (Arg);
6863 Loc : constant Source_Ptr := Sloc (Expr);
6864 Comps : List_Id := No_List;
6865 Exprs : List_Id := No_List;
6866 Nam : Name_Id := No_Name;
6867 Nam_Loc : Source_Ptr;
6870 -- The pragma argument is in positional form:
6872 -- pragma Depends (Nam => ...)
6876 -- Note that the Sloc of the Chars field is the Sloc of the pragma
6877 -- argument association.
6879 if Nkind (Arg) = N_Pragma_Argument_Association then
6881 Nam_Loc := Sloc (Arg);
6883 -- Remove the pragma argument name as this will be captured in the
6886 Set_Chars (Arg, No_Name);
6889 -- The argument is already in aggregate form, but the presence of a
6890 -- name causes this to be interpreted as named association which in
6891 -- turn must be converted into an aggregate.
6893 -- pragma Global (In_Out => (A, B, C))
6897 -- pragma Global ((In_Out => (A, B, C)))
6899 -- aggregate aggregate
6901 if Nkind (Expr) = N_Aggregate then
6902 if Nam = No_Name then
6906 -- Do not transform a null argument into an aggregate as N_Null has
6907 -- special meaning in formal verification pragmas.
6909 elsif Nkind (Expr) = N_Null then
6913 -- Everything comes from source if the original comes from source
6915 Set_Comes_From_Source_Default (Comes_From_Source (Arg));
6917 -- Positional argument is transformed into an aggregate with an
6918 -- Expressions list.
6920 if Nam = No_Name then
6921 Exprs := New_List (Relocate_Node (Expr));
6923 -- An associative argument is transformed into an aggregate with
6924 -- Component_Associations.
6928 Make_Component_Association (Loc,
6929 Choices => New_List (Make_Identifier (Nam_Loc, Nam)),
6930 Expression => Relocate_Node (Expr)));
6933 Set_Expression (Arg,
6934 Make_Aggregate (Loc,
6935 Component_Associations => Comps,
6936 Expressions => Exprs));
6938 -- Restore Comes_From_Source default
6940 Set_Comes_From_Source_Default (CFSD);
6941 end Ensure_Aggregate_Form;
6947 procedure Error_Pragma (Msg : String) is
6949 Error_Msg_Name_1 := Pname;
6950 Error_Msg_N (Fix_Error (Msg), N);
6954 ----------------------
6955 -- Error_Pragma_Arg --
6956 ----------------------
6958 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
6960 Error_Msg_Name_1 := Pname;
6961 Error_Msg_N (Fix_Error (Msg), Get_Pragma_Arg (Arg));
6963 end Error_Pragma_Arg;
6965 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
6967 Error_Msg_Name_1 := Pname;
6968 Error_Msg_N (Fix_Error (Msg1), Get_Pragma_Arg (Arg));
6969 Error_Pragma_Arg (Msg2, Arg);
6970 end Error_Pragma_Arg;
6972 ----------------------------
6973 -- Error_Pragma_Arg_Ident --
6974 ----------------------------
6976 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
6978 Error_Msg_Name_1 := Pname;
6979 Error_Msg_N (Fix_Error (Msg), Arg);
6981 end Error_Pragma_Arg_Ident;
6983 ----------------------
6984 -- Error_Pragma_Ref --
6985 ----------------------
6987 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
6989 Error_Msg_Name_1 := Pname;
6990 Error_Msg_Sloc := Sloc (Ref);
6991 Error_Msg_NE (Fix_Error (Msg), N, Ref);
6993 end Error_Pragma_Ref;
6995 ------------------------
6996 -- Find_Lib_Unit_Name --
6997 ------------------------
6999 function Find_Lib_Unit_Name return Entity_Id is
7001 -- Return inner compilation unit entity, for case of nested
7002 -- categorization pragmas. This happens in generic unit.
7004 if Nkind (Parent (N)) = N_Package_Specification
7005 and then Defining_Entity (Parent (N)) /= Current_Scope
7007 return Defining_Entity (Parent (N));
7009 return Current_Scope;
7011 end Find_Lib_Unit_Name;
7013 ----------------------------
7014 -- Find_Program_Unit_Name --
7015 ----------------------------
7017 procedure Find_Program_Unit_Name (Id : Node_Id) is
7018 Unit_Name : Entity_Id;
7019 Unit_Kind : Node_Kind;
7020 P : constant Node_Id := Parent (N);
7023 if Nkind (P) = N_Compilation_Unit then
7024 Unit_Kind := Nkind (Unit (P));
7026 if Nkind_In (Unit_Kind, N_Subprogram_Declaration,
7027 N_Package_Declaration)
7028 or else Unit_Kind in N_Generic_Declaration
7030 Unit_Name := Defining_Entity (Unit (P));
7032 if Chars (Id) = Chars (Unit_Name) then
7033 Set_Entity (Id, Unit_Name);
7034 Set_Etype (Id, Etype (Unit_Name));
7036 Set_Etype (Id, Any_Type);
7038 ("cannot find program unit referenced by pragma%");
7042 Set_Etype (Id, Any_Type);
7043 Error_Pragma ("pragma% inapplicable to this unit");
7049 end Find_Program_Unit_Name;
7051 -----------------------------------------
7052 -- Find_Unique_Parameterless_Procedure --
7053 -----------------------------------------
7055 function Find_Unique_Parameterless_Procedure
7057 Arg : Node_Id) return Entity_Id
7059 Proc : Entity_Id := Empty;
7062 -- The body of this procedure needs some comments ???
7064 if not Is_Entity_Name (Name) then
7066 ("argument of pragma% must be entity name", Arg);
7068 elsif not Is_Overloaded (Name) then
7069 Proc := Entity (Name);
7071 if Ekind (Proc) /= E_Procedure
7072 or else Present (First_Formal (Proc))
7075 ("argument of pragma% must be parameterless procedure", Arg);
7080 Found : Boolean := False;
7082 Index : Interp_Index;
7085 Get_First_Interp (Name, Index, It);
7086 while Present (It.Nam) loop
7089 if Ekind (Proc) = E_Procedure
7090 and then No (First_Formal (Proc))
7094 Set_Entity (Name, Proc);
7095 Set_Is_Overloaded (Name, False);
7098 ("ambiguous handler name for pragma% ", Arg);
7102 Get_Next_Interp (Index, It);
7107 ("argument of pragma% must be parameterless procedure",
7110 Proc := Entity (Name);
7116 end Find_Unique_Parameterless_Procedure;
7122 function Fix_Error (Msg : String) return String is
7123 Res : String (Msg'Range) := Msg;
7124 Res_Last : Natural := Msg'Last;
7128 -- If we have a rewriting of another pragma, go to that pragma
7130 if Is_Rewrite_Substitution (N)
7131 and then Nkind (Original_Node (N)) = N_Pragma
7133 Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
7136 -- Case where pragma comes from an aspect specification
7138 if From_Aspect_Specification (N) then
7140 -- Change appearence of "pragma" in message to "aspect"
7143 while J <= Res_Last - 5 loop
7144 if Res (J .. J + 5) = "pragma" then
7145 Res (J .. J + 5) := "aspect";
7153 -- Change "argument of" at start of message to "entity for"
7156 and then Res (Res'First .. Res'First + 10) = "argument of"
7158 Res (Res'First .. Res'First + 9) := "entity for";
7159 Res (Res'First + 10 .. Res_Last - 1) :=
7160 Res (Res'First + 11 .. Res_Last);
7161 Res_Last := Res_Last - 1;
7164 -- Change "argument" at start of message to "entity"
7167 and then Res (Res'First .. Res'First + 7) = "argument"
7169 Res (Res'First .. Res'First + 5) := "entity";
7170 Res (Res'First + 6 .. Res_Last - 2) :=
7171 Res (Res'First + 8 .. Res_Last);
7172 Res_Last := Res_Last - 2;
7175 -- Get name from corresponding aspect
7177 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
7180 -- Return possibly modified message
7182 return Res (Res'First .. Res_Last);
7185 -------------------------
7186 -- Gather_Associations --
7187 -------------------------
7189 procedure Gather_Associations
7191 Args : out Args_List)
7196 -- Initialize all parameters to Empty
7198 for J in Args'Range loop
7202 -- That's all we have to do if there are no argument associations
7204 if No (Pragma_Argument_Associations (N)) then
7208 -- Otherwise first deal with any positional parameters present
7210 Arg := First (Pragma_Argument_Associations (N));
7211 for Index in Args'Range loop
7212 exit when No (Arg) or else Chars (Arg) /= No_Name;
7213 Args (Index) := Get_Pragma_Arg (Arg);
7217 -- Positional parameters all processed, if any left, then we
7218 -- have too many positional parameters.
7220 if Present (Arg) and then Chars (Arg) = No_Name then
7222 ("too many positional associations for pragma%", Arg);
7225 -- Process named parameters if any are present
7227 while Present (Arg) loop
7228 if Chars (Arg) = No_Name then
7230 ("positional association cannot follow named association",
7234 for Index in Names'Range loop
7235 if Names (Index) = Chars (Arg) then
7236 if Present (Args (Index)) then
7238 ("duplicate argument association for pragma%", Arg);
7240 Args (Index) := Get_Pragma_Arg (Arg);
7245 if Index = Names'Last then
7246 Error_Msg_Name_1 := Pname;
7247 Error_Msg_N ("pragma% does not allow & argument", Arg);
7249 -- Check for possible misspelling
7251 for Index1 in Names'Range loop
7252 if Is_Bad_Spelling_Of
7253 (Chars (Arg), Names (Index1))
7255 Error_Msg_Name_1 := Names (Index1);
7256 Error_Msg_N -- CODEFIX
7257 ("\possible misspelling of%", Arg);
7269 end Gather_Associations;
7275 procedure GNAT_Pragma is
7277 -- We need to check the No_Implementation_Pragmas restriction for
7278 -- the case of a pragma from source. Note that the case of aspects
7279 -- generating corresponding pragmas marks these pragmas as not being
7280 -- from source, so this test also catches that case.
7282 if Comes_From_Source (N) then
7283 Check_Restriction (No_Implementation_Pragmas, N);
7287 --------------------------
7288 -- Is_Before_First_Decl --
7289 --------------------------
7291 function Is_Before_First_Decl
7292 (Pragma_Node : Node_Id;
7293 Decls : List_Id) return Boolean
7295 Item : Node_Id := First (Decls);
7298 -- Only other pragmas can come before this pragma, but they might
7299 -- have been rewritten so check the original node.
7302 if No (Item) or else Nkind (Original_Node (Item)) /= N_Pragma then
7305 elsif Item = Pragma_Node then
7311 end Is_Before_First_Decl;
7313 -----------------------------
7314 -- Is_Configuration_Pragma --
7315 -----------------------------
7317 -- A configuration pragma must appear in the context clause of a
7318 -- compilation unit, and only other pragmas may precede it. Note that
7319 -- the test below also permits use in a configuration pragma file.
7321 function Is_Configuration_Pragma return Boolean is
7322 Lis : constant List_Id := List_Containing (N);
7323 Par : constant Node_Id := Parent (N);
7327 -- If no parent, then we are in the configuration pragma file,
7328 -- so the placement is definitely appropriate.
7333 -- Otherwise we must be in the context clause of a compilation unit
7334 -- and the only thing allowed before us in the context list is more
7335 -- configuration pragmas.
7337 elsif Nkind (Par) = N_Compilation_Unit
7338 and then Context_Items (Par) = Lis
7345 elsif Nkind (Prg) /= N_Pragma then
7355 end Is_Configuration_Pragma;
7357 --------------------------
7358 -- Is_In_Context_Clause --
7359 --------------------------
7361 function Is_In_Context_Clause return Boolean is
7363 Parent_Node : Node_Id;
7366 if not Is_List_Member (N) then
7370 Plist := List_Containing (N);
7371 Parent_Node := Parent (Plist);
7373 if Parent_Node = Empty
7374 or else Nkind (Parent_Node) /= N_Compilation_Unit
7375 or else Context_Items (Parent_Node) /= Plist
7382 end Is_In_Context_Clause;
7384 ---------------------------------
7385 -- Is_Static_String_Expression --
7386 ---------------------------------
7388 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
7389 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
7390 Lit : constant Boolean := Nkind (Argx) = N_String_Literal;
7393 Analyze_And_Resolve (Argx);
7395 -- Special case Ada 83, where the expression will never be static,
7396 -- but we will return true if we had a string literal to start with.
7398 if Ada_Version = Ada_83 then
7401 -- Normal case, true only if we end up with a string literal that
7402 -- is marked as being the result of evaluating a static expression.
7405 return Is_OK_Static_Expression (Argx)
7406 and then Nkind (Argx) = N_String_Literal;
7409 end Is_Static_String_Expression;
7411 ----------------------
7412 -- Pragma_Misplaced --
7413 ----------------------
7415 procedure Pragma_Misplaced is
7417 Error_Pragma ("incorrect placement of pragma%");
7418 end Pragma_Misplaced;
7420 ------------------------------------------------
7421 -- Process_Atomic_Independent_Shared_Volatile --
7422 ------------------------------------------------
7424 procedure Process_Atomic_Independent_Shared_Volatile is
7425 procedure Check_VFA_Conflicts (Ent : Entity_Id);
7426 -- Check that Volatile_Full_Access and VFA do not conflict
7428 procedure Mark_Component_Or_Object (Ent : Entity_Id);
7429 -- Appropriately set flags on the given entity, either an array or
7430 -- record component, or an object declaration) according to the
7433 procedure Mark_Type (Ent : Entity_Id);
7434 -- Appropriately set flags on the given entity, a type
7436 procedure Set_Atomic_VFA (Ent : Entity_Id);
7437 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
7438 -- no explicit alignment was given, set alignment to unknown, since
7439 -- back end knows what the alignment requirements are for atomic and
7440 -- full access arrays. Note: this is necessary for derived types.
7442 -------------------------
7443 -- Check_VFA_Conflicts --
7444 -------------------------
7446 procedure Check_VFA_Conflicts (Ent : Entity_Id) is
7450 VFA_And_Atomic : Boolean := False;
7451 -- Set True if both VFA and Atomic present
7454 -- Fetch the type in case we are dealing with an object or
7457 if Is_Type (Ent) then
7460 pragma Assert (Is_Object (Ent)
7462 Nkind (Declaration_Node (Ent)) = N_Component_Declaration);
7467 -- Check Atomic and VFA used together
7469 if Prag_Id = Pragma_Volatile_Full_Access
7470 or else Is_Volatile_Full_Access (Ent)
7472 if Prag_Id = Pragma_Atomic
7473 or else Prag_Id = Pragma_Shared
7474 or else Is_Atomic (Ent)
7476 VFA_And_Atomic := True;
7478 elsif Is_Array_Type (Typ) then
7479 VFA_And_Atomic := Has_Atomic_Components (Typ);
7481 -- Note: Has_Atomic_Components is not used below, as this flag
7482 -- represents the pragma of the same name, Atomic_Components,
7483 -- which only applies to arrays.
7485 elsif Is_Record_Type (Typ) then
7486 -- Attributes cannot be applied to discriminants, only
7487 -- regular record components.
7489 Comp := First_Component (Typ);
7490 while Present (Comp) loop
7492 or else Is_Atomic (Typ)
7494 VFA_And_Atomic := True;
7499 Next_Component (Comp);
7503 if VFA_And_Atomic then
7505 ("cannot have Volatile_Full_Access and Atomic for same "
7509 end Check_VFA_Conflicts;
7511 ------------------------------
7512 -- Mark_Component_Or_Object --
7513 ------------------------------
7515 procedure Mark_Component_Or_Object (Ent : Entity_Id) is
7517 if Prag_Id = Pragma_Atomic
7518 or else Prag_Id = Pragma_Shared
7519 or else Prag_Id = Pragma_Volatile_Full_Access
7521 if Prag_Id = Pragma_Volatile_Full_Access then
7522 Set_Is_Volatile_Full_Access (Ent);
7524 Set_Is_Atomic (Ent);
7527 -- If the object declaration has an explicit initialization, a
7528 -- temporary may have to be created to hold the expression, to
7529 -- ensure that access to the object remains atomic.
7531 if Nkind (Parent (Ent)) = N_Object_Declaration
7532 and then Present (Expression (Parent (Ent)))
7534 Set_Has_Delayed_Freeze (Ent);
7538 -- Atomic/Shared/Volatile_Full_Access imply Independent
7540 if Prag_Id /= Pragma_Volatile then
7541 Set_Is_Independent (Ent);
7543 if Prag_Id = Pragma_Independent then
7544 Record_Independence_Check (N, Ent);
7548 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7550 if Prag_Id /= Pragma_Independent then
7551 Set_Is_Volatile (Ent);
7552 Set_Treat_As_Volatile (Ent);
7554 end Mark_Component_Or_Object;
7560 procedure Mark_Type (Ent : Entity_Id) is
7562 -- Attribute belongs on the base type. If the view of the type is
7563 -- currently private, it also belongs on the underlying type.
7565 -- In Ada_2020, the pragma can apply to a formal type, for which
7566 -- there may be no underlying type.
7568 if Prag_Id = Pragma_Atomic
7569 or else Prag_Id = Pragma_Shared
7570 or else Prag_Id = Pragma_Volatile_Full_Access
7572 Set_Atomic_VFA (Ent);
7573 Set_Atomic_VFA (Base_Type (Ent));
7575 if not Is_Generic_Type (Ent) then
7576 Set_Atomic_VFA (Underlying_Type (Ent));
7580 -- Atomic/Shared/Volatile_Full_Access imply Independent
7582 if Prag_Id /= Pragma_Volatile then
7583 Set_Is_Independent (Ent);
7584 Set_Is_Independent (Base_Type (Ent));
7586 if not Is_Generic_Type (Ent) then
7587 Set_Is_Independent (Underlying_Type (Ent));
7589 if Prag_Id = Pragma_Independent then
7590 Record_Independence_Check (N, Base_Type (Ent));
7595 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7597 if Prag_Id /= Pragma_Independent then
7598 Set_Is_Volatile (Ent);
7599 Set_Is_Volatile (Base_Type (Ent));
7601 if not Is_Generic_Type (Ent) then
7602 Set_Is_Volatile (Underlying_Type (Ent));
7603 Set_Treat_As_Volatile (Underlying_Type (Ent));
7606 Set_Treat_As_Volatile (Ent);
7609 -- Apply Volatile to the composite type's individual components,
7612 if Prag_Id = Pragma_Volatile
7613 and then Is_Record_Type (Etype (Ent))
7618 Comp := First_Component (Ent);
7619 while Present (Comp) loop
7620 Mark_Component_Or_Object (Comp);
7622 Next_Component (Comp);
7628 --------------------
7629 -- Set_Atomic_VFA --
7630 --------------------
7632 procedure Set_Atomic_VFA (Ent : Entity_Id) is
7634 if Prag_Id = Pragma_Volatile_Full_Access then
7635 Set_Is_Volatile_Full_Access (Ent);
7637 Set_Is_Atomic (Ent);
7640 if not Has_Alignment_Clause (Ent) then
7641 Set_Alignment (Ent, Uint_0);
7651 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
7654 Check_Ada_83_Warning;
7655 Check_No_Identifiers;
7656 Check_Arg_Count (1);
7657 Check_Arg_Is_Local_Name (Arg1);
7658 E_Arg := Get_Pragma_Arg (Arg1);
7660 if Etype (E_Arg) = Any_Type then
7664 E := Entity (E_Arg);
7666 -- A pragma that applies to a Ghost entity becomes Ghost for the
7667 -- purposes of legality checks and removal of ignored Ghost code.
7669 Mark_Ghost_Pragma (N, E);
7671 -- Check duplicate before we chain ourselves
7673 Check_Duplicate_Pragma (E);
7675 -- Check appropriateness of the entity
7677 Decl := Declaration_Node (E);
7679 -- Deal with the case where the pragma/attribute is applied to a type
7682 if Rep_Item_Too_Early (E, N)
7683 or else Rep_Item_Too_Late (E, N)
7687 Check_First_Subtype (Arg1);
7692 -- Deal with the case where the pragma/attribute applies to a
7693 -- component or object declaration.
7695 elsif Nkind (Decl) = N_Object_Declaration
7696 or else (Nkind (Decl) = N_Component_Declaration
7697 and then Original_Record_Component (E) = E)
7699 if Rep_Item_Too_Late (E, N) then
7703 Mark_Component_Or_Object (E);
7705 -- In other cases give an error
7708 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
7711 -- Check that Volatile_Full_Access and Atomic do not conflict
7713 Check_VFA_Conflicts (E);
7715 -- Check for the application of Atomic or Volatile_Full_Access to
7716 -- an entity that has [nonatomic] aliased, or else specified to be
7717 -- independently addressable, subcomponents.
7719 if (Prag_Id = Pragma_Atomic and then Ada_Version >= Ada_2020)
7720 or else Prag_Id = Pragma_Volatile_Full_Access
7722 Check_Atomic_VFA (E, VFA => Prag_Id = Pragma_Volatile_Full_Access);
7725 -- The following check is only relevant when SPARK_Mode is on as
7726 -- this is not a standard Ada legality rule. Pragma Volatile can
7727 -- only apply to a full type declaration or an object declaration
7728 -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for
7729 -- untagged derived types that are rewritten as subtypes of their
7730 -- respective root types.
7733 and then Prag_Id = Pragma_Volatile
7734 and then not Nkind_In (Original_Node (Decl),
7735 N_Full_Type_Declaration,
7736 N_Object_Declaration,
7737 N_Single_Protected_Declaration,
7738 N_Single_Task_Declaration)
7741 ("argument of pragma % must denote a full type or object "
7742 & "declaration", Arg1);
7744 end Process_Atomic_Independent_Shared_Volatile;
7746 -------------------------------------------
7747 -- Process_Compile_Time_Warning_Or_Error --
7748 -------------------------------------------
7750 procedure Process_Compile_Time_Warning_Or_Error is
7751 P : Node_Id := Parent (N);
7752 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
7755 Check_Arg_Count (2);
7756 Check_No_Identifiers;
7757 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
7758 Analyze_And_Resolve (Arg1x, Standard_Boolean);
7760 -- In GNATprove mode, pragma Compile_Time_Error is translated as
7761 -- a Check pragma in GNATprove mode, handled as an assumption in
7762 -- GNATprove. This is correct as the compiler will issue an error
7763 -- if the condition cannot be statically evaluated to False.
7764 -- Compile_Time_Warning are ignored, as the analyzer may not have the
7765 -- same information as the compiler (in particular regarding size of
7766 -- objects decided in gigi) so it makes no sense to issue a warning
7769 if GNATprove_Mode then
7770 if Prag_Id = Pragma_Compile_Time_Error then
7774 -- Implement Compile_Time_Error by generating
7775 -- a corresponding Check pragma:
7777 -- pragma Check (name, condition);
7779 -- where name is the identifier matching the pragma name. So
7780 -- rewrite pragma in this manner and analyze the result.
7782 New_Args := New_List
7783 (Make_Pragma_Argument_Association
7785 Expression => Make_Identifier (Loc, Pname)),
7786 Make_Pragma_Argument_Association
7788 Expression => Arg1x));
7790 -- Rewrite as Check pragma
7794 Chars => Name_Check,
7795 Pragma_Argument_Associations => New_Args));
7801 Rewrite (N, Make_Null_Statement (Loc));
7807 -- If the condition is known at compile time (now), validate it now.
7808 -- Otherwise, register the expression for validation after the back
7809 -- end has been called, because it might be known at compile time
7810 -- then. For example, if the expression is "Record_Type'Size /= 32"
7811 -- it might be known after the back end has determined the size of
7812 -- Record_Type. We do not defer validation if we're inside a generic
7813 -- unit, because we will have more information in the instances.
7815 if Compile_Time_Known_Value (Arg1x) then
7816 Validate_Compile_Time_Warning_Or_Error (N, Sloc (Arg1));
7818 while Present (P) and then Nkind (P) not in N_Generic_Declaration
7820 if Nkind_In (P, N_Package_Body, N_Subprogram_Body) then
7821 P := Corresponding_Spec (P);
7828 Defer_Compile_Time_Warning_Error_To_BE (N);
7831 end Process_Compile_Time_Warning_Or_Error;
7833 ------------------------
7834 -- Process_Convention --
7835 ------------------------
7837 procedure Process_Convention
7838 (C : out Convention_Id;
7839 Ent : out Entity_Id)
7843 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
7844 -- Called if we have more than one Export/Import/Convention pragma.
7845 -- This is generally illegal, but we have a special case of allowing
7846 -- Import and Interface to coexist if they specify the convention in
7847 -- a consistent manner. We are allowed to do this, since Interface is
7848 -- an implementation defined pragma, and we choose to do it since we
7849 -- know Rational allows this combination. S is the entity id of the
7850 -- subprogram in question. This procedure also sets the special flag
7851 -- Import_Interface_Present in both pragmas in the case where we do
7852 -- have matching Import and Interface pragmas.
7854 procedure Set_Convention_From_Pragma (E : Entity_Id);
7855 -- Set convention in entity E, and also flag that the entity has a
7856 -- convention pragma. If entity is for a private or incomplete type,
7857 -- also set convention and flag on underlying type. This procedure
7858 -- also deals with the special case of C_Pass_By_Copy convention,
7859 -- and error checks for inappropriate convention specification.
7861 -------------------------------
7862 -- Diagnose_Multiple_Pragmas --
7863 -------------------------------
7865 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
7866 Pdec : constant Node_Id := Declaration_Node (S);
7870 function Same_Convention (Decl : Node_Id) return Boolean;
7871 -- Decl is a pragma node. This function returns True if this
7872 -- pragma has a first argument that is an identifier with a
7873 -- Chars field corresponding to the Convention_Id C.
7875 function Same_Name (Decl : Node_Id) return Boolean;
7876 -- Decl is a pragma node. This function returns True if this
7877 -- pragma has a second argument that is an identifier with a
7878 -- Chars field that matches the Chars of the current subprogram.
7880 ---------------------
7881 -- Same_Convention --
7882 ---------------------
7884 function Same_Convention (Decl : Node_Id) return Boolean is
7885 Arg1 : constant Node_Id :=
7886 First (Pragma_Argument_Associations (Decl));
7889 if Present (Arg1) then
7891 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
7893 if Nkind (Arg) = N_Identifier
7894 and then Is_Convention_Name (Chars (Arg))
7895 and then Get_Convention_Id (Chars (Arg)) = C
7903 end Same_Convention;
7909 function Same_Name (Decl : Node_Id) return Boolean is
7910 Arg1 : constant Node_Id :=
7911 First (Pragma_Argument_Associations (Decl));
7919 Arg2 := Next (Arg1);
7926 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
7928 if Nkind (Arg) = N_Identifier
7929 and then Chars (Arg) = Chars (S)
7938 -- Start of processing for Diagnose_Multiple_Pragmas
7943 -- Definitely give message if we have Convention/Export here
7945 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
7948 -- If we have an Import or Export, scan back from pragma to
7949 -- find any previous pragma applying to the same procedure.
7950 -- The scan will be terminated by the start of the list, or
7951 -- hitting the subprogram declaration. This won't allow one
7952 -- pragma to appear in the public part and one in the private
7953 -- part, but that seems very unlikely in practice.
7957 while Present (Decl) and then Decl /= Pdec loop
7959 -- Look for pragma with same name as us
7961 if Nkind (Decl) = N_Pragma
7962 and then Same_Name (Decl)
7964 -- Give error if same as our pragma or Export/Convention
7966 if Nam_In (Pragma_Name_Unmapped (Decl),
7969 Pragma_Name_Unmapped (N))
7973 -- Case of Import/Interface or the other way round
7975 elsif Nam_In (Pragma_Name_Unmapped (Decl),
7976 Name_Interface, Name_Import)
7978 -- Here we know that we have Import and Interface. It
7979 -- doesn't matter which way round they are. See if
7980 -- they specify the same convention. If so, all OK,
7981 -- and set special flags to stop other messages
7983 if Same_Convention (Decl) then
7984 Set_Import_Interface_Present (N);
7985 Set_Import_Interface_Present (Decl);
7988 -- If different conventions, special message
7991 Error_Msg_Sloc := Sloc (Decl);
7993 ("convention differs from that given#", Arg1);
8003 -- Give message if needed if we fall through those tests
8004 -- except on Relaxed_RM_Semantics where we let go: either this
8005 -- is a case accepted/ignored by other Ada compilers (e.g.
8006 -- a mix of Convention and Import), or another error will be
8007 -- generated later (e.g. using both Import and Export).
8009 if Err and not Relaxed_RM_Semantics then
8011 ("at most one Convention/Export/Import pragma is allowed",
8014 end Diagnose_Multiple_Pragmas;
8016 --------------------------------
8017 -- Set_Convention_From_Pragma --
8018 --------------------------------
8020 procedure Set_Convention_From_Pragma (E : Entity_Id) is
8022 -- Ada 2005 (AI-430): Check invalid attempt to change convention
8023 -- for an overridden dispatching operation. Technically this is
8024 -- an amendment and should only be done in Ada 2005 mode. However,
8025 -- this is clearly a mistake, since the problem that is addressed
8026 -- by this AI is that there is a clear gap in the RM.
8028 if Is_Dispatching_Operation (E)
8029 and then Present (Overridden_Operation (E))
8030 and then C /= Convention (Overridden_Operation (E))
8033 ("cannot change convention for overridden dispatching "
8034 & "operation", Arg1);
8037 -- Special checks for Convention_Stdcall
8039 if C = Convention_Stdcall then
8041 -- A dispatching call is not allowed. A dispatching subprogram
8042 -- cannot be used to interface to the Win32 API, so in fact
8043 -- this check does not impose any effective restriction.
8045 if Is_Dispatching_Operation (E) then
8046 Error_Msg_Sloc := Sloc (E);
8048 -- Note: make this unconditional so that if there is more
8049 -- than one call to which the pragma applies, we get a
8050 -- message for each call. Also don't use Error_Pragma,
8051 -- so that we get multiple messages.
8054 ("dispatching subprogram# cannot use Stdcall convention!",
8057 -- Several allowed cases
8059 elsif Is_Subprogram_Or_Generic_Subprogram (E)
8063 or else Ekind (E) = E_Variable
8065 -- A component as well. The entity does not have its Ekind
8066 -- set until the enclosing record declaration is fully
8069 or else Nkind (Parent (E)) = N_Component_Declaration
8071 -- An access to subprogram is also allowed
8075 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
8077 -- Allow internal call to set convention of subprogram type
8079 or else Ekind (E) = E_Subprogram_Type
8085 ("second argument of pragma% must be subprogram (type)",
8090 -- Set the convention
8092 Set_Convention (E, C);
8093 Set_Has_Convention_Pragma (E);
8095 -- For the case of a record base type, also set the convention of
8096 -- any anonymous access types declared in the record which do not
8097 -- currently have a specified convention.
8099 if Is_Record_Type (E) and then Is_Base_Type (E) then
8104 Comp := First_Component (E);
8105 while Present (Comp) loop
8106 if Present (Etype (Comp))
8107 and then Ekind_In (Etype (Comp),
8108 E_Anonymous_Access_Type,
8109 E_Anonymous_Access_Subprogram_Type)
8110 and then not Has_Convention_Pragma (Comp)
8112 Set_Convention (Comp, C);
8115 Next_Component (Comp);
8120 -- Deal with incomplete/private type case, where underlying type
8121 -- is available, so set convention of that underlying type.
8123 if Is_Incomplete_Or_Private_Type (E)
8124 and then Present (Underlying_Type (E))
8126 Set_Convention (Underlying_Type (E), C);
8127 Set_Has_Convention_Pragma (Underlying_Type (E), True);
8130 -- A class-wide type should inherit the convention of the specific
8131 -- root type (although this isn't specified clearly by the RM).
8133 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
8134 Set_Convention (Class_Wide_Type (E), C);
8137 -- If the entity is a record type, then check for special case of
8138 -- C_Pass_By_Copy, which is treated the same as C except that the
8139 -- special record flag is set. This convention is only permitted
8140 -- on record types (see AI95-00131).
8142 if Cname = Name_C_Pass_By_Copy then
8143 if Is_Record_Type (E) then
8144 Set_C_Pass_By_Copy (Base_Type (E));
8145 elsif Is_Incomplete_Or_Private_Type (E)
8146 and then Is_Record_Type (Underlying_Type (E))
8148 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
8151 ("C_Pass_By_Copy convention allowed only for record type",
8156 -- If the entity is a derived boolean type, check for the special
8157 -- case of convention C, C++, or Fortran, where we consider any
8158 -- nonzero value to represent true.
8160 if Is_Discrete_Type (E)
8161 and then Root_Type (Etype (E)) = Standard_Boolean
8167 C = Convention_Fortran)
8169 Set_Nonzero_Is_True (Base_Type (E));
8171 end Set_Convention_From_Pragma;
8175 Comp_Unit : Unit_Number_Type;
8180 -- Start of processing for Process_Convention
8183 Check_At_Least_N_Arguments (2);
8184 Check_Optional_Identifier (Arg1, Name_Convention);
8185 Check_Arg_Is_Identifier (Arg1);
8186 Cname := Chars (Get_Pragma_Arg (Arg1));
8188 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
8189 -- tested again below to set the critical flag).
8191 if Cname = Name_C_Pass_By_Copy then
8194 -- Otherwise we must have something in the standard convention list
8196 elsif Is_Convention_Name (Cname) then
8197 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
8199 -- Otherwise warn on unrecognized convention
8202 if Warn_On_Export_Import then
8204 ("??unrecognized convention name, C assumed",
8205 Get_Pragma_Arg (Arg1));
8211 Check_Optional_Identifier (Arg2, Name_Entity);
8212 Check_Arg_Is_Local_Name (Arg2);
8214 Id := Get_Pragma_Arg (Arg2);
8217 if not Is_Entity_Name (Id) then
8218 Error_Pragma_Arg ("entity name required", Arg2);
8223 -- Set entity to return
8227 -- Ada_Pass_By_Copy special checking
8229 if C = Convention_Ada_Pass_By_Copy then
8230 if not Is_First_Subtype (E) then
8232 ("convention `Ada_Pass_By_Copy` only allowed for types",
8236 if Is_By_Reference_Type (E) then
8238 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
8242 -- Ada_Pass_By_Reference special checking
8244 elsif C = Convention_Ada_Pass_By_Reference then
8245 if not Is_First_Subtype (E) then
8247 ("convention `Ada_Pass_By_Reference` only allowed for types",
8251 if Is_By_Copy_Type (E) then
8253 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
8258 -- Go to renamed subprogram if present, since convention applies to
8259 -- the actual renamed entity, not to the renaming entity. If the
8260 -- subprogram is inherited, go to parent subprogram.
8262 if Is_Subprogram (E)
8263 and then Present (Alias (E))
8265 if Nkind (Parent (Declaration_Node (E))) =
8266 N_Subprogram_Renaming_Declaration
8268 if Scope (E) /= Scope (Alias (E)) then
8270 ("cannot apply pragma% to non-local entity&#", E);
8275 elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
8276 N_Private_Extension_Declaration)
8277 and then Scope (E) = Scope (Alias (E))
8281 -- Return the parent subprogram the entity was inherited from
8287 -- Check that we are not applying this to a specless body. Relax this
8288 -- check if Relaxed_RM_Semantics to accommodate other Ada compilers.
8290 if Is_Subprogram (E)
8291 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
8292 and then not Relaxed_RM_Semantics
8295 ("pragma% requires separate spec and must come before body");
8298 -- Check that we are not applying this to a named constant
8300 if Ekind_In (E, E_Named_Integer, E_Named_Real) then
8301 Error_Msg_Name_1 := Pname;
8303 ("cannot apply pragma% to named constant!",
8304 Get_Pragma_Arg (Arg2));
8306 ("\supply appropriate type for&!", Arg2);
8309 if Ekind (E) = E_Enumeration_Literal then
8310 Error_Pragma ("enumeration literal not allowed for pragma%");
8313 -- Check for rep item appearing too early or too late
8315 if Etype (E) = Any_Type
8316 or else Rep_Item_Too_Early (E, N)
8320 elsif Present (Underlying_Type (E)) then
8321 E := Underlying_Type (E);
8324 if Rep_Item_Too_Late (E, N) then
8328 if Has_Convention_Pragma (E) then
8329 Diagnose_Multiple_Pragmas (E);
8331 elsif Convention (E) = Convention_Protected
8332 or else Ekind (Scope (E)) = E_Protected_Type
8335 ("a protected operation cannot be given a different convention",
8339 -- For Intrinsic, a subprogram is required
8341 if C = Convention_Intrinsic
8342 and then not Is_Subprogram_Or_Generic_Subprogram (E)
8344 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
8346 if not (Is_Type (E) and then Relaxed_RM_Semantics) then
8348 ("second argument of pragma% must be a subprogram", Arg2);
8352 -- Deal with non-subprogram cases
8354 if not Is_Subprogram_Or_Generic_Subprogram (E) then
8355 Set_Convention_From_Pragma (E);
8359 -- The pragma must apply to a first subtype, but it can also
8360 -- apply to a generic type in a generic formal part, in which
8361 -- case it will also appear in the corresponding instance.
8363 if Is_Generic_Type (E) or else In_Instance then
8366 Check_First_Subtype (Arg2);
8369 Set_Convention_From_Pragma (Base_Type (E));
8371 -- For access subprograms, we must set the convention on the
8372 -- internally generated directly designated type as well.
8374 if Ekind (E) = E_Access_Subprogram_Type then
8375 Set_Convention_From_Pragma (Directly_Designated_Type (E));
8379 -- For the subprogram case, set proper convention for all homonyms
8380 -- in same scope and the same declarative part, i.e. the same
8381 -- compilation unit.
8384 Comp_Unit := Get_Source_Unit (E);
8385 Set_Convention_From_Pragma (E);
8387 -- Treat a pragma Import as an implicit body, and pragma import
8388 -- as implicit reference (for navigation in GNAT Studio).
8390 if Prag_Id = Pragma_Import then
8391 Generate_Reference (E, Id, 'b');
8393 -- For exported entities we restrict the generation of references
8394 -- to entities exported to foreign languages since entities
8395 -- exported to Ada do not provide further information to
8396 -- GNAT Studio and add undesired references to the output of the
8399 elsif Prag_Id = Pragma_Export
8400 and then Convention (E) /= Convention_Ada
8402 Generate_Reference (E, Id, 'i');
8405 -- If the pragma comes from an aspect, it only applies to the
8406 -- given entity, not its homonyms.
8408 if From_Aspect_Specification (N) then
8409 if C = Convention_Intrinsic
8410 and then Nkind (Ent) = N_Defining_Operator_Symbol
8412 if Is_Fixed_Point_Type (Etype (Ent))
8413 or else Is_Fixed_Point_Type (Etype (First_Entity (Ent)))
8414 or else Is_Fixed_Point_Type (Etype (Last_Entity (Ent)))
8417 ("no intrinsic operator available for this fixed-point "
8420 ("\use expression functions with the desired "
8421 & "conversions made explicit", N);
8428 -- Otherwise Loop through the homonyms of the pragma argument's
8429 -- entity, an apply convention to those in the current scope.
8435 exit when No (E1) or else Scope (E1) /= Current_Scope;
8437 -- Ignore entry for which convention is already set
8439 if Has_Convention_Pragma (E1) then
8443 if Is_Subprogram (E1)
8444 and then Nkind (Parent (Declaration_Node (E1))) =
8446 and then not Relaxed_RM_Semantics
8448 Set_Has_Completion (E); -- to prevent cascaded error
8450 ("pragma% requires separate spec and must come before "
8454 -- Do not set the pragma on inherited operations or on formal
8457 if Comes_From_Source (E1)
8458 and then Comp_Unit = Get_Source_Unit (E1)
8459 and then not Is_Formal_Subprogram (E1)
8460 and then Nkind (Original_Node (Parent (E1))) /=
8461 N_Full_Type_Declaration
8463 if Present (Alias (E1))
8464 and then Scope (E1) /= Scope (Alias (E1))
8467 ("cannot apply pragma% to non-local entity& declared#",
8471 Set_Convention_From_Pragma (E1);
8473 if Prag_Id = Pragma_Import then
8474 Generate_Reference (E1, Id, 'b');
8482 end Process_Convention;
8484 ----------------------------------------
8485 -- Process_Disable_Enable_Atomic_Sync --
8486 ----------------------------------------
8488 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
8490 Check_No_Identifiers;
8491 Check_At_Most_N_Arguments (1);
8493 -- Modeled internally as
8494 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
8499 Pragma_Argument_Associations => New_List (
8500 Make_Pragma_Argument_Association (Loc,
8502 Make_Identifier (Loc, Name_Atomic_Synchronization)))));
8504 if Present (Arg1) then
8505 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
8509 end Process_Disable_Enable_Atomic_Sync;
8511 -------------------------------------------------
8512 -- Process_Extended_Import_Export_Internal_Arg --
8513 -------------------------------------------------
8515 procedure Process_Extended_Import_Export_Internal_Arg
8516 (Arg_Internal : Node_Id := Empty)
8519 if No (Arg_Internal) then
8520 Error_Pragma ("Internal parameter required for pragma%");
8523 if Nkind (Arg_Internal) = N_Identifier then
8526 elsif Nkind (Arg_Internal) = N_Operator_Symbol
8527 and then (Prag_Id = Pragma_Import_Function
8529 Prag_Id = Pragma_Export_Function)
8535 ("wrong form for Internal parameter for pragma%", Arg_Internal);
8538 Check_Arg_Is_Local_Name (Arg_Internal);
8539 end Process_Extended_Import_Export_Internal_Arg;
8541 --------------------------------------------------
8542 -- Process_Extended_Import_Export_Object_Pragma --
8543 --------------------------------------------------
8545 procedure Process_Extended_Import_Export_Object_Pragma
8546 (Arg_Internal : Node_Id;
8547 Arg_External : Node_Id;
8553 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
8554 Def_Id := Entity (Arg_Internal);
8556 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
8558 ("pragma% must designate an object", Arg_Internal);
8561 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
8563 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
8566 ("previous Common/Psect_Object applies, pragma % not permitted",
8570 if Rep_Item_Too_Late (Def_Id, N) then
8574 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
8576 if Present (Arg_Size) then
8577 Check_Arg_Is_External_Name (Arg_Size);
8580 -- Export_Object case
8582 if Prag_Id = Pragma_Export_Object then
8583 if not Is_Library_Level_Entity (Def_Id) then
8585 ("argument for pragma% must be library level entity",
8589 if Ekind (Current_Scope) = E_Generic_Package then
8590 Error_Pragma ("pragma& cannot appear in a generic unit");
8593 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
8595 ("exported object must have compile time known size",
8599 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
8600 Error_Msg_N ("??duplicate Export_Object pragma", N);
8602 Set_Exported (Def_Id, Arg_Internal);
8605 -- Import_Object case
8608 if Is_Concurrent_Type (Etype (Def_Id)) then
8610 ("cannot use pragma% for task/protected object",
8614 if Ekind (Def_Id) = E_Constant then
8616 ("cannot import a constant", Arg_Internal);
8619 if Warn_On_Export_Import
8620 and then Has_Discriminants (Etype (Def_Id))
8623 ("imported value must be initialized??", Arg_Internal);
8626 if Warn_On_Export_Import
8627 and then Is_Access_Type (Etype (Def_Id))
8630 ("cannot import object of an access type??", Arg_Internal);
8633 if Warn_On_Export_Import
8634 and then Is_Imported (Def_Id)
8636 Error_Msg_N ("??duplicate Import_Object pragma", N);
8638 -- Check for explicit initialization present. Note that an
8639 -- initialization generated by the code generator, e.g. for an
8640 -- access type, does not count here.
8642 elsif Present (Expression (Parent (Def_Id)))
8645 (Original_Node (Expression (Parent (Def_Id))))
8647 Error_Msg_Sloc := Sloc (Def_Id);
8649 ("imported entities cannot be initialized (RM B.1(24))",
8650 "\no initialization allowed for & declared#", Arg1);
8652 Set_Imported (Def_Id);
8653 Note_Possible_Modification (Arg_Internal, Sure => False);
8656 end Process_Extended_Import_Export_Object_Pragma;
8658 ------------------------------------------------------
8659 -- Process_Extended_Import_Export_Subprogram_Pragma --
8660 ------------------------------------------------------
8662 procedure Process_Extended_Import_Export_Subprogram_Pragma
8663 (Arg_Internal : Node_Id;
8664 Arg_External : Node_Id;
8665 Arg_Parameter_Types : Node_Id;
8666 Arg_Result_Type : Node_Id := Empty;
8667 Arg_Mechanism : Node_Id;
8668 Arg_Result_Mechanism : Node_Id := Empty)
8674 Ambiguous : Boolean;
8677 function Same_Base_Type
8679 Formal : Entity_Id) return Boolean;
8680 -- Determines if Ptype references the type of Formal. Note that only
8681 -- the base types need to match according to the spec. Ptype here is
8682 -- the argument from the pragma, which is either a type name, or an
8683 -- access attribute.
8685 --------------------
8686 -- Same_Base_Type --
8687 --------------------
8689 function Same_Base_Type
8691 Formal : Entity_Id) return Boolean
8693 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
8697 -- Case where pragma argument is typ'Access
8699 if Nkind (Ptype) = N_Attribute_Reference
8700 and then Attribute_Name (Ptype) = Name_Access
8702 Pref := Prefix (Ptype);
8705 if not Is_Entity_Name (Pref)
8706 or else Entity (Pref) = Any_Type
8711 -- We have a match if the corresponding argument is of an
8712 -- anonymous access type, and its designated type matches the
8713 -- type of the prefix of the access attribute
8715 return Ekind (Ftyp) = E_Anonymous_Access_Type
8716 and then Base_Type (Entity (Pref)) =
8717 Base_Type (Etype (Designated_Type (Ftyp)));
8719 -- Case where pragma argument is a type name
8724 if not Is_Entity_Name (Ptype)
8725 or else Entity (Ptype) = Any_Type
8730 -- We have a match if the corresponding argument is of the type
8731 -- given in the pragma (comparing base types)
8733 return Base_Type (Entity (Ptype)) = Ftyp;
8737 -- Start of processing for
8738 -- Process_Extended_Import_Export_Subprogram_Pragma
8741 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
8745 -- Loop through homonyms (overloadings) of the entity
8747 Hom_Id := Entity (Arg_Internal);
8748 while Present (Hom_Id) loop
8749 Def_Id := Get_Base_Subprogram (Hom_Id);
8751 -- We need a subprogram in the current scope
8753 if not Is_Subprogram (Def_Id)
8754 or else Scope (Def_Id) /= Current_Scope
8761 -- Pragma cannot apply to subprogram body
8763 if Is_Subprogram (Def_Id)
8764 and then Nkind (Parent (Declaration_Node (Def_Id))) =
8768 ("pragma% requires separate spec and must come before "
8772 -- Test result type if given, note that the result type
8773 -- parameter can only be present for the function cases.
8775 if Present (Arg_Result_Type)
8776 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
8780 elsif Etype (Def_Id) /= Standard_Void_Type
8781 and then Nam_In (Pname, Name_Export_Procedure,
8782 Name_Import_Procedure)
8786 -- Test parameter types if given. Note that this parameter has
8787 -- not been analyzed (and must not be, since it is semantic
8788 -- nonsense), so we get it as the parser left it.
8790 elsif Present (Arg_Parameter_Types) then
8791 Check_Matching_Types : declare
8796 Formal := First_Formal (Def_Id);
8798 if Nkind (Arg_Parameter_Types) = N_Null then
8799 if Present (Formal) then
8803 -- A list of one type, e.g. (List) is parsed as a
8804 -- parenthesized expression.
8806 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
8807 and then Paren_Count (Arg_Parameter_Types) = 1
8810 or else Present (Next_Formal (Formal))
8815 Same_Base_Type (Arg_Parameter_Types, Formal);
8818 -- A list of more than one type is parsed as a aggregate
8820 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
8821 and then Paren_Count (Arg_Parameter_Types) = 0
8823 Ptype := First (Expressions (Arg_Parameter_Types));
8824 while Present (Ptype) or else Present (Formal) loop
8827 or else not Same_Base_Type (Ptype, Formal)
8832 Next_Formal (Formal);
8837 -- Anything else is of the wrong form
8841 ("wrong form for Parameter_Types parameter",
8842 Arg_Parameter_Types);
8844 end Check_Matching_Types;
8847 -- Match is now False if the entry we found did not match
8848 -- either a supplied Parameter_Types or Result_Types argument
8854 -- Ambiguous case, the flag Ambiguous shows if we already
8855 -- detected this and output the initial messages.
8858 if not Ambiguous then
8860 Error_Msg_Name_1 := Pname;
8862 ("pragma% does not uniquely identify subprogram!",
8864 Error_Msg_Sloc := Sloc (Ent);
8865 Error_Msg_N ("matching subprogram #!", N);
8869 Error_Msg_Sloc := Sloc (Def_Id);
8870 Error_Msg_N ("matching subprogram #!", N);
8875 Hom_Id := Homonym (Hom_Id);
8878 -- See if we found an entry
8881 if not Ambiguous then
8882 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
8884 ("pragma% cannot be given for generic subprogram");
8887 ("pragma% does not identify local subprogram");
8894 -- Import pragmas must be for imported entities
8896 if Prag_Id = Pragma_Import_Function
8898 Prag_Id = Pragma_Import_Procedure
8900 Prag_Id = Pragma_Import_Valued_Procedure
8902 if not Is_Imported (Ent) then
8904 ("pragma Import or Interface must precede pragma%");
8907 -- Here we have the Export case which can set the entity as exported
8909 -- But does not do so if the specified external name is null, since
8910 -- that is taken as a signal in DEC Ada 83 (with which we want to be
8911 -- compatible) to request no external name.
8913 elsif Nkind (Arg_External) = N_String_Literal
8914 and then String_Length (Strval (Arg_External)) = 0
8918 -- In all other cases, set entity as exported
8921 Set_Exported (Ent, Arg_Internal);
8924 -- Special processing for Valued_Procedure cases
8926 if Prag_Id = Pragma_Import_Valued_Procedure
8928 Prag_Id = Pragma_Export_Valued_Procedure
8930 Formal := First_Formal (Ent);
8933 Error_Pragma ("at least one parameter required for pragma%");
8935 elsif Ekind (Formal) /= E_Out_Parameter then
8936 Error_Pragma ("first parameter must have mode out for pragma%");
8939 Set_Is_Valued_Procedure (Ent);
8943 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
8945 -- Process Result_Mechanism argument if present. We have already
8946 -- checked that this is only allowed for the function case.
8948 if Present (Arg_Result_Mechanism) then
8949 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
8952 -- Process Mechanism parameter if present. Note that this parameter
8953 -- is not analyzed, and must not be analyzed since it is semantic
8954 -- nonsense, so we get it in exactly as the parser left it.
8956 if Present (Arg_Mechanism) then
8964 -- A single mechanism association without a formal parameter
8965 -- name is parsed as a parenthesized expression. All other
8966 -- cases are parsed as aggregates, so we rewrite the single
8967 -- parameter case as an aggregate for consistency.
8969 if Nkind (Arg_Mechanism) /= N_Aggregate
8970 and then Paren_Count (Arg_Mechanism) = 1
8972 Rewrite (Arg_Mechanism,
8973 Make_Aggregate (Sloc (Arg_Mechanism),
8974 Expressions => New_List (
8975 Relocate_Node (Arg_Mechanism))));
8978 -- Case of only mechanism name given, applies to all formals
8980 if Nkind (Arg_Mechanism) /= N_Aggregate then
8981 Formal := First_Formal (Ent);
8982 while Present (Formal) loop
8983 Set_Mechanism_Value (Formal, Arg_Mechanism);
8984 Next_Formal (Formal);
8987 -- Case of list of mechanism associations given
8990 if Null_Record_Present (Arg_Mechanism) then
8992 ("inappropriate form for Mechanism parameter",
8996 -- Deal with positional ones first
8998 Formal := First_Formal (Ent);
9000 if Present (Expressions (Arg_Mechanism)) then
9001 Mname := First (Expressions (Arg_Mechanism));
9002 while Present (Mname) loop
9005 ("too many mechanism associations", Mname);
9008 Set_Mechanism_Value (Formal, Mname);
9009 Next_Formal (Formal);
9014 -- Deal with named entries
9016 if Present (Component_Associations (Arg_Mechanism)) then
9017 Massoc := First (Component_Associations (Arg_Mechanism));
9018 while Present (Massoc) loop
9019 Choice := First (Choices (Massoc));
9021 if Nkind (Choice) /= N_Identifier
9022 or else Present (Next (Choice))
9025 ("incorrect form for mechanism association",
9029 Formal := First_Formal (Ent);
9033 ("parameter name & not present", Choice);
9036 if Chars (Choice) = Chars (Formal) then
9038 (Formal, Expression (Massoc));
9040 -- Set entity on identifier (needed by ASIS)
9042 Set_Entity (Choice, Formal);
9047 Next_Formal (Formal);
9056 end Process_Extended_Import_Export_Subprogram_Pragma;
9058 --------------------------
9059 -- Process_Generic_List --
9060 --------------------------
9062 procedure Process_Generic_List is
9067 Check_No_Identifiers;
9068 Check_At_Least_N_Arguments (1);
9070 -- Check all arguments are names of generic units or instances
9073 while Present (Arg) loop
9074 Exp := Get_Pragma_Arg (Arg);
9077 if not Is_Entity_Name (Exp)
9079 (not Is_Generic_Instance (Entity (Exp))
9081 not Is_Generic_Unit (Entity (Exp)))
9084 ("pragma% argument must be name of generic unit/instance",
9090 end Process_Generic_List;
9092 ------------------------------------
9093 -- Process_Import_Predefined_Type --
9094 ------------------------------------
9096 procedure Process_Import_Predefined_Type is
9097 Loc : constant Source_Ptr := Sloc (N);
9099 Ftyp : Node_Id := Empty;
9105 Nam := String_To_Name (Strval (Expression (Arg3)));
9107 Elmt := First_Elmt (Predefined_Float_Types);
9108 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
9112 Ftyp := Node (Elmt);
9114 if Present (Ftyp) then
9116 -- Don't build a derived type declaration, because predefined C
9117 -- types have no declaration anywhere, so cannot really be named.
9118 -- Instead build a full type declaration, starting with an
9119 -- appropriate type definition is built
9121 if Is_Floating_Point_Type (Ftyp) then
9122 Def := Make_Floating_Point_Definition (Loc,
9123 Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
9124 Make_Real_Range_Specification (Loc,
9125 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
9126 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
9128 -- Should never have a predefined type we cannot handle
9131 raise Program_Error;
9134 -- Build and insert a Full_Type_Declaration, which will be
9135 -- analyzed as soon as this list entry has been analyzed.
9137 Decl := Make_Full_Type_Declaration (Loc,
9138 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
9139 Type_Definition => Def);
9141 Insert_After (N, Decl);
9142 Mark_Rewrite_Insertion (Decl);
9145 Error_Pragma_Arg ("no matching type found for pragma%", Arg2);
9147 end Process_Import_Predefined_Type;
9149 ---------------------------------
9150 -- Process_Import_Or_Interface --
9151 ---------------------------------
9153 procedure Process_Import_Or_Interface is
9159 -- In Relaxed_RM_Semantics, support old Ada 83 style:
9160 -- pragma Import (Entity, "external name");
9162 if Relaxed_RM_Semantics
9163 and then Arg_Count = 2
9164 and then Prag_Id = Pragma_Import
9165 and then Nkind (Expression (Arg2)) = N_String_Literal
9168 Def_Id := Get_Pragma_Arg (Arg1);
9171 if not Is_Entity_Name (Def_Id) then
9172 Error_Pragma_Arg ("entity name required", Arg1);
9175 Def_Id := Entity (Def_Id);
9176 Kill_Size_Check_Code (Def_Id);
9177 Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False);
9180 Process_Convention (C, Def_Id);
9182 -- A pragma that applies to a Ghost entity becomes Ghost for the
9183 -- purposes of legality checks and removal of ignored Ghost code.
9185 Mark_Ghost_Pragma (N, Def_Id);
9186 Kill_Size_Check_Code (Def_Id);
9187 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
9190 -- Various error checks
9192 if Ekind_In (Def_Id, E_Variable, E_Constant) then
9194 -- We do not permit Import to apply to a renaming declaration
9196 if Present (Renamed_Object (Def_Id)) then
9198 ("pragma% not allowed for object renaming", Arg2);
9200 -- User initialization is not allowed for imported object, but
9201 -- the object declaration may contain a default initialization,
9202 -- that will be discarded. Note that an explicit initialization
9203 -- only counts if it comes from source, otherwise it is simply
9204 -- the code generator making an implicit initialization explicit.
9206 elsif Present (Expression (Parent (Def_Id)))
9207 and then Comes_From_Source
9208 (Original_Node (Expression (Parent (Def_Id))))
9210 -- Set imported flag to prevent cascaded errors
9212 Set_Is_Imported (Def_Id);
9214 Error_Msg_Sloc := Sloc (Def_Id);
9216 ("no initialization allowed for declaration of& #",
9217 "\imported entities cannot be initialized (RM B.1(24))",
9221 -- If the pragma comes from an aspect specification the
9222 -- Is_Imported flag has already been set.
9224 if not From_Aspect_Specification (N) then
9225 Set_Imported (Def_Id);
9228 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
9230 -- Note that we do not set Is_Public here. That's because we
9231 -- only want to set it if there is no address clause, and we
9232 -- don't know that yet, so we delay that processing till
9235 -- pragma Import completes deferred constants
9237 if Ekind (Def_Id) = E_Constant then
9238 Set_Has_Completion (Def_Id);
9241 -- It is not possible to import a constant of an unconstrained
9242 -- array type (e.g. string) because there is no simple way to
9243 -- write a meaningful subtype for it.
9245 if Is_Array_Type (Etype (Def_Id))
9246 and then not Is_Constrained (Etype (Def_Id))
9249 ("imported constant& must have a constrained subtype",
9254 elsif Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
9256 -- If the name is overloaded, pragma applies to all of the denoted
9257 -- entities in the same declarative part, unless the pragma comes
9258 -- from an aspect specification or was generated by the compiler
9259 -- (such as for pragma Provide_Shift_Operators).
9262 while Present (Hom_Id) loop
9264 Def_Id := Get_Base_Subprogram (Hom_Id);
9266 -- Ignore inherited subprograms because the pragma will apply
9267 -- to the parent operation, which is the one called.
9269 if Is_Overloadable (Def_Id)
9270 and then Present (Alias (Def_Id))
9274 -- If it is not a subprogram, it must be in an outer scope and
9275 -- pragma does not apply.
9277 elsif not Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
9280 -- The pragma does not apply to primitives of interfaces
9282 elsif Is_Dispatching_Operation (Def_Id)
9283 and then Present (Find_Dispatching_Type (Def_Id))
9284 and then Is_Interface (Find_Dispatching_Type (Def_Id))
9288 -- Verify that the homonym is in the same declarative part (not
9289 -- just the same scope). If the pragma comes from an aspect
9290 -- specification we know that it is part of the declaration.
9292 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
9293 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
9294 and then not From_Aspect_Specification (N)
9299 -- If the pragma comes from an aspect specification the
9300 -- Is_Imported flag has already been set.
9302 if not From_Aspect_Specification (N) then
9303 Set_Imported (Def_Id);
9306 -- Reject an Import applied to an abstract subprogram
9308 if Is_Subprogram (Def_Id)
9309 and then Is_Abstract_Subprogram (Def_Id)
9311 Error_Msg_Sloc := Sloc (Def_Id);
9313 ("cannot import abstract subprogram& declared#",
9317 -- Special processing for Convention_Intrinsic
9319 if C = Convention_Intrinsic then
9321 -- Link_Name argument not allowed for intrinsic
9325 Set_Is_Intrinsic_Subprogram (Def_Id);
9327 -- If no external name is present, then check that this
9328 -- is a valid intrinsic subprogram. If an external name
9329 -- is present, then this is handled by the back end.
9332 Check_Intrinsic_Subprogram
9333 (Def_Id, Get_Pragma_Arg (Arg2));
9337 -- Verify that the subprogram does not have a completion
9338 -- through a renaming declaration. For other completions the
9339 -- pragma appears as a too late representation.
9342 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
9346 and then Nkind (Decl) = N_Subprogram_Declaration
9347 and then Present (Corresponding_Body (Decl))
9348 and then Nkind (Unit_Declaration_Node
9349 (Corresponding_Body (Decl))) =
9350 N_Subprogram_Renaming_Declaration
9352 Error_Msg_Sloc := Sloc (Def_Id);
9354 ("cannot import&, renaming already provided for "
9355 & "declaration #", N, Def_Id);
9359 -- If the pragma comes from an aspect specification, there
9360 -- must be an Import aspect specified as well. In the rare
9361 -- case where Import is set to False, the suprogram needs to
9362 -- have a local completion.
9365 Imp_Aspect : constant Node_Id :=
9366 Find_Aspect (Def_Id, Aspect_Import);
9370 if Present (Imp_Aspect)
9371 and then Present (Expression (Imp_Aspect))
9373 Expr := Expression (Imp_Aspect);
9374 Analyze_And_Resolve (Expr, Standard_Boolean);
9376 if Is_Entity_Name (Expr)
9377 and then Entity (Expr) = Standard_True
9379 Set_Has_Completion (Def_Id);
9382 -- If there is no expression, the default is True, as for
9383 -- all boolean aspects. Same for the older pragma.
9386 Set_Has_Completion (Def_Id);
9390 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
9393 if Is_Compilation_Unit (Hom_Id) then
9395 -- Its possible homonyms are not affected by the pragma.
9396 -- Such homonyms might be present in the context of other
9397 -- units being compiled.
9401 elsif From_Aspect_Specification (N) then
9404 -- If the pragma was created by the compiler, then we don't
9405 -- want it to apply to other homonyms. This kind of case can
9406 -- occur when using pragma Provide_Shift_Operators, which
9407 -- generates implicit shift and rotate operators with Import
9408 -- pragmas that might apply to earlier explicit or implicit
9409 -- declarations marked with Import (for example, coming from
9410 -- an earlier pragma Provide_Shift_Operators for another type),
9411 -- and we don't generally want other homonyms being treated
9412 -- as imported or the pragma flagged as an illegal duplicate.
9414 elsif not Comes_From_Source (N) then
9418 Hom_Id := Homonym (Hom_Id);
9422 -- Import a CPP class
9424 elsif C = Convention_CPP
9425 and then (Is_Record_Type (Def_Id)
9426 or else Ekind (Def_Id) = E_Incomplete_Type)
9428 if Ekind (Def_Id) = E_Incomplete_Type then
9429 if Present (Full_View (Def_Id)) then
9430 Def_Id := Full_View (Def_Id);
9434 ("cannot import 'C'P'P type before full declaration seen",
9435 Get_Pragma_Arg (Arg2));
9437 -- Although we have reported the error we decorate it as
9438 -- CPP_Class to avoid reporting spurious errors
9440 Set_Is_CPP_Class (Def_Id);
9445 -- Types treated as CPP classes must be declared limited (note:
9446 -- this used to be a warning but there is no real benefit to it
9447 -- since we did effectively intend to treat the type as limited
9450 if not Is_Limited_Type (Def_Id) then
9452 ("imported 'C'P'P type must be limited",
9453 Get_Pragma_Arg (Arg2));
9456 if Etype (Def_Id) /= Def_Id
9457 and then not Is_CPP_Class (Root_Type (Def_Id))
9459 Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
9462 Set_Is_CPP_Class (Def_Id);
9464 -- Imported CPP types must not have discriminants (because C++
9465 -- classes do not have discriminants).
9467 if Has_Discriminants (Def_Id) then
9469 ("imported 'C'P'P type cannot have discriminants",
9470 First (Discriminant_Specifications
9471 (Declaration_Node (Def_Id))));
9474 -- Check that components of imported CPP types do not have default
9475 -- expressions. For private types this check is performed when the
9476 -- full view is analyzed (see Process_Full_View).
9478 if not Is_Private_Type (Def_Id) then
9479 Check_CPP_Type_Has_No_Defaults (Def_Id);
9482 -- Import a CPP exception
9484 elsif C = Convention_CPP
9485 and then Ekind (Def_Id) = E_Exception
9489 ("'External_'Name arguments is required for 'Cpp exception",
9492 -- As only a string is allowed, Check_Arg_Is_External_Name
9495 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
9498 if Present (Arg4) then
9500 ("Link_Name argument not allowed for imported Cpp exception",
9504 -- Do not call Set_Interface_Name as the name of the exception
9505 -- shouldn't be modified (and in particular it shouldn't be
9506 -- the External_Name). For exceptions, the External_Name is the
9507 -- name of the RTTI structure.
9509 -- ??? Emit an error if pragma Import/Export_Exception is present
9511 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
9513 Check_Arg_Count (3);
9514 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
9516 Process_Import_Predefined_Type;
9520 ("second argument of pragma% must be object, subprogram "
9521 & "or incomplete type",
9525 -- If this pragma applies to a compilation unit, then the unit, which
9526 -- is a subprogram, does not require (or allow) a body. We also do
9527 -- not need to elaborate imported procedures.
9529 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
9531 Cunit : constant Node_Id := Parent (Parent (N));
9533 Set_Body_Required (Cunit, False);
9536 end Process_Import_Or_Interface;
9538 --------------------
9539 -- Process_Inline --
9540 --------------------
9542 procedure Process_Inline (Status : Inline_Status) is
9549 Ghost_Error_Posted : Boolean := False;
9550 -- Flag set when an error concerning the illegal mix of Ghost and
9551 -- non-Ghost subprograms is emitted.
9553 Ghost_Id : Entity_Id := Empty;
9554 -- The entity of the first Ghost subprogram encountered while
9555 -- processing the arguments of the pragma.
9557 procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id);
9558 -- Verify the placement of pragma Inline_Always with respect to the
9559 -- initial declaration of subprogram Spec_Id.
9561 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
9562 -- Returns True if it can be determined at this stage that inlining
9563 -- is not possible, for example if the body is available and contains
9564 -- exception handlers, we prevent inlining, since otherwise we can
9565 -- get undefined symbols at link time. This function also emits a
9566 -- warning if the pragma appears too late.
9568 -- ??? is business with link symbols still valid, or does it relate
9569 -- to front end ZCX which is being phased out ???
9571 procedure Make_Inline (Subp : Entity_Id);
9572 -- Subp is the defining unit name of the subprogram declaration. If
9573 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
9574 -- the corresponding body, if there is one present.
9576 procedure Set_Inline_Flags (Subp : Entity_Id);
9577 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
9578 -- Also set or clear Is_Inlined flag on Subp depending on Status.
9580 -----------------------------------
9581 -- Check_Inline_Always_Placement --
9582 -----------------------------------
9584 procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id) is
9585 Spec_Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
9587 function Compilation_Unit_OK return Boolean;
9588 pragma Inline (Compilation_Unit_OK);
9589 -- Determine whether pragma Inline_Always applies to a compatible
9590 -- compilation unit denoted by Spec_Id.
9592 function Declarative_List_OK return Boolean;
9593 pragma Inline (Declarative_List_OK);
9594 -- Determine whether the initial declaration of subprogram Spec_Id
9595 -- and the pragma appear in compatible declarative lists.
9597 function Subprogram_Body_OK return Boolean;
9598 pragma Inline (Subprogram_Body_OK);
9599 -- Determine whether pragma Inline_Always applies to a compatible
9600 -- subprogram body denoted by Spec_Id.
9602 -------------------------
9603 -- Compilation_Unit_OK --
9604 -------------------------
9606 function Compilation_Unit_OK return Boolean is
9607 Comp_Unit : constant Node_Id := Parent (Spec_Decl);
9610 -- The pragma appears after the initial declaration of a
9611 -- compilation unit.
9613 -- procedure Comp_Unit;
9614 -- pragma Inline_Always (Comp_Unit);
9616 -- Note that for compatibility reasons, the following case is
9619 -- procedure Stand_Alone_Body_Comp_Unit is
9621 -- end Stand_Alone_Body_Comp_Unit;
9622 -- pragma Inline_Always (Stand_Alone_Body_Comp_Unit);
9625 Nkind (Comp_Unit) = N_Compilation_Unit
9626 and then Present (Aux_Decls_Node (Comp_Unit))
9627 and then Is_List_Member (N)
9628 and then List_Containing (N) =
9629 Pragmas_After (Aux_Decls_Node (Comp_Unit));
9630 end Compilation_Unit_OK;
9632 -------------------------
9633 -- Declarative_List_OK --
9634 -------------------------
9636 function Declarative_List_OK return Boolean is
9637 Context : constant Node_Id := Parent (Spec_Decl);
9639 Init_Decl : Node_Id;
9640 Init_List : List_Id;
9641 Prag_List : List_Id;
9644 -- Determine the proper initial declaration. In general this is
9645 -- the declaration node of the subprogram except when the input
9646 -- denotes a generic instantiation.
9648 -- procedure Inst is new Gen;
9649 -- pragma Inline_Always (Inst);
9651 -- In this case the original subprogram is moved inside an
9652 -- anonymous package while pragma Inline_Always remains at the
9653 -- level of the anonymous package. Use the declaration of the
9654 -- package because it reflects the placement of the original
9657 -- package Anon_Pack is
9658 -- procedure Inst is ... end Inst; -- original
9661 -- procedure Inst renames Anon_Pack.Inst;
9662 -- pragma Inline_Always (Inst);
9664 if Is_Generic_Instance (Spec_Id) then
9665 Init_Decl := Parent (Parent (Spec_Decl));
9666 pragma Assert (Nkind (Init_Decl) = N_Package_Declaration);
9668 Init_Decl := Spec_Decl;
9671 if Is_List_Member (Init_Decl) and then Is_List_Member (N) then
9672 Init_List := List_Containing (Init_Decl);
9673 Prag_List := List_Containing (N);
9675 -- The pragma and then initial declaration appear within the
9676 -- same declarative list.
9678 if Init_List = Prag_List then
9681 -- A special case of the above is when both the pragma and
9682 -- the initial declaration appear in different lists of a
9683 -- package spec, protected definition, or a task definition.
9688 -- pragma Inline_Always (Proc);
9691 elsif Nkind_In (Context, N_Package_Specification,
9692 N_Protected_Definition,
9694 and then Init_List = Visible_Declarations (Context)
9695 and then Prag_List = Private_Declarations (Context)
9702 end Declarative_List_OK;
9704 ------------------------
9705 -- Subprogram_Body_OK --
9706 ------------------------
9708 function Subprogram_Body_OK return Boolean is
9709 Body_Decl : Node_Id;
9712 -- The pragma appears within the declarative list of a stand-
9713 -- alone subprogram body.
9715 -- procedure Stand_Alone_Body is
9716 -- pragma Inline_Always (Stand_Alone_Body);
9719 -- end Stand_Alone_Body;
9721 -- The compiler creates a dummy spec in this case, however the
9722 -- pragma remains within the declarative list of the body.
9724 if Nkind (Spec_Decl) = N_Subprogram_Declaration
9725 and then not Comes_From_Source (Spec_Decl)
9726 and then Present (Corresponding_Body (Spec_Decl))
9729 Unit_Declaration_Node (Corresponding_Body (Spec_Decl));
9731 if Present (Declarations (Body_Decl))
9732 and then Is_List_Member (N)
9733 and then List_Containing (N) = Declarations (Body_Decl)
9740 end Subprogram_Body_OK;
9742 -- Start of processing for Check_Inline_Always_Placement
9745 -- This check is relevant only for pragma Inline_Always
9747 if Pname /= Name_Inline_Always then
9750 -- Nothing to do when the pragma is internally generated on the
9751 -- assumption that it is properly placed.
9753 elsif not Comes_From_Source (N) then
9756 -- Nothing to do for internally generated subprograms that act
9757 -- as accidental homonyms of a source subprogram being inlined.
9759 elsif not Comes_From_Source (Spec_Id) then
9762 -- Nothing to do for generic formal subprograms that act as
9763 -- homonyms of another source subprogram being inlined.
9765 elsif Is_Formal_Subprogram (Spec_Id) then
9768 elsif Compilation_Unit_OK
9769 or else Declarative_List_OK
9770 or else Subprogram_Body_OK
9775 -- At this point it is known that the pragma applies to or appears
9776 -- within a completing body, a completing stub, or a subunit.
9778 Error_Msg_Name_1 := Pname;
9779 Error_Msg_Name_2 := Chars (Spec_Id);
9780 Error_Msg_Sloc := Sloc (Spec_Id);
9783 ("pragma % must appear on initial declaration of subprogram "
9784 & "% defined #", N);
9785 end Check_Inline_Always_Placement;
9787 ---------------------------
9788 -- Inlining_Not_Possible --
9789 ---------------------------
9791 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
9792 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
9796 if Nkind (Decl) = N_Subprogram_Body then
9797 Stats := Handled_Statement_Sequence (Decl);
9798 return Present (Exception_Handlers (Stats))
9799 or else Present (At_End_Proc (Stats));
9801 elsif Nkind (Decl) = N_Subprogram_Declaration
9802 and then Present (Corresponding_Body (Decl))
9804 if Analyzed (Corresponding_Body (Decl)) then
9805 Error_Msg_N ("pragma appears too late, ignored??", N);
9808 -- If the subprogram is a renaming as body, the body is just a
9809 -- call to the renamed subprogram, and inlining is trivially
9813 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
9814 N_Subprogram_Renaming_Declaration
9820 Handled_Statement_Sequence
9821 (Unit_Declaration_Node (Corresponding_Body (Decl)));
9824 Present (Exception_Handlers (Stats))
9825 or else Present (At_End_Proc (Stats));
9829 -- If body is not available, assume the best, the check is
9830 -- performed again when compiling enclosing package bodies.
9834 end Inlining_Not_Possible;
9840 procedure Make_Inline (Subp : Entity_Id) is
9841 Kind : constant Entity_Kind := Ekind (Subp);
9842 Inner_Subp : Entity_Id := Subp;
9845 -- Ignore if bad type, avoid cascaded error
9847 if Etype (Subp) = Any_Type then
9851 -- If inlining is not possible, for now do not treat as an error
9853 elsif Status /= Suppressed
9854 and then Front_End_Inlining
9855 and then Inlining_Not_Possible (Subp)
9860 -- Here we have a candidate for inlining, but we must exclude
9861 -- derived operations. Otherwise we would end up trying to inline
9862 -- a phantom declaration, and the result would be to drag in a
9863 -- body which has no direct inlining associated with it. That
9864 -- would not only be inefficient but would also result in the
9865 -- backend doing cross-unit inlining in cases where it was
9866 -- definitely inappropriate to do so.
9868 -- However, a simple Comes_From_Source test is insufficient, since
9869 -- we do want to allow inlining of generic instances which also do
9870 -- not come from source. We also need to recognize specs generated
9871 -- by the front-end for bodies that carry the pragma. Finally,
9872 -- predefined operators do not come from source but are not
9873 -- inlineable either.
9875 elsif Is_Generic_Instance (Subp)
9876 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
9880 elsif not Comes_From_Source (Subp)
9881 and then Scope (Subp) /= Standard_Standard
9887 -- The referenced entity must either be the enclosing entity, or
9888 -- an entity declared within the current open scope.
9890 if Present (Scope (Subp))
9891 and then Scope (Subp) /= Current_Scope
9892 and then Subp /= Current_Scope
9895 ("argument of% must be entity in current scope", Assoc);
9899 -- Processing for procedure, operator or function. If subprogram
9900 -- is aliased (as for an instance) indicate that the renamed
9901 -- entity (if declared in the same unit) is inlined.
9902 -- If this is the anonymous subprogram created for a subprogram
9903 -- instance, the inlining applies to it directly. Otherwise we
9904 -- retrieve it as the alias of the visible subprogram instance.
9906 if Is_Subprogram (Subp) then
9908 -- Ensure that pragma Inline_Always is associated with the
9909 -- initial declaration of the subprogram.
9911 Check_Inline_Always_Placement (Subp);
9913 if Is_Wrapper_Package (Scope (Subp)) then
9916 Inner_Subp := Ultimate_Alias (Inner_Subp);
9919 if In_Same_Source_Unit (Subp, Inner_Subp) then
9920 Set_Inline_Flags (Inner_Subp);
9922 Decl := Parent (Parent (Inner_Subp));
9924 if Nkind (Decl) = N_Subprogram_Declaration
9925 and then Present (Corresponding_Body (Decl))
9927 Set_Inline_Flags (Corresponding_Body (Decl));
9929 elsif Is_Generic_Instance (Subp)
9930 and then Comes_From_Source (Subp)
9932 -- Indicate that the body needs to be created for
9933 -- inlining subsequent calls. The instantiation node
9934 -- follows the declaration of the wrapper package
9935 -- created for it. The subprogram that requires the
9936 -- body is the anonymous one in the wrapper package.
9938 if Scope (Subp) /= Standard_Standard
9940 Need_Subprogram_Instance_Body
9941 (Next (Unit_Declaration_Node
9942 (Scope (Alias (Subp)))), Subp)
9947 -- Inline is a program unit pragma (RM 10.1.5) and cannot
9948 -- appear in a formal part to apply to a formal subprogram.
9949 -- Do not apply check within an instance or a formal package
9950 -- the test will have been applied to the original generic.
9952 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
9953 and then List_Containing (Decl) = List_Containing (N)
9954 and then not In_Instance
9957 ("Inline cannot apply to a formal subprogram", N);
9959 -- If Subp is a renaming, it is the renamed entity that
9960 -- will appear in any call, and be inlined. However, for
9961 -- ASIS uses it is convenient to indicate that the renaming
9962 -- itself is an inlined subprogram, so that some gnatcheck
9963 -- rules can be applied in the absence of expansion.
9965 elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then
9966 Set_Inline_Flags (Subp);
9972 -- For a generic subprogram set flag as well, for use at the point
9973 -- of instantiation, to determine whether the body should be
9976 elsif Is_Generic_Subprogram (Subp) then
9977 Set_Inline_Flags (Subp);
9980 -- Literals are by definition inlined
9982 elsif Kind = E_Enumeration_Literal then
9985 -- Anything else is an error
9989 ("expect subprogram name for pragma%", Assoc);
9993 ----------------------
9994 -- Set_Inline_Flags --
9995 ----------------------
9997 procedure Set_Inline_Flags (Subp : Entity_Id) is
9999 -- First set the Has_Pragma_XXX flags and issue the appropriate
10000 -- errors and warnings for suspicious combinations.
10002 if Prag_Id = Pragma_No_Inline then
10003 if Has_Pragma_Inline_Always (Subp) then
10005 ("Inline_Always and No_Inline are mutually exclusive", N);
10006 elsif Has_Pragma_Inline (Subp) then
10008 ("Inline and No_Inline both specified for& ??",
10009 N, Entity (Subp_Id));
10012 Set_Has_Pragma_No_Inline (Subp);
10014 if Prag_Id = Pragma_Inline_Always then
10015 if Has_Pragma_No_Inline (Subp) then
10017 ("Inline_Always and No_Inline are mutually exclusive",
10021 Set_Has_Pragma_Inline_Always (Subp);
10023 if Has_Pragma_No_Inline (Subp) then
10025 ("Inline and No_Inline both specified for& ??",
10026 N, Entity (Subp_Id));
10030 Set_Has_Pragma_Inline (Subp);
10033 -- Then adjust the Is_Inlined flag. It can never be set if the
10034 -- subprogram is subject to pragma No_Inline.
10038 Set_Is_Inlined (Subp, False);
10044 if not Has_Pragma_No_Inline (Subp) then
10045 Set_Is_Inlined (Subp, True);
10049 -- A pragma that applies to a Ghost entity becomes Ghost for the
10050 -- purposes of legality checks and removal of ignored Ghost code.
10052 Mark_Ghost_Pragma (N, Subp);
10054 -- Capture the entity of the first Ghost subprogram being
10055 -- processed for error detection purposes.
10057 if Is_Ghost_Entity (Subp) then
10058 if No (Ghost_Id) then
10062 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
10063 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
10065 elsif Present (Ghost_Id) and then not Ghost_Error_Posted then
10066 Ghost_Error_Posted := True;
10068 Error_Msg_Name_1 := Pname;
10070 ("pragma % cannot mention ghost and non-ghost subprograms",
10073 Error_Msg_Sloc := Sloc (Ghost_Id);
10074 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
10076 Error_Msg_Sloc := Sloc (Subp);
10077 Error_Msg_NE ("\& # declared as non-ghost", N, Subp);
10079 end Set_Inline_Flags;
10081 -- Start of processing for Process_Inline
10084 -- An inlined subprogram may grant access to its private enclosing
10085 -- context depending on the placement of its body. From elaboration
10086 -- point of view, the flow of execution may enter this private
10087 -- context, and then reach an external unit, thus producing a
10088 -- dependency on that external unit. For such a path to be properly
10089 -- discovered and encoded in the ALI file of the main unit, let the
10090 -- ABE mechanism process the body of the main unit, and encode all
10091 -- relevant invocation constructs and the relations between them.
10093 Mark_Save_Invocation_Graph_Of_Body;
10095 Check_No_Identifiers;
10096 Check_At_Least_N_Arguments (1);
10098 if Status = Enabled then
10099 Inline_Processing_Required := True;
10103 while Present (Assoc) loop
10104 Subp_Id := Get_Pragma_Arg (Assoc);
10108 if Is_Entity_Name (Subp_Id) then
10109 Subp := Entity (Subp_Id);
10111 if Subp = Any_Id then
10113 -- If previous error, avoid cascaded errors
10115 Check_Error_Detected;
10119 Make_Inline (Subp);
10121 -- For the pragma case, climb homonym chain. This is
10122 -- what implements allowing the pragma in the renaming
10123 -- case, with the result applying to the ancestors, and
10124 -- also allows Inline to apply to all previous homonyms.
10126 if not From_Aspect_Specification (N) then
10127 while Present (Homonym (Subp))
10128 and then Scope (Homonym (Subp)) = Current_Scope
10130 Make_Inline (Homonym (Subp));
10131 Subp := Homonym (Subp);
10137 if not Applies then
10138 Error_Pragma_Arg ("inappropriate argument for pragma%", Assoc);
10144 -- If the context is a package declaration, the pragma indicates
10145 -- that inlining will require the presence of the corresponding
10146 -- body. (this may be further refined).
10149 and then Nkind (Unit (Cunit (Current_Sem_Unit))) =
10150 N_Package_Declaration
10152 Set_Body_Needed_For_Inlining (Cunit_Entity (Current_Sem_Unit));
10154 end Process_Inline;
10156 ----------------------------
10157 -- Process_Interface_Name --
10158 ----------------------------
10160 procedure Process_Interface_Name
10161 (Subprogram_Def : Entity_Id;
10163 Link_Arg : Node_Id;
10167 Link_Nam : Node_Id;
10168 String_Val : String_Id;
10170 procedure Check_Form_Of_Interface_Name (SN : Node_Id);
10171 -- SN is a string literal node for an interface name. This routine
10172 -- performs some minimal checks that the name is reasonable. In
10173 -- particular that no spaces or other obviously incorrect characters
10174 -- appear. This is only a warning, since any characters are allowed.
10176 ----------------------------------
10177 -- Check_Form_Of_Interface_Name --
10178 ----------------------------------
10180 procedure Check_Form_Of_Interface_Name (SN : Node_Id) is
10181 S : constant String_Id := Strval (Expr_Value_S (SN));
10182 SL : constant Nat := String_Length (S);
10187 Error_Msg_N ("interface name cannot be null string", SN);
10190 for J in 1 .. SL loop
10191 C := Get_String_Char (S, J);
10193 -- Look for dubious character and issue unconditional warning.
10194 -- Definitely dubious if not in character range.
10196 if not In_Character_Range (C)
10198 -- Commas, spaces and (back)slashes are dubious
10200 or else Get_Character (C) = ','
10201 or else Get_Character (C) = '\'
10202 or else Get_Character (C) = ' '
10203 or else Get_Character (C) = '/'
10206 ("??interface name contains illegal character",
10207 Sloc (SN) + Source_Ptr (J));
10210 end Check_Form_Of_Interface_Name;
10212 -- Start of processing for Process_Interface_Name
10215 -- If we are looking at a pragma that comes from an aspect then it
10216 -- needs to have its corresponding aspect argument expressions
10217 -- analyzed in addition to the generated pragma so that aspects
10218 -- within generic units get properly resolved.
10220 if Present (Prag) and then From_Aspect_Specification (Prag) then
10222 Asp : constant Node_Id := Corresponding_Aspect (Prag);
10230 -- Obtain all interfacing aspects used to construct the pragma
10232 Get_Interfacing_Aspects
10233 (Asp, Dummy_1, EN, Dummy_2, Dummy_3, LN);
10235 -- Analyze the expression of aspect External_Name
10237 if Present (EN) then
10238 Analyze (Expression (EN));
10241 -- Analyze the expressio of aspect Link_Name
10243 if Present (LN) then
10244 Analyze (Expression (LN));
10249 if No (Link_Arg) then
10250 if No (Ext_Arg) then
10253 elsif Chars (Ext_Arg) = Name_Link_Name then
10255 Link_Nam := Expression (Ext_Arg);
10258 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
10259 Ext_Nam := Expression (Ext_Arg);
10264 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
10265 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
10266 Ext_Nam := Expression (Ext_Arg);
10267 Link_Nam := Expression (Link_Arg);
10270 -- Check expressions for external name and link name are static
10272 if Present (Ext_Nam) then
10273 Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String);
10274 Check_Form_Of_Interface_Name (Ext_Nam);
10276 -- Verify that external name is not the name of a local entity,
10277 -- which would hide the imported one and could lead to run-time
10278 -- surprises. The problem can only arise for entities declared in
10279 -- a package body (otherwise the external name is fully qualified
10280 -- and will not conflict).
10288 if Prag_Id = Pragma_Import then
10289 Nam := String_To_Name (Strval (Expr_Value_S (Ext_Nam)));
10290 E := Entity_Id (Get_Name_Table_Int (Nam));
10292 if Nam /= Chars (Subprogram_Def)
10293 and then Present (E)
10294 and then not Is_Overloadable (E)
10295 and then Is_Immediately_Visible (E)
10296 and then not Is_Imported (E)
10297 and then Ekind (Scope (E)) = E_Package
10300 while Present (Par) loop
10301 if Nkind (Par) = N_Package_Body then
10302 Error_Msg_Sloc := Sloc (E);
10304 ("imported entity is hidden by & declared#",
10309 Par := Parent (Par);
10316 if Present (Link_Nam) then
10317 Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String);
10318 Check_Form_Of_Interface_Name (Link_Nam);
10321 -- If there is no link name, just set the external name
10323 if No (Link_Nam) then
10324 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
10326 -- For the Link_Name case, the given literal is preceded by an
10327 -- asterisk, which indicates to GCC that the given name should be
10328 -- taken literally, and in particular that no prepending of
10329 -- underlines should occur, even in systems where this is the
10334 Store_String_Char (Get_Char_Code ('*'));
10335 String_Val := Strval (Expr_Value_S (Link_Nam));
10336 Store_String_Chars (String_Val);
10338 Make_String_Literal (Sloc (Link_Nam),
10339 Strval => End_String);
10342 -- Set the interface name. If the entity is a generic instance, use
10343 -- its alias, which is the callable entity.
10345 if Is_Generic_Instance (Subprogram_Def) then
10346 Set_Encoded_Interface_Name
10347 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
10349 Set_Encoded_Interface_Name
10350 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
10353 Check_Duplicated_Export_Name (Link_Nam);
10354 end Process_Interface_Name;
10356 -----------------------------------------
10357 -- Process_Interrupt_Or_Attach_Handler --
10358 -----------------------------------------
10360 procedure Process_Interrupt_Or_Attach_Handler is
10361 Handler : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1));
10362 Prot_Typ : constant Entity_Id := Scope (Handler);
10365 -- A pragma that applies to a Ghost entity becomes Ghost for the
10366 -- purposes of legality checks and removal of ignored Ghost code.
10368 Mark_Ghost_Pragma (N, Handler);
10369 Set_Is_Interrupt_Handler (Handler);
10371 pragma Assert (Ekind (Prot_Typ) = E_Protected_Type);
10373 Record_Rep_Item (Prot_Typ, N);
10375 -- Chain the pragma on the contract for completeness
10377 Add_Contract_Item (N, Handler);
10378 end Process_Interrupt_Or_Attach_Handler;
10380 --------------------------------------------------
10381 -- Process_Restrictions_Or_Restriction_Warnings --
10382 --------------------------------------------------
10384 -- Note: some of the simple identifier cases were handled in par-prag,
10385 -- but it is harmless (and more straightforward) to simply handle all
10386 -- cases here, even if it means we repeat a bit of work in some cases.
10388 procedure Process_Restrictions_Or_Restriction_Warnings
10392 R_Id : Restriction_Id;
10398 -- Ignore all Restrictions pragmas in CodePeer mode
10400 if CodePeer_Mode then
10404 Check_Ada_83_Warning;
10405 Check_At_Least_N_Arguments (1);
10406 Check_Valid_Configuration_Pragma;
10409 while Present (Arg) loop
10411 Expr := Get_Pragma_Arg (Arg);
10413 -- Case of no restriction identifier present
10415 if Id = No_Name then
10416 if Nkind (Expr) /= N_Identifier then
10418 ("invalid form for restriction", Arg);
10423 (Process_Restriction_Synonyms (Expr));
10425 if R_Id not in All_Boolean_Restrictions then
10426 Error_Msg_Name_1 := Pname;
10428 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
10430 -- Check for possible misspelling
10432 for J in Restriction_Id loop
10434 Rnm : constant String := Restriction_Id'Image (J);
10437 Name_Buffer (1 .. Rnm'Length) := Rnm;
10438 Name_Len := Rnm'Length;
10439 Set_Casing (All_Lower_Case);
10441 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
10444 (Source_Index (Current_Sem_Unit)));
10445 Error_Msg_String (1 .. Rnm'Length) :=
10446 Name_Buffer (1 .. Name_Len);
10447 Error_Msg_Strlen := Rnm'Length;
10448 Error_Msg_N -- CODEFIX
10449 ("\possible misspelling of ""~""",
10450 Get_Pragma_Arg (Arg));
10459 if Implementation_Restriction (R_Id) then
10460 Check_Restriction (No_Implementation_Restrictions, Arg);
10463 -- Special processing for No_Elaboration_Code restriction
10465 if R_Id = No_Elaboration_Code then
10467 -- Restriction is only recognized within a configuration
10468 -- pragma file, or within a unit of the main extended
10469 -- program. Note: the test for Main_Unit is needed to
10470 -- properly include the case of configuration pragma files.
10472 if not (Current_Sem_Unit = Main_Unit
10473 or else In_Extended_Main_Source_Unit (N))
10477 -- Don't allow in a subunit unless already specified in
10480 elsif Nkind (Parent (N)) = N_Compilation_Unit
10481 and then Nkind (Unit (Parent (N))) = N_Subunit
10482 and then not Restriction_Active (No_Elaboration_Code)
10485 ("invalid specification of ""No_Elaboration_Code""",
10488 ("\restriction cannot be specified in a subunit", N);
10490 ("\unless also specified in body or spec", N);
10493 -- If we accept a No_Elaboration_Code restriction, then it
10494 -- needs to be added to the configuration restriction set so
10495 -- that we get proper application to other units in the main
10496 -- extended source as required.
10499 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
10503 -- If this is a warning, then set the warning unless we already
10504 -- have a real restriction active (we never want a warning to
10505 -- override a real restriction).
10508 if not Restriction_Active (R_Id) then
10509 Set_Restriction (R_Id, N);
10510 Restriction_Warnings (R_Id) := True;
10513 -- If real restriction case, then set it and make sure that the
10514 -- restriction warning flag is off, since a real restriction
10515 -- always overrides a warning.
10518 Set_Restriction (R_Id, N);
10519 Restriction_Warnings (R_Id) := False;
10522 -- Check for obsolescent restrictions in Ada 2005 mode
10525 and then Ada_Version >= Ada_2005
10526 and then (R_Id = No_Asynchronous_Control
10528 R_Id = No_Unchecked_Deallocation
10530 R_Id = No_Unchecked_Conversion)
10532 Check_Restriction (No_Obsolescent_Features, N);
10535 -- A very special case that must be processed here: pragma
10536 -- Restrictions (No_Exceptions) turns off all run-time
10537 -- checking. This is a bit dubious in terms of the formal
10538 -- language definition, but it is what is intended by RM
10539 -- H.4(12). Restriction_Warnings never affects generated code
10540 -- so this is done only in the real restriction case.
10542 -- Atomic_Synchronization is not a real check, so it is not
10543 -- affected by this processing).
10545 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
10546 -- run-time checks in CodePeer and GNATprove modes: we want to
10547 -- generate checks for analysis purposes, as set respectively
10548 -- by -gnatC and -gnatd.F
10551 and then not (CodePeer_Mode or GNATprove_Mode)
10552 and then R_Id = No_Exceptions
10554 for J in Scope_Suppress.Suppress'Range loop
10555 if J /= Atomic_Synchronization then
10556 Scope_Suppress.Suppress (J) := True;
10561 -- Case of No_Dependence => unit-name. Note that the parser
10562 -- already made the necessary entry in the No_Dependence table.
10564 elsif Id = Name_No_Dependence then
10565 if not OK_No_Dependence_Unit_Name (Expr) then
10569 -- Case of No_Specification_Of_Aspect => aspect-identifier
10571 elsif Id = Name_No_Specification_Of_Aspect then
10576 if Nkind (Expr) /= N_Identifier then
10579 A_Id := Get_Aspect_Id (Chars (Expr));
10582 if A_Id = No_Aspect then
10583 Error_Pragma_Arg ("invalid restriction name", Arg);
10585 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
10589 -- Case of No_Use_Of_Attribute => attribute-identifier
10591 elsif Id = Name_No_Use_Of_Attribute then
10592 if Nkind (Expr) /= N_Identifier
10593 or else not Is_Attribute_Name (Chars (Expr))
10595 Error_Msg_N ("unknown attribute name??", Expr);
10598 Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
10601 -- Case of No_Use_Of_Entity => fully-qualified-name
10603 elsif Id = Name_No_Use_Of_Entity then
10605 -- Restriction is only recognized within a configuration
10606 -- pragma file, or within a unit of the main extended
10607 -- program. Note: the test for Main_Unit is needed to
10608 -- properly include the case of configuration pragma files.
10610 if Current_Sem_Unit = Main_Unit
10611 or else In_Extended_Main_Source_Unit (N)
10613 if not OK_No_Dependence_Unit_Name (Expr) then
10614 Error_Msg_N ("wrong form for entity name", Expr);
10616 Set_Restriction_No_Use_Of_Entity
10617 (Expr, Warn, No_Profile);
10621 -- Case of No_Use_Of_Pragma => pragma-identifier
10623 elsif Id = Name_No_Use_Of_Pragma then
10624 if Nkind (Expr) /= N_Identifier
10625 or else not Is_Pragma_Name (Chars (Expr))
10627 Error_Msg_N ("unknown pragma name??", Expr);
10629 Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
10632 -- All other cases of restriction identifier present
10635 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
10636 Analyze_And_Resolve (Expr, Any_Integer);
10638 if R_Id not in All_Parameter_Restrictions then
10640 ("invalid restriction parameter identifier", Arg);
10642 elsif not Is_OK_Static_Expression (Expr) then
10643 Flag_Non_Static_Expr
10644 ("value must be static expression!", Expr);
10647 elsif not Is_Integer_Type (Etype (Expr))
10648 or else Expr_Value (Expr) < 0
10651 ("value must be non-negative integer", Arg);
10654 -- Restriction pragma is active
10656 Val := Expr_Value (Expr);
10658 if not UI_Is_In_Int_Range (Val) then
10660 ("pragma ignored, value too large??", Arg);
10663 -- Warning case. If the real restriction is active, then we
10664 -- ignore the request, since warning never overrides a real
10665 -- restriction. Otherwise we set the proper warning. Note that
10666 -- this circuit sets the warning again if it is already set,
10667 -- which is what we want, since the constant may have changed.
10670 if not Restriction_Active (R_Id) then
10672 (R_Id, N, Integer (UI_To_Int (Val)));
10673 Restriction_Warnings (R_Id) := True;
10676 -- Real restriction case, set restriction and make sure warning
10677 -- flag is off since real restriction always overrides warning.
10680 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
10681 Restriction_Warnings (R_Id) := False;
10687 end Process_Restrictions_Or_Restriction_Warnings;
10689 ---------------------------------
10690 -- Process_Suppress_Unsuppress --
10691 ---------------------------------
10693 -- Note: this procedure makes entries in the check suppress data
10694 -- structures managed by Sem. See spec of package Sem for full
10695 -- details on how we handle recording of check suppression.
10697 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
10702 In_Package_Spec : constant Boolean :=
10703 Is_Package_Or_Generic_Package (Current_Scope)
10704 and then not In_Package_Body (Current_Scope);
10706 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
10707 -- Used to suppress a single check on the given entity
10709 --------------------------------
10710 -- Suppress_Unsuppress_Echeck --
10711 --------------------------------
10713 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
10715 -- Check for error of trying to set atomic synchronization for
10716 -- a non-atomic variable.
10718 if C = Atomic_Synchronization
10719 and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
10722 ("pragma & requires atomic type or variable",
10723 Pragma_Identifier (Original_Node (N)));
10726 Set_Checks_May_Be_Suppressed (E);
10728 if In_Package_Spec then
10729 Push_Global_Suppress_Stack_Entry
10732 Suppress => Suppress_Case);
10734 Push_Local_Suppress_Stack_Entry
10737 Suppress => Suppress_Case);
10740 -- If this is a first subtype, and the base type is distinct,
10741 -- then also set the suppress flags on the base type.
10743 if Is_First_Subtype (E) and then Etype (E) /= E then
10744 Suppress_Unsuppress_Echeck (Etype (E), C);
10746 end Suppress_Unsuppress_Echeck;
10748 -- Start of processing for Process_Suppress_Unsuppress
10751 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
10752 -- on user code: we want to generate checks for analysis purposes, as
10753 -- set respectively by -gnatC and -gnatd.F
10755 if Comes_From_Source (N)
10756 and then (CodePeer_Mode or GNATprove_Mode)
10761 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
10762 -- declarative part or a package spec (RM 11.5(5)).
10764 if not Is_Configuration_Pragma then
10765 Check_Is_In_Decl_Part_Or_Package_Spec;
10768 Check_At_Least_N_Arguments (1);
10769 Check_At_Most_N_Arguments (2);
10770 Check_No_Identifier (Arg1);
10771 Check_Arg_Is_Identifier (Arg1);
10773 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
10775 if C = No_Check_Id then
10777 ("argument of pragma% is not valid check name", Arg1);
10780 -- Warn that suppress of Elaboration_Check has no effect in SPARK
10782 if C = Elaboration_Check and then SPARK_Mode = On then
10784 ("Suppress of Elaboration_Check ignored in SPARK??",
10785 "\elaboration checking rules are statically enforced "
10786 & "(SPARK RM 7.7)", Arg1);
10789 -- One-argument case
10791 if Arg_Count = 1 then
10793 -- Make an entry in the local scope suppress table. This is the
10794 -- table that directly shows the current value of the scope
10795 -- suppress check for any check id value.
10797 if C = All_Checks then
10799 -- For All_Checks, we set all specific predefined checks with
10800 -- the exception of Elaboration_Check, which is handled
10801 -- specially because of not wanting All_Checks to have the
10802 -- effect of deactivating static elaboration order processing.
10803 -- Atomic_Synchronization is also not affected, since this is
10804 -- not a real check.
10806 for J in Scope_Suppress.Suppress'Range loop
10807 if J /= Elaboration_Check
10809 J /= Atomic_Synchronization
10811 Scope_Suppress.Suppress (J) := Suppress_Case;
10815 -- If not All_Checks, and predefined check, then set appropriate
10816 -- scope entry. Note that we will set Elaboration_Check if this
10817 -- is explicitly specified. Atomic_Synchronization is allowed
10818 -- only if internally generated and entity is atomic.
10820 elsif C in Predefined_Check_Id
10821 and then (not Comes_From_Source (N)
10822 or else C /= Atomic_Synchronization)
10824 Scope_Suppress.Suppress (C) := Suppress_Case;
10827 -- Also make an entry in the Local_Entity_Suppress table
10829 Push_Local_Suppress_Stack_Entry
10832 Suppress => Suppress_Case);
10834 -- Case of two arguments present, where the check is suppressed for
10835 -- a specified entity (given as the second argument of the pragma)
10838 -- This is obsolescent in Ada 2005 mode
10840 if Ada_Version >= Ada_2005 then
10841 Check_Restriction (No_Obsolescent_Features, Arg2);
10844 Check_Optional_Identifier (Arg2, Name_On);
10845 E_Id := Get_Pragma_Arg (Arg2);
10848 if not Is_Entity_Name (E_Id) then
10850 ("second argument of pragma% must be entity name", Arg2);
10853 E := Entity (E_Id);
10859 -- A pragma that applies to a Ghost entity becomes Ghost for the
10860 -- purposes of legality checks and removal of ignored Ghost code.
10862 Mark_Ghost_Pragma (N, E);
10864 -- Enforce RM 11.5(7) which requires that for a pragma that
10865 -- appears within a package spec, the named entity must be
10866 -- within the package spec. We allow the package name itself
10867 -- to be mentioned since that makes sense, although it is not
10868 -- strictly allowed by 11.5(7).
10871 and then E /= Current_Scope
10872 and then Scope (E) /= Current_Scope
10875 ("entity in pragma% is not in package spec (RM 11.5(7))",
10879 -- Loop through homonyms. As noted below, in the case of a package
10880 -- spec, only homonyms within the package spec are considered.
10883 Suppress_Unsuppress_Echeck (E, C);
10885 if Is_Generic_Instance (E)
10886 and then Is_Subprogram (E)
10887 and then Present (Alias (E))
10889 Suppress_Unsuppress_Echeck (Alias (E), C);
10892 -- Move to next homonym if not aspect spec case
10894 exit when From_Aspect_Specification (N);
10898 -- If we are within a package specification, the pragma only
10899 -- applies to homonyms in the same scope.
10901 exit when In_Package_Spec
10902 and then Scope (E) /= Current_Scope;
10905 end Process_Suppress_Unsuppress;
10907 -------------------------------
10908 -- Record_Independence_Check --
10909 -------------------------------
10911 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id) is
10912 pragma Unreferenced (N, E);
10914 -- For GCC back ends the validation is done a priori
10915 -- ??? This code is dead, might be useful in the future
10917 -- if not AAMP_On_Target then
10921 -- Independence_Checks.Append ((N, E));
10924 end Record_Independence_Check;
10930 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
10932 if Is_Imported (E) then
10934 ("cannot export entity& that was previously imported", Arg);
10936 elsif Present (Address_Clause (E))
10937 and then not Relaxed_RM_Semantics
10940 ("cannot export entity& that has an address clause", Arg);
10943 Set_Is_Exported (E);
10945 -- Generate a reference for entity explicitly, because the
10946 -- identifier may be overloaded and name resolution will not
10949 Generate_Reference (E, Arg);
10951 -- Deal with exporting non-library level entity
10953 if not Is_Library_Level_Entity (E) then
10955 -- Not allowed at all for subprograms
10957 if Is_Subprogram (E) then
10958 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
10960 -- Otherwise set public and statically allocated
10964 Set_Is_Statically_Allocated (E);
10966 -- Warn if the corresponding W flag is set
10968 if Warn_On_Export_Import
10970 -- Only do this for something that was in the source. Not
10971 -- clear if this can be False now (there used for sure to be
10972 -- cases on some systems where it was False), but anyway the
10973 -- test is harmless if not needed, so it is retained.
10975 and then Comes_From_Source (Arg)
10978 ("?x?& has been made static as a result of Export",
10981 ("\?x?this usage is non-standard and non-portable",
10987 if Warn_On_Export_Import and then Is_Type (E) then
10988 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
10991 if Warn_On_Export_Import and Inside_A_Generic then
10993 ("all instances of& will have the same external name?x?",
10998 ----------------------------------------------
10999 -- Set_Extended_Import_Export_External_Name --
11000 ----------------------------------------------
11002 procedure Set_Extended_Import_Export_External_Name
11003 (Internal_Ent : Entity_Id;
11004 Arg_External : Node_Id)
11006 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
11007 New_Name : Node_Id;
11010 if No (Arg_External) then
11014 Check_Arg_Is_External_Name (Arg_External);
11016 if Nkind (Arg_External) = N_String_Literal then
11017 if String_Length (Strval (Arg_External)) = 0 then
11020 New_Name := Adjust_External_Name_Case (Arg_External);
11023 elsif Nkind (Arg_External) = N_Identifier then
11024 New_Name := Get_Default_External_Name (Arg_External);
11026 -- Check_Arg_Is_External_Name should let through only identifiers and
11027 -- string literals or static string expressions (which are folded to
11028 -- string literals).
11031 raise Program_Error;
11034 -- If we already have an external name set (by a prior normal Import
11035 -- or Export pragma), then the external names must match
11037 if Present (Interface_Name (Internal_Ent)) then
11039 -- Ignore mismatching names in CodePeer mode, to support some
11040 -- old compilers which would export the same procedure under
11041 -- different names, e.g:
11043 -- pragma Export_Procedure (P, "a");
11044 -- pragma Export_Procedure (P, "b");
11046 if CodePeer_Mode then
11050 Check_Matching_Internal_Names : declare
11051 S1 : constant String_Id := Strval (Old_Name);
11052 S2 : constant String_Id := Strval (New_Name);
11054 procedure Mismatch;
11055 pragma No_Return (Mismatch);
11056 -- Called if names do not match
11062 procedure Mismatch is
11064 Error_Msg_Sloc := Sloc (Old_Name);
11066 ("external name does not match that given #",
11070 -- Start of processing for Check_Matching_Internal_Names
11073 if String_Length (S1) /= String_Length (S2) then
11077 for J in 1 .. String_Length (S1) loop
11078 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
11083 end Check_Matching_Internal_Names;
11085 -- Otherwise set the given name
11088 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
11089 Check_Duplicated_Export_Name (New_Name);
11091 end Set_Extended_Import_Export_External_Name;
11097 procedure Set_Imported (E : Entity_Id) is
11099 -- Error message if already imported or exported
11101 if Is_Exported (E) or else Is_Imported (E) then
11103 -- Error if being set Exported twice
11105 if Is_Exported (E) then
11106 Error_Msg_NE ("entity& was previously exported", N, E);
11108 -- Ignore error in CodePeer mode where we treat all imported
11109 -- subprograms as unknown.
11111 elsif CodePeer_Mode then
11114 -- OK if Import/Interface case
11116 elsif Import_Interface_Present (N) then
11119 -- Error if being set Imported twice
11122 Error_Msg_NE ("entity& was previously imported", N, E);
11125 Error_Msg_Name_1 := Pname;
11127 ("\(pragma% applies to all previous entities)", N);
11129 Error_Msg_Sloc := Sloc (E);
11130 Error_Msg_NE ("\import not allowed for& declared#", N, E);
11132 -- Here if not previously imported or exported, OK to import
11135 Set_Is_Imported (E);
11137 -- For subprogram, set Import_Pragma field
11139 if Is_Subprogram (E) then
11140 Set_Import_Pragma (E, N);
11143 -- If the entity is an object that is not at the library level,
11144 -- then it is statically allocated. We do not worry about objects
11145 -- with address clauses in this context since they are not really
11146 -- imported in the linker sense.
11149 and then not Is_Library_Level_Entity (E)
11150 and then No (Address_Clause (E))
11152 Set_Is_Statically_Allocated (E);
11159 -------------------------
11160 -- Set_Mechanism_Value --
11161 -------------------------
11163 -- Note: the mechanism name has not been analyzed (and cannot indeed be
11164 -- analyzed, since it is semantic nonsense), so we get it in the exact
11165 -- form created by the parser.
11167 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
11168 procedure Bad_Mechanism;
11169 pragma No_Return (Bad_Mechanism);
11170 -- Signal bad mechanism name
11172 -------------------
11173 -- Bad_Mechanism --
11174 -------------------
11176 procedure Bad_Mechanism is
11178 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
11181 -- Start of processing for Set_Mechanism_Value
11184 if Mechanism (Ent) /= Default_Mechanism then
11186 ("mechanism for & has already been set", Mech_Name, Ent);
11189 -- MECHANISM_NAME ::= value | reference
11191 if Nkind (Mech_Name) = N_Identifier then
11192 if Chars (Mech_Name) = Name_Value then
11193 Set_Mechanism (Ent, By_Copy);
11196 elsif Chars (Mech_Name) = Name_Reference then
11197 Set_Mechanism (Ent, By_Reference);
11200 elsif Chars (Mech_Name) = Name_Copy then
11202 ("bad mechanism name, Value assumed", Mech_Name);
11211 end Set_Mechanism_Value;
11213 --------------------------
11214 -- Set_Rational_Profile --
11215 --------------------------
11217 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
11218 -- extension to the semantics of renaming declarations.
11220 procedure Set_Rational_Profile is
11222 Implicit_Packing := True;
11223 Overriding_Renamings := True;
11224 Use_VADS_Size := True;
11225 end Set_Rational_Profile;
11227 ---------------------------
11228 -- Set_Ravenscar_Profile --
11229 ---------------------------
11231 -- The tasks to be done here are
11233 -- Set required policies
11235 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11236 -- (For Ravenscar and GNAT_Extended_Ravenscar profiles)
11237 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11238 -- (For GNAT_Ravenscar_EDF profile)
11239 -- pragma Locking_Policy (Ceiling_Locking)
11241 -- Set Detect_Blocking mode
11243 -- Set required restrictions (see System.Rident for detailed list)
11245 -- Set the No_Dependence rules
11246 -- No_Dependence => Ada.Asynchronous_Task_Control
11247 -- No_Dependence => Ada.Calendar
11248 -- No_Dependence => Ada.Execution_Time.Group_Budget
11249 -- No_Dependence => Ada.Execution_Time.Timers
11250 -- No_Dependence => Ada.Task_Attributes
11251 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11253 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id) is
11254 procedure Set_Error_Msg_To_Profile_Name;
11255 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
11258 -----------------------------------
11259 -- Set_Error_Msg_To_Profile_Name --
11260 -----------------------------------
11262 procedure Set_Error_Msg_To_Profile_Name is
11263 Prof_Nam : constant Node_Id :=
11265 (First (Pragma_Argument_Associations (N)));
11268 Get_Name_String (Chars (Prof_Nam));
11269 Adjust_Name_Case (Global_Name_Buffer, Sloc (Prof_Nam));
11270 Error_Msg_Strlen := Name_Len;
11271 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
11272 end Set_Error_Msg_To_Profile_Name;
11281 Profile_Dispatching_Policy : Character;
11283 -- Start of processing for Set_Ravenscar_Profile
11286 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11288 if Profile = GNAT_Ravenscar_EDF then
11289 Profile_Dispatching_Policy := 'E';
11291 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11294 Profile_Dispatching_Policy := 'F';
11297 if Task_Dispatching_Policy /= ' '
11298 and then Task_Dispatching_Policy /= Profile_Dispatching_Policy
11300 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
11301 Set_Error_Msg_To_Profile_Name;
11302 Error_Pragma ("Profile (~) incompatible with policy#");
11304 -- Set the FIFO_Within_Priorities policy, but always preserve
11305 -- System_Location since we like the error message with the run time
11309 Task_Dispatching_Policy := Profile_Dispatching_Policy;
11311 if Task_Dispatching_Policy_Sloc /= System_Location then
11312 Task_Dispatching_Policy_Sloc := Loc;
11316 -- pragma Locking_Policy (Ceiling_Locking)
11318 if Locking_Policy /= ' '
11319 and then Locking_Policy /= 'C'
11321 Error_Msg_Sloc := Locking_Policy_Sloc;
11322 Set_Error_Msg_To_Profile_Name;
11323 Error_Pragma ("Profile (~) incompatible with policy#");
11325 -- Set the Ceiling_Locking policy, but preserve System_Location since
11326 -- we like the error message with the run time name.
11329 Locking_Policy := 'C';
11331 if Locking_Policy_Sloc /= System_Location then
11332 Locking_Policy_Sloc := Loc;
11336 -- pragma Detect_Blocking
11338 Detect_Blocking := True;
11340 -- Set the corresponding restrictions
11342 Set_Profile_Restrictions
11343 (Profile, N, Warn => Treat_Restrictions_As_Warnings);
11345 -- Set the No_Dependence restrictions
11347 -- The following No_Dependence restrictions:
11348 -- No_Dependence => Ada.Asynchronous_Task_Control
11349 -- No_Dependence => Ada.Calendar
11350 -- No_Dependence => Ada.Task_Attributes
11351 -- are already set by previous call to Set_Profile_Restrictions.
11353 -- Set the following restrictions which were added to Ada 2005:
11354 -- No_Dependence => Ada.Execution_Time.Group_Budget
11355 -- No_Dependence => Ada.Execution_Time.Timers
11357 if Ada_Version >= Ada_2005 then
11358 Pref_Id := Make_Identifier (Loc, Name_Find ("ada"));
11359 Sel_Id := Make_Identifier (Loc, Name_Find ("execution_time"));
11362 Make_Selected_Component
11365 Selector_Name => Sel_Id);
11367 Sel_Id := Make_Identifier (Loc, Name_Find ("group_budgets"));
11370 Make_Selected_Component
11373 Selector_Name => Sel_Id);
11375 Set_Restriction_No_Dependence
11377 Warn => Treat_Restrictions_As_Warnings,
11378 Profile => Ravenscar);
11380 Sel_Id := Make_Identifier (Loc, Name_Find ("timers"));
11383 Make_Selected_Component
11386 Selector_Name => Sel_Id);
11388 Set_Restriction_No_Dependence
11390 Warn => Treat_Restrictions_As_Warnings,
11391 Profile => Ravenscar);
11394 -- Set the following restriction which was added to Ada 2012 (see
11396 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11398 if Ada_Version >= Ada_2012 then
11399 Pref_Id := Make_Identifier (Loc, Name_Find ("system"));
11400 Sel_Id := Make_Identifier (Loc, Name_Find ("multiprocessors"));
11403 Make_Selected_Component
11406 Selector_Name => Sel_Id);
11408 Sel_Id := Make_Identifier (Loc, Name_Find ("dispatching_domains"));
11411 Make_Selected_Component
11414 Selector_Name => Sel_Id);
11416 Set_Restriction_No_Dependence
11418 Warn => Treat_Restrictions_As_Warnings,
11419 Profile => Ravenscar);
11421 end Set_Ravenscar_Profile;
11423 -----------------------------------
11424 -- Validate_Acc_Condition_Clause --
11425 -----------------------------------
11427 procedure Validate_Acc_Condition_Clause (Clause : Node_Id) is
11429 Analyze_And_Resolve (Clause);
11431 if not Is_Boolean_Type (Etype (Clause)) then
11432 Error_Pragma ("expected a boolean");
11434 end Validate_Acc_Condition_Clause;
11436 ------------------------------
11437 -- Validate_Acc_Data_Clause --
11438 ------------------------------
11440 procedure Validate_Acc_Data_Clause (Clause : Node_Id) is
11444 Expr := Acc_First (Clause);
11445 while Present (Expr) loop
11446 if Nkind (Expr) /= N_Identifier then
11447 Error_Pragma ("expected an identifer");
11450 Analyze_And_Resolve (Expr);
11452 Expr := Acc_Next (Expr);
11454 end Validate_Acc_Data_Clause;
11456 ----------------------------------
11457 -- Validate_Acc_Int_Expr_Clause --
11458 ----------------------------------
11460 procedure Validate_Acc_Int_Expr_Clause (Clause : Node_Id) is
11462 Analyze_And_Resolve (Clause);
11464 if not Is_Integer_Type (Etype (Clause)) then
11465 Error_Pragma_Arg ("expected an integer", Clause);
11467 end Validate_Acc_Int_Expr_Clause;
11469 ---------------------------------------
11470 -- Validate_Acc_Int_Expr_List_Clause --
11471 ---------------------------------------
11473 procedure Validate_Acc_Int_Expr_List_Clause (Clause : Node_Id) is
11477 Expr := Acc_First (Clause);
11478 while Present (Expr) loop
11479 Analyze_And_Resolve (Expr);
11481 if not Is_Integer_Type (Etype (Expr)) then
11482 Error_Pragma ("expected an integer");
11485 Expr := Acc_Next (Expr);
11487 end Validate_Acc_Int_Expr_List_Clause;
11489 --------------------------------
11490 -- Validate_Acc_Loop_Collapse --
11491 --------------------------------
11493 procedure Validate_Acc_Loop_Collapse (Clause : Node_Id) is
11495 Par_Loop : Node_Id;
11499 -- Make sure the argument is a positive integer
11501 Analyze_And_Resolve (Clause);
11503 Count := Static_Integer (Clause);
11504 if Count = No_Uint or else Count < 1 then
11505 Error_Pragma_Arg ("expected a positive integer", Clause);
11508 -- Then, make sure we have at least Count-1 tightly-nested loops
11509 -- (i.e. loops with no statements in between).
11511 Par_Loop := Parent (Parent (Parent (Clause)));
11512 Stmt := First (Statements (Par_Loop));
11514 -- Skip first pragmas in the parent loop
11516 while Present (Stmt) and then Nkind (Stmt) = N_Pragma loop
11520 if not Present (Next (Stmt)) then
11521 while Nkind (Stmt) = N_Loop_Statement and Count > 1 loop
11522 Stmt := First (Statements (Stmt));
11523 exit when Present (Next (Stmt));
11525 Count := Count - 1;
11531 ("Collapse argument too high or loops not tightly nested",
11534 end Validate_Acc_Loop_Collapse;
11536 ----------------------------
11537 -- Validate_Acc_Loop_Gang --
11538 ----------------------------
11540 procedure Validate_Acc_Loop_Gang (Clause : Node_Id) is
11542 Error_Pragma_Arg ("Loop_Gang not implemented", Clause);
11543 end Validate_Acc_Loop_Gang;
11545 ------------------------------
11546 -- Validate_Acc_Loop_Vector --
11547 ------------------------------
11549 procedure Validate_Acc_Loop_Vector (Clause : Node_Id) is
11551 Error_Pragma_Arg ("Loop_Vector not implemented", Clause);
11552 end Validate_Acc_Loop_Vector;
11554 -------------------------------
11555 -- Validate_Acc_Loop_Worker --
11556 -------------------------------
11558 procedure Validate_Acc_Loop_Worker (Clause : Node_Id) is
11560 Error_Pragma_Arg ("Loop_Worker not implemented", Clause);
11561 end Validate_Acc_Loop_Worker;
11563 ---------------------------------
11564 -- Validate_Acc_Name_Reduction --
11565 ---------------------------------
11567 procedure Validate_Acc_Name_Reduction (Clause : Node_Id) is
11569 -- ??? On top of the following operations, the OpenAcc spec adds the
11570 -- "bitwise and", "bitwise or" and modulo for C and ".eqv" and
11571 -- ".neqv" for Fortran. Can we, should we and how do we support them
11574 type Reduction_Op is (Add_Op, Mul_Op, Max_Op, Min_Op, And_Op, Or_Op);
11576 function To_Reduction_Op (Op : String) return Reduction_Op;
11577 -- Convert operator Op described by a String into its corresponding
11578 -- enumeration value.
11580 ---------------------
11581 -- To_Reduction_Op --
11582 ---------------------
11584 function To_Reduction_Op (Op : String) return Reduction_Op is
11589 elsif Op = "*" then
11592 elsif Op = "max" then
11595 elsif Op = "min" then
11598 elsif Op = "and" then
11601 elsif Op = "or" then
11605 Error_Pragma ("unsuported reduction operation");
11607 end To_Reduction_Op;
11611 Seen : constant Elist_Id := New_Elmt_List;
11614 Reduc_Op : Node_Id;
11615 Reduc_Var : Node_Id;
11617 -- Start of processing for Validate_Acc_Name_Reduction
11620 -- Reduction operations appear in the following form:
11621 -- ("+" => (a, b), "*" => c)
11623 Expr := First (Component_Associations (Clause));
11624 while Present (Expr) loop
11625 Reduc_Op := First (Choices (Expr));
11626 String_To_Name_Buffer (Strval (Reduc_Op));
11628 case To_Reduction_Op (Name_Buffer (1 .. Name_Len)) is
11634 Reduc_Var := Acc_First (Expression (Expr));
11635 while Present (Reduc_Var) loop
11636 Analyze_And_Resolve (Reduc_Var);
11638 if Contains (Seen, Entity (Reduc_Var)) then
11639 Error_Pragma ("variable used in multiple reductions");
11642 if Nkind (Reduc_Var) /= N_Identifier
11643 or not Is_Numeric_Type (Etype (Reduc_Var))
11646 ("expected an identifier for a Numeric");
11649 Append_Elmt (Entity (Reduc_Var), Seen);
11652 Reduc_Var := Acc_Next (Reduc_Var);
11658 Reduc_Var := Acc_First (Expression (Expr));
11659 while Present (Reduc_Var) loop
11660 Analyze_And_Resolve (Reduc_Var);
11662 if Contains (Seen, Entity (Reduc_Var)) then
11663 Error_Pragma ("variable used in multiple reductions");
11666 if Nkind (Reduc_Var) /= N_Identifier
11667 or not Is_Boolean_Type (Etype (Reduc_Var))
11670 ("expected a variable of type boolean");
11673 Append_Elmt (Entity (Reduc_Var), Seen);
11676 Reduc_Var := Acc_Next (Reduc_Var);
11682 end Validate_Acc_Name_Reduction;
11684 -----------------------------------
11685 -- Validate_Acc_Size_Expressions --
11686 -----------------------------------
11688 procedure Validate_Acc_Size_Expressions (Clause : Node_Id) is
11689 function Validate_Size_Expr (Expr : Node_Id) return Boolean;
11690 -- A size expr is either an integer expression or "*"
11692 ------------------------
11693 -- Validate_Size_Expr --
11694 ------------------------
11696 function Validate_Size_Expr (Expr : Node_Id) return Boolean is
11698 if Nkind (Expr) = N_Operator_Symbol then
11699 return Get_String_Char (Strval (Expr), 1) = Get_Char_Code ('*');
11702 Analyze_And_Resolve (Expr);
11704 return Is_Integer_Type (Etype (Expr));
11705 end Validate_Size_Expr;
11711 -- Start of processing for Validate_Acc_Size_Expressions
11714 Expr := Acc_First (Clause);
11715 while Present (Expr) loop
11716 if not Validate_Size_Expr (Expr) then
11718 ("Size expressions should be either integers or '*'");
11721 Expr := Acc_Next (Expr);
11723 end Validate_Acc_Size_Expressions;
11725 -- Start of processing for Analyze_Pragma
11728 -- The following code is a defense against recursion. Not clear that
11729 -- this can happen legitimately, but perhaps some error situations can
11730 -- cause it, and we did see this recursion during testing.
11732 if Analyzed (N) then
11738 Check_Restriction_No_Use_Of_Pragma (N);
11740 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
11741 -- Default_Scalar_Storage_Order if the -gnatI switch was given.
11743 if Should_Ignore_Pragma_Sem (N)
11744 or else (Prag_Id = Pragma_Default_Scalar_Storage_Order
11745 and then Ignore_Rep_Clauses)
11750 -- Deal with unrecognized pragma
11752 if not Is_Pragma_Name (Pname) then
11753 if Warn_On_Unrecognized_Pragma then
11754 Error_Msg_Name_1 := Pname;
11755 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
11757 for PN in First_Pragma_Name .. Last_Pragma_Name loop
11758 if Is_Bad_Spelling_Of (Pname, PN) then
11759 Error_Msg_Name_1 := PN;
11760 Error_Msg_N -- CODEFIX
11761 ("\?g?possible misspelling of %!", Pragma_Identifier (N));
11770 -- Here to start processing for recognized pragma
11772 Pname := Original_Aspect_Pragma_Name (N);
11774 -- Capture setting of Opt.Uneval_Old
11776 case Opt.Uneval_Old is
11778 Set_Uneval_Old_Accept (N);
11784 Set_Uneval_Old_Warn (N);
11787 raise Program_Error;
11790 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
11791 -- is already set, indicating that we have already checked the policy
11792 -- at the right point. This happens for example in the case of a pragma
11793 -- that is derived from an Aspect.
11795 if Is_Ignored (N) or else Is_Checked (N) then
11798 -- For a pragma that is a rewriting of another pragma, copy the
11799 -- Is_Checked/Is_Ignored status from the rewritten pragma.
11801 elsif Is_Rewrite_Substitution (N)
11802 and then Nkind (Original_Node (N)) = N_Pragma
11804 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
11805 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
11807 -- Otherwise query the applicable policy at this point
11810 Check_Applicable_Policy (N);
11812 -- If pragma is disabled, rewrite as NULL and skip analysis
11814 if Is_Disabled (N) then
11815 Rewrite (N, Make_Null_Statement (Loc));
11821 -- Preset arguments
11829 if Present (Pragma_Argument_Associations (N)) then
11830 Arg_Count := List_Length (Pragma_Argument_Associations (N));
11831 Arg1 := First (Pragma_Argument_Associations (N));
11833 if Present (Arg1) then
11834 Arg2 := Next (Arg1);
11836 if Present (Arg2) then
11837 Arg3 := Next (Arg2);
11839 if Present (Arg3) then
11840 Arg4 := Next (Arg3);
11846 -- An enumeration type defines the pragmas that are supported by the
11847 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
11848 -- into the corresponding enumeration value for the following case.
11856 -- pragma Abort_Defer;
11858 when Pragma_Abort_Defer =>
11860 Check_Arg_Count (0);
11862 -- The only required semantic processing is to check the
11863 -- placement. This pragma must appear at the start of the
11864 -- statement sequence of a handled sequence of statements.
11866 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
11867 or else N /= First (Statements (Parent (N)))
11872 --------------------
11873 -- Abstract_State --
11874 --------------------
11876 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
11878 -- ABSTRACT_STATE_LIST ::=
11880 -- | STATE_NAME_WITH_OPTIONS
11881 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
11883 -- STATE_NAME_WITH_OPTIONS ::=
11885 -- | (STATE_NAME with OPTION_LIST)
11887 -- OPTION_LIST ::= OPTION {, OPTION}
11891 -- | NAME_VALUE_OPTION
11893 -- SIMPLE_OPTION ::= Ghost | Synchronous
11895 -- NAME_VALUE_OPTION ::=
11896 -- Part_Of => ABSTRACT_STATE
11897 -- | External [=> EXTERNAL_PROPERTY_LIST]
11899 -- EXTERNAL_PROPERTY_LIST ::=
11900 -- EXTERNAL_PROPERTY
11901 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
11903 -- EXTERNAL_PROPERTY ::=
11904 -- Async_Readers [=> boolean_EXPRESSION]
11905 -- | Async_Writers [=> boolean_EXPRESSION]
11906 -- | Effective_Reads [=> boolean_EXPRESSION]
11907 -- | Effective_Writes [=> boolean_EXPRESSION]
11908 -- others => boolean_EXPRESSION
11910 -- STATE_NAME ::= defining_identifier
11912 -- ABSTRACT_STATE ::= name
11914 -- Characteristics:
11916 -- * Analysis - The annotation is fully analyzed immediately upon
11917 -- elaboration as it cannot forward reference entities.
11919 -- * Expansion - None.
11921 -- * Template - The annotation utilizes the generic template of the
11922 -- related package declaration.
11924 -- * Globals - The annotation cannot reference global entities.
11926 -- * Instance - The annotation is instantiated automatically when
11927 -- the related generic package is instantiated.
11929 when Pragma_Abstract_State => Abstract_State : declare
11930 Missing_Parentheses : Boolean := False;
11931 -- Flag set when a state declaration with options is not properly
11934 -- Flags used to verify the consistency of states
11936 Non_Null_Seen : Boolean := False;
11937 Null_Seen : Boolean := False;
11939 procedure Analyze_Abstract_State
11941 Pack_Id : Entity_Id);
11942 -- Verify the legality of a single state declaration. Create and
11943 -- decorate a state abstraction entity and introduce it into the
11944 -- visibility chain. Pack_Id denotes the entity or the related
11945 -- package where pragma Abstract_State appears.
11947 procedure Malformed_State_Error (State : Node_Id);
11948 -- Emit an error concerning the illegal declaration of abstract
11949 -- state State. This routine diagnoses syntax errors that lead to
11950 -- a different parse tree. The error is issued regardless of the
11951 -- SPARK mode in effect.
11953 ----------------------------
11954 -- Analyze_Abstract_State --
11955 ----------------------------
11957 procedure Analyze_Abstract_State
11959 Pack_Id : Entity_Id)
11961 -- Flags used to verify the consistency of options
11963 AR_Seen : Boolean := False;
11964 AW_Seen : Boolean := False;
11965 ER_Seen : Boolean := False;
11966 EW_Seen : Boolean := False;
11967 External_Seen : Boolean := False;
11968 Ghost_Seen : Boolean := False;
11969 Others_Seen : Boolean := False;
11970 Part_Of_Seen : Boolean := False;
11971 Synchronous_Seen : Boolean := False;
11973 -- Flags used to store the static value of all external states'
11976 AR_Val : Boolean := False;
11977 AW_Val : Boolean := False;
11978 ER_Val : Boolean := False;
11979 EW_Val : Boolean := False;
11981 State_Id : Entity_Id := Empty;
11982 -- The entity to be generated for the current state declaration
11984 procedure Analyze_External_Option (Opt : Node_Id);
11985 -- Verify the legality of option External
11987 procedure Analyze_External_Property
11989 Expr : Node_Id := Empty);
11990 -- Verify the legailty of a single external property. Prop
11991 -- denotes the external property. Expr is the expression used
11992 -- to set the property.
11994 procedure Analyze_Part_Of_Option (Opt : Node_Id);
11995 -- Verify the legality of option Part_Of
11997 procedure Check_Duplicate_Option
11999 Status : in out Boolean);
12000 -- Flag Status denotes whether a particular option has been
12001 -- seen while processing a state. This routine verifies that
12002 -- Opt is not a duplicate option and sets the flag Status
12003 -- (SPARK RM 7.1.4(1)).
12005 procedure Check_Duplicate_Property
12007 Status : in out Boolean);
12008 -- Flag Status denotes whether a particular property has been
12009 -- seen while processing option External. This routine verifies
12010 -- that Prop is not a duplicate property and sets flag Status.
12011 -- Opt is not a duplicate property and sets the flag Status.
12012 -- (SPARK RM 7.1.4(2))
12014 procedure Check_Ghost_Synchronous;
12015 -- Ensure that the abstract state is not subject to both Ghost
12016 -- and Synchronous simple options. Emit an error if this is the
12019 procedure Create_Abstract_State
12023 Is_Null : Boolean);
12024 -- Generate an abstract state entity with name Nam and enter it
12025 -- into visibility. Decl is the "declaration" of the state as
12026 -- it appears in pragma Abstract_State. Loc is the location of
12027 -- the related state "declaration". Flag Is_Null should be set
12028 -- when the associated Abstract_State pragma defines a null
12031 -----------------------------
12032 -- Analyze_External_Option --
12033 -----------------------------
12035 procedure Analyze_External_Option (Opt : Node_Id) is
12036 Errors : constant Nat := Serious_Errors_Detected;
12038 Props : Node_Id := Empty;
12041 if Nkind (Opt) = N_Component_Association then
12042 Props := Expression (Opt);
12045 -- External state with properties
12047 if Present (Props) then
12049 -- Multiple properties appear as an aggregate
12051 if Nkind (Props) = N_Aggregate then
12053 -- Simple property form
12055 Prop := First (Expressions (Props));
12056 while Present (Prop) loop
12057 Analyze_External_Property (Prop);
12061 -- Property with expression form
12063 Prop := First (Component_Associations (Props));
12064 while Present (Prop) loop
12065 Analyze_External_Property
12066 (Prop => First (Choices (Prop)),
12067 Expr => Expression (Prop));
12075 Analyze_External_Property (Props);
12078 -- An external state defined without any properties defaults
12079 -- all properties to True.
12088 -- Once all external properties have been processed, verify
12089 -- their mutual interaction. Do not perform the check when
12090 -- at least one of the properties is illegal as this will
12091 -- produce a bogus error.
12093 if Errors = Serious_Errors_Detected then
12094 Check_External_Properties
12095 (State, AR_Val, AW_Val, ER_Val, EW_Val);
12097 end Analyze_External_Option;
12099 -------------------------------
12100 -- Analyze_External_Property --
12101 -------------------------------
12103 procedure Analyze_External_Property
12105 Expr : Node_Id := Empty)
12107 Expr_Val : Boolean;
12110 -- Check the placement of "others" (if available)
12112 if Nkind (Prop) = N_Others_Choice then
12113 if Others_Seen then
12115 ("only one others choice allowed in option External",
12118 Others_Seen := True;
12121 elsif Others_Seen then
12123 ("others must be the last property in option External",
12126 -- The only remaining legal options are the four predefined
12127 -- external properties.
12129 elsif Nkind (Prop) = N_Identifier
12130 and then Nam_In (Chars (Prop), Name_Async_Readers,
12131 Name_Async_Writers,
12132 Name_Effective_Reads,
12133 Name_Effective_Writes)
12137 -- Otherwise the construct is not a valid property
12140 SPARK_Msg_N ("invalid external state property", Prop);
12144 -- Ensure that the expression of the external state property
12145 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
12147 if Present (Expr) then
12148 Analyze_And_Resolve (Expr, Standard_Boolean);
12150 if Is_OK_Static_Expression (Expr) then
12151 Expr_Val := Is_True (Expr_Value (Expr));
12154 ("expression of external state property must be "
12159 -- The lack of expression defaults the property to True
12165 -- Named properties
12167 if Nkind (Prop) = N_Identifier then
12168 if Chars (Prop) = Name_Async_Readers then
12169 Check_Duplicate_Property (Prop, AR_Seen);
12170 AR_Val := Expr_Val;
12172 elsif Chars (Prop) = Name_Async_Writers then
12173 Check_Duplicate_Property (Prop, AW_Seen);
12174 AW_Val := Expr_Val;
12176 elsif Chars (Prop) = Name_Effective_Reads then
12177 Check_Duplicate_Property (Prop, ER_Seen);
12178 ER_Val := Expr_Val;
12181 Check_Duplicate_Property (Prop, EW_Seen);
12182 EW_Val := Expr_Val;
12185 -- The handling of property "others" must take into account
12186 -- all other named properties that have been encountered so
12187 -- far. Only those that have not been seen are affected by
12191 if not AR_Seen then
12192 AR_Val := Expr_Val;
12195 if not AW_Seen then
12196 AW_Val := Expr_Val;
12199 if not ER_Seen then
12200 ER_Val := Expr_Val;
12203 if not EW_Seen then
12204 EW_Val := Expr_Val;
12207 end Analyze_External_Property;
12209 ----------------------------
12210 -- Analyze_Part_Of_Option --
12211 ----------------------------
12213 procedure Analyze_Part_Of_Option (Opt : Node_Id) is
12214 Encap : constant Node_Id := Expression (Opt);
12215 Constits : Elist_Id;
12216 Encap_Id : Entity_Id;
12220 Check_Duplicate_Option (Opt, Part_Of_Seen);
12223 (Indic => First (Choices (Opt)),
12224 Item_Id => State_Id,
12226 Encap_Id => Encap_Id,
12229 -- The Part_Of indicator transforms the abstract state into
12230 -- a constituent of the encapsulating state or single
12231 -- concurrent type.
12234 pragma Assert (Present (Encap_Id));
12235 Constits := Part_Of_Constituents (Encap_Id);
12237 if No (Constits) then
12238 Constits := New_Elmt_List;
12239 Set_Part_Of_Constituents (Encap_Id, Constits);
12242 Append_Elmt (State_Id, Constits);
12243 Set_Encapsulating_State (State_Id, Encap_Id);
12245 end Analyze_Part_Of_Option;
12247 ----------------------------
12248 -- Check_Duplicate_Option --
12249 ----------------------------
12251 procedure Check_Duplicate_Option
12253 Status : in out Boolean)
12257 SPARK_Msg_N ("duplicate state option", Opt);
12261 end Check_Duplicate_Option;
12263 ------------------------------
12264 -- Check_Duplicate_Property --
12265 ------------------------------
12267 procedure Check_Duplicate_Property
12269 Status : in out Boolean)
12273 SPARK_Msg_N ("duplicate external property", Prop);
12277 end Check_Duplicate_Property;
12279 -----------------------------
12280 -- Check_Ghost_Synchronous --
12281 -----------------------------
12283 procedure Check_Ghost_Synchronous is
12285 -- A synchronized abstract state cannot be Ghost and vice
12286 -- versa (SPARK RM 6.9(19)).
12288 if Ghost_Seen and Synchronous_Seen then
12289 SPARK_Msg_N ("synchronized state cannot be ghost", State);
12291 end Check_Ghost_Synchronous;
12293 ---------------------------
12294 -- Create_Abstract_State --
12295 ---------------------------
12297 procedure Create_Abstract_State
12304 -- The abstract state may be semi-declared when the related
12305 -- package was withed through a limited with clause. In that
12306 -- case reuse the entity to fully declare the state.
12308 if Present (Decl) and then Present (Entity (Decl)) then
12309 State_Id := Entity (Decl);
12311 -- Otherwise the elaboration of pragma Abstract_State
12312 -- declares the state.
12315 State_Id := Make_Defining_Identifier (Loc, Nam);
12317 if Present (Decl) then
12318 Set_Entity (Decl, State_Id);
12322 -- Null states never come from source
12324 Set_Comes_From_Source (State_Id, not Is_Null);
12325 Set_Parent (State_Id, State);
12326 Set_Ekind (State_Id, E_Abstract_State);
12327 Set_Etype (State_Id, Standard_Void_Type);
12328 Set_Encapsulating_State (State_Id, Empty);
12330 -- Set the SPARK mode from the current context
12332 Set_SPARK_Pragma (State_Id, SPARK_Mode_Pragma);
12333 Set_SPARK_Pragma_Inherited (State_Id);
12335 -- An abstract state declared within a Ghost region becomes
12336 -- Ghost (SPARK RM 6.9(2)).
12338 if Ghost_Mode > None or else Is_Ghost_Entity (Pack_Id) then
12339 Set_Is_Ghost_Entity (State_Id);
12342 -- Establish a link between the state declaration and the
12343 -- abstract state entity. Note that a null state remains as
12344 -- N_Null and does not carry any linkages.
12346 if not Is_Null then
12347 if Present (Decl) then
12348 Set_Entity (Decl, State_Id);
12349 Set_Etype (Decl, Standard_Void_Type);
12352 -- Every non-null state must be defined, nameable and
12355 Push_Scope (Pack_Id);
12356 Generate_Definition (State_Id);
12357 Enter_Name (State_Id);
12360 end Create_Abstract_State;
12367 -- Start of processing for Analyze_Abstract_State
12370 -- A package with a null abstract state is not allowed to
12371 -- declare additional states.
12375 ("package & has null abstract state", State, Pack_Id);
12377 -- Null states appear as internally generated entities
12379 elsif Nkind (State) = N_Null then
12380 Create_Abstract_State
12381 (Nam => New_Internal_Name ('S'),
12383 Loc => Sloc (State),
12387 -- Catch a case where a null state appears in a list of
12388 -- non-null states.
12390 if Non_Null_Seen then
12392 ("package & has non-null abstract state",
12396 -- Simple state declaration
12398 elsif Nkind (State) = N_Identifier then
12399 Create_Abstract_State
12400 (Nam => Chars (State),
12402 Loc => Sloc (State),
12404 Non_Null_Seen := True;
12406 -- State declaration with various options. This construct
12407 -- appears as an extension aggregate in the tree.
12409 elsif Nkind (State) = N_Extension_Aggregate then
12410 if Nkind (Ancestor_Part (State)) = N_Identifier then
12411 Create_Abstract_State
12412 (Nam => Chars (Ancestor_Part (State)),
12413 Decl => Ancestor_Part (State),
12414 Loc => Sloc (Ancestor_Part (State)),
12416 Non_Null_Seen := True;
12419 ("state name must be an identifier",
12420 Ancestor_Part (State));
12423 -- Options External, Ghost and Synchronous appear as
12426 Opt := First (Expressions (State));
12427 while Present (Opt) loop
12428 if Nkind (Opt) = N_Identifier then
12432 if Chars (Opt) = Name_External then
12433 Check_Duplicate_Option (Opt, External_Seen);
12434 Analyze_External_Option (Opt);
12438 elsif Chars (Opt) = Name_Ghost then
12439 Check_Duplicate_Option (Opt, Ghost_Seen);
12440 Check_Ghost_Synchronous;
12442 if Present (State_Id) then
12443 Set_Is_Ghost_Entity (State_Id);
12448 elsif Chars (Opt) = Name_Synchronous then
12449 Check_Duplicate_Option (Opt, Synchronous_Seen);
12450 Check_Ghost_Synchronous;
12452 -- Option Part_Of without an encapsulating state is
12453 -- illegal (SPARK RM 7.1.4(8)).
12455 elsif Chars (Opt) = Name_Part_Of then
12457 ("indicator Part_Of must denote abstract state, "
12458 & "single protected type or single task type",
12461 -- Do not emit an error message when a previous state
12462 -- declaration with options was not parenthesized as
12463 -- the option is actually another state declaration.
12465 -- with Abstract_State
12466 -- (State_1 with ..., -- missing parentheses
12467 -- (State_2 with ...),
12468 -- State_3) -- ok state declaration
12470 elsif Missing_Parentheses then
12473 -- Otherwise the option is not allowed. Note that it
12474 -- is not possible to distinguish between an option
12475 -- and a state declaration when a previous state with
12476 -- options not properly parentheses.
12478 -- with Abstract_State
12479 -- (State_1 with ..., -- missing parentheses
12480 -- State_2); -- could be an option
12484 ("simple option not allowed in state declaration",
12488 -- Catch a case where missing parentheses around a state
12489 -- declaration with options cause a subsequent state
12490 -- declaration with options to be treated as an option.
12492 -- with Abstract_State
12493 -- (State_1 with ..., -- missing parentheses
12494 -- (State_2 with ...))
12496 elsif Nkind (Opt) = N_Extension_Aggregate then
12497 Missing_Parentheses := True;
12499 ("state declaration must be parenthesized",
12500 Ancestor_Part (State));
12502 -- Otherwise the option is malformed
12505 SPARK_Msg_N ("malformed option", Opt);
12511 -- Options External and Part_Of appear as component
12514 Opt := First (Component_Associations (State));
12515 while Present (Opt) loop
12516 Opt_Nam := First (Choices (Opt));
12518 if Nkind (Opt_Nam) = N_Identifier then
12519 if Chars (Opt_Nam) = Name_External then
12520 Analyze_External_Option (Opt);
12522 elsif Chars (Opt_Nam) = Name_Part_Of then
12523 Analyze_Part_Of_Option (Opt);
12526 SPARK_Msg_N ("invalid state option", Opt);
12529 SPARK_Msg_N ("invalid state option", Opt);
12535 -- Any other attempt to declare a state is illegal
12538 Malformed_State_Error (State);
12542 -- Guard against a junk state. In such cases no entity is
12543 -- generated and the subsequent checks cannot be applied.
12545 if Present (State_Id) then
12547 -- Verify whether the state does not introduce an illegal
12548 -- hidden state within a package subject to a null abstract
12551 Check_No_Hidden_State (State_Id);
12553 -- Check whether the lack of option Part_Of agrees with the
12554 -- placement of the abstract state with respect to the state
12557 if not Part_Of_Seen then
12558 Check_Missing_Part_Of (State_Id);
12561 -- Associate the state with its related package
12563 if No (Abstract_States (Pack_Id)) then
12564 Set_Abstract_States (Pack_Id, New_Elmt_List);
12567 Append_Elmt (State_Id, Abstract_States (Pack_Id));
12569 end Analyze_Abstract_State;
12571 ---------------------------
12572 -- Malformed_State_Error --
12573 ---------------------------
12575 procedure Malformed_State_Error (State : Node_Id) is
12577 Error_Msg_N ("malformed abstract state declaration", State);
12579 -- An abstract state with a simple option is being declared
12580 -- with "=>" rather than the legal "with". The state appears
12581 -- as a component association.
12583 if Nkind (State) = N_Component_Association then
12584 Error_Msg_N ("\use WITH to specify simple option", State);
12586 end Malformed_State_Error;
12590 Pack_Decl : Node_Id;
12591 Pack_Id : Entity_Id;
12595 -- Start of processing for Abstract_State
12599 Check_No_Identifiers;
12600 Check_Arg_Count (1);
12602 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
12604 if not Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
12605 N_Package_Declaration)
12611 Pack_Id := Defining_Entity (Pack_Decl);
12613 -- A pragma that applies to a Ghost entity becomes Ghost for the
12614 -- purposes of legality checks and removal of ignored Ghost code.
12616 Mark_Ghost_Pragma (N, Pack_Id);
12617 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
12619 -- Chain the pragma on the contract for completeness
12621 Add_Contract_Item (N, Pack_Id);
12623 -- The legality checks of pragmas Abstract_State, Initializes, and
12624 -- Initial_Condition are affected by the SPARK mode in effect. In
12625 -- addition, these three pragmas are subject to an inherent order:
12627 -- 1) Abstract_State
12629 -- 3) Initial_Condition
12631 -- Analyze all these pragmas in the order outlined above
12633 Analyze_If_Present (Pragma_SPARK_Mode);
12634 States := Expression (Get_Argument (N, Pack_Id));
12636 -- Multiple non-null abstract states appear as an aggregate
12638 if Nkind (States) = N_Aggregate then
12639 State := First (Expressions (States));
12640 while Present (State) loop
12641 Analyze_Abstract_State (State, Pack_Id);
12645 -- An abstract state with a simple option is being illegaly
12646 -- declared with "=>" rather than "with". In this case the
12647 -- state declaration appears as a component association.
12649 if Present (Component_Associations (States)) then
12650 State := First (Component_Associations (States));
12651 while Present (State) loop
12652 Malformed_State_Error (State);
12657 -- Various forms of a single abstract state. Note that these may
12658 -- include malformed state declarations.
12661 Analyze_Abstract_State (States, Pack_Id);
12664 Analyze_If_Present (Pragma_Initializes);
12665 Analyze_If_Present (Pragma_Initial_Condition);
12666 end Abstract_State;
12672 when Pragma_Acc_Data => Acc_Data : declare
12673 Clause_Names : constant Name_List :=
12686 Clauses : Args_List (Clause_Names'Range);
12689 if not OpenAcc_Enabled then
12695 if Nkind (Parent (N)) /= N_Loop_Statement then
12697 ("Acc_Data pragma should be placed in loop or block "
12701 Gather_Associations (Clause_Names, Clauses);
12703 for Id in Clause_Names'First .. Clause_Names'Last loop
12704 Clause := Clauses (Id);
12706 if Present (Clause) then
12707 case Clause_Names (Id) is
12715 Validate_Acc_Data_Clause (Clause);
12722 Error_Pragma ("unsupported pragma clause");
12725 raise Program_Error;
12730 Set_Is_OpenAcc_Environment (Parent (N));
12737 when Pragma_Acc_Loop => Acc_Loop : declare
12738 Clause_Names : constant Name_List :=
12751 Clauses : Args_List (Clause_Names'Range);
12755 if not OpenAcc_Enabled then
12761 -- Make sure the pragma is in an openacc construct
12763 Check_Loop_Pragma_Placement;
12766 while Present (Par)
12767 and then (Nkind (Par) /= N_Loop_Statement
12768 or else not Is_OpenAcc_Environment (Par))
12770 Par := Parent (Par);
12773 if not Is_OpenAcc_Environment (Par) then
12775 ("Acc_Loop directive must be associated with an OpenAcc "
12776 & "construct region");
12779 Gather_Associations (Clause_Names, Clauses);
12781 for Id in Clause_Names'First .. Clause_Names'Last loop
12782 Clause := Clauses (Id);
12784 if Present (Clause) then
12785 case Clause_Names (Id) is
12792 when Name_Collapse =>
12793 Validate_Acc_Loop_Collapse (Clause);
12796 Validate_Acc_Loop_Gang (Clause);
12798 when Name_Acc_Private =>
12799 Validate_Acc_Data_Clause (Clause);
12801 when Name_Reduction =>
12802 Validate_Acc_Name_Reduction (Clause);
12805 Validate_Acc_Size_Expressions (Clause);
12807 when Name_Vector =>
12808 Validate_Acc_Loop_Vector (Clause);
12810 when Name_Worker =>
12811 Validate_Acc_Loop_Worker (Clause);
12814 raise Program_Error;
12819 Set_Is_OpenAcc_Loop (Parent (N));
12822 ----------------------------------
12823 -- Acc_Parallel and Acc_Kernels --
12824 ----------------------------------
12826 when Pragma_Acc_Parallel
12827 | Pragma_Acc_Kernels
12829 Acc_Kernels_Or_Parallel : declare
12830 Clause_Names : constant Name_List :=
12843 Name_Vector_Length,
12849 Name_First_Private,
12858 Clauses : Args_List (Clause_Names'Range);
12861 if not OpenAcc_Enabled then
12866 Check_Loop_Pragma_Placement;
12868 if Nkind (Parent (N)) /= N_Loop_Statement then
12870 ("pragma should be placed in loop or block statements");
12873 Gather_Associations (Clause_Names, Clauses);
12875 for Id in Clause_Names'First .. Clause_Names'Last loop
12876 Clause := Clauses (Id);
12878 if Present (Clause) then
12879 if Chars (Parent (Clause)) = No_Name then
12880 Error_Pragma ("all arguments should be associations");
12882 case Clause_Names (Id) is
12884 -- Note: According to the OpenAcc Standard v2.6,
12885 -- Async's argument should be optional. Because this
12886 -- complicates parsing the clause, the argument is
12887 -- made mandatory. The standard defines two negative
12888 -- values, acc_async_noval and acc_async_sync. When
12889 -- given acc_async_noval as value, the clause should
12890 -- behave as if no argument was given. According to
12891 -- the standard, acc_async_noval is defined in header
12892 -- files for C and Fortran, thus this value should
12893 -- probably be defined in the OpenAcc Ada library once
12894 -- it is implemented.
12899 | Name_Vector_Length
12901 Validate_Acc_Int_Expr_Clause (Clause);
12903 when Name_Acc_If =>
12904 Validate_Acc_Condition_Clause (Clause);
12906 -- Unsupported by GCC
12911 Error_Pragma ("unsupported clause");
12913 when Name_Acc_Private
12914 | Name_First_Private
12916 if Prag_Id /= Pragma_Acc_Parallel then
12918 ("argument is only available for 'Parallel' "
12921 Validate_Acc_Data_Clause (Clause);
12931 Validate_Acc_Data_Clause (Clause);
12933 when Name_Reduction =>
12934 if Prag_Id /= Pragma_Acc_Parallel then
12936 ("argument is only available for 'Parallel' "
12939 Validate_Acc_Name_Reduction (Clause);
12942 when Name_Default =>
12943 if Chars (Clause) /= Name_None then
12944 Error_Pragma ("expected none");
12947 when Name_Device_Type =>
12948 Error_Pragma ("unsupported pragma clause");
12950 -- Similar to Name_Async, Name_Wait's arguments should
12951 -- be optional. However, this can be simulated using
12952 -- acc_async_noval, hence, we do not bother making the
12953 -- argument optional for now.
12956 Validate_Acc_Int_Expr_List_Clause (Clause);
12959 raise Program_Error;
12965 Set_Is_OpenAcc_Environment (Parent (N));
12966 end Acc_Kernels_Or_Parallel;
12974 -- Note: this pragma also has some specific processing in Par.Prag
12975 -- because we want to set the Ada version mode during parsing.
12977 when Pragma_Ada_83 =>
12979 Check_Arg_Count (0);
12981 -- We really should check unconditionally for proper configuration
12982 -- pragma placement, since we really don't want mixed Ada modes
12983 -- within a single unit, and the GNAT reference manual has always
12984 -- said this was a configuration pragma, but we did not check and
12985 -- are hesitant to add the check now.
12987 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
12988 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
12989 -- or Ada 2012 mode.
12991 if Ada_Version >= Ada_2005 then
12992 Check_Valid_Configuration_Pragma;
12995 -- Now set Ada 83 mode
12997 if Latest_Ada_Only then
12998 Error_Pragma ("??pragma% ignored");
13000 Ada_Version := Ada_83;
13001 Ada_Version_Explicit := Ada_83;
13002 Ada_Version_Pragma := N;
13011 -- Note: this pragma also has some specific processing in Par.Prag
13012 -- because we want to set the Ada 83 version mode during parsing.
13014 when Pragma_Ada_95 =>
13016 Check_Arg_Count (0);
13018 -- We really should check unconditionally for proper configuration
13019 -- pragma placement, since we really don't want mixed Ada modes
13020 -- within a single unit, and the GNAT reference manual has always
13021 -- said this was a configuration pragma, but we did not check and
13022 -- are hesitant to add the check now.
13024 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
13025 -- or Ada 95, so we must check if we are in Ada 2005 mode.
13027 if Ada_Version >= Ada_2005 then
13028 Check_Valid_Configuration_Pragma;
13031 -- Now set Ada 95 mode
13033 if Latest_Ada_Only then
13034 Error_Pragma ("??pragma% ignored");
13036 Ada_Version := Ada_95;
13037 Ada_Version_Explicit := Ada_95;
13038 Ada_Version_Pragma := N;
13041 ---------------------
13042 -- Ada_05/Ada_2005 --
13043 ---------------------
13046 -- pragma Ada_05 (LOCAL_NAME);
13048 -- pragma Ada_2005;
13049 -- pragma Ada_2005 (LOCAL_NAME):
13051 -- Note: these pragmas also have some specific processing in Par.Prag
13052 -- because we want to set the Ada 2005 version mode during parsing.
13054 -- The one argument form is used for managing the transition from
13055 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
13056 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
13057 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
13058 -- mode, a preference rule is established which does not choose
13059 -- such an entity unless it is unambiguously specified. This avoids
13060 -- extra subprograms marked this way from generating ambiguities in
13061 -- otherwise legal pre-Ada_2005 programs. The one argument form is
13062 -- intended for exclusive use in the GNAT run-time library.
13073 if Arg_Count = 1 then
13074 Check_Arg_Is_Local_Name (Arg1);
13075 E_Id := Get_Pragma_Arg (Arg1);
13077 if Etype (E_Id) = Any_Type then
13081 Set_Is_Ada_2005_Only (Entity (E_Id));
13082 Record_Rep_Item (Entity (E_Id), N);
13085 Check_Arg_Count (0);
13087 -- For Ada_2005 we unconditionally enforce the documented
13088 -- configuration pragma placement, since we do not want to
13089 -- tolerate mixed modes in a unit involving Ada 2005. That
13090 -- would cause real difficulties for those cases where there
13091 -- are incompatibilities between Ada 95 and Ada 2005.
13093 Check_Valid_Configuration_Pragma;
13095 -- Now set appropriate Ada mode
13097 if Latest_Ada_Only then
13098 Error_Pragma ("??pragma% ignored");
13100 Ada_Version := Ada_2005;
13101 Ada_Version_Explicit := Ada_2005;
13102 Ada_Version_Pragma := N;
13107 ---------------------
13108 -- Ada_12/Ada_2012 --
13109 ---------------------
13112 -- pragma Ada_12 (LOCAL_NAME);
13114 -- pragma Ada_2012;
13115 -- pragma Ada_2012 (LOCAL_NAME):
13117 -- Note: these pragmas also have some specific processing in Par.Prag
13118 -- because we want to set the Ada 2012 version mode during parsing.
13120 -- The one argument form is used for managing the transition from Ada
13121 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
13122 -- as Ada_2012 only, then referencing the entity in any pre-Ada_2012
13123 -- mode will generate a warning. In addition, in any pre-Ada_2012
13124 -- mode, a preference rule is established which does not choose
13125 -- such an entity unless it is unambiguously specified. This avoids
13126 -- extra subprograms marked this way from generating ambiguities in
13127 -- otherwise legal pre-Ada_2012 programs. The one argument form is
13128 -- intended for exclusive use in the GNAT run-time library.
13139 if Arg_Count = 1 then
13140 Check_Arg_Is_Local_Name (Arg1);
13141 E_Id := Get_Pragma_Arg (Arg1);
13143 if Etype (E_Id) = Any_Type then
13147 Set_Is_Ada_2012_Only (Entity (E_Id));
13148 Record_Rep_Item (Entity (E_Id), N);
13151 Check_Arg_Count (0);
13153 -- For Ada_2012 we unconditionally enforce the documented
13154 -- configuration pragma placement, since we do not want to
13155 -- tolerate mixed modes in a unit involving Ada 2012. That
13156 -- would cause real difficulties for those cases where there
13157 -- are incompatibilities between Ada 95 and Ada 2012. We could
13158 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
13160 Check_Valid_Configuration_Pragma;
13162 -- Now set appropriate Ada mode
13164 Ada_Version := Ada_2012;
13165 Ada_Version_Explicit := Ada_2012;
13166 Ada_Version_Pragma := N;
13174 -- pragma Ada_2020;
13176 -- Note: this pragma also has some specific processing in Par.Prag
13177 -- because we want to set the Ada 2020 version mode during parsing.
13179 when Pragma_Ada_2020 =>
13182 Check_Arg_Count (0);
13184 Check_Valid_Configuration_Pragma;
13186 -- Now set appropriate Ada mode
13188 Ada_Version := Ada_2020;
13189 Ada_Version_Explicit := Ada_2020;
13190 Ada_Version_Pragma := N;
13192 -------------------------------------
13193 -- Aggregate_Individually_Assign --
13194 -------------------------------------
13196 -- pragma Aggregate_Individually_Assign;
13198 when Pragma_Aggregate_Individually_Assign =>
13200 Check_Arg_Count (0);
13201 Check_Valid_Configuration_Pragma;
13202 Aggregate_Individually_Assign := True;
13204 ----------------------
13205 -- All_Calls_Remote --
13206 ----------------------
13208 -- pragma All_Calls_Remote [(library_package_NAME)];
13210 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
13211 Lib_Entity : Entity_Id;
13214 Check_Ada_83_Warning;
13215 Check_Valid_Library_Unit_Pragma;
13217 if Nkind (N) = N_Null_Statement then
13221 Lib_Entity := Find_Lib_Unit_Name;
13223 -- A pragma that applies to a Ghost entity becomes Ghost for the
13224 -- purposes of legality checks and removal of ignored Ghost code.
13226 Mark_Ghost_Pragma (N, Lib_Entity);
13228 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
13230 if Present (Lib_Entity) and then not Debug_Flag_U then
13231 if not Is_Remote_Call_Interface (Lib_Entity) then
13232 Error_Pragma ("pragma% only apply to rci unit");
13234 -- Set flag for entity of the library unit
13237 Set_Has_All_Calls_Remote (Lib_Entity);
13240 end All_Calls_Remote;
13242 ---------------------------
13243 -- Allow_Integer_Address --
13244 ---------------------------
13246 -- pragma Allow_Integer_Address;
13248 when Pragma_Allow_Integer_Address =>
13250 Check_Valid_Configuration_Pragma;
13251 Check_Arg_Count (0);
13253 -- If Address is a private type, then set the flag to allow
13254 -- integer address values. If Address is not private, then this
13255 -- pragma has no purpose, so it is simply ignored. Not clear if
13256 -- there are any such targets now.
13258 if Opt.Address_Is_Private then
13259 Opt.Allow_Integer_Address := True;
13267 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
13268 -- ARG ::= NAME | EXPRESSION
13270 -- The first two arguments are by convention intended to refer to an
13271 -- external tool and a tool-specific function. These arguments are
13274 when Pragma_Annotate => Annotate : declare
13279 --------------------------
13280 -- Inferred_String_Type --
13281 --------------------------
13283 function Preferred_String_Type (Expr : Node_Id) return Entity_Id;
13284 -- Infer the type to use for a string literal or a concatentation
13285 -- of operands whose types can be inferred. For such expressions,
13286 -- returns the "narrowest" of the three predefined string types
13287 -- that can represent the characters occurring in the expression.
13288 -- For other expressions, returns Empty.
13290 function Preferred_String_Type (Expr : Node_Id) return Entity_Id is
13292 case Nkind (Expr) is
13293 when N_String_Literal =>
13294 if Has_Wide_Wide_Character (Expr) then
13295 return Standard_Wide_Wide_String;
13296 elsif Has_Wide_Character (Expr) then
13297 return Standard_Wide_String;
13299 return Standard_String;
13302 when N_Op_Concat =>
13304 L_Type : constant Entity_Id
13305 := Preferred_String_Type (Left_Opnd (Expr));
13306 R_Type : constant Entity_Id
13307 := Preferred_String_Type (Right_Opnd (Expr));
13309 Type_Table : constant array (1 .. 4) of Entity_Id
13311 Standard_Wide_Wide_String,
13312 Standard_Wide_String,
13315 for Idx in Type_Table'Range loop
13316 if (L_Type = Type_Table (Idx)) or
13317 (R_Type = Type_Table (Idx))
13319 return Type_Table (Idx);
13322 raise Program_Error;
13328 end Preferred_String_Type;
13331 Check_At_Least_N_Arguments (1);
13333 Nam_Arg := Last (Pragma_Argument_Associations (N));
13335 -- Determine whether the last argument is "Entity => local_NAME"
13336 -- and if it is, perform the required semantic checks. Remove the
13337 -- argument from further processing.
13339 if Nkind (Nam_Arg) = N_Pragma_Argument_Association
13340 and then Chars (Nam_Arg) = Name_Entity
13342 Check_Arg_Is_Local_Name (Nam_Arg);
13343 Arg_Count := Arg_Count - 1;
13345 -- A pragma that applies to a Ghost entity becomes Ghost for
13346 -- the purposes of legality checks and removal of ignored Ghost
13349 if Is_Entity_Name (Get_Pragma_Arg (Nam_Arg))
13350 and then Present (Entity (Get_Pragma_Arg (Nam_Arg)))
13352 Mark_Ghost_Pragma (N, Entity (Get_Pragma_Arg (Nam_Arg)));
13355 -- Not allowed in compiler units (bootstrap issues)
13357 Check_Compiler_Unit ("Entity for pragma Annotate", N);
13360 -- Continue the processing with last argument removed for now
13362 Check_Arg_Is_Identifier (Arg1);
13363 Check_No_Identifiers;
13366 -- The second parameter is optional, it is never analyzed
13371 -- Otherwise there is a second parameter
13374 -- The second parameter must be an identifier
13376 Check_Arg_Is_Identifier (Arg2);
13378 -- Process the remaining parameters (if any)
13380 Arg := Next (Arg2);
13381 while Present (Arg) loop
13382 Expr := Get_Pragma_Arg (Arg);
13385 if Is_Entity_Name (Expr) then
13388 -- For string literals and concatenations of string literals
13389 -- we assume Standard_String as the type, unless the string
13390 -- contains wide or wide_wide characters.
13392 elsif Present (Preferred_String_Type (Expr)) then
13393 Resolve (Expr, Preferred_String_Type (Expr));
13395 elsif Is_Overloaded (Expr) then
13396 Error_Pragma_Arg ("ambiguous argument for pragma%", Expr);
13407 -------------------------------------------------
13408 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
13409 -------------------------------------------------
13412 -- ( [Check => ] Boolean_EXPRESSION
13413 -- [, [Message =>] Static_String_EXPRESSION]);
13415 -- pragma Assert_And_Cut
13416 -- ( [Check => ] Boolean_EXPRESSION
13417 -- [, [Message =>] Static_String_EXPRESSION]);
13420 -- ( [Check => ] Boolean_EXPRESSION
13421 -- [, [Message =>] Static_String_EXPRESSION]);
13423 -- pragma Loop_Invariant
13424 -- ( [Check => ] Boolean_EXPRESSION
13425 -- [, [Message =>] Static_String_EXPRESSION]);
13428 | Pragma_Assert_And_Cut
13430 | Pragma_Loop_Invariant
13433 function Contains_Loop_Entry (Expr : Node_Id) return Boolean;
13434 -- Determine whether expression Expr contains a Loop_Entry
13435 -- attribute reference.
13437 -------------------------
13438 -- Contains_Loop_Entry --
13439 -------------------------
13441 function Contains_Loop_Entry (Expr : Node_Id) return Boolean is
13442 Has_Loop_Entry : Boolean := False;
13444 function Process (N : Node_Id) return Traverse_Result;
13445 -- Process function for traversal to look for Loop_Entry
13451 function Process (N : Node_Id) return Traverse_Result is
13453 if Nkind (N) = N_Attribute_Reference
13454 and then Attribute_Name (N) = Name_Loop_Entry
13456 Has_Loop_Entry := True;
13463 procedure Traverse is new Traverse_Proc (Process);
13465 -- Start of processing for Contains_Loop_Entry
13469 return Has_Loop_Entry;
13470 end Contains_Loop_Entry;
13475 New_Args : List_Id;
13477 -- Start of processing for Assert
13480 -- Assert is an Ada 2005 RM-defined pragma
13482 if Prag_Id = Pragma_Assert then
13485 -- The remaining ones are GNAT pragmas
13491 Check_At_Least_N_Arguments (1);
13492 Check_At_Most_N_Arguments (2);
13493 Check_Arg_Order ((Name_Check, Name_Message));
13494 Check_Optional_Identifier (Arg1, Name_Check);
13495 Expr := Get_Pragma_Arg (Arg1);
13497 -- Special processing for Loop_Invariant, Loop_Variant or for
13498 -- other cases where a Loop_Entry attribute is present. If the
13499 -- assertion pragma contains attribute Loop_Entry, ensure that
13500 -- the related pragma is within a loop.
13502 if Prag_Id = Pragma_Loop_Invariant
13503 or else Prag_Id = Pragma_Loop_Variant
13504 or else Contains_Loop_Entry (Expr)
13506 Check_Loop_Pragma_Placement;
13508 -- Perform preanalysis to deal with embedded Loop_Entry
13511 Preanalyze_Assert_Expression (Expr, Any_Boolean);
13514 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
13515 -- a corresponding Check pragma:
13517 -- pragma Check (name, condition [, msg]);
13519 -- Where name is the identifier matching the pragma name. So
13520 -- rewrite pragma in this manner, transfer the message argument
13521 -- if present, and analyze the result
13523 -- Note: When dealing with a semantically analyzed tree, the
13524 -- information that a Check node N corresponds to a source Assert,
13525 -- Assume, or Assert_And_Cut pragma can be retrieved from the
13526 -- pragma kind of Original_Node(N).
13528 New_Args := New_List (
13529 Make_Pragma_Argument_Association (Loc,
13530 Expression => Make_Identifier (Loc, Pname)),
13531 Make_Pragma_Argument_Association (Sloc (Expr),
13532 Expression => Expr));
13534 if Arg_Count > 1 then
13535 Check_Optional_Identifier (Arg2, Name_Message);
13537 -- Provide semantic annnotations for optional argument, for
13538 -- ASIS use, before rewriting.
13540 Preanalyze_And_Resolve (Expression (Arg2), Standard_String);
13541 Append_To (New_Args, New_Copy_Tree (Arg2));
13544 -- Rewrite as Check pragma
13548 Chars => Name_Check,
13549 Pragma_Argument_Associations => New_Args));
13554 ----------------------
13555 -- Assertion_Policy --
13556 ----------------------
13558 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
13560 -- The following form is Ada 2012 only, but we allow it in all modes
13562 -- Pragma Assertion_Policy (
13563 -- ASSERTION_KIND => POLICY_IDENTIFIER
13564 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
13566 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
13568 -- RM_ASSERTION_KIND ::= Assert |
13569 -- Static_Predicate |
13570 -- Dynamic_Predicate |
13575 -- Type_Invariant |
13576 -- Type_Invariant'Class
13578 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
13580 -- Contract_Cases |
13582 -- Default_Initial_Condition |
13584 -- Initial_Condition |
13585 -- Loop_Invariant |
13591 -- Statement_Assertions
13593 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
13594 -- ID_ASSERTION_KIND list contains implementation-defined additions
13595 -- recognized by GNAT. The effect is to control the behavior of
13596 -- identically named aspects and pragmas, depending on the specified
13597 -- policy identifier:
13599 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
13601 -- Note: Check and Ignore are language-defined. Disable is a GNAT
13602 -- implementation-defined addition that results in totally ignoring
13603 -- the corresponding assertion. If Disable is specified, then the
13604 -- argument of the assertion is not even analyzed. This is useful
13605 -- when the aspect/pragma argument references entities in a with'ed
13606 -- package that is replaced by a dummy package in the final build.
13608 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
13609 -- and Type_Invariant'Class were recognized by the parser and
13610 -- transformed into references to the special internal identifiers
13611 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
13612 -- processing is required here.
13614 when Pragma_Assertion_Policy => Assertion_Policy : declare
13615 procedure Resolve_Suppressible (Policy : Node_Id);
13616 -- Converts the assertion policy 'Suppressible' to either Check or
13617 -- Ignore based on whether checks are suppressed via -gnatp.
13619 --------------------------
13620 -- Resolve_Suppressible --
13621 --------------------------
13623 procedure Resolve_Suppressible (Policy : Node_Id) is
13624 Arg : constant Node_Id := Get_Pragma_Arg (Policy);
13628 -- Transform policy argument Suppressible into either Ignore or
13629 -- Check depending on whether checks are enabled or suppressed.
13631 if Chars (Arg) = Name_Suppressible then
13632 if Suppress_Checks then
13633 Nam := Name_Ignore;
13638 Rewrite (Arg, Make_Identifier (Sloc (Arg), Nam));
13640 end Resolve_Suppressible;
13652 -- This can always appear as a configuration pragma
13654 if Is_Configuration_Pragma then
13657 -- It can also appear in a declarative part or package spec in Ada
13658 -- 2012 mode. We allow this in other modes, but in that case we
13659 -- consider that we have an Ada 2012 pragma on our hands.
13662 Check_Is_In_Decl_Part_Or_Package_Spec;
13666 -- One argument case with no identifier (first form above)
13669 and then (Nkind (Arg1) /= N_Pragma_Argument_Association
13670 or else Chars (Arg1) = No_Name)
13672 Check_Arg_Is_One_Of (Arg1,
13673 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
13675 Resolve_Suppressible (Arg1);
13677 -- Treat one argument Assertion_Policy as equivalent to:
13679 -- pragma Check_Policy (Assertion, policy)
13681 -- So rewrite pragma in that manner and link on to the chain
13682 -- of Check_Policy pragmas, marking the pragma as analyzed.
13684 Policy := Get_Pragma_Arg (Arg1);
13688 Chars => Name_Check_Policy,
13689 Pragma_Argument_Associations => New_List (
13690 Make_Pragma_Argument_Association (Loc,
13691 Expression => Make_Identifier (Loc, Name_Assertion)),
13693 Make_Pragma_Argument_Association (Loc,
13695 Make_Identifier (Sloc (Policy), Chars (Policy))))));
13698 -- Here if we have two or more arguments
13701 Check_At_Least_N_Arguments (1);
13704 -- Loop through arguments
13707 while Present (Arg) loop
13708 LocP := Sloc (Arg);
13710 -- Kind must be specified
13712 if Nkind (Arg) /= N_Pragma_Argument_Association
13713 or else Chars (Arg) = No_Name
13716 ("missing assertion kind for pragma%", Arg);
13719 -- Check Kind and Policy have allowed forms
13721 Kind := Chars (Arg);
13722 Policy := Get_Pragma_Arg (Arg);
13724 if not Is_Valid_Assertion_Kind (Kind) then
13726 ("invalid assertion kind for pragma%", Arg);
13729 Check_Arg_Is_One_Of (Arg,
13730 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
13732 Resolve_Suppressible (Arg);
13734 if Kind = Name_Ghost then
13736 -- The Ghost policy must be either Check or Ignore
13737 -- (SPARK RM 6.9(6)).
13739 if not Nam_In (Chars (Policy), Name_Check,
13743 ("argument of pragma % Ghost must be Check or "
13744 & "Ignore", Policy);
13747 -- Pragma Assertion_Policy specifying a Ghost policy
13748 -- cannot occur within a Ghost subprogram or package
13749 -- (SPARK RM 6.9(14)).
13751 if Ghost_Mode > None then
13753 ("pragma % cannot appear within ghost subprogram or "
13758 -- Rewrite the Assertion_Policy pragma as a series of
13759 -- Check_Policy pragmas of the form:
13761 -- Check_Policy (Kind, Policy);
13763 -- Note: the insertion of the pragmas cannot be done with
13764 -- Insert_Action because in the configuration case, there
13765 -- are no scopes on the scope stack and the mechanism will
13768 Insert_Before_And_Analyze (N,
13770 Chars => Name_Check_Policy,
13771 Pragma_Argument_Associations => New_List (
13772 Make_Pragma_Argument_Association (LocP,
13773 Expression => Make_Identifier (LocP, Kind)),
13774 Make_Pragma_Argument_Association (LocP,
13775 Expression => Policy))));
13780 -- Rewrite the Assertion_Policy pragma as null since we have
13781 -- now inserted all the equivalent Check pragmas.
13783 Rewrite (N, Make_Null_Statement (Loc));
13786 end Assertion_Policy;
13788 ------------------------------
13789 -- Assume_No_Invalid_Values --
13790 ------------------------------
13792 -- pragma Assume_No_Invalid_Values (On | Off);
13794 when Pragma_Assume_No_Invalid_Values =>
13796 Check_Valid_Configuration_Pragma;
13797 Check_Arg_Count (1);
13798 Check_No_Identifiers;
13799 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
13801 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
13802 Assume_No_Invalid_Values := True;
13804 Assume_No_Invalid_Values := False;
13807 --------------------------
13808 -- Attribute_Definition --
13809 --------------------------
13811 -- pragma Attribute_Definition
13812 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
13813 -- [Entity =>] LOCAL_NAME,
13814 -- [Expression =>] EXPRESSION | NAME);
13816 when Pragma_Attribute_Definition => Attribute_Definition : declare
13817 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
13822 Check_Arg_Count (3);
13823 Check_Optional_Identifier (Arg1, "attribute");
13824 Check_Optional_Identifier (Arg2, "entity");
13825 Check_Optional_Identifier (Arg3, "expression");
13827 if Nkind (Attribute_Designator) /= N_Identifier then
13828 Error_Msg_N ("attribute name expected", Attribute_Designator);
13832 Check_Arg_Is_Local_Name (Arg2);
13834 -- If the attribute is not recognized, then issue a warning (not
13835 -- an error), and ignore the pragma.
13837 Aname := Chars (Attribute_Designator);
13839 if not Is_Attribute_Name (Aname) then
13840 Bad_Attribute (Attribute_Designator, Aname, Warn => True);
13844 -- Otherwise, rewrite the pragma as an attribute definition clause
13847 Make_Attribute_Definition_Clause (Loc,
13848 Name => Get_Pragma_Arg (Arg2),
13850 Expression => Get_Pragma_Arg (Arg3)));
13852 end Attribute_Definition;
13854 ------------------------------------------------------------------
13855 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
13857 ------------------------------------------------------------------
13859 -- pragma Async_Readers [ (boolean_EXPRESSION) ];
13860 -- pragma Async_Writers [ (boolean_EXPRESSION) ];
13861 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
13862 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
13863 -- pragma No_Caching [ (boolean_EXPRESSION) ];
13865 when Pragma_Async_Readers
13866 | Pragma_Async_Writers
13867 | Pragma_Effective_Reads
13868 | Pragma_Effective_Writes
13869 | Pragma_No_Caching
13871 Async_Effective : declare
13872 Obj_Decl : Node_Id;
13873 Obj_Id : Entity_Id;
13877 Check_No_Identifiers;
13878 Check_At_Most_N_Arguments (1);
13880 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
13882 -- Object declaration
13884 if Nkind (Obj_Decl) /= N_Object_Declaration then
13889 Obj_Id := Defining_Entity (Obj_Decl);
13891 -- Perform minimal verification to ensure that the argument is at
13892 -- least a variable. Subsequent finer grained checks will be done
13893 -- at the end of the declarative region the contains the pragma.
13895 if Ekind (Obj_Id) = E_Variable then
13897 -- A pragma that applies to a Ghost entity becomes Ghost for
13898 -- the purposes of legality checks and removal of ignored Ghost
13901 Mark_Ghost_Pragma (N, Obj_Id);
13903 -- Chain the pragma on the contract for further processing by
13904 -- Analyze_External_Property_In_Decl_Part.
13906 Add_Contract_Item (N, Obj_Id);
13908 -- Analyze the Boolean expression (if any)
13910 if Present (Arg1) then
13911 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
13914 -- Otherwise the external property applies to a constant
13917 Error_Pragma ("pragma % must apply to a volatile object");
13919 end Async_Effective;
13925 -- pragma Asynchronous (LOCAL_NAME);
13927 when Pragma_Asynchronous => Asynchronous : declare
13930 Formal : Entity_Id;
13935 procedure Process_Async_Pragma;
13936 -- Common processing for procedure and access-to-procedure case
13938 --------------------------
13939 -- Process_Async_Pragma --
13940 --------------------------
13942 procedure Process_Async_Pragma is
13945 Set_Is_Asynchronous (Nm);
13949 -- The formals should be of mode IN (RM E.4.1(6))
13952 while Present (S) loop
13953 Formal := Defining_Identifier (S);
13955 if Nkind (Formal) = N_Defining_Identifier
13956 and then Ekind (Formal) /= E_In_Parameter
13959 ("pragma% procedure can only have IN parameter",
13966 Set_Is_Asynchronous (Nm);
13967 end Process_Async_Pragma;
13969 -- Start of processing for pragma Asynchronous
13972 Check_Ada_83_Warning;
13973 Check_No_Identifiers;
13974 Check_Arg_Count (1);
13975 Check_Arg_Is_Local_Name (Arg1);
13977 if Debug_Flag_U then
13981 C_Ent := Cunit_Entity (Current_Sem_Unit);
13982 Analyze (Get_Pragma_Arg (Arg1));
13983 Nm := Entity (Get_Pragma_Arg (Arg1));
13985 -- A pragma that applies to a Ghost entity becomes Ghost for the
13986 -- purposes of legality checks and removal of ignored Ghost code.
13988 Mark_Ghost_Pragma (N, Nm);
13990 if not Is_Remote_Call_Interface (C_Ent)
13991 and then not Is_Remote_Types (C_Ent)
13993 -- This pragma should only appear in an RCI or Remote Types
13994 -- unit (RM E.4.1(4)).
13997 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
14000 if Ekind (Nm) = E_Procedure
14001 and then Nkind (Parent (Nm)) = N_Procedure_Specification
14003 if not Is_Remote_Call_Interface (Nm) then
14005 ("pragma% cannot be applied on non-remote procedure",
14009 L := Parameter_Specifications (Parent (Nm));
14010 Process_Async_Pragma;
14013 elsif Ekind (Nm) = E_Function then
14015 ("pragma% cannot be applied to function", Arg1);
14017 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
14018 if Is_Record_Type (Nm) then
14020 -- A record type that is the Equivalent_Type for a remote
14021 -- access-to-subprogram type.
14023 Decl := Declaration_Node (Corresponding_Remote_Type (Nm));
14026 -- A non-expanded RAS type (distribution is not enabled)
14028 Decl := Declaration_Node (Nm);
14031 if Nkind (Decl) = N_Full_Type_Declaration
14032 and then Nkind (Type_Definition (Decl)) =
14033 N_Access_Procedure_Definition
14035 L := Parameter_Specifications (Type_Definition (Decl));
14036 Process_Async_Pragma;
14038 if Is_Asynchronous (Nm)
14039 and then Expander_Active
14040 and then Get_PCS_Name /= Name_No_DSA
14042 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
14047 ("pragma% cannot reference access-to-function type",
14051 -- Only other possibility is Access-to-class-wide type
14053 elsif Is_Access_Type (Nm)
14054 and then Is_Class_Wide_Type (Designated_Type (Nm))
14056 Check_First_Subtype (Arg1);
14057 Set_Is_Asynchronous (Nm);
14058 if Expander_Active then
14059 RACW_Type_Is_Asynchronous (Nm);
14063 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
14071 -- pragma Atomic (LOCAL_NAME);
14073 when Pragma_Atomic =>
14074 Process_Atomic_Independent_Shared_Volatile;
14076 -----------------------
14077 -- Atomic_Components --
14078 -----------------------
14080 -- pragma Atomic_Components (array_LOCAL_NAME);
14082 -- This processing is shared by Volatile_Components
14084 when Pragma_Atomic_Components
14085 | Pragma_Volatile_Components
14087 Atomic_Components : declare
14093 Check_Ada_83_Warning;
14094 Check_No_Identifiers;
14095 Check_Arg_Count (1);
14096 Check_Arg_Is_Local_Name (Arg1);
14097 E_Id := Get_Pragma_Arg (Arg1);
14099 if Etype (E_Id) = Any_Type then
14103 E := Entity (E_Id);
14105 -- A pragma that applies to a Ghost entity becomes Ghost for the
14106 -- purposes of legality checks and removal of ignored Ghost code.
14108 Mark_Ghost_Pragma (N, E);
14109 Check_Duplicate_Pragma (E);
14111 if Rep_Item_Too_Early (E, N)
14113 Rep_Item_Too_Late (E, N)
14118 D := Declaration_Node (E);
14120 if (Nkind (D) = N_Full_Type_Declaration and then Is_Array_Type (E))
14122 (Nkind (D) = N_Object_Declaration
14123 and then (Ekind (E) = E_Constant
14125 Ekind (E) = E_Variable)
14126 and then Nkind (Object_Definition (D)) =
14127 N_Constrained_Array_Definition)
14129 (Ada_Version >= Ada_2020
14130 and then Nkind (D) = N_Formal_Type_Declaration)
14132 -- The flag is set on the base type, or on the object
14134 if Nkind (D) = N_Full_Type_Declaration then
14135 E := Base_Type (E);
14138 -- Atomic implies both Independent and Volatile
14140 if Prag_Id = Pragma_Atomic_Components then
14141 if Ada_Version >= Ada_2020 then
14143 (Component_Type (Etype (E)), VFA => False);
14146 Set_Has_Atomic_Components (E);
14147 Set_Has_Independent_Components (E);
14150 Set_Has_Volatile_Components (E);
14153 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
14155 end Atomic_Components;
14157 --------------------
14158 -- Attach_Handler --
14159 --------------------
14161 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
14163 when Pragma_Attach_Handler =>
14164 Check_Ada_83_Warning;
14165 Check_No_Identifiers;
14166 Check_Arg_Count (2);
14168 if No_Run_Time_Mode then
14169 Error_Msg_CRT ("Attach_Handler pragma", N);
14171 Check_Interrupt_Or_Attach_Handler;
14173 -- The expression that designates the attribute may depend on a
14174 -- discriminant, and is therefore a per-object expression, to
14175 -- be expanded in the init proc. If expansion is enabled, then
14176 -- perform semantic checks on a copy only.
14181 Parg2 : constant Node_Id := Get_Pragma_Arg (Arg2);
14184 -- In Relaxed_RM_Semantics mode, we allow any static
14185 -- integer value, for compatibility with other compilers.
14187 if Relaxed_RM_Semantics
14188 and then Nkind (Parg2) = N_Integer_Literal
14190 Typ := Standard_Integer;
14192 Typ := RTE (RE_Interrupt_ID);
14195 if Expander_Active then
14196 Temp := New_Copy_Tree (Parg2);
14197 Set_Parent (Temp, N);
14198 Preanalyze_And_Resolve (Temp, Typ);
14201 Resolve (Parg2, Typ);
14205 Process_Interrupt_Or_Attach_Handler;
14208 --------------------
14209 -- C_Pass_By_Copy --
14210 --------------------
14212 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
14214 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
14220 Check_Valid_Configuration_Pragma;
14221 Check_Arg_Count (1);
14222 Check_Optional_Identifier (Arg1, "max_size");
14224 Arg := Get_Pragma_Arg (Arg1);
14225 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
14227 Val := Expr_Value (Arg);
14231 ("maximum size for pragma% must be positive", Arg1);
14233 elsif UI_Is_In_Int_Range (Val) then
14234 Default_C_Record_Mechanism := UI_To_Int (Val);
14236 -- If a giant value is given, Int'Last will do well enough.
14237 -- If sometime someone complains that a record larger than
14238 -- two gigabytes is not copied, we will worry about it then.
14241 Default_C_Record_Mechanism := Mechanism_Type'Last;
14243 end C_Pass_By_Copy;
14249 -- pragma Check ([Name =>] CHECK_KIND,
14250 -- [Check =>] Boolean_EXPRESSION
14251 -- [,[Message =>] String_EXPRESSION]);
14253 -- CHECK_KIND ::= IDENTIFIER |
14256 -- Invariant'Class |
14257 -- Type_Invariant'Class
14259 -- The identifiers Assertions and Statement_Assertions are not
14260 -- allowed, since they have special meaning for Check_Policy.
14262 -- WARNING: The code below manages Ghost regions. Return statements
14263 -- must be replaced by gotos which jump to the end of the code and
14264 -- restore the Ghost mode.
14266 when Pragma_Check => Check : declare
14267 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
14268 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
14269 -- Save the Ghost-related attributes to restore on exit
14275 pragma Warnings (Off, Str);
14278 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
14279 -- the mode now to ensure that any nodes generated during analysis
14280 -- and expansion are marked as Ghost.
14282 Set_Ghost_Mode (N);
14285 Check_At_Least_N_Arguments (2);
14286 Check_At_Most_N_Arguments (3);
14287 Check_Optional_Identifier (Arg1, Name_Name);
14288 Check_Optional_Identifier (Arg2, Name_Check);
14290 if Arg_Count = 3 then
14291 Check_Optional_Identifier (Arg3, Name_Message);
14292 Str := Get_Pragma_Arg (Arg3);
14295 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
14296 Check_Arg_Is_Identifier (Arg1);
14297 Cname := Chars (Get_Pragma_Arg (Arg1));
14299 -- Check forbidden name Assertions or Statement_Assertions
14302 when Name_Assertions =>
14304 ("""Assertions"" is not allowed as a check kind for "
14305 & "pragma%", Arg1);
14307 when Name_Statement_Assertions =>
14309 ("""Statement_Assertions"" is not allowed as a check kind "
14310 & "for pragma%", Arg1);
14316 -- Check applicable policy. We skip this if Checked/Ignored status
14317 -- is already set (e.g. in the case of a pragma from an aspect).
14319 if Is_Checked (N) or else Is_Ignored (N) then
14322 -- For a non-source pragma that is a rewriting of another pragma,
14323 -- copy the Is_Checked/Ignored status from the rewritten pragma.
14325 elsif Is_Rewrite_Substitution (N)
14326 and then Nkind (Original_Node (N)) = N_Pragma
14328 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
14329 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
14331 -- Otherwise query the applicable policy at this point
14334 case Check_Kind (Cname) is
14335 when Name_Ignore =>
14336 Set_Is_Ignored (N, True);
14337 Set_Is_Checked (N, False);
14340 Set_Is_Ignored (N, False);
14341 Set_Is_Checked (N, True);
14343 -- For disable, rewrite pragma as null statement and skip
14344 -- rest of the analysis of the pragma.
14346 when Name_Disable =>
14347 Rewrite (N, Make_Null_Statement (Loc));
14351 -- No other possibilities
14354 raise Program_Error;
14358 -- If check kind was not Disable, then continue pragma analysis
14360 Expr := Get_Pragma_Arg (Arg2);
14362 -- Mark the pragma (or, if rewritten from an aspect, the original
14363 -- aspect) as enabled. Nothing to do for an internally generated
14364 -- check for a dynamic predicate.
14367 and then not Split_PPC (N)
14368 and then Cname /= Name_Dynamic_Predicate
14370 Set_SCO_Pragma_Enabled (Loc);
14373 -- Deal with analyzing the string argument. If checks are not
14374 -- on we don't want any expansion (since such expansion would
14375 -- not get properly deleted) but we do want to analyze (to get
14376 -- proper references). The Preanalyze_And_Resolve routine does
14377 -- just what we want. Ditto if pragma is active, because it will
14378 -- be rewritten as an if-statement whose analysis will complete
14379 -- analysis and expansion of the string message. This makes a
14380 -- difference in the unusual case where the expression for the
14381 -- string may have a side effect, such as raising an exception.
14382 -- This is mandated by RM 11.4.2, which specifies that the string
14383 -- expression is only evaluated if the check fails and
14384 -- Assertion_Error is to be raised.
14386 if Arg_Count = 3 then
14387 Preanalyze_And_Resolve (Str, Standard_String);
14390 -- Now you might think we could just do the same with the Boolean
14391 -- expression if checks are off (and expansion is on) and then
14392 -- rewrite the check as a null statement. This would work but we
14393 -- would lose the useful warnings about an assertion being bound
14394 -- to fail even if assertions are turned off.
14396 -- So instead we wrap the boolean expression in an if statement
14397 -- that looks like:
14399 -- if False and then condition then
14403 -- The reason we do this rewriting during semantic analysis rather
14404 -- than as part of normal expansion is that we cannot analyze and
14405 -- expand the code for the boolean expression directly, or it may
14406 -- cause insertion of actions that would escape the attempt to
14407 -- suppress the check code.
14409 -- Note that the Sloc for the if statement corresponds to the
14410 -- argument condition, not the pragma itself. The reason for
14411 -- this is that we may generate a warning if the condition is
14412 -- False at compile time, and we do not want to delete this
14413 -- warning when we delete the if statement.
14415 if Expander_Active and Is_Ignored (N) then
14416 Eloc := Sloc (Expr);
14419 Make_If_Statement (Eloc,
14421 Make_And_Then (Eloc,
14422 Left_Opnd => Make_Identifier (Eloc, Name_False),
14423 Right_Opnd => Expr),
14424 Then_Statements => New_List (
14425 Make_Null_Statement (Eloc))));
14427 -- Now go ahead and analyze the if statement
14429 In_Assertion_Expr := In_Assertion_Expr + 1;
14431 -- One rather special treatment. If we are now in Eliminated
14432 -- overflow mode, then suppress overflow checking since we do
14433 -- not want to drag in the bignum stuff if we are in Ignore
14434 -- mode anyway. This is particularly important if we are using
14435 -- a configurable run time that does not support bignum ops.
14437 if Scope_Suppress.Overflow_Mode_Assertions = Eliminated then
14439 Svo : constant Boolean :=
14440 Scope_Suppress.Suppress (Overflow_Check);
14442 Scope_Suppress.Overflow_Mode_Assertions := Strict;
14443 Scope_Suppress.Suppress (Overflow_Check) := True;
14445 Scope_Suppress.Suppress (Overflow_Check) := Svo;
14446 Scope_Suppress.Overflow_Mode_Assertions := Eliminated;
14449 -- Not that special case
14455 -- All done with this check
14457 In_Assertion_Expr := In_Assertion_Expr - 1;
14459 -- Check is active or expansion not active. In these cases we can
14460 -- just go ahead and analyze the boolean with no worries.
14463 In_Assertion_Expr := In_Assertion_Expr + 1;
14464 Analyze_And_Resolve (Expr, Any_Boolean);
14465 In_Assertion_Expr := In_Assertion_Expr - 1;
14468 Restore_Ghost_Region (Saved_GM, Saved_IGR);
14471 --------------------------
14472 -- Check_Float_Overflow --
14473 --------------------------
14475 -- pragma Check_Float_Overflow;
14477 when Pragma_Check_Float_Overflow =>
14479 Check_Valid_Configuration_Pragma;
14480 Check_Arg_Count (0);
14481 Check_Float_Overflow := not Machine_Overflows_On_Target;
14487 -- pragma Check_Name (check_IDENTIFIER);
14489 when Pragma_Check_Name =>
14491 Check_No_Identifiers;
14492 Check_Valid_Configuration_Pragma;
14493 Check_Arg_Count (1);
14494 Check_Arg_Is_Identifier (Arg1);
14497 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
14500 for J in Check_Names.First .. Check_Names.Last loop
14501 if Check_Names.Table (J) = Nam then
14506 Check_Names.Append (Nam);
14513 -- This is the old style syntax, which is still allowed in all modes:
14515 -- pragma Check_Policy ([Name =>] CHECK_KIND
14516 -- [Policy =>] POLICY_IDENTIFIER);
14518 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
14520 -- CHECK_KIND ::= IDENTIFIER |
14523 -- Type_Invariant'Class |
14526 -- This is the new style syntax, compatible with Assertion_Policy
14527 -- and also allowed in all modes.
14529 -- Pragma Check_Policy (
14530 -- CHECK_KIND => POLICY_IDENTIFIER
14531 -- {, CHECK_KIND => POLICY_IDENTIFIER});
14533 -- Note: the identifiers Name and Policy are not allowed as
14534 -- Check_Kind values. This avoids ambiguities between the old and
14535 -- new form syntax.
14537 when Pragma_Check_Policy => Check_Policy : declare
14542 Check_At_Least_N_Arguments (1);
14544 -- A Check_Policy pragma can appear either as a configuration
14545 -- pragma, or in a declarative part or a package spec (see RM
14546 -- 11.5(5) for rules for Suppress/Unsuppress which are also
14547 -- followed for Check_Policy).
14549 if not Is_Configuration_Pragma then
14550 Check_Is_In_Decl_Part_Or_Package_Spec;
14553 -- Figure out if we have the old or new syntax. We have the
14554 -- old syntax if the first argument has no identifier, or the
14555 -- identifier is Name.
14557 if Nkind (Arg1) /= N_Pragma_Argument_Association
14558 or else Nam_In (Chars (Arg1), No_Name, Name_Name)
14562 Check_Arg_Count (2);
14563 Check_Optional_Identifier (Arg1, Name_Name);
14564 Kind := Get_Pragma_Arg (Arg1);
14565 Rewrite_Assertion_Kind (Kind,
14566 From_Policy => Comes_From_Source (N));
14567 Check_Arg_Is_Identifier (Arg1);
14569 -- Check forbidden check kind
14571 if Nam_In (Chars (Kind), Name_Name, Name_Policy) then
14572 Error_Msg_Name_2 := Chars (Kind);
14574 ("pragma% does not allow% as check name", Arg1);
14579 Check_Optional_Identifier (Arg2, Name_Policy);
14580 Check_Arg_Is_One_Of
14582 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
14584 -- And chain pragma on the Check_Policy_List for search
14586 Set_Next_Pragma (N, Opt.Check_Policy_List);
14587 Opt.Check_Policy_List := N;
14589 -- For the new syntax, what we do is to convert each argument to
14590 -- an old syntax equivalent. We do that because we want to chain
14591 -- old style Check_Policy pragmas for the search (we don't want
14592 -- to have to deal with multiple arguments in the search).
14603 while Present (Arg) loop
14604 LocP := Sloc (Arg);
14605 Argx := Get_Pragma_Arg (Arg);
14607 -- Kind must be specified
14609 if Nkind (Arg) /= N_Pragma_Argument_Association
14610 or else Chars (Arg) = No_Name
14613 ("missing assertion kind for pragma%", Arg);
14616 -- Construct equivalent old form syntax Check_Policy
14617 -- pragma and insert it to get remaining checks.
14621 Chars => Name_Check_Policy,
14622 Pragma_Argument_Associations => New_List (
14623 Make_Pragma_Argument_Association (LocP,
14625 Make_Identifier (LocP, Chars (Arg))),
14626 Make_Pragma_Argument_Association (Sloc (Argx),
14627 Expression => Argx)));
14631 -- For a configuration pragma, insert old form in
14632 -- the corresponding file.
14634 if Is_Configuration_Pragma then
14635 Insert_After (N, New_P);
14639 Insert_Action (N, New_P);
14643 -- Rewrite original Check_Policy pragma to null, since we
14644 -- have converted it into a series of old syntax pragmas.
14646 Rewrite (N, Make_Null_Statement (Loc));
14656 -- pragma Comment (static_string_EXPRESSION)
14658 -- Processing for pragma Comment shares the circuitry for pragma
14659 -- Ident. The only differences are that Ident enforces a limit of 31
14660 -- characters on its argument, and also enforces limitations on
14661 -- placement for DEC compatibility. Pragma Comment shares neither of
14662 -- these restrictions.
14664 -------------------
14665 -- Common_Object --
14666 -------------------
14668 -- pragma Common_Object (
14669 -- [Internal =>] LOCAL_NAME
14670 -- [, [External =>] EXTERNAL_SYMBOL]
14671 -- [, [Size =>] EXTERNAL_SYMBOL]);
14673 -- Processing for this pragma is shared with Psect_Object
14675 ----------------------------------------------
14676 -- Compile_Time_Error, Compile_Time_Warning --
14677 ----------------------------------------------
14679 -- pragma Compile_Time_Error
14680 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14682 -- pragma Compile_Time_Warning
14683 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14685 when Pragma_Compile_Time_Error | Pragma_Compile_Time_Warning =>
14687 Process_Compile_Time_Warning_Or_Error;
14689 ---------------------------
14690 -- Compiler_Unit_Warning --
14691 ---------------------------
14693 -- pragma Compiler_Unit_Warning;
14697 -- Originally, we had only pragma Compiler_Unit, and it resulted in
14698 -- errors not warnings. This means that we had introduced a big extra
14699 -- inertia to compiler changes, since even if we implemented a new
14700 -- feature, and even if all versions to be used for bootstrapping
14701 -- implemented this new feature, we could not use it, since old
14702 -- compilers would give errors for using this feature in units
14703 -- having Compiler_Unit pragmas.
14705 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
14706 -- problem. We no longer have any units mentioning Compiler_Unit,
14707 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
14708 -- and thus generates a warning which can be ignored. So that deals
14709 -- with the problem of old compilers not implementing the newer form
14712 -- Newer compilers recognize the new pragma, but generate warning
14713 -- messages instead of errors, which again can be ignored in the
14714 -- case of an old compiler which implements a wanted new feature
14715 -- but at the time felt like warning about it for older compilers.
14717 -- We retain Compiler_Unit so that new compilers can be used to build
14718 -- older run-times that use this pragma. That's an unusual case, but
14719 -- it's easy enough to handle, so why not?
14721 when Pragma_Compiler_Unit
14722 | Pragma_Compiler_Unit_Warning
14725 Check_Arg_Count (0);
14727 -- Only recognized in main unit
14729 if Current_Sem_Unit = Main_Unit then
14730 Compiler_Unit := True;
14733 -----------------------------
14734 -- Complete_Representation --
14735 -----------------------------
14737 -- pragma Complete_Representation;
14739 when Pragma_Complete_Representation =>
14741 Check_Arg_Count (0);
14743 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
14745 ("pragma & must appear within record representation clause");
14748 ----------------------------
14749 -- Complex_Representation --
14750 ----------------------------
14752 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
14754 when Pragma_Complex_Representation => Complex_Representation : declare
14761 Check_Arg_Count (1);
14762 Check_Optional_Identifier (Arg1, Name_Entity);
14763 Check_Arg_Is_Local_Name (Arg1);
14764 E_Id := Get_Pragma_Arg (Arg1);
14766 if Etype (E_Id) = Any_Type then
14770 E := Entity (E_Id);
14772 if not Is_Record_Type (E) then
14774 ("argument for pragma% must be record type", Arg1);
14777 Ent := First_Entity (E);
14780 or else No (Next_Entity (Ent))
14781 or else Present (Next_Entity (Next_Entity (Ent)))
14782 or else not Is_Floating_Point_Type (Etype (Ent))
14783 or else Etype (Ent) /= Etype (Next_Entity (Ent))
14786 ("record for pragma% must have two fields of the same "
14787 & "floating-point type", Arg1);
14790 Set_Has_Complex_Representation (Base_Type (E));
14792 -- We need to treat the type has having a non-standard
14793 -- representation, for back-end purposes, even though in
14794 -- general a complex will have the default representation
14795 -- of a record with two real components.
14797 Set_Has_Non_Standard_Rep (Base_Type (E));
14799 end Complex_Representation;
14801 -------------------------
14802 -- Component_Alignment --
14803 -------------------------
14805 -- pragma Component_Alignment (
14806 -- [Form =>] ALIGNMENT_CHOICE
14807 -- [, [Name =>] type_LOCAL_NAME]);
14809 -- ALIGNMENT_CHOICE ::=
14811 -- | Component_Size_4
14815 when Pragma_Component_Alignment => Component_AlignmentP : declare
14816 Args : Args_List (1 .. 2);
14817 Names : constant Name_List (1 .. 2) := (
14821 Form : Node_Id renames Args (1);
14822 Name : Node_Id renames Args (2);
14824 Atype : Component_Alignment_Kind;
14829 Gather_Associations (Names, Args);
14832 Error_Pragma ("missing Form argument for pragma%");
14835 Check_Arg_Is_Identifier (Form);
14837 -- Get proper alignment, note that Default = Component_Size on all
14838 -- machines we have so far, and we want to set this value rather
14839 -- than the default value to indicate that it has been explicitly
14840 -- set (and thus will not get overridden by the default component
14841 -- alignment for the current scope)
14843 if Chars (Form) = Name_Component_Size then
14844 Atype := Calign_Component_Size;
14846 elsif Chars (Form) = Name_Component_Size_4 then
14847 Atype := Calign_Component_Size_4;
14849 elsif Chars (Form) = Name_Default then
14850 Atype := Calign_Component_Size;
14852 elsif Chars (Form) = Name_Storage_Unit then
14853 Atype := Calign_Storage_Unit;
14857 ("invalid Form parameter for pragma%", Form);
14860 -- The pragma appears in a configuration file
14862 if No (Parent (N)) then
14863 Check_Valid_Configuration_Pragma;
14865 -- Capture the component alignment in a global variable when
14866 -- the pragma appears in a configuration file. Note that the
14867 -- scope stack is empty at this point and cannot be used to
14868 -- store the alignment value.
14870 Configuration_Component_Alignment := Atype;
14872 -- Case with no name, supplied, affects scope table entry
14874 elsif No (Name) then
14876 (Scope_Stack.Last).Component_Alignment_Default := Atype;
14878 -- Case of name supplied
14881 Check_Arg_Is_Local_Name (Name);
14883 Typ := Entity (Name);
14886 or else Rep_Item_Too_Early (Typ, N)
14890 Typ := Underlying_Type (Typ);
14893 if not Is_Record_Type (Typ)
14894 and then not Is_Array_Type (Typ)
14897 ("Name parameter of pragma% must identify record or "
14898 & "array type", Name);
14901 -- An explicit Component_Alignment pragma overrides an
14902 -- implicit pragma Pack, but not an explicit one.
14904 if not Has_Pragma_Pack (Base_Type (Typ)) then
14905 Set_Is_Packed (Base_Type (Typ), False);
14906 Set_Component_Alignment (Base_Type (Typ), Atype);
14909 end Component_AlignmentP;
14911 --------------------------------
14912 -- Constant_After_Elaboration --
14913 --------------------------------
14915 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
14917 when Pragma_Constant_After_Elaboration => Constant_After_Elaboration :
14919 Obj_Decl : Node_Id;
14920 Obj_Id : Entity_Id;
14924 Check_No_Identifiers;
14925 Check_At_Most_N_Arguments (1);
14927 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
14929 if Nkind (Obj_Decl) /= N_Object_Declaration then
14934 Obj_Id := Defining_Entity (Obj_Decl);
14936 -- The object declaration must be a library-level variable which
14937 -- is either explicitly initialized or obtains a value during the
14938 -- elaboration of a package body (SPARK RM 3.3.1).
14940 if Ekind (Obj_Id) = E_Variable then
14941 if not Is_Library_Level_Entity (Obj_Id) then
14943 ("pragma % must apply to a library level variable");
14947 -- Otherwise the pragma applies to a constant, which is illegal
14950 Error_Pragma ("pragma % must apply to a variable declaration");
14954 -- A pragma that applies to a Ghost entity becomes Ghost for the
14955 -- purposes of legality checks and removal of ignored Ghost code.
14957 Mark_Ghost_Pragma (N, Obj_Id);
14959 -- Chain the pragma on the contract for completeness
14961 Add_Contract_Item (N, Obj_Id);
14963 -- Analyze the Boolean expression (if any)
14965 if Present (Arg1) then
14966 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
14968 end Constant_After_Elaboration;
14970 --------------------
14971 -- Contract_Cases --
14972 --------------------
14974 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
14976 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
14978 -- CASE_GUARD ::= boolean_EXPRESSION | others
14980 -- CONSEQUENCE ::= boolean_EXPRESSION
14982 -- Characteristics:
14984 -- * Analysis - The annotation undergoes initial checks to verify
14985 -- the legal placement and context. Secondary checks preanalyze the
14988 -- Analyze_Contract_Cases_In_Decl_Part
14990 -- * Expansion - The annotation is expanded during the expansion of
14991 -- the related subprogram [body] contract as performed in:
14993 -- Expand_Subprogram_Contract
14995 -- * Template - The annotation utilizes the generic template of the
14996 -- related subprogram [body] when it is:
14998 -- aspect on subprogram declaration
14999 -- aspect on stand-alone subprogram body
15000 -- pragma on stand-alone subprogram body
15002 -- The annotation must prepare its own template when it is:
15004 -- pragma on subprogram declaration
15006 -- * Globals - Capture of global references must occur after full
15009 -- * Instance - The annotation is instantiated automatically when
15010 -- the related generic subprogram [body] is instantiated except for
15011 -- the "pragma on subprogram declaration" case. In that scenario
15012 -- the annotation must instantiate itself.
15014 when Pragma_Contract_Cases => Contract_Cases : declare
15015 Spec_Id : Entity_Id;
15016 Subp_Decl : Node_Id;
15017 Subp_Spec : Node_Id;
15021 Check_No_Identifiers;
15022 Check_Arg_Count (1);
15024 -- Ensure the proper placement of the pragma. Contract_Cases must
15025 -- be associated with a subprogram declaration or a body that acts
15029 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
15033 if Nkind (Subp_Decl) = N_Entry_Declaration then
15036 -- Generic subprogram
15038 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
15041 -- Body acts as spec
15043 elsif Nkind (Subp_Decl) = N_Subprogram_Body
15044 and then No (Corresponding_Spec (Subp_Decl))
15048 -- Body stub acts as spec
15050 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
15051 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
15057 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
15058 Subp_Spec := Specification (Subp_Decl);
15060 -- Pragma Contract_Cases is forbidden on null procedures, as
15061 -- this may lead to potential ambiguities in behavior when
15062 -- interface null procedures are involved.
15064 if Nkind (Subp_Spec) = N_Procedure_Specification
15065 and then Null_Present (Subp_Spec)
15067 Error_Msg_N (Fix_Error
15068 ("pragma % cannot apply to null procedure"), N);
15077 Spec_Id := Unique_Defining_Entity (Subp_Decl);
15079 -- A pragma that applies to a Ghost entity becomes Ghost for the
15080 -- purposes of legality checks and removal of ignored Ghost code.
15082 Mark_Ghost_Pragma (N, Spec_Id);
15083 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
15085 -- Chain the pragma on the contract for further processing by
15086 -- Analyze_Contract_Cases_In_Decl_Part.
15088 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
15090 -- Fully analyze the pragma when it appears inside an entry
15091 -- or subprogram body because it cannot benefit from forward
15094 if Nkind_In (Subp_Decl, N_Entry_Body,
15096 N_Subprogram_Body_Stub)
15098 -- The legality checks of pragma Contract_Cases are affected by
15099 -- the SPARK mode in effect and the volatility of the context.
15100 -- Analyze all pragmas in a specific order.
15102 Analyze_If_Present (Pragma_SPARK_Mode);
15103 Analyze_If_Present (Pragma_Volatile_Function);
15104 Analyze_Contract_Cases_In_Decl_Part (N);
15106 end Contract_Cases;
15112 -- pragma Controlled (first_subtype_LOCAL_NAME);
15114 when Pragma_Controlled => Controlled : declare
15118 Check_No_Identifiers;
15119 Check_Arg_Count (1);
15120 Check_Arg_Is_Local_Name (Arg1);
15121 Arg := Get_Pragma_Arg (Arg1);
15123 if not Is_Entity_Name (Arg)
15124 or else not Is_Access_Type (Entity (Arg))
15126 Error_Pragma_Arg ("pragma% requires access type", Arg1);
15128 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
15136 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
15137 -- [Entity =>] LOCAL_NAME);
15139 when Pragma_Convention => Convention : declare
15142 pragma Warnings (Off, C);
15143 pragma Warnings (Off, E);
15146 Check_Arg_Order ((Name_Convention, Name_Entity));
15147 Check_Ada_83_Warning;
15148 Check_Arg_Count (2);
15149 Process_Convention (C, E);
15151 -- A pragma that applies to a Ghost entity becomes Ghost for the
15152 -- purposes of legality checks and removal of ignored Ghost code.
15154 Mark_Ghost_Pragma (N, E);
15157 ---------------------------
15158 -- Convention_Identifier --
15159 ---------------------------
15161 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
15162 -- [Convention =>] convention_IDENTIFIER);
15164 when Pragma_Convention_Identifier => Convention_Identifier : declare
15170 Check_Arg_Order ((Name_Name, Name_Convention));
15171 Check_Arg_Count (2);
15172 Check_Optional_Identifier (Arg1, Name_Name);
15173 Check_Optional_Identifier (Arg2, Name_Convention);
15174 Check_Arg_Is_Identifier (Arg1);
15175 Check_Arg_Is_Identifier (Arg2);
15176 Idnam := Chars (Get_Pragma_Arg (Arg1));
15177 Cname := Chars (Get_Pragma_Arg (Arg2));
15179 if Is_Convention_Name (Cname) then
15180 Record_Convention_Identifier
15181 (Idnam, Get_Convention_Id (Cname));
15184 ("second arg for % pragma must be convention", Arg2);
15186 end Convention_Identifier;
15192 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
15194 when Pragma_CPP_Class =>
15197 if Warn_On_Obsolescent_Feature then
15199 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
15200 & "effect; replace it by pragma import?j?", N);
15203 Check_Arg_Count (1);
15207 Chars => Name_Import,
15208 Pragma_Argument_Associations => New_List (
15209 Make_Pragma_Argument_Association (Loc,
15210 Expression => Make_Identifier (Loc, Name_CPP)),
15211 New_Copy (First (Pragma_Argument_Associations (N))))));
15214 ---------------------
15215 -- CPP_Constructor --
15216 ---------------------
15218 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
15219 -- [, [External_Name =>] static_string_EXPRESSION ]
15220 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15222 when Pragma_CPP_Constructor => CPP_Constructor : declare
15225 Def_Id : Entity_Id;
15226 Tag_Typ : Entity_Id;
15230 Check_At_Least_N_Arguments (1);
15231 Check_At_Most_N_Arguments (3);
15232 Check_Optional_Identifier (Arg1, Name_Entity);
15233 Check_Arg_Is_Local_Name (Arg1);
15235 Id := Get_Pragma_Arg (Arg1);
15236 Find_Program_Unit_Name (Id);
15238 -- If we did not find the name, we are done
15240 if Etype (Id) = Any_Type then
15244 Def_Id := Entity (Id);
15246 -- Check if already defined as constructor
15248 if Is_Constructor (Def_Id) then
15250 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
15254 if Ekind (Def_Id) = E_Function
15255 and then (Is_CPP_Class (Etype (Def_Id))
15256 or else (Is_Class_Wide_Type (Etype (Def_Id))
15258 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
15260 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
15262 ("'C'P'P constructor must be defined in the scope of "
15263 & "its returned type", Arg1);
15266 if Arg_Count >= 2 then
15267 Set_Imported (Def_Id);
15268 Set_Is_Public (Def_Id);
15269 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
15272 Set_Has_Completion (Def_Id);
15273 Set_Is_Constructor (Def_Id);
15274 Set_Convention (Def_Id, Convention_CPP);
15276 -- Imported C++ constructors are not dispatching primitives
15277 -- because in C++ they don't have a dispatch table slot.
15278 -- However, in Ada the constructor has the profile of a
15279 -- function that returns a tagged type and therefore it has
15280 -- been treated as a primitive operation during semantic
15281 -- analysis. We now remove it from the list of primitive
15282 -- operations of the type.
15284 if Is_Tagged_Type (Etype (Def_Id))
15285 and then not Is_Class_Wide_Type (Etype (Def_Id))
15286 and then Is_Dispatching_Operation (Def_Id)
15288 Tag_Typ := Etype (Def_Id);
15290 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
15291 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
15295 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
15296 Set_Is_Dispatching_Operation (Def_Id, False);
15299 -- For backward compatibility, if the constructor returns a
15300 -- class wide type, and we internally change the return type to
15301 -- the corresponding root type.
15303 if Is_Class_Wide_Type (Etype (Def_Id)) then
15304 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
15308 ("pragma% requires function returning a 'C'P'P_Class type",
15311 end CPP_Constructor;
15317 when Pragma_CPP_Virtual =>
15320 if Warn_On_Obsolescent_Feature then
15322 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
15330 when Pragma_CPP_Vtable =>
15333 if Warn_On_Obsolescent_Feature then
15335 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
15343 -- pragma CPU (EXPRESSION);
15345 when Pragma_CPU => CPU : declare
15346 P : constant Node_Id := Parent (N);
15352 Check_No_Identifiers;
15353 Check_Arg_Count (1);
15357 if Nkind (P) = N_Subprogram_Body then
15358 Check_In_Main_Program;
15360 Arg := Get_Pragma_Arg (Arg1);
15361 Analyze_And_Resolve (Arg, Any_Integer);
15363 Ent := Defining_Unit_Name (Specification (P));
15365 if Nkind (Ent) = N_Defining_Program_Unit_Name then
15366 Ent := Defining_Identifier (Ent);
15371 if not Is_OK_Static_Expression (Arg) then
15372 Flag_Non_Static_Expr
15373 ("main subprogram affinity is not static!", Arg);
15376 -- If constraint error, then we already signalled an error
15378 elsif Raises_Constraint_Error (Arg) then
15381 -- Otherwise check in range
15385 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
15386 -- This is the entity System.Multiprocessors.CPU_Range;
15388 Val : constant Uint := Expr_Value (Arg);
15391 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
15393 Val > Expr_Value (Type_High_Bound (CPU_Id))
15396 ("main subprogram CPU is out of range", Arg1);
15402 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
15406 elsif Nkind (P) = N_Task_Definition then
15407 Arg := Get_Pragma_Arg (Arg1);
15408 Ent := Defining_Identifier (Parent (P));
15410 -- The expression must be analyzed in the special manner
15411 -- described in "Handling of Default and Per-Object
15412 -- Expressions" in sem.ads.
15414 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
15416 -- Anything else is incorrect
15422 -- Check duplicate pragma before we chain the pragma in the Rep
15423 -- Item chain of Ent.
15425 Check_Duplicate_Pragma (Ent);
15426 Record_Rep_Item (Ent, N);
15429 --------------------
15430 -- Deadline_Floor --
15431 --------------------
15433 -- pragma Deadline_Floor (time_span_EXPRESSION);
15435 when Pragma_Deadline_Floor => Deadline_Floor : declare
15436 P : constant Node_Id := Parent (N);
15442 Check_No_Identifiers;
15443 Check_Arg_Count (1);
15445 Arg := Get_Pragma_Arg (Arg1);
15447 -- The expression must be analyzed in the special manner described
15448 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
15450 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
15452 -- Only protected types allowed
15454 if Nkind (P) /= N_Protected_Definition then
15458 Ent := Defining_Identifier (Parent (P));
15460 -- Check duplicate pragma before we chain the pragma in the Rep
15461 -- Item chain of Ent.
15463 Check_Duplicate_Pragma (Ent);
15464 Record_Rep_Item (Ent, N);
15466 end Deadline_Floor;
15472 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
15474 when Pragma_Debug => Debug : declare
15481 -- The condition for executing the call is that the expander
15482 -- is active and that we are not ignoring this debug pragma.
15487 (Expander_Active and then not Is_Ignored (N)),
15490 if not Is_Ignored (N) then
15491 Set_SCO_Pragma_Enabled (Loc);
15494 if Arg_Count = 2 then
15496 Make_And_Then (Loc,
15497 Left_Opnd => Relocate_Node (Cond),
15498 Right_Opnd => Get_Pragma_Arg (Arg1));
15499 Call := Get_Pragma_Arg (Arg2);
15501 Call := Get_Pragma_Arg (Arg1);
15504 if Nkind_In (Call, N_Expanded_Name,
15507 N_Indexed_Component,
15508 N_Selected_Component)
15510 -- If this pragma Debug comes from source, its argument was
15511 -- parsed as a name form (which is syntactically identical).
15512 -- In a generic context a parameterless call will be left as
15513 -- an expanded name (if global) or selected_component if local.
15514 -- Change it to a procedure call statement now.
15516 Change_Name_To_Procedure_Call_Statement (Call);
15518 elsif Nkind (Call) = N_Procedure_Call_Statement then
15520 -- Already in the form of a procedure call statement: nothing
15521 -- to do (could happen in case of an internally generated
15527 -- All other cases: diagnose error
15530 ("argument of pragma ""Debug"" is not procedure call",
15535 -- Rewrite into a conditional with an appropriate condition. We
15536 -- wrap the procedure call in a block so that overhead from e.g.
15537 -- use of the secondary stack does not generate execution overhead
15538 -- for suppressed conditions.
15540 -- Normally the analysis that follows will freeze the subprogram
15541 -- being called. However, if the call is to a null procedure,
15542 -- we want to freeze it before creating the block, because the
15543 -- analysis that follows may be done with expansion disabled, in
15544 -- which case the body will not be generated, leading to spurious
15547 if Nkind (Call) = N_Procedure_Call_Statement
15548 and then Is_Entity_Name (Name (Call))
15550 Analyze (Name (Call));
15551 Freeze_Before (N, Entity (Name (Call)));
15555 Make_Implicit_If_Statement (N,
15557 Then_Statements => New_List (
15558 Make_Block_Statement (Loc,
15559 Handled_Statement_Sequence =>
15560 Make_Handled_Sequence_Of_Statements (Loc,
15561 Statements => New_List (Relocate_Node (Call)))))));
15564 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
15565 -- after analysis of the normally rewritten node, to capture all
15566 -- references to entities, which avoids issuing wrong warnings
15567 -- about unused entities.
15569 if GNATprove_Mode then
15570 Rewrite (N, Make_Null_Statement (Loc));
15578 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
15580 when Pragma_Debug_Policy =>
15582 Check_Arg_Count (1);
15583 Check_No_Identifiers;
15584 Check_Arg_Is_Identifier (Arg1);
15586 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
15587 -- rewrite it that way, and let the rest of the checking come
15588 -- from analyzing the rewritten pragma.
15592 Chars => Name_Check_Policy,
15593 Pragma_Argument_Associations => New_List (
15594 Make_Pragma_Argument_Association (Loc,
15595 Expression => Make_Identifier (Loc, Name_Debug)),
15597 Make_Pragma_Argument_Association (Loc,
15598 Expression => Get_Pragma_Arg (Arg1)))));
15601 -------------------------------
15602 -- Default_Initial_Condition --
15603 -------------------------------
15605 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
15607 when Pragma_Default_Initial_Condition => DIC : declare
15614 Check_No_Identifiers;
15615 Check_At_Most_N_Arguments (1);
15619 while Present (Stmt) loop
15621 -- Skip prior pragmas, but check for duplicates
15623 if Nkind (Stmt) = N_Pragma then
15624 if Pragma_Name (Stmt) = Pname then
15631 -- Skip internally generated code. Note that derived type
15632 -- declarations of untagged types with discriminants are
15633 -- rewritten as private type declarations.
15635 elsif not Comes_From_Source (Stmt)
15636 and then Nkind (Stmt) /= N_Private_Type_Declaration
15640 -- The associated private type [extension] has been found, stop
15643 elsif Nkind_In (Stmt, N_Private_Extension_Declaration,
15644 N_Private_Type_Declaration)
15646 Typ := Defining_Entity (Stmt);
15649 -- The pragma does not apply to a legal construct, issue an
15650 -- error and stop the analysis.
15657 Stmt := Prev (Stmt);
15660 -- The pragma does not apply to a legal construct, issue an error
15661 -- and stop the analysis.
15668 -- A pragma that applies to a Ghost entity becomes Ghost for the
15669 -- purposes of legality checks and removal of ignored Ghost code.
15671 Mark_Ghost_Pragma (N, Typ);
15673 -- The pragma signals that the type defines its own DIC assertion
15676 Set_Has_Own_DIC (Typ);
15678 -- Chain the pragma on the rep item chain for further processing
15680 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
15682 -- Create the declaration of the procedure which verifies the
15683 -- assertion expression of pragma DIC at runtime.
15685 Build_DIC_Procedure_Declaration (Typ);
15688 ----------------------------------
15689 -- Default_Scalar_Storage_Order --
15690 ----------------------------------
15692 -- pragma Default_Scalar_Storage_Order
15693 -- (High_Order_First | Low_Order_First);
15695 when Pragma_Default_Scalar_Storage_Order => DSSO : declare
15696 Default : Character;
15700 Check_Arg_Count (1);
15702 -- Default_Scalar_Storage_Order can appear as a configuration
15703 -- pragma, or in a declarative part of a package spec.
15705 if not Is_Configuration_Pragma then
15706 Check_Is_In_Decl_Part_Or_Package_Spec;
15709 Check_No_Identifiers;
15710 Check_Arg_Is_One_Of
15711 (Arg1, Name_High_Order_First, Name_Low_Order_First);
15712 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
15713 Default := Fold_Upper (Name_Buffer (1));
15715 if not Support_Nondefault_SSO_On_Target
15716 and then (Ttypes.Bytes_Big_Endian /= (Default = 'H'))
15718 if Warn_On_Unrecognized_Pragma then
15720 ("non-default Scalar_Storage_Order not supported "
15721 & "on target?g?", N);
15723 ("\pragma Default_Scalar_Storage_Order ignored?g?", N);
15726 -- Here set the specified default
15729 Opt.Default_SSO := Default;
15733 --------------------------
15734 -- Default_Storage_Pool --
15735 --------------------------
15737 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
15739 when Pragma_Default_Storage_Pool => Default_Storage_Pool : declare
15744 Check_Arg_Count (1);
15746 -- Default_Storage_Pool can appear as a configuration pragma, or
15747 -- in a declarative part of a package spec.
15749 if not Is_Configuration_Pragma then
15750 Check_Is_In_Decl_Part_Or_Package_Spec;
15753 if From_Aspect_Specification (N) then
15755 E : constant Entity_Id := Entity (Corresponding_Aspect (N));
15757 if not In_Open_Scopes (E) then
15759 ("aspect must apply to package or subprogram", N);
15764 if Present (Arg1) then
15765 Pool := Get_Pragma_Arg (Arg1);
15767 -- Case of Default_Storage_Pool (null);
15769 if Nkind (Pool) = N_Null then
15772 -- This is an odd case, this is not really an expression,
15773 -- so we don't have a type for it. So just set the type to
15776 Set_Etype (Pool, Empty);
15778 -- Case of Default_Storage_Pool (storage_pool_NAME);
15781 -- If it's a configuration pragma, then the only allowed
15782 -- argument is "null".
15784 if Is_Configuration_Pragma then
15785 Error_Pragma_Arg ("NULL expected", Arg1);
15788 -- The expected type for a non-"null" argument is
15789 -- Root_Storage_Pool'Class, and the pool must be a variable.
15791 Analyze_And_Resolve
15792 (Pool, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
15794 if Is_Variable (Pool) then
15796 -- A pragma that applies to a Ghost entity becomes Ghost
15797 -- for the purposes of legality checks and removal of
15798 -- ignored Ghost code.
15800 Mark_Ghost_Pragma (N, Entity (Pool));
15804 ("default storage pool must be a variable", Arg1);
15808 -- Record the pool name (or null). Freeze.Freeze_Entity for an
15809 -- access type will use this information to set the appropriate
15810 -- attributes of the access type. If the pragma appears in a
15811 -- generic unit it is ignored, given that it may refer to a
15814 if not Inside_A_Generic then
15815 Default_Pool := Pool;
15818 end Default_Storage_Pool;
15824 -- pragma Depends (DEPENDENCY_RELATION);
15826 -- DEPENDENCY_RELATION ::=
15828 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
15830 -- DEPENDENCY_CLAUSE ::=
15831 -- OUTPUT_LIST =>[+] INPUT_LIST
15832 -- | NULL_DEPENDENCY_CLAUSE
15834 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
15836 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
15838 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
15840 -- OUTPUT ::= NAME | FUNCTION_RESULT
15843 -- where FUNCTION_RESULT is a function Result attribute_reference
15845 -- Characteristics:
15847 -- * Analysis - The annotation undergoes initial checks to verify
15848 -- the legal placement and context. Secondary checks fully analyze
15849 -- the dependency clauses in:
15851 -- Analyze_Depends_In_Decl_Part
15853 -- * Expansion - None.
15855 -- * Template - The annotation utilizes the generic template of the
15856 -- related subprogram [body] when it is:
15858 -- aspect on subprogram declaration
15859 -- aspect on stand-alone subprogram body
15860 -- pragma on stand-alone subprogram body
15862 -- The annotation must prepare its own template when it is:
15864 -- pragma on subprogram declaration
15866 -- * Globals - Capture of global references must occur after full
15869 -- * Instance - The annotation is instantiated automatically when
15870 -- the related generic subprogram [body] is instantiated except for
15871 -- the "pragma on subprogram declaration" case. In that scenario
15872 -- the annotation must instantiate itself.
15874 when Pragma_Depends => Depends : declare
15876 Spec_Id : Entity_Id;
15877 Subp_Decl : Node_Id;
15880 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
15884 -- Chain the pragma on the contract for further processing by
15885 -- Analyze_Depends_In_Decl_Part.
15887 Add_Contract_Item (N, Spec_Id);
15889 -- Fully analyze the pragma when it appears inside an entry
15890 -- or subprogram body because it cannot benefit from forward
15893 if Nkind_In (Subp_Decl, N_Entry_Body,
15895 N_Subprogram_Body_Stub)
15897 -- The legality checks of pragmas Depends and Global are
15898 -- affected by the SPARK mode in effect and the volatility
15899 -- of the context. In addition these two pragmas are subject
15900 -- to an inherent order:
15905 -- Analyze all these pragmas in the order outlined above
15907 Analyze_If_Present (Pragma_SPARK_Mode);
15908 Analyze_If_Present (Pragma_Volatile_Function);
15909 Analyze_If_Present (Pragma_Global);
15910 Analyze_Depends_In_Decl_Part (N);
15915 ---------------------
15916 -- Detect_Blocking --
15917 ---------------------
15919 -- pragma Detect_Blocking;
15921 when Pragma_Detect_Blocking =>
15923 Check_Arg_Count (0);
15924 Check_Valid_Configuration_Pragma;
15925 Detect_Blocking := True;
15927 ------------------------------------
15928 -- Disable_Atomic_Synchronization --
15929 ------------------------------------
15931 -- pragma Disable_Atomic_Synchronization [(Entity)];
15933 when Pragma_Disable_Atomic_Synchronization =>
15935 Process_Disable_Enable_Atomic_Sync (Name_Suppress);
15937 -------------------
15938 -- Discard_Names --
15939 -------------------
15941 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
15943 when Pragma_Discard_Names => Discard_Names : declare
15948 Check_Ada_83_Warning;
15950 -- Deal with configuration pragma case
15952 if Arg_Count = 0 and then Is_Configuration_Pragma then
15953 Global_Discard_Names := True;
15956 -- Otherwise, check correct appropriate context
15959 Check_Is_In_Decl_Part_Or_Package_Spec;
15961 if Arg_Count = 0 then
15963 -- If there is no parameter, then from now on this pragma
15964 -- applies to any enumeration, exception or tagged type
15965 -- defined in the current declarative part, and recursively
15966 -- to any nested scope.
15968 Set_Discard_Names (Current_Scope);
15972 Check_Arg_Count (1);
15973 Check_Optional_Identifier (Arg1, Name_On);
15974 Check_Arg_Is_Local_Name (Arg1);
15976 E_Id := Get_Pragma_Arg (Arg1);
15978 if Etype (E_Id) = Any_Type then
15982 E := Entity (E_Id);
15984 -- A pragma that applies to a Ghost entity becomes Ghost for
15985 -- the purposes of legality checks and removal of ignored
15988 Mark_Ghost_Pragma (N, E);
15990 if (Is_First_Subtype (E)
15992 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
15993 or else Ekind (E) = E_Exception
15995 Set_Discard_Names (E);
15996 Record_Rep_Item (E, N);
16000 ("inappropriate entity for pragma%", Arg1);
16006 ------------------------
16007 -- Dispatching_Domain --
16008 ------------------------
16010 -- pragma Dispatching_Domain (EXPRESSION);
16012 when Pragma_Dispatching_Domain => Dispatching_Domain : declare
16013 P : constant Node_Id := Parent (N);
16019 Check_No_Identifiers;
16020 Check_Arg_Count (1);
16022 -- This pragma is born obsolete, but not the aspect
16024 if not From_Aspect_Specification (N) then
16026 (No_Obsolescent_Features, Pragma_Identifier (N));
16029 if Nkind (P) = N_Task_Definition then
16030 Arg := Get_Pragma_Arg (Arg1);
16031 Ent := Defining_Identifier (Parent (P));
16033 -- A pragma that applies to a Ghost entity becomes Ghost for
16034 -- the purposes of legality checks and removal of ignored Ghost
16037 Mark_Ghost_Pragma (N, Ent);
16039 -- The expression must be analyzed in the special manner
16040 -- described in "Handling of Default and Per-Object
16041 -- Expressions" in sem.ads.
16043 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
16045 -- Check duplicate pragma before we chain the pragma in the Rep
16046 -- Item chain of Ent.
16048 Check_Duplicate_Pragma (Ent);
16049 Record_Rep_Item (Ent, N);
16051 -- Anything else is incorrect
16056 end Dispatching_Domain;
16062 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
16064 when Pragma_Elaborate => Elaborate : declare
16069 -- Pragma must be in context items list of a compilation unit
16071 if not Is_In_Context_Clause then
16075 -- Must be at least one argument
16077 if Arg_Count = 0 then
16078 Error_Pragma ("pragma% requires at least one argument");
16081 -- In Ada 83 mode, there can be no items following it in the
16082 -- context list except other pragmas and implicit with clauses
16083 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
16084 -- placement rule does not apply.
16086 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
16088 while Present (Citem) loop
16089 if Nkind (Citem) = N_Pragma
16090 or else (Nkind (Citem) = N_With_Clause
16091 and then Implicit_With (Citem))
16096 ("(Ada 83) pragma% must be at end of context clause");
16103 -- Finally, the arguments must all be units mentioned in a with
16104 -- clause in the same context clause. Note we already checked (in
16105 -- Par.Prag) that the arguments are all identifiers or selected
16109 Outer : while Present (Arg) loop
16110 Citem := First (List_Containing (N));
16111 Inner : while Citem /= N loop
16112 if Nkind (Citem) = N_With_Clause
16113 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
16115 Set_Elaborate_Present (Citem, True);
16116 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
16118 -- With the pragma present, elaboration calls on
16119 -- subprograms from the named unit need no further
16120 -- checks, as long as the pragma appears in the current
16121 -- compilation unit. If the pragma appears in some unit
16122 -- in the context, there might still be a need for an
16123 -- Elaborate_All_Desirable from the current compilation
16124 -- to the named unit, so we keep the check enabled. This
16125 -- does not apply in SPARK mode, where we allow pragma
16126 -- Elaborate, but we don't trust it to be right so we
16127 -- will still insist on the Elaborate_All.
16129 if Legacy_Elaboration_Checks
16130 and then In_Extended_Main_Source_Unit (N)
16131 and then SPARK_Mode /= On
16133 Set_Suppress_Elaboration_Warnings
16134 (Entity (Name (Citem)));
16145 ("argument of pragma% is not withed unit", Arg);
16152 -------------------
16153 -- Elaborate_All --
16154 -------------------
16156 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
16158 when Pragma_Elaborate_All => Elaborate_All : declare
16163 Check_Ada_83_Warning;
16165 -- Pragma must be in context items list of a compilation unit
16167 if not Is_In_Context_Clause then
16171 -- Must be at least one argument
16173 if Arg_Count = 0 then
16174 Error_Pragma ("pragma% requires at least one argument");
16177 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
16178 -- have to appear at the end of the context clause, but may
16179 -- appear mixed in with other items, even in Ada 83 mode.
16181 -- Final check: the arguments must all be units mentioned in
16182 -- a with clause in the same context clause. Note that we
16183 -- already checked (in Par.Prag) that all the arguments are
16184 -- either identifiers or selected components.
16187 Outr : while Present (Arg) loop
16188 Citem := First (List_Containing (N));
16189 Innr : while Citem /= N loop
16190 if Nkind (Citem) = N_With_Clause
16191 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
16193 Set_Elaborate_All_Present (Citem, True);
16194 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
16196 -- Suppress warnings and elaboration checks on the named
16197 -- unit if the pragma is in the current compilation, as
16198 -- for pragma Elaborate.
16200 if Legacy_Elaboration_Checks
16201 and then In_Extended_Main_Source_Unit (N)
16203 Set_Suppress_Elaboration_Warnings
16204 (Entity (Name (Citem)));
16214 Set_Error_Posted (N);
16216 ("argument of pragma% is not withed unit", Arg);
16223 --------------------
16224 -- Elaborate_Body --
16225 --------------------
16227 -- pragma Elaborate_Body [( library_unit_NAME )];
16229 when Pragma_Elaborate_Body => Elaborate_Body : declare
16230 Cunit_Node : Node_Id;
16231 Cunit_Ent : Entity_Id;
16234 Check_Ada_83_Warning;
16235 Check_Valid_Library_Unit_Pragma;
16237 if Nkind (N) = N_Null_Statement then
16241 Cunit_Node := Cunit (Current_Sem_Unit);
16242 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
16244 -- A pragma that applies to a Ghost entity becomes Ghost for the
16245 -- purposes of legality checks and removal of ignored Ghost code.
16247 Mark_Ghost_Pragma (N, Cunit_Ent);
16249 if Nkind_In (Unit (Cunit_Node), N_Package_Body,
16252 Error_Pragma ("pragma% must refer to a spec, not a body");
16254 Set_Body_Required (Cunit_Node);
16255 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
16257 -- If we are in dynamic elaboration mode, then we suppress
16258 -- elaboration warnings for the unit, since it is definitely
16259 -- fine NOT to do dynamic checks at the first level (and such
16260 -- checks will be suppressed because no elaboration boolean
16261 -- is created for Elaborate_Body packages).
16263 -- But in the static model of elaboration, Elaborate_Body is
16264 -- definitely NOT good enough to ensure elaboration safety on
16265 -- its own, since the body may WITH other units that are not
16266 -- safe from an elaboration point of view, so a client must
16267 -- still do an Elaborate_All on such units.
16269 -- Debug flag -gnatdD restores the old behavior of 3.13, where
16270 -- Elaborate_Body always suppressed elab warnings.
16272 if Legacy_Elaboration_Checks
16273 and then (Dynamic_Elaboration_Checks or Debug_Flag_DD)
16275 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
16278 end Elaborate_Body;
16280 ------------------------
16281 -- Elaboration_Checks --
16282 ------------------------
16284 -- pragma Elaboration_Checks (Static | Dynamic);
16286 when Pragma_Elaboration_Checks => Elaboration_Checks : declare
16287 procedure Check_Duplicate_Elaboration_Checks_Pragma;
16288 -- Emit an error if the current context list already contains
16289 -- a previous Elaboration_Checks pragma. This routine raises
16290 -- Pragma_Exit if a duplicate is found.
16292 procedure Ignore_Elaboration_Checks_Pragma;
16293 -- Warn that the effects of the pragma are ignored. This routine
16294 -- raises Pragma_Exit.
16296 -----------------------------------------------
16297 -- Check_Duplicate_Elaboration_Checks_Pragma --
16298 -----------------------------------------------
16300 procedure Check_Duplicate_Elaboration_Checks_Pragma is
16305 while Present (Item) loop
16306 if Nkind (Item) = N_Pragma
16307 and then Pragma_Name (Item) = Name_Elaboration_Checks
16317 end Check_Duplicate_Elaboration_Checks_Pragma;
16319 --------------------------------------
16320 -- Ignore_Elaboration_Checks_Pragma --
16321 --------------------------------------
16323 procedure Ignore_Elaboration_Checks_Pragma is
16325 Error_Msg_Name_1 := Pname;
16326 Error_Msg_N ("??effects of pragma % are ignored", N);
16328 ("\place pragma on initial declaration of library unit", N);
16331 end Ignore_Elaboration_Checks_Pragma;
16335 Context : constant Node_Id := Parent (N);
16338 -- Start of processing for Elaboration_Checks
16342 Check_Arg_Count (1);
16343 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
16345 -- The pragma appears in a configuration file
16347 if No (Context) then
16348 Check_Valid_Configuration_Pragma;
16349 Check_Duplicate_Elaboration_Checks_Pragma;
16351 -- The pragma acts as a configuration pragma in a compilation unit
16353 -- pragma Elaboration_Checks (...);
16354 -- package Pack is ...;
16356 elsif Nkind (Context) = N_Compilation_Unit
16357 and then List_Containing (N) = Context_Items (Context)
16359 Check_Valid_Configuration_Pragma;
16360 Check_Duplicate_Elaboration_Checks_Pragma;
16362 Unt := Unit (Context);
16364 -- The pragma must appear on the initial declaration of a unit.
16365 -- If this is not the case, warn that the effects of the pragma
16368 if Nkind (Unt) = N_Package_Body then
16369 Ignore_Elaboration_Checks_Pragma;
16371 -- Check the Acts_As_Spec flag of the compilation units itself
16372 -- to determine whether the subprogram body completes since it
16373 -- has not been analyzed yet. This is safe because compilation
16374 -- units are not overloadable.
16376 elsif Nkind (Unt) = N_Subprogram_Body
16377 and then not Acts_As_Spec (Context)
16379 Ignore_Elaboration_Checks_Pragma;
16381 elsif Nkind (Unt) = N_Subunit then
16382 Ignore_Elaboration_Checks_Pragma;
16385 -- Otherwise the pragma does not appear at the configuration level
16392 -- At this point the pragma is not a duplicate, and appears in the
16393 -- proper context. Set the elaboration model in effect.
16395 Dynamic_Elaboration_Checks :=
16396 Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic;
16397 end Elaboration_Checks;
16403 -- pragma Eliminate (
16404 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
16405 -- [Entity =>] IDENTIFIER |
16406 -- SELECTED_COMPONENT |
16408 -- [, Source_Location => SOURCE_TRACE]);
16410 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
16411 -- SOURCE_TRACE ::= STRING_LITERAL
16413 when Pragma_Eliminate => Eliminate : declare
16414 Args : Args_List (1 .. 5);
16415 Names : constant Name_List (1 .. 5) := (
16418 Name_Parameter_Types,
16420 Name_Source_Location);
16422 -- Note : Parameter_Types and Result_Type are leftovers from
16423 -- prior implementations of the pragma. They are not generated
16424 -- by the gnatelim tool, and play no role in selecting which
16425 -- of a set of overloaded names is chosen for elimination.
16427 Unit_Name : Node_Id renames Args (1);
16428 Entity : Node_Id renames Args (2);
16429 Parameter_Types : Node_Id renames Args (3);
16430 Result_Type : Node_Id renames Args (4);
16431 Source_Location : Node_Id renames Args (5);
16435 Check_Valid_Configuration_Pragma;
16436 Gather_Associations (Names, Args);
16438 if No (Unit_Name) then
16439 Error_Pragma ("missing Unit_Name argument for pragma%");
16443 and then (Present (Parameter_Types)
16445 Present (Result_Type)
16447 Present (Source_Location))
16449 Error_Pragma ("missing Entity argument for pragma%");
16452 if (Present (Parameter_Types)
16454 Present (Result_Type))
16456 Present (Source_Location)
16459 ("parameter profile and source location cannot be used "
16460 & "together in pragma%");
16463 Process_Eliminate_Pragma
16472 -----------------------------------
16473 -- Enable_Atomic_Synchronization --
16474 -----------------------------------
16476 -- pragma Enable_Atomic_Synchronization [(Entity)];
16478 when Pragma_Enable_Atomic_Synchronization =>
16480 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
16487 -- [ Convention =>] convention_IDENTIFIER,
16488 -- [ Entity =>] LOCAL_NAME
16489 -- [, [External_Name =>] static_string_EXPRESSION ]
16490 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16492 when Pragma_Export => Export : declare
16494 Def_Id : Entity_Id;
16496 pragma Warnings (Off, C);
16499 Check_Ada_83_Warning;
16503 Name_External_Name,
16506 Check_At_Least_N_Arguments (2);
16507 Check_At_Most_N_Arguments (4);
16509 -- In Relaxed_RM_Semantics, support old Ada 83 style:
16510 -- pragma Export (Entity, "external name");
16512 if Relaxed_RM_Semantics
16513 and then Arg_Count = 2
16514 and then Nkind (Expression (Arg2)) = N_String_Literal
16517 Def_Id := Get_Pragma_Arg (Arg1);
16520 if not Is_Entity_Name (Def_Id) then
16521 Error_Pragma_Arg ("entity name required", Arg1);
16524 Def_Id := Entity (Def_Id);
16525 Set_Exported (Def_Id, Arg1);
16528 Process_Convention (C, Def_Id);
16530 -- A pragma that applies to a Ghost entity becomes Ghost for
16531 -- the purposes of legality checks and removal of ignored Ghost
16534 Mark_Ghost_Pragma (N, Def_Id);
16536 if Ekind (Def_Id) /= E_Constant then
16537 Note_Possible_Modification
16538 (Get_Pragma_Arg (Arg2), Sure => False);
16541 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
16542 Set_Exported (Def_Id, Arg2);
16545 -- If the entity is a deferred constant, propagate the information
16546 -- to the full view, because gigi elaborates the full view only.
16548 if Ekind (Def_Id) = E_Constant
16549 and then Present (Full_View (Def_Id))
16552 Id2 : constant Entity_Id := Full_View (Def_Id);
16554 Set_Is_Exported (Id2, Is_Exported (Def_Id));
16555 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
16556 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
16561 ---------------------
16562 -- Export_Function --
16563 ---------------------
16565 -- pragma Export_Function (
16566 -- [Internal =>] LOCAL_NAME
16567 -- [, [External =>] EXTERNAL_SYMBOL]
16568 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16569 -- [, [Result_Type =>] TYPE_DESIGNATOR]
16570 -- [, [Mechanism =>] MECHANISM]
16571 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
16573 -- EXTERNAL_SYMBOL ::=
16575 -- | static_string_EXPRESSION
16577 -- PARAMETER_TYPES ::=
16579 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16581 -- TYPE_DESIGNATOR ::=
16583 -- | subtype_Name ' Access
16587 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16589 -- MECHANISM_ASSOCIATION ::=
16590 -- [formal_parameter_NAME =>] MECHANISM_NAME
16592 -- MECHANISM_NAME ::=
16596 when Pragma_Export_Function => Export_Function : declare
16597 Args : Args_List (1 .. 6);
16598 Names : constant Name_List (1 .. 6) := (
16601 Name_Parameter_Types,
16604 Name_Result_Mechanism);
16606 Internal : Node_Id renames Args (1);
16607 External : Node_Id renames Args (2);
16608 Parameter_Types : Node_Id renames Args (3);
16609 Result_Type : Node_Id renames Args (4);
16610 Mechanism : Node_Id renames Args (5);
16611 Result_Mechanism : Node_Id renames Args (6);
16615 Gather_Associations (Names, Args);
16616 Process_Extended_Import_Export_Subprogram_Pragma (
16617 Arg_Internal => Internal,
16618 Arg_External => External,
16619 Arg_Parameter_Types => Parameter_Types,
16620 Arg_Result_Type => Result_Type,
16621 Arg_Mechanism => Mechanism,
16622 Arg_Result_Mechanism => Result_Mechanism);
16623 end Export_Function;
16625 -------------------
16626 -- Export_Object --
16627 -------------------
16629 -- pragma Export_Object (
16630 -- [Internal =>] LOCAL_NAME
16631 -- [, [External =>] EXTERNAL_SYMBOL]
16632 -- [, [Size =>] EXTERNAL_SYMBOL]);
16634 -- EXTERNAL_SYMBOL ::=
16636 -- | static_string_EXPRESSION
16638 -- PARAMETER_TYPES ::=
16640 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16642 -- TYPE_DESIGNATOR ::=
16644 -- | subtype_Name ' Access
16648 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16650 -- MECHANISM_ASSOCIATION ::=
16651 -- [formal_parameter_NAME =>] MECHANISM_NAME
16653 -- MECHANISM_NAME ::=
16657 when Pragma_Export_Object => Export_Object : declare
16658 Args : Args_List (1 .. 3);
16659 Names : constant Name_List (1 .. 3) := (
16664 Internal : Node_Id renames Args (1);
16665 External : Node_Id renames Args (2);
16666 Size : Node_Id renames Args (3);
16670 Gather_Associations (Names, Args);
16671 Process_Extended_Import_Export_Object_Pragma (
16672 Arg_Internal => Internal,
16673 Arg_External => External,
16677 ----------------------
16678 -- Export_Procedure --
16679 ----------------------
16681 -- pragma Export_Procedure (
16682 -- [Internal =>] LOCAL_NAME
16683 -- [, [External =>] EXTERNAL_SYMBOL]
16684 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16685 -- [, [Mechanism =>] MECHANISM]);
16687 -- EXTERNAL_SYMBOL ::=
16689 -- | static_string_EXPRESSION
16691 -- PARAMETER_TYPES ::=
16693 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16695 -- TYPE_DESIGNATOR ::=
16697 -- | subtype_Name ' Access
16701 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16703 -- MECHANISM_ASSOCIATION ::=
16704 -- [formal_parameter_NAME =>] MECHANISM_NAME
16706 -- MECHANISM_NAME ::=
16710 when Pragma_Export_Procedure => Export_Procedure : declare
16711 Args : Args_List (1 .. 4);
16712 Names : constant Name_List (1 .. 4) := (
16715 Name_Parameter_Types,
16718 Internal : Node_Id renames Args (1);
16719 External : Node_Id renames Args (2);
16720 Parameter_Types : Node_Id renames Args (3);
16721 Mechanism : Node_Id renames Args (4);
16725 Gather_Associations (Names, Args);
16726 Process_Extended_Import_Export_Subprogram_Pragma (
16727 Arg_Internal => Internal,
16728 Arg_External => External,
16729 Arg_Parameter_Types => Parameter_Types,
16730 Arg_Mechanism => Mechanism);
16731 end Export_Procedure;
16737 -- pragma Export_Value (
16738 -- [Value =>] static_integer_EXPRESSION,
16739 -- [Link_Name =>] static_string_EXPRESSION);
16741 when Pragma_Export_Value =>
16743 Check_Arg_Order ((Name_Value, Name_Link_Name));
16744 Check_Arg_Count (2);
16746 Check_Optional_Identifier (Arg1, Name_Value);
16747 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
16749 Check_Optional_Identifier (Arg2, Name_Link_Name);
16750 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
16752 -----------------------------
16753 -- Export_Valued_Procedure --
16754 -----------------------------
16756 -- pragma Export_Valued_Procedure (
16757 -- [Internal =>] LOCAL_NAME
16758 -- [, [External =>] EXTERNAL_SYMBOL,]
16759 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16760 -- [, [Mechanism =>] MECHANISM]);
16762 -- EXTERNAL_SYMBOL ::=
16764 -- | static_string_EXPRESSION
16766 -- PARAMETER_TYPES ::=
16768 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16770 -- TYPE_DESIGNATOR ::=
16772 -- | subtype_Name ' Access
16776 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16778 -- MECHANISM_ASSOCIATION ::=
16779 -- [formal_parameter_NAME =>] MECHANISM_NAME
16781 -- MECHANISM_NAME ::=
16785 when Pragma_Export_Valued_Procedure =>
16786 Export_Valued_Procedure : declare
16787 Args : Args_List (1 .. 4);
16788 Names : constant Name_List (1 .. 4) := (
16791 Name_Parameter_Types,
16794 Internal : Node_Id renames Args (1);
16795 External : Node_Id renames Args (2);
16796 Parameter_Types : Node_Id renames Args (3);
16797 Mechanism : Node_Id renames Args (4);
16801 Gather_Associations (Names, Args);
16802 Process_Extended_Import_Export_Subprogram_Pragma (
16803 Arg_Internal => Internal,
16804 Arg_External => External,
16805 Arg_Parameter_Types => Parameter_Types,
16806 Arg_Mechanism => Mechanism);
16807 end Export_Valued_Procedure;
16809 -------------------
16810 -- Extend_System --
16811 -------------------
16813 -- pragma Extend_System ([Name =>] Identifier);
16815 when Pragma_Extend_System =>
16817 Check_Valid_Configuration_Pragma;
16818 Check_Arg_Count (1);
16819 Check_Optional_Identifier (Arg1, Name_Name);
16820 Check_Arg_Is_Identifier (Arg1);
16822 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
16825 and then Name_Buffer (1 .. 4) = "aux_"
16827 if Present (System_Extend_Pragma_Arg) then
16828 if Chars (Get_Pragma_Arg (Arg1)) =
16829 Chars (Expression (System_Extend_Pragma_Arg))
16833 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
16834 Error_Pragma ("pragma% conflicts with that #");
16838 System_Extend_Pragma_Arg := Arg1;
16840 if not GNAT_Mode then
16841 System_Extend_Unit := Arg1;
16845 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
16848 ------------------------
16849 -- Extensions_Allowed --
16850 ------------------------
16852 -- pragma Extensions_Allowed (ON | OFF);
16854 when Pragma_Extensions_Allowed =>
16856 Check_Arg_Count (1);
16857 Check_No_Identifiers;
16858 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
16860 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
16861 Extensions_Allowed := True;
16862 Ada_Version := Ada_Version_Type'Last;
16865 Extensions_Allowed := False;
16866 Ada_Version := Ada_Version_Explicit;
16867 Ada_Version_Pragma := Empty;
16870 ------------------------
16871 -- Extensions_Visible --
16872 ------------------------
16874 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
16876 -- Characteristics:
16878 -- * Analysis - The annotation is fully analyzed immediately upon
16879 -- elaboration as its expression must be static.
16881 -- * Expansion - None.
16883 -- * Template - The annotation utilizes the generic template of the
16884 -- related subprogram [body] when it is:
16886 -- aspect on subprogram declaration
16887 -- aspect on stand-alone subprogram body
16888 -- pragma on stand-alone subprogram body
16890 -- The annotation must prepare its own template when it is:
16892 -- pragma on subprogram declaration
16894 -- * Globals - Capture of global references must occur after full
16897 -- * Instance - The annotation is instantiated automatically when
16898 -- the related generic subprogram [body] is instantiated except for
16899 -- the "pragma on subprogram declaration" case. In that scenario
16900 -- the annotation must instantiate itself.
16902 when Pragma_Extensions_Visible => Extensions_Visible : declare
16903 Formal : Entity_Id;
16904 Has_OK_Formal : Boolean := False;
16905 Spec_Id : Entity_Id;
16906 Subp_Decl : Node_Id;
16910 Check_No_Identifiers;
16911 Check_At_Most_N_Arguments (1);
16914 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
16916 -- Abstract subprogram declaration
16918 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
16921 -- Generic subprogram declaration
16923 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
16926 -- Body acts as spec
16928 elsif Nkind (Subp_Decl) = N_Subprogram_Body
16929 and then No (Corresponding_Spec (Subp_Decl))
16933 -- Body stub acts as spec
16935 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
16936 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
16940 -- Subprogram declaration
16942 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
16945 -- Otherwise the pragma is associated with an illegal construct
16948 Error_Pragma ("pragma % must apply to a subprogram");
16952 -- Mark the pragma as Ghost if the related subprogram is also
16953 -- Ghost. This also ensures that any expansion performed further
16954 -- below will produce Ghost nodes.
16956 Spec_Id := Unique_Defining_Entity (Subp_Decl);
16957 Mark_Ghost_Pragma (N, Spec_Id);
16959 -- Chain the pragma on the contract for completeness
16961 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
16963 -- The legality checks of pragma Extension_Visible are affected
16964 -- by the SPARK mode in effect. Analyze all pragmas in specific
16967 Analyze_If_Present (Pragma_SPARK_Mode);
16969 -- Examine the formals of the related subprogram
16971 Formal := First_Formal (Spec_Id);
16972 while Present (Formal) loop
16974 -- At least one of the formals is of a specific tagged type,
16975 -- the pragma is legal.
16977 if Is_Specific_Tagged_Type (Etype (Formal)) then
16978 Has_OK_Formal := True;
16981 -- A generic subprogram with at least one formal of a private
16982 -- type ensures the legality of the pragma because the actual
16983 -- may be specifically tagged. Note that this is verified by
16984 -- the check above at instantiation time.
16986 elsif Is_Private_Type (Etype (Formal))
16987 and then Is_Generic_Type (Etype (Formal))
16989 Has_OK_Formal := True;
16993 Next_Formal (Formal);
16996 if not Has_OK_Formal then
16997 Error_Msg_Name_1 := Pname;
16998 Error_Msg_N (Fix_Error ("incorrect placement of pragma %"), N);
17000 ("\subprogram & lacks parameter of specific tagged or "
17001 & "generic private type", N, Spec_Id);
17006 -- Analyze the Boolean expression (if any)
17008 if Present (Arg1) then
17009 Check_Static_Boolean_Expression
17010 (Expression (Get_Argument (N, Spec_Id)));
17012 end Extensions_Visible;
17018 -- pragma External (
17019 -- [ Convention =>] convention_IDENTIFIER,
17020 -- [ Entity =>] LOCAL_NAME
17021 -- [, [External_Name =>] static_string_EXPRESSION ]
17022 -- [, [Link_Name =>] static_string_EXPRESSION ]);
17024 when Pragma_External => External : declare
17027 pragma Warnings (Off, C);
17034 Name_External_Name,
17036 Check_At_Least_N_Arguments (2);
17037 Check_At_Most_N_Arguments (4);
17038 Process_Convention (C, E);
17040 -- A pragma that applies to a Ghost entity becomes Ghost for the
17041 -- purposes of legality checks and removal of ignored Ghost code.
17043 Mark_Ghost_Pragma (N, E);
17045 Note_Possible_Modification
17046 (Get_Pragma_Arg (Arg2), Sure => False);
17047 Process_Interface_Name (E, Arg3, Arg4, N);
17048 Set_Exported (E, Arg2);
17051 --------------------------
17052 -- External_Name_Casing --
17053 --------------------------
17055 -- pragma External_Name_Casing (
17056 -- UPPERCASE | LOWERCASE
17057 -- [, AS_IS | UPPERCASE | LOWERCASE]);
17059 when Pragma_External_Name_Casing =>
17061 Check_No_Identifiers;
17063 if Arg_Count = 2 then
17064 Check_Arg_Is_One_Of
17065 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
17067 case Chars (Get_Pragma_Arg (Arg2)) is
17069 Opt.External_Name_Exp_Casing := As_Is;
17071 when Name_Uppercase =>
17072 Opt.External_Name_Exp_Casing := Uppercase;
17074 when Name_Lowercase =>
17075 Opt.External_Name_Exp_Casing := Lowercase;
17082 Check_Arg_Count (1);
17085 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
17087 case Chars (Get_Pragma_Arg (Arg1)) is
17088 when Name_Uppercase =>
17089 Opt.External_Name_Imp_Casing := Uppercase;
17091 when Name_Lowercase =>
17092 Opt.External_Name_Imp_Casing := Lowercase;
17102 -- pragma Fast_Math;
17104 when Pragma_Fast_Math =>
17106 Check_No_Identifiers;
17107 Check_Valid_Configuration_Pragma;
17110 --------------------------
17111 -- Favor_Top_Level --
17112 --------------------------
17114 -- pragma Favor_Top_Level (type_NAME);
17116 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
17121 Check_No_Identifiers;
17122 Check_Arg_Count (1);
17123 Check_Arg_Is_Local_Name (Arg1);
17124 Typ := Entity (Get_Pragma_Arg (Arg1));
17126 -- A pragma that applies to a Ghost entity becomes Ghost for the
17127 -- purposes of legality checks and removal of ignored Ghost code.
17129 Mark_Ghost_Pragma (N, Typ);
17131 -- If it's an access-to-subprogram type (in particular, not a
17132 -- subtype), set the flag on that type.
17134 if Is_Access_Subprogram_Type (Typ) then
17135 Set_Can_Use_Internal_Rep (Typ, False);
17137 -- Otherwise it's an error (name denotes the wrong sort of entity)
17141 ("access-to-subprogram type expected",
17142 Get_Pragma_Arg (Arg1));
17144 end Favor_Top_Level;
17146 ---------------------------
17147 -- Finalize_Storage_Only --
17148 ---------------------------
17150 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
17152 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
17153 Assoc : constant Node_Id := Arg1;
17154 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
17159 Check_No_Identifiers;
17160 Check_Arg_Count (1);
17161 Check_Arg_Is_Local_Name (Arg1);
17163 Find_Type (Type_Id);
17164 Typ := Entity (Type_Id);
17167 or else Rep_Item_Too_Early (Typ, N)
17171 Typ := Underlying_Type (Typ);
17174 if not Is_Controlled (Typ) then
17175 Error_Pragma ("pragma% must specify controlled type");
17178 Check_First_Subtype (Arg1);
17180 if Finalize_Storage_Only (Typ) then
17181 Error_Pragma ("duplicate pragma%, only one allowed");
17183 elsif not Rep_Item_Too_Late (Typ, N) then
17184 Set_Finalize_Storage_Only (Base_Type (Typ), True);
17186 end Finalize_Storage;
17192 -- pragma Ghost [ (boolean_EXPRESSION) ];
17194 when Pragma_Ghost => Ghost : declare
17198 Orig_Stmt : Node_Id;
17199 Prev_Id : Entity_Id;
17204 Check_No_Identifiers;
17205 Check_At_Most_N_Arguments (1);
17209 while Present (Stmt) loop
17211 -- Skip prior pragmas, but check for duplicates
17213 if Nkind (Stmt) = N_Pragma then
17214 if Pragma_Name (Stmt) = Pname then
17221 -- Task unit declared without a definition cannot be subject to
17222 -- pragma Ghost (SPARK RM 6.9(19)).
17224 elsif Nkind_In (Stmt, N_Single_Task_Declaration,
17225 N_Task_Type_Declaration)
17227 Error_Pragma ("pragma % cannot apply to a task type");
17230 -- Skip internally generated code
17232 elsif not Comes_From_Source (Stmt) then
17233 Orig_Stmt := Original_Node (Stmt);
17235 -- When pragma Ghost applies to an untagged derivation, the
17236 -- derivation is transformed into a [sub]type declaration.
17238 if Nkind_In (Stmt, N_Full_Type_Declaration,
17239 N_Subtype_Declaration)
17240 and then Comes_From_Source (Orig_Stmt)
17241 and then Nkind (Orig_Stmt) = N_Full_Type_Declaration
17242 and then Nkind (Type_Definition (Orig_Stmt)) =
17243 N_Derived_Type_Definition
17245 Id := Defining_Entity (Stmt);
17248 -- When pragma Ghost applies to an object declaration which
17249 -- is initialized by means of a function call that returns
17250 -- on the secondary stack, the object declaration becomes a
17253 elsif Nkind (Stmt) = N_Object_Renaming_Declaration
17254 and then Comes_From_Source (Orig_Stmt)
17255 and then Nkind (Orig_Stmt) = N_Object_Declaration
17257 Id := Defining_Entity (Stmt);
17260 -- When pragma Ghost applies to an expression function, the
17261 -- expression function is transformed into a subprogram.
17263 elsif Nkind (Stmt) = N_Subprogram_Declaration
17264 and then Comes_From_Source (Orig_Stmt)
17265 and then Nkind (Orig_Stmt) = N_Expression_Function
17267 Id := Defining_Entity (Stmt);
17271 -- The pragma applies to a legal construct, stop the traversal
17273 elsif Nkind_In (Stmt, N_Abstract_Subprogram_Declaration,
17274 N_Full_Type_Declaration,
17275 N_Generic_Subprogram_Declaration,
17276 N_Object_Declaration,
17277 N_Private_Extension_Declaration,
17278 N_Private_Type_Declaration,
17279 N_Subprogram_Declaration,
17280 N_Subtype_Declaration)
17282 Id := Defining_Entity (Stmt);
17285 -- The pragma does not apply to a legal construct, issue an
17286 -- error and stop the analysis.
17290 ("pragma % must apply to an object, package, subprogram "
17295 Stmt := Prev (Stmt);
17298 Context := Parent (N);
17300 -- Handle compilation units
17302 if Nkind (Context) = N_Compilation_Unit_Aux then
17303 Context := Unit (Parent (Context));
17306 -- Protected and task types cannot be subject to pragma Ghost
17307 -- (SPARK RM 6.9(19)).
17309 if Nkind_In (Context, N_Protected_Body, N_Protected_Definition)
17311 Error_Pragma ("pragma % cannot apply to a protected type");
17314 elsif Nkind_In (Context, N_Task_Body, N_Task_Definition) then
17315 Error_Pragma ("pragma % cannot apply to a task type");
17321 -- When pragma Ghost is associated with a [generic] package, it
17322 -- appears in the visible declarations.
17324 if Nkind (Context) = N_Package_Specification
17325 and then Present (Visible_Declarations (Context))
17326 and then List_Containing (N) = Visible_Declarations (Context)
17328 Id := Defining_Entity (Context);
17330 -- Pragma Ghost applies to a stand-alone subprogram body
17332 elsif Nkind (Context) = N_Subprogram_Body
17333 and then No (Corresponding_Spec (Context))
17335 Id := Defining_Entity (Context);
17337 -- Pragma Ghost applies to a subprogram declaration that acts
17338 -- as a compilation unit.
17340 elsif Nkind (Context) = N_Subprogram_Declaration then
17341 Id := Defining_Entity (Context);
17343 -- Pragma Ghost applies to a generic subprogram
17345 elsif Nkind (Context) = N_Generic_Subprogram_Declaration then
17346 Id := Defining_Entity (Specification (Context));
17352 ("pragma % must apply to an object, package, subprogram or "
17357 -- Handle completions of types and constants that are subject to
17360 if Is_Record_Type (Id) or else Ekind (Id) = E_Constant then
17361 Prev_Id := Incomplete_Or_Partial_View (Id);
17363 if Present (Prev_Id) and then not Is_Ghost_Entity (Prev_Id) then
17364 Error_Msg_Name_1 := Pname;
17366 -- The full declaration of a deferred constant cannot be
17367 -- subject to pragma Ghost unless the deferred declaration
17368 -- is also Ghost (SPARK RM 6.9(9)).
17370 if Ekind (Prev_Id) = E_Constant then
17371 Error_Msg_Name_1 := Pname;
17372 Error_Msg_NE (Fix_Error
17373 ("pragma % must apply to declaration of deferred "
17374 & "constant &"), N, Id);
17377 -- Pragma Ghost may appear on the full view of an incomplete
17378 -- type because the incomplete declaration lacks aspects and
17379 -- cannot be subject to pragma Ghost.
17381 elsif Ekind (Prev_Id) = E_Incomplete_Type then
17384 -- The full declaration of a type cannot be subject to
17385 -- pragma Ghost unless the partial view is also Ghost
17386 -- (SPARK RM 6.9(9)).
17389 Error_Msg_NE (Fix_Error
17390 ("pragma % must apply to partial view of type &"),
17396 -- A synchronized object cannot be subject to pragma Ghost
17397 -- (SPARK RM 6.9(19)).
17399 elsif Ekind (Id) = E_Variable then
17400 if Is_Protected_Type (Etype (Id)) then
17401 Error_Pragma ("pragma % cannot apply to a protected object");
17404 elsif Is_Task_Type (Etype (Id)) then
17405 Error_Pragma ("pragma % cannot apply to a task object");
17410 -- Analyze the Boolean expression (if any)
17412 if Present (Arg1) then
17413 Expr := Get_Pragma_Arg (Arg1);
17415 Analyze_And_Resolve (Expr, Standard_Boolean);
17417 if Is_OK_Static_Expression (Expr) then
17419 -- "Ghostness" cannot be turned off once enabled within a
17420 -- region (SPARK RM 6.9(6)).
17422 if Is_False (Expr_Value (Expr))
17423 and then Ghost_Mode > None
17426 ("pragma % with value False cannot appear in enabled "
17431 -- Otherwie the expression is not static
17435 ("expression of pragma % must be static", Expr);
17440 Set_Is_Ghost_Entity (Id);
17447 -- pragma Global (GLOBAL_SPECIFICATION);
17449 -- GLOBAL_SPECIFICATION ::=
17452 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
17454 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
17456 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
17457 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
17458 -- GLOBAL_ITEM ::= NAME
17460 -- Characteristics:
17462 -- * Analysis - The annotation undergoes initial checks to verify
17463 -- the legal placement and context. Secondary checks fully analyze
17464 -- the dependency clauses in:
17466 -- Analyze_Global_In_Decl_Part
17468 -- * Expansion - None.
17470 -- * Template - The annotation utilizes the generic template of the
17471 -- related subprogram [body] when it is:
17473 -- aspect on subprogram declaration
17474 -- aspect on stand-alone subprogram body
17475 -- pragma on stand-alone subprogram body
17477 -- The annotation must prepare its own template when it is:
17479 -- pragma on subprogram declaration
17481 -- * Globals - Capture of global references must occur after full
17484 -- * Instance - The annotation is instantiated automatically when
17485 -- the related generic subprogram [body] is instantiated except for
17486 -- the "pragma on subprogram declaration" case. In that scenario
17487 -- the annotation must instantiate itself.
17489 when Pragma_Global => Global : declare
17491 Spec_Id : Entity_Id;
17492 Subp_Decl : Node_Id;
17495 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
17499 -- Chain the pragma on the contract for further processing by
17500 -- Analyze_Global_In_Decl_Part.
17502 Add_Contract_Item (N, Spec_Id);
17504 -- Fully analyze the pragma when it appears inside an entry
17505 -- or subprogram body because it cannot benefit from forward
17508 if Nkind_In (Subp_Decl, N_Entry_Body,
17510 N_Subprogram_Body_Stub)
17512 -- The legality checks of pragmas Depends and Global are
17513 -- affected by the SPARK mode in effect and the volatility
17514 -- of the context. In addition these two pragmas are subject
17515 -- to an inherent order:
17520 -- Analyze all these pragmas in the order outlined above
17522 Analyze_If_Present (Pragma_SPARK_Mode);
17523 Analyze_If_Present (Pragma_Volatile_Function);
17524 Analyze_Global_In_Decl_Part (N);
17525 Analyze_If_Present (Pragma_Depends);
17534 -- pragma Ident (static_string_EXPRESSION)
17536 -- Note: pragma Comment shares this processing. Pragma Ident is
17537 -- identical in effect to pragma Commment.
17539 when Pragma_Comment
17547 Check_Arg_Count (1);
17548 Check_No_Identifiers;
17549 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
17552 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
17559 GP := Parent (Parent (N));
17561 if Nkind_In (GP, N_Package_Declaration,
17562 N_Generic_Package_Declaration)
17567 -- If we have a compilation unit, then record the ident value,
17568 -- checking for improper duplication.
17570 if Nkind (GP) = N_Compilation_Unit then
17571 CS := Ident_String (Current_Sem_Unit);
17573 if Present (CS) then
17575 -- If we have multiple instances, concatenate them, but
17576 -- not in ASIS, where we want the original tree.
17578 if not ASIS_Mode then
17579 Start_String (Strval (CS));
17580 Store_String_Char (' ');
17581 Store_String_Chars (Strval (Str));
17582 Set_Strval (CS, End_String);
17586 Set_Ident_String (Current_Sem_Unit, Str);
17589 -- For subunits, we just ignore the Ident, since in GNAT these
17590 -- are not separate object files, and hence not separate units
17591 -- in the unit table.
17593 elsif Nkind (GP) = N_Subunit then
17599 -------------------
17600 -- Ignore_Pragma --
17601 -------------------
17603 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
17605 -- Entirely handled in the parser, nothing to do here
17607 when Pragma_Ignore_Pragma =>
17610 ----------------------------
17611 -- Implementation_Defined --
17612 ----------------------------
17614 -- pragma Implementation_Defined (LOCAL_NAME);
17616 -- Marks previously declared entity as implementation defined. For
17617 -- an overloaded entity, applies to the most recent homonym.
17619 -- pragma Implementation_Defined;
17621 -- The form with no arguments appears anywhere within a scope, most
17622 -- typically a package spec, and indicates that all entities that are
17623 -- defined within the package spec are Implementation_Defined.
17625 when Pragma_Implementation_Defined => Implementation_Defined : declare
17630 Check_No_Identifiers;
17632 -- Form with no arguments
17634 if Arg_Count = 0 then
17635 Set_Is_Implementation_Defined (Current_Scope);
17637 -- Form with one argument
17640 Check_Arg_Count (1);
17641 Check_Arg_Is_Local_Name (Arg1);
17642 Ent := Entity (Get_Pragma_Arg (Arg1));
17643 Set_Is_Implementation_Defined (Ent);
17645 end Implementation_Defined;
17651 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
17653 -- IMPLEMENTATION_KIND ::=
17654 -- By_Entry | By_Protected_Procedure | By_Any | Optional
17656 -- "By_Any" and "Optional" are treated as synonyms in order to
17657 -- support Ada 2012 aspect Synchronization.
17659 when Pragma_Implemented => Implemented : declare
17660 Proc_Id : Entity_Id;
17665 Check_Arg_Count (2);
17666 Check_No_Identifiers;
17667 Check_Arg_Is_Identifier (Arg1);
17668 Check_Arg_Is_Local_Name (Arg1);
17669 Check_Arg_Is_One_Of (Arg2,
17672 Name_By_Protected_Procedure,
17675 -- Extract the name of the local procedure
17677 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
17679 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
17680 -- primitive procedure of a synchronized tagged type.
17682 if Ekind (Proc_Id) = E_Procedure
17683 and then Is_Primitive (Proc_Id)
17684 and then Present (First_Formal (Proc_Id))
17686 Typ := Etype (First_Formal (Proc_Id));
17688 if Is_Tagged_Type (Typ)
17691 -- Check for a protected, a synchronized or a task interface
17693 ((Is_Interface (Typ)
17694 and then Is_Synchronized_Interface (Typ))
17696 -- Check for a protected type or a task type that implements
17700 (Is_Concurrent_Record_Type (Typ)
17701 and then Present (Interfaces (Typ)))
17703 -- In analysis-only mode, examine original protected type
17706 (Nkind (Parent (Typ)) = N_Protected_Type_Declaration
17707 and then Present (Interface_List (Parent (Typ))))
17709 -- Check for a private record extension with keyword
17713 (Ekind_In (Typ, E_Record_Type_With_Private,
17714 E_Record_Subtype_With_Private)
17715 and then Synchronized_Present (Parent (Typ))))
17720 ("controlling formal must be of synchronized tagged type",
17725 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
17726 -- By_Protected_Procedure to the primitive procedure of a task
17729 if Chars (Arg2) = Name_By_Protected_Procedure
17730 and then Is_Interface (Typ)
17731 and then Is_Task_Interface (Typ)
17734 ("implementation kind By_Protected_Procedure cannot be "
17735 & "applied to a task interface primitive", Arg2);
17739 -- Procedures declared inside a protected type must be accepted
17741 elsif Ekind (Proc_Id) = E_Procedure
17742 and then Is_Protected_Type (Scope (Proc_Id))
17746 -- The first argument is not a primitive procedure
17750 ("pragma % must be applied to a primitive procedure", Arg1);
17754 Record_Rep_Item (Proc_Id, N);
17757 ----------------------
17758 -- Implicit_Packing --
17759 ----------------------
17761 -- pragma Implicit_Packing;
17763 when Pragma_Implicit_Packing =>
17765 Check_Arg_Count (0);
17766 Implicit_Packing := True;
17773 -- [Convention =>] convention_IDENTIFIER,
17774 -- [Entity =>] LOCAL_NAME
17775 -- [, [External_Name =>] static_string_EXPRESSION ]
17776 -- [, [Link_Name =>] static_string_EXPRESSION ]);
17778 when Pragma_Import =>
17779 Check_Ada_83_Warning;
17783 Name_External_Name,
17786 Check_At_Least_N_Arguments (2);
17787 Check_At_Most_N_Arguments (4);
17788 Process_Import_Or_Interface;
17790 ---------------------
17791 -- Import_Function --
17792 ---------------------
17794 -- pragma Import_Function (
17795 -- [Internal =>] LOCAL_NAME,
17796 -- [, [External =>] EXTERNAL_SYMBOL]
17797 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17798 -- [, [Result_Type =>] SUBTYPE_MARK]
17799 -- [, [Mechanism =>] MECHANISM]
17800 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
17802 -- EXTERNAL_SYMBOL ::=
17804 -- | static_string_EXPRESSION
17806 -- PARAMETER_TYPES ::=
17808 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17810 -- TYPE_DESIGNATOR ::=
17812 -- | subtype_Name ' Access
17816 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17818 -- MECHANISM_ASSOCIATION ::=
17819 -- [formal_parameter_NAME =>] MECHANISM_NAME
17821 -- MECHANISM_NAME ::=
17825 when Pragma_Import_Function => Import_Function : declare
17826 Args : Args_List (1 .. 6);
17827 Names : constant Name_List (1 .. 6) := (
17830 Name_Parameter_Types,
17833 Name_Result_Mechanism);
17835 Internal : Node_Id renames Args (1);
17836 External : Node_Id renames Args (2);
17837 Parameter_Types : Node_Id renames Args (3);
17838 Result_Type : Node_Id renames Args (4);
17839 Mechanism : Node_Id renames Args (5);
17840 Result_Mechanism : Node_Id renames Args (6);
17844 Gather_Associations (Names, Args);
17845 Process_Extended_Import_Export_Subprogram_Pragma (
17846 Arg_Internal => Internal,
17847 Arg_External => External,
17848 Arg_Parameter_Types => Parameter_Types,
17849 Arg_Result_Type => Result_Type,
17850 Arg_Mechanism => Mechanism,
17851 Arg_Result_Mechanism => Result_Mechanism);
17852 end Import_Function;
17854 -------------------
17855 -- Import_Object --
17856 -------------------
17858 -- pragma Import_Object (
17859 -- [Internal =>] LOCAL_NAME
17860 -- [, [External =>] EXTERNAL_SYMBOL]
17861 -- [, [Size =>] EXTERNAL_SYMBOL]);
17863 -- EXTERNAL_SYMBOL ::=
17865 -- | static_string_EXPRESSION
17867 when Pragma_Import_Object => Import_Object : declare
17868 Args : Args_List (1 .. 3);
17869 Names : constant Name_List (1 .. 3) := (
17874 Internal : Node_Id renames Args (1);
17875 External : Node_Id renames Args (2);
17876 Size : Node_Id renames Args (3);
17880 Gather_Associations (Names, Args);
17881 Process_Extended_Import_Export_Object_Pragma (
17882 Arg_Internal => Internal,
17883 Arg_External => External,
17887 ----------------------
17888 -- Import_Procedure --
17889 ----------------------
17891 -- pragma Import_Procedure (
17892 -- [Internal =>] LOCAL_NAME
17893 -- [, [External =>] EXTERNAL_SYMBOL]
17894 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17895 -- [, [Mechanism =>] MECHANISM]);
17897 -- EXTERNAL_SYMBOL ::=
17899 -- | static_string_EXPRESSION
17901 -- PARAMETER_TYPES ::=
17903 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17905 -- TYPE_DESIGNATOR ::=
17907 -- | subtype_Name ' Access
17911 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17913 -- MECHANISM_ASSOCIATION ::=
17914 -- [formal_parameter_NAME =>] MECHANISM_NAME
17916 -- MECHANISM_NAME ::=
17920 when Pragma_Import_Procedure => Import_Procedure : declare
17921 Args : Args_List (1 .. 4);
17922 Names : constant Name_List (1 .. 4) := (
17925 Name_Parameter_Types,
17928 Internal : Node_Id renames Args (1);
17929 External : Node_Id renames Args (2);
17930 Parameter_Types : Node_Id renames Args (3);
17931 Mechanism : Node_Id renames Args (4);
17935 Gather_Associations (Names, Args);
17936 Process_Extended_Import_Export_Subprogram_Pragma (
17937 Arg_Internal => Internal,
17938 Arg_External => External,
17939 Arg_Parameter_Types => Parameter_Types,
17940 Arg_Mechanism => Mechanism);
17941 end Import_Procedure;
17943 -----------------------------
17944 -- Import_Valued_Procedure --
17945 -----------------------------
17947 -- pragma Import_Valued_Procedure (
17948 -- [Internal =>] LOCAL_NAME
17949 -- [, [External =>] EXTERNAL_SYMBOL]
17950 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17951 -- [, [Mechanism =>] MECHANISM]);
17953 -- EXTERNAL_SYMBOL ::=
17955 -- | static_string_EXPRESSION
17957 -- PARAMETER_TYPES ::=
17959 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17961 -- TYPE_DESIGNATOR ::=
17963 -- | subtype_Name ' Access
17967 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17969 -- MECHANISM_ASSOCIATION ::=
17970 -- [formal_parameter_NAME =>] MECHANISM_NAME
17972 -- MECHANISM_NAME ::=
17976 when Pragma_Import_Valued_Procedure =>
17977 Import_Valued_Procedure : declare
17978 Args : Args_List (1 .. 4);
17979 Names : constant Name_List (1 .. 4) := (
17982 Name_Parameter_Types,
17985 Internal : Node_Id renames Args (1);
17986 External : Node_Id renames Args (2);
17987 Parameter_Types : Node_Id renames Args (3);
17988 Mechanism : Node_Id renames Args (4);
17992 Gather_Associations (Names, Args);
17993 Process_Extended_Import_Export_Subprogram_Pragma (
17994 Arg_Internal => Internal,
17995 Arg_External => External,
17996 Arg_Parameter_Types => Parameter_Types,
17997 Arg_Mechanism => Mechanism);
17998 end Import_Valued_Procedure;
18004 -- pragma Independent (LOCAL_NAME);
18006 when Pragma_Independent =>
18007 Process_Atomic_Independent_Shared_Volatile;
18009 ----------------------------
18010 -- Independent_Components --
18011 ----------------------------
18013 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
18015 when Pragma_Independent_Components => Independent_Components : declare
18022 Check_Ada_83_Warning;
18024 Check_No_Identifiers;
18025 Check_Arg_Count (1);
18026 Check_Arg_Is_Local_Name (Arg1);
18027 E_Id := Get_Pragma_Arg (Arg1);
18029 if Etype (E_Id) = Any_Type then
18033 E := Entity (E_Id);
18035 -- A record type with a self-referential component of anonymous
18036 -- access type is given an incomplete view in order to handle the
18039 -- type Rec is record
18040 -- Self : access Rec;
18046 -- type Ptr is access Rec;
18047 -- type Rec is record
18051 -- Since the incomplete view is now the initial view of the type,
18052 -- the argument of the pragma will reference the incomplete view,
18053 -- but this view is illegal according to the semantics of the
18056 -- Obtain the full view of an internally-generated incomplete type
18057 -- only. This way an attempt to associate the pragma with a source
18058 -- incomplete type is still caught.
18060 if Ekind (E) = E_Incomplete_Type
18061 and then not Comes_From_Source (E)
18062 and then Present (Full_View (E))
18064 E := Full_View (E);
18067 -- A pragma that applies to a Ghost entity becomes Ghost for the
18068 -- purposes of legality checks and removal of ignored Ghost code.
18070 Mark_Ghost_Pragma (N, E);
18072 -- Check duplicate before we chain ourselves
18074 Check_Duplicate_Pragma (E);
18076 -- Check appropriate entity
18078 if Rep_Item_Too_Early (E, N)
18080 Rep_Item_Too_Late (E, N)
18085 D := Declaration_Node (E);
18087 -- The flag is set on the base type, or on the object
18089 if Nkind (D) = N_Full_Type_Declaration
18090 and then (Is_Array_Type (E) or else Is_Record_Type (E))
18092 Set_Has_Independent_Components (Base_Type (E));
18093 Record_Independence_Check (N, Base_Type (E));
18095 -- For record type, set all components independent
18097 if Is_Record_Type (E) then
18098 C := First_Component (E);
18099 while Present (C) loop
18100 Set_Is_Independent (C);
18101 Next_Component (C);
18105 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
18106 and then Nkind (D) = N_Object_Declaration
18107 and then Nkind (Object_Definition (D)) =
18108 N_Constrained_Array_Definition
18110 Set_Has_Independent_Components (E);
18111 Record_Independence_Check (N, E);
18114 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
18116 end Independent_Components;
18118 -----------------------
18119 -- Initial_Condition --
18120 -----------------------
18122 -- pragma Initial_Condition (boolean_EXPRESSION);
18124 -- Characteristics:
18126 -- * Analysis - The annotation undergoes initial checks to verify
18127 -- the legal placement and context. Secondary checks preanalyze the
18130 -- Analyze_Initial_Condition_In_Decl_Part
18132 -- * Expansion - The annotation is expanded during the expansion of
18133 -- the package body whose declaration is subject to the annotation
18136 -- Expand_Pragma_Initial_Condition
18138 -- * Template - The annotation utilizes the generic template of the
18139 -- related package declaration.
18141 -- * Globals - Capture of global references must occur after full
18144 -- * Instance - The annotation is instantiated automatically when
18145 -- the related generic package is instantiated.
18147 when Pragma_Initial_Condition => Initial_Condition : declare
18148 Pack_Decl : Node_Id;
18149 Pack_Id : Entity_Id;
18153 Check_No_Identifiers;
18154 Check_Arg_Count (1);
18156 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
18158 if not Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
18159 N_Package_Declaration)
18165 Pack_Id := Defining_Entity (Pack_Decl);
18167 -- A pragma that applies to a Ghost entity becomes Ghost for the
18168 -- purposes of legality checks and removal of ignored Ghost code.
18170 Mark_Ghost_Pragma (N, Pack_Id);
18172 -- Chain the pragma on the contract for further processing by
18173 -- Analyze_Initial_Condition_In_Decl_Part.
18175 Add_Contract_Item (N, Pack_Id);
18177 -- The legality checks of pragmas Abstract_State, Initializes, and
18178 -- Initial_Condition are affected by the SPARK mode in effect. In
18179 -- addition, these three pragmas are subject to an inherent order:
18181 -- 1) Abstract_State
18183 -- 3) Initial_Condition
18185 -- Analyze all these pragmas in the order outlined above
18187 Analyze_If_Present (Pragma_SPARK_Mode);
18188 Analyze_If_Present (Pragma_Abstract_State);
18189 Analyze_If_Present (Pragma_Initializes);
18190 end Initial_Condition;
18192 ------------------------
18193 -- Initialize_Scalars --
18194 ------------------------
18196 -- pragma Initialize_Scalars
18197 -- [ ( TYPE_VALUE_PAIR {, TYPE_VALUE_PAIR} ) ];
18199 -- TYPE_VALUE_PAIR ::=
18200 -- SCALAR_TYPE => static_EXPRESSION
18206 -- | Long_Long_Flat
18216 when Pragma_Initialize_Scalars => Do_Initialize_Scalars : declare
18217 Seen : array (Scalar_Id) of Node_Id := (others => Empty);
18218 -- This collection holds the individual pairs which specify the
18219 -- invalid values of their respective scalar types.
18221 procedure Analyze_Float_Value
18222 (Scal_Typ : Float_Scalar_Id;
18223 Val_Expr : Node_Id);
18224 -- Analyze a type value pair associated with float type Scal_Typ
18225 -- and expression Val_Expr.
18227 procedure Analyze_Integer_Value
18228 (Scal_Typ : Integer_Scalar_Id;
18229 Val_Expr : Node_Id);
18230 -- Analyze a type value pair associated with integer type Scal_Typ
18231 -- and expression Val_Expr.
18233 procedure Analyze_Type_Value_Pair (Pair : Node_Id);
18234 -- Analyze type value pair Pair
18236 -------------------------
18237 -- Analyze_Float_Value --
18238 -------------------------
18240 procedure Analyze_Float_Value
18241 (Scal_Typ : Float_Scalar_Id;
18242 Val_Expr : Node_Id)
18245 Analyze_And_Resolve (Val_Expr, Any_Real);
18247 if Is_OK_Static_Expression (Val_Expr) then
18248 Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value_R (Val_Expr));
18251 Error_Msg_Name_1 := Scal_Typ;
18252 Error_Msg_N ("value for type % must be static", Val_Expr);
18254 end Analyze_Float_Value;
18256 ---------------------------
18257 -- Analyze_Integer_Value --
18258 ---------------------------
18260 procedure Analyze_Integer_Value
18261 (Scal_Typ : Integer_Scalar_Id;
18262 Val_Expr : Node_Id)
18265 Analyze_And_Resolve (Val_Expr, Any_Integer);
18267 if Is_OK_Static_Expression (Val_Expr) then
18268 Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value (Val_Expr));
18271 Error_Msg_Name_1 := Scal_Typ;
18272 Error_Msg_N ("value for type % must be static", Val_Expr);
18274 end Analyze_Integer_Value;
18276 -----------------------------
18277 -- Analyze_Type_Value_Pair --
18278 -----------------------------
18280 procedure Analyze_Type_Value_Pair (Pair : Node_Id) is
18281 Scal_Typ : constant Name_Id := Chars (Pair);
18282 Val_Expr : constant Node_Id := Expression (Pair);
18283 Prev_Pair : Node_Id;
18286 if Scal_Typ in Scalar_Id then
18287 Prev_Pair := Seen (Scal_Typ);
18289 -- Prevent multiple attempts to set a value for a scalar
18292 if Present (Prev_Pair) then
18293 Error_Msg_Name_1 := Scal_Typ;
18295 ("cannot specify multiple invalid values for type %",
18298 Error_Msg_Sloc := Sloc (Prev_Pair);
18299 Error_Msg_N ("previous value set #", Pair);
18301 -- Ignore the effects of the pair, but do not halt the
18302 -- analysis of the pragma altogether.
18306 -- Otherwise capture the first pair for this scalar type
18309 Seen (Scal_Typ) := Pair;
18312 if Scal_Typ in Float_Scalar_Id then
18313 Analyze_Float_Value (Scal_Typ, Val_Expr);
18315 else pragma Assert (Scal_Typ in Integer_Scalar_Id);
18316 Analyze_Integer_Value (Scal_Typ, Val_Expr);
18319 -- Otherwise the scalar family is illegal
18322 Error_Msg_Name_1 := Pname;
18324 ("argument of pragma % must denote valid scalar family",
18327 end Analyze_Type_Value_Pair;
18331 Pairs : constant List_Id := Pragma_Argument_Associations (N);
18334 -- Start of processing for Do_Initialize_Scalars
18338 Check_Valid_Configuration_Pragma;
18339 Check_Restriction (No_Initialize_Scalars, N);
18341 -- Ignore the effects of the pragma when No_Initialize_Scalars is
18344 if Restriction_Active (No_Initialize_Scalars) then
18347 -- Initialize_Scalars creates false positives in CodePeer, and
18348 -- incorrect negative results in GNATprove mode, so ignore this
18349 -- pragma in these modes.
18351 elsif CodePeer_Mode or GNATprove_Mode then
18354 -- Otherwise analyze the pragma
18357 if Present (Pairs) then
18359 -- Install Standard in order to provide access to primitive
18360 -- types in case the expressions contain attributes such as
18363 Push_Scope (Standard_Standard);
18365 Pair := First (Pairs);
18366 while Present (Pair) loop
18367 Analyze_Type_Value_Pair (Pair);
18376 Init_Or_Norm_Scalars := True;
18377 Initialize_Scalars := True;
18379 end Do_Initialize_Scalars;
18385 -- pragma Initializes (INITIALIZATION_LIST);
18387 -- INITIALIZATION_LIST ::=
18389 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
18391 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
18396 -- | (INPUT {, INPUT})
18400 -- Characteristics:
18402 -- * Analysis - The annotation undergoes initial checks to verify
18403 -- the legal placement and context. Secondary checks preanalyze the
18406 -- Analyze_Initializes_In_Decl_Part
18408 -- * Expansion - None.
18410 -- * Template - The annotation utilizes the generic template of the
18411 -- related package declaration.
18413 -- * Globals - Capture of global references must occur after full
18416 -- * Instance - The annotation is instantiated automatically when
18417 -- the related generic package is instantiated.
18419 when Pragma_Initializes => Initializes : declare
18420 Pack_Decl : Node_Id;
18421 Pack_Id : Entity_Id;
18425 Check_No_Identifiers;
18426 Check_Arg_Count (1);
18428 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
18430 if not Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
18431 N_Package_Declaration)
18437 Pack_Id := Defining_Entity (Pack_Decl);
18439 -- A pragma that applies to a Ghost entity becomes Ghost for the
18440 -- purposes of legality checks and removal of ignored Ghost code.
18442 Mark_Ghost_Pragma (N, Pack_Id);
18443 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
18445 -- Chain the pragma on the contract for further processing by
18446 -- Analyze_Initializes_In_Decl_Part.
18448 Add_Contract_Item (N, Pack_Id);
18450 -- The legality checks of pragmas Abstract_State, Initializes, and
18451 -- Initial_Condition are affected by the SPARK mode in effect. In
18452 -- addition, these three pragmas are subject to an inherent order:
18454 -- 1) Abstract_State
18456 -- 3) Initial_Condition
18458 -- Analyze all these pragmas in the order outlined above
18460 Analyze_If_Present (Pragma_SPARK_Mode);
18461 Analyze_If_Present (Pragma_Abstract_State);
18462 Analyze_If_Present (Pragma_Initial_Condition);
18469 -- pragma Inline ( NAME {, NAME} );
18471 when Pragma_Inline =>
18473 -- Pragma always active unless in GNATprove mode. It is disabled
18474 -- in GNATprove mode because frontend inlining is applied
18475 -- independently of pragmas Inline and Inline_Always for
18476 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
18479 if not GNATprove_Mode then
18481 -- Inline status is Enabled if option -gnatn is specified.
18482 -- However this status determines only the value of the
18483 -- Is_Inlined flag on the subprogram and does not prevent
18484 -- the pragma itself from being recorded for later use,
18485 -- in particular for a later modification of Is_Inlined
18486 -- independently of the -gnatn option.
18488 -- In other words, if -gnatn is specified for a unit, then
18489 -- all Inline pragmas processed for the compilation of this
18490 -- unit, including those in the spec of other units, are
18491 -- activated, so subprograms will be inlined across units.
18493 -- If -gnatn is not specified, no Inline pragma is activated
18494 -- here, which means that subprograms will not be inlined
18495 -- across units. The Is_Inlined flag will nevertheless be
18496 -- set later when bodies are analyzed, so subprograms will
18497 -- be inlined within the unit.
18499 if Inline_Active then
18500 Process_Inline (Enabled);
18502 Process_Inline (Disabled);
18506 -------------------
18507 -- Inline_Always --
18508 -------------------
18510 -- pragma Inline_Always ( NAME {, NAME} );
18512 when Pragma_Inline_Always =>
18515 -- Pragma always active unless in CodePeer mode or GNATprove
18516 -- mode. It is disabled in CodePeer mode because inlining is
18517 -- not helpful, and enabling it caused walk order issues. It
18518 -- is disabled in GNATprove mode because frontend inlining is
18519 -- applied independently of pragmas Inline and Inline_Always for
18520 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
18523 if not CodePeer_Mode and not GNATprove_Mode then
18524 Process_Inline (Enabled);
18527 --------------------
18528 -- Inline_Generic --
18529 --------------------
18531 -- pragma Inline_Generic (NAME {, NAME});
18533 when Pragma_Inline_Generic =>
18535 Process_Generic_List;
18537 ----------------------
18538 -- Inspection_Point --
18539 ----------------------
18541 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
18543 when Pragma_Inspection_Point => Inspection_Point : declare
18550 if Arg_Count > 0 then
18553 Exp := Get_Pragma_Arg (Arg);
18556 if not Is_Entity_Name (Exp)
18557 or else not Is_Object (Entity (Exp))
18559 Error_Pragma_Arg ("object name required", Arg);
18563 exit when No (Arg);
18566 end Inspection_Point;
18572 -- pragma Interface (
18573 -- [ Convention =>] convention_IDENTIFIER,
18574 -- [ Entity =>] LOCAL_NAME
18575 -- [, [External_Name =>] static_string_EXPRESSION ]
18576 -- [, [Link_Name =>] static_string_EXPRESSION ]);
18578 when Pragma_Interface =>
18583 Name_External_Name,
18585 Check_At_Least_N_Arguments (2);
18586 Check_At_Most_N_Arguments (4);
18587 Process_Import_Or_Interface;
18589 -- In Ada 2005, the permission to use Interface (a reserved word)
18590 -- as a pragma name is considered an obsolescent feature, and this
18591 -- pragma was already obsolescent in Ada 95.
18593 if Ada_Version >= Ada_95 then
18595 (No_Obsolescent_Features, Pragma_Identifier (N));
18597 if Warn_On_Obsolescent_Feature then
18599 ("pragma Interface is an obsolescent feature?j?", N);
18601 ("|use pragma Import instead?j?", N);
18605 --------------------
18606 -- Interface_Name --
18607 --------------------
18609 -- pragma Interface_Name (
18610 -- [ Entity =>] LOCAL_NAME
18611 -- [,[External_Name =>] static_string_EXPRESSION ]
18612 -- [,[Link_Name =>] static_string_EXPRESSION ]);
18614 when Pragma_Interface_Name => Interface_Name : declare
18616 Def_Id : Entity_Id;
18617 Hom_Id : Entity_Id;
18623 ((Name_Entity, Name_External_Name, Name_Link_Name));
18624 Check_At_Least_N_Arguments (2);
18625 Check_At_Most_N_Arguments (3);
18626 Id := Get_Pragma_Arg (Arg1);
18629 -- This is obsolete from Ada 95 on, but it is an implementation
18630 -- defined pragma, so we do not consider that it violates the
18631 -- restriction (No_Obsolescent_Features).
18633 if Ada_Version >= Ada_95 then
18634 if Warn_On_Obsolescent_Feature then
18636 ("pragma Interface_Name is an obsolescent feature?j?", N);
18638 ("|use pragma Import instead?j?", N);
18642 if not Is_Entity_Name (Id) then
18644 ("first argument for pragma% must be entity name", Arg1);
18645 elsif Etype (Id) = Any_Type then
18648 Def_Id := Entity (Id);
18651 -- Special DEC-compatible processing for the object case, forces
18652 -- object to be imported.
18654 if Ekind (Def_Id) = E_Variable then
18655 Kill_Size_Check_Code (Def_Id);
18656 Note_Possible_Modification (Id, Sure => False);
18658 -- Initialization is not allowed for imported variable
18660 if Present (Expression (Parent (Def_Id)))
18661 and then Comes_From_Source (Expression (Parent (Def_Id)))
18663 Error_Msg_Sloc := Sloc (Def_Id);
18665 ("no initialization allowed for declaration of& #",
18669 -- For compatibility, support VADS usage of providing both
18670 -- pragmas Interface and Interface_Name to obtain the effect
18671 -- of a single Import pragma.
18673 if Is_Imported (Def_Id)
18674 and then Present (First_Rep_Item (Def_Id))
18675 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
18676 and then Pragma_Name (First_Rep_Item (Def_Id)) =
18681 Set_Imported (Def_Id);
18684 Set_Is_Public (Def_Id);
18685 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
18688 -- Otherwise must be subprogram
18690 elsif not Is_Subprogram (Def_Id) then
18692 ("argument of pragma% is not subprogram", Arg1);
18695 Check_At_Most_N_Arguments (3);
18699 -- Loop through homonyms
18702 Def_Id := Get_Base_Subprogram (Hom_Id);
18704 if Is_Imported (Def_Id) then
18705 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
18709 exit when From_Aspect_Specification (N);
18710 Hom_Id := Homonym (Hom_Id);
18712 exit when No (Hom_Id)
18713 or else Scope (Hom_Id) /= Current_Scope;
18718 ("argument of pragma% is not imported subprogram",
18722 end Interface_Name;
18724 -----------------------
18725 -- Interrupt_Handler --
18726 -----------------------
18728 -- pragma Interrupt_Handler (handler_NAME);
18730 when Pragma_Interrupt_Handler =>
18731 Check_Ada_83_Warning;
18732 Check_Arg_Count (1);
18733 Check_No_Identifiers;
18735 if No_Run_Time_Mode then
18736 Error_Msg_CRT ("Interrupt_Handler pragma", N);
18738 Check_Interrupt_Or_Attach_Handler;
18739 Process_Interrupt_Or_Attach_Handler;
18742 ------------------------
18743 -- Interrupt_Priority --
18744 ------------------------
18746 -- pragma Interrupt_Priority [(EXPRESSION)];
18748 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
18749 P : constant Node_Id := Parent (N);
18754 Check_Ada_83_Warning;
18756 if Arg_Count /= 0 then
18757 Arg := Get_Pragma_Arg (Arg1);
18758 Check_Arg_Count (1);
18759 Check_No_Identifiers;
18761 -- The expression must be analyzed in the special manner
18762 -- described in "Handling of Default and Per-Object
18763 -- Expressions" in sem.ads.
18765 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
18768 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
18773 Ent := Defining_Identifier (Parent (P));
18775 -- Check duplicate pragma before we chain the pragma in the Rep
18776 -- Item chain of Ent.
18778 Check_Duplicate_Pragma (Ent);
18779 Record_Rep_Item (Ent, N);
18781 -- Check the No_Task_At_Interrupt_Priority restriction
18783 if Nkind (P) = N_Task_Definition then
18784 Check_Restriction (No_Task_At_Interrupt_Priority, N);
18787 end Interrupt_Priority;
18789 ---------------------
18790 -- Interrupt_State --
18791 ---------------------
18793 -- pragma Interrupt_State (
18794 -- [Name =>] INTERRUPT_ID,
18795 -- [State =>] INTERRUPT_STATE);
18797 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
18798 -- INTERRUPT_STATE => System | Runtime | User
18800 -- Note: if the interrupt id is given as an identifier, then it must
18801 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
18802 -- given as a static integer expression which must be in the range of
18803 -- Ada.Interrupts.Interrupt_ID.
18805 when Pragma_Interrupt_State => Interrupt_State : declare
18806 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
18807 -- This is the entity Ada.Interrupts.Interrupt_ID;
18809 State_Type : Character;
18810 -- Set to 's'/'r'/'u' for System/Runtime/User
18813 -- Index to entry in Interrupt_States table
18816 -- Value of interrupt
18818 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
18819 -- The first argument to the pragma
18821 Int_Ent : Entity_Id;
18822 -- Interrupt entity in Ada.Interrupts.Names
18826 Check_Arg_Order ((Name_Name, Name_State));
18827 Check_Arg_Count (2);
18829 Check_Optional_Identifier (Arg1, Name_Name);
18830 Check_Optional_Identifier (Arg2, Name_State);
18831 Check_Arg_Is_Identifier (Arg2);
18833 -- First argument is identifier
18835 if Nkind (Arg1X) = N_Identifier then
18837 -- Search list of names in Ada.Interrupts.Names
18839 Int_Ent := First_Entity (RTE (RE_Names));
18841 if No (Int_Ent) then
18842 Error_Pragma_Arg ("invalid interrupt name", Arg1);
18844 elsif Chars (Int_Ent) = Chars (Arg1X) then
18845 Int_Val := Expr_Value (Constant_Value (Int_Ent));
18849 Next_Entity (Int_Ent);
18852 -- First argument is not an identifier, so it must be a static
18853 -- expression of type Ada.Interrupts.Interrupt_ID.
18856 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
18857 Int_Val := Expr_Value (Arg1X);
18859 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
18861 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
18864 ("value not in range of type "
18865 & """Ada.Interrupts.Interrupt_'I'D""", Arg1);
18871 case Chars (Get_Pragma_Arg (Arg2)) is
18872 when Name_Runtime => State_Type := 'r';
18873 when Name_System => State_Type := 's';
18874 when Name_User => State_Type := 'u';
18877 Error_Pragma_Arg ("invalid interrupt state", Arg2);
18880 -- Check if entry is already stored
18882 IST_Num := Interrupt_States.First;
18884 -- If entry not found, add it
18886 if IST_Num > Interrupt_States.Last then
18887 Interrupt_States.Append
18888 ((Interrupt_Number => UI_To_Int (Int_Val),
18889 Interrupt_State => State_Type,
18890 Pragma_Loc => Loc));
18893 -- Case of entry for the same entry
18895 elsif Int_Val = Interrupt_States.Table (IST_Num).
18898 -- If state matches, done, no need to make redundant entry
18901 State_Type = Interrupt_States.Table (IST_Num).
18904 -- Otherwise if state does not match, error
18907 Interrupt_States.Table (IST_Num).Pragma_Loc;
18909 ("state conflicts with that given #", Arg2);
18913 IST_Num := IST_Num + 1;
18915 end Interrupt_State;
18921 -- pragma Invariant
18922 -- ([Entity =>] type_LOCAL_NAME,
18923 -- [Check =>] EXPRESSION
18924 -- [,[Message =>] String_Expression]);
18926 when Pragma_Invariant => Invariant : declare
18933 Check_At_Least_N_Arguments (2);
18934 Check_At_Most_N_Arguments (3);
18935 Check_Optional_Identifier (Arg1, Name_Entity);
18936 Check_Optional_Identifier (Arg2, Name_Check);
18938 if Arg_Count = 3 then
18939 Check_Optional_Identifier (Arg3, Name_Message);
18940 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
18943 Check_Arg_Is_Local_Name (Arg1);
18945 Typ_Arg := Get_Pragma_Arg (Arg1);
18946 Find_Type (Typ_Arg);
18947 Typ := Entity (Typ_Arg);
18949 -- Nothing to do of the related type is erroneous in some way
18951 if Typ = Any_Type then
18954 -- AI12-0041: Invariants are allowed in interface types
18956 elsif Is_Interface (Typ) then
18959 -- An invariant must apply to a private type, or appear in the
18960 -- private part of a package spec and apply to a completion.
18961 -- a class-wide invariant can only appear on a private declaration
18962 -- or private extension, not a completion.
18964 -- A [class-wide] invariant may be associated a [limited] private
18965 -- type or a private extension.
18967 elsif Ekind_In (Typ, E_Limited_Private_Type,
18969 E_Record_Type_With_Private)
18973 -- A non-class-wide invariant may be associated with the full view
18974 -- of a [limited] private type or a private extension.
18976 elsif Has_Private_Declaration (Typ)
18977 and then not Class_Present (N)
18981 -- A class-wide invariant may appear on the partial view only
18983 elsif Class_Present (N) then
18985 ("pragma % only allowed for private type", Arg1);
18988 -- A regular invariant may appear on both views
18992 ("pragma % only allowed for private type or corresponding "
18993 & "full view", Arg1);
18997 -- An invariant associated with an abstract type (this includes
18998 -- interfaces) must be class-wide.
19000 if Is_Abstract_Type (Typ) and then not Class_Present (N) then
19002 ("pragma % not allowed for abstract type", Arg1);
19006 -- A pragma that applies to a Ghost entity becomes Ghost for the
19007 -- purposes of legality checks and removal of ignored Ghost code.
19009 Mark_Ghost_Pragma (N, Typ);
19011 -- The pragma defines a type-specific invariant, the type is said
19012 -- to have invariants of its "own".
19014 Set_Has_Own_Invariants (Typ);
19016 -- Set the Invariants_Ignored flag if that policy is in effect
19018 Set_Invariants_Ignored (Typ,
19019 Present (Check_Policy_List)
19021 (Policy_In_Effect (Name_Invariant) = Name_Ignore
19023 Policy_In_Effect (Name_Type_Invariant) = Name_Ignore));
19025 -- If the invariant is class-wide, then it can be inherited by
19026 -- derived or interface implementing types. The type is said to
19027 -- have "inheritable" invariants.
19029 if Class_Present (N) then
19030 Set_Has_Inheritable_Invariants (Typ);
19033 -- Chain the pragma on to the rep item chain, for processing when
19034 -- the type is frozen.
19036 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
19038 -- Create the declaration of the invariant procedure that will
19039 -- verify the invariant at run time. Interfaces are treated as the
19040 -- partial view of a private type in order to achieve uniformity
19041 -- with the general case. As a result, an interface receives only
19042 -- a "partial" invariant procedure, which is never called.
19044 Build_Invariant_Procedure_Declaration
19046 Partial_Invariant => Is_Interface (Typ));
19053 -- pragma Keep_Names ([On => ] LOCAL_NAME);
19055 when Pragma_Keep_Names => Keep_Names : declare
19060 Check_Arg_Count (1);
19061 Check_Optional_Identifier (Arg1, Name_On);
19062 Check_Arg_Is_Local_Name (Arg1);
19064 Arg := Get_Pragma_Arg (Arg1);
19067 if Etype (Arg) = Any_Type then
19071 if not Is_Entity_Name (Arg)
19072 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
19075 ("pragma% requires a local enumeration type", Arg1);
19078 Set_Discard_Names (Entity (Arg), False);
19085 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
19087 when Pragma_License =>
19090 -- Do not analyze pragma any further in CodePeer mode, to avoid
19091 -- extraneous errors in this implementation-dependent pragma,
19092 -- which has a different profile on other compilers.
19094 if CodePeer_Mode then
19098 Check_Arg_Count (1);
19099 Check_No_Identifiers;
19100 Check_Valid_Configuration_Pragma;
19101 Check_Arg_Is_Identifier (Arg1);
19104 Sind : constant Source_File_Index :=
19105 Source_Index (Current_Sem_Unit);
19108 case Chars (Get_Pragma_Arg (Arg1)) is
19110 Set_License (Sind, GPL);
19112 when Name_Modified_GPL =>
19113 Set_License (Sind, Modified_GPL);
19115 when Name_Restricted =>
19116 Set_License (Sind, Restricted);
19118 when Name_Unrestricted =>
19119 Set_License (Sind, Unrestricted);
19122 Error_Pragma_Arg ("invalid license name", Arg1);
19130 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
19132 when Pragma_Link_With => Link_With : declare
19138 if Operating_Mode = Generate_Code
19139 and then In_Extended_Main_Source_Unit (N)
19141 Check_At_Least_N_Arguments (1);
19142 Check_No_Identifiers;
19143 Check_Is_In_Decl_Part_Or_Package_Spec;
19144 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
19148 while Present (Arg) loop
19149 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
19151 -- Store argument, converting sequences of spaces to a
19152 -- single null character (this is one of the differences
19153 -- in processing between Link_With and Linker_Options).
19155 Arg_Store : declare
19156 C : constant Char_Code := Get_Char_Code (' ');
19157 S : constant String_Id :=
19158 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
19159 L : constant Nat := String_Length (S);
19162 procedure Skip_Spaces;
19163 -- Advance F past any spaces
19169 procedure Skip_Spaces is
19171 while F <= L and then Get_String_Char (S, F) = C loop
19176 -- Start of processing for Arg_Store
19179 Skip_Spaces; -- skip leading spaces
19181 -- Loop through characters, changing any embedded
19182 -- sequence of spaces to a single null character (this
19183 -- is how Link_With/Linker_Options differ)
19186 if Get_String_Char (S, F) = C then
19189 Store_String_Char (ASCII.NUL);
19192 Store_String_Char (Get_String_Char (S, F));
19200 if Present (Arg) then
19201 Store_String_Char (ASCII.NUL);
19205 Store_Linker_Option_String (End_String);
19213 -- pragma Linker_Alias (
19214 -- [Entity =>] LOCAL_NAME
19215 -- [Target =>] static_string_EXPRESSION);
19217 when Pragma_Linker_Alias =>
19219 Check_Arg_Order ((Name_Entity, Name_Target));
19220 Check_Arg_Count (2);
19221 Check_Optional_Identifier (Arg1, Name_Entity);
19222 Check_Optional_Identifier (Arg2, Name_Target);
19223 Check_Arg_Is_Library_Level_Local_Name (Arg1);
19224 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
19226 -- The only processing required is to link this item on to the
19227 -- list of rep items for the given entity. This is accomplished
19228 -- by the call to Rep_Item_Too_Late (when no error is detected
19229 -- and False is returned).
19231 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
19234 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
19237 ------------------------
19238 -- Linker_Constructor --
19239 ------------------------
19241 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
19243 -- Code is shared with Linker_Destructor
19245 -----------------------
19246 -- Linker_Destructor --
19247 -----------------------
19249 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
19251 when Pragma_Linker_Constructor
19252 | Pragma_Linker_Destructor
19254 Linker_Constructor : declare
19260 Check_Arg_Count (1);
19261 Check_No_Identifiers;
19262 Check_Arg_Is_Local_Name (Arg1);
19263 Arg1_X := Get_Pragma_Arg (Arg1);
19265 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
19267 if not Is_Library_Level_Entity (Proc) then
19269 ("argument for pragma% must be library level entity", Arg1);
19272 -- The only processing required is to link this item on to the
19273 -- list of rep items for the given entity. This is accomplished
19274 -- by the call to Rep_Item_Too_Late (when no error is detected
19275 -- and False is returned).
19277 if Rep_Item_Too_Late (Proc, N) then
19280 Set_Has_Gigi_Rep_Item (Proc);
19282 end Linker_Constructor;
19284 --------------------
19285 -- Linker_Options --
19286 --------------------
19288 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
19290 when Pragma_Linker_Options => Linker_Options : declare
19294 Check_Ada_83_Warning;
19295 Check_No_Identifiers;
19296 Check_Arg_Count (1);
19297 Check_Is_In_Decl_Part_Or_Package_Spec;
19298 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
19299 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
19302 while Present (Arg) loop
19303 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
19304 Store_String_Char (ASCII.NUL);
19306 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
19310 if Operating_Mode = Generate_Code
19311 and then In_Extended_Main_Source_Unit (N)
19313 Store_Linker_Option_String (End_String);
19315 end Linker_Options;
19317 --------------------
19318 -- Linker_Section --
19319 --------------------
19321 -- pragma Linker_Section (
19322 -- [Entity =>] LOCAL_NAME
19323 -- [Section =>] static_string_EXPRESSION);
19325 when Pragma_Linker_Section => Linker_Section : declare
19330 Ghost_Error_Posted : Boolean := False;
19331 -- Flag set when an error concerning the illegal mix of Ghost and
19332 -- non-Ghost subprograms is emitted.
19334 Ghost_Id : Entity_Id := Empty;
19335 -- The entity of the first Ghost subprogram encountered while
19336 -- processing the arguments of the pragma.
19340 Check_Arg_Order ((Name_Entity, Name_Section));
19341 Check_Arg_Count (2);
19342 Check_Optional_Identifier (Arg1, Name_Entity);
19343 Check_Optional_Identifier (Arg2, Name_Section);
19344 Check_Arg_Is_Library_Level_Local_Name (Arg1);
19345 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
19347 -- Check kind of entity
19349 Arg := Get_Pragma_Arg (Arg1);
19350 Ent := Entity (Arg);
19352 case Ekind (Ent) is
19354 -- Objects (constants and variables) and types. For these cases
19355 -- all we need to do is to set the Linker_Section_pragma field,
19356 -- checking that we do not have a duplicate.
19362 LPE := Linker_Section_Pragma (Ent);
19364 if Present (LPE) then
19365 Error_Msg_Sloc := Sloc (LPE);
19367 ("Linker_Section already specified for &#", Arg1, Ent);
19370 Set_Linker_Section_Pragma (Ent, N);
19372 -- A pragma that applies to a Ghost entity becomes Ghost for
19373 -- the purposes of legality checks and removal of ignored
19376 Mark_Ghost_Pragma (N, Ent);
19380 when Subprogram_Kind =>
19382 -- Aspect case, entity already set
19384 if From_Aspect_Specification (N) then
19385 Set_Linker_Section_Pragma
19386 (Entity (Corresponding_Aspect (N)), N);
19388 -- Propagate it to its ultimate aliased entity to
19389 -- facilitate the backend processing this attribute
19390 -- in instantiations of generic subprograms.
19392 if Present (Alias (Entity (Corresponding_Aspect (N))))
19394 Set_Linker_Section_Pragma
19396 (Entity (Corresponding_Aspect (N))), N);
19399 -- Pragma case, we must climb the homonym chain, but skip
19400 -- any for which the linker section is already set.
19404 if No (Linker_Section_Pragma (Ent)) then
19405 Set_Linker_Section_Pragma (Ent, N);
19407 -- Propagate it to its ultimate aliased entity to
19408 -- facilitate the backend processing this attribute
19409 -- in instantiations of generic subprograms.
19411 if Present (Alias (Ent)) then
19412 Set_Linker_Section_Pragma
19413 (Ultimate_Alias (Ent), N);
19416 -- A pragma that applies to a Ghost entity becomes
19417 -- Ghost for the purposes of legality checks and
19418 -- removal of ignored Ghost code.
19420 Mark_Ghost_Pragma (N, Ent);
19422 -- Capture the entity of the first Ghost subprogram
19423 -- being processed for error detection purposes.
19425 if Is_Ghost_Entity (Ent) then
19426 if No (Ghost_Id) then
19430 -- Otherwise the subprogram is non-Ghost. It is
19431 -- illegal to mix references to Ghost and non-Ghost
19432 -- entities (SPARK RM 6.9).
19434 elsif Present (Ghost_Id)
19435 and then not Ghost_Error_Posted
19437 Ghost_Error_Posted := True;
19439 Error_Msg_Name_1 := Pname;
19441 ("pragma % cannot mention ghost and "
19442 & "non-ghost subprograms", N);
19444 Error_Msg_Sloc := Sloc (Ghost_Id);
19446 ("\& # declared as ghost", N, Ghost_Id);
19448 Error_Msg_Sloc := Sloc (Ent);
19450 ("\& # declared as non-ghost", N, Ent);
19454 Ent := Homonym (Ent);
19456 or else Scope (Ent) /= Current_Scope;
19460 -- All other cases are illegal
19464 ("pragma% applies only to objects, subprograms, and types",
19467 end Linker_Section;
19473 -- pragma List (On | Off)
19475 -- There is nothing to do here, since we did all the processing for
19476 -- this pragma in Par.Prag (so that it works properly even in syntax
19479 when Pragma_List =>
19486 -- pragma Lock_Free [(Boolean_EXPRESSION)];
19488 when Pragma_Lock_Free => Lock_Free : declare
19489 P : constant Node_Id := Parent (N);
19495 Check_No_Identifiers;
19496 Check_At_Most_N_Arguments (1);
19498 -- Protected definition case
19500 if Nkind (P) = N_Protected_Definition then
19501 Ent := Defining_Identifier (Parent (P));
19505 if Arg_Count = 1 then
19506 Arg := Get_Pragma_Arg (Arg1);
19507 Val := Is_True (Static_Boolean (Arg));
19509 -- No arguments (expression is considered to be True)
19515 -- Check duplicate pragma before we chain the pragma in the Rep
19516 -- Item chain of Ent.
19518 Check_Duplicate_Pragma (Ent);
19519 Record_Rep_Item (Ent, N);
19520 Set_Uses_Lock_Free (Ent, Val);
19522 -- Anything else is incorrect placement
19529 --------------------
19530 -- Locking_Policy --
19531 --------------------
19533 -- pragma Locking_Policy (policy_IDENTIFIER);
19535 when Pragma_Locking_Policy => declare
19536 subtype LP_Range is Name_Id
19537 range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
19542 Check_Ada_83_Warning;
19543 Check_Arg_Count (1);
19544 Check_No_Identifiers;
19545 Check_Arg_Is_Locking_Policy (Arg1);
19546 Check_Valid_Configuration_Pragma;
19547 LP_Val := Chars (Get_Pragma_Arg (Arg1));
19550 when Name_Ceiling_Locking => LP := 'C';
19551 when Name_Concurrent_Readers_Locking => LP := 'R';
19552 when Name_Inheritance_Locking => LP := 'I';
19555 if Locking_Policy /= ' '
19556 and then Locking_Policy /= LP
19558 Error_Msg_Sloc := Locking_Policy_Sloc;
19559 Error_Pragma ("locking policy incompatible with policy#");
19561 -- Set new policy, but always preserve System_Location since we
19562 -- like the error message with the run time name.
19565 Locking_Policy := LP;
19567 if Locking_Policy_Sloc /= System_Location then
19568 Locking_Policy_Sloc := Loc;
19573 -------------------
19574 -- Loop_Optimize --
19575 -------------------
19577 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
19579 -- OPTIMIZATION_HINT ::=
19580 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
19582 when Pragma_Loop_Optimize => Loop_Optimize : declare
19587 Check_At_Least_N_Arguments (1);
19588 Check_No_Identifiers;
19590 Hint := First (Pragma_Argument_Associations (N));
19591 while Present (Hint) loop
19592 Check_Arg_Is_One_Of (Hint, Name_Ivdep,
19600 Check_Loop_Pragma_Placement;
19607 -- pragma Loop_Variant
19608 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
19610 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
19612 -- CHANGE_DIRECTION ::= Increases | Decreases
19614 when Pragma_Loop_Variant => Loop_Variant : declare
19619 Check_At_Least_N_Arguments (1);
19620 Check_Loop_Pragma_Placement;
19622 -- Process all increasing / decreasing expressions
19624 Variant := First (Pragma_Argument_Associations (N));
19625 while Present (Variant) loop
19626 if Chars (Variant) = No_Name then
19627 Error_Pragma_Arg_Ident ("expect name `Increases`", Variant);
19629 elsif not Nam_In (Chars (Variant), Name_Decreases,
19633 Name : String := Get_Name_String (Chars (Variant));
19636 -- It is a common mistake to write "Increasing" for
19637 -- "Increases" or "Decreasing" for "Decreases". Recognize
19638 -- specially names starting with "incr" or "decr" to
19639 -- suggest the corresponding name.
19641 System.Case_Util.To_Lower (Name);
19643 if Name'Length >= 4
19644 and then Name (1 .. 4) = "incr"
19646 Error_Pragma_Arg_Ident
19647 ("expect name `Increases`", Variant);
19649 elsif Name'Length >= 4
19650 and then Name (1 .. 4) = "decr"
19652 Error_Pragma_Arg_Ident
19653 ("expect name `Decreases`", Variant);
19656 Error_Pragma_Arg_Ident
19657 ("expect name `Increases` or `Decreases`", Variant);
19662 Preanalyze_Assert_Expression
19663 (Expression (Variant), Any_Discrete);
19669 -----------------------
19670 -- Machine_Attribute --
19671 -----------------------
19673 -- pragma Machine_Attribute (
19674 -- [Entity =>] LOCAL_NAME,
19675 -- [Attribute_Name =>] static_string_EXPRESSION
19676 -- [, [Info =>] static_EXPRESSION {, static_EXPRESSION}] );
19678 when Pragma_Machine_Attribute => Machine_Attribute : declare
19680 Def_Id : Entity_Id;
19684 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
19686 if Arg_Count >= 3 then
19687 Check_Optional_Identifier (Arg3, Name_Info);
19689 while Present (Arg) loop
19690 Check_Arg_Is_OK_Static_Expression (Arg);
19694 Check_Arg_Count (2);
19697 Check_Optional_Identifier (Arg1, Name_Entity);
19698 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
19699 Check_Arg_Is_Local_Name (Arg1);
19700 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
19701 Def_Id := Entity (Get_Pragma_Arg (Arg1));
19703 if Is_Access_Type (Def_Id) then
19704 Def_Id := Designated_Type (Def_Id);
19707 if Rep_Item_Too_Early (Def_Id, N) then
19711 Def_Id := Underlying_Type (Def_Id);
19713 -- The only processing required is to link this item on to the
19714 -- list of rep items for the given entity. This is accomplished
19715 -- by the call to Rep_Item_Too_Late (when no error is detected
19716 -- and False is returned).
19718 if Rep_Item_Too_Late (Def_Id, N) then
19721 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
19723 end Machine_Attribute;
19730 -- (MAIN_OPTION [, MAIN_OPTION]);
19733 -- [STACK_SIZE =>] static_integer_EXPRESSION
19734 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
19735 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
19737 when Pragma_Main => Main : declare
19738 Args : Args_List (1 .. 3);
19739 Names : constant Name_List (1 .. 3) := (
19741 Name_Task_Stack_Size_Default,
19742 Name_Time_Slicing_Enabled);
19748 Gather_Associations (Names, Args);
19750 for J in 1 .. 2 loop
19751 if Present (Args (J)) then
19752 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
19756 if Present (Args (3)) then
19757 Check_Arg_Is_OK_Static_Expression (Args (3), Standard_Boolean);
19761 while Present (Nod) loop
19762 if Nkind (Nod) = N_Pragma
19763 and then Pragma_Name (Nod) = Name_Main
19765 Error_Msg_Name_1 := Pname;
19766 Error_Msg_N ("duplicate pragma% not permitted", Nod);
19777 -- pragma Main_Storage
19778 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
19780 -- MAIN_STORAGE_OPTION ::=
19781 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
19782 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
19784 when Pragma_Main_Storage => Main_Storage : declare
19785 Args : Args_List (1 .. 2);
19786 Names : constant Name_List (1 .. 2) := (
19787 Name_Working_Storage,
19794 Gather_Associations (Names, Args);
19796 for J in 1 .. 2 loop
19797 if Present (Args (J)) then
19798 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
19802 Check_In_Main_Program;
19805 while Present (Nod) loop
19806 if Nkind (Nod) = N_Pragma
19807 and then Pragma_Name (Nod) = Name_Main_Storage
19809 Error_Msg_Name_1 := Pname;
19810 Error_Msg_N ("duplicate pragma% not permitted", Nod);
19817 ----------------------------
19818 -- Max_Entry_Queue_Length --
19819 ----------------------------
19821 -- pragma Max_Entry_Queue_Length (static_integer_EXPRESSION);
19823 -- This processing is shared by Pragma_Max_Entry_Queue_Depth and
19824 -- Pragma_Max_Queue_Length.
19826 when Pragma_Max_Entry_Queue_Length
19827 | Pragma_Max_Entry_Queue_Depth
19828 | Pragma_Max_Queue_Length
19830 Max_Entry_Queue_Length : declare
19832 Entry_Decl : Node_Id;
19833 Entry_Id : Entity_Id;
19837 if Prag_Id = Pragma_Max_Entry_Queue_Depth
19838 or else Prag_Id = Pragma_Max_Queue_Length
19843 Check_Arg_Count (1);
19846 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
19848 -- Entry declaration
19850 if Nkind (Entry_Decl) = N_Entry_Declaration then
19852 -- Entry illegally within a task
19854 if Nkind (Parent (N)) = N_Task_Definition then
19855 Error_Pragma ("pragma % cannot apply to task entries");
19859 Entry_Id := Defining_Entity (Entry_Decl);
19861 -- Otherwise the pragma is associated with an illegal construct
19864 Error_Pragma ("pragma % must apply to a protected entry");
19868 -- Mark the pragma as Ghost if the related subprogram is also
19869 -- Ghost. This also ensures that any expansion performed further
19870 -- below will produce Ghost nodes.
19872 Mark_Ghost_Pragma (N, Entry_Id);
19874 -- Analyze the Integer expression
19876 Arg := Get_Pragma_Arg (Arg1);
19877 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
19879 Val := Expr_Value (Arg);
19883 ("argument for pragma% cannot be less than -1", Arg1);
19885 elsif not UI_Is_In_Int_Range (Val) then
19887 ("argument for pragma% out of range of Integer", Arg1);
19891 Record_Rep_Item (Entry_Id, N);
19892 end Max_Entry_Queue_Length;
19898 -- pragma Memory_Size (NUMERIC_LITERAL)
19900 when Pragma_Memory_Size =>
19903 -- Memory size is simply ignored
19905 Check_No_Identifiers;
19906 Check_Arg_Count (1);
19907 Check_Arg_Is_Integer_Literal (Arg1);
19915 -- The only correct use of this pragma is on its own in a file, in
19916 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
19917 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
19918 -- check for a file containing nothing but a No_Body pragma). If we
19919 -- attempt to process it during normal semantics processing, it means
19920 -- it was misplaced.
19922 when Pragma_No_Body =>
19926 -----------------------------
19927 -- No_Elaboration_Code_All --
19928 -----------------------------
19930 -- pragma No_Elaboration_Code_All;
19932 when Pragma_No_Elaboration_Code_All =>
19934 Check_Valid_Library_Unit_Pragma;
19936 if Nkind (N) = N_Null_Statement then
19940 -- Must appear for a spec or generic spec
19942 if not Nkind_In (Unit (Cunit (Current_Sem_Unit)),
19943 N_Generic_Package_Declaration,
19944 N_Generic_Subprogram_Declaration,
19945 N_Package_Declaration,
19946 N_Subprogram_Declaration)
19950 ("pragma% can only occur for package "
19951 & "or subprogram spec"));
19954 -- Set flag in unit table
19956 Set_No_Elab_Code_All (Current_Sem_Unit);
19958 -- Set restriction No_Elaboration_Code if this is the main unit
19960 if Current_Sem_Unit = Main_Unit then
19961 Set_Restriction (No_Elaboration_Code, N);
19964 -- If we are in the main unit or in an extended main source unit,
19965 -- then we also add it to the configuration restrictions so that
19966 -- it will apply to all units in the extended main source.
19968 if Current_Sem_Unit = Main_Unit
19969 or else In_Extended_Main_Source_Unit (N)
19971 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
19974 -- If in main extended unit, activate transitive with test
19976 if In_Extended_Main_Source_Unit (N) then
19977 Opt.No_Elab_Code_All_Pragma := N;
19980 -----------------------------
19981 -- No_Component_Reordering --
19982 -----------------------------
19984 -- pragma No_Component_Reordering [([Entity =>] type_LOCAL_NAME)];
19986 when Pragma_No_Component_Reordering => No_Comp_Reordering : declare
19992 Check_At_Most_N_Arguments (1);
19994 if Arg_Count = 0 then
19995 Check_Valid_Configuration_Pragma;
19996 Opt.No_Component_Reordering := True;
19999 Check_Optional_Identifier (Arg2, Name_Entity);
20000 Check_Arg_Is_Local_Name (Arg1);
20001 E_Id := Get_Pragma_Arg (Arg1);
20003 if Etype (E_Id) = Any_Type then
20007 E := Entity (E_Id);
20009 if not Is_Record_Type (E) then
20010 Error_Pragma_Arg ("pragma% requires record type", Arg1);
20013 Set_No_Reordering (Base_Type (E));
20015 end No_Comp_Reordering;
20017 --------------------------
20018 -- No_Heap_Finalization --
20019 --------------------------
20021 -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];
20023 when Pragma_No_Heap_Finalization => No_Heap_Finalization : declare
20024 Context : constant Node_Id := Parent (N);
20025 Typ_Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
20031 Check_No_Identifiers;
20033 -- The pragma appears in a configuration file
20035 if No (Context) then
20036 Check_Arg_Count (0);
20037 Check_Valid_Configuration_Pragma;
20039 -- Detect a duplicate pragma
20041 if Present (No_Heap_Finalization_Pragma) then
20044 Prev => No_Heap_Finalization_Pragma);
20048 No_Heap_Finalization_Pragma := N;
20050 -- Otherwise the pragma should be associated with a library-level
20051 -- named access-to-object type.
20054 Check_Arg_Count (1);
20055 Check_Arg_Is_Local_Name (Arg1);
20057 Find_Type (Typ_Arg);
20058 Typ := Entity (Typ_Arg);
20060 -- The type being subjected to the pragma is erroneous
20062 if Typ = Any_Type then
20063 Error_Pragma ("cannot find type referenced by pragma %");
20065 -- The pragma is applied to an incomplete or generic formal
20066 -- type way too early.
20068 elsif Rep_Item_Too_Early (Typ, N) then
20072 Typ := Underlying_Type (Typ);
20075 -- The pragma must apply to an access-to-object type
20077 if Ekind_In (Typ, E_Access_Type, E_General_Access_Type) then
20080 -- Give a detailed error message on all other access type kinds
20082 elsif Ekind (Typ) = E_Access_Protected_Subprogram_Type then
20084 ("pragma % cannot apply to access protected subprogram "
20087 elsif Ekind (Typ) = E_Access_Subprogram_Type then
20089 ("pragma % cannot apply to access subprogram type");
20091 elsif Is_Anonymous_Access_Type (Typ) then
20093 ("pragma % cannot apply to anonymous access type");
20095 -- Give a general error message in case the pragma applies to a
20096 -- non-access type.
20100 ("pragma % must apply to library level access type");
20103 -- At this point the argument denotes an access-to-object type.
20104 -- Ensure that the type is declared at the library level.
20106 if Is_Library_Level_Entity (Typ) then
20109 -- Quietly ignore an access-to-object type originally declared
20110 -- at the library level within a generic, but instantiated at
20111 -- a non-library level. As a result the access-to-object type
20112 -- "loses" its No_Heap_Finalization property.
20114 elsif In_Instance then
20119 ("pragma % must apply to library level access type");
20122 -- Detect a duplicate pragma
20124 if Present (No_Heap_Finalization_Pragma) then
20127 Prev => No_Heap_Finalization_Pragma);
20131 Prev := Get_Pragma (Typ, Pragma_No_Heap_Finalization);
20133 if Present (Prev) then
20141 Record_Rep_Item (Typ, N);
20143 end No_Heap_Finalization;
20149 -- pragma No_Inline ( NAME {, NAME} );
20151 when Pragma_No_Inline =>
20153 Process_Inline (Suppressed);
20159 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
20161 when Pragma_No_Return => No_Return : declare
20167 Ghost_Error_Posted : Boolean := False;
20168 -- Flag set when an error concerning the illegal mix of Ghost and
20169 -- non-Ghost subprograms is emitted.
20171 Ghost_Id : Entity_Id := Empty;
20172 -- The entity of the first Ghost procedure encountered while
20173 -- processing the arguments of the pragma.
20177 Check_At_Least_N_Arguments (1);
20179 -- Loop through arguments of pragma
20182 while Present (Arg) loop
20183 Check_Arg_Is_Local_Name (Arg);
20184 Id := Get_Pragma_Arg (Arg);
20187 if not Is_Entity_Name (Id) then
20188 Error_Pragma_Arg ("entity name required", Arg);
20191 if Etype (Id) = Any_Type then
20195 -- Loop to find matching procedures
20201 and then Scope (E) = Current_Scope
20203 if Ekind_In (E, E_Generic_Procedure, E_Procedure) then
20205 -- Check that the pragma is not applied to a body.
20206 -- First check the specless body case, to give a
20207 -- different error message. These checks do not apply
20208 -- if Relaxed_RM_Semantics, to accommodate other Ada
20209 -- compilers. Disable these checks under -gnatd.J.
20211 if not Debug_Flag_Dot_JJ then
20212 if Nkind (Parent (Declaration_Node (E))) =
20214 and then not Relaxed_RM_Semantics
20217 ("pragma% requires separate spec and must come "
20221 -- Now the "specful" body case
20223 if Rep_Item_Too_Late (E, N) then
20230 -- A pragma that applies to a Ghost entity becomes Ghost
20231 -- for the purposes of legality checks and removal of
20232 -- ignored Ghost code.
20234 Mark_Ghost_Pragma (N, E);
20236 -- Capture the entity of the first Ghost procedure being
20237 -- processed for error detection purposes.
20239 if Is_Ghost_Entity (E) then
20240 if No (Ghost_Id) then
20244 -- Otherwise the subprogram is non-Ghost. It is illegal
20245 -- to mix references to Ghost and non-Ghost entities
20248 elsif Present (Ghost_Id)
20249 and then not Ghost_Error_Posted
20251 Ghost_Error_Posted := True;
20253 Error_Msg_Name_1 := Pname;
20255 ("pragma % cannot mention ghost and non-ghost "
20256 & "procedures", N);
20258 Error_Msg_Sloc := Sloc (Ghost_Id);
20259 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
20261 Error_Msg_Sloc := Sloc (E);
20262 Error_Msg_NE ("\& # declared as non-ghost", N, E);
20265 -- Set flag on any alias as well
20267 if Is_Overloadable (E) and then Present (Alias (E)) then
20268 Set_No_Return (Alias (E));
20274 exit when From_Aspect_Specification (N);
20278 -- If entity in not in current scope it may be the enclosing
20279 -- suprogram body to which the aspect applies.
20282 if Entity (Id) = Current_Scope
20283 and then From_Aspect_Specification (N)
20285 Set_No_Return (Entity (Id));
20287 Error_Pragma_Arg ("no procedure& found for pragma%", Arg);
20299 -- pragma No_Run_Time;
20301 -- Note: this pragma is retained for backwards compatibility. See
20302 -- body of Rtsfind for full details on its handling.
20304 when Pragma_No_Run_Time =>
20306 Check_Valid_Configuration_Pragma;
20307 Check_Arg_Count (0);
20309 -- Remove backward compatibility if Build_Type is FSF or GPL and
20310 -- generate a warning.
20313 Ignore : constant Boolean := Build_Type in FSF .. GPL;
20316 Error_Pragma ("pragma% is ignored, has no effect??");
20318 No_Run_Time_Mode := True;
20319 Configurable_Run_Time_Mode := True;
20321 -- Set Duration to 32 bits if word size is 32
20323 if Ttypes.System_Word_Size = 32 then
20324 Duration_32_Bits_On_Target := True;
20327 -- Set appropriate restrictions
20329 Set_Restriction (No_Finalization, N);
20330 Set_Restriction (No_Exception_Handlers, N);
20331 Set_Restriction (Max_Tasks, N, 0);
20332 Set_Restriction (No_Tasking, N);
20336 -----------------------
20337 -- No_Tagged_Streams --
20338 -----------------------
20340 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
20342 when Pragma_No_Tagged_Streams => No_Tagged_Strms : declare
20348 Check_At_Most_N_Arguments (1);
20350 -- One argument case
20352 if Arg_Count = 1 then
20353 Check_Optional_Identifier (Arg1, Name_Entity);
20354 Check_Arg_Is_Local_Name (Arg1);
20355 E_Id := Get_Pragma_Arg (Arg1);
20357 if Etype (E_Id) = Any_Type then
20361 E := Entity (E_Id);
20363 Check_Duplicate_Pragma (E);
20365 if not Is_Tagged_Type (E) or else Is_Derived_Type (E) then
20367 ("argument for pragma% must be root tagged type", Arg1);
20370 if Rep_Item_Too_Early (E, N)
20372 Rep_Item_Too_Late (E, N)
20376 Set_No_Tagged_Streams_Pragma (E, N);
20379 -- Zero argument case
20382 Check_Is_In_Decl_Part_Or_Package_Spec;
20383 No_Tagged_Streams := N;
20385 end No_Tagged_Strms;
20387 ------------------------
20388 -- No_Strict_Aliasing --
20389 ------------------------
20391 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
20393 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
20399 Check_At_Most_N_Arguments (1);
20401 if Arg_Count = 0 then
20402 Check_Valid_Configuration_Pragma;
20403 Opt.No_Strict_Aliasing := True;
20406 Check_Optional_Identifier (Arg2, Name_Entity);
20407 Check_Arg_Is_Local_Name (Arg1);
20408 E_Id := Get_Pragma_Arg (Arg1);
20410 if Etype (E_Id) = Any_Type then
20414 E := Entity (E_Id);
20416 if not Is_Access_Type (E) then
20417 Error_Pragma_Arg ("pragma% requires access type", Arg1);
20420 Set_No_Strict_Aliasing (Base_Type (E));
20422 end No_Strict_Aliasing;
20424 -----------------------
20425 -- Normalize_Scalars --
20426 -----------------------
20428 -- pragma Normalize_Scalars;
20430 when Pragma_Normalize_Scalars =>
20431 Check_Ada_83_Warning;
20432 Check_Arg_Count (0);
20433 Check_Valid_Configuration_Pragma;
20435 -- Normalize_Scalars creates false positives in CodePeer, and
20436 -- incorrect negative results in GNATprove mode, so ignore this
20437 -- pragma in these modes.
20439 if not (CodePeer_Mode or GNATprove_Mode) then
20440 Normalize_Scalars := True;
20441 Init_Or_Norm_Scalars := True;
20448 -- pragma Obsolescent;
20450 -- pragma Obsolescent (
20451 -- [Message =>] static_string_EXPRESSION
20452 -- [,[Version =>] Ada_05]]);
20454 -- pragma Obsolescent (
20455 -- [Entity =>] NAME
20456 -- [,[Message =>] static_string_EXPRESSION
20457 -- [,[Version =>] Ada_05]] );
20459 when Pragma_Obsolescent => Obsolescent : declare
20463 procedure Set_Obsolescent (E : Entity_Id);
20464 -- Given an entity Ent, mark it as obsolescent if appropriate
20466 ---------------------
20467 -- Set_Obsolescent --
20468 ---------------------
20470 procedure Set_Obsolescent (E : Entity_Id) is
20479 -- A pragma that applies to a Ghost entity becomes Ghost for
20480 -- the purposes of legality checks and removal of ignored Ghost
20483 Mark_Ghost_Pragma (N, E);
20485 -- Entity name was given
20487 if Present (Ename) then
20489 -- If entity name matches, we are fine. Save entity in
20490 -- pragma argument, for ASIS use.
20492 if Chars (Ename) = Chars (Ent) then
20493 Set_Entity (Ename, Ent);
20494 Generate_Reference (Ent, Ename);
20496 -- If entity name does not match, only possibility is an
20497 -- enumeration literal from an enumeration type declaration.
20499 elsif Ekind (Ent) /= E_Enumeration_Type then
20501 ("pragma % entity name does not match declaration");
20504 Ent := First_Literal (E);
20508 ("pragma % entity name does not match any "
20509 & "enumeration literal");
20511 elsif Chars (Ent) = Chars (Ename) then
20512 Set_Entity (Ename, Ent);
20513 Generate_Reference (Ent, Ename);
20517 Ent := Next_Literal (Ent);
20523 -- Ent points to entity to be marked
20525 if Arg_Count >= 1 then
20527 -- Deal with static string argument
20529 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
20530 S := Strval (Get_Pragma_Arg (Arg1));
20532 for J in 1 .. String_Length (S) loop
20533 if not In_Character_Range (Get_String_Char (S, J)) then
20535 ("pragma% argument does not allow wide characters",
20540 Obsolescent_Warnings.Append
20541 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
20543 -- Check for Ada_05 parameter
20545 if Arg_Count /= 1 then
20546 Check_Arg_Count (2);
20549 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
20552 Check_Arg_Is_Identifier (Argx);
20554 if Chars (Argx) /= Name_Ada_05 then
20555 Error_Msg_Name_2 := Name_Ada_05;
20557 ("only allowed argument for pragma% is %", Argx);
20560 if Ada_Version_Explicit < Ada_2005
20561 or else not Warn_On_Ada_2005_Compatibility
20569 -- Set flag if pragma active
20572 Set_Is_Obsolescent (Ent);
20576 end Set_Obsolescent;
20578 -- Start of processing for pragma Obsolescent
20583 Check_At_Most_N_Arguments (3);
20585 -- See if first argument specifies an entity name
20589 (Chars (Arg1) = Name_Entity
20591 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
20593 N_Operator_Symbol))
20595 Ename := Get_Pragma_Arg (Arg1);
20597 -- Eliminate first argument, so we can share processing
20601 Arg_Count := Arg_Count - 1;
20603 -- No Entity name argument given
20609 if Arg_Count >= 1 then
20610 Check_Optional_Identifier (Arg1, Name_Message);
20612 if Arg_Count = 2 then
20613 Check_Optional_Identifier (Arg2, Name_Version);
20617 -- Get immediately preceding declaration
20620 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
20624 -- Cases where we do not follow anything other than another pragma
20628 -- First case: library level compilation unit declaration with
20629 -- the pragma immediately following the declaration.
20631 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
20633 (Defining_Entity (Unit (Parent (Parent (N)))));
20636 -- Case 2: library unit placement for package
20640 Ent : constant Entity_Id := Find_Lib_Unit_Name;
20642 if Is_Package_Or_Generic_Package (Ent) then
20643 Set_Obsolescent (Ent);
20649 -- Cases where we must follow a declaration, including an
20650 -- abstract subprogram declaration, which is not in the
20651 -- other node subtypes.
20654 if Nkind (Decl) not in N_Declaration
20655 and then Nkind (Decl) not in N_Later_Decl_Item
20656 and then Nkind (Decl) not in N_Generic_Declaration
20657 and then Nkind (Decl) not in N_Renaming_Declaration
20658 and then Nkind (Decl) /= N_Abstract_Subprogram_Declaration
20661 ("pragma% misplaced, "
20662 & "must immediately follow a declaration");
20665 Set_Obsolescent (Defining_Entity (Decl));
20675 -- pragma Optimize (Time | Space | Off);
20677 -- The actual check for optimize is done in Gigi. Note that this
20678 -- pragma does not actually change the optimization setting, it
20679 -- simply checks that it is consistent with the pragma.
20681 when Pragma_Optimize =>
20682 Check_No_Identifiers;
20683 Check_Arg_Count (1);
20684 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
20686 ------------------------
20687 -- Optimize_Alignment --
20688 ------------------------
20690 -- pragma Optimize_Alignment (Time | Space | Off);
20692 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
20694 Check_No_Identifiers;
20695 Check_Arg_Count (1);
20696 Check_Valid_Configuration_Pragma;
20699 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
20702 when Name_Off => Opt.Optimize_Alignment := 'O';
20703 when Name_Space => Opt.Optimize_Alignment := 'S';
20704 when Name_Time => Opt.Optimize_Alignment := 'T';
20707 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
20711 -- Set indication that mode is set locally. If we are in fact in a
20712 -- configuration pragma file, this setting is harmless since the
20713 -- switch will get reset anyway at the start of each unit.
20715 Optimize_Alignment_Local := True;
20716 end Optimize_Alignment;
20722 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
20724 when Pragma_Ordered => Ordered : declare
20725 Assoc : constant Node_Id := Arg1;
20731 Check_No_Identifiers;
20732 Check_Arg_Count (1);
20733 Check_Arg_Is_Local_Name (Arg1);
20735 Type_Id := Get_Pragma_Arg (Assoc);
20736 Find_Type (Type_Id);
20737 Typ := Entity (Type_Id);
20739 if Typ = Any_Type then
20742 Typ := Underlying_Type (Typ);
20745 if not Is_Enumeration_Type (Typ) then
20746 Error_Pragma ("pragma% must specify enumeration type");
20749 Check_First_Subtype (Arg1);
20750 Set_Has_Pragma_Ordered (Base_Type (Typ));
20753 -------------------
20754 -- Overflow_Mode --
20755 -------------------
20757 -- pragma Overflow_Mode
20758 -- ([General => ] MODE [, [Assertions => ] MODE]);
20760 -- MODE := STRICT | MINIMIZED | ELIMINATED
20762 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
20763 -- since System.Bignums makes this assumption. This is true of nearly
20764 -- all (all?) targets.
20766 when Pragma_Overflow_Mode => Overflow_Mode : declare
20767 function Get_Overflow_Mode
20769 Arg : Node_Id) return Overflow_Mode_Type;
20770 -- Function to process one pragma argument, Arg. If an identifier
20771 -- is present, it must be Name. Mode type is returned if a valid
20772 -- argument exists, otherwise an error is signalled.
20774 -----------------------
20775 -- Get_Overflow_Mode --
20776 -----------------------
20778 function Get_Overflow_Mode
20780 Arg : Node_Id) return Overflow_Mode_Type
20782 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
20785 Check_Optional_Identifier (Arg, Name);
20786 Check_Arg_Is_Identifier (Argx);
20788 if Chars (Argx) = Name_Strict then
20791 elsif Chars (Argx) = Name_Minimized then
20794 elsif Chars (Argx) = Name_Eliminated then
20795 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then
20797 ("Eliminated not implemented on this target", Argx);
20803 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
20805 end Get_Overflow_Mode;
20807 -- Start of processing for Overflow_Mode
20811 Check_At_Least_N_Arguments (1);
20812 Check_At_Most_N_Arguments (2);
20814 -- Process first argument
20816 Scope_Suppress.Overflow_Mode_General :=
20817 Get_Overflow_Mode (Name_General, Arg1);
20819 -- Case of only one argument
20821 if Arg_Count = 1 then
20822 Scope_Suppress.Overflow_Mode_Assertions :=
20823 Scope_Suppress.Overflow_Mode_General;
20825 -- Case of two arguments present
20828 Scope_Suppress.Overflow_Mode_Assertions :=
20829 Get_Overflow_Mode (Name_Assertions, Arg2);
20833 --------------------------
20834 -- Overriding Renamings --
20835 --------------------------
20837 -- pragma Overriding_Renamings;
20839 when Pragma_Overriding_Renamings =>
20841 Check_Arg_Count (0);
20842 Check_Valid_Configuration_Pragma;
20843 Overriding_Renamings := True;
20849 -- pragma Pack (first_subtype_LOCAL_NAME);
20851 when Pragma_Pack => Pack : declare
20852 Assoc : constant Node_Id := Arg1;
20854 Ignore : Boolean := False;
20859 Check_No_Identifiers;
20860 Check_Arg_Count (1);
20861 Check_Arg_Is_Local_Name (Arg1);
20862 Type_Id := Get_Pragma_Arg (Assoc);
20864 if not Is_Entity_Name (Type_Id)
20865 or else not Is_Type (Entity (Type_Id))
20868 ("argument for pragma% must be type or subtype", Arg1);
20871 Find_Type (Type_Id);
20872 Typ := Entity (Type_Id);
20875 or else Rep_Item_Too_Early (Typ, N)
20879 Typ := Underlying_Type (Typ);
20882 -- A pragma that applies to a Ghost entity becomes Ghost for the
20883 -- purposes of legality checks and removal of ignored Ghost code.
20885 Mark_Ghost_Pragma (N, Typ);
20887 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
20888 Error_Pragma ("pragma% must specify array or record type");
20891 Check_First_Subtype (Arg1);
20892 Check_Duplicate_Pragma (Typ);
20896 if Is_Array_Type (Typ) then
20897 Ctyp := Component_Type (Typ);
20899 -- Ignore pack that does nothing
20901 if Known_Static_Esize (Ctyp)
20902 and then Known_Static_RM_Size (Ctyp)
20903 and then Esize (Ctyp) = RM_Size (Ctyp)
20904 and then Addressable (Esize (Ctyp))
20909 -- Process OK pragma Pack. Note that if there is a separate
20910 -- component clause present, the Pack will be cancelled. This
20911 -- processing is in Freeze.
20913 if not Rep_Item_Too_Late (Typ, N) then
20915 -- In CodePeer mode, we do not need complex front-end
20916 -- expansions related to pragma Pack, so disable handling
20919 if CodePeer_Mode then
20922 -- Normal case where we do the pack action
20926 Set_Is_Packed (Base_Type (Typ));
20927 Set_Has_Non_Standard_Rep (Base_Type (Typ));
20930 Set_Has_Pragma_Pack (Base_Type (Typ));
20934 -- For record types, the pack is always effective
20936 else pragma Assert (Is_Record_Type (Typ));
20937 if not Rep_Item_Too_Late (Typ, N) then
20938 Set_Is_Packed (Base_Type (Typ));
20939 Set_Has_Pragma_Pack (Base_Type (Typ));
20940 Set_Has_Non_Standard_Rep (Base_Type (Typ));
20951 -- There is nothing to do here, since we did all the processing for
20952 -- this pragma in Par.Prag (so that it works properly even in syntax
20955 when Pragma_Page =>
20962 -- pragma Part_Of (ABSTRACT_STATE);
20964 -- ABSTRACT_STATE ::= NAME
20966 when Pragma_Part_Of => Part_Of : declare
20967 procedure Propagate_Part_Of
20968 (Pack_Id : Entity_Id;
20969 State_Id : Entity_Id;
20970 Instance : Node_Id);
20971 -- Propagate the Part_Of indicator to all abstract states and
20972 -- objects declared in the visible state space of a package
20973 -- denoted by Pack_Id. State_Id is the encapsulating state.
20974 -- Instance is the package instantiation node.
20976 -----------------------
20977 -- Propagate_Part_Of --
20978 -----------------------
20980 procedure Propagate_Part_Of
20981 (Pack_Id : Entity_Id;
20982 State_Id : Entity_Id;
20983 Instance : Node_Id)
20985 Has_Item : Boolean := False;
20986 -- Flag set when the visible state space contains at least one
20987 -- abstract state or variable.
20989 procedure Propagate_Part_Of (Pack_Id : Entity_Id);
20990 -- Propagate the Part_Of indicator to all abstract states and
20991 -- objects declared in the visible state space of a package
20992 -- denoted by Pack_Id.
20994 -----------------------
20995 -- Propagate_Part_Of --
20996 -----------------------
20998 procedure Propagate_Part_Of (Pack_Id : Entity_Id) is
20999 Constits : Elist_Id;
21000 Item_Id : Entity_Id;
21003 -- Traverse the entity chain of the package and set relevant
21004 -- attributes of abstract states and objects declared in the
21005 -- visible state space of the package.
21007 Item_Id := First_Entity (Pack_Id);
21008 while Present (Item_Id)
21009 and then not In_Private_Part (Item_Id)
21011 -- Do not consider internally generated items
21013 if not Comes_From_Source (Item_Id) then
21016 -- Do not consider generic formals or their corresponding
21017 -- actuals because they are not part of a visible state.
21018 -- Note that both entities are marked as hidden.
21020 elsif Is_Hidden (Item_Id) then
21023 -- The Part_Of indicator turns an abstract state or an
21024 -- object into a constituent of the encapsulating state.
21025 -- Note that constants are considered here even though
21026 -- they may not depend on variable input. This check is
21027 -- left to the SPARK prover.
21029 elsif Ekind_In (Item_Id, E_Abstract_State,
21034 Constits := Part_Of_Constituents (State_Id);
21036 if No (Constits) then
21037 Constits := New_Elmt_List;
21038 Set_Part_Of_Constituents (State_Id, Constits);
21041 Append_Elmt (Item_Id, Constits);
21042 Set_Encapsulating_State (Item_Id, State_Id);
21044 -- Recursively handle nested packages and instantiations
21046 elsif Ekind (Item_Id) = E_Package then
21047 Propagate_Part_Of (Item_Id);
21050 Next_Entity (Item_Id);
21052 end Propagate_Part_Of;
21054 -- Start of processing for Propagate_Part_Of
21057 Propagate_Part_Of (Pack_Id);
21059 -- Detect a package instantiation that is subject to a Part_Of
21060 -- indicator, but has no visible state.
21062 if not Has_Item then
21064 ("package instantiation & has Part_Of indicator but "
21065 & "lacks visible state", Instance, Pack_Id);
21067 end Propagate_Part_Of;
21071 Constits : Elist_Id;
21073 Encap_Id : Entity_Id;
21074 Item_Id : Entity_Id;
21078 -- Start of processing for Part_Of
21082 Check_No_Identifiers;
21083 Check_Arg_Count (1);
21085 Stmt := Find_Related_Context (N, Do_Checks => True);
21087 -- Object declaration
21089 if Nkind (Stmt) = N_Object_Declaration then
21092 -- Package instantiation
21094 elsif Nkind (Stmt) = N_Package_Instantiation then
21097 -- Single concurrent type declaration
21099 elsif Is_Single_Concurrent_Type_Declaration (Stmt) then
21102 -- Otherwise the pragma is associated with an illegal construct
21109 -- Extract the entity of the related object declaration or package
21110 -- instantiation. In the case of the instantiation, use the entity
21111 -- of the instance spec.
21113 if Nkind (Stmt) = N_Package_Instantiation then
21114 Stmt := Instance_Spec (Stmt);
21117 Item_Id := Defining_Entity (Stmt);
21119 -- A pragma that applies to a Ghost entity becomes Ghost for the
21120 -- purposes of legality checks and removal of ignored Ghost code.
21122 Mark_Ghost_Pragma (N, Item_Id);
21124 -- Chain the pragma on the contract for further processing by
21125 -- Analyze_Part_Of_In_Decl_Part or for completeness.
21127 Add_Contract_Item (N, Item_Id);
21129 -- A variable may act as constituent of a single concurrent type
21130 -- which in turn could be declared after the variable. Due to this
21131 -- discrepancy, the full analysis of indicator Part_Of is delayed
21132 -- until the end of the enclosing declarative region (see routine
21133 -- Analyze_Part_Of_In_Decl_Part).
21135 if Ekind (Item_Id) = E_Variable then
21138 -- Otherwise indicator Part_Of applies to a constant or a package
21142 Encap := Get_Pragma_Arg (Arg1);
21144 -- Detect any discrepancies between the placement of the
21145 -- constant or package instantiation with respect to state
21146 -- space and the encapsulating state.
21150 Item_Id => Item_Id,
21152 Encap_Id => Encap_Id,
21156 pragma Assert (Present (Encap_Id));
21158 if Ekind (Item_Id) = E_Constant then
21159 Constits := Part_Of_Constituents (Encap_Id);
21161 if No (Constits) then
21162 Constits := New_Elmt_List;
21163 Set_Part_Of_Constituents (Encap_Id, Constits);
21166 Append_Elmt (Item_Id, Constits);
21167 Set_Encapsulating_State (Item_Id, Encap_Id);
21169 -- Propagate the Part_Of indicator to the visible state
21170 -- space of the package instantiation.
21174 (Pack_Id => Item_Id,
21175 State_Id => Encap_Id,
21182 ----------------------------------
21183 -- Partition_Elaboration_Policy --
21184 ----------------------------------
21186 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
21188 when Pragma_Partition_Elaboration_Policy => PEP : declare
21189 subtype PEP_Range is Name_Id
21190 range First_Partition_Elaboration_Policy_Name
21191 .. Last_Partition_Elaboration_Policy_Name;
21192 PEP_Val : PEP_Range;
21197 Check_Arg_Count (1);
21198 Check_No_Identifiers;
21199 Check_Arg_Is_Partition_Elaboration_Policy (Arg1);
21200 Check_Valid_Configuration_Pragma;
21201 PEP_Val := Chars (Get_Pragma_Arg (Arg1));
21204 when Name_Concurrent => PEP := 'C';
21205 when Name_Sequential => PEP := 'S';
21208 if Partition_Elaboration_Policy /= ' '
21209 and then Partition_Elaboration_Policy /= PEP
21211 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc;
21213 ("partition elaboration policy incompatible with policy#");
21215 -- Set new policy, but always preserve System_Location since we
21216 -- like the error message with the run time name.
21219 Partition_Elaboration_Policy := PEP;
21221 if Partition_Elaboration_Policy_Sloc /= System_Location then
21222 Partition_Elaboration_Policy_Sloc := Loc;
21231 -- pragma Passive [(PASSIVE_FORM)];
21233 -- PASSIVE_FORM ::= Semaphore | No
21235 when Pragma_Passive =>
21238 if Nkind (Parent (N)) /= N_Task_Definition then
21239 Error_Pragma ("pragma% must be within task definition");
21242 if Arg_Count /= 0 then
21243 Check_Arg_Count (1);
21244 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
21247 ----------------------------------
21248 -- Preelaborable_Initialization --
21249 ----------------------------------
21251 -- pragma Preelaborable_Initialization (DIRECT_NAME);
21253 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
21258 Check_Arg_Count (1);
21259 Check_No_Identifiers;
21260 Check_Arg_Is_Identifier (Arg1);
21261 Check_Arg_Is_Local_Name (Arg1);
21262 Check_First_Subtype (Arg1);
21263 Ent := Entity (Get_Pragma_Arg (Arg1));
21265 -- A pragma that applies to a Ghost entity becomes Ghost for the
21266 -- purposes of legality checks and removal of ignored Ghost code.
21268 Mark_Ghost_Pragma (N, Ent);
21270 -- The pragma may come from an aspect on a private declaration,
21271 -- even if the freeze point at which this is analyzed in the
21272 -- private part after the full view.
21274 if Has_Private_Declaration (Ent)
21275 and then From_Aspect_Specification (N)
21279 -- Check appropriate type argument
21281 elsif Is_Private_Type (Ent)
21282 or else Is_Protected_Type (Ent)
21283 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))
21285 -- AI05-0028: The pragma applies to all composite types. Note
21286 -- that we apply this binding interpretation to earlier versions
21287 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
21288 -- choice since there are other compilers that do the same.
21290 or else Is_Composite_Type (Ent)
21296 ("pragma % can only be applied to private, formal derived, "
21297 & "protected, or composite type", Arg1);
21300 -- Give an error if the pragma is applied to a protected type that
21301 -- does not qualify (due to having entries, or due to components
21302 -- that do not qualify).
21304 if Is_Protected_Type (Ent)
21305 and then not Has_Preelaborable_Initialization (Ent)
21308 ("protected type & does not have preelaborable "
21309 & "initialization", Ent);
21311 -- Otherwise mark the type as definitely having preelaborable
21315 Set_Known_To_Have_Preelab_Init (Ent);
21318 if Has_Pragma_Preelab_Init (Ent)
21319 and then Warn_On_Redundant_Constructs
21321 Error_Pragma ("?r?duplicate pragma%!");
21323 Set_Has_Pragma_Preelab_Init (Ent);
21327 --------------------
21328 -- Persistent_BSS --
21329 --------------------
21331 -- pragma Persistent_BSS [(object_NAME)];
21333 when Pragma_Persistent_BSS => Persistent_BSS : declare
21340 Check_At_Most_N_Arguments (1);
21342 -- Case of application to specific object (one argument)
21344 if Arg_Count = 1 then
21345 Check_Arg_Is_Library_Level_Local_Name (Arg1);
21347 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
21349 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
21352 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
21355 Ent := Entity (Get_Pragma_Arg (Arg1));
21357 -- A pragma that applies to a Ghost entity becomes Ghost for
21358 -- the purposes of legality checks and removal of ignored Ghost
21361 Mark_Ghost_Pragma (N, Ent);
21363 -- Check for duplication before inserting in list of
21364 -- representation items.
21366 Check_Duplicate_Pragma (Ent);
21368 if Rep_Item_Too_Late (Ent, N) then
21372 Decl := Parent (Ent);
21374 if Present (Expression (Decl)) then
21375 -- Variables in Persistent_BSS cannot be initialized, so
21376 -- turn off any initialization that might be caused by
21377 -- pragmas Initialize_Scalars or Normalize_Scalars.
21379 if Kill_Range_Check (Expression (Decl)) then
21382 Name_Suppress_Initialization,
21383 Pragma_Argument_Associations => New_List (
21384 Make_Pragma_Argument_Association (Loc,
21385 Expression => New_Occurrence_Of (Ent, Loc))));
21386 Insert_Before (N, Prag);
21391 ("object for pragma% cannot have initialization", Arg1);
21395 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
21397 ("object type for pragma% is not potentially persistent",
21402 Make_Linker_Section_Pragma
21403 (Ent, Loc, ".persistent.bss");
21404 Insert_After (N, Prag);
21407 -- Case of use as configuration pragma with no arguments
21410 Check_Valid_Configuration_Pragma;
21411 Persistent_BSS_Mode := True;
21413 end Persistent_BSS;
21415 --------------------
21416 -- Rename_Pragma --
21417 --------------------
21419 -- pragma Rename_Pragma (
21420 -- [New_Name =>] IDENTIFIER,
21421 -- [Renamed =>] pragma_IDENTIFIER);
21423 when Pragma_Rename_Pragma => Rename_Pragma : declare
21424 New_Name : constant Node_Id := Get_Pragma_Arg (Arg1);
21425 Old_Name : constant Node_Id := Get_Pragma_Arg (Arg2);
21429 Check_Valid_Configuration_Pragma;
21430 Check_Arg_Count (2);
21431 Check_Optional_Identifier (Arg1, Name_New_Name);
21432 Check_Optional_Identifier (Arg2, Name_Renamed);
21434 if Nkind (New_Name) /= N_Identifier then
21435 Error_Pragma_Arg ("identifier expected", Arg1);
21438 if Nkind (Old_Name) /= N_Identifier then
21439 Error_Pragma_Arg ("identifier expected", Arg2);
21442 -- The New_Name arg should not be an existing pragma (but we allow
21443 -- it; it's just a warning). The Old_Name arg must be an existing
21446 if Is_Pragma_Name (Chars (New_Name)) then
21447 Error_Pragma_Arg ("??pragma is already defined", Arg1);
21450 if not Is_Pragma_Name (Chars (Old_Name)) then
21451 Error_Pragma_Arg ("existing pragma name expected", Arg1);
21454 Map_Pragma_Name (From => Chars (New_Name), To => Chars (Old_Name));
21461 -- pragma Polling (ON | OFF);
21463 when Pragma_Polling =>
21465 Check_Arg_Count (1);
21466 Check_No_Identifiers;
21467 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
21468 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
21470 -----------------------------------
21471 -- Post/Post_Class/Postcondition --
21472 -----------------------------------
21474 -- pragma Post (Boolean_EXPRESSION);
21475 -- pragma Post_Class (Boolean_EXPRESSION);
21476 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
21477 -- [,[Message =>] String_EXPRESSION]);
21479 -- Characteristics:
21481 -- * Analysis - The annotation undergoes initial checks to verify
21482 -- the legal placement and context. Secondary checks preanalyze the
21485 -- Analyze_Pre_Post_Condition_In_Decl_Part
21487 -- * Expansion - The annotation is expanded during the expansion of
21488 -- the related subprogram [body] contract as performed in:
21490 -- Expand_Subprogram_Contract
21492 -- * Template - The annotation utilizes the generic template of the
21493 -- related subprogram [body] when it is:
21495 -- aspect on subprogram declaration
21496 -- aspect on stand-alone subprogram body
21497 -- pragma on stand-alone subprogram body
21499 -- The annotation must prepare its own template when it is:
21501 -- pragma on subprogram declaration
21503 -- * Globals - Capture of global references must occur after full
21506 -- * Instance - The annotation is instantiated automatically when
21507 -- the related generic subprogram [body] is instantiated except for
21508 -- the "pragma on subprogram declaration" case. In that scenario
21509 -- the annotation must instantiate itself.
21512 | Pragma_Post_Class
21513 | Pragma_Postcondition
21515 Analyze_Pre_Post_Condition;
21517 --------------------------------
21518 -- Pre/Pre_Class/Precondition --
21519 --------------------------------
21521 -- pragma Pre (Boolean_EXPRESSION);
21522 -- pragma Pre_Class (Boolean_EXPRESSION);
21523 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
21524 -- [,[Message =>] String_EXPRESSION]);
21526 -- Characteristics:
21528 -- * Analysis - The annotation undergoes initial checks to verify
21529 -- the legal placement and context. Secondary checks preanalyze the
21532 -- Analyze_Pre_Post_Condition_In_Decl_Part
21534 -- * Expansion - The annotation is expanded during the expansion of
21535 -- the related subprogram [body] contract as performed in:
21537 -- Expand_Subprogram_Contract
21539 -- * Template - The annotation utilizes the generic template of the
21540 -- related subprogram [body] when it is:
21542 -- aspect on subprogram declaration
21543 -- aspect on stand-alone subprogram body
21544 -- pragma on stand-alone subprogram body
21546 -- The annotation must prepare its own template when it is:
21548 -- pragma on subprogram declaration
21550 -- * Globals - Capture of global references must occur after full
21553 -- * Instance - The annotation is instantiated automatically when
21554 -- the related generic subprogram [body] is instantiated except for
21555 -- the "pragma on subprogram declaration" case. In that scenario
21556 -- the annotation must instantiate itself.
21560 | Pragma_Precondition
21562 Analyze_Pre_Post_Condition;
21568 -- pragma Predicate
21569 -- ([Entity =>] type_LOCAL_NAME,
21570 -- [Check =>] boolean_EXPRESSION);
21572 when Pragma_Predicate => Predicate : declare
21579 Check_Arg_Count (2);
21580 Check_Optional_Identifier (Arg1, Name_Entity);
21581 Check_Optional_Identifier (Arg2, Name_Check);
21583 Check_Arg_Is_Local_Name (Arg1);
21585 Type_Id := Get_Pragma_Arg (Arg1);
21586 Find_Type (Type_Id);
21587 Typ := Entity (Type_Id);
21589 if Typ = Any_Type then
21593 -- A pragma that applies to a Ghost entity becomes Ghost for the
21594 -- purposes of legality checks and removal of ignored Ghost code.
21596 Mark_Ghost_Pragma (N, Typ);
21598 -- The remaining processing is simply to link the pragma on to
21599 -- the rep item chain, for processing when the type is frozen.
21600 -- This is accomplished by a call to Rep_Item_Too_Late. We also
21601 -- mark the type as having predicates.
21603 -- If the current policy for predicate checking is Ignore mark the
21604 -- subtype accordingly. In the case of predicates we consider them
21605 -- enabled unless Ignore is specified (either directly or with a
21606 -- general Assertion_Policy pragma) to preserve existing warnings.
21608 Set_Has_Predicates (Typ);
21610 -- Indicate that the pragma must be processed at the point the
21611 -- type is frozen, as is done for the corresponding aspect.
21613 Set_Has_Delayed_Aspects (Typ);
21614 Set_Has_Delayed_Freeze (Typ);
21616 Set_Predicates_Ignored (Typ,
21617 Present (Check_Policy_List)
21619 Policy_In_Effect (Name_Dynamic_Predicate) = Name_Ignore);
21620 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
21623 -----------------------
21624 -- Predicate_Failure --
21625 -----------------------
21627 -- pragma Predicate_Failure
21628 -- ([Entity =>] type_LOCAL_NAME,
21629 -- [Message =>] string_EXPRESSION);
21631 when Pragma_Predicate_Failure => Predicate_Failure : declare
21638 Check_Arg_Count (2);
21639 Check_Optional_Identifier (Arg1, Name_Entity);
21640 Check_Optional_Identifier (Arg2, Name_Message);
21642 Check_Arg_Is_Local_Name (Arg1);
21644 Type_Id := Get_Pragma_Arg (Arg1);
21645 Find_Type (Type_Id);
21646 Typ := Entity (Type_Id);
21648 if Typ = Any_Type then
21652 -- A pragma that applies to a Ghost entity becomes Ghost for the
21653 -- purposes of legality checks and removal of ignored Ghost code.
21655 Mark_Ghost_Pragma (N, Typ);
21657 -- The remaining processing is simply to link the pragma on to
21658 -- the rep item chain, for processing when the type is frozen.
21659 -- This is accomplished by a call to Rep_Item_Too_Late.
21661 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
21662 end Predicate_Failure;
21668 -- pragma Preelaborate [(library_unit_NAME)];
21670 -- Set the flag Is_Preelaborated of program unit name entity
21672 when Pragma_Preelaborate => Preelaborate : declare
21673 Pa : constant Node_Id := Parent (N);
21674 Pk : constant Node_Kind := Nkind (Pa);
21678 Check_Ada_83_Warning;
21679 Check_Valid_Library_Unit_Pragma;
21681 if Nkind (N) = N_Null_Statement then
21685 Ent := Find_Lib_Unit_Name;
21687 -- A pragma that applies to a Ghost entity becomes Ghost for the
21688 -- purposes of legality checks and removal of ignored Ghost code.
21690 Mark_Ghost_Pragma (N, Ent);
21691 Check_Duplicate_Pragma (Ent);
21693 -- This filters out pragmas inside generic parents that show up
21694 -- inside instantiations. Pragmas that come from aspects in the
21695 -- unit are not ignored.
21697 if Present (Ent) then
21698 if Pk = N_Package_Specification
21699 and then Present (Generic_Parent (Pa))
21700 and then not From_Aspect_Specification (N)
21705 if not Debug_Flag_U then
21706 Set_Is_Preelaborated (Ent);
21708 if Legacy_Elaboration_Checks then
21709 Set_Suppress_Elaboration_Warnings (Ent);
21716 -------------------------------
21717 -- Prefix_Exception_Messages --
21718 -------------------------------
21720 -- pragma Prefix_Exception_Messages;
21722 when Pragma_Prefix_Exception_Messages =>
21724 Check_Valid_Configuration_Pragma;
21725 Check_Arg_Count (0);
21726 Prefix_Exception_Messages := True;
21732 -- pragma Priority (EXPRESSION);
21734 when Pragma_Priority => Priority : declare
21735 P : constant Node_Id := Parent (N);
21740 Check_No_Identifiers;
21741 Check_Arg_Count (1);
21745 if Nkind (P) = N_Subprogram_Body then
21746 Check_In_Main_Program;
21748 Ent := Defining_Unit_Name (Specification (P));
21750 if Nkind (Ent) = N_Defining_Program_Unit_Name then
21751 Ent := Defining_Identifier (Ent);
21754 Arg := Get_Pragma_Arg (Arg1);
21755 Analyze_And_Resolve (Arg, Standard_Integer);
21759 if not Is_OK_Static_Expression (Arg) then
21760 Flag_Non_Static_Expr
21761 ("main subprogram priority is not static!", Arg);
21764 -- If constraint error, then we already signalled an error
21766 elsif Raises_Constraint_Error (Arg) then
21769 -- Otherwise check in range except if Relaxed_RM_Semantics
21770 -- where we ignore the value if out of range.
21773 if not Relaxed_RM_Semantics
21774 and then not Is_In_Range (Arg, RTE (RE_Priority))
21777 ("main subprogram priority is out of range", Arg1);
21780 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
21784 -- Load an arbitrary entity from System.Tasking.Stages or
21785 -- System.Tasking.Restricted.Stages (depending on the
21786 -- supported profile) to make sure that one of these packages
21787 -- is implicitly with'ed, since we need to have the tasking
21788 -- run time active for the pragma Priority to have any effect.
21789 -- Previously we with'ed the package System.Tasking, but this
21790 -- package does not trigger the required initialization of the
21791 -- run-time library.
21794 Discard : Entity_Id;
21795 pragma Warnings (Off, Discard);
21797 if Restricted_Profile then
21798 Discard := RTE (RE_Activate_Restricted_Tasks);
21800 Discard := RTE (RE_Activate_Tasks);
21804 -- Task or Protected, must be of type Integer
21806 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
21807 Arg := Get_Pragma_Arg (Arg1);
21808 Ent := Defining_Identifier (Parent (P));
21810 -- The expression must be analyzed in the special manner
21811 -- described in "Handling of Default and Per-Object
21812 -- Expressions" in sem.ads.
21814 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority));
21816 if not Is_OK_Static_Expression (Arg) then
21817 Check_Restriction (Static_Priorities, Arg);
21820 -- Anything else is incorrect
21826 -- Check duplicate pragma before we chain the pragma in the Rep
21827 -- Item chain of Ent.
21829 Check_Duplicate_Pragma (Ent);
21830 Record_Rep_Item (Ent, N);
21833 -----------------------------------
21834 -- Priority_Specific_Dispatching --
21835 -----------------------------------
21837 -- pragma Priority_Specific_Dispatching (
21838 -- policy_IDENTIFIER,
21839 -- first_priority_EXPRESSION,
21840 -- last_priority_EXPRESSION);
21842 when Pragma_Priority_Specific_Dispatching =>
21843 Priority_Specific_Dispatching : declare
21844 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
21845 -- This is the entity System.Any_Priority;
21848 Lower_Bound : Node_Id;
21849 Upper_Bound : Node_Id;
21855 Check_Arg_Count (3);
21856 Check_No_Identifiers;
21857 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
21858 Check_Valid_Configuration_Pragma;
21859 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
21860 DP := Fold_Upper (Name_Buffer (1));
21862 Lower_Bound := Get_Pragma_Arg (Arg2);
21863 Check_Arg_Is_OK_Static_Expression (Lower_Bound, Standard_Integer);
21864 Lower_Val := Expr_Value (Lower_Bound);
21866 Upper_Bound := Get_Pragma_Arg (Arg3);
21867 Check_Arg_Is_OK_Static_Expression (Upper_Bound, Standard_Integer);
21868 Upper_Val := Expr_Value (Upper_Bound);
21870 -- It is not allowed to use Task_Dispatching_Policy and
21871 -- Priority_Specific_Dispatching in the same partition.
21873 if Task_Dispatching_Policy /= ' ' then
21874 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
21876 ("pragma% incompatible with Task_Dispatching_Policy#");
21878 -- Check lower bound in range
21880 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
21882 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
21885 ("first_priority is out of range", Arg2);
21887 -- Check upper bound in range
21889 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
21891 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
21894 ("last_priority is out of range", Arg3);
21896 -- Check that the priority range is valid
21898 elsif Lower_Val > Upper_Val then
21900 ("last_priority_expression must be greater than or equal to "
21901 & "first_priority_expression");
21903 -- Store the new policy, but always preserve System_Location since
21904 -- we like the error message with the run-time name.
21907 -- Check overlapping in the priority ranges specified in other
21908 -- Priority_Specific_Dispatching pragmas within the same
21909 -- partition. We can only check those we know about.
21912 Specific_Dispatching.First .. Specific_Dispatching.Last
21914 if Specific_Dispatching.Table (J).First_Priority in
21915 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
21916 or else Specific_Dispatching.Table (J).Last_Priority in
21917 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
21920 Specific_Dispatching.Table (J).Pragma_Loc;
21922 ("priority range overlaps with "
21923 & "Priority_Specific_Dispatching#");
21927 -- The use of Priority_Specific_Dispatching is incompatible
21928 -- with Task_Dispatching_Policy.
21930 if Task_Dispatching_Policy /= ' ' then
21931 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
21933 ("Priority_Specific_Dispatching incompatible "
21934 & "with Task_Dispatching_Policy#");
21937 -- The use of Priority_Specific_Dispatching forces ceiling
21940 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
21941 Error_Msg_Sloc := Locking_Policy_Sloc;
21943 ("Priority_Specific_Dispatching incompatible "
21944 & "with Locking_Policy#");
21946 -- Set the Ceiling_Locking policy, but preserve System_Location
21947 -- since we like the error message with the run time name.
21950 Locking_Policy := 'C';
21952 if Locking_Policy_Sloc /= System_Location then
21953 Locking_Policy_Sloc := Loc;
21957 -- Add entry in the table
21959 Specific_Dispatching.Append
21960 ((Dispatching_Policy => DP,
21961 First_Priority => UI_To_Int (Lower_Val),
21962 Last_Priority => UI_To_Int (Upper_Val),
21963 Pragma_Loc => Loc));
21965 end Priority_Specific_Dispatching;
21971 -- pragma Profile (profile_IDENTIFIER);
21973 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
21975 when Pragma_Profile =>
21977 Check_Arg_Count (1);
21978 Check_Valid_Configuration_Pragma;
21979 Check_No_Identifiers;
21982 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21985 if Chars (Argx) = Name_Ravenscar then
21986 Set_Ravenscar_Profile (Ravenscar, N);
21988 elsif Chars (Argx) = Name_Gnat_Extended_Ravenscar then
21989 Set_Ravenscar_Profile (GNAT_Extended_Ravenscar, N);
21991 elsif Chars (Argx) = Name_Gnat_Ravenscar_EDF then
21992 Set_Ravenscar_Profile (GNAT_Ravenscar_EDF, N);
21994 elsif Chars (Argx) = Name_Restricted then
21995 Set_Profile_Restrictions
21997 N, Warn => Treat_Restrictions_As_Warnings);
21999 elsif Chars (Argx) = Name_Rational then
22000 Set_Rational_Profile;
22002 elsif Chars (Argx) = Name_No_Implementation_Extensions then
22003 Set_Profile_Restrictions
22004 (No_Implementation_Extensions,
22005 N, Warn => Treat_Restrictions_As_Warnings);
22008 Error_Pragma_Arg ("& is not a valid profile", Argx);
22012 ----------------------
22013 -- Profile_Warnings --
22014 ----------------------
22016 -- pragma Profile_Warnings (profile_IDENTIFIER);
22018 -- profile_IDENTIFIER => Restricted | Ravenscar
22020 when Pragma_Profile_Warnings =>
22022 Check_Arg_Count (1);
22023 Check_Valid_Configuration_Pragma;
22024 Check_No_Identifiers;
22027 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
22030 if Chars (Argx) = Name_Ravenscar then
22031 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
22033 elsif Chars (Argx) = Name_Restricted then
22034 Set_Profile_Restrictions (Restricted, N, Warn => True);
22036 elsif Chars (Argx) = Name_No_Implementation_Extensions then
22037 Set_Profile_Restrictions
22038 (No_Implementation_Extensions, N, Warn => True);
22041 Error_Pragma_Arg ("& is not a valid profile", Argx);
22045 --------------------------
22046 -- Propagate_Exceptions --
22047 --------------------------
22049 -- pragma Propagate_Exceptions;
22051 -- Note: this pragma is obsolete and has no effect
22053 when Pragma_Propagate_Exceptions =>
22055 Check_Arg_Count (0);
22057 if Warn_On_Obsolescent_Feature then
22059 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
22060 "and has no effect?j?", N);
22063 -----------------------------
22064 -- Provide_Shift_Operators --
22065 -----------------------------
22067 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
22069 when Pragma_Provide_Shift_Operators =>
22070 Provide_Shift_Operators : declare
22073 procedure Declare_Shift_Operator (Nam : Name_Id);
22074 -- Insert declaration and pragma Instrinsic for named shift op
22076 ----------------------------
22077 -- Declare_Shift_Operator --
22078 ----------------------------
22080 procedure Declare_Shift_Operator (Nam : Name_Id) is
22086 Make_Subprogram_Declaration (Loc,
22087 Make_Function_Specification (Loc,
22088 Defining_Unit_Name =>
22089 Make_Defining_Identifier (Loc, Chars => Nam),
22091 Result_Definition =>
22092 Make_Identifier (Loc, Chars => Chars (Ent)),
22094 Parameter_Specifications => New_List (
22095 Make_Parameter_Specification (Loc,
22096 Defining_Identifier =>
22097 Make_Defining_Identifier (Loc, Name_Value),
22099 Make_Identifier (Loc, Chars => Chars (Ent))),
22101 Make_Parameter_Specification (Loc,
22102 Defining_Identifier =>
22103 Make_Defining_Identifier (Loc, Name_Amount),
22105 New_Occurrence_Of (Standard_Natural, Loc)))));
22109 Chars => Name_Import,
22110 Pragma_Argument_Associations => New_List (
22111 Make_Pragma_Argument_Association (Loc,
22112 Expression => Make_Identifier (Loc, Name_Intrinsic)),
22113 Make_Pragma_Argument_Association (Loc,
22114 Expression => Make_Identifier (Loc, Nam))));
22116 Insert_After (N, Import);
22117 Insert_After (N, Func);
22118 end Declare_Shift_Operator;
22120 -- Start of processing for Provide_Shift_Operators
22124 Check_Arg_Count (1);
22125 Check_Arg_Is_Local_Name (Arg1);
22127 Arg1 := Get_Pragma_Arg (Arg1);
22129 -- We must have an entity name
22131 if not Is_Entity_Name (Arg1) then
22133 ("pragma % must apply to integer first subtype", Arg1);
22136 -- If no Entity, means there was a prior error so ignore
22138 if Present (Entity (Arg1)) then
22139 Ent := Entity (Arg1);
22141 -- Apply error checks
22143 if not Is_First_Subtype (Ent) then
22145 ("cannot apply pragma %",
22146 "\& is not a first subtype",
22149 elsif not Is_Integer_Type (Ent) then
22151 ("cannot apply pragma %",
22152 "\& is not an integer type",
22155 elsif Has_Shift_Operator (Ent) then
22157 ("cannot apply pragma %",
22158 "\& already has declared shift operators",
22161 elsif Is_Frozen (Ent) then
22163 ("pragma % appears too late",
22164 "\& is already frozen",
22168 -- Now declare the operators. We do this during analysis rather
22169 -- than expansion, since we want the operators available if we
22170 -- are operating in -gnatc or ASIS mode.
22172 Declare_Shift_Operator (Name_Rotate_Left);
22173 Declare_Shift_Operator (Name_Rotate_Right);
22174 Declare_Shift_Operator (Name_Shift_Left);
22175 Declare_Shift_Operator (Name_Shift_Right);
22176 Declare_Shift_Operator (Name_Shift_Right_Arithmetic);
22178 end Provide_Shift_Operators;
22184 -- pragma Psect_Object (
22185 -- [Internal =>] LOCAL_NAME,
22186 -- [, [External =>] EXTERNAL_SYMBOL]
22187 -- [, [Size =>] EXTERNAL_SYMBOL]);
22189 when Pragma_Common_Object
22190 | Pragma_Psect_Object
22192 Psect_Object : declare
22193 Args : Args_List (1 .. 3);
22194 Names : constant Name_List (1 .. 3) := (
22199 Internal : Node_Id renames Args (1);
22200 External : Node_Id renames Args (2);
22201 Size : Node_Id renames Args (3);
22203 Def_Id : Entity_Id;
22205 procedure Check_Arg (Arg : Node_Id);
22206 -- Checks that argument is either a string literal or an
22207 -- identifier, and posts error message if not.
22213 procedure Check_Arg (Arg : Node_Id) is
22215 if not Nkind_In (Original_Node (Arg),
22220 ("inappropriate argument for pragma %", Arg);
22224 -- Start of processing for Common_Object/Psect_Object
22228 Gather_Associations (Names, Args);
22229 Process_Extended_Import_Export_Internal_Arg (Internal);
22231 Def_Id := Entity (Internal);
22233 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
22235 ("pragma% must designate an object", Internal);
22238 Check_Arg (Internal);
22240 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
22242 ("cannot use pragma% for imported/exported object",
22246 if Is_Concurrent_Type (Etype (Internal)) then
22248 ("cannot specify pragma % for task/protected object",
22252 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
22254 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
22256 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N);
22259 if Ekind (Def_Id) = E_Constant then
22261 ("cannot specify pragma % for a constant", Internal);
22264 if Is_Record_Type (Etype (Internal)) then
22270 Ent := First_Entity (Etype (Internal));
22271 while Present (Ent) loop
22272 Decl := Declaration_Node (Ent);
22274 if Ekind (Ent) = E_Component
22275 and then Nkind (Decl) = N_Component_Declaration
22276 and then Present (Expression (Decl))
22277 and then Warn_On_Export_Import
22280 ("?x?object for pragma % has defaults", Internal);
22290 if Present (Size) then
22294 if Present (External) then
22295 Check_Arg_Is_External_Name (External);
22298 -- If all error tests pass, link pragma on to the rep item chain
22300 Record_Rep_Item (Def_Id, N);
22307 -- pragma Pure [(library_unit_NAME)];
22309 when Pragma_Pure => Pure : declare
22313 Check_Ada_83_Warning;
22315 -- If the pragma comes from a subprogram instantiation, nothing to
22316 -- check, this can happen at any level of nesting.
22318 if Is_Wrapper_Package (Current_Scope) then
22321 Check_Valid_Library_Unit_Pragma;
22324 if Nkind (N) = N_Null_Statement then
22328 Ent := Find_Lib_Unit_Name;
22330 -- A pragma that applies to a Ghost entity becomes Ghost for the
22331 -- purposes of legality checks and removal of ignored Ghost code.
22333 Mark_Ghost_Pragma (N, Ent);
22335 if not Debug_Flag_U then
22337 Set_Has_Pragma_Pure (Ent);
22339 if Legacy_Elaboration_Checks then
22340 Set_Suppress_Elaboration_Warnings (Ent);
22345 -------------------
22346 -- Pure_Function --
22347 -------------------
22349 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
22351 when Pragma_Pure_Function => Pure_Function : declare
22352 Def_Id : Entity_Id;
22355 Effective : Boolean := False;
22356 Orig_Def : Entity_Id;
22357 Same_Decl : Boolean := False;
22361 Check_Arg_Count (1);
22362 Check_Optional_Identifier (Arg1, Name_Entity);
22363 Check_Arg_Is_Local_Name (Arg1);
22364 E_Id := Get_Pragma_Arg (Arg1);
22366 if Etype (E_Id) = Any_Type then
22370 -- Loop through homonyms (overloadings) of referenced entity
22372 E := Entity (E_Id);
22374 -- A pragma that applies to a Ghost entity becomes Ghost for the
22375 -- purposes of legality checks and removal of ignored Ghost code.
22377 Mark_Ghost_Pragma (N, E);
22379 if Present (E) then
22381 Def_Id := Get_Base_Subprogram (E);
22383 if not Ekind_In (Def_Id, E_Function,
22384 E_Generic_Function,
22388 ("pragma% requires a function name", Arg1);
22391 -- When we have a generic function we must jump up a level
22392 -- to the declaration of the wrapper package itself.
22394 Orig_Def := Def_Id;
22396 if Is_Generic_Instance (Def_Id) then
22397 while Nkind (Orig_Def) /= N_Package_Declaration loop
22398 Orig_Def := Parent (Orig_Def);
22402 if In_Same_Declarative_Part (Parent (N), Orig_Def) then
22404 Set_Is_Pure (Def_Id);
22406 if not Has_Pragma_Pure_Function (Def_Id) then
22407 Set_Has_Pragma_Pure_Function (Def_Id);
22412 exit when From_Aspect_Specification (N);
22414 exit when No (E) or else Scope (E) /= Current_Scope;
22418 and then Warn_On_Redundant_Constructs
22421 ("pragma Pure_Function on& is redundant?r?",
22424 elsif not Same_Decl then
22426 ("pragma% argument must be in same declarative part",
22432 --------------------
22433 -- Queuing_Policy --
22434 --------------------
22436 -- pragma Queuing_Policy (policy_IDENTIFIER);
22438 when Pragma_Queuing_Policy => declare
22442 Check_Ada_83_Warning;
22443 Check_Arg_Count (1);
22444 Check_No_Identifiers;
22445 Check_Arg_Is_Queuing_Policy (Arg1);
22446 Check_Valid_Configuration_Pragma;
22447 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
22448 QP := Fold_Upper (Name_Buffer (1));
22450 if Queuing_Policy /= ' '
22451 and then Queuing_Policy /= QP
22453 Error_Msg_Sloc := Queuing_Policy_Sloc;
22454 Error_Pragma ("queuing policy incompatible with policy#");
22456 -- Set new policy, but always preserve System_Location since we
22457 -- like the error message with the run time name.
22460 Queuing_Policy := QP;
22462 if Queuing_Policy_Sloc /= System_Location then
22463 Queuing_Policy_Sloc := Loc;
22472 -- pragma Rational, for compatibility with foreign compiler
22474 when Pragma_Rational =>
22475 Set_Rational_Profile;
22477 ---------------------
22478 -- Refined_Depends --
22479 ---------------------
22481 -- pragma Refined_Depends (DEPENDENCY_RELATION);
22483 -- DEPENDENCY_RELATION ::=
22485 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
22487 -- DEPENDENCY_CLAUSE ::=
22488 -- OUTPUT_LIST =>[+] INPUT_LIST
22489 -- | NULL_DEPENDENCY_CLAUSE
22491 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
22493 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
22495 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
22497 -- OUTPUT ::= NAME | FUNCTION_RESULT
22500 -- where FUNCTION_RESULT is a function Result attribute_reference
22502 -- Characteristics:
22504 -- * Analysis - The annotation undergoes initial checks to verify
22505 -- the legal placement and context. Secondary checks fully analyze
22506 -- the dependency clauses/global list in:
22508 -- Analyze_Refined_Depends_In_Decl_Part
22510 -- * Expansion - None.
22512 -- * Template - The annotation utilizes the generic template of the
22513 -- related subprogram body.
22515 -- * Globals - Capture of global references must occur after full
22518 -- * Instance - The annotation is instantiated automatically when
22519 -- the related generic subprogram body is instantiated.
22521 when Pragma_Refined_Depends => Refined_Depends : declare
22522 Body_Id : Entity_Id;
22524 Spec_Id : Entity_Id;
22527 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
22531 -- Chain the pragma on the contract for further processing by
22532 -- Analyze_Refined_Depends_In_Decl_Part.
22534 Add_Contract_Item (N, Body_Id);
22536 -- The legality checks of pragmas Refined_Depends and
22537 -- Refined_Global are affected by the SPARK mode in effect and
22538 -- the volatility of the context. In addition these two pragmas
22539 -- are subject to an inherent order:
22541 -- 1) Refined_Global
22542 -- 2) Refined_Depends
22544 -- Analyze all these pragmas in the order outlined above
22546 Analyze_If_Present (Pragma_SPARK_Mode);
22547 Analyze_If_Present (Pragma_Volatile_Function);
22548 Analyze_If_Present (Pragma_Refined_Global);
22549 Analyze_Refined_Depends_In_Decl_Part (N);
22551 end Refined_Depends;
22553 --------------------
22554 -- Refined_Global --
22555 --------------------
22557 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
22559 -- GLOBAL_SPECIFICATION ::=
22562 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
22564 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
22566 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
22567 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
22568 -- GLOBAL_ITEM ::= NAME
22570 -- Characteristics:
22572 -- * Analysis - The annotation undergoes initial checks to verify
22573 -- the legal placement and context. Secondary checks fully analyze
22574 -- the dependency clauses/global list in:
22576 -- Analyze_Refined_Global_In_Decl_Part
22578 -- * Expansion - None.
22580 -- * Template - The annotation utilizes the generic template of the
22581 -- related subprogram body.
22583 -- * Globals - Capture of global references must occur after full
22586 -- * Instance - The annotation is instantiated automatically when
22587 -- the related generic subprogram body is instantiated.
22589 when Pragma_Refined_Global => Refined_Global : declare
22590 Body_Id : Entity_Id;
22592 Spec_Id : Entity_Id;
22595 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
22599 -- Chain the pragma on the contract for further processing by
22600 -- Analyze_Refined_Global_In_Decl_Part.
22602 Add_Contract_Item (N, Body_Id);
22604 -- The legality checks of pragmas Refined_Depends and
22605 -- Refined_Global are affected by the SPARK mode in effect and
22606 -- the volatility of the context. In addition these two pragmas
22607 -- are subject to an inherent order:
22609 -- 1) Refined_Global
22610 -- 2) Refined_Depends
22612 -- Analyze all these pragmas in the order outlined above
22614 Analyze_If_Present (Pragma_SPARK_Mode);
22615 Analyze_If_Present (Pragma_Volatile_Function);
22616 Analyze_Refined_Global_In_Decl_Part (N);
22617 Analyze_If_Present (Pragma_Refined_Depends);
22619 end Refined_Global;
22625 -- pragma Refined_Post (boolean_EXPRESSION);
22627 -- Characteristics:
22629 -- * Analysis - The annotation is fully analyzed immediately upon
22630 -- elaboration as it cannot forward reference entities.
22632 -- * Expansion - The annotation is expanded during the expansion of
22633 -- the related subprogram body contract as performed in:
22635 -- Expand_Subprogram_Contract
22637 -- * Template - The annotation utilizes the generic template of the
22638 -- related subprogram body.
22640 -- * Globals - Capture of global references must occur after full
22643 -- * Instance - The annotation is instantiated automatically when
22644 -- the related generic subprogram body is instantiated.
22646 when Pragma_Refined_Post => Refined_Post : declare
22647 Body_Id : Entity_Id;
22649 Spec_Id : Entity_Id;
22652 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
22654 -- Fully analyze the pragma when it appears inside a subprogram
22655 -- body because it cannot benefit from forward references.
22659 -- Chain the pragma on the contract for completeness
22661 Add_Contract_Item (N, Body_Id);
22663 -- The legality checks of pragma Refined_Post are affected by
22664 -- the SPARK mode in effect and the volatility of the context.
22665 -- Analyze all pragmas in a specific order.
22667 Analyze_If_Present (Pragma_SPARK_Mode);
22668 Analyze_If_Present (Pragma_Volatile_Function);
22669 Analyze_Pre_Post_Condition_In_Decl_Part (N);
22671 -- Currently it is not possible to inline pre/postconditions on
22672 -- a subprogram subject to pragma Inline_Always.
22674 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
22678 -------------------
22679 -- Refined_State --
22680 -------------------
22682 -- pragma Refined_State (REFINEMENT_LIST);
22684 -- REFINEMENT_LIST ::=
22685 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
22687 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
22689 -- CONSTITUENT_LIST ::=
22692 -- | (CONSTITUENT {, CONSTITUENT})
22694 -- CONSTITUENT ::= object_NAME | state_NAME
22696 -- Characteristics:
22698 -- * Analysis - The annotation undergoes initial checks to verify
22699 -- the legal placement and context. Secondary checks preanalyze the
22700 -- refinement clauses in:
22702 -- Analyze_Refined_State_In_Decl_Part
22704 -- * Expansion - None.
22706 -- * Template - The annotation utilizes the template of the related
22709 -- * Globals - Capture of global references must occur after full
22712 -- * Instance - The annotation is instantiated automatically when
22713 -- the related generic package body is instantiated.
22715 when Pragma_Refined_State => Refined_State : declare
22716 Pack_Decl : Node_Id;
22717 Spec_Id : Entity_Id;
22721 Check_No_Identifiers;
22722 Check_Arg_Count (1);
22724 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
22726 if Nkind (Pack_Decl) /= N_Package_Body then
22731 Spec_Id := Corresponding_Spec (Pack_Decl);
22733 -- A pragma that applies to a Ghost entity becomes Ghost for the
22734 -- purposes of legality checks and removal of ignored Ghost code.
22736 Mark_Ghost_Pragma (N, Spec_Id);
22738 -- Chain the pragma on the contract for further processing by
22739 -- Analyze_Refined_State_In_Decl_Part.
22741 Add_Contract_Item (N, Defining_Entity (Pack_Decl));
22743 -- The legality checks of pragma Refined_State are affected by the
22744 -- SPARK mode in effect. Analyze all pragmas in a specific order.
22746 Analyze_If_Present (Pragma_SPARK_Mode);
22748 -- State refinement is allowed only when the corresponding package
22749 -- declaration has non-null pragma Abstract_State. Refinement not
22750 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
22752 if SPARK_Mode /= Off
22754 (No (Abstract_States (Spec_Id))
22755 or else Has_Null_Abstract_State (Spec_Id))
22758 ("useless refinement, package & does not define abstract "
22759 & "states", N, Spec_Id);
22764 -----------------------
22765 -- Relative_Deadline --
22766 -----------------------
22768 -- pragma Relative_Deadline (time_span_EXPRESSION);
22770 when Pragma_Relative_Deadline => Relative_Deadline : declare
22771 P : constant Node_Id := Parent (N);
22776 Check_No_Identifiers;
22777 Check_Arg_Count (1);
22779 Arg := Get_Pragma_Arg (Arg1);
22781 -- The expression must be analyzed in the special manner described
22782 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
22784 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
22788 if Nkind (P) = N_Subprogram_Body then
22789 Check_In_Main_Program;
22791 -- Only Task and subprogram cases allowed
22793 elsif Nkind (P) /= N_Task_Definition then
22797 -- Check duplicate pragma before we set the corresponding flag
22799 if Has_Relative_Deadline_Pragma (P) then
22800 Error_Pragma ("duplicate pragma% not allowed");
22803 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
22804 -- Relative_Deadline pragma node cannot be inserted in the Rep
22805 -- Item chain of Ent since it is rewritten by the expander as a
22806 -- procedure call statement that will break the chain.
22808 Set_Has_Relative_Deadline_Pragma (P);
22809 end Relative_Deadline;
22811 ------------------------
22812 -- Remote_Access_Type --
22813 ------------------------
22815 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
22817 when Pragma_Remote_Access_Type => Remote_Access_Type : declare
22822 Check_Arg_Count (1);
22823 Check_Optional_Identifier (Arg1, Name_Entity);
22824 Check_Arg_Is_Local_Name (Arg1);
22826 E := Entity (Get_Pragma_Arg (Arg1));
22828 -- A pragma that applies to a Ghost entity becomes Ghost for the
22829 -- purposes of legality checks and removal of ignored Ghost code.
22831 Mark_Ghost_Pragma (N, E);
22833 if Nkind (Parent (E)) = N_Formal_Type_Declaration
22834 and then Ekind (E) = E_General_Access_Type
22835 and then Is_Class_Wide_Type (Directly_Designated_Type (E))
22836 and then Scope (Root_Type (Directly_Designated_Type (E)))
22838 and then Is_Valid_Remote_Object_Type
22839 (Root_Type (Directly_Designated_Type (E)))
22841 Set_Is_Remote_Types (E);
22845 ("pragma% applies only to formal access-to-class-wide types",
22848 end Remote_Access_Type;
22850 ---------------------------
22851 -- Remote_Call_Interface --
22852 ---------------------------
22854 -- pragma Remote_Call_Interface [(library_unit_NAME)];
22856 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
22857 Cunit_Node : Node_Id;
22858 Cunit_Ent : Entity_Id;
22862 Check_Ada_83_Warning;
22863 Check_Valid_Library_Unit_Pragma;
22865 if Nkind (N) = N_Null_Statement then
22869 Cunit_Node := Cunit (Current_Sem_Unit);
22870 K := Nkind (Unit (Cunit_Node));
22871 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22873 -- A pragma that applies to a Ghost entity becomes Ghost for the
22874 -- purposes of legality checks and removal of ignored Ghost code.
22876 Mark_Ghost_Pragma (N, Cunit_Ent);
22878 if K = N_Package_Declaration
22879 or else K = N_Generic_Package_Declaration
22880 or else K = N_Subprogram_Declaration
22881 or else K = N_Generic_Subprogram_Declaration
22882 or else (K = N_Subprogram_Body
22883 and then Acts_As_Spec (Unit (Cunit_Node)))
22888 "pragma% must apply to package or subprogram declaration");
22891 Set_Is_Remote_Call_Interface (Cunit_Ent);
22892 end Remote_Call_Interface;
22898 -- pragma Remote_Types [(library_unit_NAME)];
22900 when Pragma_Remote_Types => Remote_Types : declare
22901 Cunit_Node : Node_Id;
22902 Cunit_Ent : Entity_Id;
22905 Check_Ada_83_Warning;
22906 Check_Valid_Library_Unit_Pragma;
22908 if Nkind (N) = N_Null_Statement then
22912 Cunit_Node := Cunit (Current_Sem_Unit);
22913 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22915 -- A pragma that applies to a Ghost entity becomes Ghost for the
22916 -- purposes of legality checks and removal of ignored Ghost code.
22918 Mark_Ghost_Pragma (N, Cunit_Ent);
22920 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
22921 N_Generic_Package_Declaration)
22924 ("pragma% can only apply to a package declaration");
22927 Set_Is_Remote_Types (Cunit_Ent);
22934 -- pragma Ravenscar;
22936 when Pragma_Ravenscar =>
22938 Check_Arg_Count (0);
22939 Check_Valid_Configuration_Pragma;
22940 Set_Ravenscar_Profile (Ravenscar, N);
22942 if Warn_On_Obsolescent_Feature then
22944 ("pragma Ravenscar is an obsolescent feature?j?", N);
22946 ("|use pragma Profile (Ravenscar) instead?j?", N);
22949 -------------------------
22950 -- Restricted_Run_Time --
22951 -------------------------
22953 -- pragma Restricted_Run_Time;
22955 when Pragma_Restricted_Run_Time =>
22957 Check_Arg_Count (0);
22958 Check_Valid_Configuration_Pragma;
22959 Set_Profile_Restrictions
22960 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
22962 if Warn_On_Obsolescent_Feature then
22964 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
22967 ("|use pragma Profile (Restricted) instead?j?", N);
22974 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
22977 -- restriction_IDENTIFIER
22978 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22980 when Pragma_Restrictions =>
22981 Process_Restrictions_Or_Restriction_Warnings
22982 (Warn => Treat_Restrictions_As_Warnings);
22984 --------------------------
22985 -- Restriction_Warnings --
22986 --------------------------
22988 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
22991 -- restriction_IDENTIFIER
22992 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22994 when Pragma_Restriction_Warnings =>
22996 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
23002 -- pragma Reviewable;
23004 when Pragma_Reviewable =>
23005 Check_Ada_83_Warning;
23006 Check_Arg_Count (0);
23008 -- Call dummy debugging function rv. This is done to assist front
23009 -- end debugging. By placing a Reviewable pragma in the source
23010 -- program, a breakpoint on rv catches this place in the source,
23011 -- allowing convenient stepping to the point of interest.
23015 --------------------------
23016 -- Secondary_Stack_Size --
23017 --------------------------
23019 -- pragma Secondary_Stack_Size (EXPRESSION);
23021 when Pragma_Secondary_Stack_Size => Secondary_Stack_Size : declare
23022 P : constant Node_Id := Parent (N);
23028 Check_No_Identifiers;
23029 Check_Arg_Count (1);
23031 if Nkind (P) = N_Task_Definition then
23032 Arg := Get_Pragma_Arg (Arg1);
23033 Ent := Defining_Identifier (Parent (P));
23035 -- The expression must be analyzed in the special manner
23036 -- described in "Handling of Default Expressions" in sem.ads.
23038 Preanalyze_Spec_Expression (Arg, Any_Integer);
23040 -- The pragma cannot appear if the No_Secondary_Stack
23041 -- restriction is in effect.
23043 Check_Restriction (No_Secondary_Stack, Arg);
23045 -- Anything else is incorrect
23051 -- Check duplicate pragma before we chain the pragma in the Rep
23052 -- Item chain of Ent.
23054 Check_Duplicate_Pragma (Ent);
23055 Record_Rep_Item (Ent, N);
23056 end Secondary_Stack_Size;
23058 --------------------------
23059 -- Short_Circuit_And_Or --
23060 --------------------------
23062 -- pragma Short_Circuit_And_Or;
23064 when Pragma_Short_Circuit_And_Or =>
23066 Check_Arg_Count (0);
23067 Check_Valid_Configuration_Pragma;
23068 Short_Circuit_And_Or := True;
23070 -------------------
23071 -- Share_Generic --
23072 -------------------
23074 -- pragma Share_Generic (GNAME {, GNAME});
23076 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
23078 when Pragma_Share_Generic =>
23080 Process_Generic_List;
23086 -- pragma Shared (LOCAL_NAME);
23088 when Pragma_Shared =>
23090 Process_Atomic_Independent_Shared_Volatile;
23092 --------------------
23093 -- Shared_Passive --
23094 --------------------
23096 -- pragma Shared_Passive [(library_unit_NAME)];
23098 -- Set the flag Is_Shared_Passive of program unit name entity
23100 when Pragma_Shared_Passive => Shared_Passive : declare
23101 Cunit_Node : Node_Id;
23102 Cunit_Ent : Entity_Id;
23105 Check_Ada_83_Warning;
23106 Check_Valid_Library_Unit_Pragma;
23108 if Nkind (N) = N_Null_Statement then
23112 Cunit_Node := Cunit (Current_Sem_Unit);
23113 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
23115 -- A pragma that applies to a Ghost entity becomes Ghost for the
23116 -- purposes of legality checks and removal of ignored Ghost code.
23118 Mark_Ghost_Pragma (N, Cunit_Ent);
23120 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
23121 N_Generic_Package_Declaration)
23124 ("pragma% can only apply to a package declaration");
23127 Set_Is_Shared_Passive (Cunit_Ent);
23128 end Shared_Passive;
23130 -----------------------
23131 -- Short_Descriptors --
23132 -----------------------
23134 -- pragma Short_Descriptors;
23136 -- Recognize and validate, but otherwise ignore
23138 when Pragma_Short_Descriptors =>
23140 Check_Arg_Count (0);
23141 Check_Valid_Configuration_Pragma;
23143 ------------------------------
23144 -- Simple_Storage_Pool_Type --
23145 ------------------------------
23147 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
23149 when Pragma_Simple_Storage_Pool_Type =>
23150 Simple_Storage_Pool_Type : declare
23156 Check_Arg_Count (1);
23157 Check_Arg_Is_Library_Level_Local_Name (Arg1);
23159 Type_Id := Get_Pragma_Arg (Arg1);
23160 Find_Type (Type_Id);
23161 Typ := Entity (Type_Id);
23163 if Typ = Any_Type then
23167 -- A pragma that applies to a Ghost entity becomes Ghost for the
23168 -- purposes of legality checks and removal of ignored Ghost code.
23170 Mark_Ghost_Pragma (N, Typ);
23172 -- We require the pragma to apply to a type declared in a package
23173 -- declaration, but not (immediately) within a package body.
23175 if Ekind (Current_Scope) /= E_Package
23176 or else In_Package_Body (Current_Scope)
23179 ("pragma% can only apply to type declared immediately "
23180 & "within a package declaration");
23183 -- A simple storage pool type must be an immutably limited record
23184 -- or private type. If the pragma is given for a private type,
23185 -- the full type is similarly restricted (which is checked later
23186 -- in Freeze_Entity).
23188 if Is_Record_Type (Typ)
23189 and then not Is_Limited_View (Typ)
23192 ("pragma% can only apply to explicitly limited record type");
23194 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
23196 ("pragma% can only apply to a private type that is limited");
23198 elsif not Is_Record_Type (Typ)
23199 and then not Is_Private_Type (Typ)
23202 ("pragma% can only apply to limited record or private type");
23205 Record_Rep_Item (Typ, N);
23206 end Simple_Storage_Pool_Type;
23208 ----------------------
23209 -- Source_File_Name --
23210 ----------------------
23212 -- There are five forms for this pragma:
23214 -- pragma Source_File_Name (
23215 -- [UNIT_NAME =>] unit_NAME,
23216 -- BODY_FILE_NAME => STRING_LITERAL
23217 -- [, [INDEX =>] INTEGER_LITERAL]);
23219 -- pragma Source_File_Name (
23220 -- [UNIT_NAME =>] unit_NAME,
23221 -- SPEC_FILE_NAME => STRING_LITERAL
23222 -- [, [INDEX =>] INTEGER_LITERAL]);
23224 -- pragma Source_File_Name (
23225 -- BODY_FILE_NAME => STRING_LITERAL
23226 -- [, DOT_REPLACEMENT => STRING_LITERAL]
23227 -- [, CASING => CASING_SPEC]);
23229 -- pragma Source_File_Name (
23230 -- SPEC_FILE_NAME => STRING_LITERAL
23231 -- [, DOT_REPLACEMENT => STRING_LITERAL]
23232 -- [, CASING => CASING_SPEC]);
23234 -- pragma Source_File_Name (
23235 -- SUBUNIT_FILE_NAME => STRING_LITERAL
23236 -- [, DOT_REPLACEMENT => STRING_LITERAL]
23237 -- [, CASING => CASING_SPEC]);
23239 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
23241 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
23242 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
23243 -- only be used when no project file is used, while SFNP can only be
23244 -- used when a project file is used.
23246 -- No processing here. Processing was completed during parsing, since
23247 -- we need to have file names set as early as possible. Units are
23248 -- loaded well before semantic processing starts.
23250 -- The only processing we defer to this point is the check for
23251 -- correct placement.
23253 when Pragma_Source_File_Name =>
23255 Check_Valid_Configuration_Pragma;
23257 ------------------------------
23258 -- Source_File_Name_Project --
23259 ------------------------------
23261 -- See Source_File_Name for syntax
23263 -- No processing here. Processing was completed during parsing, since
23264 -- we need to have file names set as early as possible. Units are
23265 -- loaded well before semantic processing starts.
23267 -- The only processing we defer to this point is the check for
23268 -- correct placement.
23270 when Pragma_Source_File_Name_Project =>
23272 Check_Valid_Configuration_Pragma;
23274 -- Check that a pragma Source_File_Name_Project is used only in a
23275 -- configuration pragmas file.
23277 -- Pragmas Source_File_Name_Project should only be generated by
23278 -- the Project Manager in configuration pragmas files.
23280 -- This is really an ugly test. It seems to depend on some
23281 -- accidental and undocumented property. At the very least it
23282 -- needs to be documented, but it would be better to have a
23283 -- clean way of testing if we are in a configuration file???
23285 if Present (Parent (N)) then
23287 ("pragma% can only appear in a configuration pragmas file");
23290 ----------------------
23291 -- Source_Reference --
23292 ----------------------
23294 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
23296 -- Nothing to do, all processing completed in Par.Prag, since we need
23297 -- the information for possible parser messages that are output.
23299 when Pragma_Source_Reference =>
23306 -- pragma SPARK_Mode [(On | Off)];
23308 when Pragma_SPARK_Mode => Do_SPARK_Mode : declare
23309 Mode_Id : SPARK_Mode_Type;
23311 procedure Check_Pragma_Conformance
23312 (Context_Pragma : Node_Id;
23313 Entity : Entity_Id;
23314 Entity_Pragma : Node_Id);
23315 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
23316 -- conformance of pragma N depending the following scenarios:
23318 -- If pragma Context_Pragma is not Empty, verify that pragma N is
23319 -- compatible with the pragma Context_Pragma that was inherited
23320 -- from the context:
23321 -- * If the mode of Context_Pragma is ON, then the new mode can
23323 -- * If the mode of Context_Pragma is OFF, then the only allowed
23324 -- new mode is also OFF. Emit error if this is not the case.
23326 -- If Entity is not Empty, verify that pragma N is compatible with
23327 -- pragma Entity_Pragma that belongs to Entity.
23328 -- * If Entity_Pragma is Empty, always issue an error as this
23329 -- corresponds to the case where a previous section of Entity
23330 -- has no SPARK_Mode set.
23331 -- * If the mode of Entity_Pragma is ON, then the new mode can
23333 -- * If the mode of Entity_Pragma is OFF, then the only allowed
23334 -- new mode is also OFF. Emit error if this is not the case.
23336 procedure Check_Library_Level_Entity (E : Entity_Id);
23337 -- Subsidiary to routines Process_xxx. Verify that the related
23338 -- entity E subject to pragma SPARK_Mode is library-level.
23340 procedure Process_Body (Decl : Node_Id);
23341 -- Verify the legality of pragma SPARK_Mode when it appears as the
23342 -- top of the body declarations of entry, package, protected unit,
23343 -- subprogram or task unit body denoted by Decl.
23345 procedure Process_Overloadable (Decl : Node_Id);
23346 -- Verify the legality of pragma SPARK_Mode when it applies to an
23347 -- entry or [generic] subprogram declaration denoted by Decl.
23349 procedure Process_Private_Part (Decl : Node_Id);
23350 -- Verify the legality of pragma SPARK_Mode when it appears at the
23351 -- top of the private declarations of a package spec, protected or
23352 -- task unit declaration denoted by Decl.
23354 procedure Process_Statement_Part (Decl : Node_Id);
23355 -- Verify the legality of pragma SPARK_Mode when it appears at the
23356 -- top of the statement sequence of a package body denoted by node
23359 procedure Process_Visible_Part (Decl : Node_Id);
23360 -- Verify the legality of pragma SPARK_Mode when it appears at the
23361 -- top of the visible declarations of a package spec, protected or
23362 -- task unit declaration denoted by Decl. The routine is also used
23363 -- on protected or task units declared without a definition.
23365 procedure Set_SPARK_Context;
23366 -- Subsidiary to routines Process_xxx. Set the global variables
23367 -- which represent the mode of the context from pragma N. Ensure
23368 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
23370 ------------------------------
23371 -- Check_Pragma_Conformance --
23372 ------------------------------
23374 procedure Check_Pragma_Conformance
23375 (Context_Pragma : Node_Id;
23376 Entity : Entity_Id;
23377 Entity_Pragma : Node_Id)
23379 Err_Id : Entity_Id;
23383 -- The current pragma may appear without an argument. If this
23384 -- is the case, associate all error messages with the pragma
23387 if Present (Arg1) then
23393 -- The mode of the current pragma is compared against that of
23394 -- an enclosing context.
23396 if Present (Context_Pragma) then
23397 pragma Assert (Nkind (Context_Pragma) = N_Pragma);
23399 -- Issue an error if the new mode is less restrictive than
23400 -- that of the context.
23402 if Get_SPARK_Mode_From_Annotation (Context_Pragma) = Off
23403 and then Get_SPARK_Mode_From_Annotation (N) = On
23406 ("cannot change SPARK_Mode from Off to On", Err_N);
23407 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
23408 Error_Msg_N ("\SPARK_Mode was set to Off#", Err_N);
23413 -- The mode of the current pragma is compared against that of
23414 -- an initial package, protected type, subprogram or task type
23417 if Present (Entity) then
23419 -- A simple protected or task type is transformed into an
23420 -- anonymous type whose name cannot be used to issue error
23421 -- messages. Recover the original entity of the type.
23423 if Ekind_In (Entity, E_Protected_Type, E_Task_Type) then
23426 (Original_Node (Unit_Declaration_Node (Entity)));
23431 -- Both the initial declaration and the completion carry
23432 -- SPARK_Mode pragmas.
23434 if Present (Entity_Pragma) then
23435 pragma Assert (Nkind (Entity_Pragma) = N_Pragma);
23437 -- Issue an error if the new mode is less restrictive
23438 -- than that of the initial declaration.
23440 if Get_SPARK_Mode_From_Annotation (Entity_Pragma) = Off
23441 and then Get_SPARK_Mode_From_Annotation (N) = On
23443 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
23444 Error_Msg_Sloc := Sloc (Entity_Pragma);
23446 ("\value Off was set for SPARK_Mode on&#",
23451 -- Otherwise the initial declaration lacks a SPARK_Mode
23452 -- pragma in which case the current pragma is illegal as
23453 -- it cannot "complete".
23456 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
23457 Error_Msg_Sloc := Sloc (Err_Id);
23459 ("\no value was set for SPARK_Mode on&#",
23464 end Check_Pragma_Conformance;
23466 --------------------------------
23467 -- Check_Library_Level_Entity --
23468 --------------------------------
23470 procedure Check_Library_Level_Entity (E : Entity_Id) is
23471 procedure Add_Entity_To_Name_Buffer;
23472 -- Add the E_Kind of entity E to the name buffer
23474 -------------------------------
23475 -- Add_Entity_To_Name_Buffer --
23476 -------------------------------
23478 procedure Add_Entity_To_Name_Buffer is
23480 if Ekind_In (E, E_Entry, E_Entry_Family) then
23481 Add_Str_To_Name_Buffer ("entry");
23483 elsif Ekind_In (E, E_Generic_Package,
23487 Add_Str_To_Name_Buffer ("package");
23489 elsif Ekind_In (E, E_Protected_Body, E_Protected_Type) then
23490 Add_Str_To_Name_Buffer ("protected type");
23492 elsif Ekind_In (E, E_Function,
23493 E_Generic_Function,
23494 E_Generic_Procedure,
23498 Add_Str_To_Name_Buffer ("subprogram");
23501 pragma Assert (Ekind_In (E, E_Task_Body, E_Task_Type));
23502 Add_Str_To_Name_Buffer ("task type");
23504 end Add_Entity_To_Name_Buffer;
23508 Msg_1 : constant String := "incorrect placement of pragma%";
23511 -- Start of processing for Check_Library_Level_Entity
23514 -- A SPARK_Mode of On shall only apply to library-level
23515 -- entities, except for those in generic instances, which are
23516 -- ignored (even if the entity gets SPARK_Mode pragma attached
23517 -- in the AST, its effect is not taken into account unless the
23518 -- context already provides SPARK_Mode of On in GNATprove).
23520 if Get_SPARK_Mode_From_Annotation (N) = On
23521 and then not Is_Library_Level_Entity (E)
23522 and then Instantiation_Location (Sloc (N)) = No_Location
23524 Error_Msg_Name_1 := Pname;
23525 Error_Msg_N (Fix_Error (Msg_1), N);
23528 Add_Str_To_Name_Buffer ("\& is not a library-level ");
23529 Add_Entity_To_Name_Buffer;
23531 Msg_2 := Name_Find;
23532 Error_Msg_NE (Get_Name_String (Msg_2), N, E);
23536 end Check_Library_Level_Entity;
23542 procedure Process_Body (Decl : Node_Id) is
23543 Body_Id : constant Entity_Id := Defining_Entity (Decl);
23544 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl);
23547 -- Ignore pragma when applied to the special body created for
23548 -- inlining, recognized by its internal name _Parent.
23550 if Chars (Body_Id) = Name_uParent then
23554 Check_Library_Level_Entity (Body_Id);
23556 -- For entry bodies, verify the legality against:
23557 -- * The mode of the context
23558 -- * The mode of the spec (if any)
23560 if Nkind_In (Decl, N_Entry_Body, N_Subprogram_Body) then
23562 -- A stand-alone subprogram body
23564 if Body_Id = Spec_Id then
23565 Check_Pragma_Conformance
23566 (Context_Pragma => SPARK_Pragma (Body_Id),
23568 Entity_Pragma => Empty);
23570 -- An entry or subprogram body that completes a previous
23574 Check_Pragma_Conformance
23575 (Context_Pragma => SPARK_Pragma (Body_Id),
23577 Entity_Pragma => SPARK_Pragma (Spec_Id));
23581 Set_SPARK_Pragma (Body_Id, N);
23582 Set_SPARK_Pragma_Inherited (Body_Id, False);
23584 -- For package bodies, verify the legality against:
23585 -- * The mode of the context
23586 -- * The mode of the private part
23588 -- This case is separated from protected and task bodies
23589 -- because the statement part of the package body inherits
23590 -- the mode of the body declarations.
23592 elsif Nkind (Decl) = N_Package_Body then
23593 Check_Pragma_Conformance
23594 (Context_Pragma => SPARK_Pragma (Body_Id),
23596 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
23599 Set_SPARK_Pragma (Body_Id, N);
23600 Set_SPARK_Pragma_Inherited (Body_Id, False);
23601 Set_SPARK_Aux_Pragma (Body_Id, N);
23602 Set_SPARK_Aux_Pragma_Inherited (Body_Id, True);
23604 -- For protected and task bodies, verify the legality against:
23605 -- * The mode of the context
23606 -- * The mode of the private part
23610 (Nkind_In (Decl, N_Protected_Body, N_Task_Body));
23612 Check_Pragma_Conformance
23613 (Context_Pragma => SPARK_Pragma (Body_Id),
23615 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
23618 Set_SPARK_Pragma (Body_Id, N);
23619 Set_SPARK_Pragma_Inherited (Body_Id, False);
23623 --------------------------
23624 -- Process_Overloadable --
23625 --------------------------
23627 procedure Process_Overloadable (Decl : Node_Id) is
23628 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
23629 Spec_Typ : constant Entity_Id := Etype (Spec_Id);
23632 Check_Library_Level_Entity (Spec_Id);
23634 -- Verify the legality against:
23635 -- * The mode of the context
23637 Check_Pragma_Conformance
23638 (Context_Pragma => SPARK_Pragma (Spec_Id),
23640 Entity_Pragma => Empty);
23642 Set_SPARK_Pragma (Spec_Id, N);
23643 Set_SPARK_Pragma_Inherited (Spec_Id, False);
23645 -- When the pragma applies to the anonymous object created for
23646 -- a single task type, decorate the type as well. This scenario
23647 -- arises when the single task type lacks a task definition,
23648 -- therefore there is no issue with respect to a potential
23649 -- pragma SPARK_Mode in the private part.
23651 -- task type Anon_Task_Typ;
23652 -- Obj : Anon_Task_Typ;
23653 -- pragma SPARK_Mode ...;
23655 if Is_Single_Task_Object (Spec_Id) then
23656 Set_SPARK_Pragma (Spec_Typ, N);
23657 Set_SPARK_Pragma_Inherited (Spec_Typ, False);
23658 Set_SPARK_Aux_Pragma (Spec_Typ, N);
23659 Set_SPARK_Aux_Pragma_Inherited (Spec_Typ, True);
23661 end Process_Overloadable;
23663 --------------------------
23664 -- Process_Private_Part --
23665 --------------------------
23667 procedure Process_Private_Part (Decl : Node_Id) is
23668 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
23671 Check_Library_Level_Entity (Spec_Id);
23673 -- Verify the legality against:
23674 -- * The mode of the visible declarations
23676 Check_Pragma_Conformance
23677 (Context_Pragma => Empty,
23679 Entity_Pragma => SPARK_Pragma (Spec_Id));
23682 Set_SPARK_Aux_Pragma (Spec_Id, N);
23683 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False);
23684 end Process_Private_Part;
23686 ----------------------------
23687 -- Process_Statement_Part --
23688 ----------------------------
23690 procedure Process_Statement_Part (Decl : Node_Id) is
23691 Body_Id : constant Entity_Id := Defining_Entity (Decl);
23694 Check_Library_Level_Entity (Body_Id);
23696 -- Verify the legality against:
23697 -- * The mode of the body declarations
23699 Check_Pragma_Conformance
23700 (Context_Pragma => Empty,
23702 Entity_Pragma => SPARK_Pragma (Body_Id));
23705 Set_SPARK_Aux_Pragma (Body_Id, N);
23706 Set_SPARK_Aux_Pragma_Inherited (Body_Id, False);
23707 end Process_Statement_Part;
23709 --------------------------
23710 -- Process_Visible_Part --
23711 --------------------------
23713 procedure Process_Visible_Part (Decl : Node_Id) is
23714 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
23715 Obj_Id : Entity_Id;
23718 Check_Library_Level_Entity (Spec_Id);
23720 -- Verify the legality against:
23721 -- * The mode of the context
23723 Check_Pragma_Conformance
23724 (Context_Pragma => SPARK_Pragma (Spec_Id),
23726 Entity_Pragma => Empty);
23728 -- A task unit declared without a definition does not set the
23729 -- SPARK_Mode of the context because the task does not have any
23730 -- entries that could inherit the mode.
23732 if not Nkind_In (Decl, N_Single_Task_Declaration,
23733 N_Task_Type_Declaration)
23738 Set_SPARK_Pragma (Spec_Id, N);
23739 Set_SPARK_Pragma_Inherited (Spec_Id, False);
23740 Set_SPARK_Aux_Pragma (Spec_Id, N);
23741 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True);
23743 -- When the pragma applies to a single protected or task type,
23744 -- decorate the corresponding anonymous object as well.
23746 -- protected Anon_Prot_Typ is
23747 -- pragma SPARK_Mode ...;
23749 -- end Anon_Prot_Typ;
23751 -- Obj : Anon_Prot_Typ;
23753 if Is_Single_Concurrent_Type (Spec_Id) then
23754 Obj_Id := Anonymous_Object (Spec_Id);
23756 Set_SPARK_Pragma (Obj_Id, N);
23757 Set_SPARK_Pragma_Inherited (Obj_Id, False);
23759 end Process_Visible_Part;
23761 -----------------------
23762 -- Set_SPARK_Context --
23763 -----------------------
23765 procedure Set_SPARK_Context is
23767 SPARK_Mode := Mode_Id;
23768 SPARK_Mode_Pragma := N;
23769 end Set_SPARK_Context;
23777 -- Start of processing for Do_SPARK_Mode
23780 -- When a SPARK_Mode pragma appears inside an instantiation whose
23781 -- enclosing context has SPARK_Mode set to "off", the pragma has
23782 -- no semantic effect.
23784 if Ignore_SPARK_Mode_Pragmas_In_Instance then
23785 Rewrite (N, Make_Null_Statement (Loc));
23791 Check_No_Identifiers;
23792 Check_At_Most_N_Arguments (1);
23794 -- Check the legality of the mode (no argument = ON)
23796 if Arg_Count = 1 then
23797 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23798 Mode := Chars (Get_Pragma_Arg (Arg1));
23803 Mode_Id := Get_SPARK_Mode_Type (Mode);
23804 Context := Parent (N);
23806 -- The pragma appears in a configuration file
23808 if No (Context) then
23809 Check_Valid_Configuration_Pragma;
23811 if Present (SPARK_Mode_Pragma) then
23814 Prev => SPARK_Mode_Pragma);
23820 -- The pragma acts as a configuration pragma in a compilation unit
23822 -- pragma SPARK_Mode ...;
23823 -- package Pack is ...;
23825 elsif Nkind (Context) = N_Compilation_Unit
23826 and then List_Containing (N) = Context_Items (Context)
23828 Check_Valid_Configuration_Pragma;
23831 -- Otherwise the placement of the pragma within the tree dictates
23832 -- its associated construct. Inspect the declarative list where
23833 -- the pragma resides to find a potential construct.
23837 while Present (Stmt) loop
23839 -- Skip prior pragmas, but check for duplicates. Note that
23840 -- this also takes care of pragmas generated for aspects.
23842 if Nkind (Stmt) = N_Pragma then
23843 if Pragma_Name (Stmt) = Pname then
23850 -- The pragma applies to an expression function that has
23851 -- already been rewritten into a subprogram declaration.
23853 -- function Expr_Func return ... is (...);
23854 -- pragma SPARK_Mode ...;
23856 elsif Nkind (Stmt) = N_Subprogram_Declaration
23857 and then Nkind (Original_Node (Stmt)) =
23858 N_Expression_Function
23860 Process_Overloadable (Stmt);
23863 -- The pragma applies to the anonymous object created for a
23864 -- single concurrent type.
23866 -- protected type Anon_Prot_Typ ...;
23867 -- Obj : Anon_Prot_Typ;
23868 -- pragma SPARK_Mode ...;
23870 elsif Nkind (Stmt) = N_Object_Declaration
23871 and then Is_Single_Concurrent_Object
23872 (Defining_Entity (Stmt))
23874 Process_Overloadable (Stmt);
23877 -- Skip internally generated code
23879 elsif not Comes_From_Source (Stmt) then
23882 -- The pragma applies to an entry or [generic] subprogram
23886 -- pragma SPARK_Mode ...;
23889 -- procedure Proc ...;
23890 -- pragma SPARK_Mode ...;
23892 elsif Nkind_In (Stmt, N_Generic_Subprogram_Declaration,
23893 N_Subprogram_Declaration)
23894 or else (Nkind (Stmt) = N_Entry_Declaration
23895 and then Is_Protected_Type
23896 (Scope (Defining_Entity (Stmt))))
23898 Process_Overloadable (Stmt);
23901 -- Otherwise the pragma does not apply to a legal construct
23902 -- or it does not appear at the top of a declarative or a
23903 -- statement list. Issue an error and stop the analysis.
23913 -- The pragma applies to a package or a subprogram that acts as
23914 -- a compilation unit.
23916 -- procedure Proc ...;
23917 -- pragma SPARK_Mode ...;
23919 if Nkind (Context) = N_Compilation_Unit_Aux then
23920 Context := Unit (Parent (Context));
23923 -- The pragma appears at the top of entry, package, protected
23924 -- unit, subprogram or task unit body declarations.
23926 -- entry Ent when ... is
23927 -- pragma SPARK_Mode ...;
23929 -- package body Pack is
23930 -- pragma SPARK_Mode ...;
23932 -- procedure Proc ... is
23933 -- pragma SPARK_Mode;
23935 -- protected body Prot is
23936 -- pragma SPARK_Mode ...;
23938 if Nkind_In (Context, N_Entry_Body,
23944 Process_Body (Context);
23946 -- The pragma appears at the top of the visible or private
23947 -- declaration of a package spec, protected or task unit.
23950 -- pragma SPARK_Mode ...;
23952 -- pragma SPARK_Mode ...;
23954 -- protected [type] Prot is
23955 -- pragma SPARK_Mode ...;
23957 -- pragma SPARK_Mode ...;
23959 elsif Nkind_In (Context, N_Package_Specification,
23960 N_Protected_Definition,
23963 if List_Containing (N) = Visible_Declarations (Context) then
23964 Process_Visible_Part (Parent (Context));
23966 Process_Private_Part (Parent (Context));
23969 -- The pragma appears at the top of package body statements
23971 -- package body Pack is
23973 -- pragma SPARK_Mode;
23975 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
23976 and then Nkind (Parent (Context)) = N_Package_Body
23978 Process_Statement_Part (Parent (Context));
23980 -- The pragma appeared as an aspect of a [generic] subprogram
23981 -- declaration that acts as a compilation unit.
23984 -- procedure Proc ...;
23985 -- pragma SPARK_Mode ...;
23987 elsif Nkind_In (Context, N_Generic_Subprogram_Declaration,
23988 N_Subprogram_Declaration)
23990 Process_Overloadable (Context);
23992 -- The pragma does not apply to a legal construct, issue error
24000 --------------------------------
24001 -- Static_Elaboration_Desired --
24002 --------------------------------
24004 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
24006 when Pragma_Static_Elaboration_Desired =>
24008 Check_At_Most_N_Arguments (1);
24010 if Is_Compilation_Unit (Current_Scope)
24011 and then Ekind (Current_Scope) = E_Package
24013 Set_Static_Elaboration_Desired (Current_Scope, True);
24015 Error_Pragma ("pragma% must apply to a library-level package");
24022 -- pragma Storage_Size (EXPRESSION);
24024 when Pragma_Storage_Size => Storage_Size : declare
24025 P : constant Node_Id := Parent (N);
24029 Check_No_Identifiers;
24030 Check_Arg_Count (1);
24032 -- The expression must be analyzed in the special manner described
24033 -- in "Handling of Default Expressions" in sem.ads.
24035 Arg := Get_Pragma_Arg (Arg1);
24036 Preanalyze_Spec_Expression (Arg, Any_Integer);
24038 if not Is_OK_Static_Expression (Arg) then
24039 Check_Restriction (Static_Storage_Size, Arg);
24042 if Nkind (P) /= N_Task_Definition then
24047 if Has_Storage_Size_Pragma (P) then
24048 Error_Pragma ("duplicate pragma% not allowed");
24050 Set_Has_Storage_Size_Pragma (P, True);
24053 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
24061 -- pragma Storage_Unit (NUMERIC_LITERAL);
24063 -- Only permitted argument is System'Storage_Unit value
24065 when Pragma_Storage_Unit =>
24066 Check_No_Identifiers;
24067 Check_Arg_Count (1);
24068 Check_Arg_Is_Integer_Literal (Arg1);
24070 if Intval (Get_Pragma_Arg (Arg1)) /=
24071 UI_From_Int (Ttypes.System_Storage_Unit)
24073 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
24075 ("the only allowed argument for pragma% is ^", Arg1);
24078 --------------------
24079 -- Stream_Convert --
24080 --------------------
24082 -- pragma Stream_Convert (
24083 -- [Entity =>] type_LOCAL_NAME,
24084 -- [Read =>] function_NAME,
24085 -- [Write =>] function NAME);
24087 when Pragma_Stream_Convert => Stream_Convert : declare
24088 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
24089 -- Check that the given argument is the name of a local function
24090 -- of one argument that is not overloaded earlier in the current
24091 -- local scope. A check is also made that the argument is a
24092 -- function with one parameter.
24094 --------------------------------------
24095 -- Check_OK_Stream_Convert_Function --
24096 --------------------------------------
24098 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
24102 Check_Arg_Is_Local_Name (Arg);
24103 Ent := Entity (Get_Pragma_Arg (Arg));
24105 if Has_Homonym (Ent) then
24107 ("argument for pragma% may not be overloaded", Arg);
24110 if Ekind (Ent) /= E_Function
24111 or else No (First_Formal (Ent))
24112 or else Present (Next_Formal (First_Formal (Ent)))
24115 ("argument for pragma% must be function of one argument",
24118 end Check_OK_Stream_Convert_Function;
24120 -- Start of processing for Stream_Convert
24124 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
24125 Check_Arg_Count (3);
24126 Check_Optional_Identifier (Arg1, Name_Entity);
24127 Check_Optional_Identifier (Arg2, Name_Read);
24128 Check_Optional_Identifier (Arg3, Name_Write);
24129 Check_Arg_Is_Local_Name (Arg1);
24130 Check_OK_Stream_Convert_Function (Arg2);
24131 Check_OK_Stream_Convert_Function (Arg3);
24134 Typ : constant Entity_Id :=
24135 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
24136 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
24137 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
24140 Check_First_Subtype (Arg1);
24142 -- Check for too early or too late. Note that we don't enforce
24143 -- the rule about primitive operations in this case, since, as
24144 -- is the case for explicit stream attributes themselves, these
24145 -- restrictions are not appropriate. Note that the chaining of
24146 -- the pragma by Rep_Item_Too_Late is actually the critical
24147 -- processing done for this pragma.
24149 if Rep_Item_Too_Early (Typ, N)
24151 Rep_Item_Too_Late (Typ, N, FOnly => True)
24156 -- Return if previous error
24158 if Etype (Typ) = Any_Type
24160 Etype (Read) = Any_Type
24162 Etype (Write) = Any_Type
24169 if Underlying_Type (Etype (Read)) /= Typ then
24171 ("incorrect return type for function&", Arg2);
24174 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
24176 ("incorrect parameter type for function&", Arg3);
24179 if Underlying_Type (Etype (First_Formal (Read))) /=
24180 Underlying_Type (Etype (Write))
24183 ("result type of & does not match Read parameter type",
24187 end Stream_Convert;
24193 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
24195 -- This is processed by the parser since some of the style checks
24196 -- take place during source scanning and parsing. This means that
24197 -- we don't need to issue error messages here.
24199 when Pragma_Style_Checks => Style_Checks : declare
24200 A : constant Node_Id := Get_Pragma_Arg (Arg1);
24206 Check_No_Identifiers;
24208 -- Two argument form
24210 if Arg_Count = 2 then
24211 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
24218 E_Id := Get_Pragma_Arg (Arg2);
24221 if not Is_Entity_Name (E_Id) then
24223 ("second argument of pragma% must be entity name",
24227 E := Entity (E_Id);
24229 if not Ignore_Style_Checks_Pragmas then
24234 Set_Suppress_Style_Checks
24235 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off);
24236 exit when No (Homonym (E));
24243 -- One argument form
24246 Check_Arg_Count (1);
24248 if Nkind (A) = N_String_Literal then
24252 Slen : constant Natural := Natural (String_Length (S));
24253 Options : String (1 .. Slen);
24259 C := Get_String_Char (S, Pos (J));
24260 exit when not In_Character_Range (C);
24261 Options (J) := Get_Character (C);
24263 -- If at end of string, set options. As per discussion
24264 -- above, no need to check for errors, since we issued
24265 -- them in the parser.
24268 if not Ignore_Style_Checks_Pragmas then
24269 Set_Style_Check_Options (Options);
24279 elsif Nkind (A) = N_Identifier then
24280 if Chars (A) = Name_All_Checks then
24281 if not Ignore_Style_Checks_Pragmas then
24283 Set_GNAT_Style_Check_Options;
24285 Set_Default_Style_Check_Options;
24289 elsif Chars (A) = Name_On then
24290 if not Ignore_Style_Checks_Pragmas then
24291 Style_Check := True;
24294 elsif Chars (A) = Name_Off then
24295 if not Ignore_Style_Checks_Pragmas then
24296 Style_Check := False;
24307 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
24309 when Pragma_Subtitle =>
24311 Check_Arg_Count (1);
24312 Check_Optional_Identifier (Arg1, Name_Subtitle);
24313 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
24320 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
24322 when Pragma_Suppress =>
24323 Process_Suppress_Unsuppress (Suppress_Case => True);
24329 -- pragma Suppress_All;
24331 -- The only check made here is that the pragma has no arguments.
24332 -- There are no placement rules, and the processing required (setting
24333 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
24334 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
24335 -- then creates and inserts a pragma Suppress (All_Checks).
24337 when Pragma_Suppress_All =>
24339 Check_Arg_Count (0);
24341 -------------------------
24342 -- Suppress_Debug_Info --
24343 -------------------------
24345 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
24347 when Pragma_Suppress_Debug_Info => Suppress_Debug_Info : declare
24348 Nam_Id : Entity_Id;
24352 Check_Arg_Count (1);
24353 Check_Optional_Identifier (Arg1, Name_Entity);
24354 Check_Arg_Is_Local_Name (Arg1);
24356 Nam_Id := Entity (Get_Pragma_Arg (Arg1));
24358 -- A pragma that applies to a Ghost entity becomes Ghost for the
24359 -- purposes of legality checks and removal of ignored Ghost code.
24361 Mark_Ghost_Pragma (N, Nam_Id);
24362 Set_Debug_Info_Off (Nam_Id);
24363 end Suppress_Debug_Info;
24365 ----------------------------------
24366 -- Suppress_Exception_Locations --
24367 ----------------------------------
24369 -- pragma Suppress_Exception_Locations;
24371 when Pragma_Suppress_Exception_Locations =>
24373 Check_Arg_Count (0);
24374 Check_Valid_Configuration_Pragma;
24375 Exception_Locations_Suppressed := True;
24377 -----------------------------
24378 -- Suppress_Initialization --
24379 -----------------------------
24381 -- pragma Suppress_Initialization ([Entity =>] type_Name);
24383 when Pragma_Suppress_Initialization => Suppress_Init : declare
24389 Check_Arg_Count (1);
24390 Check_Optional_Identifier (Arg1, Name_Entity);
24391 Check_Arg_Is_Local_Name (Arg1);
24393 E_Id := Get_Pragma_Arg (Arg1);
24395 if Etype (E_Id) = Any_Type then
24399 E := Entity (E_Id);
24401 -- A pragma that applies to a Ghost entity becomes Ghost for the
24402 -- purposes of legality checks and removal of ignored Ghost code.
24404 Mark_Ghost_Pragma (N, E);
24406 if not Is_Type (E) and then Ekind (E) /= E_Variable then
24408 ("pragma% requires variable, type or subtype", Arg1);
24411 if Rep_Item_Too_Early (E, N)
24413 Rep_Item_Too_Late (E, N, FOnly => True)
24418 -- For incomplete/private type, set flag on full view
24420 if Is_Incomplete_Or_Private_Type (E) then
24421 if No (Full_View (Base_Type (E))) then
24423 ("argument of pragma% cannot be an incomplete type", Arg1);
24425 Set_Suppress_Initialization (Full_View (E));
24428 -- For first subtype, set flag on base type
24430 elsif Is_First_Subtype (E) then
24431 Set_Suppress_Initialization (Base_Type (E));
24433 -- For other than first subtype, set flag on subtype or variable
24436 Set_Suppress_Initialization (E);
24444 -- pragma System_Name (DIRECT_NAME);
24446 -- Syntax check: one argument, which must be the identifier GNAT or
24447 -- the identifier GCC, no other identifiers are acceptable.
24449 when Pragma_System_Name =>
24451 Check_No_Identifiers;
24452 Check_Arg_Count (1);
24453 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
24455 -----------------------------
24456 -- Task_Dispatching_Policy --
24457 -----------------------------
24459 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
24461 when Pragma_Task_Dispatching_Policy => declare
24465 Check_Ada_83_Warning;
24466 Check_Arg_Count (1);
24467 Check_No_Identifiers;
24468 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
24469 Check_Valid_Configuration_Pragma;
24470 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
24471 DP := Fold_Upper (Name_Buffer (1));
24473 if Task_Dispatching_Policy /= ' '
24474 and then Task_Dispatching_Policy /= DP
24476 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
24478 ("task dispatching policy incompatible with policy#");
24480 -- Set new policy, but always preserve System_Location since we
24481 -- like the error message with the run time name.
24484 Task_Dispatching_Policy := DP;
24486 if Task_Dispatching_Policy_Sloc /= System_Location then
24487 Task_Dispatching_Policy_Sloc := Loc;
24496 -- pragma Task_Info (EXPRESSION);
24498 when Pragma_Task_Info => Task_Info : declare
24499 P : constant Node_Id := Parent (N);
24505 if Warn_On_Obsolescent_Feature then
24507 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
24508 & "instead?j?", N);
24511 if Nkind (P) /= N_Task_Definition then
24512 Error_Pragma ("pragma% must appear in task definition");
24515 Check_No_Identifiers;
24516 Check_Arg_Count (1);
24518 Analyze_And_Resolve
24519 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
24521 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
24525 Ent := Defining_Identifier (Parent (P));
24527 -- Check duplicate pragma before we chain the pragma in the Rep
24528 -- Item chain of Ent.
24531 (Ent, Name_Task_Info, Check_Parents => False)
24533 Error_Pragma ("duplicate pragma% not allowed");
24536 Record_Rep_Item (Ent, N);
24543 -- pragma Task_Name (string_EXPRESSION);
24545 when Pragma_Task_Name => Task_Name : declare
24546 P : constant Node_Id := Parent (N);
24551 Check_No_Identifiers;
24552 Check_Arg_Count (1);
24554 Arg := Get_Pragma_Arg (Arg1);
24556 -- The expression is used in the call to Create_Task, and must be
24557 -- expanded there, not in the context of the current spec. It must
24558 -- however be analyzed to capture global references, in case it
24559 -- appears in a generic context.
24561 Preanalyze_And_Resolve (Arg, Standard_String);
24563 if Nkind (P) /= N_Task_Definition then
24567 Ent := Defining_Identifier (Parent (P));
24569 -- Check duplicate pragma before we chain the pragma in the Rep
24570 -- Item chain of Ent.
24573 (Ent, Name_Task_Name, Check_Parents => False)
24575 Error_Pragma ("duplicate pragma% not allowed");
24578 Record_Rep_Item (Ent, N);
24585 -- pragma Task_Storage (
24586 -- [Task_Type =>] LOCAL_NAME,
24587 -- [Top_Guard =>] static_integer_EXPRESSION);
24589 when Pragma_Task_Storage => Task_Storage : declare
24590 Args : Args_List (1 .. 2);
24591 Names : constant Name_List (1 .. 2) := (
24595 Task_Type : Node_Id renames Args (1);
24596 Top_Guard : Node_Id renames Args (2);
24602 Gather_Associations (Names, Args);
24604 if No (Task_Type) then
24606 ("missing task_type argument for pragma%");
24609 Check_Arg_Is_Local_Name (Task_Type);
24611 Ent := Entity (Task_Type);
24613 if not Is_Task_Type (Ent) then
24615 ("argument for pragma% must be task type", Task_Type);
24618 if No (Top_Guard) then
24620 ("pragma% takes two arguments", Task_Type);
24622 Check_Arg_Is_OK_Static_Expression (Top_Guard, Any_Integer);
24625 Check_First_Subtype (Task_Type);
24627 if Rep_Item_Too_Late (Ent, N) then
24636 -- pragma Test_Case
24637 -- ([Name =>] Static_String_EXPRESSION
24638 -- ,[Mode =>] MODE_TYPE
24639 -- [, Requires => Boolean_EXPRESSION]
24640 -- [, Ensures => Boolean_EXPRESSION]);
24642 -- MODE_TYPE ::= Nominal | Robustness
24644 -- Characteristics:
24646 -- * Analysis - The annotation undergoes initial checks to verify
24647 -- the legal placement and context. Secondary checks preanalyze the
24650 -- Analyze_Test_Case_In_Decl_Part
24652 -- * Expansion - None.
24654 -- * Template - The annotation utilizes the generic template of the
24655 -- related subprogram when it is:
24657 -- aspect on subprogram declaration
24659 -- The annotation must prepare its own template when it is:
24661 -- pragma on subprogram declaration
24663 -- * Globals - Capture of global references must occur after full
24666 -- * Instance - The annotation is instantiated automatically when
24667 -- the related generic subprogram is instantiated except for the
24668 -- "pragma on subprogram declaration" case. In that scenario the
24669 -- annotation must instantiate itself.
24671 when Pragma_Test_Case => Test_Case : declare
24672 procedure Check_Distinct_Name (Subp_Id : Entity_Id);
24673 -- Ensure that the contract of subprogram Subp_Id does not contain
24674 -- another Test_Case pragma with the same Name as the current one.
24676 -------------------------
24677 -- Check_Distinct_Name --
24678 -------------------------
24680 procedure Check_Distinct_Name (Subp_Id : Entity_Id) is
24681 Items : constant Node_Id := Contract (Subp_Id);
24682 Name : constant String_Id := Get_Name_From_CTC_Pragma (N);
24686 -- Inspect all Test_Case pragma of the related subprogram
24687 -- looking for one with a duplicate "Name" argument.
24689 if Present (Items) then
24690 Prag := Contract_Test_Cases (Items);
24691 while Present (Prag) loop
24692 if Pragma_Name (Prag) = Name_Test_Case
24694 and then String_Equal
24695 (Name, Get_Name_From_CTC_Pragma (Prag))
24697 Error_Msg_Sloc := Sloc (Prag);
24698 Error_Pragma ("name for pragma % is already used #");
24701 Prag := Next_Pragma (Prag);
24704 end Check_Distinct_Name;
24708 Pack_Decl : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
24711 Subp_Decl : Node_Id;
24712 Subp_Id : Entity_Id;
24714 -- Start of processing for Test_Case
24718 Check_At_Least_N_Arguments (2);
24719 Check_At_Most_N_Arguments (4);
24721 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
24725 Check_Optional_Identifier (Arg1, Name_Name);
24726 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
24730 Check_Optional_Identifier (Arg2, Name_Mode);
24731 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
24733 -- Arguments "Requires" and "Ensures"
24735 if Present (Arg3) then
24736 if Present (Arg4) then
24737 Check_Identifier (Arg3, Name_Requires);
24738 Check_Identifier (Arg4, Name_Ensures);
24740 Check_Identifier_Is_One_Of
24741 (Arg3, Name_Requires, Name_Ensures);
24745 -- Pragma Test_Case must be associated with a subprogram declared
24746 -- in a library-level package. First determine whether the current
24747 -- compilation unit is a legal context.
24749 if Nkind_In (Pack_Decl, N_Package_Declaration,
24750 N_Generic_Package_Declaration)
24754 -- Otherwise the placement is illegal
24758 ("pragma % must be specified within a package declaration");
24762 Subp_Decl := Find_Related_Declaration_Or_Body (N);
24764 -- Find the enclosing context
24766 Context := Parent (Subp_Decl);
24768 if Present (Context) then
24769 Context := Parent (Context);
24772 -- Verify the placement of the pragma
24774 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
24776 ("pragma % cannot be applied to abstract subprogram");
24779 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
24780 Error_Pragma ("pragma % cannot be applied to entry");
24783 -- The context is a [generic] subprogram declared at the top level
24784 -- of the [generic] package unit.
24786 elsif Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration,
24787 N_Subprogram_Declaration)
24788 and then Present (Context)
24789 and then Nkind_In (Context, N_Generic_Package_Declaration,
24790 N_Package_Declaration)
24794 -- Otherwise the placement is illegal
24798 ("pragma % must be applied to a library-level subprogram "
24803 Subp_Id := Defining_Entity (Subp_Decl);
24805 -- A pragma that applies to a Ghost entity becomes Ghost for the
24806 -- purposes of legality checks and removal of ignored Ghost code.
24808 Mark_Ghost_Pragma (N, Subp_Id);
24810 -- Chain the pragma on the contract for further processing by
24811 -- Analyze_Test_Case_In_Decl_Part.
24813 Add_Contract_Item (N, Subp_Id);
24815 -- Preanalyze the original aspect argument "Name" for ASIS or for
24816 -- a generic subprogram to properly capture global references.
24818 if ASIS_Mode or else Is_Generic_Subprogram (Subp_Id) then
24819 Asp_Arg := Test_Case_Arg (N, Name_Name, From_Aspect => True);
24821 if Present (Asp_Arg) then
24823 -- The argument appears with an identifier in association
24826 if Nkind (Asp_Arg) = N_Component_Association then
24827 Asp_Arg := Expression (Asp_Arg);
24830 Check_Expr_Is_OK_Static_Expression
24831 (Asp_Arg, Standard_String);
24835 -- Ensure that the all Test_Case pragmas of the related subprogram
24836 -- have distinct names.
24838 Check_Distinct_Name (Subp_Id);
24840 -- Fully analyze the pragma when it appears inside an entry
24841 -- or subprogram body because it cannot benefit from forward
24844 if Nkind_In (Subp_Decl, N_Entry_Body,
24846 N_Subprogram_Body_Stub)
24848 -- The legality checks of pragma Test_Case are affected by the
24849 -- SPARK mode in effect and the volatility of the context.
24850 -- Analyze all pragmas in a specific order.
24852 Analyze_If_Present (Pragma_SPARK_Mode);
24853 Analyze_If_Present (Pragma_Volatile_Function);
24854 Analyze_Test_Case_In_Decl_Part (N);
24858 --------------------------
24859 -- Thread_Local_Storage --
24860 --------------------------
24862 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
24864 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
24870 Check_Arg_Count (1);
24871 Check_Optional_Identifier (Arg1, Name_Entity);
24872 Check_Arg_Is_Library_Level_Local_Name (Arg1);
24874 Id := Get_Pragma_Arg (Arg1);
24877 if not Is_Entity_Name (Id)
24878 or else Ekind (Entity (Id)) /= E_Variable
24880 Error_Pragma_Arg ("local variable name required", Arg1);
24885 -- A pragma that applies to a Ghost entity becomes Ghost for the
24886 -- purposes of legality checks and removal of ignored Ghost code.
24888 Mark_Ghost_Pragma (N, E);
24890 if Rep_Item_Too_Early (E, N)
24892 Rep_Item_Too_Late (E, N)
24897 Set_Has_Pragma_Thread_Local_Storage (E);
24898 Set_Has_Gigi_Rep_Item (E);
24899 end Thread_Local_Storage;
24905 -- pragma Time_Slice (static_duration_EXPRESSION);
24907 when Pragma_Time_Slice => Time_Slice : declare
24913 Check_Arg_Count (1);
24914 Check_No_Identifiers;
24915 Check_In_Main_Program;
24916 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_Duration);
24918 if not Error_Posted (Arg1) then
24920 while Present (Nod) loop
24921 if Nkind (Nod) = N_Pragma
24922 and then Pragma_Name (Nod) = Name_Time_Slice
24924 Error_Msg_Name_1 := Pname;
24925 Error_Msg_N ("duplicate pragma% not permitted", Nod);
24932 -- Process only if in main unit
24934 if Get_Source_Unit (Loc) = Main_Unit then
24935 Opt.Time_Slice_Set := True;
24936 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
24938 if Val <= Ureal_0 then
24939 Opt.Time_Slice_Value := 0;
24941 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
24942 Opt.Time_Slice_Value := 1_000_000_000;
24945 Opt.Time_Slice_Value :=
24946 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
24955 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
24957 -- TITLING_OPTION ::=
24958 -- [Title =>] STRING_LITERAL
24959 -- | [Subtitle =>] STRING_LITERAL
24961 when Pragma_Title => Title : declare
24962 Args : Args_List (1 .. 2);
24963 Names : constant Name_List (1 .. 2) := (
24969 Gather_Associations (Names, Args);
24972 for J in 1 .. 2 loop
24973 if Present (Args (J)) then
24974 Check_Arg_Is_OK_Static_Expression
24975 (Args (J), Standard_String);
24980 ----------------------------
24981 -- Type_Invariant[_Class] --
24982 ----------------------------
24984 -- pragma Type_Invariant[_Class]
24985 -- ([Entity =>] type_LOCAL_NAME,
24986 -- [Check =>] EXPRESSION);
24988 when Pragma_Type_Invariant
24989 | Pragma_Type_Invariant_Class
24991 Type_Invariant : declare
24992 I_Pragma : Node_Id;
24995 Check_Arg_Count (2);
24997 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
24998 -- setting Class_Present for the Type_Invariant_Class case.
25000 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class);
25001 I_Pragma := New_Copy (N);
25002 Set_Pragma_Identifier
25003 (I_Pragma, Make_Identifier (Loc, Name_Invariant));
25004 Rewrite (N, I_Pragma);
25005 Set_Analyzed (N, False);
25007 end Type_Invariant;
25009 ---------------------
25010 -- Unchecked_Union --
25011 ---------------------
25013 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
25015 when Pragma_Unchecked_Union => Unchecked_Union : declare
25016 Assoc : constant Node_Id := Arg1;
25017 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
25027 Check_No_Identifiers;
25028 Check_Arg_Count (1);
25029 Check_Arg_Is_Local_Name (Arg1);
25031 Find_Type (Type_Id);
25033 Typ := Entity (Type_Id);
25035 -- A pragma that applies to a Ghost entity becomes Ghost for the
25036 -- purposes of legality checks and removal of ignored Ghost code.
25038 Mark_Ghost_Pragma (N, Typ);
25041 or else Rep_Item_Too_Early (Typ, N)
25045 Typ := Underlying_Type (Typ);
25048 if Rep_Item_Too_Late (Typ, N) then
25052 Check_First_Subtype (Arg1);
25054 -- Note remaining cases are references to a type in the current
25055 -- declarative part. If we find an error, we post the error on
25056 -- the relevant type declaration at an appropriate point.
25058 if not Is_Record_Type (Typ) then
25059 Error_Msg_N ("unchecked union must be record type", Typ);
25062 elsif Is_Tagged_Type (Typ) then
25063 Error_Msg_N ("unchecked union must not be tagged", Typ);
25066 elsif not Has_Discriminants (Typ) then
25068 ("unchecked union must have one discriminant", Typ);
25071 -- Note: in previous versions of GNAT we used to check for limited
25072 -- types and give an error, but in fact the standard does allow
25073 -- Unchecked_Union on limited types, so this check was removed.
25075 -- Similarly, GNAT used to require that all discriminants have
25076 -- default values, but this is not mandated by the RM.
25078 -- Proceed with basic error checks completed
25081 Tdef := Type_Definition (Declaration_Node (Typ));
25082 Clist := Component_List (Tdef);
25084 -- Check presence of component list and variant part
25086 if No (Clist) or else No (Variant_Part (Clist)) then
25088 ("unchecked union must have variant part", Tdef);
25092 -- Check components
25094 Comp := First_Non_Pragma (Component_Items (Clist));
25095 while Present (Comp) loop
25096 Check_Component (Comp, Typ);
25097 Next_Non_Pragma (Comp);
25100 -- Check variant part
25102 Vpart := Variant_Part (Clist);
25104 Variant := First_Non_Pragma (Variants (Vpart));
25105 while Present (Variant) loop
25106 Check_Variant (Variant, Typ);
25107 Next_Non_Pragma (Variant);
25111 Set_Is_Unchecked_Union (Typ);
25112 Set_Convention (Typ, Convention_C);
25113 Set_Has_Unchecked_Union (Base_Type (Typ));
25114 Set_Is_Unchecked_Union (Base_Type (Typ));
25115 end Unchecked_Union;
25117 ----------------------------
25118 -- Unevaluated_Use_Of_Old --
25119 ----------------------------
25121 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
25123 when Pragma_Unevaluated_Use_Of_Old =>
25125 Check_Arg_Count (1);
25126 Check_No_Identifiers;
25127 Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow);
25129 -- Suppress/Unsuppress can appear as a configuration pragma, or in
25130 -- a declarative part or a package spec.
25132 if not Is_Configuration_Pragma then
25133 Check_Is_In_Decl_Part_Or_Package_Spec;
25136 -- Store proper setting of Uneval_Old
25138 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
25139 Uneval_Old := Fold_Upper (Name_Buffer (1));
25141 ------------------------
25142 -- Unimplemented_Unit --
25143 ------------------------
25145 -- pragma Unimplemented_Unit;
25147 -- Note: this only gives an error if we are generating code, or if
25148 -- we are in a generic library unit (where the pragma appears in the
25149 -- body, not in the spec).
25151 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
25152 Cunitent : constant Entity_Id :=
25153 Cunit_Entity (Get_Source_Unit (Loc));
25154 Ent_Kind : constant Entity_Kind := Ekind (Cunitent);
25158 Check_Arg_Count (0);
25160 if Operating_Mode = Generate_Code
25161 or else Ent_Kind = E_Generic_Function
25162 or else Ent_Kind = E_Generic_Procedure
25163 or else Ent_Kind = E_Generic_Package
25165 Get_Name_String (Chars (Cunitent));
25166 Set_Casing (Mixed_Case);
25167 Write_Str (Name_Buffer (1 .. Name_Len));
25168 Write_Str (" is not supported in this configuration");
25170 raise Unrecoverable_Error;
25172 end Unimplemented_Unit;
25174 ------------------------
25175 -- Universal_Aliasing --
25176 ------------------------
25178 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
25180 when Pragma_Universal_Aliasing => Universal_Alias : declare
25186 Check_Arg_Count (1);
25187 Check_Optional_Identifier (Arg2, Name_Entity);
25188 Check_Arg_Is_Local_Name (Arg1);
25189 E_Id := Get_Pragma_Arg (Arg1);
25191 if Etype (E_Id) = Any_Type then
25195 E := Entity (E_Id);
25197 if not Is_Type (E) then
25198 Error_Pragma_Arg ("pragma% requires type", Arg1);
25201 -- A pragma that applies to a Ghost entity becomes Ghost for the
25202 -- purposes of legality checks and removal of ignored Ghost code.
25204 Mark_Ghost_Pragma (N, E);
25205 Set_Universal_Aliasing (Base_Type (E));
25206 Record_Rep_Item (E, N);
25207 end Universal_Alias;
25209 --------------------
25210 -- Universal_Data --
25211 --------------------
25213 -- pragma Universal_Data [(library_unit_NAME)];
25215 when Pragma_Universal_Data =>
25217 Error_Pragma ("??pragma% ignored (applies only to AAMP)");
25223 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
25225 when Pragma_Unmodified =>
25226 Analyze_Unmodified_Or_Unused;
25232 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
25234 -- or when used in a context clause:
25236 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
25238 when Pragma_Unreferenced =>
25239 Analyze_Unreferenced_Or_Unused;
25241 --------------------------
25242 -- Unreferenced_Objects --
25243 --------------------------
25245 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
25247 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
25249 Arg_Expr : Node_Id;
25250 Arg_Id : Entity_Id;
25252 Ghost_Error_Posted : Boolean := False;
25253 -- Flag set when an error concerning the illegal mix of Ghost and
25254 -- non-Ghost types is emitted.
25256 Ghost_Id : Entity_Id := Empty;
25257 -- The entity of the first Ghost type encountered while processing
25258 -- the arguments of the pragma.
25262 Check_At_Least_N_Arguments (1);
25265 while Present (Arg) loop
25266 Check_No_Identifier (Arg);
25267 Check_Arg_Is_Local_Name (Arg);
25268 Arg_Expr := Get_Pragma_Arg (Arg);
25270 if Is_Entity_Name (Arg_Expr) then
25271 Arg_Id := Entity (Arg_Expr);
25273 if Is_Type (Arg_Id) then
25274 Set_Has_Pragma_Unreferenced_Objects (Arg_Id);
25276 -- A pragma that applies to a Ghost entity becomes Ghost
25277 -- for the purposes of legality checks and removal of
25278 -- ignored Ghost code.
25280 Mark_Ghost_Pragma (N, Arg_Id);
25282 -- Capture the entity of the first Ghost type being
25283 -- processed for error detection purposes.
25285 if Is_Ghost_Entity (Arg_Id) then
25286 if No (Ghost_Id) then
25287 Ghost_Id := Arg_Id;
25290 -- Otherwise the type is non-Ghost. It is illegal to mix
25291 -- references to Ghost and non-Ghost entities
25294 elsif Present (Ghost_Id)
25295 and then not Ghost_Error_Posted
25297 Ghost_Error_Posted := True;
25299 Error_Msg_Name_1 := Pname;
25301 ("pragma % cannot mention ghost and non-ghost types",
25304 Error_Msg_Sloc := Sloc (Ghost_Id);
25305 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
25307 Error_Msg_Sloc := Sloc (Arg_Id);
25308 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
25312 ("argument for pragma% must be type or subtype", Arg);
25316 ("argument for pragma% must be type or subtype", Arg);
25321 end Unreferenced_Objects;
25323 ------------------------------
25324 -- Unreserve_All_Interrupts --
25325 ------------------------------
25327 -- pragma Unreserve_All_Interrupts;
25329 when Pragma_Unreserve_All_Interrupts =>
25331 Check_Arg_Count (0);
25333 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
25334 Unreserve_All_Interrupts := True;
25341 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
25343 when Pragma_Unsuppress =>
25345 Process_Suppress_Unsuppress (Suppress_Case => False);
25351 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
25353 when Pragma_Unused =>
25354 Analyze_Unmodified_Or_Unused (Is_Unused => True);
25355 Analyze_Unreferenced_Or_Unused (Is_Unused => True);
25357 -------------------
25358 -- Use_VADS_Size --
25359 -------------------
25361 -- pragma Use_VADS_Size;
25363 when Pragma_Use_VADS_Size =>
25365 Check_Arg_Count (0);
25366 Check_Valid_Configuration_Pragma;
25367 Use_VADS_Size := True;
25369 ---------------------
25370 -- Validity_Checks --
25371 ---------------------
25373 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
25375 when Pragma_Validity_Checks => Validity_Checks : declare
25376 A : constant Node_Id := Get_Pragma_Arg (Arg1);
25382 Check_Arg_Count (1);
25383 Check_No_Identifiers;
25385 -- Pragma always active unless in CodePeer or GNATprove modes,
25386 -- which use a fixed configuration of validity checks.
25388 if not (CodePeer_Mode or GNATprove_Mode) then
25389 if Nkind (A) = N_String_Literal then
25393 Slen : constant Natural := Natural (String_Length (S));
25394 Options : String (1 .. Slen);
25398 -- Couldn't we use a for loop here over Options'Range???
25402 C := Get_String_Char (S, Pos (J));
25404 -- This is a weird test, it skips setting validity
25405 -- checks entirely if any element of S is out of
25406 -- range of Character, what is that about ???
25408 exit when not In_Character_Range (C);
25409 Options (J) := Get_Character (C);
25412 Set_Validity_Check_Options (Options);
25420 elsif Nkind (A) = N_Identifier then
25421 if Chars (A) = Name_All_Checks then
25422 Set_Validity_Check_Options ("a");
25423 elsif Chars (A) = Name_On then
25424 Validity_Checks_On := True;
25425 elsif Chars (A) = Name_Off then
25426 Validity_Checks_On := False;
25430 end Validity_Checks;
25436 -- pragma Volatile (LOCAL_NAME);
25438 when Pragma_Volatile =>
25439 Process_Atomic_Independent_Shared_Volatile;
25441 -------------------------
25442 -- Volatile_Components --
25443 -------------------------
25445 -- pragma Volatile_Components (array_LOCAL_NAME);
25447 -- Volatile is handled by the same circuit as Atomic_Components
25449 --------------------------
25450 -- Volatile_Full_Access --
25451 --------------------------
25453 -- pragma Volatile_Full_Access (LOCAL_NAME);
25455 when Pragma_Volatile_Full_Access =>
25457 Process_Atomic_Independent_Shared_Volatile;
25459 -----------------------
25460 -- Volatile_Function --
25461 -----------------------
25463 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
25465 when Pragma_Volatile_Function => Volatile_Function : declare
25466 Over_Id : Entity_Id;
25467 Spec_Id : Entity_Id;
25468 Subp_Decl : Node_Id;
25472 Check_No_Identifiers;
25473 Check_At_Most_N_Arguments (1);
25476 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
25478 -- Generic subprogram
25480 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
25483 -- Body acts as spec
25485 elsif Nkind (Subp_Decl) = N_Subprogram_Body
25486 and then No (Corresponding_Spec (Subp_Decl))
25490 -- Body stub acts as spec
25492 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
25493 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
25499 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
25507 Spec_Id := Unique_Defining_Entity (Subp_Decl);
25509 if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
25514 -- A pragma that applies to a Ghost entity becomes Ghost for the
25515 -- purposes of legality checks and removal of ignored Ghost code.
25517 Mark_Ghost_Pragma (N, Spec_Id);
25519 -- Chain the pragma on the contract for completeness
25521 Add_Contract_Item (N, Spec_Id);
25523 -- The legality checks of pragma Volatile_Function are affected by
25524 -- the SPARK mode in effect. Analyze all pragmas in a specific
25527 Analyze_If_Present (Pragma_SPARK_Mode);
25529 -- A volatile function cannot override a non-volatile function
25530 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
25531 -- in New_Overloaded_Entity, however at that point the pragma has
25532 -- not been processed yet.
25534 Over_Id := Overridden_Operation (Spec_Id);
25536 if Present (Over_Id)
25537 and then not Is_Volatile_Function (Over_Id)
25540 ("incompatible volatile function values in effect", Spec_Id);
25542 Error_Msg_Sloc := Sloc (Over_Id);
25544 ("\& declared # with Volatile_Function value False",
25547 Error_Msg_Sloc := Sloc (Spec_Id);
25549 ("\overridden # with Volatile_Function value True",
25553 -- Analyze the Boolean expression (if any)
25555 if Present (Arg1) then
25556 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
25558 end Volatile_Function;
25560 ----------------------
25561 -- Warning_As_Error --
25562 ----------------------
25564 -- pragma Warning_As_Error (static_string_EXPRESSION);
25566 when Pragma_Warning_As_Error =>
25568 Check_Arg_Count (1);
25569 Check_No_Identifiers;
25570 Check_Valid_Configuration_Pragma;
25572 if not Is_Static_String_Expression (Arg1) then
25574 ("argument of pragma% must be static string expression",
25577 -- OK static string expression
25580 Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1;
25581 Warnings_As_Errors (Warnings_As_Errors_Count) :=
25582 new String'(Acquire_Warning_Match_String
25583 (Expr_Value_S (Get_Pragma_Arg (Arg1))));
25590 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
25592 -- DETAILS ::= On | Off
25593 -- DETAILS ::= On | Off, local_NAME
25594 -- DETAILS ::= static_string_EXPRESSION
25595 -- DETAILS ::= On | Off, static_string_EXPRESSION
25597 -- TOOL_NAME ::= GNAT | GNATProve
25599 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
25601 -- Note: If the first argument matches an allowed tool name, it is
25602 -- always considered to be a tool name, even if there is a string
25603 -- variable of that name.
25605 -- Note if the second argument of DETAILS is a local_NAME then the
25606 -- second form is always understood. If the intention is to use
25607 -- the fourth form, then you can write NAME & "" to force the
25608 -- intepretation as a static_string_EXPRESSION.
25610 when Pragma_Warnings => Warnings : declare
25611 Reason : String_Id;
25615 Check_At_Least_N_Arguments (1);
25617 -- See if last argument is labeled Reason. If so, make sure we
25618 -- have a string literal or a concatenation of string literals,
25619 -- and acquire the REASON string. Then remove the REASON argument
25620 -- by decreasing Num_Args by one; Remaining processing looks only
25621 -- at first Num_Args arguments).
25624 Last_Arg : constant Node_Id :=
25625 Last (Pragma_Argument_Associations (N));
25628 if Nkind (Last_Arg) = N_Pragma_Argument_Association
25629 and then Chars (Last_Arg) = Name_Reason
25632 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
25633 Reason := End_String;
25634 Arg_Count := Arg_Count - 1;
25636 -- Not allowed in compiler units (bootstrap issues)
25638 Check_Compiler_Unit ("Reason for pragma Warnings", N);
25640 -- No REASON string, set null string as reason
25643 Reason := Null_String_Id;
25647 -- Now proceed with REASON taken care of and eliminated
25649 Check_No_Identifiers;
25651 -- If debug flag -gnatd.i is set, pragma is ignored
25653 if Debug_Flag_Dot_I then
25657 -- Process various forms of the pragma
25660 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
25661 Shifted_Args : List_Id;
25664 -- See if first argument is a tool name, currently either
25665 -- GNAT or GNATprove. If so, either ignore the pragma if the
25666 -- tool used does not match, or continue as if no tool name
25667 -- was given otherwise, by shifting the arguments.
25669 if Nkind (Argx) = N_Identifier
25670 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
25672 if Chars (Argx) = Name_Gnat then
25673 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
25674 Rewrite (N, Make_Null_Statement (Loc));
25679 elsif Chars (Argx) = Name_Gnatprove then
25680 if not GNATprove_Mode then
25681 Rewrite (N, Make_Null_Statement (Loc));
25687 raise Program_Error;
25690 -- At this point, the pragma Warnings applies to the tool,
25691 -- so continue with shifted arguments.
25693 Arg_Count := Arg_Count - 1;
25695 if Arg_Count = 1 then
25696 Shifted_Args := New_List (New_Copy (Arg2));
25697 elsif Arg_Count = 2 then
25698 Shifted_Args := New_List (New_Copy (Arg2),
25700 elsif Arg_Count = 3 then
25701 Shifted_Args := New_List (New_Copy (Arg2),
25705 raise Program_Error;
25710 Chars => Name_Warnings,
25711 Pragma_Argument_Associations => Shifted_Args));
25716 -- One argument case
25718 if Arg_Count = 1 then
25720 -- On/Off one argument case was processed by parser
25722 if Nkind (Argx) = N_Identifier
25723 and then Nam_In (Chars (Argx), Name_On, Name_Off)
25727 -- One argument case must be ON/OFF or static string expr
25729 elsif not Is_Static_String_Expression (Arg1) then
25731 ("argument of pragma% must be On/Off or static string "
25732 & "expression", Arg1);
25734 -- One argument string expression case
25738 Lit : constant Node_Id := Expr_Value_S (Argx);
25739 Str : constant String_Id := Strval (Lit);
25740 Len : constant Nat := String_Length (Str);
25748 while J <= Len loop
25749 C := Get_String_Char (Str, J);
25750 OK := In_Character_Range (C);
25753 Chr := Get_Character (C);
25755 -- Dash case: only -Wxxx is accepted
25762 C := Get_String_Char (Str, J);
25763 Chr := Get_Character (C);
25764 exit when Chr = 'W';
25769 elsif J < Len and then Chr = '.' then
25771 C := Get_String_Char (Str, J);
25772 Chr := Get_Character (C);
25774 if not Set_Dot_Warning_Switch (Chr) then
25776 ("invalid warning switch character "
25777 & '.' & Chr, Arg1);
25783 OK := Set_Warning_Switch (Chr);
25788 ("invalid warning switch character " & Chr,
25794 ("invalid wide character in warning switch ",
25803 -- Two or more arguments (must be two)
25806 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
25807 Check_Arg_Count (2);
25815 E_Id := Get_Pragma_Arg (Arg2);
25818 -- In the expansion of an inlined body, a reference to
25819 -- the formal may be wrapped in a conversion if the
25820 -- actual is a conversion. Retrieve the real entity name.
25822 if (In_Instance_Body or In_Inlined_Body)
25823 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
25825 E_Id := Expression (E_Id);
25828 -- Entity name case
25830 if Is_Entity_Name (E_Id) then
25831 E := Entity (E_Id);
25838 (E, (Chars (Get_Pragma_Arg (Arg1)) =
25841 -- Suppress elaboration warnings if the entity
25842 -- denotes an elaboration target.
25844 if Is_Elaboration_Target (E) then
25845 Set_Is_Elaboration_Warnings_OK_Id (E, False);
25848 -- For OFF case, make entry in warnings off
25849 -- pragma table for later processing. But we do
25850 -- not do that within an instance, since these
25851 -- warnings are about what is needed in the
25852 -- template, not an instance of it.
25854 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
25855 and then Warn_On_Warnings_Off
25856 and then not In_Instance
25858 Warnings_Off_Pragmas.Append ((N, E, Reason));
25861 if Is_Enumeration_Type (E) then
25865 Lit := First_Literal (E);
25866 while Present (Lit) loop
25867 Set_Warnings_Off (Lit);
25868 Next_Literal (Lit);
25873 exit when No (Homonym (E));
25878 -- Error if not entity or static string expression case
25880 elsif not Is_Static_String_Expression (Arg2) then
25882 ("second argument of pragma% must be entity name "
25883 & "or static string expression", Arg2);
25885 -- Static string expression case
25888 -- Note on configuration pragma case: If this is a
25889 -- configuration pragma, then for an OFF pragma, we
25890 -- just set Config True in the call, which is all
25891 -- that needs to be done. For the case of ON, this
25892 -- is normally an error, unless it is canceling the
25893 -- effect of a previous OFF pragma in the same file.
25894 -- In any other case, an error will be signalled (ON
25895 -- with no matching OFF).
25897 -- Note: We set Used if we are inside a generic to
25898 -- disable the test that the non-config case actually
25899 -- cancels a warning. That's because we can't be sure
25900 -- there isn't an instantiation in some other unit
25901 -- where a warning is suppressed.
25903 -- We could do a little better here by checking if the
25904 -- generic unit we are inside is public, but for now
25905 -- we don't bother with that refinement.
25908 Message : constant String :=
25909 Acquire_Warning_Match_String
25910 (Expr_Value_S (Get_Pragma_Arg (Arg2)));
25912 if Chars (Argx) = Name_Off then
25913 Set_Specific_Warning_Off
25914 (Loc, Message, Reason,
25915 Config => Is_Configuration_Pragma,
25916 Used => Inside_A_Generic or else In_Instance);
25918 elsif Chars (Argx) = Name_On then
25919 Set_Specific_Warning_On (Loc, Message, Err);
25923 ("??pragma Warnings On with no matching "
25924 & "Warnings Off", Loc);
25934 -------------------
25935 -- Weak_External --
25936 -------------------
25938 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
25940 when Pragma_Weak_External => Weak_External : declare
25945 Check_Arg_Count (1);
25946 Check_Optional_Identifier (Arg1, Name_Entity);
25947 Check_Arg_Is_Library_Level_Local_Name (Arg1);
25948 Ent := Entity (Get_Pragma_Arg (Arg1));
25950 if Rep_Item_Too_Early (Ent, N) then
25953 Ent := Underlying_Type (Ent);
25956 -- The pragma applies to entities with addresses
25958 if Is_Type (Ent) then
25959 Error_Pragma ("pragma applies to objects and subprograms");
25962 -- The only processing required is to link this item on to the
25963 -- list of rep items for the given entity. This is accomplished
25964 -- by the call to Rep_Item_Too_Late (when no error is detected
25965 -- and False is returned).
25967 if Rep_Item_Too_Late (Ent, N) then
25970 Set_Has_Gigi_Rep_Item (Ent);
25974 -----------------------------
25975 -- Wide_Character_Encoding --
25976 -----------------------------
25978 -- pragma Wide_Character_Encoding (IDENTIFIER);
25980 when Pragma_Wide_Character_Encoding =>
25983 -- Nothing to do, handled in parser. Note that we do not enforce
25984 -- configuration pragma placement, this pragma can appear at any
25985 -- place in the source, allowing mixed encodings within a single
25990 --------------------
25991 -- Unknown_Pragma --
25992 --------------------
25994 -- Should be impossible, since the case of an unknown pragma is
25995 -- separately processed before the case statement is entered.
25997 when Unknown_Pragma =>
25998 raise Program_Error;
26001 -- AI05-0144: detect dangerous order dependence. Disabled for now,
26002 -- until AI is formally approved.
26004 -- Check_Order_Dependence;
26007 when Pragma_Exit => null;
26008 end Analyze_Pragma;
26010 ---------------------------------------------
26011 -- Analyze_Pre_Post_Condition_In_Decl_Part --
26012 ---------------------------------------------
26014 -- WARNING: This routine manages Ghost regions. Return statements must be
26015 -- replaced by gotos which jump to the end of the routine and restore the
26018 procedure Analyze_Pre_Post_Condition_In_Decl_Part
26020 Freeze_Id : Entity_Id := Empty)
26022 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
26023 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
26025 Disp_Typ : Entity_Id;
26026 -- The dispatching type of the subprogram subject to the pre- or
26029 function Check_References (Nod : Node_Id) return Traverse_Result;
26030 -- Check that expression Nod does not mention non-primitives of the
26031 -- type, global objects of the type, or other illegalities described
26032 -- and implied by AI12-0113.
26034 ----------------------
26035 -- Check_References --
26036 ----------------------
26038 function Check_References (Nod : Node_Id) return Traverse_Result is
26040 if Nkind (Nod) = N_Function_Call
26041 and then Is_Entity_Name (Name (Nod))
26044 Func : constant Entity_Id := Entity (Name (Nod));
26048 -- An operation of the type must be a primitive
26050 if No (Find_Dispatching_Type (Func)) then
26051 Form := First_Formal (Func);
26052 while Present (Form) loop
26053 if Etype (Form) = Disp_Typ then
26055 ("operation in class-wide condition must be "
26056 & "primitive of &", Nod, Disp_Typ);
26059 Next_Formal (Form);
26062 -- A return object of the type is illegal as well
26064 if Etype (Func) = Disp_Typ
26065 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
26068 ("operation in class-wide condition must be primitive "
26069 & "of &", Nod, Disp_Typ);
26072 -- Otherwise we have a call to an overridden primitive, and we
26073 -- will create a common class-wide clone for the body of
26074 -- original operation and its eventual inherited versions. If
26075 -- the original operation dispatches on result it is never
26076 -- inherited and there is no need for a clone. There is not
26077 -- need for a clone either in GNATprove mode, as cases that
26078 -- would require it are rejected (when an inherited primitive
26079 -- calls an overridden operation in a class-wide contract), and
26080 -- the clone would make proof impossible in some cases.
26082 elsif not Is_Abstract_Subprogram (Spec_Id)
26083 and then No (Class_Wide_Clone (Spec_Id))
26084 and then not Has_Controlling_Result (Spec_Id)
26085 and then not GNATprove_Mode
26087 Build_Class_Wide_Clone_Decl (Spec_Id);
26091 elsif Is_Entity_Name (Nod)
26093 (Etype (Nod) = Disp_Typ
26094 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
26095 and then Ekind_In (Entity (Nod), E_Constant, E_Variable)
26098 ("object in class-wide condition must be formal of type &",
26101 elsif Nkind (Nod) = N_Explicit_Dereference
26102 and then (Etype (Nod) = Disp_Typ
26103 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
26104 and then (not Is_Entity_Name (Prefix (Nod))
26105 or else not Is_Formal (Entity (Prefix (Nod))))
26108 ("operation in class-wide condition must be primitive of &",
26113 end Check_References;
26115 procedure Check_Class_Wide_Condition is
26116 new Traverse_Proc (Check_References);
26120 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
26122 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
26123 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
26124 -- Save the Ghost-related attributes to restore on exit
26127 Restore_Scope : Boolean := False;
26129 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
26132 -- Do not analyze the pragma multiple times
26134 if Is_Analyzed_Pragma (N) then
26138 -- Set the Ghost mode in effect from the pragma. Due to the delayed
26139 -- analysis of the pragma, the Ghost mode at point of declaration and
26140 -- point of analysis may not necessarily be the same. Use the mode in
26141 -- effect at the point of declaration.
26143 Set_Ghost_Mode (N);
26145 -- Ensure that the subprogram and its formals are visible when analyzing
26146 -- the expression of the pragma.
26148 if not In_Open_Scopes (Spec_Id) then
26149 Restore_Scope := True;
26150 Push_Scope (Spec_Id);
26152 if Is_Generic_Subprogram (Spec_Id) then
26153 Install_Generic_Formals (Spec_Id);
26155 Install_Formals (Spec_Id);
26159 Errors := Serious_Errors_Detected;
26160 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
26162 -- Emit a clarification message when the expression contains at least
26163 -- one undefined reference, possibly due to contract freezing.
26165 if Errors /= Serious_Errors_Detected
26166 and then Present (Freeze_Id)
26167 and then Has_Undefined_Reference (Expr)
26169 Contract_Freeze_Error (Spec_Id, Freeze_Id);
26172 if Class_Present (N) then
26174 -- Verify that a class-wide condition is legal, i.e. the operation is
26175 -- a primitive of a tagged type. Note that a generic subprogram is
26176 -- not a primitive operation.
26178 Disp_Typ := Find_Dispatching_Type (Spec_Id);
26180 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
26181 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
26183 if From_Aspect_Specification (N) then
26185 ("aspect % can only be specified for a primitive operation "
26186 & "of a tagged type", Corresponding_Aspect (N));
26188 -- The pragma is a source construct
26192 ("pragma % can only be specified for a primitive operation "
26193 & "of a tagged type", N);
26196 -- Remaining semantic checks require a full tree traversal
26199 Check_Class_Wide_Condition (Expr);
26204 if Restore_Scope then
26208 -- If analysis of the condition indicates that a class-wide clone
26209 -- has been created, build and analyze its declaration.
26211 if Is_Subprogram (Spec_Id)
26212 and then Present (Class_Wide_Clone (Spec_Id))
26214 Analyze (Unit_Declaration_Node (Class_Wide_Clone (Spec_Id)));
26217 -- Currently it is not possible to inline pre/postconditions on a
26218 -- subprogram subject to pragma Inline_Always.
26220 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
26221 Set_Is_Analyzed_Pragma (N);
26223 Restore_Ghost_Region (Saved_GM, Saved_IGR);
26224 end Analyze_Pre_Post_Condition_In_Decl_Part;
26226 ------------------------------------------
26227 -- Analyze_Refined_Depends_In_Decl_Part --
26228 ------------------------------------------
26230 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
26231 procedure Check_Dependency_Clause
26232 (Spec_Id : Entity_Id;
26233 Dep_Clause : Node_Id;
26234 Dep_States : Elist_Id;
26235 Refinements : List_Id;
26236 Matched_Items : in out Elist_Id);
26237 -- Try to match a single dependency clause Dep_Clause against one or
26238 -- more refinement clauses found in list Refinements. Each successful
26239 -- match eliminates at least one refinement clause from Refinements.
26240 -- Spec_Id denotes the entity of the related subprogram. Dep_States
26241 -- denotes the entities of all abstract states which appear in pragma
26242 -- Depends. Matched_Items contains the entities of all successfully
26243 -- matched items found in pragma Depends.
26245 procedure Check_Output_States
26246 (Spec_Inputs : Elist_Id;
26247 Spec_Outputs : Elist_Id;
26248 Body_Inputs : Elist_Id;
26249 Body_Outputs : Elist_Id);
26250 -- Determine whether pragma Depends contains an output state with a
26251 -- visible refinement and if so, ensure that pragma Refined_Depends
26252 -- mentions all its constituents as outputs. Spec_Inputs and
26253 -- Spec_Outputs denote the inputs and outputs of the subprogram spec
26254 -- synthesized from pragma Depends. Body_Inputs and Body_Outputs denote
26255 -- the inputs and outputs of the subprogram body synthesized from pragma
26256 -- Refined_Depends.
26258 function Collect_States (Clauses : List_Id) return Elist_Id;
26259 -- Given a normalized list of dependencies obtained from calling
26260 -- Normalize_Clauses, return a list containing the entities of all
26261 -- states appearing in dependencies. It helps in checking refinements
26262 -- involving a state and a corresponding constituent which is not a
26263 -- direct constituent of the state.
26265 procedure Normalize_Clauses (Clauses : List_Id);
26266 -- Given a list of dependence or refinement clauses Clauses, normalize
26267 -- each clause by creating multiple dependencies with exactly one input
26270 procedure Remove_Extra_Clauses
26271 (Clauses : List_Id;
26272 Matched_Items : Elist_Id);
26273 -- Given a list of refinement clauses Clauses, remove all clauses whose
26274 -- inputs and/or outputs have been previously matched. See the body for
26275 -- all special cases. Matched_Items contains the entities of all matched
26276 -- items found in pragma Depends.
26278 procedure Report_Extra_Clauses (Clauses : List_Id);
26279 -- Emit an error for each extra clause found in list Clauses
26281 -----------------------------
26282 -- Check_Dependency_Clause --
26283 -----------------------------
26285 procedure Check_Dependency_Clause
26286 (Spec_Id : Entity_Id;
26287 Dep_Clause : Node_Id;
26288 Dep_States : Elist_Id;
26289 Refinements : List_Id;
26290 Matched_Items : in out Elist_Id)
26292 Dep_Input : constant Node_Id := Expression (Dep_Clause);
26293 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
26295 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
26296 -- Determine whether dependency item Dep_Item has been matched in a
26297 -- previous clause.
26299 function Is_In_Out_State_Clause return Boolean;
26300 -- Determine whether dependence clause Dep_Clause denotes an abstract
26301 -- state that depends on itself (State => State).
26303 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
26304 -- Determine whether item Item denotes an abstract state with visible
26305 -- null refinement.
26307 procedure Match_Items
26308 (Dep_Item : Node_Id;
26309 Ref_Item : Node_Id;
26310 Matched : out Boolean);
26311 -- Try to match dependence item Dep_Item against refinement item
26312 -- Ref_Item. To match against a possible null refinement (see 2, 9),
26313 -- set Ref_Item to Empty. Flag Matched is set to True when one of
26314 -- the following conformance scenarios is in effect:
26315 -- 1) Both items denote null
26316 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
26317 -- 3) Both items denote attribute 'Result
26318 -- 4) Both items denote the same object
26319 -- 5) Both items denote the same formal parameter
26320 -- 6) Both items denote the same current instance of a type
26321 -- 7) Both items denote the same discriminant
26322 -- 8) Dep_Item is an abstract state with visible null refinement
26323 -- and Ref_Item denotes null.
26324 -- 9) Dep_Item is an abstract state with visible null refinement
26325 -- and Ref_Item is Empty (special case).
26326 -- 10) Dep_Item is an abstract state with full or partial visible
26327 -- non-null refinement and Ref_Item denotes one of its
26329 -- 11) Dep_Item is an abstract state without a full visible
26330 -- refinement and Ref_Item denotes the same state.
26331 -- When scenario 10 is in effect, the entity of the abstract state
26332 -- denoted by Dep_Item is added to list Refined_States.
26334 procedure Record_Item (Item_Id : Entity_Id);
26335 -- Store the entity of an item denoted by Item_Id in Matched_Items
26337 ------------------------
26338 -- Is_Already_Matched --
26339 ------------------------
26341 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean is
26342 Item_Id : Entity_Id := Empty;
26345 -- When the dependency item denotes attribute 'Result, check for
26346 -- the entity of the related subprogram.
26348 if Is_Attribute_Result (Dep_Item) then
26349 Item_Id := Spec_Id;
26351 elsif Is_Entity_Name (Dep_Item) then
26352 Item_Id := Available_View (Entity_Of (Dep_Item));
26356 Present (Item_Id) and then Contains (Matched_Items, Item_Id);
26357 end Is_Already_Matched;
26359 ----------------------------
26360 -- Is_In_Out_State_Clause --
26361 ----------------------------
26363 function Is_In_Out_State_Clause return Boolean is
26364 Dep_Input_Id : Entity_Id;
26365 Dep_Output_Id : Entity_Id;
26368 -- Detect the following clause:
26371 if Is_Entity_Name (Dep_Input)
26372 and then Is_Entity_Name (Dep_Output)
26374 -- Handle abstract views generated for limited with clauses
26376 Dep_Input_Id := Available_View (Entity_Of (Dep_Input));
26377 Dep_Output_Id := Available_View (Entity_Of (Dep_Output));
26380 Ekind (Dep_Input_Id) = E_Abstract_State
26381 and then Dep_Input_Id = Dep_Output_Id;
26385 end Is_In_Out_State_Clause;
26387 ---------------------------
26388 -- Is_Null_Refined_State --
26389 ---------------------------
26391 function Is_Null_Refined_State (Item : Node_Id) return Boolean is
26392 Item_Id : Entity_Id;
26395 if Is_Entity_Name (Item) then
26397 -- Handle abstract views generated for limited with clauses
26399 Item_Id := Available_View (Entity_Of (Item));
26402 Ekind (Item_Id) = E_Abstract_State
26403 and then Has_Null_Visible_Refinement (Item_Id);
26407 end Is_Null_Refined_State;
26413 procedure Match_Items
26414 (Dep_Item : Node_Id;
26415 Ref_Item : Node_Id;
26416 Matched : out Boolean)
26418 Dep_Item_Id : Entity_Id;
26419 Ref_Item_Id : Entity_Id;
26422 -- Assume that the two items do not match
26426 -- A null matches null or Empty (special case)
26428 if Nkind (Dep_Item) = N_Null
26429 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
26433 -- Attribute 'Result matches attribute 'Result
26435 elsif Is_Attribute_Result (Dep_Item)
26436 and then Is_Attribute_Result (Ref_Item)
26438 -- Put the entity of the related function on the list of
26439 -- matched items because attribute 'Result does not carry
26440 -- an entity similar to states and constituents.
26442 Record_Item (Spec_Id);
26445 -- Abstract states, current instances of concurrent types,
26446 -- discriminants, formal parameters and objects.
26448 elsif Is_Entity_Name (Dep_Item) then
26450 -- Handle abstract views generated for limited with clauses
26452 Dep_Item_Id := Available_View (Entity_Of (Dep_Item));
26454 if Ekind (Dep_Item_Id) = E_Abstract_State then
26456 -- An abstract state with visible null refinement matches
26457 -- null or Empty (special case).
26459 if Has_Null_Visible_Refinement (Dep_Item_Id)
26460 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
26462 Record_Item (Dep_Item_Id);
26465 -- An abstract state with visible non-null refinement
26466 -- matches one of its constituents, or itself for an
26467 -- abstract state with partial visible refinement.
26469 elsif Has_Non_Null_Visible_Refinement (Dep_Item_Id) then
26470 if Is_Entity_Name (Ref_Item) then
26471 Ref_Item_Id := Entity_Of (Ref_Item);
26473 if Ekind_In (Ref_Item_Id, E_Abstract_State,
26476 and then Present (Encapsulating_State (Ref_Item_Id))
26477 and then Find_Encapsulating_State
26478 (Dep_States, Ref_Item_Id) = Dep_Item_Id
26480 Record_Item (Dep_Item_Id);
26483 elsif not Has_Visible_Refinement (Dep_Item_Id)
26484 and then Ref_Item_Id = Dep_Item_Id
26486 Record_Item (Dep_Item_Id);
26491 -- An abstract state without a visible refinement matches
26494 elsif Is_Entity_Name (Ref_Item)
26495 and then Entity_Of (Ref_Item) = Dep_Item_Id
26497 Record_Item (Dep_Item_Id);
26501 -- A current instance of a concurrent type, discriminant,
26502 -- formal parameter or an object matches itself.
26504 elsif Is_Entity_Name (Ref_Item)
26505 and then Entity_Of (Ref_Item) = Dep_Item_Id
26507 Record_Item (Dep_Item_Id);
26517 procedure Record_Item (Item_Id : Entity_Id) is
26519 if No (Matched_Items) then
26520 Matched_Items := New_Elmt_List;
26523 Append_Unique_Elmt (Item_Id, Matched_Items);
26528 Clause_Matched : Boolean := False;
26529 Dummy : Boolean := False;
26530 Inputs_Match : Boolean;
26531 Next_Ref_Clause : Node_Id;
26532 Outputs_Match : Boolean;
26533 Ref_Clause : Node_Id;
26534 Ref_Input : Node_Id;
26535 Ref_Output : Node_Id;
26537 -- Start of processing for Check_Dependency_Clause
26540 -- Do not perform this check in an instance because it was already
26541 -- performed successfully in the generic template.
26543 if In_Instance then
26547 -- Examine all refinement clauses and compare them against the
26548 -- dependence clause.
26550 Ref_Clause := First (Refinements);
26551 while Present (Ref_Clause) loop
26552 Next_Ref_Clause := Next (Ref_Clause);
26554 -- Obtain the attributes of the current refinement clause
26556 Ref_Input := Expression (Ref_Clause);
26557 Ref_Output := First (Choices (Ref_Clause));
26559 -- The current refinement clause matches the dependence clause
26560 -- when both outputs match and both inputs match. See routine
26561 -- Match_Items for all possible conformance scenarios.
26563 -- Depends Dep_Output => Dep_Input
26567 -- Refined_Depends Ref_Output => Ref_Input
26570 (Dep_Item => Dep_Input,
26571 Ref_Item => Ref_Input,
26572 Matched => Inputs_Match);
26575 (Dep_Item => Dep_Output,
26576 Ref_Item => Ref_Output,
26577 Matched => Outputs_Match);
26579 -- An In_Out state clause may be matched against a refinement with
26580 -- a null input or null output as long as the non-null side of the
26581 -- relation contains a valid constituent of the In_Out_State.
26583 if Is_In_Out_State_Clause then
26585 -- Depends => (State => State)
26586 -- Refined_Depends => (null => Constit) -- OK
26589 and then not Outputs_Match
26590 and then Nkind (Ref_Output) = N_Null
26592 Outputs_Match := True;
26595 -- Depends => (State => State)
26596 -- Refined_Depends => (Constit => null) -- OK
26598 if not Inputs_Match
26599 and then Outputs_Match
26600 and then Nkind (Ref_Input) = N_Null
26602 Inputs_Match := True;
26606 -- The current refinement clause is legally constructed following
26607 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
26608 -- the pool of candidates. The seach continues because a single
26609 -- dependence clause may have multiple matching refinements.
26611 if Inputs_Match and Outputs_Match then
26612 Clause_Matched := True;
26613 Remove (Ref_Clause);
26616 Ref_Clause := Next_Ref_Clause;
26619 -- Depending on the order or composition of refinement clauses, an
26620 -- In_Out state clause may not be directly refinable.
26622 -- Refined_State => (State => (Constit_1, Constit_2))
26623 -- Depends => ((Output, State) => (Input, State))
26624 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
26626 -- Matching normalized clause (State => State) fails because there is
26627 -- no direct refinement capable of satisfying this relation. Another
26628 -- similar case arises when clauses (Constit_1 => Input) and (Output
26629 -- => Constit_2) are matched first, leaving no candidates for clause
26630 -- (State => State). Both scenarios are legal as long as one of the
26631 -- previous clauses mentioned a valid constituent of State.
26633 if not Clause_Matched
26634 and then Is_In_Out_State_Clause
26635 and then Is_Already_Matched (Dep_Input)
26637 Clause_Matched := True;
26640 -- A clause where the input is an abstract state with visible null
26641 -- refinement or a 'Result attribute is implicitly matched when the
26642 -- output has already been matched in a previous clause.
26644 -- Refined_State => (State => null)
26645 -- Depends => (Output => State) -- implicitly OK
26646 -- Refined_Depends => (Output => ...)
26647 -- Depends => (...'Result => State) -- implicitly OK
26648 -- Refined_Depends => (...'Result => ...)
26650 if not Clause_Matched
26651 and then Is_Null_Refined_State (Dep_Input)
26652 and then Is_Already_Matched (Dep_Output)
26654 Clause_Matched := True;
26657 -- A clause where the output is an abstract state with visible null
26658 -- refinement is implicitly matched when the input has already been
26659 -- matched in a previous clause.
26661 -- Refined_State => (State => null)
26662 -- Depends => (State => Input) -- implicitly OK
26663 -- Refined_Depends => (... => Input)
26665 if not Clause_Matched
26666 and then Is_Null_Refined_State (Dep_Output)
26667 and then Is_Already_Matched (Dep_Input)
26669 Clause_Matched := True;
26672 -- At this point either all refinement clauses have been examined or
26673 -- pragma Refined_Depends contains a solitary null. Only an abstract
26674 -- state with null refinement can possibly match these cases.
26676 -- Refined_State => (State => null)
26677 -- Depends => (State => null)
26678 -- Refined_Depends => null -- OK
26680 if not Clause_Matched then
26682 (Dep_Item => Dep_Input,
26684 Matched => Inputs_Match);
26687 (Dep_Item => Dep_Output,
26689 Matched => Outputs_Match);
26691 Clause_Matched := Inputs_Match and Outputs_Match;
26694 -- If the contents of Refined_Depends are legal, then the current
26695 -- dependence clause should be satisfied either by an explicit match
26696 -- or by one of the special cases.
26698 if not Clause_Matched then
26700 (Fix_Msg (Spec_Id, "dependence clause of subprogram & has no "
26701 & "matching refinement in body"), Dep_Clause, Spec_Id);
26703 end Check_Dependency_Clause;
26705 -------------------------
26706 -- Check_Output_States --
26707 -------------------------
26709 procedure Check_Output_States
26710 (Spec_Inputs : Elist_Id;
26711 Spec_Outputs : Elist_Id;
26712 Body_Inputs : Elist_Id;
26713 Body_Outputs : Elist_Id)
26715 procedure Check_Constituent_Usage (State_Id : Entity_Id);
26716 -- Determine whether all constituents of state State_Id with full
26717 -- visible refinement are used as outputs in pragma Refined_Depends.
26718 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
26720 -----------------------------
26721 -- Check_Constituent_Usage --
26722 -----------------------------
26724 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
26725 Constits : constant Elist_Id :=
26726 Partial_Refinement_Constituents (State_Id);
26727 Constit_Elmt : Elmt_Id;
26728 Constit_Id : Entity_Id;
26729 Only_Partial : constant Boolean :=
26730 not Has_Visible_Refinement (State_Id);
26731 Posted : Boolean := False;
26734 if Present (Constits) then
26735 Constit_Elmt := First_Elmt (Constits);
26736 while Present (Constit_Elmt) loop
26737 Constit_Id := Node (Constit_Elmt);
26739 -- Issue an error when a constituent of State_Id is used,
26740 -- and State_Id has only partial visible refinement
26741 -- (SPARK RM 7.2.4(3d)).
26743 if Only_Partial then
26744 if (Present (Body_Inputs)
26745 and then Appears_In (Body_Inputs, Constit_Id))
26747 (Present (Body_Outputs)
26748 and then Appears_In (Body_Outputs, Constit_Id))
26750 Error_Msg_Name_1 := Chars (State_Id);
26752 ("constituent & of state % cannot be used in "
26753 & "dependence refinement", N, Constit_Id);
26754 Error_Msg_Name_1 := Chars (State_Id);
26755 SPARK_Msg_N ("\use state % instead", N);
26758 -- The constituent acts as an input (SPARK RM 7.2.5(3))
26760 elsif Present (Body_Inputs)
26761 and then Appears_In (Body_Inputs, Constit_Id)
26763 Error_Msg_Name_1 := Chars (State_Id);
26765 ("constituent & of state % must act as output in "
26766 & "dependence refinement", N, Constit_Id);
26768 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
26770 elsif No (Body_Outputs)
26771 or else not Appears_In (Body_Outputs, Constit_Id)
26776 ("output state & must be replaced by all its "
26777 & "constituents in dependence refinement",
26782 ("\constituent & is missing in output list",
26786 Next_Elmt (Constit_Elmt);
26789 end Check_Constituent_Usage;
26794 Item_Elmt : Elmt_Id;
26795 Item_Id : Entity_Id;
26797 -- Start of processing for Check_Output_States
26800 -- Do not perform this check in an instance because it was already
26801 -- performed successfully in the generic template.
26803 if In_Instance then
26806 -- Inspect the outputs of pragma Depends looking for a state with a
26807 -- visible refinement.
26809 elsif Present (Spec_Outputs) then
26810 Item_Elmt := First_Elmt (Spec_Outputs);
26811 while Present (Item_Elmt) loop
26812 Item := Node (Item_Elmt);
26814 -- Deal with the mixed nature of the input and output lists
26816 if Nkind (Item) = N_Defining_Identifier then
26819 Item_Id := Available_View (Entity_Of (Item));
26822 if Ekind (Item_Id) = E_Abstract_State then
26824 -- The state acts as an input-output, skip it
26826 if Present (Spec_Inputs)
26827 and then Appears_In (Spec_Inputs, Item_Id)
26831 -- Ensure that all of the constituents are utilized as
26832 -- outputs in pragma Refined_Depends.
26834 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
26835 Check_Constituent_Usage (Item_Id);
26839 Next_Elmt (Item_Elmt);
26842 end Check_Output_States;
26844 --------------------
26845 -- Collect_States --
26846 --------------------
26848 function Collect_States (Clauses : List_Id) return Elist_Id is
26849 procedure Collect_State
26851 States : in out Elist_Id);
26852 -- Add the entity of Item to list States when it denotes to a state
26854 -------------------
26855 -- Collect_State --
26856 -------------------
26858 procedure Collect_State
26860 States : in out Elist_Id)
26865 if Is_Entity_Name (Item) then
26866 Id := Entity_Of (Item);
26868 if Ekind (Id) = E_Abstract_State then
26869 if No (States) then
26870 States := New_Elmt_List;
26873 Append_Unique_Elmt (Id, States);
26883 States : Elist_Id := No_Elist;
26885 -- Start of processing for Collect_States
26888 Clause := First (Clauses);
26889 while Present (Clause) loop
26890 Input := Expression (Clause);
26891 Output := First (Choices (Clause));
26893 Collect_State (Input, States);
26894 Collect_State (Output, States);
26900 end Collect_States;
26902 -----------------------
26903 -- Normalize_Clauses --
26904 -----------------------
26906 procedure Normalize_Clauses (Clauses : List_Id) is
26907 procedure Normalize_Inputs (Clause : Node_Id);
26908 -- Normalize clause Clause by creating multiple clauses for each
26909 -- input item of Clause. It is assumed that Clause has exactly one
26910 -- output. The transformation is as follows:
26912 -- Output => (Input_1, Input_2) -- original
26914 -- Output => Input_1 -- normalizations
26915 -- Output => Input_2
26917 procedure Normalize_Outputs (Clause : Node_Id);
26918 -- Normalize clause Clause by creating multiple clause for each
26919 -- output item of Clause. The transformation is as follows:
26921 -- (Output_1, Output_2) => Input -- original
26923 -- Output_1 => Input -- normalization
26924 -- Output_2 => Input
26926 ----------------------
26927 -- Normalize_Inputs --
26928 ----------------------
26930 procedure Normalize_Inputs (Clause : Node_Id) is
26931 Inputs : constant Node_Id := Expression (Clause);
26932 Loc : constant Source_Ptr := Sloc (Clause);
26933 Output : constant List_Id := Choices (Clause);
26934 Last_Input : Node_Id;
26936 New_Clause : Node_Id;
26937 Next_Input : Node_Id;
26940 -- Normalization is performed only when the original clause has
26941 -- more than one input. Multiple inputs appear as an aggregate.
26943 if Nkind (Inputs) = N_Aggregate then
26944 Last_Input := Last (Expressions (Inputs));
26946 -- Create a new clause for each input
26948 Input := First (Expressions (Inputs));
26949 while Present (Input) loop
26950 Next_Input := Next (Input);
26952 -- Unhook the current input from the original input list
26953 -- because it will be relocated to a new clause.
26957 -- Special processing for the last input. At this point the
26958 -- original aggregate has been stripped down to one element.
26959 -- Replace the aggregate by the element itself.
26961 if Input = Last_Input then
26962 Rewrite (Inputs, Input);
26964 -- Generate a clause of the form:
26969 Make_Component_Association (Loc,
26970 Choices => New_Copy_List_Tree (Output),
26971 Expression => Input);
26973 -- The new clause contains replicated content that has
26974 -- already been analyzed, mark the clause as analyzed.
26976 Set_Analyzed (New_Clause);
26977 Insert_After (Clause, New_Clause);
26980 Input := Next_Input;
26983 end Normalize_Inputs;
26985 -----------------------
26986 -- Normalize_Outputs --
26987 -----------------------
26989 procedure Normalize_Outputs (Clause : Node_Id) is
26990 Inputs : constant Node_Id := Expression (Clause);
26991 Loc : constant Source_Ptr := Sloc (Clause);
26992 Outputs : constant Node_Id := First (Choices (Clause));
26993 Last_Output : Node_Id;
26994 New_Clause : Node_Id;
26995 Next_Output : Node_Id;
26999 -- Multiple outputs appear as an aggregate. Nothing to do when
27000 -- the clause has exactly one output.
27002 if Nkind (Outputs) = N_Aggregate then
27003 Last_Output := Last (Expressions (Outputs));
27005 -- Create a clause for each output. Note that each time a new
27006 -- clause is created, the original output list slowly shrinks
27007 -- until there is one item left.
27009 Output := First (Expressions (Outputs));
27010 while Present (Output) loop
27011 Next_Output := Next (Output);
27013 -- Unhook the output from the original output list as it
27014 -- will be relocated to a new clause.
27018 -- Special processing for the last output. At this point
27019 -- the original aggregate has been stripped down to one
27020 -- element. Replace the aggregate by the element itself.
27022 if Output = Last_Output then
27023 Rewrite (Outputs, Output);
27026 -- Generate a clause of the form:
27027 -- (Output => Inputs)
27030 Make_Component_Association (Loc,
27031 Choices => New_List (Output),
27032 Expression => New_Copy_Tree (Inputs));
27034 -- The new clause contains replicated content that has
27035 -- already been analyzed. There is not need to reanalyze
27038 Set_Analyzed (New_Clause);
27039 Insert_After (Clause, New_Clause);
27042 Output := Next_Output;
27045 end Normalize_Outputs;
27051 -- Start of processing for Normalize_Clauses
27054 Clause := First (Clauses);
27055 while Present (Clause) loop
27056 Normalize_Outputs (Clause);
27060 Clause := First (Clauses);
27061 while Present (Clause) loop
27062 Normalize_Inputs (Clause);
27065 end Normalize_Clauses;
27067 --------------------------
27068 -- Remove_Extra_Clauses --
27069 --------------------------
27071 procedure Remove_Extra_Clauses
27072 (Clauses : List_Id;
27073 Matched_Items : Elist_Id)
27077 Input_Id : Entity_Id;
27078 Next_Clause : Node_Id;
27080 State_Id : Entity_Id;
27083 Clause := First (Clauses);
27084 while Present (Clause) loop
27085 Next_Clause := Next (Clause);
27087 Input := Expression (Clause);
27088 Output := First (Choices (Clause));
27090 -- Recognize a clause of the form
27094 -- where Input is a constituent of a state which was already
27095 -- successfully matched. This clause must be removed because it
27096 -- simply indicates that some of the constituents of the state
27099 -- Refined_State => (State => (Constit_1, Constit_2))
27100 -- Depends => (Output => State)
27101 -- Refined_Depends => ((Output => Constit_1), -- State matched
27102 -- (null => Constit_2)) -- OK
27104 if Nkind (Output) = N_Null and then Is_Entity_Name (Input) then
27106 -- Handle abstract views generated for limited with clauses
27108 Input_Id := Available_View (Entity_Of (Input));
27110 -- The input must be a constituent of a state
27112 if Ekind_In (Input_Id, E_Abstract_State,
27115 and then Present (Encapsulating_State (Input_Id))
27117 State_Id := Encapsulating_State (Input_Id);
27119 -- The state must have a non-null visible refinement and be
27120 -- matched in a previous clause.
27122 if Has_Non_Null_Visible_Refinement (State_Id)
27123 and then Contains (Matched_Items, State_Id)
27129 -- Recognize a clause of the form
27133 -- where Output is an arbitrary item. This clause must be removed
27134 -- because a null input legitimately matches anything.
27136 elsif Nkind (Input) = N_Null then
27140 Clause := Next_Clause;
27142 end Remove_Extra_Clauses;
27144 --------------------------
27145 -- Report_Extra_Clauses --
27146 --------------------------
27148 procedure Report_Extra_Clauses (Clauses : List_Id) is
27152 -- Do not perform this check in an instance because it was already
27153 -- performed successfully in the generic template.
27155 if In_Instance then
27158 elsif Present (Clauses) then
27159 Clause := First (Clauses);
27160 while Present (Clause) loop
27162 ("unmatched or extra clause in dependence refinement",
27168 end Report_Extra_Clauses;
27172 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
27173 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
27174 Errors : constant Nat := Serious_Errors_Detected;
27181 Body_Inputs : Elist_Id := No_Elist;
27182 Body_Outputs : Elist_Id := No_Elist;
27183 -- The inputs and outputs of the subprogram body synthesized from pragma
27184 -- Refined_Depends.
27186 Dependencies : List_Id := No_List;
27188 -- The corresponding Depends pragma along with its clauses
27190 Matched_Items : Elist_Id := No_Elist;
27191 -- A list containing the entities of all successfully matched items
27192 -- found in pragma Depends.
27194 Refinements : List_Id := No_List;
27195 -- The clauses of pragma Refined_Depends
27197 Spec_Id : Entity_Id;
27198 -- The entity of the subprogram subject to pragma Refined_Depends
27200 Spec_Inputs : Elist_Id := No_Elist;
27201 Spec_Outputs : Elist_Id := No_Elist;
27202 -- The inputs and outputs of the subprogram spec synthesized from pragma
27205 States : Elist_Id := No_Elist;
27206 -- A list containing the entities of all states whose constituents
27207 -- appear in pragma Depends.
27209 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
27212 -- Do not analyze the pragma multiple times
27214 if Is_Analyzed_Pragma (N) then
27218 Spec_Id := Unique_Defining_Entity (Body_Decl);
27220 -- Use the anonymous object as the proper spec when Refined_Depends
27221 -- applies to the body of a single task type. The object carries the
27222 -- proper Chars as well as all non-refined versions of pragmas.
27224 if Is_Single_Concurrent_Type (Spec_Id) then
27225 Spec_Id := Anonymous_Object (Spec_Id);
27228 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
27230 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
27231 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
27233 if No (Depends) then
27235 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
27236 & "& lacks aspect or pragma Depends"), N, Spec_Id);
27240 Deps := Expression (Get_Argument (Depends, Spec_Id));
27242 -- A null dependency relation renders the refinement useless because it
27243 -- cannot possibly mention abstract states with visible refinement. Note
27244 -- that the inverse is not true as states may be refined to null
27245 -- (SPARK RM 7.2.5(2)).
27247 if Nkind (Deps) = N_Null then
27249 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
27250 & "depend on abstract state with visible refinement"), N, Spec_Id);
27254 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
27255 -- This ensures that the categorization of all refined dependency items
27256 -- is consistent with their role.
27258 Analyze_Depends_In_Decl_Part (N);
27260 -- Do not match dependencies against refinements if Refined_Depends is
27261 -- illegal to avoid emitting misleading error.
27263 if Serious_Errors_Detected = Errors then
27265 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
27266 -- the inputs and outputs of the subprogram spec and body to verify
27267 -- the use of states with visible refinement and their constituents.
27269 if No (Get_Pragma (Spec_Id, Pragma_Global))
27270 or else No (Get_Pragma (Body_Id, Pragma_Refined_Global))
27272 Collect_Subprogram_Inputs_Outputs
27273 (Subp_Id => Spec_Id,
27274 Synthesize => True,
27275 Subp_Inputs => Spec_Inputs,
27276 Subp_Outputs => Spec_Outputs,
27277 Global_Seen => Dummy);
27279 Collect_Subprogram_Inputs_Outputs
27280 (Subp_Id => Body_Id,
27281 Synthesize => True,
27282 Subp_Inputs => Body_Inputs,
27283 Subp_Outputs => Body_Outputs,
27284 Global_Seen => Dummy);
27286 -- For an output state with a visible refinement, ensure that all
27287 -- constituents appear as outputs in the dependency refinement.
27289 Check_Output_States
27290 (Spec_Inputs => Spec_Inputs,
27291 Spec_Outputs => Spec_Outputs,
27292 Body_Inputs => Body_Inputs,
27293 Body_Outputs => Body_Outputs);
27296 -- Matching is disabled in ASIS because clauses are not normalized as
27297 -- this is a tree altering activity similar to expansion.
27303 -- Multiple dependency clauses appear as component associations of an
27304 -- aggregate. Note that the clauses are copied because the algorithm
27305 -- modifies them and this should not be visible in Depends.
27307 pragma Assert (Nkind (Deps) = N_Aggregate);
27308 Dependencies := New_Copy_List_Tree (Component_Associations (Deps));
27309 Normalize_Clauses (Dependencies);
27311 -- Gather all states which appear in Depends
27313 States := Collect_States (Dependencies);
27315 Refs := Expression (Get_Argument (N, Spec_Id));
27317 if Nkind (Refs) = N_Null then
27318 Refinements := No_List;
27320 -- Multiple dependency clauses appear as component associations of an
27321 -- aggregate. Note that the clauses are copied because the algorithm
27322 -- modifies them and this should not be visible in Refined_Depends.
27324 else pragma Assert (Nkind (Refs) = N_Aggregate);
27325 Refinements := New_Copy_List_Tree (Component_Associations (Refs));
27326 Normalize_Clauses (Refinements);
27329 -- At this point the clauses of pragmas Depends and Refined_Depends
27330 -- have been normalized into simple dependencies between one output
27331 -- and one input. Examine all clauses of pragma Depends looking for
27332 -- matching clauses in pragma Refined_Depends.
27334 Clause := First (Dependencies);
27335 while Present (Clause) loop
27336 Check_Dependency_Clause
27337 (Spec_Id => Spec_Id,
27338 Dep_Clause => Clause,
27339 Dep_States => States,
27340 Refinements => Refinements,
27341 Matched_Items => Matched_Items);
27346 -- Pragma Refined_Depends may contain multiple clarification clauses
27347 -- which indicate that certain constituents do not influence the data
27348 -- flow in any way. Such clauses must be removed as long as the state
27349 -- has been matched, otherwise they will be incorrectly flagged as
27352 -- Refined_State => (State => (Constit_1, Constit_2))
27353 -- Depends => (Output => State)
27354 -- Refined_Depends => ((Output => Constit_1), -- State matched
27355 -- (null => Constit_2)) -- must be removed
27357 Remove_Extra_Clauses (Refinements, Matched_Items);
27359 if Serious_Errors_Detected = Errors then
27360 Report_Extra_Clauses (Refinements);
27365 Set_Is_Analyzed_Pragma (N);
27366 end Analyze_Refined_Depends_In_Decl_Part;
27368 -----------------------------------------
27369 -- Analyze_Refined_Global_In_Decl_Part --
27370 -----------------------------------------
27372 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is
27374 -- The corresponding Global pragma
27376 Has_In_State : Boolean := False;
27377 Has_In_Out_State : Boolean := False;
27378 Has_Out_State : Boolean := False;
27379 Has_Proof_In_State : Boolean := False;
27380 -- These flags are set when the corresponding Global pragma has a state
27381 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
27384 Has_Null_State : Boolean := False;
27385 -- This flag is set when the corresponding Global pragma has at least
27386 -- one state with a null refinement.
27388 In_Constits : Elist_Id := No_Elist;
27389 In_Out_Constits : Elist_Id := No_Elist;
27390 Out_Constits : Elist_Id := No_Elist;
27391 Proof_In_Constits : Elist_Id := No_Elist;
27392 -- These lists contain the entities of all Input, In_Out, Output and
27393 -- Proof_In constituents that appear in Refined_Global and participate
27394 -- in state refinement.
27396 In_Items : Elist_Id := No_Elist;
27397 In_Out_Items : Elist_Id := No_Elist;
27398 Out_Items : Elist_Id := No_Elist;
27399 Proof_In_Items : Elist_Id := No_Elist;
27400 -- These lists contain the entities of all Input, In_Out, Output and
27401 -- Proof_In items defined in the corresponding Global pragma.
27403 Repeat_Items : Elist_Id := No_Elist;
27404 -- A list of all global items without full visible refinement found
27405 -- in pragma Global. These states should be repeated in the global
27406 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
27407 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
27409 Spec_Id : Entity_Id;
27410 -- The entity of the subprogram subject to pragma Refined_Global
27412 States : Elist_Id := No_Elist;
27413 -- A list of all states with full or partial visible refinement found in
27416 procedure Check_In_Out_States;
27417 -- Determine whether the corresponding Global pragma mentions In_Out
27418 -- states with visible refinement and if so, ensure that one of the
27419 -- following completions apply to the constituents of the state:
27420 -- 1) there is at least one constituent of mode In_Out
27421 -- 2) there is at least one Input and one Output constituent
27422 -- 3) not all constituents are present and one of them is of mode
27424 -- This routine may remove elements from In_Constits, In_Out_Constits,
27425 -- Out_Constits and Proof_In_Constits.
27427 procedure Check_Input_States;
27428 -- Determine whether the corresponding Global pragma mentions Input
27429 -- states with visible refinement and if so, ensure that at least one of
27430 -- its constituents appears as an Input item in Refined_Global.
27431 -- This routine may remove elements from In_Constits, In_Out_Constits,
27432 -- Out_Constits and Proof_In_Constits.
27434 procedure Check_Output_States;
27435 -- Determine whether the corresponding Global pragma mentions Output
27436 -- states with visible refinement and if so, ensure that all of its
27437 -- constituents appear as Output items in Refined_Global.
27438 -- This routine may remove elements from In_Constits, In_Out_Constits,
27439 -- Out_Constits and Proof_In_Constits.
27441 procedure Check_Proof_In_States;
27442 -- Determine whether the corresponding Global pragma mentions Proof_In
27443 -- states with visible refinement and if so, ensure that at least one of
27444 -- its constituents appears as a Proof_In item in Refined_Global.
27445 -- This routine may remove elements from In_Constits, In_Out_Constits,
27446 -- Out_Constits and Proof_In_Constits.
27448 procedure Check_Refined_Global_List
27450 Global_Mode : Name_Id := Name_Input);
27451 -- Verify the legality of a single global list declaration. Global_Mode
27452 -- denotes the current mode in effect.
27454 procedure Collect_Global_Items
27456 Mode : Name_Id := Name_Input);
27457 -- Gather all Input, In_Out, Output and Proof_In items from node List
27458 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
27459 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
27460 -- and Has_Proof_In_State are set when there is at least one abstract
27461 -- state with full or partial visible refinement available in the
27462 -- corresponding mode. Flag Has_Null_State is set when at least state
27463 -- has a null refinement. Mode denotes the current global mode in
27466 function Present_Then_Remove
27468 Item : Entity_Id) return Boolean;
27469 -- Search List for a particular entity Item. If Item has been found,
27470 -- remove it from List. This routine is used to strip lists In_Constits,
27471 -- In_Out_Constits and Out_Constits of valid constituents.
27473 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id);
27474 -- Same as function Present_Then_Remove, but do not report the presence
27475 -- of Item in List.
27477 procedure Report_Extra_Constituents;
27478 -- Emit an error for each constituent found in lists In_Constits,
27479 -- In_Out_Constits and Out_Constits.
27481 procedure Report_Missing_Items;
27482 -- Emit an error for each global item not repeated found in list
27485 -------------------------
27486 -- Check_In_Out_States --
27487 -------------------------
27489 procedure Check_In_Out_States is
27490 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27491 -- Determine whether one of the following coverage scenarios is in
27493 -- 1) there is at least one constituent of mode In_Out or Output
27494 -- 2) there is at least one pair of constituents with modes Input
27495 -- and Output, or Proof_In and Output.
27496 -- 3) there is at least one constituent of mode Output and not all
27497 -- constituents are present.
27498 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
27500 -----------------------------
27501 -- Check_Constituent_Usage --
27502 -----------------------------
27504 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27505 Constits : constant Elist_Id :=
27506 Partial_Refinement_Constituents (State_Id);
27507 Constit_Elmt : Elmt_Id;
27508 Constit_Id : Entity_Id;
27509 Has_Missing : Boolean := False;
27510 In_Out_Seen : Boolean := False;
27511 Input_Seen : Boolean := False;
27512 Output_Seen : Boolean := False;
27513 Proof_In_Seen : Boolean := False;
27516 -- Process all the constituents of the state and note their modes
27517 -- within the global refinement.
27519 if Present (Constits) then
27520 Constit_Elmt := First_Elmt (Constits);
27521 while Present (Constit_Elmt) loop
27522 Constit_Id := Node (Constit_Elmt);
27524 if Present_Then_Remove (In_Constits, Constit_Id) then
27525 Input_Seen := True;
27527 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then
27528 In_Out_Seen := True;
27530 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
27531 Output_Seen := True;
27533 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
27535 Proof_In_Seen := True;
27538 Has_Missing := True;
27541 Next_Elmt (Constit_Elmt);
27545 -- An In_Out constituent is a valid completion
27547 if In_Out_Seen then
27550 -- A pair of one Input/Proof_In and one Output constituent is a
27551 -- valid completion.
27553 elsif (Input_Seen or Proof_In_Seen) and Output_Seen then
27556 elsif Output_Seen then
27558 -- A single Output constituent is a valid completion only when
27559 -- some of the other constituents are missing.
27561 if Has_Missing then
27564 -- Otherwise all constituents are of mode Output
27568 ("global refinement of state & must include at least one "
27569 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
27573 -- The state lacks a completion. When full refinement is visible,
27574 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
27575 -- refinement is visible, emit an error if the abstract state
27576 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
27577 -- both are utilized, Check_State_And_Constituent_Use. will issue
27580 elsif not Input_Seen
27581 and then not In_Out_Seen
27582 and then not Output_Seen
27583 and then not Proof_In_Seen
27585 if Has_Visible_Refinement (State_Id)
27586 or else Contains (Repeat_Items, State_Id)
27589 ("missing global refinement of state &", N, State_Id);
27592 -- Otherwise the state has a malformed completion where at least
27593 -- one of the constituents has a different mode.
27597 ("global refinement of state & redefines the mode of its "
27598 & "constituents", N, State_Id);
27600 end Check_Constituent_Usage;
27604 Item_Elmt : Elmt_Id;
27605 Item_Id : Entity_Id;
27607 -- Start of processing for Check_In_Out_States
27610 -- Do not perform this check in an instance because it was already
27611 -- performed successfully in the generic template.
27613 if In_Instance then
27616 -- Inspect the In_Out items of the corresponding Global pragma
27617 -- looking for a state with a visible refinement.
27619 elsif Has_In_Out_State and then Present (In_Out_Items) then
27620 Item_Elmt := First_Elmt (In_Out_Items);
27621 while Present (Item_Elmt) loop
27622 Item_Id := Node (Item_Elmt);
27624 -- Ensure that one of the three coverage variants is satisfied
27626 if Ekind (Item_Id) = E_Abstract_State
27627 and then Has_Non_Null_Visible_Refinement (Item_Id)
27629 Check_Constituent_Usage (Item_Id);
27632 Next_Elmt (Item_Elmt);
27635 end Check_In_Out_States;
27637 ------------------------
27638 -- Check_Input_States --
27639 ------------------------
27641 procedure Check_Input_States is
27642 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27643 -- Determine whether at least one constituent of state State_Id with
27644 -- full or partial visible refinement is used and has mode Input.
27645 -- Ensure that the remaining constituents do not have In_Out or
27646 -- Output modes. Emit an error if this is not the case
27647 -- (SPARK RM 7.2.4(5)).
27649 -----------------------------
27650 -- Check_Constituent_Usage --
27651 -----------------------------
27653 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27654 Constits : constant Elist_Id :=
27655 Partial_Refinement_Constituents (State_Id);
27656 Constit_Elmt : Elmt_Id;
27657 Constit_Id : Entity_Id;
27658 In_Seen : Boolean := False;
27661 if Present (Constits) then
27662 Constit_Elmt := First_Elmt (Constits);
27663 while Present (Constit_Elmt) loop
27664 Constit_Id := Node (Constit_Elmt);
27666 -- At least one of the constituents appears as an Input
27668 if Present_Then_Remove (In_Constits, Constit_Id) then
27671 -- A Proof_In constituent can refine an Input state as long
27672 -- as there is at least one Input constituent present.
27674 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
27678 -- The constituent appears in the global refinement, but has
27679 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
27681 elsif Present_Then_Remove (In_Out_Constits, Constit_Id)
27682 or else Present_Then_Remove (Out_Constits, Constit_Id)
27684 Error_Msg_Name_1 := Chars (State_Id);
27686 ("constituent & of state % must have mode `Input` in "
27687 & "global refinement", N, Constit_Id);
27690 Next_Elmt (Constit_Elmt);
27694 -- Not one of the constituents appeared as Input. Always emit an
27695 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
27696 -- When only partial refinement is visible, emit an error if the
27697 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27698 -- the case where both are utilized, an error will be issued in
27699 -- Check_State_And_Constituent_Use.
27702 and then (Has_Visible_Refinement (State_Id)
27703 or else Contains (Repeat_Items, State_Id))
27706 ("global refinement of state & must include at least one "
27707 & "constituent of mode `Input`", N, State_Id);
27709 end Check_Constituent_Usage;
27713 Item_Elmt : Elmt_Id;
27714 Item_Id : Entity_Id;
27716 -- Start of processing for Check_Input_States
27719 -- Do not perform this check in an instance because it was already
27720 -- performed successfully in the generic template.
27722 if In_Instance then
27725 -- Inspect the Input items of the corresponding Global pragma looking
27726 -- for a state with a visible refinement.
27728 elsif Has_In_State and then Present (In_Items) then
27729 Item_Elmt := First_Elmt (In_Items);
27730 while Present (Item_Elmt) loop
27731 Item_Id := Node (Item_Elmt);
27733 -- When full refinement is visible, ensure that at least one of
27734 -- the constituents is utilized and is of mode Input. When only
27735 -- partial refinement is visible, ensure that either one of
27736 -- the constituents is utilized and is of mode Input, or the
27737 -- abstract state is repeated and no constituent is utilized.
27739 if Ekind (Item_Id) = E_Abstract_State
27740 and then Has_Non_Null_Visible_Refinement (Item_Id)
27742 Check_Constituent_Usage (Item_Id);
27745 Next_Elmt (Item_Elmt);
27748 end Check_Input_States;
27750 -------------------------
27751 -- Check_Output_States --
27752 -------------------------
27754 procedure Check_Output_States is
27755 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27756 -- Determine whether all constituents of state State_Id with full
27757 -- visible refinement are used and have mode Output. Emit an error
27758 -- if this is not the case (SPARK RM 7.2.4(5)).
27760 -----------------------------
27761 -- Check_Constituent_Usage --
27762 -----------------------------
27764 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27765 Constits : constant Elist_Id :=
27766 Partial_Refinement_Constituents (State_Id);
27767 Only_Partial : constant Boolean :=
27768 not Has_Visible_Refinement (State_Id);
27769 Constit_Elmt : Elmt_Id;
27770 Constit_Id : Entity_Id;
27771 Posted : Boolean := False;
27774 if Present (Constits) then
27775 Constit_Elmt := First_Elmt (Constits);
27776 while Present (Constit_Elmt) loop
27777 Constit_Id := Node (Constit_Elmt);
27779 -- Issue an error when a constituent of State_Id is utilized
27780 -- and State_Id has only partial visible refinement
27781 -- (SPARK RM 7.2.4(3d)).
27783 if Only_Partial then
27784 if Present_Then_Remove (Out_Constits, Constit_Id)
27785 or else Present_Then_Remove (In_Constits, Constit_Id)
27787 Present_Then_Remove (In_Out_Constits, Constit_Id)
27789 Present_Then_Remove (Proof_In_Constits, Constit_Id)
27791 Error_Msg_Name_1 := Chars (State_Id);
27793 ("constituent & of state % cannot be used in global "
27794 & "refinement", N, Constit_Id);
27795 Error_Msg_Name_1 := Chars (State_Id);
27796 SPARK_Msg_N ("\use state % instead", N);
27799 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
27802 -- The constituent appears in the global refinement, but has
27803 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
27805 elsif Present_Then_Remove (In_Constits, Constit_Id)
27806 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
27807 or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
27809 Error_Msg_Name_1 := Chars (State_Id);
27811 ("constituent & of state % must have mode `Output` in "
27812 & "global refinement", N, Constit_Id);
27814 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
27820 ("`Output` state & must be replaced by all its "
27821 & "constituents in global refinement", N, State_Id);
27825 ("\constituent & is missing in output list",
27829 Next_Elmt (Constit_Elmt);
27832 end Check_Constituent_Usage;
27836 Item_Elmt : Elmt_Id;
27837 Item_Id : Entity_Id;
27839 -- Start of processing for Check_Output_States
27842 -- Do not perform this check in an instance because it was already
27843 -- performed successfully in the generic template.
27845 if In_Instance then
27848 -- Inspect the Output items of the corresponding Global pragma
27849 -- looking for a state with a visible refinement.
27851 elsif Has_Out_State and then Present (Out_Items) then
27852 Item_Elmt := First_Elmt (Out_Items);
27853 while Present (Item_Elmt) loop
27854 Item_Id := Node (Item_Elmt);
27856 -- When full refinement is visible, ensure that all of the
27857 -- constituents are utilized and they have mode Output. When
27858 -- only partial refinement is visible, ensure that no
27859 -- constituent is utilized.
27861 if Ekind (Item_Id) = E_Abstract_State
27862 and then Has_Non_Null_Visible_Refinement (Item_Id)
27864 Check_Constituent_Usage (Item_Id);
27867 Next_Elmt (Item_Elmt);
27870 end Check_Output_States;
27872 ---------------------------
27873 -- Check_Proof_In_States --
27874 ---------------------------
27876 procedure Check_Proof_In_States is
27877 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27878 -- Determine whether at least one constituent of state State_Id with
27879 -- full or partial visible refinement is used and has mode Proof_In.
27880 -- Ensure that the remaining constituents do not have Input, In_Out,
27881 -- or Output modes. Emit an error if this is not the case
27882 -- (SPARK RM 7.2.4(5)).
27884 -----------------------------
27885 -- Check_Constituent_Usage --
27886 -----------------------------
27888 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27889 Constits : constant Elist_Id :=
27890 Partial_Refinement_Constituents (State_Id);
27891 Constit_Elmt : Elmt_Id;
27892 Constit_Id : Entity_Id;
27893 Proof_In_Seen : Boolean := False;
27896 if Present (Constits) then
27897 Constit_Elmt := First_Elmt (Constits);
27898 while Present (Constit_Elmt) loop
27899 Constit_Id := Node (Constit_Elmt);
27901 -- At least one of the constituents appears as Proof_In
27903 if Present_Then_Remove (Proof_In_Constits, Constit_Id) then
27904 Proof_In_Seen := True;
27906 -- The constituent appears in the global refinement, but has
27907 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
27909 elsif Present_Then_Remove (In_Constits, Constit_Id)
27910 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
27911 or else Present_Then_Remove (Out_Constits, Constit_Id)
27913 Error_Msg_Name_1 := Chars (State_Id);
27915 ("constituent & of state % must have mode `Proof_In` "
27916 & "in global refinement", N, Constit_Id);
27919 Next_Elmt (Constit_Elmt);
27923 -- Not one of the constituents appeared as Proof_In. Always emit
27924 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
27925 -- When only partial refinement is visible, emit an error if the
27926 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27927 -- the case where both are utilized, an error will be issued by
27928 -- Check_State_And_Constituent_Use.
27930 if not Proof_In_Seen
27931 and then (Has_Visible_Refinement (State_Id)
27932 or else Contains (Repeat_Items, State_Id))
27935 ("global refinement of state & must include at least one "
27936 & "constituent of mode `Proof_In`", N, State_Id);
27938 end Check_Constituent_Usage;
27942 Item_Elmt : Elmt_Id;
27943 Item_Id : Entity_Id;
27945 -- Start of processing for Check_Proof_In_States
27948 -- Do not perform this check in an instance because it was already
27949 -- performed successfully in the generic template.
27951 if In_Instance then
27954 -- Inspect the Proof_In items of the corresponding Global pragma
27955 -- looking for a state with a visible refinement.
27957 elsif Has_Proof_In_State and then Present (Proof_In_Items) then
27958 Item_Elmt := First_Elmt (Proof_In_Items);
27959 while Present (Item_Elmt) loop
27960 Item_Id := Node (Item_Elmt);
27962 -- Ensure that at least one of the constituents is utilized
27963 -- and is of mode Proof_In. When only partial refinement is
27964 -- visible, ensure that either one of the constituents is
27965 -- utilized and is of mode Proof_In, or the abstract state
27966 -- is repeated and no constituent is utilized.
27968 if Ekind (Item_Id) = E_Abstract_State
27969 and then Has_Non_Null_Visible_Refinement (Item_Id)
27971 Check_Constituent_Usage (Item_Id);
27974 Next_Elmt (Item_Elmt);
27977 end Check_Proof_In_States;
27979 -------------------------------
27980 -- Check_Refined_Global_List --
27981 -------------------------------
27983 procedure Check_Refined_Global_List
27985 Global_Mode : Name_Id := Name_Input)
27987 procedure Check_Refined_Global_Item
27989 Global_Mode : Name_Id);
27990 -- Verify the legality of a single global item declaration. Parameter
27991 -- Global_Mode denotes the current mode in effect.
27993 -------------------------------
27994 -- Check_Refined_Global_Item --
27995 -------------------------------
27997 procedure Check_Refined_Global_Item
27999 Global_Mode : Name_Id)
28001 Item_Id : constant Entity_Id := Entity_Of (Item);
28003 procedure Inconsistent_Mode_Error (Expect : Name_Id);
28004 -- Issue a common error message for all mode mismatches. Expect
28005 -- denotes the expected mode.
28007 -----------------------------
28008 -- Inconsistent_Mode_Error --
28009 -----------------------------
28011 procedure Inconsistent_Mode_Error (Expect : Name_Id) is
28014 ("global item & has inconsistent modes", Item, Item_Id);
28016 Error_Msg_Name_1 := Global_Mode;
28017 Error_Msg_Name_2 := Expect;
28018 SPARK_Msg_N ("\expected mode %, found mode %", Item);
28019 end Inconsistent_Mode_Error;
28023 Enc_State : Entity_Id := Empty;
28024 -- Encapsulating state for constituent, Empty otherwise
28026 -- Start of processing for Check_Refined_Global_Item
28029 if Ekind_In (Item_Id, E_Abstract_State,
28033 Enc_State := Find_Encapsulating_State (States, Item_Id);
28036 -- When the state or object acts as a constituent of another
28037 -- state with a visible refinement, collect it for the state
28038 -- completeness checks performed later on. Note that the item
28039 -- acts as a constituent only when the encapsulating state is
28040 -- present in pragma Global.
28042 if Present (Enc_State)
28043 and then (Has_Visible_Refinement (Enc_State)
28044 or else Has_Partial_Visible_Refinement (Enc_State))
28045 and then Contains (States, Enc_State)
28047 -- If the state has only partial visible refinement, remove it
28048 -- from the list of items that should be repeated from pragma
28051 if not Has_Visible_Refinement (Enc_State) then
28052 Present_Then_Remove (Repeat_Items, Enc_State);
28055 if Global_Mode = Name_Input then
28056 Append_New_Elmt (Item_Id, In_Constits);
28058 elsif Global_Mode = Name_In_Out then
28059 Append_New_Elmt (Item_Id, In_Out_Constits);
28061 elsif Global_Mode = Name_Output then
28062 Append_New_Elmt (Item_Id, Out_Constits);
28064 elsif Global_Mode = Name_Proof_In then
28065 Append_New_Elmt (Item_Id, Proof_In_Constits);
28068 -- When not a constituent, ensure that both occurrences of the
28069 -- item in pragmas Global and Refined_Global match. Also remove
28070 -- it when present from the list of items that should be repeated
28071 -- from pragma Global.
28074 Present_Then_Remove (Repeat_Items, Item_Id);
28076 if Contains (In_Items, Item_Id) then
28077 if Global_Mode /= Name_Input then
28078 Inconsistent_Mode_Error (Name_Input);
28081 elsif Contains (In_Out_Items, Item_Id) then
28082 if Global_Mode /= Name_In_Out then
28083 Inconsistent_Mode_Error (Name_In_Out);
28086 elsif Contains (Out_Items, Item_Id) then
28087 if Global_Mode /= Name_Output then
28088 Inconsistent_Mode_Error (Name_Output);
28091 elsif Contains (Proof_In_Items, Item_Id) then
28094 -- The item does not appear in the corresponding Global pragma,
28095 -- it must be an extra (SPARK RM 7.2.4(3)).
28098 pragma Assert (Present (Global));
28099 Error_Msg_Sloc := Sloc (Global);
28101 ("extra global item & does not refine or repeat any "
28102 & "global item #", Item, Item_Id);
28105 end Check_Refined_Global_Item;
28111 -- Start of processing for Check_Refined_Global_List
28114 -- Do not perform this check in an instance because it was already
28115 -- performed successfully in the generic template.
28117 if In_Instance then
28120 elsif Nkind (List) = N_Null then
28123 -- Single global item declaration
28125 elsif Nkind_In (List, N_Expanded_Name,
28127 N_Selected_Component)
28129 Check_Refined_Global_Item (List, Global_Mode);
28131 -- Simple global list or moded global list declaration
28133 elsif Nkind (List) = N_Aggregate then
28135 -- The declaration of a simple global list appear as a collection
28138 if Present (Expressions (List)) then
28139 Item := First (Expressions (List));
28140 while Present (Item) loop
28141 Check_Refined_Global_Item (Item, Global_Mode);
28145 -- The declaration of a moded global list appears as a collection
28146 -- of component associations where individual choices denote
28149 elsif Present (Component_Associations (List)) then
28150 Item := First (Component_Associations (List));
28151 while Present (Item) loop
28152 Check_Refined_Global_List
28153 (List => Expression (Item),
28154 Global_Mode => Chars (First (Choices (Item))));
28162 raise Program_Error;
28168 raise Program_Error;
28170 end Check_Refined_Global_List;
28172 --------------------------
28173 -- Collect_Global_Items --
28174 --------------------------
28176 procedure Collect_Global_Items
28178 Mode : Name_Id := Name_Input)
28180 procedure Collect_Global_Item
28182 Item_Mode : Name_Id);
28183 -- Add a single item to the appropriate list. Item_Mode denotes the
28184 -- current mode in effect.
28186 -------------------------
28187 -- Collect_Global_Item --
28188 -------------------------
28190 procedure Collect_Global_Item
28192 Item_Mode : Name_Id)
28194 Item_Id : constant Entity_Id := Available_View (Entity_Of (Item));
28195 -- The above handles abstract views of variables and states built
28196 -- for limited with clauses.
28199 -- Signal that the global list contains at least one abstract
28200 -- state with a visible refinement. Note that the refinement may
28201 -- be null in which case there are no constituents.
28203 if Ekind (Item_Id) = E_Abstract_State then
28204 if Has_Null_Visible_Refinement (Item_Id) then
28205 Has_Null_State := True;
28207 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
28208 Append_New_Elmt (Item_Id, States);
28210 if Item_Mode = Name_Input then
28211 Has_In_State := True;
28212 elsif Item_Mode = Name_In_Out then
28213 Has_In_Out_State := True;
28214 elsif Item_Mode = Name_Output then
28215 Has_Out_State := True;
28216 elsif Item_Mode = Name_Proof_In then
28217 Has_Proof_In_State := True;
28222 -- Record global items without full visible refinement found in
28223 -- pragma Global which should be repeated in the global refinement
28224 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
28226 if Ekind (Item_Id) /= E_Abstract_State
28227 or else not Has_Visible_Refinement (Item_Id)
28229 Append_New_Elmt (Item_Id, Repeat_Items);
28232 -- Add the item to the proper list
28234 if Item_Mode = Name_Input then
28235 Append_New_Elmt (Item_Id, In_Items);
28236 elsif Item_Mode = Name_In_Out then
28237 Append_New_Elmt (Item_Id, In_Out_Items);
28238 elsif Item_Mode = Name_Output then
28239 Append_New_Elmt (Item_Id, Out_Items);
28240 elsif Item_Mode = Name_Proof_In then
28241 Append_New_Elmt (Item_Id, Proof_In_Items);
28243 end Collect_Global_Item;
28249 -- Start of processing for Collect_Global_Items
28252 if Nkind (List) = N_Null then
28255 -- Single global item declaration
28257 elsif Nkind_In (List, N_Expanded_Name,
28259 N_Selected_Component)
28261 Collect_Global_Item (List, Mode);
28263 -- Single global list or moded global list declaration
28265 elsif Nkind (List) = N_Aggregate then
28267 -- The declaration of a simple global list appear as a collection
28270 if Present (Expressions (List)) then
28271 Item := First (Expressions (List));
28272 while Present (Item) loop
28273 Collect_Global_Item (Item, Mode);
28277 -- The declaration of a moded global list appears as a collection
28278 -- of component associations where individual choices denote mode.
28280 elsif Present (Component_Associations (List)) then
28281 Item := First (Component_Associations (List));
28282 while Present (Item) loop
28283 Collect_Global_Items
28284 (List => Expression (Item),
28285 Mode => Chars (First (Choices (Item))));
28293 raise Program_Error;
28296 -- To accommodate partial decoration of disabled SPARK features, this
28297 -- routine may be called with illegal input. If this is the case, do
28298 -- not raise Program_Error.
28303 end Collect_Global_Items;
28305 -------------------------
28306 -- Present_Then_Remove --
28307 -------------------------
28309 function Present_Then_Remove
28311 Item : Entity_Id) return Boolean
28316 if Present (List) then
28317 Elmt := First_Elmt (List);
28318 while Present (Elmt) loop
28319 if Node (Elmt) = Item then
28320 Remove_Elmt (List, Elmt);
28329 end Present_Then_Remove;
28331 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id) is
28334 Ignore := Present_Then_Remove (List, Item);
28335 end Present_Then_Remove;
28337 -------------------------------
28338 -- Report_Extra_Constituents --
28339 -------------------------------
28341 procedure Report_Extra_Constituents is
28342 procedure Report_Extra_Constituents_In_List (List : Elist_Id);
28343 -- Emit an error for every element of List
28345 ---------------------------------------
28346 -- Report_Extra_Constituents_In_List --
28347 ---------------------------------------
28349 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is
28350 Constit_Elmt : Elmt_Id;
28353 if Present (List) then
28354 Constit_Elmt := First_Elmt (List);
28355 while Present (Constit_Elmt) loop
28356 SPARK_Msg_NE ("extra constituent &", N, Node (Constit_Elmt));
28357 Next_Elmt (Constit_Elmt);
28360 end Report_Extra_Constituents_In_List;
28362 -- Start of processing for Report_Extra_Constituents
28365 -- Do not perform this check in an instance because it was already
28366 -- performed successfully in the generic template.
28368 if In_Instance then
28372 Report_Extra_Constituents_In_List (In_Constits);
28373 Report_Extra_Constituents_In_List (In_Out_Constits);
28374 Report_Extra_Constituents_In_List (Out_Constits);
28375 Report_Extra_Constituents_In_List (Proof_In_Constits);
28377 end Report_Extra_Constituents;
28379 --------------------------
28380 -- Report_Missing_Items --
28381 --------------------------
28383 procedure Report_Missing_Items is
28384 Item_Elmt : Elmt_Id;
28385 Item_Id : Entity_Id;
28388 -- Do not perform this check in an instance because it was already
28389 -- performed successfully in the generic template.
28391 if In_Instance then
28395 if Present (Repeat_Items) then
28396 Item_Elmt := First_Elmt (Repeat_Items);
28397 while Present (Item_Elmt) loop
28398 Item_Id := Node (Item_Elmt);
28399 SPARK_Msg_NE ("missing global item &", N, Item_Id);
28400 Next_Elmt (Item_Elmt);
28404 end Report_Missing_Items;
28408 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
28409 Errors : constant Nat := Serious_Errors_Detected;
28411 No_Constit : Boolean;
28413 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
28416 -- Do not analyze the pragma multiple times
28418 if Is_Analyzed_Pragma (N) then
28422 Spec_Id := Unique_Defining_Entity (Body_Decl);
28424 -- Use the anonymous object as the proper spec when Refined_Global
28425 -- applies to the body of a single task type. The object carries the
28426 -- proper Chars as well as all non-refined versions of pragmas.
28428 if Is_Single_Concurrent_Type (Spec_Id) then
28429 Spec_Id := Anonymous_Object (Spec_Id);
28432 Global := Get_Pragma (Spec_Id, Pragma_Global);
28433 Items := Expression (Get_Argument (N, Spec_Id));
28435 -- The subprogram declaration lacks pragma Global. This renders
28436 -- Refined_Global useless as there is nothing to refine.
28438 if No (Global) then
28440 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
28441 & "& lacks aspect or pragma Global"), N, Spec_Id);
28445 -- Extract all relevant items from the corresponding Global pragma
28447 Collect_Global_Items (Expression (Get_Argument (Global, Spec_Id)));
28449 -- Package and subprogram bodies are instantiated individually in
28450 -- a separate compiler pass. Due to this mode of instantiation, the
28451 -- refinement of a state may no longer be visible when a subprogram
28452 -- body contract is instantiated. Since the generic template is legal,
28453 -- do not perform this check in the instance to circumvent this oddity.
28455 if In_Instance then
28458 -- Non-instance case
28461 -- The corresponding Global pragma must mention at least one
28462 -- state with a visible refinement at the point Refined_Global
28463 -- is processed. States with null refinements need Refined_Global
28464 -- pragma (SPARK RM 7.2.4(2)).
28466 if not Has_In_State
28467 and then not Has_In_Out_State
28468 and then not Has_Out_State
28469 and then not Has_Proof_In_State
28470 and then not Has_Null_State
28473 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
28474 & "depend on abstract state with visible refinement"),
28478 -- The global refinement of inputs and outputs cannot be null when
28479 -- the corresponding Global pragma contains at least one item except
28480 -- in the case where we have states with null refinements.
28482 elsif Nkind (Items) = N_Null
28484 (Present (In_Items)
28485 or else Present (In_Out_Items)
28486 or else Present (Out_Items)
28487 or else Present (Proof_In_Items))
28488 and then not Has_Null_State
28491 (Fix_Msg (Spec_Id, "refinement cannot be null, subprogram & has "
28492 & "global items"), N, Spec_Id);
28497 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
28498 -- This ensures that the categorization of all refined global items is
28499 -- consistent with their role.
28501 Analyze_Global_In_Decl_Part (N);
28503 -- Perform all refinement checks with respect to completeness and mode
28506 if Serious_Errors_Detected = Errors then
28507 Check_Refined_Global_List (Items);
28510 -- Store the information that no constituent is used in the global
28511 -- refinement, prior to calling checking procedures which remove items
28512 -- from the list of constituents.
28516 and then No (In_Out_Constits)
28517 and then No (Out_Constits)
28518 and then No (Proof_In_Constits);
28520 -- For Input states with visible refinement, at least one constituent
28521 -- must be used as an Input in the global refinement.
28523 if Serious_Errors_Detected = Errors then
28524 Check_Input_States;
28527 -- Verify all possible completion variants for In_Out states with
28528 -- visible refinement.
28530 if Serious_Errors_Detected = Errors then
28531 Check_In_Out_States;
28534 -- For Output states with visible refinement, all constituents must be
28535 -- used as Outputs in the global refinement.
28537 if Serious_Errors_Detected = Errors then
28538 Check_Output_States;
28541 -- For Proof_In states with visible refinement, at least one constituent
28542 -- must be used as Proof_In in the global refinement.
28544 if Serious_Errors_Detected = Errors then
28545 Check_Proof_In_States;
28548 -- Emit errors for all constituents that belong to other states with
28549 -- visible refinement that do not appear in Global.
28551 if Serious_Errors_Detected = Errors then
28552 Report_Extra_Constituents;
28555 -- Emit errors for all items in Global that are not repeated in the
28556 -- global refinement and for which there is no full visible refinement
28557 -- and, in the case of states with partial visible refinement, no
28558 -- constituent is mentioned in the global refinement.
28560 if Serious_Errors_Detected = Errors then
28561 Report_Missing_Items;
28564 -- Emit an error if no constituent is used in the global refinement
28565 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
28566 -- one may be issued by the checking procedures. Do not perform this
28567 -- check in an instance because it was already performed successfully
28568 -- in the generic template.
28570 if Serious_Errors_Detected = Errors
28571 and then not In_Instance
28572 and then not Has_Null_State
28573 and then No_Constit
28575 SPARK_Msg_N ("missing refinement", N);
28579 Set_Is_Analyzed_Pragma (N);
28580 end Analyze_Refined_Global_In_Decl_Part;
28582 ----------------------------------------
28583 -- Analyze_Refined_State_In_Decl_Part --
28584 ----------------------------------------
28586 procedure Analyze_Refined_State_In_Decl_Part
28588 Freeze_Id : Entity_Id := Empty)
28590 Body_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
28591 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
28592 Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl);
28594 Available_States : Elist_Id := No_Elist;
28595 -- A list of all abstract states defined in the package declaration that
28596 -- are available for refinement. The list is used to report unrefined
28599 Body_States : Elist_Id := No_Elist;
28600 -- A list of all hidden states that appear in the body of the related
28601 -- package. The list is used to report unused hidden states.
28603 Constituents_Seen : Elist_Id := No_Elist;
28604 -- A list that contains all constituents processed so far. The list is
28605 -- used to detect multiple uses of the same constituent.
28607 Freeze_Posted : Boolean := False;
28608 -- A flag that controls the output of a freezing-related error (see use
28611 Refined_States_Seen : Elist_Id := No_Elist;
28612 -- A list that contains all refined states processed so far. The list is
28613 -- used to detect duplicate refinements.
28615 procedure Analyze_Refinement_Clause (Clause : Node_Id);
28616 -- Perform full analysis of a single refinement clause
28618 procedure Report_Unrefined_States (States : Elist_Id);
28619 -- Emit errors for all unrefined abstract states found in list States
28621 -------------------------------
28622 -- Analyze_Refinement_Clause --
28623 -------------------------------
28625 procedure Analyze_Refinement_Clause (Clause : Node_Id) is
28626 AR_Constit : Entity_Id := Empty;
28627 AW_Constit : Entity_Id := Empty;
28628 ER_Constit : Entity_Id := Empty;
28629 EW_Constit : Entity_Id := Empty;
28630 -- The entities of external constituents that contain one of the
28631 -- following enabled properties: Async_Readers, Async_Writers,
28632 -- Effective_Reads and Effective_Writes.
28634 External_Constit_Seen : Boolean := False;
28635 -- Flag used to mark when at least one external constituent is part
28636 -- of the state refinement.
28638 Non_Null_Seen : Boolean := False;
28639 Null_Seen : Boolean := False;
28640 -- Flags used to detect multiple uses of null in a single clause or a
28641 -- mixture of null and non-null constituents.
28643 Part_Of_Constits : Elist_Id := No_Elist;
28644 -- A list of all candidate constituents subject to indicator Part_Of
28645 -- where the encapsulating state is the current state.
28648 State_Id : Entity_Id;
28649 -- The current state being refined
28651 procedure Analyze_Constituent (Constit : Node_Id);
28652 -- Perform full analysis of a single constituent
28654 procedure Check_External_Property
28655 (Prop_Nam : Name_Id;
28657 Constit : Entity_Id);
28658 -- Determine whether a property denoted by name Prop_Nam is present
28659 -- in the refined state. Emit an error if this is not the case. Flag
28660 -- Enabled should be set when the property applies to the refined
28661 -- state. Constit denotes the constituent (if any) which introduces
28662 -- the property in the refinement.
28664 procedure Match_State;
28665 -- Determine whether the state being refined appears in list
28666 -- Available_States. Emit an error when attempting to re-refine the
28667 -- state or when the state is not defined in the package declaration,
28668 -- otherwise remove the state from Available_States.
28670 procedure Report_Unused_Constituents (Constits : Elist_Id);
28671 -- Emit errors for all unused Part_Of constituents in list Constits
28673 -------------------------
28674 -- Analyze_Constituent --
28675 -------------------------
28677 procedure Analyze_Constituent (Constit : Node_Id) is
28678 procedure Match_Constituent (Constit_Id : Entity_Id);
28679 -- Determine whether constituent Constit denoted by its entity
28680 -- Constit_Id appears in Body_States. Emit an error when the
28681 -- constituent is not a valid hidden state of the related package
28682 -- or when it is used more than once. Otherwise remove the
28683 -- constituent from Body_States.
28685 -----------------------
28686 -- Match_Constituent --
28687 -----------------------
28689 procedure Match_Constituent (Constit_Id : Entity_Id) is
28690 procedure Collect_Constituent;
28691 -- Verify the legality of constituent Constit_Id and add it to
28692 -- the refinements of State_Id.
28694 -------------------------
28695 -- Collect_Constituent --
28696 -------------------------
28698 procedure Collect_Constituent is
28699 Constits : Elist_Id;
28702 -- The Ghost policy in effect at the point of abstract state
28703 -- declaration and constituent must match (SPARK RM 6.9(15))
28705 Check_Ghost_Refinement
28706 (State, State_Id, Constit, Constit_Id);
28708 -- A synchronized state must be refined by a synchronized
28709 -- object or another synchronized state (SPARK RM 9.6).
28711 if Is_Synchronized_State (State_Id)
28712 and then not Is_Synchronized_Object (Constit_Id)
28713 and then not Is_Synchronized_State (Constit_Id)
28716 ("constituent of synchronized state & must be "
28717 & "synchronized", Constit, State_Id);
28720 -- Add the constituent to the list of processed items to aid
28721 -- with the detection of duplicates.
28723 Append_New_Elmt (Constit_Id, Constituents_Seen);
28725 -- Collect the constituent in the list of refinement items
28726 -- and establish a relation between the refined state and
28729 Constits := Refinement_Constituents (State_Id);
28731 if No (Constits) then
28732 Constits := New_Elmt_List;
28733 Set_Refinement_Constituents (State_Id, Constits);
28736 Append_Elmt (Constit_Id, Constits);
28737 Set_Encapsulating_State (Constit_Id, State_Id);
28739 -- The state has at least one legal constituent, mark the
28740 -- start of the refinement region. The region ends when the
28741 -- body declarations end (see routine Analyze_Declarations).
28743 Set_Has_Visible_Refinement (State_Id);
28745 -- When the constituent is external, save its relevant
28746 -- property for further checks.
28748 if Async_Readers_Enabled (Constit_Id) then
28749 AR_Constit := Constit_Id;
28750 External_Constit_Seen := True;
28753 if Async_Writers_Enabled (Constit_Id) then
28754 AW_Constit := Constit_Id;
28755 External_Constit_Seen := True;
28758 if Effective_Reads_Enabled (Constit_Id) then
28759 ER_Constit := Constit_Id;
28760 External_Constit_Seen := True;
28763 if Effective_Writes_Enabled (Constit_Id) then
28764 EW_Constit := Constit_Id;
28765 External_Constit_Seen := True;
28767 end Collect_Constituent;
28771 State_Elmt : Elmt_Id;
28773 -- Start of processing for Match_Constituent
28776 -- Detect a duplicate use of a constituent
28778 if Contains (Constituents_Seen, Constit_Id) then
28780 ("duplicate use of constituent &", Constit, Constit_Id);
28784 -- The constituent is subject to a Part_Of indicator
28786 if Present (Encapsulating_State (Constit_Id)) then
28787 if Encapsulating_State (Constit_Id) = State_Id then
28788 Remove (Part_Of_Constits, Constit_Id);
28789 Collect_Constituent;
28791 -- The constituent is part of another state and is used
28792 -- incorrectly in the refinement of the current state.
28795 Error_Msg_Name_1 := Chars (State_Id);
28797 ("& cannot act as constituent of state %",
28798 Constit, Constit_Id);
28800 ("\Part_Of indicator specifies encapsulator &",
28801 Constit, Encapsulating_State (Constit_Id));
28804 -- The only other source of legal constituents is the body
28805 -- state space of the related package.
28808 if Present (Body_States) then
28809 State_Elmt := First_Elmt (Body_States);
28810 while Present (State_Elmt) loop
28812 -- Consume a valid constituent to signal that it has
28813 -- been encountered.
28815 if Node (State_Elmt) = Constit_Id then
28816 Remove_Elmt (Body_States, State_Elmt);
28817 Collect_Constituent;
28821 Next_Elmt (State_Elmt);
28825 -- At this point it is known that the constituent is not
28826 -- part of the package hidden state and cannot be used in
28827 -- a refinement (SPARK RM 7.2.2(9)).
28829 Error_Msg_Name_1 := Chars (Spec_Id);
28831 ("cannot use & in refinement, constituent is not a hidden "
28832 & "state of package %", Constit, Constit_Id);
28834 end Match_Constituent;
28838 Constit_Id : Entity_Id;
28839 Constits : Elist_Id;
28841 -- Start of processing for Analyze_Constituent
28844 -- Detect multiple uses of null in a single refinement clause or a
28845 -- mixture of null and non-null constituents.
28847 if Nkind (Constit) = N_Null then
28850 ("multiple null constituents not allowed", Constit);
28852 elsif Non_Null_Seen then
28854 ("cannot mix null and non-null constituents", Constit);
28859 -- Collect the constituent in the list of refinement items
28861 Constits := Refinement_Constituents (State_Id);
28863 if No (Constits) then
28864 Constits := New_Elmt_List;
28865 Set_Refinement_Constituents (State_Id, Constits);
28868 Append_Elmt (Constit, Constits);
28870 -- The state has at least one legal constituent, mark the
28871 -- start of the refinement region. The region ends when the
28872 -- body declarations end (see Analyze_Declarations).
28874 Set_Has_Visible_Refinement (State_Id);
28877 -- Non-null constituents
28880 Non_Null_Seen := True;
28884 ("cannot mix null and non-null constituents", Constit);
28888 Resolve_State (Constit);
28890 -- Ensure that the constituent denotes a valid state or a
28891 -- whole object (SPARK RM 7.2.2(5)).
28893 if Is_Entity_Name (Constit) then
28894 Constit_Id := Entity_Of (Constit);
28896 -- When a constituent is declared after a subprogram body
28897 -- that caused freezing of the related contract where
28898 -- pragma Refined_State resides, the constituent appears
28899 -- undefined and carries Any_Id as its entity.
28901 -- package body Pack
28902 -- with Refined_State => (State => Constit)
28905 -- with Refined_Global => (Input => Constit)
28913 if Constit_Id = Any_Id then
28914 SPARK_Msg_NE ("& is undefined", Constit, Constit_Id);
28916 -- Emit a specialized info message when the contract of
28917 -- the related package body was "frozen" by another body.
28918 -- Note that it is not possible to precisely identify why
28919 -- the constituent is undefined because it is not visible
28920 -- when pragma Refined_State is analyzed. This message is
28921 -- a reasonable approximation.
28923 if Present (Freeze_Id) and then not Freeze_Posted then
28924 Freeze_Posted := True;
28926 Error_Msg_Name_1 := Chars (Body_Id);
28927 Error_Msg_Sloc := Sloc (Freeze_Id);
28929 ("body & declared # freezes the contract of %",
28932 ("\all constituents must be declared before body #",
28935 -- A misplaced constituent is a critical error because
28936 -- pragma Refined_Depends or Refined_Global depends on
28937 -- the proper link between a state and a constituent.
28938 -- Stop the compilation, as this leads to a multitude
28939 -- of misleading cascaded errors.
28941 raise Unrecoverable_Error;
28944 -- The constituent is a valid state or object
28946 elsif Ekind_In (Constit_Id, E_Abstract_State,
28950 Match_Constituent (Constit_Id);
28952 -- The variable may eventually become a constituent of a
28953 -- single protected/task type. Record the reference now
28954 -- and verify its legality when analyzing the contract of
28955 -- the variable (SPARK RM 9.3).
28957 if Ekind (Constit_Id) = E_Variable then
28958 Record_Possible_Part_Of_Reference
28959 (Var_Id => Constit_Id,
28963 -- Otherwise the constituent is illegal
28967 ("constituent & must denote object or state",
28968 Constit, Constit_Id);
28971 -- The constituent is illegal
28974 SPARK_Msg_N ("malformed constituent", Constit);
28977 end Analyze_Constituent;
28979 -----------------------------
28980 -- Check_External_Property --
28981 -----------------------------
28983 procedure Check_External_Property
28984 (Prop_Nam : Name_Id;
28986 Constit : Entity_Id)
28989 -- The property is missing in the declaration of the state, but
28990 -- a constituent is introducing it in the state refinement
28991 -- (SPARK RM 7.2.8(2)).
28993 if not Enabled and then Present (Constit) then
28994 Error_Msg_Name_1 := Prop_Nam;
28995 Error_Msg_Name_2 := Chars (State_Id);
28997 ("constituent & introduces external property % in refinement "
28998 & "of state %", State, Constit);
29000 Error_Msg_Sloc := Sloc (State_Id);
29002 ("\property is missing in abstract state declaration #",
29005 end Check_External_Property;
29011 procedure Match_State is
29012 State_Elmt : Elmt_Id;
29015 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
29017 if Contains (Refined_States_Seen, State_Id) then
29019 ("duplicate refinement of state &", State, State_Id);
29023 -- Inspect the abstract states defined in the package declaration
29024 -- looking for a match.
29026 State_Elmt := First_Elmt (Available_States);
29027 while Present (State_Elmt) loop
29029 -- A valid abstract state is being refined in the body. Add
29030 -- the state to the list of processed refined states to aid
29031 -- with the detection of duplicate refinements. Remove the
29032 -- state from Available_States to signal that it has already
29035 if Node (State_Elmt) = State_Id then
29036 Append_New_Elmt (State_Id, Refined_States_Seen);
29037 Remove_Elmt (Available_States, State_Elmt);
29041 Next_Elmt (State_Elmt);
29044 -- If we get here, we are refining a state that is not defined in
29045 -- the package declaration.
29047 Error_Msg_Name_1 := Chars (Spec_Id);
29049 ("cannot refine state, & is not defined in package %",
29053 --------------------------------
29054 -- Report_Unused_Constituents --
29055 --------------------------------
29057 procedure Report_Unused_Constituents (Constits : Elist_Id) is
29058 Constit_Elmt : Elmt_Id;
29059 Constit_Id : Entity_Id;
29060 Posted : Boolean := False;
29063 if Present (Constits) then
29064 Constit_Elmt := First_Elmt (Constits);
29065 while Present (Constit_Elmt) loop
29066 Constit_Id := Node (Constit_Elmt);
29068 -- Generate an error message of the form:
29070 -- state ... has unused Part_Of constituents
29071 -- abstract state ... defined at ...
29072 -- constant ... defined at ...
29073 -- variable ... defined at ...
29078 ("state & has unused Part_Of constituents",
29082 Error_Msg_Sloc := Sloc (Constit_Id);
29084 if Ekind (Constit_Id) = E_Abstract_State then
29086 ("\abstract state & defined #", State, Constit_Id);
29088 elsif Ekind (Constit_Id) = E_Constant then
29090 ("\constant & defined #", State, Constit_Id);
29093 pragma Assert (Ekind (Constit_Id) = E_Variable);
29094 SPARK_Msg_NE ("\variable & defined #", State, Constit_Id);
29097 Next_Elmt (Constit_Elmt);
29100 end Report_Unused_Constituents;
29102 -- Local declarations
29104 Body_Ref : Node_Id;
29105 Body_Ref_Elmt : Elmt_Id;
29107 Extra_State : Node_Id;
29109 -- Start of processing for Analyze_Refinement_Clause
29112 -- A refinement clause appears as a component association where the
29113 -- sole choice is the state and the expressions are the constituents.
29114 -- This is a syntax error, always report.
29116 if Nkind (Clause) /= N_Component_Association then
29117 Error_Msg_N ("malformed state refinement clause", Clause);
29121 -- Analyze the state name of a refinement clause
29123 State := First (Choices (Clause));
29126 Resolve_State (State);
29128 -- Ensure that the state name denotes a valid abstract state that is
29129 -- defined in the spec of the related package.
29131 if Is_Entity_Name (State) then
29132 State_Id := Entity_Of (State);
29134 -- When the abstract state is undefined, it appears as Any_Id. Do
29135 -- not continue with the analysis of the clause.
29137 if State_Id = Any_Id then
29140 -- Catch any attempts to re-refine a state or refine a state that
29141 -- is not defined in the package declaration.
29143 elsif Ekind (State_Id) = E_Abstract_State then
29147 SPARK_Msg_NE ("& must denote abstract state", State, State_Id);
29151 -- References to a state with visible refinement are illegal.
29152 -- When nested packages are involved, detecting such references is
29153 -- tricky because pragma Refined_State is analyzed later than the
29154 -- offending pragma Depends or Global. References that occur in
29155 -- such nested context are stored in a list. Emit errors for all
29156 -- references found in Body_References (SPARK RM 6.1.4(8)).
29158 if Present (Body_References (State_Id)) then
29159 Body_Ref_Elmt := First_Elmt (Body_References (State_Id));
29160 while Present (Body_Ref_Elmt) loop
29161 Body_Ref := Node (Body_Ref_Elmt);
29163 SPARK_Msg_N ("reference to & not allowed", Body_Ref);
29164 Error_Msg_Sloc := Sloc (State);
29165 SPARK_Msg_N ("\refinement of & is visible#", Body_Ref);
29167 Next_Elmt (Body_Ref_Elmt);
29171 -- The state name is illegal. This is a syntax error, always report.
29174 Error_Msg_N ("malformed state name in refinement clause", State);
29178 -- A refinement clause may only refine one state at a time
29180 Extra_State := Next (State);
29182 if Present (Extra_State) then
29184 ("refinement clause cannot cover multiple states", Extra_State);
29187 -- Replicate the Part_Of constituents of the refined state because
29188 -- the algorithm will consume items.
29190 Part_Of_Constits := New_Copy_Elist (Part_Of_Constituents (State_Id));
29192 -- Analyze all constituents of the refinement. Multiple constituents
29193 -- appear as an aggregate.
29195 Constit := Expression (Clause);
29197 if Nkind (Constit) = N_Aggregate then
29198 if Present (Component_Associations (Constit)) then
29200 ("constituents of refinement clause must appear in "
29201 & "positional form", Constit);
29203 else pragma Assert (Present (Expressions (Constit)));
29204 Constit := First (Expressions (Constit));
29205 while Present (Constit) loop
29206 Analyze_Constituent (Constit);
29211 -- Various forms of a single constituent. Note that these may include
29212 -- malformed constituents.
29215 Analyze_Constituent (Constit);
29218 -- Verify that external constituents do not introduce new external
29219 -- property in the state refinement (SPARK RM 7.2.8(2)).
29221 if Is_External_State (State_Id) then
29222 Check_External_Property
29223 (Prop_Nam => Name_Async_Readers,
29224 Enabled => Async_Readers_Enabled (State_Id),
29225 Constit => AR_Constit);
29227 Check_External_Property
29228 (Prop_Nam => Name_Async_Writers,
29229 Enabled => Async_Writers_Enabled (State_Id),
29230 Constit => AW_Constit);
29232 Check_External_Property
29233 (Prop_Nam => Name_Effective_Reads,
29234 Enabled => Effective_Reads_Enabled (State_Id),
29235 Constit => ER_Constit);
29237 Check_External_Property
29238 (Prop_Nam => Name_Effective_Writes,
29239 Enabled => Effective_Writes_Enabled (State_Id),
29240 Constit => EW_Constit);
29242 -- When a refined state is not external, it should not have external
29243 -- constituents (SPARK RM 7.2.8(1)).
29245 elsif External_Constit_Seen then
29247 ("non-external state & cannot contain external constituents in "
29248 & "refinement", State, State_Id);
29251 -- Ensure that all Part_Of candidate constituents have been mentioned
29252 -- in the refinement clause.
29254 Report_Unused_Constituents (Part_Of_Constits);
29255 end Analyze_Refinement_Clause;
29257 -----------------------------
29258 -- Report_Unrefined_States --
29259 -----------------------------
29261 procedure Report_Unrefined_States (States : Elist_Id) is
29262 State_Elmt : Elmt_Id;
29265 if Present (States) then
29266 State_Elmt := First_Elmt (States);
29267 while Present (State_Elmt) loop
29269 ("abstract state & must be refined", Node (State_Elmt));
29271 Next_Elmt (State_Elmt);
29274 end Report_Unrefined_States;
29276 -- Local declarations
29278 Clauses : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
29281 -- Start of processing for Analyze_Refined_State_In_Decl_Part
29284 -- Do not analyze the pragma multiple times
29286 if Is_Analyzed_Pragma (N) then
29290 -- Save the scenario for examination by the ABE Processing phase
29292 Record_Elaboration_Scenario (N);
29294 -- Replicate the abstract states declared by the package because the
29295 -- matching algorithm will consume states.
29297 Available_States := New_Copy_Elist (Abstract_States (Spec_Id));
29299 -- Gather all abstract states and objects declared in the visible
29300 -- state space of the package body. These items must be utilized as
29301 -- constituents in a state refinement.
29303 Body_States := Collect_Body_States (Body_Id);
29305 -- Multiple non-null state refinements appear as an aggregate
29307 if Nkind (Clauses) = N_Aggregate then
29308 if Present (Expressions (Clauses)) then
29310 ("state refinements must appear as component associations",
29313 else pragma Assert (Present (Component_Associations (Clauses)));
29314 Clause := First (Component_Associations (Clauses));
29315 while Present (Clause) loop
29316 Analyze_Refinement_Clause (Clause);
29321 -- Various forms of a single state refinement. Note that these may
29322 -- include malformed refinements.
29325 Analyze_Refinement_Clause (Clauses);
29328 -- List all abstract states that were left unrefined
29330 Report_Unrefined_States (Available_States);
29332 Set_Is_Analyzed_Pragma (N);
29333 end Analyze_Refined_State_In_Decl_Part;
29335 ------------------------------------
29336 -- Analyze_Test_Case_In_Decl_Part --
29337 ------------------------------------
29339 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id) is
29340 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
29341 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
29343 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id);
29344 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
29345 -- denoted by Arg_Nam.
29347 ------------------------------
29348 -- Preanalyze_Test_Case_Arg --
29349 ------------------------------
29351 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id) is
29355 -- Preanalyze the original aspect argument for ASIS or for a generic
29356 -- subprogram to properly capture global references.
29358 if ASIS_Mode or else Is_Generic_Subprogram (Spec_Id) then
29362 Arg_Nam => Arg_Nam,
29363 From_Aspect => True);
29365 if Present (Arg) then
29366 Preanalyze_Assert_Expression
29367 (Expression (Arg), Standard_Boolean);
29371 Arg := Test_Case_Arg (N, Arg_Nam);
29373 if Present (Arg) then
29374 Preanalyze_Assert_Expression (Expression (Arg), Standard_Boolean);
29376 end Preanalyze_Test_Case_Arg;
29380 Restore_Scope : Boolean := False;
29382 -- Start of processing for Analyze_Test_Case_In_Decl_Part
29385 -- Do not analyze the pragma multiple times
29387 if Is_Analyzed_Pragma (N) then
29391 -- Ensure that the formal parameters are visible when analyzing all
29392 -- clauses. This falls out of the general rule of aspects pertaining
29393 -- to subprogram declarations.
29395 if not In_Open_Scopes (Spec_Id) then
29396 Restore_Scope := True;
29397 Push_Scope (Spec_Id);
29399 if Is_Generic_Subprogram (Spec_Id) then
29400 Install_Generic_Formals (Spec_Id);
29402 Install_Formals (Spec_Id);
29406 Preanalyze_Test_Case_Arg (Name_Requires);
29407 Preanalyze_Test_Case_Arg (Name_Ensures);
29409 if Restore_Scope then
29413 -- Currently it is not possible to inline pre/postconditions on a
29414 -- subprogram subject to pragma Inline_Always.
29416 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
29418 Set_Is_Analyzed_Pragma (N);
29419 end Analyze_Test_Case_In_Decl_Part;
29425 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is
29430 if Present (List) then
29431 Elmt := First_Elmt (List);
29432 while Present (Elmt) loop
29433 if Nkind (Node (Elmt)) = N_Defining_Identifier then
29436 Id := Entity_Of (Node (Elmt));
29439 if Id = Item_Id then
29450 -----------------------------------
29451 -- Build_Pragma_Check_Equivalent --
29452 -----------------------------------
29454 function Build_Pragma_Check_Equivalent
29456 Subp_Id : Entity_Id := Empty;
29457 Inher_Id : Entity_Id := Empty;
29458 Keep_Pragma_Id : Boolean := False) return Node_Id
29460 function Suppress_Reference (N : Node_Id) return Traverse_Result;
29461 -- Detect whether node N references a formal parameter subject to
29462 -- pragma Unreferenced. If this is the case, set Comes_From_Source
29463 -- to False to suppress the generation of a reference when analyzing
29466 ------------------------
29467 -- Suppress_Reference --
29468 ------------------------
29470 function Suppress_Reference (N : Node_Id) return Traverse_Result is
29471 Formal : Entity_Id;
29474 if Is_Entity_Name (N) and then Present (Entity (N)) then
29475 Formal := Entity (N);
29477 -- The formal parameter is subject to pragma Unreferenced. Prevent
29478 -- the generation of references by resetting the Comes_From_Source
29481 if Is_Formal (Formal)
29482 and then Has_Pragma_Unreferenced (Formal)
29484 Set_Comes_From_Source (N, False);
29489 end Suppress_Reference;
29491 procedure Suppress_References is
29492 new Traverse_Proc (Suppress_Reference);
29496 Loc : constant Source_Ptr := Sloc (Prag);
29497 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
29498 Check_Prag : Node_Id;
29502 Needs_Wrapper : Boolean;
29503 pragma Unreferenced (Needs_Wrapper);
29505 -- Start of processing for Build_Pragma_Check_Equivalent
29508 -- When the pre- or postcondition is inherited, map the formals of the
29509 -- inherited subprogram to those of the current subprogram. In addition,
29510 -- map primitive operations of the parent type into the corresponding
29511 -- primitive operations of the descendant.
29513 if Present (Inher_Id) then
29514 pragma Assert (Present (Subp_Id));
29516 Update_Primitives_Mapping (Inher_Id, Subp_Id);
29518 -- Use generic machinery to copy inherited pragma, as if it were an
29519 -- instantiation, resetting source locations appropriately, so that
29520 -- expressions inside the inherited pragma use chained locations.
29521 -- This is used in particular in GNATprove to locate precisely
29522 -- messages on a given inherited pragma.
29524 Set_Copied_Sloc_For_Inherited_Pragma
29525 (Unit_Declaration_Node (Subp_Id), Inher_Id);
29526 Check_Prag := New_Copy_Tree (Source => Prag);
29528 -- Build the inherited class-wide condition
29530 Build_Class_Wide_Expression
29531 (Prag => Check_Prag,
29533 Par_Subp => Inher_Id,
29534 Adjust_Sloc => True,
29535 Needs_Wrapper => Needs_Wrapper);
29537 -- If not an inherited condition simply copy the original pragma
29540 Check_Prag := New_Copy_Tree (Source => Prag);
29543 -- Mark the pragma as being internally generated and reset the Analyzed
29546 Set_Analyzed (Check_Prag, False);
29547 Set_Comes_From_Source (Check_Prag, False);
29549 -- The tree of the original pragma may contain references to the
29550 -- formal parameters of the related subprogram. At the same time
29551 -- the corresponding body may mark the formals as unreferenced:
29553 -- procedure Proc (Formal : ...)
29554 -- with Pre => Formal ...;
29556 -- procedure Proc (Formal : ...) is
29557 -- pragma Unreferenced (Formal);
29560 -- This creates problems because all pragma Check equivalents are
29561 -- analyzed at the end of the body declarations. Since all source
29562 -- references have already been accounted for, reset any references
29563 -- to such formals in the generated pragma Check equivalent.
29565 Suppress_References (Check_Prag);
29567 if Present (Corresponding_Aspect (Prag)) then
29568 Nam := Chars (Identifier (Corresponding_Aspect (Prag)));
29573 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
29574 -- the copied pragma in the newly created pragma, convert the copy into
29575 -- pragma Check by correcting the name and adding a check_kind argument.
29577 if not Keep_Pragma_Id then
29578 Set_Class_Present (Check_Prag, False);
29580 Set_Pragma_Identifier
29581 (Check_Prag, Make_Identifier (Loc, Name_Check));
29583 Prepend_To (Pragma_Argument_Associations (Check_Prag),
29584 Make_Pragma_Argument_Association (Loc,
29585 Expression => Make_Identifier (Loc, Nam)));
29588 -- Update the error message when the pragma is inherited
29590 if Present (Inher_Id) then
29591 Msg_Arg := Last (Pragma_Argument_Associations (Check_Prag));
29593 if Chars (Msg_Arg) = Name_Message then
29594 String_To_Name_Buffer (Strval (Expression (Msg_Arg)));
29596 -- Insert "inherited" to improve the error message
29598 if Name_Buffer (1 .. 8) = "failed p" then
29599 Insert_Str_In_Name_Buffer ("inherited ", 8);
29600 Set_Strval (Expression (Msg_Arg), String_From_Name_Buffer);
29606 end Build_Pragma_Check_Equivalent;
29608 -----------------------------
29609 -- Check_Applicable_Policy --
29610 -----------------------------
29612 procedure Check_Applicable_Policy (N : Node_Id) is
29616 Ename : constant Name_Id := Original_Aspect_Pragma_Name (N);
29619 -- No effect if not valid assertion kind name
29621 if not Is_Valid_Assertion_Kind (Ename) then
29625 -- Loop through entries in check policy list
29627 PP := Opt.Check_Policy_List;
29628 while Present (PP) loop
29630 PPA : constant List_Id := Pragma_Argument_Associations (PP);
29631 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
29635 or else Pnm = Name_Assertion
29636 or else (Pnm = Name_Statement_Assertions
29637 and then Nam_In (Ename, Name_Assert,
29638 Name_Assert_And_Cut,
29640 Name_Loop_Invariant,
29641 Name_Loop_Variant))
29643 Policy := Chars (Get_Pragma_Arg (Last (PPA)));
29649 -- In CodePeer mode and GNATprove mode, we need to
29650 -- consider all assertions, unless they are disabled.
29651 -- Force Is_Checked on ignored assertions, in particular
29652 -- because transformations of the AST may depend on
29653 -- assertions being checked (e.g. the translation of
29654 -- attribute 'Loop_Entry).
29656 if CodePeer_Mode or GNATprove_Mode then
29657 Set_Is_Checked (N, True);
29658 Set_Is_Ignored (N, False);
29660 Set_Is_Checked (N, False);
29661 Set_Is_Ignored (N, True);
29667 Set_Is_Checked (N, True);
29668 Set_Is_Ignored (N, False);
29670 when Name_Disable =>
29671 Set_Is_Ignored (N, True);
29672 Set_Is_Checked (N, False);
29673 Set_Is_Disabled (N, True);
29675 -- That should be exhaustive, the null here is a defence
29676 -- against a malformed tree from previous errors.
29685 PP := Next_Pragma (PP);
29689 -- If there are no specific entries that matched, then we let the
29690 -- setting of assertions govern. Note that this provides the needed
29691 -- compatibility with the RM for the cases of assertion, invariant,
29692 -- precondition, predicate, and postcondition. Note also that
29693 -- Assertions_Enabled is forced in CodePeer mode and GNATprove mode.
29695 if Assertions_Enabled then
29696 Set_Is_Checked (N, True);
29697 Set_Is_Ignored (N, False);
29699 Set_Is_Checked (N, False);
29700 Set_Is_Ignored (N, True);
29702 end Check_Applicable_Policy;
29704 -------------------------------
29705 -- Check_External_Properties --
29706 -------------------------------
29708 procedure Check_External_Properties
29716 -- All properties enabled
29718 if AR and AW and ER and EW then
29721 -- Async_Readers + Effective_Writes
29722 -- Async_Readers + Async_Writers + Effective_Writes
29724 elsif AR and EW and not ER then
29727 -- Async_Writers + Effective_Reads
29728 -- Async_Readers + Async_Writers + Effective_Reads
29730 elsif AW and ER and not EW then
29733 -- Async_Readers + Async_Writers
29735 elsif AR and AW and not ER and not EW then
29740 elsif AR and not AW and not ER and not EW then
29745 elsif AW and not AR and not ER and not EW then
29750 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
29753 end Check_External_Properties;
29759 function Check_Kind (Nam : Name_Id) return Name_Id is
29763 -- Loop through entries in check policy list
29765 PP := Opt.Check_Policy_List;
29766 while Present (PP) loop
29768 PPA : constant List_Id := Pragma_Argument_Associations (PP);
29769 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
29773 or else (Pnm = Name_Assertion
29774 and then Is_Valid_Assertion_Kind (Nam))
29775 or else (Pnm = Name_Statement_Assertions
29776 and then Nam_In (Nam, Name_Assert,
29777 Name_Assert_And_Cut,
29779 Name_Loop_Invariant,
29780 Name_Loop_Variant))
29782 case (Chars (Get_Pragma_Arg (Last (PPA)))) is
29791 return Name_Ignore;
29793 when Name_Disable =>
29794 return Name_Disable;
29797 raise Program_Error;
29801 PP := Next_Pragma (PP);
29806 -- If there are no specific entries that matched, then we let the
29807 -- setting of assertions govern. Note that this provides the needed
29808 -- compatibility with the RM for the cases of assertion, invariant,
29809 -- precondition, predicate, and postcondition.
29811 if Assertions_Enabled then
29814 return Name_Ignore;
29818 ---------------------------
29819 -- Check_Missing_Part_Of --
29820 ---------------------------
29822 procedure Check_Missing_Part_Of (Item_Id : Entity_Id) is
29823 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean;
29824 -- Determine whether a package denoted by Pack_Id declares at least one
29827 -----------------------
29828 -- Has_Visible_State --
29829 -----------------------
29831 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean is
29832 Item_Id : Entity_Id;
29835 -- Traverse the entity chain of the package trying to find at least
29836 -- one visible abstract state, variable or a package [instantiation]
29837 -- that declares a visible state.
29839 Item_Id := First_Entity (Pack_Id);
29840 while Present (Item_Id)
29841 and then not In_Private_Part (Item_Id)
29843 -- Do not consider internally generated items
29845 if not Comes_From_Source (Item_Id) then
29848 -- Do not consider generic formals or their corresponding actuals
29849 -- because they are not part of a visible state. Note that both
29850 -- entities are marked as hidden.
29852 elsif Is_Hidden (Item_Id) then
29855 -- A visible state has been found. Note that constants are not
29856 -- considered here because it is not possible to determine whether
29857 -- they depend on variable input. This check is left to the SPARK
29860 elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
29863 -- Recursively peek into nested packages and instantiations
29865 elsif Ekind (Item_Id) = E_Package
29866 and then Has_Visible_State (Item_Id)
29871 Next_Entity (Item_Id);
29875 end Has_Visible_State;
29879 Pack_Id : Entity_Id;
29880 Placement : State_Space_Kind;
29882 -- Start of processing for Check_Missing_Part_Of
29885 -- Do not consider abstract states, variables or package instantiations
29886 -- coming from an instance as those always inherit the Part_Of indicator
29887 -- of the instance itself.
29889 if In_Instance then
29892 -- Do not consider internally generated entities as these can never
29893 -- have a Part_Of indicator.
29895 elsif not Comes_From_Source (Item_Id) then
29898 -- Perform these checks only when SPARK_Mode is enabled as they will
29899 -- interfere with standard Ada rules and produce false positives.
29901 elsif SPARK_Mode /= On then
29904 -- Do not consider constants, because the compiler cannot accurately
29905 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
29906 -- act as a hidden state of a package.
29908 elsif Ekind (Item_Id) = E_Constant then
29912 -- Find where the abstract state, variable or package instantiation
29913 -- lives with respect to the state space.
29915 Find_Placement_In_State_Space
29916 (Item_Id => Item_Id,
29917 Placement => Placement,
29918 Pack_Id => Pack_Id);
29920 -- Items that appear in a non-package construct (subprogram, block, etc)
29921 -- do not require a Part_Of indicator because they can never act as a
29924 if Placement = Not_In_Package then
29927 -- An item declared in the body state space of a package always act as a
29928 -- constituent and does not need explicit Part_Of indicator.
29930 elsif Placement = Body_State_Space then
29933 -- In general an item declared in the visible state space of a package
29934 -- does not require a Part_Of indicator. The only exception is when the
29935 -- related package is a nongeneric private child unit, in which case
29936 -- Part_Of must denote a state in the parent unit or in one of its
29939 elsif Placement = Visible_State_Space then
29940 if Is_Child_Unit (Pack_Id)
29941 and then not Is_Generic_Unit (Pack_Id)
29942 and then Is_Private_Descendant (Pack_Id)
29944 -- A package instantiation does not need a Part_Of indicator when
29945 -- the related generic template has no visible state.
29947 if Ekind (Item_Id) = E_Package
29948 and then Is_Generic_Instance (Item_Id)
29949 and then not Has_Visible_State (Item_Id)
29953 -- All other cases require Part_Of
29957 ("indicator Part_Of is required in this context "
29958 & "(SPARK RM 7.2.6(3))", Item_Id);
29959 Error_Msg_Name_1 := Chars (Pack_Id);
29961 ("\& is declared in the visible part of private child "
29962 & "unit %", Item_Id);
29966 -- When the item appears in the private state space of a package, it
29967 -- must be a part of some state declared by the said package.
29969 else pragma Assert (Placement = Private_State_Space);
29971 -- The related package does not declare a state, the item cannot act
29972 -- as a Part_Of constituent.
29974 if No (Get_Pragma (Pack_Id, Pragma_Abstract_State)) then
29977 -- A package instantiation does not need a Part_Of indicator when the
29978 -- related generic template has no visible state.
29980 elsif Ekind (Item_Id) = E_Package
29981 and then Is_Generic_Instance (Item_Id)
29982 and then not Has_Visible_State (Item_Id)
29986 -- All other cases require Part_Of
29990 ("indicator Part_Of is required in this context "
29991 & "(SPARK RM 7.2.6(2))", Item_Id);
29992 Error_Msg_Name_1 := Chars (Pack_Id);
29994 ("\& is declared in the private part of package %", Item_Id);
29997 end Check_Missing_Part_Of;
29999 ---------------------------------------------------
30000 -- Check_Postcondition_Use_In_Inlined_Subprogram --
30001 ---------------------------------------------------
30003 procedure Check_Postcondition_Use_In_Inlined_Subprogram
30005 Spec_Id : Entity_Id)
30008 if Warn_On_Redundant_Constructs
30009 and then Has_Pragma_Inline_Always (Spec_Id)
30010 and then Assertions_Enabled
30012 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
30014 if From_Aspect_Specification (Prag) then
30016 ("aspect % not enforced on inlined subprogram &?r?",
30017 Corresponding_Aspect (Prag), Spec_Id);
30020 ("pragma % not enforced on inlined subprogram &?r?",
30024 end Check_Postcondition_Use_In_Inlined_Subprogram;
30026 -------------------------------------
30027 -- Check_State_And_Constituent_Use --
30028 -------------------------------------
30030 procedure Check_State_And_Constituent_Use
30031 (States : Elist_Id;
30032 Constits : Elist_Id;
30035 Constit_Elmt : Elmt_Id;
30036 Constit_Id : Entity_Id;
30037 State_Id : Entity_Id;
30040 -- Nothing to do if there are no states or constituents
30042 if No (States) or else No (Constits) then
30046 -- Inspect the list of constituents and try to determine whether its
30047 -- encapsulating state is in list States.
30049 Constit_Elmt := First_Elmt (Constits);
30050 while Present (Constit_Elmt) loop
30051 Constit_Id := Node (Constit_Elmt);
30053 -- Determine whether the constituent is part of an encapsulating
30054 -- state that appears in the same context and if this is the case,
30055 -- emit an error (SPARK RM 7.2.6(7)).
30057 State_Id := Find_Encapsulating_State (States, Constit_Id);
30059 if Present (State_Id) then
30060 Error_Msg_Name_1 := Chars (Constit_Id);
30062 ("cannot mention state & and its constituent % in the same "
30063 & "context", Context, State_Id);
30067 Next_Elmt (Constit_Elmt);
30069 end Check_State_And_Constituent_Use;
30071 ---------------------------------------------
30072 -- Collect_Inherited_Class_Wide_Conditions --
30073 ---------------------------------------------
30075 procedure Collect_Inherited_Class_Wide_Conditions (Subp : Entity_Id) is
30076 Parent_Subp : constant Entity_Id :=
30077 Ultimate_Alias (Overridden_Operation (Subp));
30078 -- The Overridden_Operation may itself be inherited and as such have no
30079 -- explicit contract.
30081 Prags : constant Node_Id := Contract (Parent_Subp);
30082 In_Spec_Expr : Boolean;
30083 Installed : Boolean;
30085 New_Prag : Node_Id;
30088 Installed := False;
30090 -- Iterate over the contract of the overridden subprogram to find all
30091 -- inherited class-wide pre- and postconditions.
30093 if Present (Prags) then
30094 Prag := Pre_Post_Conditions (Prags);
30096 while Present (Prag) loop
30097 if Nam_In (Pragma_Name_Unmapped (Prag),
30098 Name_Precondition, Name_Postcondition)
30099 and then Class_Present (Prag)
30101 -- The generated pragma must be analyzed in the context of
30102 -- the subprogram, to make its formals visible. In addition,
30103 -- we must inhibit freezing and full analysis because the
30104 -- controlling type of the subprogram is not frozen yet, and
30105 -- may have further primitives.
30107 if not Installed then
30110 Install_Formals (Subp);
30111 In_Spec_Expr := In_Spec_Expression;
30112 In_Spec_Expression := True;
30116 Build_Pragma_Check_Equivalent
30117 (Prag, Subp, Parent_Subp, Keep_Pragma_Id => True);
30119 Insert_After (Unit_Declaration_Node (Subp), New_Prag);
30120 Preanalyze (New_Prag);
30122 -- Prevent further analysis in subsequent processing of the
30123 -- current list of declarations
30125 Set_Analyzed (New_Prag);
30128 Prag := Next_Pragma (Prag);
30132 In_Spec_Expression := In_Spec_Expr;
30136 end Collect_Inherited_Class_Wide_Conditions;
30138 ---------------------------------------
30139 -- Collect_Subprogram_Inputs_Outputs --
30140 ---------------------------------------
30142 procedure Collect_Subprogram_Inputs_Outputs
30143 (Subp_Id : Entity_Id;
30144 Synthesize : Boolean := False;
30145 Subp_Inputs : in out Elist_Id;
30146 Subp_Outputs : in out Elist_Id;
30147 Global_Seen : out Boolean)
30149 procedure Collect_Dependency_Clause (Clause : Node_Id);
30150 -- Collect all relevant items from a dependency clause
30152 procedure Collect_Global_List
30154 Mode : Name_Id := Name_Input);
30155 -- Collect all relevant items from a global list
30157 -------------------------------
30158 -- Collect_Dependency_Clause --
30159 -------------------------------
30161 procedure Collect_Dependency_Clause (Clause : Node_Id) is
30162 procedure Collect_Dependency_Item
30164 Is_Input : Boolean);
30165 -- Add an item to the proper subprogram input or output collection
30167 -----------------------------
30168 -- Collect_Dependency_Item --
30169 -----------------------------
30171 procedure Collect_Dependency_Item
30173 Is_Input : Boolean)
30178 -- Nothing to collect when the item is null
30180 if Nkind (Item) = N_Null then
30183 -- Ditto for attribute 'Result
30185 elsif Is_Attribute_Result (Item) then
30188 -- Multiple items appear as an aggregate
30190 elsif Nkind (Item) = N_Aggregate then
30191 Extra := First (Expressions (Item));
30192 while Present (Extra) loop
30193 Collect_Dependency_Item (Extra, Is_Input);
30197 -- Otherwise this is a solitary item
30201 Append_New_Elmt (Item, Subp_Inputs);
30203 Append_New_Elmt (Item, Subp_Outputs);
30206 end Collect_Dependency_Item;
30208 -- Start of processing for Collect_Dependency_Clause
30211 if Nkind (Clause) = N_Null then
30214 -- A dependency clause appears as component association
30216 elsif Nkind (Clause) = N_Component_Association then
30217 Collect_Dependency_Item
30218 (Item => Expression (Clause),
30221 Collect_Dependency_Item
30222 (Item => First (Choices (Clause)),
30223 Is_Input => False);
30225 -- To accommodate partial decoration of disabled SPARK features, this
30226 -- routine may be called with illegal input. If this is the case, do
30227 -- not raise Program_Error.
30232 end Collect_Dependency_Clause;
30234 -------------------------
30235 -- Collect_Global_List --
30236 -------------------------
30238 procedure Collect_Global_List
30240 Mode : Name_Id := Name_Input)
30242 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id);
30243 -- Add an item to the proper subprogram input or output collection
30245 -------------------------
30246 -- Collect_Global_Item --
30247 -------------------------
30249 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is
30251 if Nam_In (Mode, Name_In_Out, Name_Input) then
30252 Append_New_Elmt (Item, Subp_Inputs);
30255 if Nam_In (Mode, Name_In_Out, Name_Output) then
30256 Append_New_Elmt (Item, Subp_Outputs);
30258 end Collect_Global_Item;
30265 -- Start of processing for Collect_Global_List
30268 if Nkind (List) = N_Null then
30271 -- Single global item declaration
30273 elsif Nkind_In (List, N_Expanded_Name,
30275 N_Selected_Component)
30277 Collect_Global_Item (List, Mode);
30279 -- Simple global list or moded global list declaration
30281 elsif Nkind (List) = N_Aggregate then
30282 if Present (Expressions (List)) then
30283 Item := First (Expressions (List));
30284 while Present (Item) loop
30285 Collect_Global_Item (Item, Mode);
30290 Assoc := First (Component_Associations (List));
30291 while Present (Assoc) loop
30292 Collect_Global_List
30293 (List => Expression (Assoc),
30294 Mode => Chars (First (Choices (Assoc))));
30299 -- To accommodate partial decoration of disabled SPARK features, this
30300 -- routine may be called with illegal input. If this is the case, do
30301 -- not raise Program_Error.
30306 end Collect_Global_List;
30313 Formal : Entity_Id;
30315 Spec_Id : Entity_Id := Empty;
30316 Subp_Decl : Node_Id;
30319 -- Start of processing for Collect_Subprogram_Inputs_Outputs
30322 Global_Seen := False;
30324 -- Process all formal parameters of entries, [generic] subprograms, and
30327 if Ekind_In (Subp_Id, E_Entry,
30330 E_Generic_Function,
30331 E_Generic_Procedure,
30335 Subp_Decl := Unit_Declaration_Node (Subp_Id);
30336 Spec_Id := Unique_Defining_Entity (Subp_Decl);
30338 -- Process all formal parameters
30340 Formal := First_Entity (Spec_Id);
30341 while Present (Formal) loop
30342 if Ekind_In (Formal, E_In_Out_Parameter, E_In_Parameter) then
30343 Append_New_Elmt (Formal, Subp_Inputs);
30346 if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then
30347 Append_New_Elmt (Formal, Subp_Outputs);
30349 -- Out parameters can act as inputs when the related type is
30350 -- tagged, unconstrained array, unconstrained record, or record
30351 -- with unconstrained components.
30353 if Ekind (Formal) = E_Out_Parameter
30354 and then Is_Unconstrained_Or_Tagged_Item (Formal)
30356 Append_New_Elmt (Formal, Subp_Inputs);
30360 Next_Entity (Formal);
30363 -- Otherwise the input denotes a task type, a task body, or the
30364 -- anonymous object created for a single task type.
30366 elsif Ekind_In (Subp_Id, E_Task_Type, E_Task_Body)
30367 or else Is_Single_Task_Object (Subp_Id)
30369 Subp_Decl := Declaration_Node (Subp_Id);
30370 Spec_Id := Unique_Defining_Entity (Subp_Decl);
30373 -- When processing an entry, subprogram or task body, look for pragmas
30374 -- Refined_Depends and Refined_Global as they specify the inputs and
30377 if Is_Entry_Body (Subp_Id)
30378 or else Ekind_In (Subp_Id, E_Subprogram_Body, E_Task_Body)
30380 Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends);
30381 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global);
30383 -- Subprogram declaration or stand-alone body case, look for pragmas
30384 -- Depends and Global
30387 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
30388 Global := Get_Pragma (Spec_Id, Pragma_Global);
30391 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
30392 -- because it provides finer granularity of inputs and outputs.
30394 if Present (Global) then
30395 Global_Seen := True;
30396 Collect_Global_List (Expression (Get_Argument (Global, Spec_Id)));
30398 -- When the related subprogram lacks pragma [Refined_]Global, fall back
30399 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
30400 -- the inputs and outputs from [Refined_]Depends.
30402 elsif Synthesize and then Present (Depends) then
30403 Clauses := Expression (Get_Argument (Depends, Spec_Id));
30405 -- Multiple dependency clauses appear as an aggregate
30407 if Nkind (Clauses) = N_Aggregate then
30408 Clause := First (Component_Associations (Clauses));
30409 while Present (Clause) loop
30410 Collect_Dependency_Clause (Clause);
30414 -- Otherwise this is a single dependency clause
30417 Collect_Dependency_Clause (Clauses);
30421 -- The current instance of a protected type acts as a formal parameter
30422 -- of mode IN for functions and IN OUT for entries and procedures
30423 -- (SPARK RM 6.1.4).
30425 if Ekind (Scope (Spec_Id)) = E_Protected_Type then
30426 Typ := Scope (Spec_Id);
30428 -- Use the anonymous object when the type is single protected
30430 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
30431 Typ := Anonymous_Object (Typ);
30434 Append_New_Elmt (Typ, Subp_Inputs);
30436 if Ekind_In (Spec_Id, E_Entry, E_Entry_Family, E_Procedure) then
30437 Append_New_Elmt (Typ, Subp_Outputs);
30440 -- The current instance of a task type acts as a formal parameter of
30441 -- mode IN OUT (SPARK RM 6.1.4).
30443 elsif Ekind (Spec_Id) = E_Task_Type then
30446 -- Use the anonymous object when the type is single task
30448 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
30449 Typ := Anonymous_Object (Typ);
30452 Append_New_Elmt (Typ, Subp_Inputs);
30453 Append_New_Elmt (Typ, Subp_Outputs);
30455 elsif Is_Single_Task_Object (Spec_Id) then
30456 Append_New_Elmt (Spec_Id, Subp_Inputs);
30457 Append_New_Elmt (Spec_Id, Subp_Outputs);
30459 end Collect_Subprogram_Inputs_Outputs;
30461 ---------------------------
30462 -- Contract_Freeze_Error --
30463 ---------------------------
30465 procedure Contract_Freeze_Error
30466 (Contract_Id : Entity_Id;
30467 Freeze_Id : Entity_Id)
30470 Error_Msg_Name_1 := Chars (Contract_Id);
30471 Error_Msg_Sloc := Sloc (Freeze_Id);
30474 ("body & declared # freezes the contract of%", Contract_Id, Freeze_Id);
30476 ("\all contractual items must be declared before body #", Contract_Id);
30477 end Contract_Freeze_Error;
30479 ---------------------------------
30480 -- Delay_Config_Pragma_Analyze --
30481 ---------------------------------
30483 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
30485 return Nam_In (Pragma_Name_Unmapped (N),
30486 Name_Interrupt_State, Name_Priority_Specific_Dispatching);
30487 end Delay_Config_Pragma_Analyze;
30489 -----------------------
30490 -- Duplication_Error --
30491 -----------------------
30493 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id) is
30494 Prag_From_Asp : constant Boolean := From_Aspect_Specification (Prag);
30495 Prev_From_Asp : constant Boolean := From_Aspect_Specification (Prev);
30498 Error_Msg_Sloc := Sloc (Prev);
30499 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
30501 -- Emit a precise message to distinguish between source pragmas and
30502 -- pragmas generated from aspects. The ordering of the two pragmas is
30506 -- Prag -- duplicate
30508 -- No error is emitted when both pragmas come from aspects because this
30509 -- is already detected by the general aspect analysis mechanism.
30511 if Prag_From_Asp and Prev_From_Asp then
30513 elsif Prag_From_Asp then
30514 Error_Msg_N ("aspect % duplicates pragma declared #", Prag);
30515 elsif Prev_From_Asp then
30516 Error_Msg_N ("pragma % duplicates aspect declared #", Prag);
30518 Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
30520 end Duplication_Error;
30522 ------------------------------
30523 -- Find_Encapsulating_State --
30524 ------------------------------
30526 function Find_Encapsulating_State
30527 (States : Elist_Id;
30528 Constit_Id : Entity_Id) return Entity_Id
30530 State_Id : Entity_Id;
30533 -- Since a constituent may be part of a larger constituent set, climb
30534 -- the encapsulating state chain looking for a state that appears in
30537 State_Id := Encapsulating_State (Constit_Id);
30538 while Present (State_Id) loop
30539 if Contains (States, State_Id) then
30543 State_Id := Encapsulating_State (State_Id);
30547 end Find_Encapsulating_State;
30549 --------------------------
30550 -- Find_Related_Context --
30551 --------------------------
30553 function Find_Related_Context
30555 Do_Checks : Boolean := False) return Node_Id
30560 Stmt := Prev (Prag);
30561 while Present (Stmt) loop
30563 -- Skip prior pragmas, but check for duplicates
30565 if Nkind (Stmt) = N_Pragma then
30567 and then Pragma_Name (Stmt) = Pragma_Name (Prag)
30574 -- Skip internally generated code
30576 elsif not Comes_From_Source (Stmt) then
30578 -- The anonymous object created for a single concurrent type is a
30579 -- suitable context.
30581 if Nkind (Stmt) = N_Object_Declaration
30582 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
30587 -- Return the current source construct
30597 end Find_Related_Context;
30599 --------------------------------------
30600 -- Find_Related_Declaration_Or_Body --
30601 --------------------------------------
30603 function Find_Related_Declaration_Or_Body
30605 Do_Checks : Boolean := False) return Node_Id
30607 Prag_Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
30609 procedure Expression_Function_Error;
30610 -- Emit an error concerning pragma Prag that illegaly applies to an
30611 -- expression function.
30613 -------------------------------
30614 -- Expression_Function_Error --
30615 -------------------------------
30617 procedure Expression_Function_Error is
30619 Error_Msg_Name_1 := Prag_Nam;
30621 -- Emit a precise message to distinguish between source pragmas and
30622 -- pragmas generated from aspects.
30624 if From_Aspect_Specification (Prag) then
30626 ("aspect % cannot apply to a stand alone expression function",
30630 ("pragma % cannot apply to a stand alone expression function",
30633 end Expression_Function_Error;
30637 Context : constant Node_Id := Parent (Prag);
30640 Look_For_Body : constant Boolean :=
30641 Nam_In (Prag_Nam, Name_Refined_Depends,
30642 Name_Refined_Global,
30644 Name_Refined_State);
30645 -- Refinement pragmas must be associated with a subprogram body [stub]
30647 -- Start of processing for Find_Related_Declaration_Or_Body
30650 Stmt := Prev (Prag);
30651 while Present (Stmt) loop
30653 -- Skip prior pragmas, but check for duplicates. Pragmas produced
30654 -- by splitting a complex pre/postcondition are not considered to
30657 if Nkind (Stmt) = N_Pragma then
30659 and then not Split_PPC (Stmt)
30660 and then Original_Aspect_Pragma_Name (Stmt) = Prag_Nam
30667 -- Emit an error when a refinement pragma appears on an expression
30668 -- function without a completion.
30671 and then Look_For_Body
30672 and then Nkind (Stmt) = N_Subprogram_Declaration
30673 and then Nkind (Original_Node (Stmt)) = N_Expression_Function
30674 and then not Has_Completion (Defining_Entity (Stmt))
30676 Expression_Function_Error;
30679 -- The refinement pragma applies to a subprogram body stub
30681 elsif Look_For_Body
30682 and then Nkind (Stmt) = N_Subprogram_Body_Stub
30686 -- Skip internally generated code
30688 elsif not Comes_From_Source (Stmt) then
30690 -- The anonymous object created for a single concurrent type is a
30691 -- suitable context.
30693 if Nkind (Stmt) = N_Object_Declaration
30694 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
30698 elsif Nkind (Stmt) = N_Subprogram_Declaration then
30700 -- The subprogram declaration is an internally generated spec
30701 -- for an expression function.
30703 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
30706 -- The subprogram declaration is an internally generated spec
30707 -- for a stand-alone subrogram body declared inside a protected
30710 elsif Present (Corresponding_Body (Stmt))
30711 and then Comes_From_Source (Corresponding_Body (Stmt))
30712 and then Is_Protected_Type (Current_Scope)
30716 -- The subprogram is actually an instance housed within an
30717 -- anonymous wrapper package.
30719 elsif Present (Generic_Parent (Specification (Stmt))) then
30724 -- Return the current construct which is either a subprogram body,
30725 -- a subprogram declaration or is illegal.
30734 -- If we fall through, then the pragma was either the first declaration
30735 -- or it was preceded by other pragmas and no source constructs.
30737 -- The pragma is associated with a library-level subprogram
30739 if Nkind (Context) = N_Compilation_Unit_Aux then
30740 return Unit (Parent (Context));
30742 -- The pragma appears inside the declarations of an entry body
30744 elsif Nkind (Context) = N_Entry_Body then
30747 -- The pragma appears inside the statements of a subprogram body. This
30748 -- placement is the result of subprogram contract expansion.
30750 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then
30751 return Parent (Context);
30753 -- The pragma appears inside the declarative part of a package body
30755 elsif Nkind (Context) = N_Package_Body then
30758 -- The pragma appears inside the declarative part of a subprogram body
30760 elsif Nkind (Context) = N_Subprogram_Body then
30763 -- The pragma appears inside the declarative part of a task body
30765 elsif Nkind (Context) = N_Task_Body then
30768 -- The pragma appears inside the visible part of a package specification
30770 elsif Nkind (Context) = N_Package_Specification then
30771 return Parent (Context);
30773 -- The pragma is a byproduct of aspect expansion, return the related
30774 -- context of the original aspect. This case has a lower priority as
30775 -- the above circuitry pinpoints precisely the related context.
30777 elsif Present (Corresponding_Aspect (Prag)) then
30778 return Parent (Corresponding_Aspect (Prag));
30780 -- No candidate subprogram [body] found
30785 end Find_Related_Declaration_Or_Body;
30787 ----------------------------------
30788 -- Find_Related_Package_Or_Body --
30789 ----------------------------------
30791 function Find_Related_Package_Or_Body
30793 Do_Checks : Boolean := False) return Node_Id
30795 Context : constant Node_Id := Parent (Prag);
30796 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
30800 Stmt := Prev (Prag);
30801 while Present (Stmt) loop
30803 -- Skip prior pragmas, but check for duplicates
30805 if Nkind (Stmt) = N_Pragma then
30806 if Do_Checks and then Pragma_Name (Stmt) = Prag_Nam then
30812 -- Skip internally generated code
30814 elsif not Comes_From_Source (Stmt) then
30815 if Nkind (Stmt) = N_Subprogram_Declaration then
30817 -- The subprogram declaration is an internally generated spec
30818 -- for an expression function.
30820 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
30823 -- The subprogram is actually an instance housed within an
30824 -- anonymous wrapper package.
30826 elsif Present (Generic_Parent (Specification (Stmt))) then
30831 -- Return the current source construct which is illegal
30840 -- If we fall through, then the pragma was either the first declaration
30841 -- or it was preceded by other pragmas and no source constructs.
30843 -- The pragma is associated with a package. The immediate context in
30844 -- this case is the specification of the package.
30846 if Nkind (Context) = N_Package_Specification then
30847 return Parent (Context);
30849 -- The pragma appears in the declarations of a package body
30851 elsif Nkind (Context) = N_Package_Body then
30854 -- The pragma appears in the statements of a package body
30856 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
30857 and then Nkind (Parent (Context)) = N_Package_Body
30859 return Parent (Context);
30861 -- The pragma is a byproduct of aspect expansion, return the related
30862 -- context of the original aspect. This case has a lower priority as
30863 -- the above circuitry pinpoints precisely the related context.
30865 elsif Present (Corresponding_Aspect (Prag)) then
30866 return Parent (Corresponding_Aspect (Prag));
30868 -- No candidate package [body] found
30873 end Find_Related_Package_Or_Body;
30879 function Get_Argument
30881 Context_Id : Entity_Id := Empty) return Node_Id
30883 Args : constant List_Id := Pragma_Argument_Associations (Prag);
30886 -- Use the expression of the original aspect when compiling for ASIS or
30887 -- when analyzing the template of a generic unit. In both cases the
30888 -- aspect's tree must be decorated to allow for ASIS queries or to save
30889 -- the global references in the generic context.
30891 if From_Aspect_Specification (Prag)
30892 and then (ASIS_Mode or else (Present (Context_Id)
30893 and then Is_Generic_Unit (Context_Id)))
30895 return Corresponding_Aspect (Prag);
30897 -- Otherwise use the expression of the pragma
30899 elsif Present (Args) then
30900 return First (Args);
30907 -------------------------
30908 -- Get_Base_Subprogram --
30909 -------------------------
30911 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
30913 -- Follow subprogram renaming chain
30915 if Is_Subprogram (Def_Id)
30916 and then Nkind (Parent (Declaration_Node (Def_Id))) =
30917 N_Subprogram_Renaming_Declaration
30918 and then Present (Alias (Def_Id))
30920 return Alias (Def_Id);
30924 end Get_Base_Subprogram;
30926 -----------------------
30927 -- Get_SPARK_Mode_Type --
30928 -----------------------
30930 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is
30932 if N = Name_On then
30934 elsif N = Name_Off then
30937 -- Any other argument is illegal. Assume that no SPARK mode applies to
30938 -- avoid potential cascaded errors.
30943 end Get_SPARK_Mode_Type;
30945 ------------------------------------
30946 -- Get_SPARK_Mode_From_Annotation --
30947 ------------------------------------
30949 function Get_SPARK_Mode_From_Annotation
30950 (N : Node_Id) return SPARK_Mode_Type
30955 if Nkind (N) = N_Aspect_Specification then
30956 Mode := Expression (N);
30958 else pragma Assert (Nkind (N) = N_Pragma);
30959 Mode := First (Pragma_Argument_Associations (N));
30961 if Present (Mode) then
30962 Mode := Get_Pragma_Arg (Mode);
30966 -- Aspect or pragma SPARK_Mode specifies an explicit mode
30968 if Present (Mode) then
30969 if Nkind (Mode) = N_Identifier then
30970 return Get_SPARK_Mode_Type (Chars (Mode));
30972 -- In case of a malformed aspect or pragma, return the default None
30978 -- Otherwise the lack of an expression defaults SPARK_Mode to On
30983 end Get_SPARK_Mode_From_Annotation;
30985 ---------------------------
30986 -- Has_Extra_Parentheses --
30987 ---------------------------
30989 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean is
30993 -- The aggregate should not have an expression list because a clause
30994 -- is always interpreted as a component association. The only way an
30995 -- expression list can sneak in is by adding extra parentheses around
30996 -- the individual clauses:
30998 -- Depends (Output => Input) -- proper form
30999 -- Depends ((Output => Input)) -- extra parentheses
31001 -- Since the extra parentheses are not allowed by the syntax of the
31002 -- pragma, flag them now to avoid emitting misleading errors down the
31005 if Nkind (Clause) = N_Aggregate
31006 and then Present (Expressions (Clause))
31008 Expr := First (Expressions (Clause));
31009 while Present (Expr) loop
31011 -- A dependency clause surrounded by extra parentheses appears
31012 -- as an aggregate of component associations with an optional
31013 -- Paren_Count set.
31015 if Nkind (Expr) = N_Aggregate
31016 and then Present (Component_Associations (Expr))
31019 ("dependency clause contains extra parentheses", Expr);
31021 -- Otherwise the expression is a malformed construct
31024 SPARK_Msg_N ("malformed dependency clause", Expr);
31034 end Has_Extra_Parentheses;
31040 procedure Initialize is
31043 Compile_Time_Warnings_Errors.Init;
31052 Dummy := Dummy + 1;
31055 -----------------------------
31056 -- Is_Config_Static_String --
31057 -----------------------------
31059 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
31061 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
31062 -- This is an internal recursive function that is just like the outer
31063 -- function except that it adds the string to the name buffer rather
31064 -- than placing the string in the name buffer.
31066 ------------------------------
31067 -- Add_Config_Static_String --
31068 ------------------------------
31070 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
31077 if Nkind (N) = N_Op_Concat then
31078 if Add_Config_Static_String (Left_Opnd (N)) then
31079 N := Right_Opnd (N);
31085 if Nkind (N) /= N_String_Literal then
31086 Error_Msg_N ("string literal expected for pragma argument", N);
31090 for J in 1 .. String_Length (Strval (N)) loop
31091 C := Get_String_Char (Strval (N), J);
31093 if not In_Character_Range (C) then
31095 ("string literal contains invalid wide character",
31096 Sloc (N) + 1 + Source_Ptr (J));
31100 Add_Char_To_Name_Buffer (Get_Character (C));
31105 end Add_Config_Static_String;
31107 -- Start of processing for Is_Config_Static_String
31112 return Add_Config_Static_String (Arg);
31113 end Is_Config_Static_String;
31115 -------------------------------
31116 -- Is_Elaboration_SPARK_Mode --
31117 -------------------------------
31119 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is
31122 (Nkind (N) = N_Pragma
31123 and then Pragma_Name (N) = Name_SPARK_Mode
31124 and then Is_List_Member (N));
31126 -- Pragma SPARK_Mode affects the elaboration of a package body when it
31127 -- appears in the statement part of the body.
31130 Present (Parent (N))
31131 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
31132 and then List_Containing (N) = Statements (Parent (N))
31133 and then Present (Parent (Parent (N)))
31134 and then Nkind (Parent (Parent (N))) = N_Package_Body;
31135 end Is_Elaboration_SPARK_Mode;
31137 -----------------------
31138 -- Is_Enabled_Pragma --
31139 -----------------------
31141 function Is_Enabled_Pragma (Prag : Node_Id) return Boolean is
31145 if Present (Prag) then
31146 Arg := First (Pragma_Argument_Associations (Prag));
31148 if Present (Arg) then
31149 return Is_True (Expr_Value (Get_Pragma_Arg (Arg)));
31151 -- The lack of a Boolean argument automatically enables the pragma
31157 -- The pragma is missing, therefore it is not enabled
31162 end Is_Enabled_Pragma;
31164 -----------------------------------------
31165 -- Is_Non_Significant_Pragma_Reference --
31166 -----------------------------------------
31168 -- This function makes use of the following static table which indicates
31169 -- whether appearance of some name in a given pragma is to be considered
31170 -- as a reference for the purposes of warnings about unreferenced objects.
31172 -- -1 indicates that appearence in any argument is significant
31173 -- 0 indicates that appearance in any argument is not significant
31174 -- +n indicates that appearance as argument n is significant, but all
31175 -- other arguments are not significant
31176 -- 9n arguments from n on are significant, before n insignificant
31178 Sig_Flags : constant array (Pragma_Id) of Int :=
31179 (Pragma_Abort_Defer => -1,
31180 Pragma_Abstract_State => -1,
31181 Pragma_Acc_Data => 0,
31182 Pragma_Acc_Kernels => 0,
31183 Pragma_Acc_Loop => 0,
31184 Pragma_Acc_Parallel => 0,
31185 Pragma_Ada_83 => -1,
31186 Pragma_Ada_95 => -1,
31187 Pragma_Ada_05 => -1,
31188 Pragma_Ada_2005 => -1,
31189 Pragma_Ada_12 => -1,
31190 Pragma_Ada_2012 => -1,
31191 Pragma_Ada_2020 => -1,
31192 Pragma_Aggregate_Individually_Assign => 0,
31193 Pragma_All_Calls_Remote => -1,
31194 Pragma_Allow_Integer_Address => -1,
31195 Pragma_Annotate => 93,
31196 Pragma_Assert => -1,
31197 Pragma_Assert_And_Cut => -1,
31198 Pragma_Assertion_Policy => 0,
31199 Pragma_Assume => -1,
31200 Pragma_Assume_No_Invalid_Values => 0,
31201 Pragma_Async_Readers => 0,
31202 Pragma_Async_Writers => 0,
31203 Pragma_Asynchronous => 0,
31204 Pragma_Atomic => 0,
31205 Pragma_Atomic_Components => 0,
31206 Pragma_Attach_Handler => -1,
31207 Pragma_Attribute_Definition => 92,
31208 Pragma_Check => -1,
31209 Pragma_Check_Float_Overflow => 0,
31210 Pragma_Check_Name => 0,
31211 Pragma_Check_Policy => 0,
31212 Pragma_CPP_Class => 0,
31213 Pragma_CPP_Constructor => 0,
31214 Pragma_CPP_Virtual => 0,
31215 Pragma_CPP_Vtable => 0,
31217 Pragma_C_Pass_By_Copy => 0,
31218 Pragma_Comment => -1,
31219 Pragma_Common_Object => 0,
31220 Pragma_Compile_Time_Error => -1,
31221 Pragma_Compile_Time_Warning => -1,
31222 Pragma_Compiler_Unit => -1,
31223 Pragma_Compiler_Unit_Warning => -1,
31224 Pragma_Complete_Representation => 0,
31225 Pragma_Complex_Representation => 0,
31226 Pragma_Component_Alignment => 0,
31227 Pragma_Constant_After_Elaboration => 0,
31228 Pragma_Contract_Cases => -1,
31229 Pragma_Controlled => 0,
31230 Pragma_Convention => 0,
31231 Pragma_Convention_Identifier => 0,
31232 Pragma_Deadline_Floor => -1,
31233 Pragma_Debug => -1,
31234 Pragma_Debug_Policy => 0,
31235 Pragma_Detect_Blocking => 0,
31236 Pragma_Default_Initial_Condition => -1,
31237 Pragma_Default_Scalar_Storage_Order => 0,
31238 Pragma_Default_Storage_Pool => 0,
31239 Pragma_Depends => -1,
31240 Pragma_Disable_Atomic_Synchronization => 0,
31241 Pragma_Discard_Names => 0,
31242 Pragma_Dispatching_Domain => -1,
31243 Pragma_Effective_Reads => 0,
31244 Pragma_Effective_Writes => 0,
31245 Pragma_Elaborate => 0,
31246 Pragma_Elaborate_All => 0,
31247 Pragma_Elaborate_Body => 0,
31248 Pragma_Elaboration_Checks => 0,
31249 Pragma_Eliminate => 0,
31250 Pragma_Enable_Atomic_Synchronization => 0,
31251 Pragma_Export => -1,
31252 Pragma_Export_Function => -1,
31253 Pragma_Export_Object => -1,
31254 Pragma_Export_Procedure => -1,
31255 Pragma_Export_Value => -1,
31256 Pragma_Export_Valued_Procedure => -1,
31257 Pragma_Extend_System => -1,
31258 Pragma_Extensions_Allowed => 0,
31259 Pragma_Extensions_Visible => 0,
31260 Pragma_External => -1,
31261 Pragma_Favor_Top_Level => 0,
31262 Pragma_External_Name_Casing => 0,
31263 Pragma_Fast_Math => 0,
31264 Pragma_Finalize_Storage_Only => 0,
31266 Pragma_Global => -1,
31267 Pragma_Ident => -1,
31268 Pragma_Ignore_Pragma => 0,
31269 Pragma_Implementation_Defined => -1,
31270 Pragma_Implemented => -1,
31271 Pragma_Implicit_Packing => 0,
31272 Pragma_Import => 93,
31273 Pragma_Import_Function => 0,
31274 Pragma_Import_Object => 0,
31275 Pragma_Import_Procedure => 0,
31276 Pragma_Import_Valued_Procedure => 0,
31277 Pragma_Independent => 0,
31278 Pragma_Independent_Components => 0,
31279 Pragma_Initial_Condition => -1,
31280 Pragma_Initialize_Scalars => 0,
31281 Pragma_Initializes => -1,
31282 Pragma_Inline => 0,
31283 Pragma_Inline_Always => 0,
31284 Pragma_Inline_Generic => 0,
31285 Pragma_Inspection_Point => -1,
31286 Pragma_Interface => 92,
31287 Pragma_Interface_Name => 0,
31288 Pragma_Interrupt_Handler => -1,
31289 Pragma_Interrupt_Priority => -1,
31290 Pragma_Interrupt_State => -1,
31291 Pragma_Invariant => -1,
31292 Pragma_Keep_Names => 0,
31293 Pragma_License => 0,
31294 Pragma_Link_With => -1,
31295 Pragma_Linker_Alias => -1,
31296 Pragma_Linker_Constructor => -1,
31297 Pragma_Linker_Destructor => -1,
31298 Pragma_Linker_Options => -1,
31299 Pragma_Linker_Section => -1,
31301 Pragma_Lock_Free => 0,
31302 Pragma_Locking_Policy => 0,
31303 Pragma_Loop_Invariant => -1,
31304 Pragma_Loop_Optimize => 0,
31305 Pragma_Loop_Variant => -1,
31306 Pragma_Machine_Attribute => -1,
31308 Pragma_Main_Storage => -1,
31309 Pragma_Max_Entry_Queue_Depth => 0,
31310 Pragma_Max_Entry_Queue_Length => 0,
31311 Pragma_Max_Queue_Length => 0,
31312 Pragma_Memory_Size => 0,
31313 Pragma_No_Body => 0,
31314 Pragma_No_Caching => 0,
31315 Pragma_No_Component_Reordering => -1,
31316 Pragma_No_Elaboration_Code_All => 0,
31317 Pragma_No_Heap_Finalization => 0,
31318 Pragma_No_Inline => 0,
31319 Pragma_No_Return => 0,
31320 Pragma_No_Run_Time => -1,
31321 Pragma_No_Strict_Aliasing => -1,
31322 Pragma_No_Tagged_Streams => 0,
31323 Pragma_Normalize_Scalars => 0,
31324 Pragma_Obsolescent => 0,
31325 Pragma_Optimize => 0,
31326 Pragma_Optimize_Alignment => 0,
31327 Pragma_Overflow_Mode => 0,
31328 Pragma_Overriding_Renamings => 0,
31329 Pragma_Ordered => 0,
31332 Pragma_Part_Of => 0,
31333 Pragma_Partition_Elaboration_Policy => 0,
31334 Pragma_Passive => 0,
31335 Pragma_Persistent_BSS => 0,
31336 Pragma_Polling => 0,
31337 Pragma_Prefix_Exception_Messages => 0,
31339 Pragma_Postcondition => -1,
31340 Pragma_Post_Class => -1,
31342 Pragma_Precondition => -1,
31343 Pragma_Predicate => -1,
31344 Pragma_Predicate_Failure => -1,
31345 Pragma_Preelaborable_Initialization => -1,
31346 Pragma_Preelaborate => 0,
31347 Pragma_Pre_Class => -1,
31348 Pragma_Priority => -1,
31349 Pragma_Priority_Specific_Dispatching => 0,
31350 Pragma_Profile => 0,
31351 Pragma_Profile_Warnings => 0,
31352 Pragma_Propagate_Exceptions => 0,
31353 Pragma_Provide_Shift_Operators => 0,
31354 Pragma_Psect_Object => 0,
31356 Pragma_Pure_Function => 0,
31357 Pragma_Queuing_Policy => 0,
31358 Pragma_Rational => 0,
31359 Pragma_Ravenscar => 0,
31360 Pragma_Refined_Depends => -1,
31361 Pragma_Refined_Global => -1,
31362 Pragma_Refined_Post => -1,
31363 Pragma_Refined_State => -1,
31364 Pragma_Relative_Deadline => 0,
31365 Pragma_Rename_Pragma => 0,
31366 Pragma_Remote_Access_Type => -1,
31367 Pragma_Remote_Call_Interface => -1,
31368 Pragma_Remote_Types => -1,
31369 Pragma_Restricted_Run_Time => 0,
31370 Pragma_Restriction_Warnings => 0,
31371 Pragma_Restrictions => 0,
31372 Pragma_Reviewable => -1,
31373 Pragma_Secondary_Stack_Size => -1,
31374 Pragma_Short_Circuit_And_Or => 0,
31375 Pragma_Share_Generic => 0,
31376 Pragma_Shared => 0,
31377 Pragma_Shared_Passive => 0,
31378 Pragma_Short_Descriptors => 0,
31379 Pragma_Simple_Storage_Pool_Type => 0,
31380 Pragma_Source_File_Name => 0,
31381 Pragma_Source_File_Name_Project => 0,
31382 Pragma_Source_Reference => 0,
31383 Pragma_SPARK_Mode => 0,
31384 Pragma_Storage_Size => -1,
31385 Pragma_Storage_Unit => 0,
31386 Pragma_Static_Elaboration_Desired => 0,
31387 Pragma_Stream_Convert => 0,
31388 Pragma_Style_Checks => 0,
31389 Pragma_Subtitle => 0,
31390 Pragma_Suppress => 0,
31391 Pragma_Suppress_Exception_Locations => 0,
31392 Pragma_Suppress_All => 0,
31393 Pragma_Suppress_Debug_Info => 0,
31394 Pragma_Suppress_Initialization => 0,
31395 Pragma_System_Name => 0,
31396 Pragma_Task_Dispatching_Policy => 0,
31397 Pragma_Task_Info => -1,
31398 Pragma_Task_Name => -1,
31399 Pragma_Task_Storage => -1,
31400 Pragma_Test_Case => -1,
31401 Pragma_Thread_Local_Storage => -1,
31402 Pragma_Time_Slice => -1,
31404 Pragma_Type_Invariant => -1,
31405 Pragma_Type_Invariant_Class => -1,
31406 Pragma_Unchecked_Union => 0,
31407 Pragma_Unevaluated_Use_Of_Old => 0,
31408 Pragma_Unimplemented_Unit => 0,
31409 Pragma_Universal_Aliasing => 0,
31410 Pragma_Universal_Data => 0,
31411 Pragma_Unmodified => 0,
31412 Pragma_Unreferenced => 0,
31413 Pragma_Unreferenced_Objects => 0,
31414 Pragma_Unreserve_All_Interrupts => 0,
31415 Pragma_Unsuppress => 0,
31416 Pragma_Unused => 0,
31417 Pragma_Use_VADS_Size => 0,
31418 Pragma_Validity_Checks => 0,
31419 Pragma_Volatile => 0,
31420 Pragma_Volatile_Components => 0,
31421 Pragma_Volatile_Full_Access => 0,
31422 Pragma_Volatile_Function => 0,
31423 Pragma_Warning_As_Error => 0,
31424 Pragma_Warnings => 0,
31425 Pragma_Weak_External => 0,
31426 Pragma_Wide_Character_Encoding => 0,
31427 Unknown_Pragma => 0);
31429 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
31435 function Arg_No return Nat;
31436 -- Returns an integer showing what argument we are in. A value of
31437 -- zero means we are not in any of the arguments.
31443 function Arg_No return Nat is
31448 A := First (Pragma_Argument_Associations (Parent (P)));
31462 -- Start of processing for Non_Significant_Pragma_Reference
31467 if Nkind (P) /= N_Pragma_Argument_Association then
31471 Id := Get_Pragma_Id (Parent (P));
31472 C := Sig_Flags (Id);
31487 return AN < (C - 90);
31493 end Is_Non_Significant_Pragma_Reference;
31495 ------------------------------
31496 -- Is_Pragma_String_Literal --
31497 ------------------------------
31499 -- This function returns true if the corresponding pragma argument is a
31500 -- static string expression. These are the only cases in which string
31501 -- literals can appear as pragma arguments. We also allow a string literal
31502 -- as the first argument to pragma Assert (although it will of course
31503 -- always generate a type error).
31505 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
31506 Pragn : constant Node_Id := Parent (Par);
31507 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
31508 Pname : constant Name_Id := Pragma_Name (Pragn);
31514 N := First (Assoc);
31521 if Pname = Name_Assert then
31524 elsif Pname = Name_Export then
31527 elsif Pname = Name_Ident then
31530 elsif Pname = Name_Import then
31533 elsif Pname = Name_Interface_Name then
31536 elsif Pname = Name_Linker_Alias then
31539 elsif Pname = Name_Linker_Section then
31542 elsif Pname = Name_Machine_Attribute then
31545 elsif Pname = Name_Source_File_Name then
31548 elsif Pname = Name_Source_Reference then
31551 elsif Pname = Name_Title then
31554 elsif Pname = Name_Subtitle then
31560 end Is_Pragma_String_Literal;
31562 ---------------------------
31563 -- Is_Private_SPARK_Mode --
31564 ---------------------------
31566 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is
31569 (Nkind (N) = N_Pragma
31570 and then Pragma_Name (N) = Name_SPARK_Mode
31571 and then Is_List_Member (N));
31573 -- For pragma SPARK_Mode to be private, it has to appear in the private
31574 -- declarations of a package.
31577 Present (Parent (N))
31578 and then Nkind (Parent (N)) = N_Package_Specification
31579 and then List_Containing (N) = Private_Declarations (Parent (N));
31580 end Is_Private_SPARK_Mode;
31582 -------------------------------------
31583 -- Is_Unconstrained_Or_Tagged_Item --
31584 -------------------------------------
31586 function Is_Unconstrained_Or_Tagged_Item
31587 (Item : Entity_Id) return Boolean
31589 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean;
31590 -- Determine whether record type Typ has at least one unconstrained
31593 ---------------------------------
31594 -- Has_Unconstrained_Component --
31595 ---------------------------------
31597 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is
31601 Comp := First_Component (Typ);
31602 while Present (Comp) loop
31603 if Is_Unconstrained_Or_Tagged_Item (Comp) then
31607 Next_Component (Comp);
31611 end Has_Unconstrained_Component;
31615 Typ : constant Entity_Id := Etype (Item);
31617 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
31620 if Is_Tagged_Type (Typ) then
31623 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
31626 elsif Is_Record_Type (Typ) then
31627 if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then
31630 return Has_Unconstrained_Component (Typ);
31633 elsif Is_Private_Type (Typ) and then Has_Discriminants (Typ) then
31639 end Is_Unconstrained_Or_Tagged_Item;
31641 -----------------------------
31642 -- Is_Valid_Assertion_Kind --
31643 -----------------------------
31645 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is
31652 | Name_Assertion_Policy
31653 | Name_Static_Predicate
31654 | Name_Dynamic_Predicate
31659 | Name_Type_Invariant
31660 | Name_uType_Invariant
31664 | Name_Assert_And_Cut
31666 | Name_Contract_Cases
31668 | Name_Default_Initial_Condition
31670 | Name_Initial_Condition
31673 | Name_Loop_Invariant
31674 | Name_Loop_Variant
31675 | Name_Postcondition
31676 | Name_Precondition
31678 | Name_Refined_Post
31679 | Name_Statement_Assertions
31686 end Is_Valid_Assertion_Kind;
31688 --------------------------------------
31689 -- Process_Compilation_Unit_Pragmas --
31690 --------------------------------------
31692 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
31694 -- A special check for pragma Suppress_All, a very strange DEC pragma,
31695 -- strange because it comes at the end of the unit. Rational has the
31696 -- same name for a pragma, but treats it as a program unit pragma, In
31697 -- GNAT we just decide to allow it anywhere at all. If it appeared then
31698 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
31699 -- node, and we insert a pragma Suppress (All_Checks) at the start of
31700 -- the context clause to ensure the correct processing.
31702 if Has_Pragma_Suppress_All (N) then
31703 Prepend_To (Context_Items (N),
31704 Make_Pragma (Sloc (N),
31705 Chars => Name_Suppress,
31706 Pragma_Argument_Associations => New_List (
31707 Make_Pragma_Argument_Association (Sloc (N),
31708 Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
31711 -- Nothing else to do at the current time
31713 end Process_Compilation_Unit_Pragmas;
31715 --------------------------------------------
31716 -- Validate_Compile_Time_Warning_Or_Error --
31717 --------------------------------------------
31719 procedure Validate_Compile_Time_Warning_Or_Error
31723 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
31724 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
31725 Arg2 : constant Node_Id := Next (Arg1);
31727 Pname : constant Name_Id := Pragma_Name_Unmapped (N);
31728 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
31731 Analyze_And_Resolve (Arg1x, Standard_Boolean);
31733 if Compile_Time_Known_Value (Arg1x) then
31734 if Is_True (Expr_Value (Arg1x)) then
31736 -- We have already verified that the second argument is a static
31737 -- string expression. Its string value must be retrieved
31738 -- explicitly if it is a declared constant, otherwise it has
31739 -- been constant-folded previously.
31742 Cent : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
31743 Str : constant String_Id :=
31744 Strval (Expr_Value_S (Get_Pragma_Arg (Arg2)));
31745 Str_Len : constant Nat := String_Length (Str);
31747 Force : constant Boolean :=
31748 Prag_Id = Pragma_Compile_Time_Warning
31749 and then Is_Spec_Name (Unit_Name (Current_Sem_Unit))
31750 and then (Ekind (Cent) /= E_Package
31751 or else not In_Private_Part (Cent));
31752 -- Set True if this is the warning case, and we are in the
31753 -- visible part of a package spec, or in a subprogram spec,
31754 -- in which case we want to force the client to see the
31755 -- warning, even though it is not in the main unit.
31763 -- Loop through segments of message separated by line feeds.
31764 -- We output these segments as separate messages with
31765 -- continuation marks for all but the first.
31770 Error_Msg_Strlen := 0;
31772 -- Loop to copy characters from argument to error message
31776 exit when Ptr > Str_Len;
31777 CC := Get_String_Char (Str, Ptr);
31780 -- Ignore wide chars ??? else store character
31782 if In_Character_Range (CC) then
31783 C := Get_Character (CC);
31784 exit when C = ASCII.LF;
31785 Error_Msg_Strlen := Error_Msg_Strlen + 1;
31786 Error_Msg_String (Error_Msg_Strlen) := C;
31790 -- Here with one line ready to go
31792 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
31794 -- If this is a warning in a spec, then we want clients
31795 -- to see the warning, so mark the message with the
31796 -- special sequence !! to force the warning. In the case
31797 -- of a package spec, we do not force this if we are in
31798 -- the private part of the spec.
31801 if Cont = False then
31802 Error_Msg ("<<~!!", Eloc);
31805 Error_Msg ("\<<~!!", Eloc);
31808 -- Error, rather than warning, or in a body, so we do not
31809 -- need to force visibility for client (error will be
31810 -- output in any case, and this is the situation in which
31811 -- we do not want a client to get a warning, since the
31812 -- warning is in the body or the spec private part).
31815 if Cont = False then
31816 Error_Msg ("<<~", Eloc);
31819 Error_Msg ("\<<~", Eloc);
31823 exit when Ptr > Str_Len;
31828 -- Arg1x is not known at compile time, so possibly issue an error
31829 -- or warning. This can happen only if the pragma's processing
31830 -- was deferred until after the back end is run (see
31831 -- Process_Compile_Time_Warning_Or_Error). Note that the warning
31832 -- control switch applies to only the warning case.
31834 elsif Prag_Id = Pragma_Compile_Time_Error then
31835 Error_Msg_N ("condition is not known at compile time", Arg1x);
31837 elsif Warn_On_Unknown_Compile_Time_Warning then
31838 Error_Msg_N ("?condition is not known at compile time", Arg1x);
31840 end Validate_Compile_Time_Warning_Or_Error;
31842 ------------------------------------
31843 -- Record_Possible_Body_Reference --
31844 ------------------------------------
31846 procedure Record_Possible_Body_Reference
31847 (State_Id : Entity_Id;
31851 Spec_Id : Entity_Id;
31854 -- Ensure that we are dealing with a reference to a state
31856 pragma Assert (Ekind (State_Id) = E_Abstract_State);
31858 -- Climb the tree starting from the reference looking for a package body
31859 -- whose spec declares the referenced state. This criteria automatically
31860 -- excludes references in package specs which are legal. Note that it is
31861 -- not wise to emit an error now as the package body may lack pragma
31862 -- Refined_State or the referenced state may not be mentioned in the
31863 -- refinement. This approach avoids the generation of misleading errors.
31866 while Present (Context) loop
31867 if Nkind (Context) = N_Package_Body then
31868 Spec_Id := Corresponding_Spec (Context);
31870 if Present (Abstract_States (Spec_Id))
31871 and then Contains (Abstract_States (Spec_Id), State_Id)
31873 if No (Body_References (State_Id)) then
31874 Set_Body_References (State_Id, New_Elmt_List);
31877 Append_Elmt (Ref, To => Body_References (State_Id));
31882 Context := Parent (Context);
31884 end Record_Possible_Body_Reference;
31886 ------------------------------------------
31887 -- Relocate_Pragmas_To_Anonymous_Object --
31888 ------------------------------------------
31890 procedure Relocate_Pragmas_To_Anonymous_Object
31891 (Typ_Decl : Node_Id;
31892 Obj_Decl : Node_Id)
31896 Next_Decl : Node_Id;
31899 if Nkind (Typ_Decl) = N_Protected_Type_Declaration then
31900 Def := Protected_Definition (Typ_Decl);
31902 pragma Assert (Nkind (Typ_Decl) = N_Task_Type_Declaration);
31903 Def := Task_Definition (Typ_Decl);
31906 -- The concurrent definition has a visible declaration list. Inspect it
31907 -- and relocate all canidate pragmas.
31909 if Present (Def) and then Present (Visible_Declarations (Def)) then
31910 Decl := First (Visible_Declarations (Def));
31911 while Present (Decl) loop
31913 -- Preserve the following declaration for iteration purposes due
31914 -- to possible relocation of a pragma.
31916 Next_Decl := Next (Decl);
31918 if Nkind (Decl) = N_Pragma
31919 and then Pragma_On_Anonymous_Object_OK (Get_Pragma_Id (Decl))
31922 Insert_After (Obj_Decl, Decl);
31924 -- Skip internally generated code
31926 elsif not Comes_From_Source (Decl) then
31929 -- No candidate pragmas are available for relocation
31938 end Relocate_Pragmas_To_Anonymous_Object;
31940 ------------------------------
31941 -- Relocate_Pragmas_To_Body --
31942 ------------------------------
31944 procedure Relocate_Pragmas_To_Body
31945 (Subp_Body : Node_Id;
31946 Target_Body : Node_Id := Empty)
31948 procedure Relocate_Pragma (Prag : Node_Id);
31949 -- Remove a single pragma from its current list and add it to the
31950 -- declarations of the proper body (either Subp_Body or Target_Body).
31952 ---------------------
31953 -- Relocate_Pragma --
31954 ---------------------
31956 procedure Relocate_Pragma (Prag : Node_Id) is
31961 -- When subprogram stubs or expression functions are involves, the
31962 -- destination declaration list belongs to the proper body.
31964 if Present (Target_Body) then
31965 Target := Target_Body;
31967 Target := Subp_Body;
31970 Decls := Declarations (Target);
31974 Set_Declarations (Target, Decls);
31977 -- Unhook the pragma from its current list
31980 Prepend (Prag, Decls);
31981 end Relocate_Pragma;
31985 Body_Id : constant Entity_Id :=
31986 Defining_Unit_Name (Specification (Subp_Body));
31987 Next_Stmt : Node_Id;
31990 -- Start of processing for Relocate_Pragmas_To_Body
31993 -- Do not process a body that comes from a separate unit as no construct
31994 -- can possibly follow it.
31996 if not Is_List_Member (Subp_Body) then
31999 -- Do not relocate pragmas that follow a stub if the stub does not have
32002 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub
32003 and then No (Target_Body)
32007 -- Do not process internally generated routine _Postconditions
32009 elsif Ekind (Body_Id) = E_Procedure
32010 and then Chars (Body_Id) = Name_uPostconditions
32015 -- Look at what is following the body. We are interested in certain kind
32016 -- of pragmas (either from source or byproducts of expansion) that can
32017 -- apply to a body [stub].
32019 Stmt := Next (Subp_Body);
32020 while Present (Stmt) loop
32022 -- Preserve the following statement for iteration purposes due to a
32023 -- possible relocation of a pragma.
32025 Next_Stmt := Next (Stmt);
32027 -- Move a candidate pragma following the body to the declarations of
32030 if Nkind (Stmt) = N_Pragma
32031 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt))
32034 -- If a source pragma Warnings follows the body, it applies to
32035 -- following statements and does not belong in the body.
32037 if Get_Pragma_Id (Stmt) = Pragma_Warnings
32038 and then Comes_From_Source (Stmt)
32042 Relocate_Pragma (Stmt);
32045 -- Skip internally generated code
32047 elsif not Comes_From_Source (Stmt) then
32050 -- No candidate pragmas are available for relocation
32058 end Relocate_Pragmas_To_Body;
32060 -------------------
32061 -- Resolve_State --
32062 -------------------
32064 procedure Resolve_State (N : Node_Id) is
32069 if Is_Entity_Name (N) and then Present (Entity (N)) then
32070 Func := Entity (N);
32072 -- Handle overloading of state names by functions. Traverse the
32073 -- homonym chain looking for an abstract state.
32075 if Ekind (Func) = E_Function and then Has_Homonym (Func) then
32076 pragma Assert (Is_Overloaded (N));
32078 State := Homonym (Func);
32079 while Present (State) loop
32080 if Ekind (State) = E_Abstract_State then
32082 -- Resolve the overloading by setting the proper entity of
32083 -- the reference to that of the state.
32085 Set_Etype (N, Standard_Void_Type);
32086 Set_Entity (N, State);
32087 Set_Is_Overloaded (N, False);
32089 Generate_Reference (State, N);
32093 State := Homonym (State);
32096 -- A function can never act as a state. If the homonym chain does
32097 -- not contain a corresponding state, then something went wrong in
32098 -- the overloading mechanism.
32100 raise Program_Error;
32105 ----------------------------
32106 -- Rewrite_Assertion_Kind --
32107 ----------------------------
32109 procedure Rewrite_Assertion_Kind
32111 From_Policy : Boolean := False)
32117 if Nkind (N) = N_Attribute_Reference
32118 and then Attribute_Name (N) = Name_Class
32119 and then Nkind (Prefix (N)) = N_Identifier
32121 case Chars (Prefix (N)) is
32128 when Name_Type_Invariant =>
32129 Nam := Name_uType_Invariant;
32131 when Name_Invariant =>
32132 Nam := Name_uInvariant;
32138 -- Recommend standard use of aspect names Pre/Post
32140 elsif Nkind (N) = N_Identifier
32141 and then From_Policy
32142 and then Serious_Errors_Detected = 0
32143 and then not ASIS_Mode
32145 if Chars (N) = Name_Precondition
32146 or else Chars (N) = Name_Postcondition
32148 Error_Msg_N ("Check_Policy is a non-standard pragma??", N);
32150 ("\use Assertion_Policy and aspect names Pre/Post for "
32151 & "Ada2012 conformance?", N);
32157 if Nam /= No_Name then
32158 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam));
32160 end Rewrite_Assertion_Kind;
32168 Dummy := Dummy + 1;
32171 --------------------------------
32172 -- Set_Encoded_Interface_Name --
32173 --------------------------------
32175 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
32176 Str : constant String_Id := Strval (S);
32177 Len : constant Nat := String_Length (Str);
32182 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
32185 -- Stores encoded value of character code CC. The encoding we use an
32186 -- underscore followed by four lower case hex digits.
32192 procedure Encode is
32194 Store_String_Char (Get_Char_Code ('_'));
32196 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
32198 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
32200 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
32202 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
32205 -- Start of processing for Set_Encoded_Interface_Name
32208 -- If first character is asterisk, this is a link name, and we leave it
32209 -- completely unmodified. We also ignore null strings (the latter case
32210 -- happens only in error cases).
32213 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
32215 Set_Interface_Name (E, S);
32220 CC := Get_String_Char (Str, J);
32222 exit when not In_Character_Range (CC);
32224 C := Get_Character (CC);
32226 exit when C /= '_' and then C /= '$'
32227 and then C not in '0' .. '9'
32228 and then C not in 'a' .. 'z'
32229 and then C not in 'A' .. 'Z';
32232 Set_Interface_Name (E, S);
32240 -- Here we need to encode. The encoding we use as follows:
32241 -- three underscores + four hex digits (lower case)
32245 for J in 1 .. String_Length (Str) loop
32246 CC := Get_String_Char (Str, J);
32248 if not In_Character_Range (CC) then
32251 C := Get_Character (CC);
32253 if C = '_' or else C = '$'
32254 or else C in '0' .. '9'
32255 or else C in 'a' .. 'z'
32256 or else C in 'A' .. 'Z'
32258 Store_String_Char (CC);
32265 Set_Interface_Name (E,
32266 Make_String_Literal (Sloc (S),
32267 Strval => End_String));
32269 end Set_Encoded_Interface_Name;
32271 ------------------------
32272 -- Set_Elab_Unit_Name --
32273 ------------------------
32275 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id) is
32280 if Nkind (N) = N_Identifier
32281 and then Nkind (With_Item) = N_Identifier
32283 Set_Entity (N, Entity (With_Item));
32285 elsif Nkind (N) = N_Selected_Component then
32286 Change_Selected_Component_To_Expanded_Name (N);
32287 Set_Entity (N, Entity (With_Item));
32288 Set_Entity (Selector_Name (N), Entity (N));
32290 Pref := Prefix (N);
32291 Scop := Scope (Entity (N));
32292 while Nkind (Pref) = N_Selected_Component loop
32293 Change_Selected_Component_To_Expanded_Name (Pref);
32294 Set_Entity (Selector_Name (Pref), Scop);
32295 Set_Entity (Pref, Scop);
32296 Pref := Prefix (Pref);
32297 Scop := Scope (Scop);
32300 Set_Entity (Pref, Scop);
32303 Generate_Reference (Entity (With_Item), N, Set_Ref => False);
32304 end Set_Elab_Unit_Name;
32306 -----------------------
32307 -- Set_Overflow_Mode --
32308 -----------------------
32310 procedure Set_Overflow_Mode (N : Node_Id) is
32312 function Get_Overflow_Mode (Arg : Node_Id) return Overflow_Mode_Type;
32313 -- Function to process one pragma argument, Arg
32315 -----------------------
32316 -- Get_Overflow_Mode --
32317 -----------------------
32319 function Get_Overflow_Mode (Arg : Node_Id) return Overflow_Mode_Type is
32320 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
32323 if Chars (Argx) = Name_Strict then
32326 elsif Chars (Argx) = Name_Minimized then
32329 elsif Chars (Argx) = Name_Eliminated then
32333 raise Program_Error;
32335 end Get_Overflow_Mode;
32339 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
32340 Arg2 : constant Node_Id := Next (Arg1);
32342 -- Start of processing for Set_Overflow_Mode
32345 -- Process first argument
32347 Scope_Suppress.Overflow_Mode_General :=
32348 Get_Overflow_Mode (Arg1);
32350 -- Case of only one argument
32353 Scope_Suppress.Overflow_Mode_Assertions :=
32354 Scope_Suppress.Overflow_Mode_General;
32356 -- Case of two arguments present
32359 Scope_Suppress.Overflow_Mode_Assertions :=
32360 Get_Overflow_Mode (Arg2);
32362 end Set_Overflow_Mode;
32364 -------------------
32365 -- Test_Case_Arg --
32366 -------------------
32368 function Test_Case_Arg
32371 From_Aspect : Boolean := False) return Node_Id
32373 Aspect : constant Node_Id := Corresponding_Aspect (Prag);
32378 pragma Assert (Nam_In (Arg_Nam, Name_Ensures,
32383 -- The caller requests the aspect argument
32385 if From_Aspect then
32386 if Present (Aspect)
32387 and then Nkind (Expression (Aspect)) = N_Aggregate
32389 Args := Expression (Aspect);
32391 -- "Name" and "Mode" may appear without an identifier as a
32392 -- positional association.
32394 if Present (Expressions (Args)) then
32395 Arg := First (Expressions (Args));
32397 if Present (Arg) and then Arg_Nam = Name_Name then
32405 if Present (Arg) and then Arg_Nam = Name_Mode then
32410 -- Some or all arguments may appear as component associatons
32412 if Present (Component_Associations (Args)) then
32413 Arg := First (Component_Associations (Args));
32414 while Present (Arg) loop
32415 if Chars (First (Choices (Arg))) = Arg_Nam then
32424 -- Otherwise retrieve the argument directly from the pragma
32427 Arg := First (Pragma_Argument_Associations (Prag));
32429 if Present (Arg) and then Arg_Nam = Name_Name then
32433 -- Skip argument "Name"
32437 if Present (Arg) and then Arg_Nam = Name_Mode then
32441 -- Skip argument "Mode"
32445 -- Arguments "Requires" and "Ensures" are optional and may not be
32448 while Present (Arg) loop
32449 if Chars (Arg) = Arg_Nam then
32460 --------------------------------------------
32461 -- Defer_Compile_Time_Warning_Error_To_BE --
32462 --------------------------------------------
32464 procedure Defer_Compile_Time_Warning_Error_To_BE (N : Node_Id) is
32465 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
32467 Compile_Time_Warnings_Errors.Append
32468 (New_Val => CTWE_Entry'(Eloc => Sloc (Arg1),
32469 Scope => Current_Scope,
32472 -- If the Boolean expression contains T'Size, and we're not in the main
32473 -- unit being compiled, then we need to copy the pragma into the main
32474 -- unit, because otherwise T'Size might never be computed, leaving it
32477 if not In_Extended_Main_Code_Unit (N) then
32478 Insert_Library_Level_Action (New_Copy_Tree (N));
32480 end Defer_Compile_Time_Warning_Error_To_BE;
32482 ------------------------------------------
32483 -- Validate_Compile_Time_Warning_Errors --
32484 ------------------------------------------
32486 procedure Validate_Compile_Time_Warning_Errors is
32487 procedure Set_Scope (S : Entity_Id);
32488 -- Install all enclosing scopes of S along with S itself
32490 procedure Unset_Scope (S : Entity_Id);
32491 -- Uninstall all enclosing scopes of S along with S itself
32497 procedure Set_Scope (S : Entity_Id) is
32499 if S /= Standard_Standard then
32500 Set_Scope (Scope (S));
32510 procedure Unset_Scope (S : Entity_Id) is
32512 if S /= Standard_Standard then
32513 Unset_Scope (Scope (S));
32519 -- Start of processing for Validate_Compile_Time_Warning_Errors
32522 Expander_Mode_Save_And_Set (False);
32523 In_Compile_Time_Warning_Or_Error := True;
32525 for N in Compile_Time_Warnings_Errors.First ..
32526 Compile_Time_Warnings_Errors.Last
32529 T : CTWE_Entry renames Compile_Time_Warnings_Errors.Table (N);
32532 Set_Scope (T.Scope);
32533 Reset_Analyzed_Flags (T.Prag);
32534 Validate_Compile_Time_Warning_Or_Error (T.Prag, T.Eloc);
32535 Unset_Scope (T.Scope);
32539 In_Compile_Time_Warning_Or_Error := False;
32540 Expander_Mode_Restore;
32541 end Validate_Compile_Time_Warning_Errors;