1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This unit contains the semantic processing for all pragmas, both language
27 -- and implementation defined. For most pragmas, the parser only does the
28 -- most basic job of checking the syntax, so Sem_Prag also contains the code
29 -- to complete the syntax checks. Certain pragmas are handled partially or
30 -- completely by the parser (see Par.Prag for further details).
32 with Aspects; use Aspects;
33 with Atree; use Atree;
34 with Casing; use Casing;
35 with Checks; use Checks;
36 with Contracts; use Contracts;
37 with Csets; use Csets;
38 with Debug; use Debug;
39 with Einfo; use Einfo;
40 with Elists; use Elists;
41 with Errout; use Errout;
42 with Exp_Dist; use Exp_Dist;
43 with Exp_Util; use Exp_Util;
44 with Expander; use Expander;
45 with Freeze; use Freeze;
46 with Ghost; use Ghost;
47 with Gnatvsn; use Gnatvsn;
49 with Lib.Writ; use Lib.Writ;
50 with Lib.Xref; use Lib.Xref;
51 with Namet.Sp; use Namet.Sp;
52 with Nlists; use Nlists;
53 with Nmake; use Nmake;
54 with Output; use Output;
55 with Par_SCO; use Par_SCO;
56 with Restrict; use Restrict;
57 with Rident; use Rident;
58 with Rtsfind; use Rtsfind;
60 with Sem_Aux; use Sem_Aux;
61 with Sem_Ch3; use Sem_Ch3;
62 with Sem_Ch6; use Sem_Ch6;
63 with Sem_Ch8; use Sem_Ch8;
64 with Sem_Ch12; use Sem_Ch12;
65 with Sem_Ch13; use Sem_Ch13;
66 with Sem_Disp; use Sem_Disp;
67 with Sem_Dist; use Sem_Dist;
68 with Sem_Elab; use Sem_Elab;
69 with Sem_Elim; use Sem_Elim;
70 with Sem_Eval; use Sem_Eval;
71 with Sem_Intr; use Sem_Intr;
72 with Sem_Mech; use Sem_Mech;
73 with Sem_Res; use Sem_Res;
74 with Sem_Type; use Sem_Type;
75 with Sem_Util; use Sem_Util;
76 with Sem_Warn; use Sem_Warn;
77 with Stand; use Stand;
78 with Sinfo; use Sinfo;
79 with Sinfo.CN; use Sinfo.CN;
80 with Sinput; use Sinput;
81 with Stringt; use Stringt;
82 with Stylesw; use Stylesw;
84 with Targparm; use Targparm;
85 with Tbuild; use Tbuild;
87 with Uintp; use Uintp;
88 with Uname; use Uname;
89 with Urealp; use Urealp;
90 with Validsw; use Validsw;
91 with Warnsw; use Warnsw;
93 with System.Case_Util;
95 package body Sem_Prag is
97 ----------------------------------------------
98 -- Common Handling of Import-Export Pragmas --
99 ----------------------------------------------
101 -- In the following section, a number of Import_xxx and Export_xxx pragmas
102 -- are defined by GNAT. These are compatible with the DEC pragmas of the
103 -- same name, and all have the following common form and processing:
106 -- [Internal =>] LOCAL_NAME
107 -- [, [External =>] EXTERNAL_SYMBOL]
108 -- [, other optional parameters ]);
111 -- [Internal =>] LOCAL_NAME
112 -- [, [External =>] EXTERNAL_SYMBOL]
113 -- [, other optional parameters ]);
115 -- EXTERNAL_SYMBOL ::=
117 -- | static_string_EXPRESSION
119 -- The internal LOCAL_NAME designates the entity that is imported or
120 -- exported, and must refer to an entity in the current declarative
121 -- part (as required by the rules for LOCAL_NAME).
123 -- The external linker name is designated by the External parameter if
124 -- given, or the Internal parameter if not (if there is no External
125 -- parameter, the External parameter is a copy of the Internal name).
127 -- If the External parameter is given as a string, then this string is
128 -- treated as an external name (exactly as though it had been given as an
129 -- External_Name parameter for a normal Import pragma).
131 -- If the External parameter is given as an identifier (or there is no
132 -- External parameter, so that the Internal identifier is used), then
133 -- the external name is the characters of the identifier, translated
134 -- to all lower case letters.
136 -- Note: the external name specified or implied by any of these special
137 -- Import_xxx or Export_xxx pragmas override an external or link name
138 -- specified in a previous Import or Export pragma.
140 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
141 -- named notation, following the standard rules for subprogram calls, i.e.
142 -- parameters can be given in any order if named notation is used, and
143 -- positional and named notation can be mixed, subject to the rule that all
144 -- positional parameters must appear first.
146 -- Note: All these pragmas are implemented exactly following the DEC design
147 -- and implementation and are intended to be fully compatible with the use
148 -- of these pragmas in the DEC Ada compiler.
150 --------------------------------------------
151 -- Checking for Duplicated External Names --
152 --------------------------------------------
154 -- It is suspicious if two separate Export pragmas use the same external
155 -- name. The following table is used to diagnose this situation so that
156 -- an appropriate warning can be issued.
158 -- The Node_Id stored is for the N_String_Literal node created to hold
159 -- the value of the external name. The Sloc of this node is used to
160 -- cross-reference the location of the duplication.
162 package Externals is new Table.Table (
163 Table_Component_Type => Node_Id,
164 Table_Index_Type => Int,
165 Table_Low_Bound => 0,
166 Table_Initial => 100,
167 Table_Increment => 100,
168 Table_Name => "Name_Externals");
170 -------------------------------------
171 -- Local Subprograms and Variables --
172 -------------------------------------
174 function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
175 -- This routine is used for possible casing adjustment of an explicit
176 -- external name supplied as a string literal (the node N), according to
177 -- the casing requirement of Opt.External_Name_Casing. If this is set to
178 -- As_Is, then the string literal is returned unchanged, but if it is set
179 -- to Uppercase or Lowercase, then a new string literal with appropriate
180 -- casing is constructed.
182 procedure Analyze_Part_Of
186 Encap_Id : out Entity_Id;
187 Legal : out Boolean);
188 -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and
189 -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the
190 -- Part_Of indicator. Item_Id is the entity of an abstract state, object or
191 -- package instantiation. Encap denotes the encapsulating state or single
192 -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when
193 -- the indicator is legal.
195 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean;
196 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
197 -- Query whether a particular item appears in a mixed list of nodes and
198 -- entities. It is assumed that all nodes in the list have entities.
200 procedure Check_Postcondition_Use_In_Inlined_Subprogram
202 Spec_Id : Entity_Id);
203 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
204 -- Precondition, Refined_Post, and Test_Case. Emit a warning when pragma
205 -- Prag is associated with subprogram Spec_Id subject to Inline_Always,
206 -- and assertions are enabled.
208 procedure Check_State_And_Constituent_Use
212 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
213 -- Global and Initializes. Determine whether a state from list States and a
214 -- corresponding constituent from list Constits (if any) appear in the same
215 -- context denoted by Context. If this is the case, emit an error.
217 procedure Contract_Freeze_Error
218 (Contract_Id : Entity_Id;
219 Freeze_Id : Entity_Id);
220 -- Subsidiary to the analysis of pragmas Contract_Cases, Part_Of, Post, and
221 -- Pre. Emit a freezing-related error message where Freeze_Id is the entity
222 -- of a body which caused contract freezing and Contract_Id denotes the
223 -- entity of the affected contstruct.
225 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id);
226 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
227 -- Prag that duplicates previous pragma Prev.
229 function Find_Encapsulating_State
231 Constit_Id : Entity_Id) return Entity_Id;
232 -- Given the entity of a constituent Constit_Id, find the corresponding
233 -- encapsulating state which appears in States. The routine returns Empty
234 -- if no such state is found.
236 function Find_Related_Context
238 Do_Checks : Boolean := False) return Node_Id;
239 -- Subsidiary to the analysis of pragmas
242 -- Constant_After_Elaboration
246 -- Find the first source declaration or statement found while traversing
247 -- the previous node chain starting from pragma Prag. If flag Do_Checks is
248 -- set, the routine reports duplicate pragmas. The routine returns Empty
249 -- when reaching the start of the node chain.
251 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
252 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
253 -- original one, following the renaming chain) is returned. Otherwise the
254 -- entity is returned unchanged. Should be in Einfo???
256 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type;
257 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
258 -- Get_SPARK_Mode_From_Annotation. Convert a name into a corresponding
259 -- value of type SPARK_Mode_Type.
261 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean;
262 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
263 -- Determine whether dependency clause Clause is surrounded by extra
264 -- parentheses. If this is the case, issue an error message.
266 function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean;
267 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
268 -- pragma Depends. Determine whether the type of dependency item Item is
269 -- tagged, unconstrained array, unconstrained record or a record with at
270 -- least one unconstrained component.
272 procedure Record_Possible_Body_Reference
273 (State_Id : Entity_Id;
275 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
276 -- Global. Given an abstract state denoted by State_Id and a reference Ref
277 -- to it, determine whether the reference appears in a package body that
278 -- will eventually refine the state. If this is the case, record the
279 -- reference for future checks (see Analyze_Refined_State_In_Decls).
281 procedure Resolve_State (N : Node_Id);
282 -- Handle the overloading of state names by functions. When N denotes a
283 -- function, this routine finds the corresponding state and sets the entity
284 -- of N to that of the state.
286 procedure Rewrite_Assertion_Kind
288 From_Policy : Boolean := False);
289 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
290 -- then it is rewritten as an identifier with the corresponding special
291 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
292 -- and Check_Policy. If the names are Precondition or Postcondition, this
293 -- combination is deprecated in favor of Assertion_Policy and Ada2012
294 -- Aspect names. The parameter From_Policy indicates that the pragma
295 -- is the old non-standard Check_Policy and not a rewritten pragma.
297 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id);
298 -- Place semantic information on the argument of an Elaborate/Elaborate_All
299 -- pragma. Entity name for unit and its parents is taken from item in
300 -- previous with_clause that mentions the unit.
302 procedure Validate_Compile_Time_Warning_Or_Error
305 -- Common processing for Compile_Time_Error and Compile_Time_Warning of
306 -- pragma N. Called when the pragma is processed as part of its regular
307 -- analysis but also called after calling the back end to validate these
308 -- pragmas for size and alignment appropriateness.
310 procedure Defer_Compile_Time_Warning_Error_To_BE (N : Node_Id);
311 -- N is a pragma Compile_Time_Error or Compile_Warning_Error whose boolean
312 -- expression is not known at compile time during the front end. This
313 -- procedure makes an entry in a table. The actual checking is performed by
314 -- Validate_Compile_Time_Warning_Errors, which is invoked after calling the
317 Dummy : Integer := 0;
318 pragma Volatile (Dummy);
319 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
322 pragma No_Inline (ip);
323 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
324 -- is just to help debugging the front end. If a pragma Inspection_Point
325 -- is added to a source program, then breaking on ip will get you to that
326 -- point in the program.
329 pragma No_Inline (rv);
330 -- This is a dummy function called by the processing for pragma Reviewable.
331 -- It is there for assisting front end debugging. By placing a Reviewable
332 -- pragma in the source program, a breakpoint on rv catches this place in
333 -- the source, allowing convenient stepping to the point of interest.
335 ------------------------------------------------------
336 -- Table for Defer_Compile_Time_Warning_Error_To_BE --
337 ------------------------------------------------------
339 -- The following table collects pragmas Compile_Time_Error and Compile_
340 -- Time_Warning for validation. Entries are made by calls to subprogram
341 -- Defer_Compile_Time_Warning_Error_To_BE, and the call to the procedure
342 -- Validate_Compile_Time_Warning_Errors does the actual error checking
343 -- and posting of warning and error messages. The reason for this delayed
344 -- processing is to take advantage of back-annotations of attributes size
345 -- and alignment values performed by the back end.
347 -- Note: the reason we store a Source_Ptr value instead of a Node_Id is
348 -- that by the time Validate_Compile_Time_Warning_Errors is called, Sprint
349 -- will already have modified all Sloc values if the -gnatD option is set.
351 type CTWE_Entry is record
353 -- Source location used in warnings and error messages
356 -- Pragma Compile_Time_Error or Compile_Time_Warning
359 -- The scope which encloses the pragma
362 package Compile_Time_Warnings_Errors is new Table.Table (
363 Table_Component_Type => CTWE_Entry,
364 Table_Index_Type => Int,
365 Table_Low_Bound => 1,
367 Table_Increment => 200,
368 Table_Name => "Compile_Time_Warnings_Errors");
370 -------------------------------
371 -- Adjust_External_Name_Case --
372 -------------------------------
374 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
378 -- Adjust case of literal if required
380 if Opt.External_Name_Exp_Casing = As_Is then
384 -- Copy existing string
390 for J in 1 .. String_Length (Strval (N)) loop
391 CC := Get_String_Char (Strval (N), J);
393 if Opt.External_Name_Exp_Casing = Uppercase
394 and then CC >= Get_Char_Code ('a')
395 and then CC <= Get_Char_Code ('z')
397 Store_String_Char (CC - 32);
399 elsif Opt.External_Name_Exp_Casing = Lowercase
400 and then CC >= Get_Char_Code ('A')
401 and then CC <= Get_Char_Code ('Z')
403 Store_String_Char (CC + 32);
406 Store_String_Char (CC);
411 Make_String_Literal (Sloc (N),
412 Strval => End_String);
414 end Adjust_External_Name_Case;
416 -----------------------------------------
417 -- Analyze_Contract_Cases_In_Decl_Part --
418 -----------------------------------------
420 -- WARNING: This routine manages Ghost regions. Return statements must be
421 -- replaced by gotos which jump to the end of the routine and restore the
424 procedure Analyze_Contract_Cases_In_Decl_Part
426 Freeze_Id : Entity_Id := Empty)
428 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
429 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
431 Others_Seen : Boolean := False;
432 -- This flag is set when an "others" choice is encountered. It is used
433 -- to detect multiple illegal occurrences of "others".
435 procedure Analyze_Contract_Case (CCase : Node_Id);
436 -- Verify the legality of a single contract case
438 ---------------------------
439 -- Analyze_Contract_Case --
440 ---------------------------
442 procedure Analyze_Contract_Case (CCase : Node_Id) is
443 Case_Guard : Node_Id;
446 Extra_Guard : Node_Id;
449 if Nkind (CCase) = N_Component_Association then
450 Case_Guard := First (Choices (CCase));
451 Conseq := Expression (CCase);
453 -- Each contract case must have exactly one case guard
455 Extra_Guard := Next (Case_Guard);
457 if Present (Extra_Guard) then
459 ("contract case must have exactly one case guard",
463 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
465 if Nkind (Case_Guard) = N_Others_Choice then
468 ("only one others choice allowed in contract cases",
474 elsif Others_Seen then
476 ("others must be the last choice in contract cases", N);
479 -- Preanalyze the case guard and consequence
481 if Nkind (Case_Guard) /= N_Others_Choice then
482 Errors := Serious_Errors_Detected;
483 Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean);
485 -- Emit a clarification message when the case guard contains
486 -- at least one undefined reference, possibly due to contract
489 if Errors /= Serious_Errors_Detected
490 and then Present (Freeze_Id)
491 and then Has_Undefined_Reference (Case_Guard)
493 Contract_Freeze_Error (Spec_Id, Freeze_Id);
497 Errors := Serious_Errors_Detected;
498 Preanalyze_Assert_Expression (Conseq, Standard_Boolean);
500 -- Emit a clarification message when the consequence contains
501 -- at least one undefined reference, possibly due to contract
504 if Errors /= Serious_Errors_Detected
505 and then Present (Freeze_Id)
506 and then Has_Undefined_Reference (Conseq)
508 Contract_Freeze_Error (Spec_Id, Freeze_Id);
511 -- The contract case is malformed
514 Error_Msg_N ("wrong syntax in contract case", CCase);
516 end Analyze_Contract_Case;
520 CCases : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
522 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
523 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
524 -- Save the Ghost-related attributes to restore on exit
527 Restore_Scope : Boolean := False;
529 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
532 -- Do not analyze the pragma multiple times
534 if Is_Analyzed_Pragma (N) then
538 -- Set the Ghost mode in effect from the pragma. Due to the delayed
539 -- analysis of the pragma, the Ghost mode at point of declaration and
540 -- point of analysis may not necessarily be the same. Use the mode in
541 -- effect at the point of declaration.
545 -- Single and multiple contract cases must appear in aggregate form. If
546 -- this is not the case, then either the parser of the analysis of the
547 -- pragma failed to produce an aggregate.
549 pragma Assert (Nkind (CCases) = N_Aggregate);
551 if Present (Component_Associations (CCases)) then
553 -- Ensure that the formal parameters are visible when analyzing all
554 -- clauses. This falls out of the general rule of aspects pertaining
555 -- to subprogram declarations.
557 if not In_Open_Scopes (Spec_Id) then
558 Restore_Scope := True;
559 Push_Scope (Spec_Id);
561 if Is_Generic_Subprogram (Spec_Id) then
562 Install_Generic_Formals (Spec_Id);
564 Install_Formals (Spec_Id);
568 CCase := First (Component_Associations (CCases));
569 while Present (CCase) loop
570 Analyze_Contract_Case (CCase);
574 if Restore_Scope then
578 -- Currently it is not possible to inline pre/postconditions on a
579 -- subprogram subject to pragma Inline_Always.
581 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
583 -- Otherwise the pragma is illegal
586 Error_Msg_N ("wrong syntax for contract 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 (Item_Id) in
701 E_Generic_In_Out_Parameter | 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 (Item_Id) in E_Constant | E_Loop_Parameter
978 -- Current instances of concurrent types
980 Ekind (Item_Id) in E_Protected_Type | E_Task_Type
985 Ekind (Item_Id) in E_Generic_In_Out_Parameter
986 | E_Generic_In_Parameter
994 Ekind (Item_Id) in 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 (Spec_Id) in 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 (Item_Id) in 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 (Item_Id) in 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 (Spec_Id) in 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 (Item_Id) in 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
2005 -- Task discriminants cannot appear in the [Refined_]Depends
2006 -- contract, but must be present for the analysis so that we
2007 -- can reject them with an informative error message.
2009 if Has_Discriminants (Spec_Id) then
2010 Install_Discriminants (Spec_Id);
2013 elsif Is_Generic_Subprogram (Spec_Id) then
2014 Install_Generic_Formals (Spec_Id);
2017 Install_Formals (Spec_Id);
2021 Clause := First (Component_Associations (Deps));
2022 while Present (Clause) loop
2023 Errors := Serious_Errors_Detected;
2025 -- The normalization mechanism may create extra clauses that
2026 -- contain replicated input and output names. There is no need
2027 -- to reanalyze them.
2029 if not Analyzed (Clause) then
2030 Set_Analyzed (Clause);
2032 Analyze_Dependency_Clause
2034 Is_Last => Clause = Last_Clause);
2037 -- Do not normalize a clause if errors were detected (count
2038 -- of Serious_Errors has increased) because the inputs and/or
2039 -- outputs may denote illegal items.
2041 if Serious_Errors_Detected = Errors then
2042 Normalize_Clause (Clause);
2048 if Restore_Scope then
2052 -- Verify that every input or output of the subprogram appear in a
2055 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
2056 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
2057 Check_Function_Return;
2059 -- The dependency list is malformed. This is a syntax error, always
2063 Error_Msg_N ("malformed dependency relation", Deps);
2067 -- The top level dependency relation is malformed. This is a syntax
2068 -- error, always report.
2071 Error_Msg_N ("malformed dependency relation", Deps);
2075 -- Ensure that a state and a corresponding constituent do not appear
2076 -- together in pragma [Refined_]Depends.
2078 Check_State_And_Constituent_Use
2079 (States => States_Seen,
2080 Constits => Constits_Seen,
2084 Set_Is_Analyzed_Pragma (N);
2085 end Analyze_Depends_In_Decl_Part;
2087 --------------------------------------------
2088 -- Analyze_External_Property_In_Decl_Part --
2089 --------------------------------------------
2091 procedure Analyze_External_Property_In_Decl_Part
2093 Expr_Val : out Boolean)
2095 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pragma_Name (N));
2096 Arg1 : constant Node_Id :=
2097 First (Pragma_Argument_Associations (N));
2098 Obj_Decl : constant Node_Id := Find_Related_Context (N);
2099 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
2105 -- Do not analyze the pragma multiple times
2107 if Is_Analyzed_Pragma (N) then
2111 Error_Msg_Name_1 := Pragma_Name (N);
2113 -- An external property pragma must apply to an effectively volatile
2114 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
2115 -- The check is performed at the end of the declarative region due to a
2116 -- possible out-of-order arrangement of pragmas:
2119 -- pragma Async_Readers (Obj);
2120 -- pragma Volatile (Obj);
2122 if Prag_Id /= Pragma_No_Caching
2123 and then not Is_Effectively_Volatile (Obj_Id)
2125 if Ekind (Obj_Id) = E_Variable
2126 and then No_Caching_Enabled (Obj_Id)
2129 ("illegal combination of external property % and property "
2130 & """No_Caching"" (SPARK RM 7.1.2(6))", N);
2133 ("external property % must apply to a volatile type or object",
2137 -- Pragma No_Caching should only apply to volatile variables of
2138 -- a non-effectively volatile type (SPARK RM 7.1.2).
2140 elsif Prag_Id = Pragma_No_Caching then
2141 if Is_Effectively_Volatile (Etype (Obj_Id)) then
2142 SPARK_Msg_N ("property % must not apply to an object of "
2143 & "an effectively volatile type", N);
2144 elsif not Is_Volatile (Obj_Id) then
2145 SPARK_Msg_N ("property % must apply to a volatile object", N);
2149 -- Ensure that the Boolean expression (if present) is static. A missing
2150 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
2154 if Present (Arg1) then
2155 Expr := Get_Pragma_Arg (Arg1);
2157 if Is_OK_Static_Expression (Expr) then
2158 Expr_Val := Is_True (Expr_Value (Expr));
2162 Set_Is_Analyzed_Pragma (N);
2163 end Analyze_External_Property_In_Decl_Part;
2165 ---------------------------------
2166 -- Analyze_Global_In_Decl_Part --
2167 ---------------------------------
2169 procedure Analyze_Global_In_Decl_Part (N : Node_Id) is
2170 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
2171 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
2172 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
2174 Constits_Seen : Elist_Id := No_Elist;
2175 -- A list containing the entities of all constituents processed so far.
2176 -- It aids in detecting illegal usage of a state and a corresponding
2177 -- constituent in pragma [Refinde_]Global.
2179 Seen : Elist_Id := No_Elist;
2180 -- A list containing the entities of all the items processed so far. It
2181 -- plays a role in detecting distinct entities.
2183 States_Seen : Elist_Id := No_Elist;
2184 -- A list containing the entities of all states processed so far. It
2185 -- helps in detecting illegal usage of a state and a corresponding
2186 -- constituent in pragma [Refined_]Global.
2188 In_Out_Seen : Boolean := False;
2189 Input_Seen : Boolean := False;
2190 Output_Seen : Boolean := False;
2191 Proof_Seen : Boolean := False;
2192 -- Flags used to verify the consistency of modes
2194 procedure Analyze_Global_List
2196 Global_Mode : Name_Id := Name_Input);
2197 -- Verify the legality of a single global list declaration. Global_Mode
2198 -- denotes the current mode in effect.
2200 -------------------------
2201 -- Analyze_Global_List --
2202 -------------------------
2204 procedure Analyze_Global_List
2206 Global_Mode : Name_Id := Name_Input)
2208 procedure Analyze_Global_Item
2210 Global_Mode : Name_Id);
2211 -- Verify the legality of a single global item declaration denoted by
2212 -- Item. Global_Mode denotes the current mode in effect.
2214 procedure Check_Duplicate_Mode
2216 Status : in out Boolean);
2217 -- Flag Status denotes whether a particular mode has been seen while
2218 -- processing a global list. This routine verifies that Mode is not a
2219 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2221 procedure Check_Mode_Restriction_In_Enclosing_Context
2223 Item_Id : Entity_Id);
2224 -- Verify that an item of mode In_Out or Output does not appear as
2225 -- an input in the Global aspect of an enclosing subprogram or task
2226 -- unit. If this is the case, emit an error. Item and Item_Id are
2227 -- respectively the item and its entity.
2229 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id);
2230 -- Mode denotes either In_Out or Output. Depending on the kind of the
2231 -- related subprogram, emit an error if those two modes apply to a
2232 -- function (SPARK RM 6.1.4(10)).
2234 -------------------------
2235 -- Analyze_Global_Item --
2236 -------------------------
2238 procedure Analyze_Global_Item
2240 Global_Mode : Name_Id)
2242 Item_Id : Entity_Id;
2245 -- Detect one of the following cases
2247 -- with Global => (null, Name)
2248 -- with Global => (Name_1, null, Name_2)
2249 -- with Global => (Name, null)
2251 if Nkind (Item) = N_Null then
2252 SPARK_Msg_N ("cannot mix null and non-null global items", Item);
2257 Resolve_State (Item);
2259 -- Find the entity of the item. If this is a renaming, climb the
2260 -- renaming chain to reach the root object. Renamings of non-
2261 -- entire objects do not yield an entity (Empty).
2263 Item_Id := Entity_Of (Item);
2265 if Present (Item_Id) then
2267 -- A global item may denote a formal parameter of an enclosing
2268 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2269 -- provide a better error diagnostic.
2271 if Is_Formal (Item_Id) then
2272 if Scope (Item_Id) = Spec_Id then
2274 (Fix_Msg (Spec_Id, "global item cannot reference "
2275 & "parameter of subprogram &"), Item, Spec_Id);
2279 -- A global item may denote a concurrent type as long as it is
2280 -- the current instance of an enclosing protected or task type
2281 -- (SPARK RM 6.1.4).
2283 elsif Ekind (Item_Id) in E_Protected_Type | E_Task_Type then
2284 if Is_CCT_Instance (Item_Id, Spec_Id) then
2286 -- Pragma [Refined_]Global associated with a protected
2287 -- subprogram cannot mention the current instance of a
2288 -- protected type because the instance behaves as a
2289 -- formal parameter.
2291 if Ekind (Item_Id) = E_Protected_Type then
2292 if Scope (Spec_Id) = Item_Id then
2293 Error_Msg_Name_1 := Chars (Item_Id);
2295 (Fix_Msg (Spec_Id, "global item of subprogram & "
2296 & "cannot reference current instance of "
2297 & "protected type %"), Item, Spec_Id);
2301 -- Pragma [Refined_]Global associated with a task type
2302 -- cannot mention the current instance of a task type
2303 -- because the instance behaves as a formal parameter.
2305 else pragma Assert (Ekind (Item_Id) = E_Task_Type);
2306 if Spec_Id = Item_Id then
2307 Error_Msg_Name_1 := Chars (Item_Id);
2309 (Fix_Msg (Spec_Id, "global item of subprogram & "
2310 & "cannot reference current instance of task "
2311 & "type %"), Item, Spec_Id);
2316 -- Otherwise the global item denotes a subtype mark that is
2317 -- not a current instance.
2321 ("invalid use of subtype mark in global list", Item);
2325 -- A global item may denote the anonymous object created for a
2326 -- single protected/task type as long as the current instance
2327 -- is the same single type (SPARK RM 6.1.4).
2329 elsif Is_Single_Concurrent_Object (Item_Id)
2330 and then Is_CCT_Instance (Etype (Item_Id), Spec_Id)
2332 -- Pragma [Refined_]Global associated with a protected
2333 -- subprogram cannot mention the current instance of a
2334 -- protected type because the instance behaves as a formal
2337 if Is_Single_Protected_Object (Item_Id) then
2338 if Scope (Spec_Id) = Etype (Item_Id) then
2339 Error_Msg_Name_1 := Chars (Item_Id);
2341 (Fix_Msg (Spec_Id, "global item of subprogram & "
2342 & "cannot reference current instance of protected "
2343 & "type %"), Item, Spec_Id);
2347 -- Pragma [Refined_]Global associated with a task type
2348 -- cannot mention the current instance of a task type
2349 -- because the instance behaves as a formal parameter.
2351 else pragma Assert (Is_Single_Task_Object (Item_Id));
2352 if Spec_Id = Item_Id then
2353 Error_Msg_Name_1 := Chars (Item_Id);
2355 (Fix_Msg (Spec_Id, "global item of subprogram & "
2356 & "cannot reference current instance of task "
2357 & "type %"), Item, Spec_Id);
2362 -- A formal object may act as a global item inside a generic
2364 elsif Is_Formal_Object (Item_Id) then
2367 -- The only legal references are those to abstract states,
2368 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2370 elsif Ekind (Item_Id) not in E_Abstract_State
2376 ("global item must denote object, state or current "
2377 & "instance of concurrent type", Item);
2379 if Ekind (Item_Id) in Named_Kind then
2381 ("\named number & is not an object", Item, Item);
2387 -- State related checks
2389 if Ekind (Item_Id) = E_Abstract_State then
2391 -- Package and subprogram bodies are instantiated
2392 -- individually in a separate compiler pass. Due to this
2393 -- mode of instantiation, the refinement of a state may
2394 -- no longer be visible when a subprogram body contract
2395 -- is instantiated. Since the generic template is legal,
2396 -- do not perform this check in the instance to circumvent
2402 -- An abstract state with visible refinement cannot appear
2403 -- in pragma [Refined_]Global as its place must be taken by
2404 -- some of its constituents (SPARK RM 6.1.4(7)).
2406 elsif Has_Visible_Refinement (Item_Id) then
2408 ("cannot mention state & in global refinement",
2410 SPARK_Msg_N ("\use its constituents instead", Item);
2413 -- An external state cannot appear as a global item of a
2414 -- nonvolatile function (SPARK RM 7.1.3(8)).
2416 elsif Is_External_State (Item_Id)
2417 and then Ekind (Spec_Id) in E_Function | E_Generic_Function
2418 and then not Is_Volatile_Function (Spec_Id)
2421 ("external state & cannot act as global item of "
2422 & "nonvolatile function", Item, Item_Id);
2425 -- If the reference to the abstract state appears in an
2426 -- enclosing package body that will eventually refine the
2427 -- state, record the reference for future checks.
2430 Record_Possible_Body_Reference
2431 (State_Id => Item_Id,
2435 -- Constant related checks
2437 elsif Ekind (Item_Id) = E_Constant
2438 and then not Is_Access_Type (Etype (Item_Id))
2441 -- Unless it is of an access type, a constant is a read-only
2442 -- item, therefore it cannot act as an output.
2444 if Global_Mode in Name_In_Out | Name_Output then
2446 ("constant & cannot act as output", Item, Item_Id);
2450 -- Loop parameter related checks
2452 elsif Ekind (Item_Id) = E_Loop_Parameter then
2454 -- A loop parameter is a read-only item, therefore it cannot
2455 -- act as an output.
2457 if Global_Mode in Name_In_Out | Name_Output then
2459 ("loop parameter & cannot act as output",
2464 -- Variable related checks. These are only relevant when
2465 -- SPARK_Mode is on as they are not standard Ada legality
2468 elsif SPARK_Mode = On
2469 and then Ekind (Item_Id) = E_Variable
2470 and then Is_Effectively_Volatile_For_Reading (Item_Id)
2472 -- An effectively volatile object for reading cannot appear
2473 -- as a global item of a nonvolatile function (SPARK RM
2476 if Ekind (Spec_Id) in E_Function | E_Generic_Function
2477 and then not Is_Volatile_Function (Spec_Id)
2480 ("volatile object & cannot act as global item of a "
2481 & "function", Item, Item_Id);
2484 -- An effectively volatile object with external property
2485 -- Effective_Reads set to True must have mode Output or
2486 -- In_Out (SPARK RM 7.1.3(10)).
2488 elsif Effective_Reads_Enabled (Item_Id)
2489 and then Global_Mode = Name_Input
2492 ("volatile object & with property Effective_Reads must "
2493 & "have mode In_Out or Output", Item, Item_Id);
2498 -- When the item renames an entire object, replace the item
2499 -- with a reference to the object.
2501 if Entity (Item) /= Item_Id then
2502 Rewrite (Item, New_Occurrence_Of (Item_Id, Sloc (Item)));
2506 -- Some form of illegal construct masquerading as a name
2507 -- (SPARK RM 6.1.4(4)).
2511 ("global item must denote object, state or current instance "
2512 & "of concurrent type", Item);
2516 -- Verify that an output does not appear as an input in an
2517 -- enclosing subprogram.
2519 if Global_Mode in Name_In_Out | Name_Output then
2520 Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id);
2523 -- The same entity might be referenced through various way.
2524 -- Check the entity of the item rather than the item itself
2525 -- (SPARK RM 6.1.4(10)).
2527 if Contains (Seen, Item_Id) then
2528 SPARK_Msg_N ("duplicate global item", Item);
2530 -- Add the entity of the current item to the list of processed
2534 Append_New_Elmt (Item_Id, Seen);
2536 if Ekind (Item_Id) = E_Abstract_State then
2537 Append_New_Elmt (Item_Id, States_Seen);
2539 -- The variable may eventually become a constituent of a single
2540 -- protected/task type. Record the reference now and verify its
2541 -- legality when analyzing the contract of the variable
2544 elsif Ekind (Item_Id) = E_Variable then
2545 Record_Possible_Part_Of_Reference
2550 if Ekind (Item_Id) in E_Abstract_State | E_Constant | E_Variable
2551 and then Present (Encapsulating_State (Item_Id))
2553 Append_New_Elmt (Item_Id, Constits_Seen);
2556 end Analyze_Global_Item;
2558 --------------------------
2559 -- Check_Duplicate_Mode --
2560 --------------------------
2562 procedure Check_Duplicate_Mode
2564 Status : in out Boolean)
2568 SPARK_Msg_N ("duplicate global mode", Mode);
2572 end Check_Duplicate_Mode;
2574 -------------------------------------------------
2575 -- Check_Mode_Restriction_In_Enclosing_Context --
2576 -------------------------------------------------
2578 procedure Check_Mode_Restriction_In_Enclosing_Context
2580 Item_Id : Entity_Id)
2582 Context : Entity_Id;
2584 Inputs : Elist_Id := No_Elist;
2585 Outputs : Elist_Id := No_Elist;
2588 -- Traverse the scope stack looking for enclosing subprograms or
2589 -- tasks subject to pragma [Refined_]Global.
2591 Context := Scope (Subp_Id);
2592 while Present (Context) and then Context /= Standard_Standard loop
2594 -- For a single task type, retrieve the corresponding object to
2595 -- which pragma [Refined_]Global is attached.
2597 if Ekind (Context) = E_Task_Type
2598 and then Is_Single_Concurrent_Type (Context)
2600 Context := Anonymous_Object (Context);
2603 if (Is_Subprogram (Context)
2604 or else Ekind (Context) = E_Task_Type
2605 or else Is_Single_Task_Object (Context))
2607 (Present (Get_Pragma (Context, Pragma_Global))
2609 Present (Get_Pragma (Context, Pragma_Refined_Global)))
2611 Collect_Subprogram_Inputs_Outputs
2612 (Subp_Id => Context,
2613 Subp_Inputs => Inputs,
2614 Subp_Outputs => Outputs,
2615 Global_Seen => Dummy);
2617 -- The item is classified as In_Out or Output but appears as
2618 -- an Input in an enclosing subprogram or task unit (SPARK
2621 if Appears_In (Inputs, Item_Id)
2622 and then not Appears_In (Outputs, Item_Id)
2625 ("global item & cannot have mode In_Out or Output",
2628 if Is_Subprogram (Context) then
2630 (Fix_Msg (Subp_Id, "\item already appears as input "
2631 & "of subprogram &"), Item, Context);
2634 (Fix_Msg (Subp_Id, "\item already appears as input "
2635 & "of task &"), Item, Context);
2638 -- Stop the traversal once an error has been detected
2644 Context := Scope (Context);
2646 end Check_Mode_Restriction_In_Enclosing_Context;
2648 ----------------------------------------
2649 -- Check_Mode_Restriction_In_Function --
2650 ----------------------------------------
2652 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
2654 if Ekind (Spec_Id) in E_Function | E_Generic_Function then
2656 ("global mode & is not applicable to functions", Mode);
2658 end Check_Mode_Restriction_In_Function;
2666 -- Start of processing for Analyze_Global_List
2669 if Nkind (List) = N_Null then
2670 Set_Analyzed (List);
2672 -- Single global item declaration
2674 elsif Nkind (List) in N_Expanded_Name
2676 | N_Selected_Component
2678 Analyze_Global_Item (List, Global_Mode);
2680 -- Simple global list or moded global list declaration
2682 elsif Nkind (List) = N_Aggregate then
2683 Set_Analyzed (List);
2685 -- The declaration of a simple global list appear as a collection
2688 if Present (Expressions (List)) then
2689 if Present (Component_Associations (List)) then
2691 ("cannot mix moded and non-moded global lists", List);
2694 Item := First (Expressions (List));
2695 while Present (Item) loop
2696 Analyze_Global_Item (Item, Global_Mode);
2700 -- The declaration of a moded global list appears as a collection
2701 -- of component associations where individual choices denote
2704 elsif Present (Component_Associations (List)) then
2705 if Present (Expressions (List)) then
2707 ("cannot mix moded and non-moded global lists", List);
2710 Assoc := First (Component_Associations (List));
2711 while Present (Assoc) loop
2712 Mode := First (Choices (Assoc));
2714 if Nkind (Mode) = N_Identifier then
2715 if Chars (Mode) = Name_In_Out then
2716 Check_Duplicate_Mode (Mode, In_Out_Seen);
2717 Check_Mode_Restriction_In_Function (Mode);
2719 elsif Chars (Mode) = Name_Input then
2720 Check_Duplicate_Mode (Mode, Input_Seen);
2722 elsif Chars (Mode) = Name_Output then
2723 Check_Duplicate_Mode (Mode, Output_Seen);
2724 Check_Mode_Restriction_In_Function (Mode);
2726 elsif Chars (Mode) = Name_Proof_In then
2727 Check_Duplicate_Mode (Mode, Proof_Seen);
2730 SPARK_Msg_N ("invalid mode selector", Mode);
2734 SPARK_Msg_N ("invalid mode selector", Mode);
2737 -- Items in a moded list appear as a collection of
2738 -- expressions. Reuse the existing machinery to analyze
2742 (List => Expression (Assoc),
2743 Global_Mode => Chars (Mode));
2751 raise Program_Error;
2754 -- Any other attempt to declare a global item is illegal. This is a
2755 -- syntax error, always report.
2758 Error_Msg_N ("malformed global list", List);
2760 end Analyze_Global_List;
2764 Items : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
2766 Restore_Scope : Boolean := False;
2768 -- Start of processing for Analyze_Global_In_Decl_Part
2771 -- Do not analyze the pragma multiple times
2773 if Is_Analyzed_Pragma (N) then
2777 -- There is nothing to be done for a null global list
2779 if Nkind (Items) = N_Null then
2780 Set_Analyzed (Items);
2782 -- Analyze the various forms of global lists and items. Note that some
2783 -- of these may be malformed in which case the analysis emits error
2787 -- When pragma [Refined_]Global appears on a single concurrent type,
2788 -- it is relocated to the anonymous object.
2790 if Is_Single_Concurrent_Object (Spec_Id) then
2793 -- Ensure that the formal parameters are visible when processing an
2794 -- item. This falls out of the general rule of aspects pertaining to
2795 -- subprogram declarations.
2797 elsif not In_Open_Scopes (Spec_Id) then
2798 Restore_Scope := True;
2799 Push_Scope (Spec_Id);
2801 if Ekind (Spec_Id) = E_Task_Type then
2803 -- Task discriminants cannot appear in the [Refined_]Global
2804 -- contract, but must be present for the analysis so that we
2805 -- can reject them with an informative error message.
2807 if Has_Discriminants (Spec_Id) then
2808 Install_Discriminants (Spec_Id);
2811 elsif Is_Generic_Subprogram (Spec_Id) then
2812 Install_Generic_Formals (Spec_Id);
2815 Install_Formals (Spec_Id);
2819 Analyze_Global_List (Items);
2821 if Restore_Scope then
2826 -- Ensure that a state and a corresponding constituent do not appear
2827 -- together in pragma [Refined_]Global.
2829 Check_State_And_Constituent_Use
2830 (States => States_Seen,
2831 Constits => Constits_Seen,
2834 Set_Is_Analyzed_Pragma (N);
2835 end Analyze_Global_In_Decl_Part;
2837 --------------------------------------------
2838 -- Analyze_Initial_Condition_In_Decl_Part --
2839 --------------------------------------------
2841 -- WARNING: This routine manages Ghost regions. Return statements must be
2842 -- replaced by gotos which jump to the end of the routine and restore the
2845 procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is
2846 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2847 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2848 Expr : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
2850 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
2851 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
2852 -- Save the Ghost-related attributes to restore on exit
2855 -- Do not analyze the pragma multiple times
2857 if Is_Analyzed_Pragma (N) then
2861 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2862 -- analysis of the pragma, the Ghost mode at point of declaration and
2863 -- point of analysis may not necessarily be the same. Use the mode in
2864 -- effect at the point of declaration.
2868 -- The expression is preanalyzed because it has not been moved to its
2869 -- final place yet. A direct analysis may generate side effects and this
2870 -- is not desired at this point.
2872 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
2873 Set_Is_Analyzed_Pragma (N);
2875 Restore_Ghost_Region (Saved_GM, Saved_IGR);
2876 end Analyze_Initial_Condition_In_Decl_Part;
2878 --------------------------------------
2879 -- Analyze_Initializes_In_Decl_Part --
2880 --------------------------------------
2882 procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is
2883 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2884 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2886 Constits_Seen : Elist_Id := No_Elist;
2887 -- A list containing the entities of all constituents processed so far.
2888 -- It aids in detecting illegal usage of a state and a corresponding
2889 -- constituent in pragma Initializes.
2891 Items_Seen : Elist_Id := No_Elist;
2892 -- A list of all initialization items processed so far. This list is
2893 -- used to detect duplicate items.
2895 States_And_Objs : Elist_Id := No_Elist;
2896 -- A list of all abstract states and objects declared in the visible
2897 -- declarations of the related package. This list is used to detect the
2898 -- legality of initialization items.
2900 States_Seen : Elist_Id := No_Elist;
2901 -- A list containing the entities of all states processed so far. It
2902 -- helps in detecting illegal usage of a state and a corresponding
2903 -- constituent in pragma Initializes.
2905 procedure Analyze_Initialization_Item (Item : Node_Id);
2906 -- Verify the legality of a single initialization item
2908 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id);
2909 -- Verify the legality of a single initialization item followed by a
2910 -- list of input items.
2912 procedure Collect_States_And_Objects (Pack_Decl : Node_Id);
2913 -- Inspect the visible declarations of the related package and gather
2914 -- the entities of all abstract states and objects in States_And_Objs.
2916 ---------------------------------
2917 -- Analyze_Initialization_Item --
2918 ---------------------------------
2920 procedure Analyze_Initialization_Item (Item : Node_Id) is
2921 Item_Id : Entity_Id;
2925 Resolve_State (Item);
2927 if Is_Entity_Name (Item) then
2928 Item_Id := Entity_Of (Item);
2930 if Present (Item_Id)
2931 and then Ekind (Item_Id) in
2932 E_Abstract_State | E_Constant | E_Variable
2934 -- When the initialization item is undefined, it appears as
2935 -- Any_Id. Do not continue with the analysis of the item.
2937 if Item_Id = Any_Id then
2940 -- The state or variable must be declared in the visible
2941 -- declarations of the package (SPARK RM 7.1.5(7)).
2943 elsif not Contains (States_And_Objs, Item_Id) then
2944 Error_Msg_Name_1 := Chars (Pack_Id);
2946 ("initialization item & must appear in the visible "
2947 & "declarations of package %", Item, Item_Id);
2949 -- Detect a duplicate use of the same initialization item
2950 -- (SPARK RM 7.1.5(5)).
2952 elsif Contains (Items_Seen, Item_Id) then
2953 SPARK_Msg_N ("duplicate initialization item", Item);
2955 -- The item is legal, add it to the list of processed states
2959 Append_New_Elmt (Item_Id, Items_Seen);
2961 if Ekind (Item_Id) = E_Abstract_State then
2962 Append_New_Elmt (Item_Id, States_Seen);
2965 if Present (Encapsulating_State (Item_Id)) then
2966 Append_New_Elmt (Item_Id, Constits_Seen);
2970 -- The item references something that is not a state or object
2971 -- (SPARK RM 7.1.5(3)).
2975 ("initialization item must denote object or state", Item);
2978 -- Some form of illegal construct masquerading as a name
2979 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2983 ("initialization item must denote object or state", Item);
2985 end Analyze_Initialization_Item;
2987 ---------------------------------------------
2988 -- Analyze_Initialization_Item_With_Inputs --
2989 ---------------------------------------------
2991 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is
2992 Inputs_Seen : Elist_Id := No_Elist;
2993 -- A list of all inputs processed so far. This list is used to detect
2994 -- duplicate uses of an input.
2996 Non_Null_Seen : Boolean := False;
2997 Null_Seen : Boolean := False;
2998 -- Flags used to check the legality of an input list
3000 procedure Analyze_Input_Item (Input : Node_Id);
3001 -- Verify the legality of a single input item
3003 ------------------------
3004 -- Analyze_Input_Item --
3005 ------------------------
3007 procedure Analyze_Input_Item (Input : Node_Id) is
3008 Input_Id : Entity_Id;
3013 if Nkind (Input) = N_Null then
3016 ("multiple null initializations not allowed", Item);
3018 elsif Non_Null_Seen then
3020 ("cannot mix null and non-null initialization item", Item);
3028 Non_Null_Seen := True;
3032 ("cannot mix null and non-null initialization item", Item);
3036 Resolve_State (Input);
3038 if Is_Entity_Name (Input) then
3039 Input_Id := Entity_Of (Input);
3041 if Present (Input_Id)
3042 and then Ekind (Input_Id) in E_Abstract_State
3044 | E_Generic_In_Out_Parameter
3045 | E_Generic_In_Parameter
3047 | E_In_Out_Parameter
3053 -- The input cannot denote states or objects declared
3054 -- within the related package (SPARK RM 7.1.5(4)).
3056 if Within_Scope (Input_Id, Current_Scope) then
3058 -- Do not consider generic formal parameters or their
3059 -- respective mappings to generic formals. Even though
3060 -- the formals appear within the scope of the package,
3061 -- it is allowed for an initialization item to depend
3062 -- on an input item.
3064 if Ekind (Input_Id) in E_Generic_In_Out_Parameter
3065 | E_Generic_In_Parameter
3069 elsif Ekind (Input_Id) in E_Constant | E_Variable
3070 and then Present (Corresponding_Generic_Association
3071 (Declaration_Node (Input_Id)))
3076 Error_Msg_Name_1 := Chars (Pack_Id);
3078 ("input item & cannot denote a visible object or "
3079 & "state of package %", Input, Input_Id);
3084 -- Detect a duplicate use of the same input item
3085 -- (SPARK RM 7.1.5(5)).
3087 if Contains (Inputs_Seen, Input_Id) then
3088 SPARK_Msg_N ("duplicate input item", Input);
3092 -- At this point it is known that the input is legal. Add
3093 -- it to the list of processed inputs.
3095 Append_New_Elmt (Input_Id, Inputs_Seen);
3097 if Ekind (Input_Id) = E_Abstract_State then
3098 Append_New_Elmt (Input_Id, States_Seen);
3101 if Ekind (Input_Id) in E_Abstract_State
3104 and then Present (Encapsulating_State (Input_Id))
3106 Append_New_Elmt (Input_Id, Constits_Seen);
3109 -- The input references something that is not a state or an
3110 -- object (SPARK RM 7.1.5(3)).
3114 ("input item must denote object or state", Input);
3117 -- Some form of illegal construct masquerading as a name
3118 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
3122 ("input item must denote object or state", Input);
3125 end Analyze_Input_Item;
3129 Inputs : constant Node_Id := Expression (Item);
3133 Name_Seen : Boolean := False;
3134 -- A flag used to detect multiple item names
3136 -- Start of processing for Analyze_Initialization_Item_With_Inputs
3139 -- Inspect the name of an item with inputs
3141 Elmt := First (Choices (Item));
3142 while Present (Elmt) loop
3144 SPARK_Msg_N ("only one item allowed in initialization", Elmt);
3147 Analyze_Initialization_Item (Elmt);
3153 -- Multiple input items appear as an aggregate
3155 if Nkind (Inputs) = N_Aggregate then
3156 if Present (Expressions (Inputs)) then
3157 Input := First (Expressions (Inputs));
3158 while Present (Input) loop
3159 Analyze_Input_Item (Input);
3164 if Present (Component_Associations (Inputs)) then
3166 ("inputs must appear in named association form", Inputs);
3169 -- Single input item
3172 Analyze_Input_Item (Inputs);
3174 end Analyze_Initialization_Item_With_Inputs;
3176 --------------------------------
3177 -- Collect_States_And_Objects --
3178 --------------------------------
3180 procedure Collect_States_And_Objects (Pack_Decl : Node_Id) is
3181 Pack_Spec : constant Node_Id := Specification (Pack_Decl);
3182 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
3184 State_Elmt : Elmt_Id;
3187 -- Collect the abstract states defined in the package (if any)
3189 if Has_Non_Null_Abstract_State (Pack_Id) then
3190 State_Elmt := First_Elmt (Abstract_States (Pack_Id));
3191 while Present (State_Elmt) loop
3192 Append_New_Elmt (Node (State_Elmt), States_And_Objs);
3193 Next_Elmt (State_Elmt);
3197 -- Collect all objects that appear in the visible declarations of the
3200 if Present (Visible_Declarations (Pack_Spec)) then
3201 Decl := First (Visible_Declarations (Pack_Spec));
3202 while Present (Decl) loop
3203 if Comes_From_Source (Decl)
3204 and then Nkind (Decl) in N_Object_Declaration
3205 | N_Object_Renaming_Declaration
3207 Append_New_Elmt (Defining_Entity (Decl), States_And_Objs);
3209 elsif Nkind (Decl) = N_Package_Declaration then
3210 Collect_States_And_Objects (Decl);
3212 elsif Is_Single_Concurrent_Type_Declaration (Decl) then
3214 (Anonymous_Object (Defining_Entity (Decl)),
3221 end Collect_States_And_Objects;
3225 Inits : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
3228 -- Start of processing for Analyze_Initializes_In_Decl_Part
3231 -- Do not analyze the pragma multiple times
3233 if Is_Analyzed_Pragma (N) then
3237 -- Nothing to do when the initialization list is empty
3239 if Nkind (Inits) = N_Null then
3243 -- Single and multiple initialization clauses appear as an aggregate. If
3244 -- this is not the case, then either the parser or the analysis of the
3245 -- pragma failed to produce an aggregate.
3247 pragma Assert (Nkind (Inits) = N_Aggregate);
3249 -- Initialize the various lists used during analysis
3251 Collect_States_And_Objects (Pack_Decl);
3253 if Present (Expressions (Inits)) then
3254 Init := First (Expressions (Inits));
3255 while Present (Init) loop
3256 Analyze_Initialization_Item (Init);
3261 if Present (Component_Associations (Inits)) then
3262 Init := First (Component_Associations (Inits));
3263 while Present (Init) loop
3264 Analyze_Initialization_Item_With_Inputs (Init);
3269 -- Ensure that a state and a corresponding constituent do not appear
3270 -- together in pragma Initializes.
3272 Check_State_And_Constituent_Use
3273 (States => States_Seen,
3274 Constits => Constits_Seen,
3277 Set_Is_Analyzed_Pragma (N);
3278 end Analyze_Initializes_In_Decl_Part;
3280 ---------------------
3281 -- Analyze_Part_Of --
3282 ---------------------
3284 procedure Analyze_Part_Of
3286 Item_Id : Entity_Id;
3288 Encap_Id : out Entity_Id;
3289 Legal : out Boolean)
3291 procedure Check_Part_Of_Abstract_State;
3292 pragma Inline (Check_Part_Of_Abstract_State);
3293 -- Verify the legality of indicator Part_Of when the encapsulator is an
3296 procedure Check_Part_Of_Concurrent_Type;
3297 pragma Inline (Check_Part_Of_Concurrent_Type);
3298 -- Verify the legality of indicator Part_Of when the encapsulator is a
3299 -- single concurrent type.
3301 ----------------------------------
3302 -- Check_Part_Of_Abstract_State --
3303 ----------------------------------
3305 procedure Check_Part_Of_Abstract_State is
3306 Pack_Id : Entity_Id;
3307 Placement : State_Space_Kind;
3308 Parent_Unit : Entity_Id;
3311 -- Determine where the object, package instantiation or state lives
3312 -- with respect to the enclosing packages or package bodies.
3314 Find_Placement_In_State_Space
3315 (Item_Id => Item_Id,
3316 Placement => Placement,
3317 Pack_Id => Pack_Id);
3319 -- The item appears in a non-package construct with a declarative
3320 -- part (subprogram, block, etc). As such, the item is not allowed
3321 -- to be a part of an encapsulating state because the item is not
3324 if Placement = Not_In_Package then
3326 ("indicator Part_Of cannot appear in this context "
3327 & "(SPARK RM 7.2.6(5))", Indic);
3329 Error_Msg_Name_1 := Chars (Scope (Encap_Id));
3331 ("\& is not part of the hidden state of package %",
3335 -- The item appears in the visible state space of some package. In
3336 -- general this scenario does not warrant Part_Of except when the
3337 -- package is a nongeneric private child unit and the encapsulating
3338 -- state is declared in a parent unit or a public descendant of that
3341 elsif Placement = Visible_State_Space then
3342 if Is_Child_Unit (Pack_Id)
3343 and then not Is_Generic_Unit (Pack_Id)
3344 and then Is_Private_Descendant (Pack_Id)
3346 -- A variable or state abstraction which is part of the visible
3347 -- state of a nongeneric private child unit or its public
3348 -- descendants must have its Part_Of indicator specified. The
3349 -- Part_Of indicator must denote a state declared by either the
3350 -- parent unit of the private unit or by a public descendant of
3351 -- that parent unit.
3353 -- Find the nearest private ancestor (which can be the current
3356 Parent_Unit := Pack_Id;
3357 while Present (Parent_Unit) loop
3360 (Parent (Unit_Declaration_Node (Parent_Unit)));
3361 Parent_Unit := Scope (Parent_Unit);
3364 Parent_Unit := Scope (Parent_Unit);
3366 if not Is_Child_Or_Sibling (Pack_Id, Scope (Encap_Id)) then
3368 ("indicator Part_Of must denote abstract state of & or of "
3369 & "its public descendant (SPARK RM 7.2.6(3))",
3370 Indic, Parent_Unit);
3373 elsif Scope (Encap_Id) = Parent_Unit
3375 (Is_Ancestor_Package (Parent_Unit, Scope (Encap_Id))
3376 and then not Is_Private_Descendant (Scope (Encap_Id)))
3382 ("indicator Part_Of must denote abstract state of & or of "
3383 & "its public descendant (SPARK RM 7.2.6(3))",
3384 Indic, Parent_Unit);
3388 -- Indicator Part_Of is not needed when the related package is
3389 -- not a nongeneric private child unit or a public descendant
3394 ("indicator Part_Of cannot appear in this context "
3395 & "(SPARK RM 7.2.6(5))", Indic);
3397 Error_Msg_Name_1 := Chars (Pack_Id);
3399 ("\& is declared in the visible part of package %",
3404 -- When the item appears in the private state space of a package, the
3405 -- encapsulating state must be declared in the same package.
3407 elsif Placement = Private_State_Space then
3408 if Scope (Encap_Id) /= Pack_Id then
3410 ("indicator Part_Of must denote an abstract state of "
3411 & "package & (SPARK RM 7.2.6(2))", Indic, Pack_Id);
3413 Error_Msg_Name_1 := Chars (Pack_Id);
3415 ("\& is declared in the private part of package %",
3420 -- Items declared in the body state space of a package do not need
3421 -- Part_Of indicators as the refinement has already been seen.
3425 ("indicator Part_Of cannot appear in this context "
3426 & "(SPARK RM 7.2.6(5))", Indic);
3428 if Scope (Encap_Id) = Pack_Id then
3429 Error_Msg_Name_1 := Chars (Pack_Id);
3431 ("\& is declared in the body of package %", Indic, Item_Id);
3437 -- At this point it is known that the Part_Of indicator is legal
3440 end Check_Part_Of_Abstract_State;
3442 -----------------------------------
3443 -- Check_Part_Of_Concurrent_Type --
3444 -----------------------------------
3446 procedure Check_Part_Of_Concurrent_Type is
3447 function In_Proper_Order
3449 Second : Node_Id) return Boolean;
3450 pragma Inline (In_Proper_Order);
3451 -- Determine whether node First precedes node Second
3453 procedure Placement_Error;
3454 pragma Inline (Placement_Error);
3455 -- Emit an error concerning the illegal placement of the item with
3456 -- respect to the single concurrent type.
3458 ---------------------
3459 -- In_Proper_Order --
3460 ---------------------
3462 function In_Proper_Order
3464 Second : Node_Id) return Boolean
3469 if List_Containing (First) = List_Containing (Second) then
3471 while Present (N) loop
3481 end In_Proper_Order;
3483 ---------------------
3484 -- Placement_Error --
3485 ---------------------
3487 procedure Placement_Error is
3490 ("indicator Part_Of must denote a previously declared single "
3491 & "protected type or single task type", Encap);
3492 end Placement_Error;
3496 Conc_Typ : constant Entity_Id := Etype (Encap_Id);
3497 Encap_Decl : constant Node_Id := Declaration_Node (Encap_Id);
3498 Encap_Context : constant Node_Id := Parent (Encap_Decl);
3500 Item_Context : Node_Id;
3501 Item_Decl : Node_Id;
3502 Prv_Decls : List_Id;
3503 Vis_Decls : List_Id;
3505 -- Start of processing for Check_Part_Of_Concurrent_Type
3508 -- Only abstract states and variables can act as constituents of an
3509 -- encapsulating single concurrent type.
3511 if Ekind (Item_Id) in E_Abstract_State | E_Variable then
3514 -- The constituent is a constant
3516 elsif Ekind (Item_Id) = E_Constant then
3517 Error_Msg_Name_1 := Chars (Encap_Id);
3519 (Fix_Msg (Conc_Typ, "constant & cannot act as constituent of "
3520 & "single protected type %"), Indic, Item_Id);
3523 -- The constituent is a package instantiation
3526 Error_Msg_Name_1 := Chars (Encap_Id);
3528 (Fix_Msg (Conc_Typ, "package instantiation & cannot act as "
3529 & "constituent of single protected type %"), Indic, Item_Id);
3533 -- When the item denotes an abstract state of a nested package, use
3534 -- the declaration of the package to detect proper placement.
3539 -- with Abstract_State => (State with Part_Of => T)
3541 if Ekind (Item_Id) = E_Abstract_State then
3542 Item_Decl := Unit_Declaration_Node (Scope (Item_Id));
3544 Item_Decl := Declaration_Node (Item_Id);
3547 Item_Context := Parent (Item_Decl);
3549 -- The item and the single concurrent type must appear in the same
3550 -- declarative region, with the item following the declaration of
3551 -- the single concurrent type (SPARK RM 9(3)).
3553 if Item_Context = Encap_Context then
3554 if Nkind (Item_Context) in N_Package_Specification
3555 | N_Protected_Definition
3558 Prv_Decls := Private_Declarations (Item_Context);
3559 Vis_Decls := Visible_Declarations (Item_Context);
3561 -- The placement is OK when the single concurrent type appears
3562 -- within the visible declarations and the item in the private
3568 -- Constit : ... with Part_Of => PO;
3571 if List_Containing (Encap_Decl) = Vis_Decls
3572 and then List_Containing (Item_Decl) = Prv_Decls
3576 -- The placement is illegal when the item appears within the
3577 -- visible declarations and the single concurrent type is in
3578 -- the private declarations.
3581 -- Constit : ... with Part_Of => PO;
3586 elsif List_Containing (Item_Decl) = Vis_Decls
3587 and then List_Containing (Encap_Decl) = Prv_Decls
3592 -- Otherwise both the item and the single concurrent type are
3593 -- in the same list. Ensure that the declaration of the single
3594 -- concurrent type precedes that of the item.
3596 elsif not In_Proper_Order
3597 (First => Encap_Decl,
3598 Second => Item_Decl)
3604 -- Otherwise both the item and the single concurrent type are
3605 -- in the same list. Ensure that the declaration of the single
3606 -- concurrent type precedes that of the item.
3608 elsif not In_Proper_Order
3609 (First => Encap_Decl,
3610 Second => Item_Decl)
3616 -- Otherwise the item and the single concurrent type reside within
3617 -- unrelated regions.
3620 Error_Msg_Name_1 := Chars (Encap_Id);
3622 (Fix_Msg (Conc_Typ, "constituent & must be declared "
3623 & "immediately within the same region as single protected "
3624 & "type %"), Indic, Item_Id);
3628 -- At this point it is known that the Part_Of indicator is legal
3631 end Check_Part_Of_Concurrent_Type;
3633 -- Start of processing for Analyze_Part_Of
3636 -- Assume that the indicator is illegal
3642 N_Expanded_Name | N_Identifier | N_Selected_Component
3645 Resolve_State (Encap);
3647 Encap_Id := Entity (Encap);
3649 -- The encapsulator is an abstract state
3651 if Ekind (Encap_Id) = E_Abstract_State then
3654 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
3656 elsif Is_Single_Concurrent_Object (Encap_Id) then
3659 -- Otherwise the encapsulator is not a legal choice
3663 ("indicator Part_Of must denote abstract state, single "
3664 & "protected type or single task type", Encap);
3668 -- This is a syntax error, always report
3672 ("indicator Part_Of must denote abstract state, single protected "
3673 & "type or single task type", Encap);
3677 -- Catch a case where indicator Part_Of denotes the abstract view of a
3678 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3680 if From_Limited_With (Encap_Id)
3681 and then Present (Non_Limited_View (Encap_Id))
3682 and then Ekind (Non_Limited_View (Encap_Id)) = E_Variable
3684 SPARK_Msg_N ("indicator Part_Of must denote abstract state", Encap);
3685 SPARK_Msg_N ("\& denotes abstract view of object", Encap);
3689 -- The encapsulator is an abstract state
3691 if Ekind (Encap_Id) = E_Abstract_State then
3692 Check_Part_Of_Abstract_State;
3694 -- The encapsulator is a single concurrent type
3697 Check_Part_Of_Concurrent_Type;
3699 end Analyze_Part_Of;
3701 ----------------------------------
3702 -- Analyze_Part_Of_In_Decl_Part --
3703 ----------------------------------
3705 procedure Analyze_Part_Of_In_Decl_Part
3707 Freeze_Id : Entity_Id := Empty)
3709 Encap : constant Node_Id :=
3710 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
3711 Errors : constant Nat := Serious_Errors_Detected;
3712 Var_Decl : constant Node_Id := Find_Related_Context (N);
3713 Var_Id : constant Entity_Id := Defining_Entity (Var_Decl);
3714 Constits : Elist_Id;
3715 Encap_Id : Entity_Id;
3719 -- Detect any discrepancies between the placement of the variable with
3720 -- respect to general state space and the encapsulating state or single
3727 Encap_Id => Encap_Id,
3730 -- The Part_Of indicator turns the variable into a constituent of the
3731 -- encapsulating state or single concurrent type.
3734 pragma Assert (Present (Encap_Id));
3735 Constits := Part_Of_Constituents (Encap_Id);
3737 if No (Constits) then
3738 Constits := New_Elmt_List;
3739 Set_Part_Of_Constituents (Encap_Id, Constits);
3742 Append_Elmt (Var_Id, Constits);
3743 Set_Encapsulating_State (Var_Id, Encap_Id);
3745 -- A Part_Of constituent partially refines an abstract state. This
3746 -- property does not apply to protected or task units.
3748 if Ekind (Encap_Id) = E_Abstract_State then
3749 Set_Has_Partial_Visible_Refinement (Encap_Id);
3753 -- Emit a clarification message when the encapsulator is undefined,
3754 -- possibly due to contract freezing.
3756 if Errors /= Serious_Errors_Detected
3757 and then Present (Freeze_Id)
3758 and then Has_Undefined_Reference (Encap)
3760 Contract_Freeze_Error (Var_Id, Freeze_Id);
3762 end Analyze_Part_Of_In_Decl_Part;
3764 --------------------
3765 -- Analyze_Pragma --
3766 --------------------
3768 procedure Analyze_Pragma (N : Node_Id) is
3769 Loc : constant Source_Ptr := Sloc (N);
3771 Pname : Name_Id := Pragma_Name (N);
3772 -- Name of the source pragma, or name of the corresponding aspect for
3773 -- pragmas which originate in a source aspect. In the latter case, the
3774 -- name may be different from the pragma name.
3776 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
3778 Pragma_Exit : exception;
3779 -- This exception is used to exit pragma processing completely. It
3780 -- is used when an error is detected, and no further processing is
3781 -- required. It is also used if an earlier error has left the tree in
3782 -- a state where the pragma should not be processed.
3785 -- Number of pragma argument associations
3792 -- First five pragma arguments (pragma argument association nodes, or
3793 -- Empty if the corresponding argument does not exist).
3795 type Name_List is array (Natural range <>) of Name_Id;
3796 type Args_List is array (Natural range <>) of Node_Id;
3797 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3799 -----------------------
3800 -- Local Subprograms --
3801 -----------------------
3803 procedure Ada_2005_Pragma;
3804 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3805 -- Ada 95 mode, these are implementation defined pragmas, so should be
3806 -- caught by the No_Implementation_Pragmas restriction.
3808 procedure Ada_2012_Pragma;
3809 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3810 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3811 -- should be caught by the No_Implementation_Pragmas restriction.
3813 procedure Analyze_Depends_Global
3814 (Spec_Id : out Entity_Id;
3815 Subp_Decl : out Node_Id;
3816 Legal : out Boolean);
3817 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3818 -- legality of the placement and related context of the pragma. Spec_Id
3819 -- is the entity of the related subprogram. Subp_Decl is the declaration
3820 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3822 procedure Analyze_If_Present (Id : Pragma_Id);
3823 -- Inspect the remainder of the list containing pragma N and look for
3824 -- a pragma that matches Id. If found, analyze the pragma.
3826 procedure Analyze_Pre_Post_Condition;
3827 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3829 procedure Analyze_Refined_Depends_Global_Post
3830 (Spec_Id : out Entity_Id;
3831 Body_Id : out Entity_Id;
3832 Legal : out Boolean);
3833 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3834 -- Refined_Global and Refined_Post. Verify the legality of the placement
3835 -- and related context of the pragma. Spec_Id is the entity of the
3836 -- related subprogram. Body_Id is the entity of the subprogram body.
3837 -- Flag Legal is set when the pragma is legal.
3839 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False);
3840 -- Perform full analysis of pragma Unmodified and the write aspect of
3841 -- pragma Unused. Flag Is_Unused should be set when verifying the
3842 -- semantics of pragma Unused.
3844 procedure Analyze_Unreferenced_Or_Unused (Is_Unused : Boolean := False);
3845 -- Perform full analysis of pragma Unreferenced and the read aspect of
3846 -- pragma Unused. Flag Is_Unused should be set when verifying the
3847 -- semantics of pragma Unused.
3849 procedure Check_Ada_83_Warning;
3850 -- Issues a warning message for the current pragma if operating in Ada
3851 -- 83 mode (used for language pragmas that are not a standard part of
3852 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3855 procedure Check_Arg_Count (Required : Nat);
3856 -- Check argument count for pragma is equal to given parameter. If not,
3857 -- then issue an error message and raise Pragma_Exit.
3859 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3860 -- Arg which can either be a pragma argument association, in which case
3861 -- the check is applied to the expression of the association or an
3862 -- expression directly.
3864 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
3865 -- Check that an argument has the right form for an EXTERNAL_NAME
3866 -- parameter of an extended import/export pragma. The rule is that the
3867 -- name must be an identifier or string literal (in Ada 83 mode) or a
3868 -- static string expression (in Ada 95 mode).
3870 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
3871 -- Check the specified argument Arg to make sure that it is an
3872 -- identifier. If not give error and raise Pragma_Exit.
3874 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
3875 -- Check the specified argument Arg to make sure that it is an integer
3876 -- literal. If not give error and raise Pragma_Exit.
3878 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
3879 -- Check the specified argument Arg to make sure that it has the proper
3880 -- syntactic form for a local name and meets the semantic requirements
3881 -- for a local name. The local name is analyzed as part of the
3882 -- processing for this call. In addition, the local name is required
3883 -- to represent an entity at the library level.
3885 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
3886 -- Check the specified argument Arg to make sure that it has the proper
3887 -- syntactic form for a local name and meets the semantic requirements
3888 -- for a local name. The local name is analyzed as part of the
3889 -- processing for this call.
3891 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
3892 -- Check the specified argument Arg to make sure that it is a valid
3893 -- locking policy name. If not give error and raise Pragma_Exit.
3895 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
3896 -- Check the specified argument Arg to make sure that it is a valid
3897 -- elaboration policy name. If not give error and raise Pragma_Exit.
3899 procedure Check_Arg_Is_One_Of
3902 procedure Check_Arg_Is_One_Of
3904 N1, N2, N3 : Name_Id);
3905 procedure Check_Arg_Is_One_Of
3907 N1, N2, N3, N4 : Name_Id);
3908 procedure Check_Arg_Is_One_Of
3910 N1, N2, N3, N4, N5 : Name_Id);
3911 -- Check the specified argument Arg to make sure that it is an
3912 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3913 -- present). If not then give error and raise Pragma_Exit.
3915 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
3916 -- Check the specified argument Arg to make sure that it is a valid
3917 -- queuing policy name. If not give error and raise Pragma_Exit.
3919 procedure Check_Arg_Is_OK_Static_Expression
3921 Typ : Entity_Id := Empty);
3922 -- Check the specified argument Arg to make sure that it is a static
3923 -- expression of the given type (i.e. it will be analyzed and resolved
3924 -- using this type, which can be any valid argument to Resolve, e.g.
3925 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3926 -- Typ is left Empty, then any static expression is allowed. Includes
3927 -- checking that the argument does not raise Constraint_Error.
3929 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
3930 -- Check the specified argument Arg to make sure that it is a valid task
3931 -- dispatching policy name. If not give error and raise Pragma_Exit.
3933 procedure Check_Arg_Order (Names : Name_List);
3934 -- Checks for an instance of two arguments with identifiers for the
3935 -- current pragma which are not in the sequence indicated by Names,
3936 -- and if so, generates a fatal message about bad order of arguments.
3938 procedure Check_At_Least_N_Arguments (N : Nat);
3939 -- Check there are at least N arguments present
3941 procedure Check_At_Most_N_Arguments (N : Nat);
3942 -- Check there are no more than N arguments present
3944 procedure Check_Atomic_VFA (E : Entity_Id; VFA : Boolean);
3945 -- Apply legality checks to type or object E subject to an Atomic aspect
3946 -- in Ada 2020 (RM C.6(13)) or to a Volatile_Full_Access aspect.
3948 procedure Check_Component
3951 In_Variant_Part : Boolean := False);
3952 -- Examine an Unchecked_Union component for correct use of per-object
3953 -- constrained subtypes, and for restrictions on finalizable components.
3954 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3955 -- should be set when Comp comes from a record variant.
3957 procedure Check_Duplicate_Pragma (E : Entity_Id);
3958 -- Check if a rep item of the same name as the current pragma is already
3959 -- chained as a rep pragma to the given entity. If so give a message
3960 -- about the duplicate, and then raise Pragma_Exit so does not return.
3961 -- Note that if E is a type, then this routine avoids flagging a pragma
3962 -- which applies to a parent type from which E is derived.
3964 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
3965 -- Nam is an N_String_Literal node containing the external name set by
3966 -- an Import or Export pragma (or extended Import or Export pragma).
3967 -- This procedure checks for possible duplications if this is the export
3968 -- case, and if found, issues an appropriate error message.
3970 procedure Check_Expr_Is_OK_Static_Expression
3972 Typ : Entity_Id := Empty);
3973 -- Check the specified expression Expr to make sure that it is a static
3974 -- expression of the given type (i.e. it will be analyzed and resolved
3975 -- using this type, which can be any valid argument to Resolve, e.g.
3976 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3977 -- Typ is left Empty, then any static expression is allowed. Includes
3978 -- checking that the expression does not raise Constraint_Error.
3980 procedure Check_First_Subtype (Arg : Node_Id);
3981 -- Checks that Arg, whose expression is an entity name, references a
3984 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
3985 -- Checks that the given argument has an identifier, and if so, requires
3986 -- it to match the given identifier name. If there is no identifier, or
3987 -- a non-matching identifier, then an error message is given and
3988 -- Pragma_Exit is raised.
3990 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
3991 -- Checks that the given argument has an identifier, and if so, requires
3992 -- it to match one of the given identifier names. If there is no
3993 -- identifier, or a non-matching identifier, then an error message is
3994 -- given and Pragma_Exit is raised.
3996 procedure Check_In_Main_Program;
3997 -- Common checks for pragmas that appear within a main program
3998 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
4000 procedure Check_Interrupt_Or_Attach_Handler;
4001 -- Common processing for first argument of pragma Interrupt_Handler or
4002 -- pragma Attach_Handler.
4004 procedure Check_Loop_Pragma_Placement;
4005 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
4006 -- appear immediately within a construct restricted to loops, and that
4007 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
4009 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
4010 -- Check that pragma appears in a declarative part, or in a package
4011 -- specification, i.e. that it does not occur in a statement sequence
4014 procedure Check_No_Identifier (Arg : Node_Id);
4015 -- Checks that the given argument does not have an identifier. If
4016 -- an identifier is present, then an error message is issued, and
4017 -- Pragma_Exit is raised.
4019 procedure Check_No_Identifiers;
4020 -- Checks that none of the arguments to the pragma has an identifier.
4021 -- If any argument has an identifier, then an error message is issued,
4022 -- and Pragma_Exit is raised.
4024 procedure Check_No_Link_Name;
4025 -- Checks that no link name is specified
4027 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
4028 -- Checks if the given argument has an identifier, and if so, requires
4029 -- it to match the given identifier name. If there is a non-matching
4030 -- identifier, then an error message is given and Pragma_Exit is raised.
4032 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
4033 -- Checks if the given argument has an identifier, and if so, requires
4034 -- it to match the given identifier name. If there is a non-matching
4035 -- identifier, then an error message is given and Pragma_Exit is raised.
4036 -- In this version of the procedure, the identifier name is given as
4037 -- a string with lower case letters.
4039 procedure Check_Static_Boolean_Expression (Expr : Node_Id);
4040 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
4041 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
4042 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
4043 -- is an OK static boolean expression. Emit an error if this is not the
4046 procedure Check_Static_Constraint (Constr : Node_Id);
4047 -- Constr is a constraint from an N_Subtype_Indication node from a
4048 -- component constraint in an Unchecked_Union type. This routine checks
4049 -- that the constraint is static as required by the restrictions for
4052 procedure Check_Valid_Configuration_Pragma;
4053 -- Legality checks for placement of a configuration pragma
4055 procedure Check_Valid_Library_Unit_Pragma;
4056 -- Legality checks for library unit pragmas. A special case arises for
4057 -- pragmas in generic instances that come from copies of the original
4058 -- library unit pragmas in the generic templates. In the case of other
4059 -- than library level instantiations these can appear in contexts which
4060 -- would normally be invalid (they only apply to the original template
4061 -- and to library level instantiations), and they are simply ignored,
4062 -- which is implemented by rewriting them as null statements.
4064 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
4065 -- Check an Unchecked_Union variant for lack of nested variants and
4066 -- presence of at least one component. UU_Typ is the related Unchecked_
4069 procedure Ensure_Aggregate_Form (Arg : Node_Id);
4070 -- Subsidiary routine to the processing of pragmas Abstract_State,
4071 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
4072 -- Refined_Global and Refined_State. Transform argument Arg into
4073 -- an aggregate if not one already. N_Null is never transformed.
4074 -- Arg may denote an aspect specification or a pragma argument
4077 procedure Error_Pragma (Msg : String);
4078 pragma No_Return (Error_Pragma);
4079 -- Outputs error message for current pragma. The message contains a %
4080 -- that will be replaced with the pragma name, and the flag is placed
4081 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
4082 -- calls Fix_Error (see spec of that procedure for details).
4084 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
4085 pragma No_Return (Error_Pragma_Arg);
4086 -- Outputs error message for current pragma. The message may contain
4087 -- a % that will be replaced with the pragma name. The parameter Arg
4088 -- may either be a pragma argument association, in which case the flag
4089 -- is placed on the expression of this association, or an expression,
4090 -- in which case the flag is placed directly on the expression. The
4091 -- message is placed using Error_Msg_N, so the message may also contain
4092 -- an & insertion character which will reference the given Arg value.
4093 -- After placing the message, Pragma_Exit is raised. Note: this routine
4094 -- calls Fix_Error (see spec of that procedure for details).
4096 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
4097 pragma No_Return (Error_Pragma_Arg);
4098 -- Similar to above form of Error_Pragma_Arg except that two messages
4099 -- are provided, the second is a continuation comment starting with \.
4101 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
4102 pragma No_Return (Error_Pragma_Arg_Ident);
4103 -- Outputs error message for current pragma. The message may contain a %
4104 -- that will be replaced with the pragma name. The parameter Arg must be
4105 -- a pragma argument association with a non-empty identifier (i.e. its
4106 -- Chars field must be set), and the error message is placed on the
4107 -- identifier. The message is placed using Error_Msg_N so the message
4108 -- may also contain an & insertion character which will reference
4109 -- the identifier. After placing the message, Pragma_Exit is raised.
4110 -- Note: this routine calls Fix_Error (see spec of that procedure for
4113 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
4114 pragma No_Return (Error_Pragma_Ref);
4115 -- Outputs error message for current pragma. The message may contain
4116 -- a % that will be replaced with the pragma name. The parameter Ref
4117 -- must be an entity whose name can be referenced by & and sloc by #.
4118 -- After placing the message, Pragma_Exit is raised. Note: this routine
4119 -- calls Fix_Error (see spec of that procedure for details).
4121 function Find_Lib_Unit_Name return Entity_Id;
4122 -- Used for a library unit pragma to find the entity to which the
4123 -- library unit pragma applies, returns the entity found.
4125 procedure Find_Program_Unit_Name (Id : Node_Id);
4126 -- If the pragma is a compilation unit pragma, the id must denote the
4127 -- compilation unit in the same compilation, and the pragma must appear
4128 -- in the list of preceding or trailing pragmas. If it is a program
4129 -- unit pragma that is not a compilation unit pragma, then the
4130 -- identifier must be visible.
4132 function Find_Unique_Parameterless_Procedure
4134 Arg : Node_Id) return Entity_Id;
4135 -- Used for a procedure pragma to find the unique parameterless
4136 -- procedure identified by Name, returns it if it exists, otherwise
4137 -- errors out and uses Arg as the pragma argument for the message.
4139 function Fix_Error (Msg : String) return String;
4140 -- This is called prior to issuing an error message. Msg is the normal
4141 -- error message issued in the pragma case. This routine checks for the
4142 -- case of a pragma coming from an aspect in the source, and returns a
4143 -- message suitable for the aspect case as follows:
4145 -- Each substring "pragma" is replaced by "aspect"
4147 -- If "argument of" is at the start of the error message text, it is
4148 -- replaced by "entity for".
4150 -- If "argument" is at the start of the error message text, it is
4151 -- replaced by "entity".
4153 -- So for example, "argument of pragma X must be discrete type"
4154 -- returns "entity for aspect X must be a discrete type".
4156 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
4157 -- be different from the pragma name). If the current pragma results
4158 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
4159 -- original pragma name.
4161 procedure Gather_Associations
4163 Args : out Args_List);
4164 -- This procedure is used to gather the arguments for a pragma that
4165 -- permits arbitrary ordering of parameters using the normal rules
4166 -- for named and positional parameters. The Names argument is a list
4167 -- of Name_Id values that corresponds to the allowed pragma argument
4168 -- association identifiers in order. The result returned in Args is
4169 -- a list of corresponding expressions that are the pragma arguments.
4170 -- Note that this is a list of expressions, not of pragma argument
4171 -- associations (Gather_Associations has completely checked all the
4172 -- optional identifiers when it returns). An entry in Args is Empty
4173 -- on return if the corresponding argument is not present.
4175 procedure GNAT_Pragma;
4176 -- Called for all GNAT defined pragmas to check the relevant restriction
4177 -- (No_Implementation_Pragmas).
4179 function Is_Before_First_Decl
4180 (Pragma_Node : Node_Id;
4181 Decls : List_Id) return Boolean;
4182 -- Return True if Pragma_Node is before the first declarative item in
4183 -- Decls where Decls is the list of declarative items.
4185 function Is_Configuration_Pragma return Boolean;
4186 -- Determines if the placement of the current pragma is appropriate
4187 -- for a configuration pragma.
4189 function Is_In_Context_Clause return Boolean;
4190 -- Returns True if pragma appears within the context clause of a unit,
4191 -- and False for any other placement (does not generate any messages).
4193 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
4194 -- Analyzes the argument, and determines if it is a static string
4195 -- expression, returns True if so, False if non-static or not String.
4196 -- A special case is that a string literal returns True in Ada 83 mode
4197 -- (which has no such thing as static string expressions). Note that
4198 -- the call analyzes its argument, so this cannot be used for the case
4199 -- where an identifier might not be declared.
4201 procedure Pragma_Misplaced;
4202 pragma No_Return (Pragma_Misplaced);
4203 -- Issue fatal error message for misplaced pragma
4205 procedure Process_Atomic_Independent_Shared_Volatile;
4206 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
4207 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
4208 -- and treated as being identical in effect to pragma Atomic.
4210 procedure Process_Compile_Time_Warning_Or_Error;
4211 -- Common processing for Compile_Time_Error and Compile_Time_Warning
4213 procedure Process_Convention
4214 (C : out Convention_Id;
4215 Ent : out Entity_Id);
4216 -- Common processing for Convention, Interface, Import and Export.
4217 -- Checks first two arguments of pragma, and sets the appropriate
4218 -- convention value in the specified entity or entities. On return
4219 -- C is the convention, Ent is the referenced entity.
4221 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
4222 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
4223 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
4225 procedure Process_Extended_Import_Export_Object_Pragma
4226 (Arg_Internal : Node_Id;
4227 Arg_External : Node_Id;
4228 Arg_Size : Node_Id);
4229 -- Common processing for the pragmas Import/Export_Object. The three
4230 -- arguments correspond to the three named parameters of the pragmas. An
4231 -- argument is empty if the corresponding parameter is not present in
4234 procedure Process_Extended_Import_Export_Internal_Arg
4235 (Arg_Internal : Node_Id := Empty);
4236 -- Common processing for all extended Import and Export pragmas. The
4237 -- argument is the pragma parameter for the Internal argument. If
4238 -- Arg_Internal is empty or inappropriate, an error message is posted.
4239 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
4240 -- set to identify the referenced entity.
4242 procedure Process_Extended_Import_Export_Subprogram_Pragma
4243 (Arg_Internal : Node_Id;
4244 Arg_External : Node_Id;
4245 Arg_Parameter_Types : Node_Id;
4246 Arg_Result_Type : Node_Id := Empty;
4247 Arg_Mechanism : Node_Id;
4248 Arg_Result_Mechanism : Node_Id := Empty);
4249 -- Common processing for all extended Import and Export pragmas applying
4250 -- to subprograms. The caller omits any arguments that do not apply to
4251 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
4252 -- only in the Import_Function and Export_Function cases). The argument
4253 -- names correspond to the allowed pragma association identifiers.
4255 procedure Process_Generic_List;
4256 -- Common processing for Share_Generic and Inline_Generic
4258 procedure Process_Import_Or_Interface;
4259 -- Common processing for Import or Interface
4261 procedure Process_Import_Predefined_Type;
4262 -- Processing for completing a type with pragma Import. This is used
4263 -- to declare types that match predefined C types, especially for cases
4264 -- without corresponding Ada predefined type.
4266 type Inline_Status is (Suppressed, Disabled, Enabled);
4267 -- Inline status of a subprogram, indicated as follows:
4268 -- Suppressed: inlining is suppressed for the subprogram
4269 -- Disabled: no inlining is requested for the subprogram
4270 -- Enabled: inlining is requested/required for the subprogram
4272 procedure Process_Inline (Status : Inline_Status);
4273 -- Common processing for No_Inline, Inline and Inline_Always. Parameter
4274 -- indicates the inline status specified by the pragma.
4276 procedure Process_Interface_Name
4277 (Subprogram_Def : Entity_Id;
4281 -- Given the last two arguments of pragma Import, pragma Export, or
4282 -- pragma Interface_Name, performs validity checks and sets the
4283 -- Interface_Name field of the given subprogram entity to the
4284 -- appropriate external or link name, depending on the arguments given.
4285 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
4286 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
4287 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
4288 -- nor Link_Arg is present, the interface name is set to the default
4289 -- from the subprogram name. In addition, the pragma itself is passed
4290 -- to analyze any expressions in the case the pragma came from an aspect
4293 procedure Process_Interrupt_Or_Attach_Handler;
4294 -- Common processing for Interrupt and Attach_Handler pragmas
4296 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
4297 -- Common processing for Restrictions and Restriction_Warnings pragmas.
4298 -- Warn is True for Restriction_Warnings, or for Restrictions if the
4299 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
4300 -- is not set in the Restrictions case.
4302 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
4303 -- Common processing for Suppress and Unsuppress. The boolean parameter
4304 -- Suppress_Case is True for the Suppress case, and False for the
4307 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id);
4308 -- Subsidiary to the analysis of pragmas Independent[_Components].
4309 -- Record such a pragma N applied to entity E for future checks.
4311 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
4312 -- This procedure sets the Is_Exported flag for the given entity,
4313 -- checking that the entity was not previously imported. Arg is
4314 -- the argument that specified the entity. A check is also made
4315 -- for exporting inappropriate entities.
4317 procedure Set_Extended_Import_Export_External_Name
4318 (Internal_Ent : Entity_Id;
4319 Arg_External : Node_Id);
4320 -- Common processing for all extended import export pragmas. The first
4321 -- argument, Internal_Ent, is the internal entity, which has already
4322 -- been checked for validity by the caller. Arg_External is from the
4323 -- Import or Export pragma, and may be null if no External parameter
4324 -- was present. If Arg_External is present and is a non-null string
4325 -- (a null string is treated as the default), then the Interface_Name
4326 -- field of Internal_Ent is set appropriately.
4328 procedure Set_Imported (E : Entity_Id);
4329 -- This procedure sets the Is_Imported flag for the given entity,
4330 -- checking that it is not previously exported or imported.
4332 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
4333 -- Mech is a parameter passing mechanism (see Import_Function syntax
4334 -- for MECHANISM_NAME). This routine checks that the mechanism argument
4335 -- has the right form, and if not issues an error message. If the
4336 -- argument has the right form then the Mechanism field of Ent is
4337 -- set appropriately.
4339 procedure Set_Rational_Profile;
4340 -- Activate the set of configuration pragmas and permissions that make
4341 -- up the Rational profile.
4343 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id);
4344 -- Activate the set of configuration pragmas and restrictions that make
4345 -- up the Profile. Profile must be either GNAT_Extended_Ravenscar,
4346 -- GNAT_Ravenscar_EDF, Jorvik, or Ravenscar. N is the corresponding
4347 -- pragma node, which is used for error messages on any constructs
4348 -- violating the profile.
4350 ---------------------
4351 -- Ada_2005_Pragma --
4352 ---------------------
4354 procedure Ada_2005_Pragma is
4356 if Ada_Version <= Ada_95 then
4357 Check_Restriction (No_Implementation_Pragmas, N);
4359 end Ada_2005_Pragma;
4361 ---------------------
4362 -- Ada_2012_Pragma --
4363 ---------------------
4365 procedure Ada_2012_Pragma is
4367 if Ada_Version <= Ada_2005 then
4368 Check_Restriction (No_Implementation_Pragmas, N);
4370 end Ada_2012_Pragma;
4372 ----------------------------
4373 -- Analyze_Depends_Global --
4374 ----------------------------
4376 procedure Analyze_Depends_Global
4377 (Spec_Id : out Entity_Id;
4378 Subp_Decl : out Node_Id;
4379 Legal : out Boolean)
4382 -- Assume that the pragma is illegal
4389 Check_Arg_Count (1);
4391 -- Ensure the proper placement of the pragma. Depends/Global must be
4392 -- associated with a subprogram declaration or a body that acts as a
4395 Subp_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4399 if Nkind (Subp_Decl) = N_Entry_Declaration then
4402 -- Generic subprogram
4404 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4407 -- Object declaration of a single concurrent type
4409 elsif Nkind (Subp_Decl) = N_Object_Declaration
4410 and then Is_Single_Concurrent_Object
4411 (Unique_Defining_Entity (Subp_Decl))
4417 elsif Nkind (Subp_Decl) = N_Single_Task_Declaration then
4420 -- Subprogram body acts as spec
4422 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4423 and then No (Corresponding_Spec (Subp_Decl))
4427 -- Subprogram body stub acts as spec
4429 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4430 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
4434 -- Subprogram declaration
4436 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4441 elsif Nkind (Subp_Decl) = N_Task_Type_Declaration then
4449 -- If we get here, then the pragma is legal
4452 Spec_Id := Unique_Defining_Entity (Subp_Decl);
4454 -- When the related context is an entry, the entry must belong to a
4455 -- protected unit (SPARK RM 6.1.4(6)).
4457 if Is_Entry_Declaration (Spec_Id)
4458 and then Ekind (Scope (Spec_Id)) /= E_Protected_Type
4463 -- When the related context is an anonymous object created for a
4464 -- simple concurrent type, the type must be a task
4465 -- (SPARK RM 6.1.4(6)).
4467 elsif Is_Single_Concurrent_Object (Spec_Id)
4468 and then Ekind (Etype (Spec_Id)) /= E_Task_Type
4474 -- A pragma that applies to a Ghost entity becomes Ghost for the
4475 -- purposes of legality checks and removal of ignored Ghost code.
4477 Mark_Ghost_Pragma (N, Spec_Id);
4478 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4479 end Analyze_Depends_Global;
4481 ------------------------
4482 -- Analyze_If_Present --
4483 ------------------------
4485 procedure Analyze_If_Present (Id : Pragma_Id) is
4489 pragma Assert (Is_List_Member (N));
4491 -- Inspect the declarations or statements following pragma N looking
4492 -- for another pragma whose Id matches the caller's request. If it is
4493 -- available, analyze it.
4496 while Present (Stmt) loop
4497 if Nkind (Stmt) = N_Pragma and then Get_Pragma_Id (Stmt) = Id then
4498 Analyze_Pragma (Stmt);
4501 -- The first source declaration or statement immediately following
4502 -- N ends the region where a pragma may appear.
4504 elsif Comes_From_Source (Stmt) then
4510 end Analyze_If_Present;
4512 --------------------------------
4513 -- Analyze_Pre_Post_Condition --
4514 --------------------------------
4516 procedure Analyze_Pre_Post_Condition is
4517 Prag_Iden : constant Node_Id := Pragma_Identifier (N);
4518 Subp_Decl : Node_Id;
4519 Subp_Id : Entity_Id;
4521 Duplicates_OK : Boolean := False;
4522 -- Flag set when a pre/postcondition allows multiple pragmas of the
4525 In_Body_OK : Boolean := False;
4526 -- Flag set when a pre/postcondition is allowed to appear on a body
4527 -- even though the subprogram may have a spec.
4529 Is_Pre_Post : Boolean := False;
4530 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4533 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean;
4534 -- Implement rules in AI12-0131: an overriding operation can have
4535 -- a class-wide precondition only if one of its ancestors has an
4536 -- explicit class-wide precondition.
4538 -----------------------------
4539 -- Inherits_Class_Wide_Pre --
4540 -----------------------------
4542 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean is
4543 Typ : constant Entity_Id := Find_Dispatching_Type (E);
4546 Prev : Entity_Id := Overridden_Operation (E);
4549 -- Check ancestors on the overriding operation to examine the
4550 -- preconditions that may apply to them.
4552 while Present (Prev) loop
4553 Cont := Contract (Prev);
4554 if Present (Cont) then
4555 Prag := Pre_Post_Conditions (Cont);
4556 while Present (Prag) loop
4557 if Pragma_Name (Prag) = Name_Precondition
4558 and then Class_Present (Prag)
4563 Prag := Next_Pragma (Prag);
4567 -- For a type derived from a generic formal type, the operation
4568 -- inheriting the condition is a renaming, not an overriding of
4569 -- the operation of the formal. Ditto for an inherited
4570 -- operation which has no explicit contracts.
4572 if Is_Generic_Type (Find_Dispatching_Type (Prev))
4573 or else not Comes_From_Source (Prev)
4575 Prev := Alias (Prev);
4577 Prev := Overridden_Operation (Prev);
4581 -- If the controlling type of the subprogram has progenitors, an
4582 -- interface operation implemented by the current operation may
4583 -- have a class-wide precondition.
4585 if Has_Interfaces (Typ) then
4590 Prim_Elmt : Elmt_Id;
4591 Prim_List : Elist_Id;
4594 Collect_Interfaces (Typ, Ints);
4595 Elmt := First_Elmt (Ints);
4597 -- Iterate over the primitive operations of each interface
4599 while Present (Elmt) loop
4600 Prim_List := Direct_Primitive_Operations (Node (Elmt));
4601 Prim_Elmt := First_Elmt (Prim_List);
4602 while Present (Prim_Elmt) loop
4603 Prim := Node (Prim_Elmt);
4604 if Chars (Prim) = Chars (E)
4605 and then Present (Contract (Prim))
4606 and then Class_Present
4607 (Pre_Post_Conditions (Contract (Prim)))
4612 Next_Elmt (Prim_Elmt);
4621 end Inherits_Class_Wide_Pre;
4623 -- Start of processing for Analyze_Pre_Post_Condition
4626 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4627 -- offer uniformity among the various kinds of pre/postconditions by
4628 -- rewriting the pragma identifier. This allows the retrieval of the
4629 -- original pragma name by routine Original_Aspect_Pragma_Name.
4631 if Comes_From_Source (N) then
4632 if Pname in Name_Pre | Name_Pre_Class then
4633 Is_Pre_Post := True;
4634 Set_Class_Present (N, Pname = Name_Pre_Class);
4635 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Precondition));
4637 elsif Pname in Name_Post | Name_Post_Class then
4638 Is_Pre_Post := True;
4639 Set_Class_Present (N, Pname = Name_Post_Class);
4640 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Postcondition));
4644 -- Determine the semantics with respect to duplicates and placement
4645 -- in a body. Pragmas Precondition and Postcondition were introduced
4646 -- before aspects and are not subject to the same aspect-like rules.
4648 if Pname in Name_Precondition | Name_Postcondition then
4649 Duplicates_OK := True;
4655 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4656 -- argument without an identifier.
4659 Check_Arg_Count (1);
4660 Check_No_Identifiers;
4662 -- Pragmas Precondition and Postcondition have complex argument
4666 Check_At_Least_N_Arguments (1);
4667 Check_At_Most_N_Arguments (2);
4668 Check_Optional_Identifier (Arg1, Name_Check);
4670 if Present (Arg2) then
4671 Check_Optional_Identifier (Arg2, Name_Message);
4672 Preanalyze_Spec_Expression
4673 (Get_Pragma_Arg (Arg2), Standard_String);
4677 -- For a pragma PPC in the extended main source unit, record enabled
4679 -- ??? nothing checks that the pragma is in the main source unit
4681 if Is_Checked (N) and then not Split_PPC (N) then
4682 Set_SCO_Pragma_Enabled (Loc);
4685 -- Ensure the proper placement of the pragma
4688 Find_Related_Declaration_Or_Body
4689 (N, Do_Checks => not Duplicates_OK);
4691 -- When a pre/postcondition pragma applies to an abstract subprogram,
4692 -- its original form must be an aspect with 'Class.
4694 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
4695 if not From_Aspect_Specification (N) then
4697 ("pragma % cannot be applied to abstract subprogram");
4699 elsif not Class_Present (N) then
4701 ("aspect % requires ''Class for abstract subprogram");
4704 -- Entry declaration
4706 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
4709 -- Generic subprogram declaration
4711 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4716 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4717 and then (No (Corresponding_Spec (Subp_Decl)) or In_Body_OK)
4721 -- Subprogram body stub
4723 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4724 and then (No (Corresponding_Spec_Of_Stub (Subp_Decl)) or In_Body_OK)
4728 -- Subprogram declaration
4730 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4732 -- AI05-0230: When a pre/postcondition pragma applies to a null
4733 -- procedure, its original form must be an aspect with 'Class.
4735 if Nkind (Specification (Subp_Decl)) = N_Procedure_Specification
4736 and then Null_Present (Specification (Subp_Decl))
4737 and then From_Aspect_Specification (N)
4738 and then not Class_Present (N)
4740 Error_Pragma ("aspect % requires ''Class for null procedure");
4743 -- Implement the legality checks mandated by AI12-0131:
4744 -- Pre'Class shall not be specified for an overriding primitive
4745 -- subprogram of a tagged type T unless the Pre'Class aspect is
4746 -- specified for the corresponding primitive subprogram of some
4750 E : constant Entity_Id := Defining_Entity (Subp_Decl);
4753 if Class_Present (N)
4754 and then Pragma_Name (N) = Name_Precondition
4755 and then Present (Overridden_Operation (E))
4756 and then not Inherits_Class_Wide_Pre (E)
4759 ("illegal class-wide precondition on overriding operation",
4760 Corresponding_Aspect (N));
4764 -- A renaming declaration may inherit a generated pragma, its
4765 -- placement comes from expansion, not from source.
4767 elsif Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration
4768 and then not Comes_From_Source (N)
4772 -- For Ada 2020, pre/postconditions can appear on formal subprograms
4774 elsif Nkind (Subp_Decl) = N_Formal_Concrete_Subprogram_Declaration
4775 and then Ada_Version >= Ada_2020
4779 -- An access-to-subprogram type can have pre/postconditions, but
4780 -- these are transferred to the generated subprogram wrapper and
4783 -- Otherwise the placement of the pragma is illegal
4790 Subp_Id := Defining_Entity (Subp_Decl);
4792 -- A pragma that applies to a Ghost entity becomes Ghost for the
4793 -- purposes of legality checks and removal of ignored Ghost code.
4795 Mark_Ghost_Pragma (N, Subp_Id);
4797 -- Chain the pragma on the contract for further processing by
4798 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4800 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
4802 -- Fully analyze the pragma when it appears inside an entry or
4803 -- subprogram body because it cannot benefit from forward references.
4805 if Nkind (Subp_Decl) in N_Entry_Body
4807 | N_Subprogram_Body_Stub
4809 -- The legality checks of pragmas Precondition and Postcondition
4810 -- are affected by the SPARK mode in effect and the volatility of
4811 -- the context. Analyze all pragmas in a specific order.
4813 Analyze_If_Present (Pragma_SPARK_Mode);
4814 Analyze_If_Present (Pragma_Volatile_Function);
4815 Analyze_Pre_Post_Condition_In_Decl_Part (N);
4817 end Analyze_Pre_Post_Condition;
4819 -----------------------------------------
4820 -- Analyze_Refined_Depends_Global_Post --
4821 -----------------------------------------
4823 procedure Analyze_Refined_Depends_Global_Post
4824 (Spec_Id : out Entity_Id;
4825 Body_Id : out Entity_Id;
4826 Legal : out Boolean)
4828 Body_Decl : Node_Id;
4829 Spec_Decl : Node_Id;
4832 -- Assume that the pragma is illegal
4839 Check_Arg_Count (1);
4840 Check_No_Identifiers;
4842 -- Verify the placement of the pragma and check for duplicates. The
4843 -- pragma must apply to a subprogram body [stub].
4845 Body_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4847 if Nkind (Body_Decl) not in
4848 N_Entry_Body | N_Subprogram_Body | N_Subprogram_Body_Stub |
4849 N_Task_Body | N_Task_Body_Stub
4855 Body_Id := Defining_Entity (Body_Decl);
4856 Spec_Id := Unique_Defining_Entity (Body_Decl);
4858 -- The pragma must apply to the second declaration of a subprogram.
4859 -- In other words, the body [stub] cannot acts as a spec.
4861 if No (Spec_Id) then
4862 Error_Pragma ("pragma % cannot apply to a stand alone body");
4865 -- Catch the case where the subprogram body is a subunit and acts as
4866 -- the third declaration of the subprogram.
4868 elsif Nkind (Parent (Body_Decl)) = N_Subunit then
4869 Error_Pragma ("pragma % cannot apply to a subunit");
4873 -- A refined pragma can only apply to the body [stub] of a subprogram
4874 -- declared in the visible part of a package. Retrieve the context of
4875 -- the subprogram declaration.
4877 Spec_Decl := Unit_Declaration_Node (Spec_Id);
4879 -- When dealing with protected entries or protected subprograms, use
4880 -- the enclosing protected type as the proper context.
4882 if Ekind (Spec_Id) in E_Entry
4886 and then Ekind (Scope (Spec_Id)) = E_Protected_Type
4888 Spec_Decl := Declaration_Node (Scope (Spec_Id));
4891 if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then
4893 (Fix_Msg (Spec_Id, "pragma % must apply to the body of "
4894 & "subprogram declared in a package specification"));
4898 -- If we get here, then the pragma is legal
4902 -- A pragma that applies to a Ghost entity becomes Ghost for the
4903 -- purposes of legality checks and removal of ignored Ghost code.
4905 Mark_Ghost_Pragma (N, Spec_Id);
4907 if Pname in Name_Refined_Depends | Name_Refined_Global then
4908 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4910 end Analyze_Refined_Depends_Global_Post;
4912 ----------------------------------
4913 -- Analyze_Unmodified_Or_Unused --
4914 ----------------------------------
4916 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False) is
4921 Ghost_Error_Posted : Boolean := False;
4922 -- Flag set when an error concerning the illegal mix of Ghost and
4923 -- non-Ghost variables is emitted.
4925 Ghost_Id : Entity_Id := Empty;
4926 -- The entity of the first Ghost variable encountered while
4927 -- processing the arguments of the pragma.
4931 Check_At_Least_N_Arguments (1);
4933 -- Loop through arguments
4936 while Present (Arg) loop
4937 Check_No_Identifier (Arg);
4939 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4940 -- in fact generate reference, so that the entity will have a
4941 -- reference, which will inhibit any warnings about it not
4942 -- being referenced, and also properly show up in the ali file
4943 -- as a reference. But this reference is recorded before the
4944 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4945 -- generated for this reference.
4947 Check_Arg_Is_Local_Name (Arg);
4948 Arg_Expr := Get_Pragma_Arg (Arg);
4950 if Is_Entity_Name (Arg_Expr) then
4951 Arg_Id := Entity (Arg_Expr);
4953 -- Skip processing the argument if already flagged
4955 if Is_Assignable (Arg_Id)
4956 and then not Has_Pragma_Unmodified (Arg_Id)
4957 and then not Has_Pragma_Unused (Arg_Id)
4959 Set_Has_Pragma_Unmodified (Arg_Id);
4962 Set_Has_Pragma_Unused (Arg_Id);
4965 -- A pragma that applies to a Ghost entity becomes Ghost for
4966 -- the purposes of legality checks and removal of ignored
4969 Mark_Ghost_Pragma (N, Arg_Id);
4971 -- Capture the entity of the first Ghost variable being
4972 -- processed for error detection purposes.
4974 if Is_Ghost_Entity (Arg_Id) then
4975 if No (Ghost_Id) then
4979 -- Otherwise the variable is non-Ghost. It is illegal to mix
4980 -- references to Ghost and non-Ghost entities
4983 elsif Present (Ghost_Id)
4984 and then not Ghost_Error_Posted
4986 Ghost_Error_Posted := True;
4988 Error_Msg_Name_1 := Pname;
4990 ("pragma % cannot mention ghost and non-ghost "
4993 Error_Msg_Sloc := Sloc (Ghost_Id);
4994 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
4996 Error_Msg_Sloc := Sloc (Arg_Id);
4997 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
5000 -- Warn if already flagged as Unused or Unmodified
5002 elsif Has_Pragma_Unmodified (Arg_Id) then
5003 if Has_Pragma_Unused (Arg_Id) then
5005 ("??pragma Unused already given for &!", Arg_Expr,
5009 ("??pragma Unmodified already given for &!", Arg_Expr,
5013 -- Otherwise the pragma referenced an illegal entity
5017 ("pragma% can only be applied to a variable", Arg_Expr);
5023 end Analyze_Unmodified_Or_Unused;
5025 ------------------------------------
5026 -- Analyze_Unreferenced_Or_Unused --
5027 ------------------------------------
5029 procedure Analyze_Unreferenced_Or_Unused
5030 (Is_Unused : Boolean := False)
5037 Ghost_Error_Posted : Boolean := False;
5038 -- Flag set when an error concerning the illegal mix of Ghost and
5039 -- non-Ghost names is emitted.
5041 Ghost_Id : Entity_Id := Empty;
5042 -- The entity of the first Ghost name encountered while processing
5043 -- the arguments of the pragma.
5047 Check_At_Least_N_Arguments (1);
5049 -- Check case of appearing within context clause
5051 if not Is_Unused and then Is_In_Context_Clause then
5053 -- The arguments must all be units mentioned in a with clause in
5054 -- the same context clause. Note that Par.Prag already checked
5055 -- that the arguments are either identifiers or selected
5059 while Present (Arg) loop
5060 Citem := First (List_Containing (N));
5061 while Citem /= N loop
5062 Arg_Expr := Get_Pragma_Arg (Arg);
5064 if Nkind (Citem) = N_With_Clause
5065 and then Same_Name (Name (Citem), Arg_Expr)
5067 Set_Has_Pragma_Unreferenced
5070 (Library_Unit (Citem))));
5071 Set_Elab_Unit_Name (Arg_Expr, Name (Citem));
5080 ("argument of pragma% is not withed unit", Arg);
5086 -- Case of not in list of context items
5090 while Present (Arg) loop
5091 Check_No_Identifier (Arg);
5093 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
5094 -- in fact generate reference, so that the entity will have a
5095 -- reference, which will inhibit any warnings about it not
5096 -- being referenced, and also properly show up in the ali file
5097 -- as a reference. But this reference is recorded before the
5098 -- Has_Pragma_Unreferenced flag is set, so that no warning is
5099 -- generated for this reference.
5101 Check_Arg_Is_Local_Name (Arg);
5102 Arg_Expr := Get_Pragma_Arg (Arg);
5104 if Is_Entity_Name (Arg_Expr) then
5105 Arg_Id := Entity (Arg_Expr);
5107 -- Warn if already flagged as Unused or Unreferenced and
5108 -- skip processing the argument.
5110 if Has_Pragma_Unreferenced (Arg_Id) then
5111 if Has_Pragma_Unused (Arg_Id) then
5113 ("??pragma Unused already given for &!", Arg_Expr,
5117 ("??pragma Unreferenced already given for &!",
5121 -- Apply Unreferenced to the entity
5124 -- If the entity is overloaded, the pragma applies to the
5125 -- most recent overloading, as documented. In this case,
5126 -- name resolution does not generate a reference, so it
5127 -- must be done here explicitly.
5129 if Is_Overloaded (Arg_Expr) then
5130 Generate_Reference (Arg_Id, N);
5133 Set_Has_Pragma_Unreferenced (Arg_Id);
5136 Set_Has_Pragma_Unused (Arg_Id);
5139 -- A pragma that applies to a Ghost entity becomes Ghost
5140 -- for the purposes of legality checks and removal of
5141 -- ignored Ghost code.
5143 Mark_Ghost_Pragma (N, Arg_Id);
5145 -- Capture the entity of the first Ghost name being
5146 -- processed for error detection purposes.
5148 if Is_Ghost_Entity (Arg_Id) then
5149 if No (Ghost_Id) then
5153 -- Otherwise the name is non-Ghost. It is illegal to mix
5154 -- references to Ghost and non-Ghost entities
5157 elsif Present (Ghost_Id)
5158 and then not Ghost_Error_Posted
5160 Ghost_Error_Posted := True;
5162 Error_Msg_Name_1 := Pname;
5164 ("pragma % cannot mention ghost and non-ghost "
5167 Error_Msg_Sloc := Sloc (Ghost_Id);
5169 ("\& # declared as ghost", N, Ghost_Id);
5171 Error_Msg_Sloc := Sloc (Arg_Id);
5173 ("\& # declared as non-ghost", N, Arg_Id);
5181 end Analyze_Unreferenced_Or_Unused;
5183 --------------------------
5184 -- Check_Ada_83_Warning --
5185 --------------------------
5187 procedure Check_Ada_83_Warning is
5189 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
5190 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
5192 end Check_Ada_83_Warning;
5194 ---------------------
5195 -- Check_Arg_Count --
5196 ---------------------
5198 procedure Check_Arg_Count (Required : Nat) is
5200 if Arg_Count /= Required then
5201 Error_Pragma ("wrong number of arguments for pragma%");
5203 end Check_Arg_Count;
5205 --------------------------------
5206 -- Check_Arg_Is_External_Name --
5207 --------------------------------
5209 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
5210 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5213 if Nkind (Argx) = N_Identifier then
5217 Analyze_And_Resolve (Argx, Standard_String);
5219 if Is_OK_Static_Expression (Argx) then
5222 elsif Etype (Argx) = Any_Type then
5225 -- An interesting special case, if we have a string literal and
5226 -- we are in Ada 83 mode, then we allow it even though it will
5227 -- not be flagged as static. This allows expected Ada 83 mode
5228 -- use of external names which are string literals, even though
5229 -- technically these are not static in Ada 83.
5231 elsif Ada_Version = Ada_83
5232 and then Nkind (Argx) = N_String_Literal
5236 -- Here we have a real error (non-static expression)
5239 Error_Msg_Name_1 := Pname;
5240 Flag_Non_Static_Expr
5241 (Fix_Error ("argument for pragma% must be a identifier or "
5242 & "static string expression!"), Argx);
5247 end Check_Arg_Is_External_Name;
5249 -----------------------------
5250 -- Check_Arg_Is_Identifier --
5251 -----------------------------
5253 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
5254 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5256 if Nkind (Argx) /= N_Identifier then
5257 Error_Pragma_Arg ("argument for pragma% must be identifier", Argx);
5259 end Check_Arg_Is_Identifier;
5261 ----------------------------------
5262 -- Check_Arg_Is_Integer_Literal --
5263 ----------------------------------
5265 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
5266 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5268 if Nkind (Argx) /= N_Integer_Literal then
5270 ("argument for pragma% must be integer literal", Argx);
5272 end Check_Arg_Is_Integer_Literal;
5274 -------------------------------------------
5275 -- Check_Arg_Is_Library_Level_Local_Name --
5276 -------------------------------------------
5280 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5281 -- | library_unit_NAME
5283 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
5285 Check_Arg_Is_Local_Name (Arg);
5287 -- If it came from an aspect, we want to give the error just as if it
5288 -- came from source.
5290 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
5291 and then (Comes_From_Source (N)
5292 or else Present (Corresponding_Aspect (Parent (Arg))))
5295 ("argument for pragma% must be library level entity", Arg);
5297 end Check_Arg_Is_Library_Level_Local_Name;
5299 -----------------------------
5300 -- Check_Arg_Is_Local_Name --
5301 -----------------------------
5305 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5306 -- | library_unit_NAME
5308 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
5309 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5312 -- If this pragma came from an aspect specification, we don't want to
5313 -- check for this error, because that would cause spurious errors, in
5314 -- case a type is frozen in a scope more nested than the type. The
5315 -- aspect itself of course can't be anywhere but on the declaration
5318 if Nkind (Arg) = N_Pragma_Argument_Association then
5319 if From_Aspect_Specification (Parent (Arg)) then
5323 -- Arg is the Expression of an N_Pragma_Argument_Association
5326 if From_Aspect_Specification (Parent (Parent (Arg))) then
5333 if Nkind (Argx) not in N_Direct_Name
5334 and then (Nkind (Argx) /= N_Attribute_Reference
5335 or else Present (Expressions (Argx))
5336 or else Nkind (Prefix (Argx)) /= N_Identifier)
5337 and then (not Is_Entity_Name (Argx)
5338 or else not Is_Compilation_Unit (Entity (Argx)))
5340 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
5343 -- No further check required if not an entity name
5345 if not Is_Entity_Name (Argx) then
5351 Ent : constant Entity_Id := Entity (Argx);
5352 Scop : constant Entity_Id := Scope (Ent);
5355 -- Case of a pragma applied to a compilation unit: pragma must
5356 -- occur immediately after the program unit in the compilation.
5358 if Is_Compilation_Unit (Ent) then
5360 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
5363 -- Case of pragma placed immediately after spec
5365 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
5368 -- Case of pragma placed immediately after body
5370 elsif Nkind (Decl) = N_Subprogram_Declaration
5371 and then Present (Corresponding_Body (Decl))
5375 (Parent (Unit_Declaration_Node
5376 (Corresponding_Body (Decl))));
5378 -- All other cases are illegal
5385 -- Special restricted placement rule from 10.2.1(11.8/2)
5387 elsif Is_Generic_Formal (Ent)
5388 and then Prag_Id = Pragma_Preelaborable_Initialization
5390 OK := List_Containing (N) =
5391 Generic_Formal_Declarations
5392 (Unit_Declaration_Node (Scop));
5394 -- If this is an aspect applied to a subprogram body, the
5395 -- pragma is inserted in its declarative part.
5397 elsif From_Aspect_Specification (N)
5398 and then Ent = Current_Scope
5400 Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body
5404 -- If the aspect is a predicate (possibly others ???) and the
5405 -- context is a record type, this is a discriminant expression
5406 -- within a type declaration, that freezes the predicated
5409 elsif From_Aspect_Specification (N)
5410 and then Prag_Id = Pragma_Predicate
5411 and then Ekind (Current_Scope) = E_Record_Type
5412 and then Scop = Scope (Current_Scope)
5416 -- Default case, just check that the pragma occurs in the scope
5417 -- of the entity denoted by the name.
5420 OK := Current_Scope = Scop;
5425 ("pragma% argument must be in same declarative part", Arg);
5429 end Check_Arg_Is_Local_Name;
5431 ---------------------------------
5432 -- Check_Arg_Is_Locking_Policy --
5433 ---------------------------------
5435 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
5436 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5439 Check_Arg_Is_Identifier (Argx);
5441 if not Is_Locking_Policy_Name (Chars (Argx)) then
5442 Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
5444 end Check_Arg_Is_Locking_Policy;
5446 -----------------------------------------------
5447 -- Check_Arg_Is_Partition_Elaboration_Policy --
5448 -----------------------------------------------
5450 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
5451 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5454 Check_Arg_Is_Identifier (Argx);
5456 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
5458 ("& is not a valid partition elaboration policy name", Argx);
5460 end Check_Arg_Is_Partition_Elaboration_Policy;
5462 -------------------------
5463 -- Check_Arg_Is_One_Of --
5464 -------------------------
5466 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5467 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5470 Check_Arg_Is_Identifier (Argx);
5472 if Chars (Argx) not in N1 | N2 then
5473 Error_Msg_Name_2 := N1;
5474 Error_Msg_Name_3 := N2;
5475 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
5477 end Check_Arg_Is_One_Of;
5479 procedure Check_Arg_Is_One_Of
5481 N1, N2, N3 : Name_Id)
5483 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5486 Check_Arg_Is_Identifier (Argx);
5488 if Chars (Argx) not in N1 | N2 | N3 then
5489 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5491 end Check_Arg_Is_One_Of;
5493 procedure Check_Arg_Is_One_Of
5495 N1, N2, N3, N4 : Name_Id)
5497 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5500 Check_Arg_Is_Identifier (Argx);
5502 if Chars (Argx) not in N1 | N2 | N3 | N4 then
5503 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5505 end Check_Arg_Is_One_Of;
5507 procedure Check_Arg_Is_One_Of
5509 N1, N2, N3, N4, N5 : Name_Id)
5511 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5514 Check_Arg_Is_Identifier (Argx);
5516 if Chars (Argx) not in N1 | N2 | N3 | N4 | N5 then
5517 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5519 end Check_Arg_Is_One_Of;
5521 ---------------------------------
5522 -- Check_Arg_Is_Queuing_Policy --
5523 ---------------------------------
5525 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
5526 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5529 Check_Arg_Is_Identifier (Argx);
5531 if not Is_Queuing_Policy_Name (Chars (Argx)) then
5532 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
5534 end Check_Arg_Is_Queuing_Policy;
5536 ---------------------------------------
5537 -- Check_Arg_Is_OK_Static_Expression --
5538 ---------------------------------------
5540 procedure Check_Arg_Is_OK_Static_Expression
5542 Typ : Entity_Id := Empty)
5545 Check_Expr_Is_OK_Static_Expression (Get_Pragma_Arg (Arg), Typ);
5546 end Check_Arg_Is_OK_Static_Expression;
5548 ------------------------------------------
5549 -- Check_Arg_Is_Task_Dispatching_Policy --
5550 ------------------------------------------
5552 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
5553 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5556 Check_Arg_Is_Identifier (Argx);
5558 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
5560 ("& is not an allowed task dispatching policy name", Argx);
5562 end Check_Arg_Is_Task_Dispatching_Policy;
5564 ---------------------
5565 -- Check_Arg_Order --
5566 ---------------------
5568 procedure Check_Arg_Order (Names : Name_List) is
5571 Highest_So_Far : Natural := 0;
5572 -- Highest index in Names seen do far
5576 for J in 1 .. Arg_Count loop
5577 if Chars (Arg) /= No_Name then
5578 for K in Names'Range loop
5579 if Chars (Arg) = Names (K) then
5580 if K < Highest_So_Far then
5581 Error_Msg_Name_1 := Pname;
5583 ("parameters out of order for pragma%", Arg);
5584 Error_Msg_Name_1 := Names (K);
5585 Error_Msg_Name_2 := Names (Highest_So_Far);
5586 Error_Msg_N ("\% must appear before %", Arg);
5590 Highest_So_Far := K;
5598 end Check_Arg_Order;
5600 --------------------------------
5601 -- Check_At_Least_N_Arguments --
5602 --------------------------------
5604 procedure Check_At_Least_N_Arguments (N : Nat) is
5606 if Arg_Count < N then
5607 Error_Pragma ("too few arguments for pragma%");
5609 end Check_At_Least_N_Arguments;
5611 -------------------------------
5612 -- Check_At_Most_N_Arguments --
5613 -------------------------------
5615 procedure Check_At_Most_N_Arguments (N : Nat) is
5618 if Arg_Count > N then
5620 for J in 1 .. N loop
5622 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
5625 end Check_At_Most_N_Arguments;
5627 ------------------------
5628 -- Check_Atomic_VFA --
5629 ------------------------
5631 procedure Check_Atomic_VFA (E : Entity_Id; VFA : Boolean) is
5633 Aliased_Subcomponent : exception;
5634 -- Exception raised if an aliased subcomponent is found in E
5636 Independent_Subcomponent : exception;
5637 -- Exception raised if an independent subcomponent is found in E
5639 procedure Check_Subcomponents (Typ : Entity_Id);
5640 -- Apply checks to subcomponents for Atomic and Volatile_Full_Access
5642 -------------------------
5643 -- Check_Subcomponents --
5644 -------------------------
5646 procedure Check_Subcomponents (Typ : Entity_Id) is
5650 if Is_Array_Type (Typ) then
5651 Comp := Component_Type (Typ);
5653 -- For Atomic we accept any atomic subcomponents
5656 and then (Has_Atomic_Components (Typ)
5657 or else Is_Atomic (Comp))
5661 -- Give an error if the components are aliased
5663 elsif Has_Aliased_Components (Typ)
5664 or else Is_Aliased (Comp)
5666 raise Aliased_Subcomponent;
5668 -- For VFA we accept non-aliased VFA subcomponents
5671 and then Is_Volatile_Full_Access (Comp)
5675 -- Give an error if the components are independent
5677 elsif Has_Independent_Components (Typ)
5678 or else Is_Independent (Comp)
5680 raise Independent_Subcomponent;
5683 -- Recurse on the component type
5685 Check_Subcomponents (Comp);
5687 -- Note: Has_Aliased_Components, like Has_Atomic_Components,
5688 -- and Has_Independent_Components, applies only to arrays.
5689 -- However, this flag does not have a corresponding pragma, so
5690 -- perhaps it should be possible to apply it to record types as
5691 -- well. Should this be done ???
5693 elsif Is_Record_Type (Typ) then
5694 -- It is possible to have an aliased discriminant, so they
5695 -- must be checked along with normal components.
5697 Comp := First_Component_Or_Discriminant (Typ);
5698 while Present (Comp) loop
5700 -- For Atomic we accept any atomic subcomponents
5703 and then (Is_Atomic (Comp)
5704 or else Is_Atomic (Etype (Comp)))
5708 -- Give an error if the component is aliased
5710 elsif Is_Aliased (Comp)
5711 or else Is_Aliased (Etype (Comp))
5713 raise Aliased_Subcomponent;
5715 -- For VFA we accept non-aliased VFA subcomponents
5718 and then (Is_Volatile_Full_Access (Comp)
5719 or else Is_Volatile_Full_Access (Etype (Comp)))
5723 -- Give an error if the component is independent
5725 elsif Is_Independent (Comp)
5726 or else Is_Independent (Etype (Comp))
5728 raise Independent_Subcomponent;
5731 -- Recurse on the component type
5733 Check_Subcomponents (Etype (Comp));
5735 Next_Component_Or_Discriminant (Comp);
5738 end Check_Subcomponents;
5743 -- Fetch the type in case we are dealing with an object or component
5748 pragma Assert (Is_Object (E)
5750 Nkind (Declaration_Node (E)) = N_Component_Declaration);
5755 -- Check all the subcomponents of the type recursively, if any
5757 Check_Subcomponents (Typ);
5760 when Aliased_Subcomponent =>
5763 ("cannot apply Volatile_Full_Access with aliased "
5767 ("cannot apply Atomic with aliased subcomponent "
5771 when Independent_Subcomponent =>
5774 ("cannot apply Volatile_Full_Access with independent "
5778 ("cannot apply Atomic with independent subcomponent "
5783 raise Program_Error;
5784 end Check_Atomic_VFA;
5786 ---------------------
5787 -- Check_Component --
5788 ---------------------
5790 procedure Check_Component
5793 In_Variant_Part : Boolean := False)
5795 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
5796 Sindic : constant Node_Id :=
5797 Subtype_Indication (Component_Definition (Comp));
5798 Typ : constant Entity_Id := Etype (Comp_Id);
5801 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
5802 -- object constraint, then the component type shall be an Unchecked_
5805 if Nkind (Sindic) = N_Subtype_Indication
5806 and then Has_Per_Object_Constraint (Comp_Id)
5807 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
5810 ("component subtype subject to per-object constraint "
5811 & "must be an Unchecked_Union", Comp);
5813 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
5814 -- the body of a generic unit, or within the body of any of its
5815 -- descendant library units, no part of the type of a component
5816 -- declared in a variant_part of the unchecked union type shall be of
5817 -- a formal private type or formal private extension declared within
5818 -- the formal part of the generic unit.
5820 elsif Ada_Version >= Ada_2012
5821 and then In_Generic_Body (UU_Typ)
5822 and then In_Variant_Part
5823 and then Is_Private_Type (Typ)
5824 and then Is_Generic_Type (Typ)
5827 ("component of unchecked union cannot be of generic type", Comp);
5829 elsif Needs_Finalization (Typ) then
5831 ("component of unchecked union cannot be controlled", Comp);
5833 elsif Has_Task (Typ) then
5835 ("component of unchecked union cannot have tasks", Comp);
5837 end Check_Component;
5839 ----------------------------
5840 -- Check_Duplicate_Pragma --
5841 ----------------------------
5843 procedure Check_Duplicate_Pragma (E : Entity_Id) is
5844 Id : Entity_Id := E;
5848 -- Nothing to do if this pragma comes from an aspect specification,
5849 -- since we could not be duplicating a pragma, and we dealt with the
5850 -- case of duplicated aspects in Analyze_Aspect_Specifications.
5852 if From_Aspect_Specification (N) then
5856 -- Otherwise current pragma may duplicate previous pragma or a
5857 -- previously given aspect specification or attribute definition
5858 -- clause for the same pragma.
5860 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
5864 -- If the entity is a type, then we have to make sure that the
5865 -- ostensible duplicate is not for a parent type from which this
5869 if Nkind (P) = N_Pragma then
5871 Args : constant List_Id :=
5872 Pragma_Argument_Associations (P);
5875 and then Is_Entity_Name (Expression (First (Args)))
5876 and then Is_Type (Entity (Expression (First (Args))))
5877 and then Entity (Expression (First (Args))) /= E
5883 elsif Nkind (P) = N_Aspect_Specification
5884 and then Is_Type (Entity (P))
5885 and then Entity (P) /= E
5891 -- Here we have a definite duplicate
5893 Error_Msg_Name_1 := Pragma_Name (N);
5894 Error_Msg_Sloc := Sloc (P);
5896 -- For a single protected or a single task object, the error is
5897 -- issued on the original entity.
5899 if Ekind (Id) in E_Task_Type | E_Protected_Type then
5900 Id := Defining_Identifier (Original_Node (Parent (Id)));
5903 if Nkind (P) = N_Aspect_Specification
5904 or else From_Aspect_Specification (P)
5906 Error_Msg_NE ("aspect% for & previously given#", N, Id);
5908 -- If -gnatwr is set, warn in case of a duplicate pragma
5909 -- [No_]Inline which is suspicious but not an error, generate
5910 -- an error for other pragmas.
5912 if Pragma_Name (N) in Name_Inline | Name_No_Inline then
5913 if Warn_On_Redundant_Constructs then
5915 ("?r?pragma% for & duplicates pragma#", N, Id);
5918 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
5924 end Check_Duplicate_Pragma;
5926 ----------------------------------
5927 -- Check_Duplicated_Export_Name --
5928 ----------------------------------
5930 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
5931 String_Val : constant String_Id := Strval (Nam);
5934 -- We are only interested in the export case, and in the case of
5935 -- generics, it is the instance, not the template, that is the
5936 -- problem (the template will generate a warning in any case).
5938 if not Inside_A_Generic
5939 and then (Prag_Id = Pragma_Export
5941 Prag_Id = Pragma_Export_Procedure
5943 Prag_Id = Pragma_Export_Valued_Procedure
5945 Prag_Id = Pragma_Export_Function)
5947 for J in Externals.First .. Externals.Last loop
5948 if String_Equal (String_Val, Strval (Externals.Table (J))) then
5949 Error_Msg_Sloc := Sloc (Externals.Table (J));
5950 Error_Msg_N ("external name duplicates name given#", Nam);
5955 Externals.Append (Nam);
5957 end Check_Duplicated_Export_Name;
5959 ----------------------------------------
5960 -- Check_Expr_Is_OK_Static_Expression --
5961 ----------------------------------------
5963 procedure Check_Expr_Is_OK_Static_Expression
5965 Typ : Entity_Id := Empty)
5968 if Present (Typ) then
5969 Analyze_And_Resolve (Expr, Typ);
5971 Analyze_And_Resolve (Expr);
5974 -- An expression cannot be considered static if its resolution failed
5975 -- or if it's erroneous. Stop the analysis of the related pragma.
5977 if Etype (Expr) = Any_Type or else Error_Posted (Expr) then
5980 elsif Is_OK_Static_Expression (Expr) then
5983 -- An interesting special case, if we have a string literal and we
5984 -- are in Ada 83 mode, then we allow it even though it will not be
5985 -- flagged as static. This allows the use of Ada 95 pragmas like
5986 -- Import in Ada 83 mode. They will of course be flagged with
5987 -- warnings as usual, but will not cause errors.
5989 elsif Ada_Version = Ada_83
5990 and then Nkind (Expr) = N_String_Literal
5994 -- Finally, we have a real error
5997 Error_Msg_Name_1 := Pname;
5998 Flag_Non_Static_Expr
5999 (Fix_Error ("argument for pragma% must be a static expression!"),
6003 end Check_Expr_Is_OK_Static_Expression;
6005 -------------------------
6006 -- Check_First_Subtype --
6007 -------------------------
6009 procedure Check_First_Subtype (Arg : Node_Id) is
6010 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
6011 Ent : constant Entity_Id := Entity (Argx);
6014 if Is_First_Subtype (Ent) then
6017 elsif Is_Type (Ent) then
6019 ("pragma% cannot apply to subtype", Argx);
6021 elsif Is_Object (Ent) then
6023 ("pragma% cannot apply to object, requires a type", Argx);
6027 ("pragma% cannot apply to&, requires a type", Argx);
6029 end Check_First_Subtype;
6031 ----------------------
6032 -- Check_Identifier --
6033 ----------------------
6035 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
6038 and then Nkind (Arg) = N_Pragma_Argument_Association
6040 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
6041 Error_Msg_Name_1 := Pname;
6042 Error_Msg_Name_2 := Id;
6043 Error_Msg_N ("pragma% argument expects identifier%", Arg);
6047 end Check_Identifier;
6049 --------------------------------
6050 -- Check_Identifier_Is_One_Of --
6051 --------------------------------
6053 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
6056 and then Nkind (Arg) = N_Pragma_Argument_Association
6058 if Chars (Arg) = No_Name then
6059 Error_Msg_Name_1 := Pname;
6060 Error_Msg_N ("pragma% argument expects an identifier", Arg);
6063 elsif Chars (Arg) /= N1
6064 and then Chars (Arg) /= N2
6066 Error_Msg_Name_1 := Pname;
6067 Error_Msg_N ("invalid identifier for pragma% argument", Arg);
6071 end Check_Identifier_Is_One_Of;
6073 ---------------------------
6074 -- Check_In_Main_Program --
6075 ---------------------------
6077 procedure Check_In_Main_Program is
6078 P : constant Node_Id := Parent (N);
6081 -- Must be in subprogram body
6083 if Nkind (P) /= N_Subprogram_Body then
6084 Error_Pragma ("% pragma allowed only in subprogram");
6086 -- Otherwise warn if obviously not main program
6088 elsif Present (Parameter_Specifications (Specification (P)))
6089 or else not Is_Compilation_Unit (Defining_Entity (P))
6091 Error_Msg_Name_1 := Pname;
6093 ("??pragma% is only effective in main program", N);
6095 end Check_In_Main_Program;
6097 ---------------------------------------
6098 -- Check_Interrupt_Or_Attach_Handler --
6099 ---------------------------------------
6101 procedure Check_Interrupt_Or_Attach_Handler is
6102 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
6103 Handler_Proc, Proc_Scope : Entity_Id;
6108 if Prag_Id = Pragma_Interrupt_Handler then
6109 Check_Restriction (No_Dynamic_Attachment, N);
6112 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
6113 Proc_Scope := Scope (Handler_Proc);
6115 if Ekind (Proc_Scope) /= E_Protected_Type then
6117 ("argument of pragma% must be protected procedure", Arg1);
6120 -- For pragma case (as opposed to access case), check placement.
6121 -- We don't need to do that for aspects, because we have the
6122 -- check that they aspect applies an appropriate procedure.
6124 if not From_Aspect_Specification (N)
6125 and then Parent (N) /= Protected_Definition (Parent (Proc_Scope))
6127 Error_Pragma ("pragma% must be in protected definition");
6130 if not Is_Library_Level_Entity (Proc_Scope) then
6132 ("argument for pragma% must be library level entity", Arg1);
6135 -- AI05-0033: A pragma cannot appear within a generic body, because
6136 -- instance can be in a nested scope. The check that protected type
6137 -- is itself a library-level declaration is done elsewhere.
6139 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
6140 -- handle code prior to AI-0033. Analysis tools typically are not
6141 -- interested in this pragma in any case, so no need to worry too
6142 -- much about its placement.
6144 if Inside_A_Generic then
6145 if Ekind (Scope (Current_Scope)) = E_Generic_Package
6146 and then In_Package_Body (Scope (Current_Scope))
6147 and then not Relaxed_RM_Semantics
6149 Error_Pragma ("pragma% cannot be used inside a generic");
6152 end Check_Interrupt_Or_Attach_Handler;
6154 ---------------------------------
6155 -- Check_Loop_Pragma_Placement --
6156 ---------------------------------
6158 procedure Check_Loop_Pragma_Placement is
6159 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id);
6160 -- Verify whether the current pragma is properly grouped with other
6161 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
6162 -- related loop where the pragma appears.
6164 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean;
6165 -- Determine whether an arbitrary statement Stmt denotes pragma
6166 -- Loop_Invariant or Loop_Variant.
6168 procedure Placement_Error (Constr : Node_Id);
6169 pragma No_Return (Placement_Error);
6170 -- Node Constr denotes the last loop restricted construct before we
6171 -- encountered an illegal relation between enclosing constructs. Emit
6172 -- an error depending on what Constr was.
6174 --------------------------------
6175 -- Check_Loop_Pragma_Grouping --
6176 --------------------------------
6178 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is
6179 Stop_Search : exception;
6180 -- This exception is used to terminate the recursive descent of
6181 -- routine Check_Grouping.
6183 procedure Check_Grouping (L : List_Id);
6184 -- Find the first group of pragmas in list L and if successful,
6185 -- ensure that the current pragma is part of that group. The
6186 -- routine raises Stop_Search once such a check is performed to
6187 -- halt the recursive descent.
6189 procedure Grouping_Error (Prag : Node_Id);
6190 pragma No_Return (Grouping_Error);
6191 -- Emit an error concerning the current pragma indicating that it
6192 -- should be placed after pragma Prag.
6194 --------------------
6195 -- Check_Grouping --
6196 --------------------
6198 procedure Check_Grouping (L : List_Id) is
6201 Prag : Node_Id := Empty; -- init to avoid warning
6204 -- Inspect the list of declarations or statements looking for
6205 -- the first grouping of pragmas:
6208 -- pragma Loop_Invariant ...;
6209 -- pragma Loop_Variant ...;
6211 -- pragma Loop_Variant ...; -- current pragma
6213 -- If the current pragma is not in the grouping, then it must
6214 -- either appear in a different declarative or statement list
6215 -- or the construct at (1) is separating the pragma from the
6219 while Present (Stmt) loop
6221 -- First pragma of the first topmost grouping has been found
6223 if Is_Loop_Pragma (Stmt) then
6225 -- The group and the current pragma are not in the same
6226 -- declarative or statement list.
6228 if List_Containing (Stmt) /= List_Containing (N) then
6229 Grouping_Error (Stmt);
6231 -- Try to reach the current pragma from the first pragma
6232 -- of the grouping while skipping other members:
6234 -- pragma Loop_Invariant ...; -- first pragma
6235 -- pragma Loop_Variant ...; -- member
6237 -- pragma Loop_Variant ...; -- current pragma
6240 while Present (Stmt) loop
6241 -- The current pragma is either the first pragma
6242 -- of the group or is a member of the group.
6243 -- Stop the search as the placement is legal.
6248 -- Skip group members, but keep track of the
6249 -- last pragma in the group.
6251 elsif Is_Loop_Pragma (Stmt) then
6254 -- Skip declarations and statements generated by
6255 -- the compiler during expansion. Note that some
6256 -- source statements (e.g. pragma Assert) may have
6257 -- been transformed so that they do not appear as
6258 -- coming from source anymore, so we instead look
6259 -- at their Original_Node.
6261 elsif not Comes_From_Source (Original_Node (Stmt))
6265 -- A non-pragma is separating the group from the
6266 -- current pragma, the placement is illegal.
6269 Grouping_Error (Prag);
6275 -- If the traversal did not reach the current pragma,
6276 -- then the list must be malformed.
6278 raise Program_Error;
6281 -- Pragmas Loop_Invariant and Loop_Variant may only appear
6282 -- inside a loop or a block housed inside a loop. Inspect
6283 -- the declarations and statements of the block as they may
6284 -- contain the first grouping. This case follows the one for
6285 -- loop pragmas, as block statements which originate in a
6286 -- loop pragma (and so Is_Loop_Pragma will return True on
6287 -- that block statement) should be treated in the previous
6290 elsif Nkind (Stmt) = N_Block_Statement then
6291 HSS := Handled_Statement_Sequence (Stmt);
6293 Check_Grouping (Declarations (Stmt));
6295 if Present (HSS) then
6296 Check_Grouping (Statements (HSS));
6304 --------------------
6305 -- Grouping_Error --
6306 --------------------
6308 procedure Grouping_Error (Prag : Node_Id) is
6310 Error_Msg_Sloc := Sloc (Prag);
6311 Error_Pragma ("pragma% must appear next to pragma#");
6314 -- Start of processing for Check_Loop_Pragma_Grouping
6317 -- Inspect the statements of the loop or nested blocks housed
6318 -- within to determine whether the current pragma is part of the
6319 -- first topmost grouping of Loop_Invariant and Loop_Variant.
6321 Check_Grouping (Statements (Loop_Stmt));
6324 when Stop_Search => null;
6325 end Check_Loop_Pragma_Grouping;
6327 --------------------
6328 -- Is_Loop_Pragma --
6329 --------------------
6331 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean is
6333 -- Inspect the original node as Loop_Invariant and Loop_Variant
6334 -- pragmas are rewritten to null when assertions are disabled.
6336 if Nkind (Original_Node (Stmt)) = N_Pragma then
6338 Pragma_Name_Unmapped (Original_Node (Stmt))
6339 in Name_Loop_Invariant | Name_Loop_Variant;
6345 ---------------------
6346 -- Placement_Error --
6347 ---------------------
6349 procedure Placement_Error (Constr : Node_Id) is
6350 LA : constant String := " with Loop_Entry";
6353 if Prag_Id = Pragma_Assert then
6354 Error_Msg_String (1 .. LA'Length) := LA;
6355 Error_Msg_Strlen := LA'Length;
6357 Error_Msg_Strlen := 0;
6360 if Nkind (Constr) = N_Pragma then
6362 ("pragma %~ must appear immediately within the statements "
6366 ("block containing pragma %~ must appear immediately within "
6367 & "the statements of a loop", Constr);
6369 end Placement_Error;
6371 -- Local declarations
6376 -- Start of processing for Check_Loop_Pragma_Placement
6379 -- Check that pragma appears immediately within a loop statement,
6380 -- ignoring intervening block statements.
6384 while Present (Stmt) loop
6386 -- The pragma or previous block must appear immediately within the
6387 -- current block's declarative or statement part.
6389 if Nkind (Stmt) = N_Block_Statement then
6390 if (No (Declarations (Stmt))
6391 or else List_Containing (Prev) /= Declarations (Stmt))
6393 List_Containing (Prev) /=
6394 Statements (Handled_Statement_Sequence (Stmt))
6396 Placement_Error (Prev);
6399 -- Keep inspecting the parents because we are now within a
6400 -- chain of nested blocks.
6404 Stmt := Parent (Stmt);
6407 -- The pragma or previous block must appear immediately within the
6408 -- statements of the loop.
6410 elsif Nkind (Stmt) = N_Loop_Statement then
6411 if List_Containing (Prev) /= Statements (Stmt) then
6412 Placement_Error (Prev);
6415 -- Stop the traversal because we reached the innermost loop
6416 -- regardless of whether we encountered an error or not.
6420 -- Ignore a handled statement sequence. Note that this node may
6421 -- be related to a subprogram body in which case we will emit an
6422 -- error on the next iteration of the search.
6424 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then
6425 Stmt := Parent (Stmt);
6427 -- Any other statement breaks the chain from the pragma to the
6431 Placement_Error (Prev);
6436 -- Check that the current pragma Loop_Invariant or Loop_Variant is
6437 -- grouped together with other such pragmas.
6439 if Is_Loop_Pragma (N) then
6441 -- The previous check should have located the related loop
6443 pragma Assert (Nkind (Stmt) = N_Loop_Statement);
6444 Check_Loop_Pragma_Grouping (Stmt);
6446 end Check_Loop_Pragma_Placement;
6448 -------------------------------------------
6449 -- Check_Is_In_Decl_Part_Or_Package_Spec --
6450 -------------------------------------------
6452 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
6461 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
6464 elsif Nkind (P) in N_Package_Specification | N_Block_Statement then
6467 -- Note: the following tests seem a little peculiar, because
6468 -- they test for bodies, but if we were in the statement part
6469 -- of the body, we would already have hit the handled statement
6470 -- sequence, so the only way we get here is by being in the
6471 -- declarative part of the body.
6474 N_Subprogram_Body | N_Package_Body | N_Task_Body | N_Entry_Body
6482 Error_Pragma ("pragma% is not in declarative part or package spec");
6483 end Check_Is_In_Decl_Part_Or_Package_Spec;
6485 -------------------------
6486 -- Check_No_Identifier --
6487 -------------------------
6489 procedure Check_No_Identifier (Arg : Node_Id) is
6491 if Nkind (Arg) = N_Pragma_Argument_Association
6492 and then Chars (Arg) /= No_Name
6494 Error_Pragma_Arg_Ident
6495 ("pragma% does not permit identifier& here", Arg);
6497 end Check_No_Identifier;
6499 --------------------------
6500 -- Check_No_Identifiers --
6501 --------------------------
6503 procedure Check_No_Identifiers is
6507 for J in 1 .. Arg_Count loop
6508 Check_No_Identifier (Arg_Node);
6511 end Check_No_Identifiers;
6513 ------------------------
6514 -- Check_No_Link_Name --
6515 ------------------------
6517 procedure Check_No_Link_Name is
6519 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then
6523 if Present (Arg4) then
6525 ("Link_Name argument not allowed for Import Intrinsic", Arg4);
6527 end Check_No_Link_Name;
6529 -------------------------------
6530 -- Check_Optional_Identifier --
6531 -------------------------------
6533 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
6536 and then Nkind (Arg) = N_Pragma_Argument_Association
6537 and then Chars (Arg) /= No_Name
6539 if Chars (Arg) /= Id then
6540 Error_Msg_Name_1 := Pname;
6541 Error_Msg_Name_2 := Id;
6542 Error_Msg_N ("pragma% argument expects identifier%", Arg);
6546 end Check_Optional_Identifier;
6548 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
6550 Check_Optional_Identifier (Arg, Name_Find (Id));
6551 end Check_Optional_Identifier;
6553 -------------------------------------
6554 -- Check_Static_Boolean_Expression --
6555 -------------------------------------
6557 procedure Check_Static_Boolean_Expression (Expr : Node_Id) is
6559 if Present (Expr) then
6560 Analyze_And_Resolve (Expr, Standard_Boolean);
6562 if not Is_OK_Static_Expression (Expr) then
6564 ("expression of pragma % must be static", Expr);
6567 end Check_Static_Boolean_Expression;
6569 -----------------------------
6570 -- Check_Static_Constraint --
6571 -----------------------------
6573 -- Note: for convenience in writing this procedure, in addition to
6574 -- the officially (i.e. by spec) allowed argument which is always a
6575 -- constraint, it also allows ranges and discriminant associations.
6576 -- Above is not clear ???
6578 procedure Check_Static_Constraint (Constr : Node_Id) is
6580 procedure Require_Static (E : Node_Id);
6581 -- Require given expression to be static expression
6583 --------------------
6584 -- Require_Static --
6585 --------------------
6587 procedure Require_Static (E : Node_Id) is
6589 if not Is_OK_Static_Expression (E) then
6590 Flag_Non_Static_Expr
6591 ("non-static constraint not allowed in Unchecked_Union!", E);
6596 -- Start of processing for Check_Static_Constraint
6599 case Nkind (Constr) is
6600 when N_Discriminant_Association =>
6601 Require_Static (Expression (Constr));
6604 Require_Static (Low_Bound (Constr));
6605 Require_Static (High_Bound (Constr));
6607 when N_Attribute_Reference =>
6608 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
6609 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
6611 when N_Range_Constraint =>
6612 Check_Static_Constraint (Range_Expression (Constr));
6614 when N_Index_Or_Discriminant_Constraint =>
6618 IDC := First (Constraints (Constr));
6619 while Present (IDC) loop
6620 Check_Static_Constraint (IDC);
6628 end Check_Static_Constraint;
6630 --------------------------------------
6631 -- Check_Valid_Configuration_Pragma --
6632 --------------------------------------
6634 -- A configuration pragma must appear in the context clause of a
6635 -- compilation unit, and only other pragmas may precede it. Note that
6636 -- the test also allows use in a configuration pragma file.
6638 procedure Check_Valid_Configuration_Pragma is
6640 if not Is_Configuration_Pragma then
6641 Error_Pragma ("incorrect placement for configuration pragma%");
6643 end Check_Valid_Configuration_Pragma;
6645 -------------------------------------
6646 -- Check_Valid_Library_Unit_Pragma --
6647 -------------------------------------
6649 procedure Check_Valid_Library_Unit_Pragma is
6651 Parent_Node : Node_Id;
6652 Unit_Name : Entity_Id;
6653 Unit_Kind : Node_Kind;
6654 Unit_Node : Node_Id;
6655 Sindex : Source_File_Index;
6658 if not Is_List_Member (N) then
6662 Plist := List_Containing (N);
6663 Parent_Node := Parent (Plist);
6665 if Parent_Node = Empty then
6668 -- Case of pragma appearing after a compilation unit. In this case
6669 -- it must have an argument with the corresponding name and must
6670 -- be part of the following pragmas of its parent.
6672 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
6673 if Plist /= Pragmas_After (Parent_Node) then
6676 elsif Arg_Count = 0 then
6678 ("argument required if outside compilation unit");
6681 Check_No_Identifiers;
6682 Check_Arg_Count (1);
6683 Unit_Node := Unit (Parent (Parent_Node));
6684 Unit_Kind := Nkind (Unit_Node);
6686 Analyze (Get_Pragma_Arg (Arg1));
6688 if Unit_Kind = N_Generic_Subprogram_Declaration
6689 or else Unit_Kind = N_Subprogram_Declaration
6691 Unit_Name := Defining_Entity (Unit_Node);
6693 elsif Unit_Kind in N_Generic_Instantiation then
6694 Unit_Name := Defining_Entity (Unit_Node);
6697 Unit_Name := Cunit_Entity (Current_Sem_Unit);
6700 if Chars (Unit_Name) /=
6701 Chars (Entity (Get_Pragma_Arg (Arg1)))
6704 ("pragma% argument is not current unit name", Arg1);
6707 if Ekind (Unit_Name) = E_Package
6708 and then Present (Renamed_Entity (Unit_Name))
6710 Error_Pragma ("pragma% not allowed for renamed package");
6714 -- Pragma appears other than after a compilation unit
6717 -- Here we check for the generic instantiation case and also
6718 -- for the case of processing a generic formal package. We
6719 -- detect these cases by noting that the Sloc on the node
6720 -- does not belong to the current compilation unit.
6722 Sindex := Source_Index (Current_Sem_Unit);
6724 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
6725 Rewrite (N, Make_Null_Statement (Loc));
6728 -- If before first declaration, the pragma applies to the
6729 -- enclosing unit, and the name if present must be this name.
6731 elsif Is_Before_First_Decl (N, Plist) then
6732 Unit_Node := Unit_Declaration_Node (Current_Scope);
6733 Unit_Kind := Nkind (Unit_Node);
6735 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
6738 elsif Unit_Kind = N_Subprogram_Body
6739 and then not Acts_As_Spec (Unit_Node)
6743 elsif Nkind (Parent_Node) = N_Package_Body then
6746 elsif Nkind (Parent_Node) = N_Package_Specification
6747 and then Plist = Private_Declarations (Parent_Node)
6751 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
6752 or else Nkind (Parent_Node) =
6753 N_Generic_Subprogram_Declaration)
6754 and then Plist = Generic_Formal_Declarations (Parent_Node)
6758 elsif Arg_Count > 0 then
6759 Analyze (Get_Pragma_Arg (Arg1));
6761 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
6763 ("name in pragma% must be enclosing unit", Arg1);
6766 -- It is legal to have no argument in this context
6772 -- Error if not before first declaration. This is because a
6773 -- library unit pragma argument must be the name of a library
6774 -- unit (RM 10.1.5(7)), but the only names permitted in this
6775 -- context are (RM 10.1.5(6)) names of subprogram declarations,
6776 -- generic subprogram declarations or generic instantiations.
6780 ("pragma% misplaced, must be before first declaration");
6784 end Check_Valid_Library_Unit_Pragma;
6790 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
6791 Clist : constant Node_Id := Component_List (Variant);
6795 Comp := First_Non_Pragma (Component_Items (Clist));
6796 while Present (Comp) loop
6797 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
6798 Next_Non_Pragma (Comp);
6802 ---------------------------
6803 -- Ensure_Aggregate_Form --
6804 ---------------------------
6806 procedure Ensure_Aggregate_Form (Arg : Node_Id) is
6807 CFSD : constant Boolean := Get_Comes_From_Source_Default;
6808 Expr : constant Node_Id := Expression (Arg);
6809 Loc : constant Source_Ptr := Sloc (Expr);
6810 Comps : List_Id := No_List;
6811 Exprs : List_Id := No_List;
6812 Nam : Name_Id := No_Name;
6813 Nam_Loc : Source_Ptr;
6816 -- The pragma argument is in positional form:
6818 -- pragma Depends (Nam => ...)
6822 -- Note that the Sloc of the Chars field is the Sloc of the pragma
6823 -- argument association.
6825 if Nkind (Arg) = N_Pragma_Argument_Association then
6827 Nam_Loc := Sloc (Arg);
6829 -- Remove the pragma argument name as this will be captured in the
6832 Set_Chars (Arg, No_Name);
6835 -- The argument is already in aggregate form, but the presence of a
6836 -- name causes this to be interpreted as named association which in
6837 -- turn must be converted into an aggregate.
6839 -- pragma Global (In_Out => (A, B, C))
6843 -- pragma Global ((In_Out => (A, B, C)))
6845 -- aggregate aggregate
6847 if Nkind (Expr) = N_Aggregate then
6848 if Nam = No_Name then
6852 -- Do not transform a null argument into an aggregate as N_Null has
6853 -- special meaning in formal verification pragmas.
6855 elsif Nkind (Expr) = N_Null then
6859 -- Everything comes from source if the original comes from source
6861 Set_Comes_From_Source_Default (Comes_From_Source (Arg));
6863 -- Positional argument is transformed into an aggregate with an
6864 -- Expressions list.
6866 if Nam = No_Name then
6867 Exprs := New_List (Relocate_Node (Expr));
6869 -- An associative argument is transformed into an aggregate with
6870 -- Component_Associations.
6874 Make_Component_Association (Loc,
6875 Choices => New_List (Make_Identifier (Nam_Loc, Nam)),
6876 Expression => Relocate_Node (Expr)));
6879 Set_Expression (Arg,
6880 Make_Aggregate (Loc,
6881 Component_Associations => Comps,
6882 Expressions => Exprs));
6884 -- Restore Comes_From_Source default
6886 Set_Comes_From_Source_Default (CFSD);
6887 end Ensure_Aggregate_Form;
6893 procedure Error_Pragma (Msg : String) is
6895 Error_Msg_Name_1 := Pname;
6896 Error_Msg_N (Fix_Error (Msg), N);
6900 ----------------------
6901 -- Error_Pragma_Arg --
6902 ----------------------
6904 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
6906 Error_Msg_Name_1 := Pname;
6907 Error_Msg_N (Fix_Error (Msg), Get_Pragma_Arg (Arg));
6909 end Error_Pragma_Arg;
6911 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
6913 Error_Msg_Name_1 := Pname;
6914 Error_Msg_N (Fix_Error (Msg1), Get_Pragma_Arg (Arg));
6915 Error_Pragma_Arg (Msg2, Arg);
6916 end Error_Pragma_Arg;
6918 ----------------------------
6919 -- Error_Pragma_Arg_Ident --
6920 ----------------------------
6922 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
6924 Error_Msg_Name_1 := Pname;
6925 Error_Msg_N (Fix_Error (Msg), Arg);
6927 end Error_Pragma_Arg_Ident;
6929 ----------------------
6930 -- Error_Pragma_Ref --
6931 ----------------------
6933 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
6935 Error_Msg_Name_1 := Pname;
6936 Error_Msg_Sloc := Sloc (Ref);
6937 Error_Msg_NE (Fix_Error (Msg), N, Ref);
6939 end Error_Pragma_Ref;
6941 ------------------------
6942 -- Find_Lib_Unit_Name --
6943 ------------------------
6945 function Find_Lib_Unit_Name return Entity_Id is
6947 -- Return inner compilation unit entity, for case of nested
6948 -- categorization pragmas. This happens in generic unit.
6950 if Nkind (Parent (N)) = N_Package_Specification
6951 and then Defining_Entity (Parent (N)) /= Current_Scope
6953 return Defining_Entity (Parent (N));
6955 return Current_Scope;
6957 end Find_Lib_Unit_Name;
6959 ----------------------------
6960 -- Find_Program_Unit_Name --
6961 ----------------------------
6963 procedure Find_Program_Unit_Name (Id : Node_Id) is
6964 Unit_Name : Entity_Id;
6965 Unit_Kind : Node_Kind;
6966 P : constant Node_Id := Parent (N);
6969 if Nkind (P) = N_Compilation_Unit then
6970 Unit_Kind := Nkind (Unit (P));
6972 if Unit_Kind in N_Subprogram_Declaration
6973 | N_Package_Declaration
6974 | N_Generic_Declaration
6976 Unit_Name := Defining_Entity (Unit (P));
6978 if Chars (Id) = Chars (Unit_Name) then
6979 Set_Entity (Id, Unit_Name);
6980 Set_Etype (Id, Etype (Unit_Name));
6982 Set_Etype (Id, Any_Type);
6984 ("cannot find program unit referenced by pragma%");
6988 Set_Etype (Id, Any_Type);
6989 Error_Pragma ("pragma% inapplicable to this unit");
6995 end Find_Program_Unit_Name;
6997 -----------------------------------------
6998 -- Find_Unique_Parameterless_Procedure --
6999 -----------------------------------------
7001 function Find_Unique_Parameterless_Procedure
7003 Arg : Node_Id) return Entity_Id
7005 Proc : Entity_Id := Empty;
7008 -- The body of this procedure needs some comments ???
7010 if not Is_Entity_Name (Name) then
7012 ("argument of pragma% must be entity name", Arg);
7014 elsif not Is_Overloaded (Name) then
7015 Proc := Entity (Name);
7017 if Ekind (Proc) /= E_Procedure
7018 or else Present (First_Formal (Proc))
7021 ("argument of pragma% must be parameterless procedure", Arg);
7026 Found : Boolean := False;
7028 Index : Interp_Index;
7031 Get_First_Interp (Name, Index, It);
7032 while Present (It.Nam) loop
7035 if Ekind (Proc) = E_Procedure
7036 and then No (First_Formal (Proc))
7040 Set_Entity (Name, Proc);
7041 Set_Is_Overloaded (Name, False);
7044 ("ambiguous handler name for pragma% ", Arg);
7048 Get_Next_Interp (Index, It);
7053 ("argument of pragma% must be parameterless procedure",
7056 Proc := Entity (Name);
7062 end Find_Unique_Parameterless_Procedure;
7068 function Fix_Error (Msg : String) return String is
7069 Res : String (Msg'Range) := Msg;
7070 Res_Last : Natural := Msg'Last;
7074 -- If we have a rewriting of another pragma, go to that pragma
7076 if Is_Rewrite_Substitution (N)
7077 and then Nkind (Original_Node (N)) = N_Pragma
7079 Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
7082 -- Case where pragma comes from an aspect specification
7084 if From_Aspect_Specification (N) then
7086 -- Change appearence of "pragma" in message to "aspect"
7089 while J <= Res_Last - 5 loop
7090 if Res (J .. J + 5) = "pragma" then
7091 Res (J .. J + 5) := "aspect";
7099 -- Change "argument of" at start of message to "entity for"
7102 and then Res (Res'First .. Res'First + 10) = "argument of"
7104 Res (Res'First .. Res'First + 9) := "entity for";
7105 Res (Res'First + 10 .. Res_Last - 1) :=
7106 Res (Res'First + 11 .. Res_Last);
7107 Res_Last := Res_Last - 1;
7110 -- Change "argument" at start of message to "entity"
7113 and then Res (Res'First .. Res'First + 7) = "argument"
7115 Res (Res'First .. Res'First + 5) := "entity";
7116 Res (Res'First + 6 .. Res_Last - 2) :=
7117 Res (Res'First + 8 .. Res_Last);
7118 Res_Last := Res_Last - 2;
7121 -- Get name from corresponding aspect
7123 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
7126 -- Return possibly modified message
7128 return Res (Res'First .. Res_Last);
7131 -------------------------
7132 -- Gather_Associations --
7133 -------------------------
7135 procedure Gather_Associations
7137 Args : out Args_List)
7142 -- Initialize all parameters to Empty
7144 for J in Args'Range loop
7148 -- That's all we have to do if there are no argument associations
7150 if No (Pragma_Argument_Associations (N)) then
7154 -- Otherwise first deal with any positional parameters present
7156 Arg := First (Pragma_Argument_Associations (N));
7157 for Index in Args'Range loop
7158 exit when No (Arg) or else Chars (Arg) /= No_Name;
7159 Args (Index) := Get_Pragma_Arg (Arg);
7163 -- Positional parameters all processed, if any left, then we
7164 -- have too many positional parameters.
7166 if Present (Arg) and then Chars (Arg) = No_Name then
7168 ("too many positional associations for pragma%", Arg);
7171 -- Process named parameters if any are present
7173 while Present (Arg) loop
7174 if Chars (Arg) = No_Name then
7176 ("positional association cannot follow named association",
7180 for Index in Names'Range loop
7181 if Names (Index) = Chars (Arg) then
7182 if Present (Args (Index)) then
7184 ("duplicate argument association for pragma%", Arg);
7186 Args (Index) := Get_Pragma_Arg (Arg);
7191 if Index = Names'Last then
7192 Error_Msg_Name_1 := Pname;
7193 Error_Msg_N ("pragma% does not allow & argument", Arg);
7195 -- Check for possible misspelling
7197 for Index1 in Names'Range loop
7198 if Is_Bad_Spelling_Of
7199 (Chars (Arg), Names (Index1))
7201 Error_Msg_Name_1 := Names (Index1);
7202 Error_Msg_N -- CODEFIX
7203 ("\possible misspelling of%", Arg);
7215 end Gather_Associations;
7221 procedure GNAT_Pragma is
7223 -- We need to check the No_Implementation_Pragmas restriction for
7224 -- the case of a pragma from source. Note that the case of aspects
7225 -- generating corresponding pragmas marks these pragmas as not being
7226 -- from source, so this test also catches that case.
7228 if Comes_From_Source (N) then
7229 Check_Restriction (No_Implementation_Pragmas, N);
7233 --------------------------
7234 -- Is_Before_First_Decl --
7235 --------------------------
7237 function Is_Before_First_Decl
7238 (Pragma_Node : Node_Id;
7239 Decls : List_Id) return Boolean
7241 Item : Node_Id := First (Decls);
7244 -- Only other pragmas can come before this pragma, but they might
7245 -- have been rewritten so check the original node.
7248 if No (Item) or else Nkind (Original_Node (Item)) /= N_Pragma then
7251 elsif Item = Pragma_Node then
7257 end Is_Before_First_Decl;
7259 -----------------------------
7260 -- Is_Configuration_Pragma --
7261 -----------------------------
7263 -- A configuration pragma must appear in the context clause of a
7264 -- compilation unit, and only other pragmas may precede it. Note that
7265 -- the test below also permits use in a configuration pragma file.
7267 function Is_Configuration_Pragma return Boolean is
7268 Lis : constant List_Id := List_Containing (N);
7269 Par : constant Node_Id := Parent (N);
7273 -- If no parent, then we are in the configuration pragma file,
7274 -- so the placement is definitely appropriate.
7279 -- Otherwise we must be in the context clause of a compilation unit
7280 -- and the only thing allowed before us in the context list is more
7281 -- configuration pragmas.
7283 elsif Nkind (Par) = N_Compilation_Unit
7284 and then Context_Items (Par) = Lis
7291 elsif Nkind (Prg) /= N_Pragma then
7301 end Is_Configuration_Pragma;
7303 --------------------------
7304 -- Is_In_Context_Clause --
7305 --------------------------
7307 function Is_In_Context_Clause return Boolean is
7309 Parent_Node : Node_Id;
7312 if not Is_List_Member (N) then
7316 Plist := List_Containing (N);
7317 Parent_Node := Parent (Plist);
7319 if Parent_Node = Empty
7320 or else Nkind (Parent_Node) /= N_Compilation_Unit
7321 or else Context_Items (Parent_Node) /= Plist
7328 end Is_In_Context_Clause;
7330 ---------------------------------
7331 -- Is_Static_String_Expression --
7332 ---------------------------------
7334 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
7335 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
7336 Lit : constant Boolean := Nkind (Argx) = N_String_Literal;
7339 Analyze_And_Resolve (Argx);
7341 -- Special case Ada 83, where the expression will never be static,
7342 -- but we will return true if we had a string literal to start with.
7344 if Ada_Version = Ada_83 then
7347 -- Normal case, true only if we end up with a string literal that
7348 -- is marked as being the result of evaluating a static expression.
7351 return Is_OK_Static_Expression (Argx)
7352 and then Nkind (Argx) = N_String_Literal;
7355 end Is_Static_String_Expression;
7357 ----------------------
7358 -- Pragma_Misplaced --
7359 ----------------------
7361 procedure Pragma_Misplaced is
7363 Error_Pragma ("incorrect placement of pragma%");
7364 end Pragma_Misplaced;
7366 ------------------------------------------------
7367 -- Process_Atomic_Independent_Shared_Volatile --
7368 ------------------------------------------------
7370 procedure Process_Atomic_Independent_Shared_Volatile is
7371 procedure Check_VFA_Conflicts (Ent : Entity_Id);
7372 -- Check that Volatile_Full_Access and VFA do not conflict
7374 procedure Mark_Component_Or_Object (Ent : Entity_Id);
7375 -- Appropriately set flags on the given entity, either an array or
7376 -- record component, or an object declaration) according to the
7379 procedure Mark_Type (Ent : Entity_Id);
7380 -- Appropriately set flags on the given entity, a type
7382 procedure Set_Atomic_VFA (Ent : Entity_Id);
7383 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
7384 -- no explicit alignment was given, set alignment to unknown, since
7385 -- back end knows what the alignment requirements are for atomic and
7386 -- full access arrays. Note: this is necessary for derived types.
7388 -------------------------
7389 -- Check_VFA_Conflicts --
7390 -------------------------
7392 procedure Check_VFA_Conflicts (Ent : Entity_Id) is
7396 VFA_And_Atomic : Boolean := False;
7397 -- Set True if both VFA and Atomic present
7400 -- Fetch the type in case we are dealing with an object or
7403 if Is_Type (Ent) then
7406 pragma Assert (Is_Object (Ent)
7408 Nkind (Declaration_Node (Ent)) = N_Component_Declaration);
7413 -- Check Atomic and VFA used together
7415 if Prag_Id = Pragma_Volatile_Full_Access
7416 or else Is_Volatile_Full_Access (Ent)
7418 if Prag_Id = Pragma_Atomic
7419 or else Prag_Id = Pragma_Shared
7420 or else Is_Atomic (Ent)
7422 VFA_And_Atomic := True;
7424 elsif Is_Array_Type (Typ) then
7425 VFA_And_Atomic := Has_Atomic_Components (Typ);
7427 -- Note: Has_Atomic_Components is not used below, as this flag
7428 -- represents the pragma of the same name, Atomic_Components,
7429 -- which only applies to arrays.
7431 elsif Is_Record_Type (Typ) then
7432 -- Attributes cannot be applied to discriminants, only
7433 -- regular record components.
7435 Comp := First_Component (Typ);
7436 while Present (Comp) loop
7438 or else Is_Atomic (Typ)
7440 VFA_And_Atomic := True;
7445 Next_Component (Comp);
7449 if VFA_And_Atomic then
7451 ("cannot have Volatile_Full_Access and Atomic for same "
7455 end Check_VFA_Conflicts;
7457 ------------------------------
7458 -- Mark_Component_Or_Object --
7459 ------------------------------
7461 procedure Mark_Component_Or_Object (Ent : Entity_Id) is
7463 if Prag_Id = Pragma_Atomic
7464 or else Prag_Id = Pragma_Shared
7465 or else Prag_Id = Pragma_Volatile_Full_Access
7467 if Prag_Id = Pragma_Volatile_Full_Access then
7468 Set_Is_Volatile_Full_Access (Ent);
7470 Set_Is_Atomic (Ent);
7473 -- If the object declaration has an explicit initialization, a
7474 -- temporary may have to be created to hold the expression, to
7475 -- ensure that access to the object remains atomic.
7477 if Nkind (Parent (Ent)) = N_Object_Declaration
7478 and then Present (Expression (Parent (Ent)))
7480 Set_Has_Delayed_Freeze (Ent);
7484 -- Atomic/Shared/Volatile_Full_Access imply Independent
7486 if Prag_Id /= Pragma_Volatile then
7487 Set_Is_Independent (Ent);
7489 if Prag_Id = Pragma_Independent then
7490 Record_Independence_Check (N, Ent);
7494 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7496 if Prag_Id /= Pragma_Independent then
7497 Set_Is_Volatile (Ent);
7498 Set_Treat_As_Volatile (Ent);
7500 end Mark_Component_Or_Object;
7506 procedure Mark_Type (Ent : Entity_Id) is
7508 -- Attribute belongs on the base type. If the view of the type is
7509 -- currently private, it also belongs on the underlying type.
7511 -- In Ada 2020, the pragma can apply to a formal type, for which
7512 -- there may be no underlying type.
7514 if Prag_Id = Pragma_Atomic
7515 or else Prag_Id = Pragma_Shared
7516 or else Prag_Id = Pragma_Volatile_Full_Access
7518 Set_Atomic_VFA (Ent);
7519 Set_Atomic_VFA (Base_Type (Ent));
7521 if not Is_Generic_Type (Ent) then
7522 Set_Atomic_VFA (Underlying_Type (Ent));
7526 -- Atomic/Shared/Volatile_Full_Access imply Independent
7528 if Prag_Id /= Pragma_Volatile then
7529 Set_Is_Independent (Ent);
7530 Set_Is_Independent (Base_Type (Ent));
7532 if not Is_Generic_Type (Ent) then
7533 Set_Is_Independent (Underlying_Type (Ent));
7535 if Prag_Id = Pragma_Independent then
7536 Record_Independence_Check (N, Base_Type (Ent));
7541 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7543 if Prag_Id /= Pragma_Independent then
7544 Set_Is_Volatile (Ent);
7545 Set_Is_Volatile (Base_Type (Ent));
7547 if not Is_Generic_Type (Ent) then
7548 Set_Is_Volatile (Underlying_Type (Ent));
7549 Set_Treat_As_Volatile (Underlying_Type (Ent));
7552 Set_Treat_As_Volatile (Ent);
7555 -- Apply Volatile to the composite type's individual components,
7558 if Prag_Id = Pragma_Volatile
7559 and then Is_Record_Type (Etype (Ent))
7564 Comp := First_Component (Ent);
7565 while Present (Comp) loop
7566 Mark_Component_Or_Object (Comp);
7568 Next_Component (Comp);
7574 --------------------
7575 -- Set_Atomic_VFA --
7576 --------------------
7578 procedure Set_Atomic_VFA (Ent : Entity_Id) is
7580 if Prag_Id = Pragma_Volatile_Full_Access then
7581 Set_Is_Volatile_Full_Access (Ent);
7583 Set_Is_Atomic (Ent);
7586 if not Has_Alignment_Clause (Ent) then
7587 Set_Alignment (Ent, Uint_0);
7597 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
7600 Check_Ada_83_Warning;
7601 Check_No_Identifiers;
7602 Check_Arg_Count (1);
7603 Check_Arg_Is_Local_Name (Arg1);
7604 E_Arg := Get_Pragma_Arg (Arg1);
7606 if Etype (E_Arg) = Any_Type then
7610 E := Entity (E_Arg);
7612 -- A pragma that applies to a Ghost entity becomes Ghost for the
7613 -- purposes of legality checks and removal of ignored Ghost code.
7615 Mark_Ghost_Pragma (N, E);
7617 -- Check duplicate before we chain ourselves
7619 Check_Duplicate_Pragma (E);
7621 -- Check appropriateness of the entity
7623 Decl := Declaration_Node (E);
7625 -- Deal with the case where the pragma/attribute is applied to a type
7628 if Rep_Item_Too_Early (E, N)
7629 or else Rep_Item_Too_Late (E, N)
7633 Check_First_Subtype (Arg1);
7638 -- Deal with the case where the pragma/attribute applies to a
7639 -- component or object declaration.
7641 elsif Nkind (Decl) = N_Object_Declaration
7642 or else (Nkind (Decl) = N_Component_Declaration
7643 and then Original_Record_Component (E) = E)
7645 if Rep_Item_Too_Late (E, N) then
7649 Mark_Component_Or_Object (E);
7651 -- In other cases give an error
7654 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
7657 -- Check that Volatile_Full_Access and Atomic do not conflict
7659 Check_VFA_Conflicts (E);
7661 -- Check for the application of Atomic or Volatile_Full_Access to
7662 -- an entity that has [nonatomic] aliased, or else specified to be
7663 -- independently addressable, subcomponents.
7665 if (Prag_Id = Pragma_Atomic and then Ada_Version >= Ada_2020)
7666 or else Prag_Id = Pragma_Volatile_Full_Access
7668 Check_Atomic_VFA (E, VFA => Prag_Id = Pragma_Volatile_Full_Access);
7671 -- The following check is only relevant when SPARK_Mode is on as
7672 -- this is not a standard Ada legality rule. Pragma Volatile can
7673 -- only apply to a full type declaration or an object declaration
7674 -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for
7675 -- untagged derived types that are rewritten as subtypes of their
7676 -- respective root types.
7679 and then Prag_Id = Pragma_Volatile
7680 and then Nkind (Original_Node (Decl)) not in
7681 N_Full_Type_Declaration |
7682 N_Formal_Type_Declaration |
7683 N_Object_Declaration |
7684 N_Single_Protected_Declaration |
7685 N_Single_Task_Declaration
7688 ("argument of pragma % must denote a full type or object "
7689 & "declaration", Arg1);
7691 end Process_Atomic_Independent_Shared_Volatile;
7693 -------------------------------------------
7694 -- Process_Compile_Time_Warning_Or_Error --
7695 -------------------------------------------
7697 procedure Process_Compile_Time_Warning_Or_Error is
7698 P : Node_Id := Parent (N);
7699 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
7702 Check_Arg_Count (2);
7703 Check_No_Identifiers;
7704 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
7705 Analyze_And_Resolve (Arg1x, Standard_Boolean);
7707 -- In GNATprove mode, pragma Compile_Time_Error is translated as
7708 -- a Check pragma in GNATprove mode, handled as an assumption in
7709 -- GNATprove. This is correct as the compiler will issue an error
7710 -- if the condition cannot be statically evaluated to False.
7711 -- Compile_Time_Warning are ignored, as the analyzer may not have the
7712 -- same information as the compiler (in particular regarding size of
7713 -- objects decided in gigi) so it makes no sense to issue a warning
7716 if GNATprove_Mode then
7717 if Prag_Id = Pragma_Compile_Time_Error then
7721 -- Implement Compile_Time_Error by generating
7722 -- a corresponding Check pragma:
7724 -- pragma Check (name, condition);
7726 -- where name is the identifier matching the pragma name. So
7727 -- rewrite pragma in this manner and analyze the result.
7729 New_Args := New_List
7730 (Make_Pragma_Argument_Association
7732 Expression => Make_Identifier (Loc, Pname)),
7733 Make_Pragma_Argument_Association
7735 Expression => Arg1x));
7737 -- Rewrite as Check pragma
7741 Chars => Name_Check,
7742 Pragma_Argument_Associations => New_Args));
7748 Rewrite (N, Make_Null_Statement (Loc));
7754 -- If the condition is known at compile time (now), validate it now.
7755 -- Otherwise, register the expression for validation after the back
7756 -- end has been called, because it might be known at compile time
7757 -- then. For example, if the expression is "Record_Type'Size /= 32"
7758 -- it might be known after the back end has determined the size of
7759 -- Record_Type. We do not defer validation if we're inside a generic
7760 -- unit, because we will have more information in the instances.
7762 if Compile_Time_Known_Value (Arg1x) then
7763 Validate_Compile_Time_Warning_Or_Error (N, Sloc (Arg1));
7765 while Present (P) and then Nkind (P) not in N_Generic_Declaration
7767 if Nkind (P) in N_Package_Body | N_Subprogram_Body then
7768 P := Corresponding_Spec (P);
7775 Defer_Compile_Time_Warning_Error_To_BE (N);
7778 end Process_Compile_Time_Warning_Or_Error;
7780 ------------------------
7781 -- Process_Convention --
7782 ------------------------
7784 procedure Process_Convention
7785 (C : out Convention_Id;
7786 Ent : out Entity_Id)
7790 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
7791 -- Called if we have more than one Export/Import/Convention pragma.
7792 -- This is generally illegal, but we have a special case of allowing
7793 -- Import and Interface to coexist if they specify the convention in
7794 -- a consistent manner. We are allowed to do this, since Interface is
7795 -- an implementation defined pragma, and we choose to do it since we
7796 -- know Rational allows this combination. S is the entity id of the
7797 -- subprogram in question. This procedure also sets the special flag
7798 -- Import_Interface_Present in both pragmas in the case where we do
7799 -- have matching Import and Interface pragmas.
7801 procedure Set_Convention_From_Pragma (E : Entity_Id);
7802 -- Set convention in entity E, and also flag that the entity has a
7803 -- convention pragma. If entity is for a private or incomplete type,
7804 -- also set convention and flag on underlying type. This procedure
7805 -- also deals with the special case of C_Pass_By_Copy convention,
7806 -- and error checks for inappropriate convention specification.
7808 -------------------------------
7809 -- Diagnose_Multiple_Pragmas --
7810 -------------------------------
7812 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
7813 Pdec : constant Node_Id := Declaration_Node (S);
7817 function Same_Convention (Decl : Node_Id) return Boolean;
7818 -- Decl is a pragma node. This function returns True if this
7819 -- pragma has a first argument that is an identifier with a
7820 -- Chars field corresponding to the Convention_Id C.
7822 function Same_Name (Decl : Node_Id) return Boolean;
7823 -- Decl is a pragma node. This function returns True if this
7824 -- pragma has a second argument that is an identifier with a
7825 -- Chars field that matches the Chars of the current subprogram.
7827 ---------------------
7828 -- Same_Convention --
7829 ---------------------
7831 function Same_Convention (Decl : Node_Id) return Boolean is
7832 Arg1 : constant Node_Id :=
7833 First (Pragma_Argument_Associations (Decl));
7836 if Present (Arg1) then
7838 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
7840 if Nkind (Arg) = N_Identifier
7841 and then Is_Convention_Name (Chars (Arg))
7842 and then Get_Convention_Id (Chars (Arg)) = C
7850 end Same_Convention;
7856 function Same_Name (Decl : Node_Id) return Boolean is
7857 Arg1 : constant Node_Id :=
7858 First (Pragma_Argument_Associations (Decl));
7866 Arg2 := Next (Arg1);
7873 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
7875 if Nkind (Arg) = N_Identifier
7876 and then Chars (Arg) = Chars (S)
7885 -- Start of processing for Diagnose_Multiple_Pragmas
7890 -- Definitely give message if we have Convention/Export here
7892 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
7895 -- If we have an Import or Export, scan back from pragma to
7896 -- find any previous pragma applying to the same procedure.
7897 -- The scan will be terminated by the start of the list, or
7898 -- hitting the subprogram declaration. This won't allow one
7899 -- pragma to appear in the public part and one in the private
7900 -- part, but that seems very unlikely in practice.
7904 while Present (Decl) and then Decl /= Pdec loop
7906 -- Look for pragma with same name as us
7908 if Nkind (Decl) = N_Pragma
7909 and then Same_Name (Decl)
7911 -- Give error if same as our pragma or Export/Convention
7913 if Pragma_Name_Unmapped (Decl)
7916 | Pragma_Name_Unmapped (N)
7920 -- Case of Import/Interface or the other way round
7922 elsif Pragma_Name_Unmapped (Decl)
7923 in Name_Interface | Name_Import
7925 -- Here we know that we have Import and Interface. It
7926 -- doesn't matter which way round they are. See if
7927 -- they specify the same convention. If so, all OK,
7928 -- and set special flags to stop other messages
7930 if Same_Convention (Decl) then
7931 Set_Import_Interface_Present (N);
7932 Set_Import_Interface_Present (Decl);
7935 -- If different conventions, special message
7938 Error_Msg_Sloc := Sloc (Decl);
7940 ("convention differs from that given#", Arg1);
7950 -- Give message if needed if we fall through those tests
7951 -- except on Relaxed_RM_Semantics where we let go: either this
7952 -- is a case accepted/ignored by other Ada compilers (e.g.
7953 -- a mix of Convention and Import), or another error will be
7954 -- generated later (e.g. using both Import and Export).
7956 if Err and not Relaxed_RM_Semantics then
7958 ("at most one Convention/Export/Import pragma is allowed",
7961 end Diagnose_Multiple_Pragmas;
7963 --------------------------------
7964 -- Set_Convention_From_Pragma --
7965 --------------------------------
7967 procedure Set_Convention_From_Pragma (E : Entity_Id) is
7969 -- Ada 2005 (AI-430): Check invalid attempt to change convention
7970 -- for an overridden dispatching operation. Technically this is
7971 -- an amendment and should only be done in Ada 2005 mode. However,
7972 -- this is clearly a mistake, since the problem that is addressed
7973 -- by this AI is that there is a clear gap in the RM.
7975 if Is_Dispatching_Operation (E)
7976 and then Present (Overridden_Operation (E))
7977 and then C /= Convention (Overridden_Operation (E))
7980 ("cannot change convention for overridden dispatching "
7981 & "operation", Arg1);
7983 -- Special check for convention Stdcall: a dispatching call is not
7984 -- allowed. A dispatching subprogram cannot be used to interface
7985 -- to the Win32 API, so this check actually does not impose any
7986 -- effective restriction.
7988 elsif Is_Dispatching_Operation (E)
7989 and then C = Convention_Stdcall
7991 -- Note: make this unconditional so that if there is more
7992 -- than one call to which the pragma applies, we get a
7993 -- message for each call. Also don't use Error_Pragma,
7994 -- so that we get multiple messages.
7996 Error_Msg_Sloc := Sloc (E);
7998 ("dispatching subprogram# cannot use Stdcall convention!",
7999 Get_Pragma_Arg (Arg1));
8002 -- Set the convention
8004 Set_Convention (E, C);
8005 Set_Has_Convention_Pragma (E);
8007 -- For the case of a record base type, also set the convention of
8008 -- any anonymous access types declared in the record which do not
8009 -- currently have a specified convention.
8010 -- Similarly for an array base type and anonymous access types
8013 if Is_Base_Type (E) then
8014 if Is_Record_Type (E) then
8019 Comp := First_Component (E);
8020 while Present (Comp) loop
8021 if Present (Etype (Comp))
8023 Ekind (Etype (Comp)) in
8024 E_Anonymous_Access_Type |
8025 E_Anonymous_Access_Subprogram_Type
8026 and then not Has_Convention_Pragma (Comp)
8028 Set_Convention (Comp, C);
8031 Next_Component (Comp);
8035 elsif Is_Array_Type (E)
8036 and then Ekind (Component_Type (E)) in
8037 E_Anonymous_Access_Type |
8038 E_Anonymous_Access_Subprogram_Type
8040 Set_Convention (Designated_Type (Component_Type (E)), C);
8044 -- Deal with incomplete/private type case, where underlying type
8045 -- is available, so set convention of that underlying type.
8047 if Is_Incomplete_Or_Private_Type (E)
8048 and then Present (Underlying_Type (E))
8050 Set_Convention (Underlying_Type (E), C);
8051 Set_Has_Convention_Pragma (Underlying_Type (E), True);
8054 -- A class-wide type should inherit the convention of the specific
8055 -- root type (although this isn't specified clearly by the RM).
8057 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
8058 Set_Convention (Class_Wide_Type (E), C);
8061 -- If the entity is a record type, then check for special case of
8062 -- C_Pass_By_Copy, which is treated the same as C except that the
8063 -- special record flag is set. This convention is only permitted
8064 -- on record types (see AI95-00131).
8066 if Cname = Name_C_Pass_By_Copy then
8067 if Is_Record_Type (E) then
8068 Set_C_Pass_By_Copy (Base_Type (E));
8069 elsif Is_Incomplete_Or_Private_Type (E)
8070 and then Is_Record_Type (Underlying_Type (E))
8072 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
8075 ("C_Pass_By_Copy convention allowed only for record type",
8080 -- If the entity is a derived boolean type, check for the special
8081 -- case of convention C, C++, or Fortran, where we consider any
8082 -- nonzero value to represent true.
8084 if Is_Discrete_Type (E)
8085 and then Root_Type (Etype (E)) = Standard_Boolean
8091 C = Convention_Fortran)
8093 Set_Nonzero_Is_True (Base_Type (E));
8095 end Set_Convention_From_Pragma;
8099 Comp_Unit : Unit_Number_Type;
8105 -- Start of processing for Process_Convention
8108 Check_At_Least_N_Arguments (2);
8109 Check_Optional_Identifier (Arg1, Name_Convention);
8110 Check_Arg_Is_Identifier (Arg1);
8111 Cname := Chars (Get_Pragma_Arg (Arg1));
8113 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
8114 -- tested again below to set the critical flag).
8116 if Cname = Name_C_Pass_By_Copy then
8119 -- Otherwise we must have something in the standard convention list
8121 elsif Is_Convention_Name (Cname) then
8122 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
8124 -- Otherwise warn on unrecognized convention
8127 if Warn_On_Export_Import then
8129 ("??unrecognized convention name, C assumed",
8130 Get_Pragma_Arg (Arg1));
8136 Check_Optional_Identifier (Arg2, Name_Entity);
8137 Check_Arg_Is_Local_Name (Arg2);
8139 Id := Get_Pragma_Arg (Arg2);
8142 if not Is_Entity_Name (Id) then
8143 Error_Pragma_Arg ("entity name required", Arg2);
8148 -- Set entity to return
8152 -- Ada_Pass_By_Copy special checking
8154 if C = Convention_Ada_Pass_By_Copy then
8155 if not Is_First_Subtype (E) then
8157 ("convention `Ada_Pass_By_Copy` only allowed for types",
8161 if Is_By_Reference_Type (E) then
8163 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
8167 -- Ada_Pass_By_Reference special checking
8169 elsif C = Convention_Ada_Pass_By_Reference then
8170 if not Is_First_Subtype (E) then
8172 ("convention `Ada_Pass_By_Reference` only allowed for types",
8176 if Is_By_Copy_Type (E) then
8178 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
8183 -- Go to renamed subprogram if present, since convention applies to
8184 -- the actual renamed entity, not to the renaming entity. If the
8185 -- subprogram is inherited, go to parent subprogram.
8187 if Is_Subprogram (E)
8188 and then Present (Alias (E))
8190 if Nkind (Parent (Declaration_Node (E))) =
8191 N_Subprogram_Renaming_Declaration
8193 if Scope (E) /= Scope (Alias (E)) then
8195 ("cannot apply pragma% to non-local entity&#", E);
8200 elsif Nkind (Parent (E)) in
8201 N_Full_Type_Declaration | N_Private_Extension_Declaration
8202 and then Scope (E) = Scope (Alias (E))
8206 -- Return the parent subprogram the entity was inherited from
8212 -- Check that we are not applying this to a specless body. Relax this
8213 -- check if Relaxed_RM_Semantics to accommodate other Ada compilers.
8215 if Is_Subprogram (E)
8216 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
8217 and then not Relaxed_RM_Semantics
8220 ("pragma% requires separate spec and must come before body");
8223 -- Check that we are not applying this to a named constant
8225 if Ekind (E) in E_Named_Integer | E_Named_Real then
8226 Error_Msg_Name_1 := Pname;
8228 ("cannot apply pragma% to named constant!",
8229 Get_Pragma_Arg (Arg2));
8231 ("\supply appropriate type for&!", Arg2);
8234 if Ekind (E) = E_Enumeration_Literal then
8235 Error_Pragma ("enumeration literal not allowed for pragma%");
8238 -- Check for rep item appearing too early or too late
8240 if Etype (E) = Any_Type
8241 or else Rep_Item_Too_Early (E, N)
8245 elsif Present (Underlying_Type (E)) then
8246 E := Underlying_Type (E);
8249 if Rep_Item_Too_Late (E, N) then
8253 if Has_Convention_Pragma (E) then
8254 Diagnose_Multiple_Pragmas (E);
8256 elsif Convention (E) = Convention_Protected
8257 or else Ekind (Scope (E)) = E_Protected_Type
8260 ("a protected operation cannot be given a different convention",
8264 -- For Intrinsic, a subprogram is required
8266 if C = Convention_Intrinsic
8267 and then not Is_Subprogram_Or_Generic_Subprogram (E)
8269 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
8271 if not (Is_Type (E) and then Relaxed_RM_Semantics) then
8273 ("second argument of pragma% must be a subprogram", Arg2);
8276 -- Special checks for C_Variadic_n
8278 elsif C in Convention_C_Variadic then
8280 -- Several allowed cases
8282 if Is_Subprogram_Or_Generic_Subprogram (E) then
8285 -- An access to subprogram is also allowed
8287 elsif Is_Access_Type (E)
8288 and then Ekind (Designated_Type (E)) = E_Subprogram_Type
8290 Subp := Designated_Type (E);
8292 -- Allow internal call to set convention of subprogram type
8294 elsif Ekind (E) = E_Subprogram_Type then
8299 ("argument of pragma% must be subprogram or access type",
8304 -- ISO C requires a named parameter before the ellipsis, so a
8305 -- variadic C function taking 0 fixed parameter cannot exist.
8307 if C = Convention_C_Variadic_0 then
8310 ("??C_Variadic_0 cannot be used for an 'I'S'O C function",
8311 Get_Pragma_Arg (Arg2));
8313 -- Now check the number of parameters of the subprogram and give
8314 -- an error if it is lower than n.
8316 elsif Present (Subp) then
8318 Minimum : constant Nat :=
8319 Convention_Id'Pos (C) -
8320 Convention_Id'Pos (Convention_C_Variadic_0);
8327 Formal := First_Formal (Subp);
8328 while Present (Formal) loop
8330 Next_Formal (Formal);
8333 if Count < Minimum then
8334 Error_Msg_Uint_1 := UI_From_Int (Minimum);
8336 ("argument of pragma% must have at least"
8337 & "^ parameters", Arg2);
8342 -- Special checks for Stdcall
8344 elsif C = Convention_Stdcall then
8346 -- Several allowed cases
8348 if Is_Subprogram_Or_Generic_Subprogram (E)
8352 or else Ekind (E) = E_Variable
8354 -- A component as well. The entity does not have its Ekind
8355 -- set until the enclosing record declaration is fully
8358 or else Nkind (Parent (E)) = N_Component_Declaration
8360 -- An access to subprogram is also allowed
8364 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
8366 -- Allow internal call to set convention of subprogram type
8368 or else Ekind (E) = E_Subprogram_Type
8374 ("argument of pragma% must be subprogram or access type",
8379 Set_Convention_From_Pragma (E);
8381 -- Deal with non-subprogram cases
8383 if not Is_Subprogram_Or_Generic_Subprogram (E) then
8386 -- The pragma must apply to a first subtype, but it can also
8387 -- apply to a generic type in a generic formal part, in which
8388 -- case it will also appear in the corresponding instance.
8390 if Is_Generic_Type (E) or else In_Instance then
8393 Check_First_Subtype (Arg2);
8396 Set_Convention_From_Pragma (Base_Type (E));
8398 -- For access subprograms, we must set the convention on the
8399 -- internally generated directly designated type as well.
8401 if Ekind (E) = E_Access_Subprogram_Type then
8402 Set_Convention_From_Pragma (Directly_Designated_Type (E));
8406 -- For the subprogram case, set proper convention for all homonyms
8407 -- in same scope and the same declarative part, i.e. the same
8408 -- compilation unit.
8411 -- Treat a pragma Import as an implicit body, and pragma import
8412 -- as implicit reference (for navigation in GNAT Studio).
8414 if Prag_Id = Pragma_Import then
8415 Generate_Reference (E, Id, 'b');
8417 -- For exported entities we restrict the generation of references
8418 -- to entities exported to foreign languages since entities
8419 -- exported to Ada do not provide further information to
8420 -- GNAT Studio and add undesired references to the output of the
8423 elsif Prag_Id = Pragma_Export
8424 and then Convention (E) /= Convention_Ada
8426 Generate_Reference (E, Id, 'i');
8429 -- If the pragma comes from an aspect, it only applies to the
8430 -- given entity, not its homonyms.
8432 if From_Aspect_Specification (N) then
8433 if C = Convention_Intrinsic
8434 and then Nkind (Ent) = N_Defining_Operator_Symbol
8436 if Is_Fixed_Point_Type (Etype (Ent))
8437 or else Is_Fixed_Point_Type (Etype (First_Entity (Ent)))
8438 or else Is_Fixed_Point_Type (Etype (Last_Entity (Ent)))
8441 ("no intrinsic operator available for this fixed-point "
8444 ("\use expression functions with the desired "
8445 & "conversions made explicit", N);
8452 -- Otherwise Loop through the homonyms of the pragma argument's
8453 -- entity, an apply convention to those in the current scope.
8455 Comp_Unit := Get_Source_Unit (E);
8460 exit when No (E1) or else Scope (E1) /= Current_Scope;
8462 -- Ignore entry for which convention is already set
8464 if Has_Convention_Pragma (E1) then
8468 if Is_Subprogram (E1)
8469 and then Nkind (Parent (Declaration_Node (E1))) =
8471 and then not Relaxed_RM_Semantics
8473 Set_Has_Completion (E); -- to prevent cascaded error
8475 ("pragma% requires separate spec and must come before "
8479 -- Do not set the pragma on inherited operations or on formal
8482 if Comes_From_Source (E1)
8483 and then Comp_Unit = Get_Source_Unit (E1)
8484 and then not Is_Formal_Subprogram (E1)
8485 and then Nkind (Original_Node (Parent (E1))) /=
8486 N_Full_Type_Declaration
8488 if Present (Alias (E1))
8489 and then Scope (E1) /= Scope (Alias (E1))
8492 ("cannot apply pragma% to non-local entity& declared#",
8496 Set_Convention_From_Pragma (E1);
8498 if Prag_Id = Pragma_Import then
8499 Generate_Reference (E1, Id, 'b');
8507 end Process_Convention;
8509 ----------------------------------------
8510 -- Process_Disable_Enable_Atomic_Sync --
8511 ----------------------------------------
8513 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
8515 Check_No_Identifiers;
8516 Check_At_Most_N_Arguments (1);
8518 -- Modeled internally as
8519 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
8524 Pragma_Argument_Associations => New_List (
8525 Make_Pragma_Argument_Association (Loc,
8527 Make_Identifier (Loc, Name_Atomic_Synchronization)))));
8529 if Present (Arg1) then
8530 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
8534 end Process_Disable_Enable_Atomic_Sync;
8536 -------------------------------------------------
8537 -- Process_Extended_Import_Export_Internal_Arg --
8538 -------------------------------------------------
8540 procedure Process_Extended_Import_Export_Internal_Arg
8541 (Arg_Internal : Node_Id := Empty)
8544 if No (Arg_Internal) then
8545 Error_Pragma ("Internal parameter required for pragma%");
8548 if Nkind (Arg_Internal) = N_Identifier then
8551 elsif Nkind (Arg_Internal) = N_Operator_Symbol
8552 and then (Prag_Id = Pragma_Import_Function
8554 Prag_Id = Pragma_Export_Function)
8560 ("wrong form for Internal parameter for pragma%", Arg_Internal);
8563 Check_Arg_Is_Local_Name (Arg_Internal);
8564 end Process_Extended_Import_Export_Internal_Arg;
8566 --------------------------------------------------
8567 -- Process_Extended_Import_Export_Object_Pragma --
8568 --------------------------------------------------
8570 procedure Process_Extended_Import_Export_Object_Pragma
8571 (Arg_Internal : Node_Id;
8572 Arg_External : Node_Id;
8578 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
8579 Def_Id := Entity (Arg_Internal);
8581 if Ekind (Def_Id) not in E_Constant | E_Variable then
8583 ("pragma% must designate an object", Arg_Internal);
8586 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
8588 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
8591 ("previous Common/Psect_Object applies, pragma % not permitted",
8595 if Rep_Item_Too_Late (Def_Id, N) then
8599 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
8601 if Present (Arg_Size) then
8602 Check_Arg_Is_External_Name (Arg_Size);
8605 -- Export_Object case
8607 if Prag_Id = Pragma_Export_Object then
8608 if not Is_Library_Level_Entity (Def_Id) then
8610 ("argument for pragma% must be library level entity",
8614 if Ekind (Current_Scope) = E_Generic_Package then
8615 Error_Pragma ("pragma& cannot appear in a generic unit");
8618 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
8620 ("exported object must have compile time known size",
8624 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
8625 Error_Msg_N ("??duplicate Export_Object pragma", N);
8627 Set_Exported (Def_Id, Arg_Internal);
8630 -- Import_Object case
8633 if Is_Concurrent_Type (Etype (Def_Id)) then
8635 ("cannot use pragma% for task/protected object",
8639 if Ekind (Def_Id) = E_Constant then
8641 ("cannot import a constant", Arg_Internal);
8644 if Warn_On_Export_Import
8645 and then Has_Discriminants (Etype (Def_Id))
8648 ("imported value must be initialized??", Arg_Internal);
8651 if Warn_On_Export_Import
8652 and then Is_Access_Type (Etype (Def_Id))
8655 ("cannot import object of an access type??", Arg_Internal);
8658 if Warn_On_Export_Import
8659 and then Is_Imported (Def_Id)
8661 Error_Msg_N ("??duplicate Import_Object pragma", N);
8663 -- Check for explicit initialization present. Note that an
8664 -- initialization generated by the code generator, e.g. for an
8665 -- access type, does not count here.
8667 elsif Present (Expression (Parent (Def_Id)))
8670 (Original_Node (Expression (Parent (Def_Id))))
8672 Error_Msg_Sloc := Sloc (Def_Id);
8674 ("imported entities cannot be initialized (RM B.1(24))",
8675 "\no initialization allowed for & declared#", Arg1);
8677 Set_Imported (Def_Id);
8678 Note_Possible_Modification (Arg_Internal, Sure => False);
8681 end Process_Extended_Import_Export_Object_Pragma;
8683 ------------------------------------------------------
8684 -- Process_Extended_Import_Export_Subprogram_Pragma --
8685 ------------------------------------------------------
8687 procedure Process_Extended_Import_Export_Subprogram_Pragma
8688 (Arg_Internal : Node_Id;
8689 Arg_External : Node_Id;
8690 Arg_Parameter_Types : Node_Id;
8691 Arg_Result_Type : Node_Id := Empty;
8692 Arg_Mechanism : Node_Id;
8693 Arg_Result_Mechanism : Node_Id := Empty)
8699 Ambiguous : Boolean;
8702 function Same_Base_Type
8704 Formal : Entity_Id) return Boolean;
8705 -- Determines if Ptype references the type of Formal. Note that only
8706 -- the base types need to match according to the spec. Ptype here is
8707 -- the argument from the pragma, which is either a type name, or an
8708 -- access attribute.
8710 --------------------
8711 -- Same_Base_Type --
8712 --------------------
8714 function Same_Base_Type
8716 Formal : Entity_Id) return Boolean
8718 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
8722 -- Case where pragma argument is typ'Access
8724 if Nkind (Ptype) = N_Attribute_Reference
8725 and then Attribute_Name (Ptype) = Name_Access
8727 Pref := Prefix (Ptype);
8730 if not Is_Entity_Name (Pref)
8731 or else Entity (Pref) = Any_Type
8736 -- We have a match if the corresponding argument is of an
8737 -- anonymous access type, and its designated type matches the
8738 -- type of the prefix of the access attribute
8740 return Ekind (Ftyp) = E_Anonymous_Access_Type
8741 and then Base_Type (Entity (Pref)) =
8742 Base_Type (Etype (Designated_Type (Ftyp)));
8744 -- Case where pragma argument is a type name
8749 if not Is_Entity_Name (Ptype)
8750 or else Entity (Ptype) = Any_Type
8755 -- We have a match if the corresponding argument is of the type
8756 -- given in the pragma (comparing base types)
8758 return Base_Type (Entity (Ptype)) = Ftyp;
8762 -- Start of processing for
8763 -- Process_Extended_Import_Export_Subprogram_Pragma
8766 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
8770 -- Loop through homonyms (overloadings) of the entity
8772 Hom_Id := Entity (Arg_Internal);
8773 while Present (Hom_Id) loop
8774 Def_Id := Get_Base_Subprogram (Hom_Id);
8776 -- We need a subprogram in the current scope
8778 if not Is_Subprogram (Def_Id)
8779 or else Scope (Def_Id) /= Current_Scope
8786 -- Pragma cannot apply to subprogram body
8788 if Is_Subprogram (Def_Id)
8789 and then Nkind (Parent (Declaration_Node (Def_Id))) =
8793 ("pragma% requires separate spec and must come before "
8797 -- Test result type if given, note that the result type
8798 -- parameter can only be present for the function cases.
8800 if Present (Arg_Result_Type)
8801 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
8805 elsif Etype (Def_Id) /= Standard_Void_Type
8807 Pname in Name_Export_Procedure | Name_Import_Procedure
8811 -- Test parameter types if given. Note that this parameter has
8812 -- not been analyzed (and must not be, since it is semantic
8813 -- nonsense), so we get it as the parser left it.
8815 elsif Present (Arg_Parameter_Types) then
8816 Check_Matching_Types : declare
8821 Formal := First_Formal (Def_Id);
8823 if Nkind (Arg_Parameter_Types) = N_Null then
8824 if Present (Formal) then
8828 -- A list of one type, e.g. (List) is parsed as a
8829 -- parenthesized expression.
8831 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
8832 and then Paren_Count (Arg_Parameter_Types) = 1
8835 or else Present (Next_Formal (Formal))
8840 Same_Base_Type (Arg_Parameter_Types, Formal);
8843 -- A list of more than one type is parsed as a aggregate
8845 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
8846 and then Paren_Count (Arg_Parameter_Types) = 0
8848 Ptype := First (Expressions (Arg_Parameter_Types));
8849 while Present (Ptype) or else Present (Formal) loop
8852 or else not Same_Base_Type (Ptype, Formal)
8857 Next_Formal (Formal);
8862 -- Anything else is of the wrong form
8866 ("wrong form for Parameter_Types parameter",
8867 Arg_Parameter_Types);
8869 end Check_Matching_Types;
8872 -- Match is now False if the entry we found did not match
8873 -- either a supplied Parameter_Types or Result_Types argument
8879 -- Ambiguous case, the flag Ambiguous shows if we already
8880 -- detected this and output the initial messages.
8883 if not Ambiguous then
8885 Error_Msg_Name_1 := Pname;
8887 ("pragma% does not uniquely identify subprogram!",
8889 Error_Msg_Sloc := Sloc (Ent);
8890 Error_Msg_N ("matching subprogram #!", N);
8894 Error_Msg_Sloc := Sloc (Def_Id);
8895 Error_Msg_N ("matching subprogram #!", N);
8900 Hom_Id := Homonym (Hom_Id);
8903 -- See if we found an entry
8906 if not Ambiguous then
8907 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
8909 ("pragma% cannot be given for generic subprogram");
8912 ("pragma% does not identify local subprogram");
8919 -- Import pragmas must be for imported entities
8921 if Prag_Id = Pragma_Import_Function
8923 Prag_Id = Pragma_Import_Procedure
8925 Prag_Id = Pragma_Import_Valued_Procedure
8927 if not Is_Imported (Ent) then
8929 ("pragma Import or Interface must precede pragma%");
8932 -- Here we have the Export case which can set the entity as exported
8934 -- But does not do so if the specified external name is null, since
8935 -- that is taken as a signal in DEC Ada 83 (with which we want to be
8936 -- compatible) to request no external name.
8938 elsif Nkind (Arg_External) = N_String_Literal
8939 and then String_Length (Strval (Arg_External)) = 0
8943 -- In all other cases, set entity as exported
8946 Set_Exported (Ent, Arg_Internal);
8949 -- Special processing for Valued_Procedure cases
8951 if Prag_Id = Pragma_Import_Valued_Procedure
8953 Prag_Id = Pragma_Export_Valued_Procedure
8955 Formal := First_Formal (Ent);
8958 Error_Pragma ("at least one parameter required for pragma%");
8960 elsif Ekind (Formal) /= E_Out_Parameter then
8961 Error_Pragma ("first parameter must have mode out for pragma%");
8964 Set_Is_Valued_Procedure (Ent);
8968 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
8970 -- Process Result_Mechanism argument if present. We have already
8971 -- checked that this is only allowed for the function case.
8973 if Present (Arg_Result_Mechanism) then
8974 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
8977 -- Process Mechanism parameter if present. Note that this parameter
8978 -- is not analyzed, and must not be analyzed since it is semantic
8979 -- nonsense, so we get it in exactly as the parser left it.
8981 if Present (Arg_Mechanism) then
8989 -- A single mechanism association without a formal parameter
8990 -- name is parsed as a parenthesized expression. All other
8991 -- cases are parsed as aggregates, so we rewrite the single
8992 -- parameter case as an aggregate for consistency.
8994 if Nkind (Arg_Mechanism) /= N_Aggregate
8995 and then Paren_Count (Arg_Mechanism) = 1
8997 Rewrite (Arg_Mechanism,
8998 Make_Aggregate (Sloc (Arg_Mechanism),
8999 Expressions => New_List (
9000 Relocate_Node (Arg_Mechanism))));
9003 -- Case of only mechanism name given, applies to all formals
9005 if Nkind (Arg_Mechanism) /= N_Aggregate then
9006 Formal := First_Formal (Ent);
9007 while Present (Formal) loop
9008 Set_Mechanism_Value (Formal, Arg_Mechanism);
9009 Next_Formal (Formal);
9012 -- Case of list of mechanism associations given
9015 if Null_Record_Present (Arg_Mechanism) then
9017 ("inappropriate form for Mechanism parameter",
9021 -- Deal with positional ones first
9023 Formal := First_Formal (Ent);
9025 if Present (Expressions (Arg_Mechanism)) then
9026 Mname := First (Expressions (Arg_Mechanism));
9027 while Present (Mname) loop
9030 ("too many mechanism associations", Mname);
9033 Set_Mechanism_Value (Formal, Mname);
9034 Next_Formal (Formal);
9039 -- Deal with named entries
9041 if Present (Component_Associations (Arg_Mechanism)) then
9042 Massoc := First (Component_Associations (Arg_Mechanism));
9043 while Present (Massoc) loop
9044 Choice := First (Choices (Massoc));
9046 if Nkind (Choice) /= N_Identifier
9047 or else Present (Next (Choice))
9050 ("incorrect form for mechanism association",
9054 Formal := First_Formal (Ent);
9058 ("parameter name & not present", Choice);
9061 if Chars (Choice) = Chars (Formal) then
9063 (Formal, Expression (Massoc));
9065 -- Set entity on identifier for proper tree
9068 Set_Entity (Choice, Formal);
9073 Next_Formal (Formal);
9082 end Process_Extended_Import_Export_Subprogram_Pragma;
9084 --------------------------
9085 -- Process_Generic_List --
9086 --------------------------
9088 procedure Process_Generic_List is
9093 Check_No_Identifiers;
9094 Check_At_Least_N_Arguments (1);
9096 -- Check all arguments are names of generic units or instances
9099 while Present (Arg) loop
9100 Exp := Get_Pragma_Arg (Arg);
9103 if not Is_Entity_Name (Exp)
9105 (not Is_Generic_Instance (Entity (Exp))
9107 not Is_Generic_Unit (Entity (Exp)))
9110 ("pragma% argument must be name of generic unit/instance",
9116 end Process_Generic_List;
9118 ------------------------------------
9119 -- Process_Import_Predefined_Type --
9120 ------------------------------------
9122 procedure Process_Import_Predefined_Type is
9123 Loc : constant Source_Ptr := Sloc (N);
9125 Ftyp : Node_Id := Empty;
9131 Nam := String_To_Name (Strval (Expression (Arg3)));
9133 Elmt := First_Elmt (Predefined_Float_Types);
9134 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
9138 Ftyp := Node (Elmt);
9140 if Present (Ftyp) then
9142 -- Don't build a derived type declaration, because predefined C
9143 -- types have no declaration anywhere, so cannot really be named.
9144 -- Instead build a full type declaration, starting with an
9145 -- appropriate type definition is built
9147 if Is_Floating_Point_Type (Ftyp) then
9148 Def := Make_Floating_Point_Definition (Loc,
9149 Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
9150 Make_Real_Range_Specification (Loc,
9151 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
9152 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
9154 -- Should never have a predefined type we cannot handle
9157 raise Program_Error;
9160 -- Build and insert a Full_Type_Declaration, which will be
9161 -- analyzed as soon as this list entry has been analyzed.
9163 Decl := Make_Full_Type_Declaration (Loc,
9164 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
9165 Type_Definition => Def);
9167 Insert_After (N, Decl);
9168 Mark_Rewrite_Insertion (Decl);
9171 Error_Pragma_Arg ("no matching type found for pragma%", Arg2);
9173 end Process_Import_Predefined_Type;
9175 ---------------------------------
9176 -- Process_Import_Or_Interface --
9177 ---------------------------------
9179 procedure Process_Import_Or_Interface is
9185 -- In Relaxed_RM_Semantics, support old Ada 83 style:
9186 -- pragma Import (Entity, "external name");
9188 if Relaxed_RM_Semantics
9189 and then Arg_Count = 2
9190 and then Prag_Id = Pragma_Import
9191 and then Nkind (Expression (Arg2)) = N_String_Literal
9194 Def_Id := Get_Pragma_Arg (Arg1);
9197 if not Is_Entity_Name (Def_Id) then
9198 Error_Pragma_Arg ("entity name required", Arg1);
9201 Def_Id := Entity (Def_Id);
9202 Kill_Size_Check_Code (Def_Id);
9203 Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False);
9206 Process_Convention (C, Def_Id);
9208 -- A pragma that applies to a Ghost entity becomes Ghost for the
9209 -- purposes of legality checks and removal of ignored Ghost code.
9211 Mark_Ghost_Pragma (N, Def_Id);
9212 Kill_Size_Check_Code (Def_Id);
9213 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
9216 -- Various error checks
9218 if Ekind (Def_Id) in E_Variable | E_Constant then
9220 -- We do not permit Import to apply to a renaming declaration
9222 if Present (Renamed_Object (Def_Id)) then
9224 ("pragma% not allowed for object renaming", Arg2);
9226 -- User initialization is not allowed for imported object, but
9227 -- the object declaration may contain a default initialization,
9228 -- that will be discarded. Note that an explicit initialization
9229 -- only counts if it comes from source, otherwise it is simply
9230 -- the code generator making an implicit initialization explicit.
9232 elsif Present (Expression (Parent (Def_Id)))
9233 and then Comes_From_Source
9234 (Original_Node (Expression (Parent (Def_Id))))
9236 -- Set imported flag to prevent cascaded errors
9238 Set_Is_Imported (Def_Id);
9240 Error_Msg_Sloc := Sloc (Def_Id);
9242 ("no initialization allowed for declaration of& #",
9243 "\imported entities cannot be initialized (RM B.1(24))",
9247 -- If the pragma comes from an aspect specification the
9248 -- Is_Imported flag has already been set.
9250 if not From_Aspect_Specification (N) then
9251 Set_Imported (Def_Id);
9254 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
9256 -- Note that we do not set Is_Public here. That's because we
9257 -- only want to set it if there is no address clause, and we
9258 -- don't know that yet, so we delay that processing till
9261 -- pragma Import completes deferred constants
9263 if Ekind (Def_Id) = E_Constant then
9264 Set_Has_Completion (Def_Id);
9267 -- It is not possible to import a constant of an unconstrained
9268 -- array type (e.g. string) because there is no simple way to
9269 -- write a meaningful subtype for it.
9271 if Is_Array_Type (Etype (Def_Id))
9272 and then not Is_Constrained (Etype (Def_Id))
9275 ("imported constant& must have a constrained subtype",
9280 elsif Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
9282 -- If the name is overloaded, pragma applies to all of the denoted
9283 -- entities in the same declarative part, unless the pragma comes
9284 -- from an aspect specification or was generated by the compiler
9285 -- (such as for pragma Provide_Shift_Operators).
9288 while Present (Hom_Id) loop
9290 Def_Id := Get_Base_Subprogram (Hom_Id);
9292 -- Ignore inherited subprograms because the pragma will apply
9293 -- to the parent operation, which is the one called.
9295 if Is_Overloadable (Def_Id)
9296 and then Present (Alias (Def_Id))
9300 -- If it is not a subprogram, it must be in an outer scope and
9301 -- pragma does not apply.
9303 elsif not Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
9306 -- The pragma does not apply to primitives of interfaces
9308 elsif Is_Dispatching_Operation (Def_Id)
9309 and then Present (Find_Dispatching_Type (Def_Id))
9310 and then Is_Interface (Find_Dispatching_Type (Def_Id))
9314 -- Verify that the homonym is in the same declarative part (not
9315 -- just the same scope). If the pragma comes from an aspect
9316 -- specification we know that it is part of the declaration.
9318 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
9319 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
9320 and then not From_Aspect_Specification (N)
9325 -- If the pragma comes from an aspect specification the
9326 -- Is_Imported flag has already been set.
9328 if not From_Aspect_Specification (N) then
9329 Set_Imported (Def_Id);
9332 -- Reject an Import applied to an abstract subprogram
9334 if Is_Subprogram (Def_Id)
9335 and then Is_Abstract_Subprogram (Def_Id)
9337 Error_Msg_Sloc := Sloc (Def_Id);
9339 ("cannot import abstract subprogram& declared#",
9343 -- Special processing for Convention_Intrinsic
9345 if C = Convention_Intrinsic then
9347 -- Link_Name argument not allowed for intrinsic
9351 Set_Is_Intrinsic_Subprogram (Def_Id);
9353 -- If no external name is present, then check that this
9354 -- is a valid intrinsic subprogram. If an external name
9355 -- is present, then this is handled by the back end.
9358 Check_Intrinsic_Subprogram
9359 (Def_Id, Get_Pragma_Arg (Arg2));
9363 -- Verify that the subprogram does not have a completion
9364 -- through a renaming declaration. For other completions the
9365 -- pragma appears as a too late representation.
9368 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
9372 and then Nkind (Decl) = N_Subprogram_Declaration
9373 and then Present (Corresponding_Body (Decl))
9374 and then Nkind (Unit_Declaration_Node
9375 (Corresponding_Body (Decl))) =
9376 N_Subprogram_Renaming_Declaration
9378 Error_Msg_Sloc := Sloc (Def_Id);
9380 ("cannot import&, renaming already provided for "
9381 & "declaration #", N, Def_Id);
9385 -- If the pragma comes from an aspect specification, there
9386 -- must be an Import aspect specified as well. In the rare
9387 -- case where Import is set to False, the suprogram needs to
9388 -- have a local completion.
9391 Imp_Aspect : constant Node_Id :=
9392 Find_Aspect (Def_Id, Aspect_Import);
9396 if Present (Imp_Aspect)
9397 and then Present (Expression (Imp_Aspect))
9399 Expr := Expression (Imp_Aspect);
9400 Analyze_And_Resolve (Expr, Standard_Boolean);
9402 if Is_Entity_Name (Expr)
9403 and then Entity (Expr) = Standard_True
9405 Set_Has_Completion (Def_Id);
9408 -- If there is no expression, the default is True, as for
9409 -- all boolean aspects. Same for the older pragma.
9412 Set_Has_Completion (Def_Id);
9416 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
9419 if Is_Compilation_Unit (Hom_Id) then
9421 -- Its possible homonyms are not affected by the pragma.
9422 -- Such homonyms might be present in the context of other
9423 -- units being compiled.
9427 elsif From_Aspect_Specification (N) then
9430 -- If the pragma was created by the compiler, then we don't
9431 -- want it to apply to other homonyms. This kind of case can
9432 -- occur when using pragma Provide_Shift_Operators, which
9433 -- generates implicit shift and rotate operators with Import
9434 -- pragmas that might apply to earlier explicit or implicit
9435 -- declarations marked with Import (for example, coming from
9436 -- an earlier pragma Provide_Shift_Operators for another type),
9437 -- and we don't generally want other homonyms being treated
9438 -- as imported or the pragma flagged as an illegal duplicate.
9440 elsif not Comes_From_Source (N) then
9444 Hom_Id := Homonym (Hom_Id);
9448 -- Import a CPP class
9450 elsif C = Convention_CPP
9451 and then (Is_Record_Type (Def_Id)
9452 or else Ekind (Def_Id) = E_Incomplete_Type)
9454 if Ekind (Def_Id) = E_Incomplete_Type then
9455 if Present (Full_View (Def_Id)) then
9456 Def_Id := Full_View (Def_Id);
9460 ("cannot import 'C'P'P type before full declaration seen",
9461 Get_Pragma_Arg (Arg2));
9463 -- Although we have reported the error we decorate it as
9464 -- CPP_Class to avoid reporting spurious errors
9466 Set_Is_CPP_Class (Def_Id);
9471 -- Types treated as CPP classes must be declared limited (note:
9472 -- this used to be a warning but there is no real benefit to it
9473 -- since we did effectively intend to treat the type as limited
9476 if not Is_Limited_Type (Def_Id) then
9478 ("imported 'C'P'P type must be limited",
9479 Get_Pragma_Arg (Arg2));
9482 if Etype (Def_Id) /= Def_Id
9483 and then not Is_CPP_Class (Root_Type (Def_Id))
9485 Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
9488 Set_Is_CPP_Class (Def_Id);
9490 -- Imported CPP types must not have discriminants (because C++
9491 -- classes do not have discriminants).
9493 if Has_Discriminants (Def_Id) then
9495 ("imported 'C'P'P type cannot have discriminants",
9496 First (Discriminant_Specifications
9497 (Declaration_Node (Def_Id))));
9500 -- Check that components of imported CPP types do not have default
9501 -- expressions. For private types this check is performed when the
9502 -- full view is analyzed (see Process_Full_View).
9504 if not Is_Private_Type (Def_Id) then
9505 Check_CPP_Type_Has_No_Defaults (Def_Id);
9508 -- Import a CPP exception
9510 elsif C = Convention_CPP
9511 and then Ekind (Def_Id) = E_Exception
9515 ("'External_'Name arguments is required for 'Cpp exception",
9518 -- As only a string is allowed, Check_Arg_Is_External_Name
9521 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
9524 if Present (Arg4) then
9526 ("Link_Name argument not allowed for imported Cpp exception",
9530 -- Do not call Set_Interface_Name as the name of the exception
9531 -- shouldn't be modified (and in particular it shouldn't be
9532 -- the External_Name). For exceptions, the External_Name is the
9533 -- name of the RTTI structure.
9535 -- ??? Emit an error if pragma Import/Export_Exception is present
9537 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
9539 Check_Arg_Count (3);
9540 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
9542 Process_Import_Predefined_Type;
9546 ("second argument of pragma% must be object, subprogram "
9547 & "or incomplete type",
9551 -- If this pragma applies to a compilation unit, then the unit, which
9552 -- is a subprogram, does not require (or allow) a body. We also do
9553 -- not need to elaborate imported procedures.
9555 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
9557 Cunit : constant Node_Id := Parent (Parent (N));
9559 Set_Body_Required (Cunit, False);
9562 end Process_Import_Or_Interface;
9564 --------------------
9565 -- Process_Inline --
9566 --------------------
9568 procedure Process_Inline (Status : Inline_Status) is
9575 Ghost_Error_Posted : Boolean := False;
9576 -- Flag set when an error concerning the illegal mix of Ghost and
9577 -- non-Ghost subprograms is emitted.
9579 Ghost_Id : Entity_Id := Empty;
9580 -- The entity of the first Ghost subprogram encountered while
9581 -- processing the arguments of the pragma.
9583 procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id);
9584 -- Verify the placement of pragma Inline_Always with respect to the
9585 -- initial declaration of subprogram Spec_Id.
9587 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
9588 -- Returns True if it can be determined at this stage that inlining
9589 -- is not possible, for example if the body is available and contains
9590 -- exception handlers, we prevent inlining, since otherwise we can
9591 -- get undefined symbols at link time. This function also emits a
9592 -- warning if the pragma appears too late.
9594 -- ??? is business with link symbols still valid, or does it relate
9595 -- to front end ZCX which is being phased out ???
9597 procedure Make_Inline (Subp : Entity_Id);
9598 -- Subp is the defining unit name of the subprogram declaration. If
9599 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
9600 -- the corresponding body, if there is one present.
9602 procedure Set_Inline_Flags (Subp : Entity_Id);
9603 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
9604 -- Also set or clear Is_Inlined flag on Subp depending on Status.
9606 -----------------------------------
9607 -- Check_Inline_Always_Placement --
9608 -----------------------------------
9610 procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id) is
9611 Spec_Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
9613 function Compilation_Unit_OK return Boolean;
9614 pragma Inline (Compilation_Unit_OK);
9615 -- Determine whether pragma Inline_Always applies to a compatible
9616 -- compilation unit denoted by Spec_Id.
9618 function Declarative_List_OK return Boolean;
9619 pragma Inline (Declarative_List_OK);
9620 -- Determine whether the initial declaration of subprogram Spec_Id
9621 -- and the pragma appear in compatible declarative lists.
9623 function Subprogram_Body_OK return Boolean;
9624 pragma Inline (Subprogram_Body_OK);
9625 -- Determine whether pragma Inline_Always applies to a compatible
9626 -- subprogram body denoted by Spec_Id.
9628 -------------------------
9629 -- Compilation_Unit_OK --
9630 -------------------------
9632 function Compilation_Unit_OK return Boolean is
9633 Comp_Unit : constant Node_Id := Parent (Spec_Decl);
9636 -- The pragma appears after the initial declaration of a
9637 -- compilation unit.
9639 -- procedure Comp_Unit;
9640 -- pragma Inline_Always (Comp_Unit);
9642 -- Note that for compatibility reasons, the following case is
9645 -- procedure Stand_Alone_Body_Comp_Unit is
9647 -- end Stand_Alone_Body_Comp_Unit;
9648 -- pragma Inline_Always (Stand_Alone_Body_Comp_Unit);
9651 Nkind (Comp_Unit) = N_Compilation_Unit
9652 and then Present (Aux_Decls_Node (Comp_Unit))
9653 and then Is_List_Member (N)
9654 and then List_Containing (N) =
9655 Pragmas_After (Aux_Decls_Node (Comp_Unit));
9656 end Compilation_Unit_OK;
9658 -------------------------
9659 -- Declarative_List_OK --
9660 -------------------------
9662 function Declarative_List_OK return Boolean is
9663 Context : constant Node_Id := Parent (Spec_Decl);
9665 Init_Decl : Node_Id;
9666 Init_List : List_Id;
9667 Prag_List : List_Id;
9670 -- Determine the proper initial declaration. In general this is
9671 -- the declaration node of the subprogram except when the input
9672 -- denotes a generic instantiation.
9674 -- procedure Inst is new Gen;
9675 -- pragma Inline_Always (Inst);
9677 -- In this case the original subprogram is moved inside an
9678 -- anonymous package while pragma Inline_Always remains at the
9679 -- level of the anonymous package. Use the declaration of the
9680 -- package because it reflects the placement of the original
9683 -- package Anon_Pack is
9684 -- procedure Inst is ... end Inst; -- original
9687 -- procedure Inst renames Anon_Pack.Inst;
9688 -- pragma Inline_Always (Inst);
9690 if Is_Generic_Instance (Spec_Id) then
9691 Init_Decl := Parent (Parent (Spec_Decl));
9692 pragma Assert (Nkind (Init_Decl) = N_Package_Declaration);
9694 Init_Decl := Spec_Decl;
9697 if Is_List_Member (Init_Decl) and then Is_List_Member (N) then
9698 Init_List := List_Containing (Init_Decl);
9699 Prag_List := List_Containing (N);
9701 -- The pragma and then initial declaration appear within the
9702 -- same declarative list.
9704 if Init_List = Prag_List then
9707 -- A special case of the above is when both the pragma and
9708 -- the initial declaration appear in different lists of a
9709 -- package spec, protected definition, or a task definition.
9714 -- pragma Inline_Always (Proc);
9717 elsif Nkind (Context) in N_Package_Specification
9718 | N_Protected_Definition
9720 and then Init_List = Visible_Declarations (Context)
9721 and then Prag_List = Private_Declarations (Context)
9728 end Declarative_List_OK;
9730 ------------------------
9731 -- Subprogram_Body_OK --
9732 ------------------------
9734 function Subprogram_Body_OK return Boolean is
9735 Body_Decl : Node_Id;
9738 -- The pragma appears within the declarative list of a stand-
9739 -- alone subprogram body.
9741 -- procedure Stand_Alone_Body is
9742 -- pragma Inline_Always (Stand_Alone_Body);
9745 -- end Stand_Alone_Body;
9747 -- The compiler creates a dummy spec in this case, however the
9748 -- pragma remains within the declarative list of the body.
9750 if Nkind (Spec_Decl) = N_Subprogram_Declaration
9751 and then not Comes_From_Source (Spec_Decl)
9752 and then Present (Corresponding_Body (Spec_Decl))
9755 Unit_Declaration_Node (Corresponding_Body (Spec_Decl));
9757 if Present (Declarations (Body_Decl))
9758 and then Is_List_Member (N)
9759 and then List_Containing (N) = Declarations (Body_Decl)
9766 end Subprogram_Body_OK;
9768 -- Start of processing for Check_Inline_Always_Placement
9771 -- This check is relevant only for pragma Inline_Always
9773 if Pname /= Name_Inline_Always then
9776 -- Nothing to do when the pragma is internally generated on the
9777 -- assumption that it is properly placed.
9779 elsif not Comes_From_Source (N) then
9782 -- Nothing to do for internally generated subprograms that act
9783 -- as accidental homonyms of a source subprogram being inlined.
9785 elsif not Comes_From_Source (Spec_Id) then
9788 -- Nothing to do for generic formal subprograms that act as
9789 -- homonyms of another source subprogram being inlined.
9791 elsif Is_Formal_Subprogram (Spec_Id) then
9794 elsif Compilation_Unit_OK
9795 or else Declarative_List_OK
9796 or else Subprogram_Body_OK
9801 -- At this point it is known that the pragma applies to or appears
9802 -- within a completing body, a completing stub, or a subunit.
9804 Error_Msg_Name_1 := Pname;
9805 Error_Msg_Name_2 := Chars (Spec_Id);
9806 Error_Msg_Sloc := Sloc (Spec_Id);
9809 ("pragma % must appear on initial declaration of subprogram "
9810 & "% defined #", N);
9811 end Check_Inline_Always_Placement;
9813 ---------------------------
9814 -- Inlining_Not_Possible --
9815 ---------------------------
9817 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
9818 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
9822 if Nkind (Decl) = N_Subprogram_Body then
9823 Stats := Handled_Statement_Sequence (Decl);
9824 return Present (Exception_Handlers (Stats))
9825 or else Present (At_End_Proc (Stats));
9827 elsif Nkind (Decl) = N_Subprogram_Declaration
9828 and then Present (Corresponding_Body (Decl))
9830 if Analyzed (Corresponding_Body (Decl)) then
9831 Error_Msg_N ("pragma appears too late, ignored??", N);
9834 -- If the subprogram is a renaming as body, the body is just a
9835 -- call to the renamed subprogram, and inlining is trivially
9839 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
9840 N_Subprogram_Renaming_Declaration
9846 Handled_Statement_Sequence
9847 (Unit_Declaration_Node (Corresponding_Body (Decl)));
9850 Present (Exception_Handlers (Stats))
9851 or else Present (At_End_Proc (Stats));
9855 -- If body is not available, assume the best, the check is
9856 -- performed again when compiling enclosing package bodies.
9860 end Inlining_Not_Possible;
9866 procedure Make_Inline (Subp : Entity_Id) is
9867 Kind : constant Entity_Kind := Ekind (Subp);
9868 Inner_Subp : Entity_Id := Subp;
9871 -- Ignore if bad type, avoid cascaded error
9873 if Etype (Subp) = Any_Type then
9877 -- If inlining is not possible, for now do not treat as an error
9879 elsif Status /= Suppressed
9880 and then Front_End_Inlining
9881 and then Inlining_Not_Possible (Subp)
9886 -- Here we have a candidate for inlining, but we must exclude
9887 -- derived operations. Otherwise we would end up trying to inline
9888 -- a phantom declaration, and the result would be to drag in a
9889 -- body which has no direct inlining associated with it. That
9890 -- would not only be inefficient but would also result in the
9891 -- backend doing cross-unit inlining in cases where it was
9892 -- definitely inappropriate to do so.
9894 -- However, a simple Comes_From_Source test is insufficient, since
9895 -- we do want to allow inlining of generic instances which also do
9896 -- not come from source. We also need to recognize specs generated
9897 -- by the front-end for bodies that carry the pragma. Finally,
9898 -- predefined operators do not come from source but are not
9899 -- inlineable either.
9901 elsif Is_Generic_Instance (Subp)
9902 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
9906 elsif not Comes_From_Source (Subp)
9907 and then Scope (Subp) /= Standard_Standard
9913 -- The referenced entity must either be the enclosing entity, or
9914 -- an entity declared within the current open scope.
9916 if Present (Scope (Subp))
9917 and then Scope (Subp) /= Current_Scope
9918 and then Subp /= Current_Scope
9921 ("argument of% must be entity in current scope", Assoc);
9925 -- Processing for procedure, operator or function. If subprogram
9926 -- is aliased (as for an instance) indicate that the renamed
9927 -- entity (if declared in the same unit) is inlined.
9928 -- If this is the anonymous subprogram created for a subprogram
9929 -- instance, the inlining applies to it directly. Otherwise we
9930 -- retrieve it as the alias of the visible subprogram instance.
9932 if Is_Subprogram (Subp) then
9934 -- Ensure that pragma Inline_Always is associated with the
9935 -- initial declaration of the subprogram.
9937 Check_Inline_Always_Placement (Subp);
9939 if Is_Wrapper_Package (Scope (Subp)) then
9942 Inner_Subp := Ultimate_Alias (Inner_Subp);
9945 if In_Same_Source_Unit (Subp, Inner_Subp) then
9946 Set_Inline_Flags (Inner_Subp);
9948 Decl := Parent (Parent (Inner_Subp));
9950 if Nkind (Decl) = N_Subprogram_Declaration
9951 and then Present (Corresponding_Body (Decl))
9953 Set_Inline_Flags (Corresponding_Body (Decl));
9955 elsif Is_Generic_Instance (Subp)
9956 and then Comes_From_Source (Subp)
9958 -- Indicate that the body needs to be created for
9959 -- inlining subsequent calls. The instantiation node
9960 -- follows the declaration of the wrapper package
9961 -- created for it. The subprogram that requires the
9962 -- body is the anonymous one in the wrapper package.
9964 if Scope (Subp) /= Standard_Standard
9966 Need_Subprogram_Instance_Body
9967 (Next (Unit_Declaration_Node
9968 (Scope (Alias (Subp)))), Subp)
9973 -- Inline is a program unit pragma (RM 10.1.5) and cannot
9974 -- appear in a formal part to apply to a formal subprogram.
9975 -- Do not apply check within an instance or a formal package
9976 -- the test will have been applied to the original generic.
9978 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
9979 and then List_Containing (Decl) = List_Containing (N)
9980 and then not In_Instance
9983 ("Inline cannot apply to a formal subprogram", N);
9989 -- For a generic subprogram set flag as well, for use at the point
9990 -- of instantiation, to determine whether the body should be
9993 elsif Is_Generic_Subprogram (Subp) then
9994 Set_Inline_Flags (Subp);
9997 -- Literals are by definition inlined
9999 elsif Kind = E_Enumeration_Literal then
10002 -- Anything else is an error
10006 ("expect subprogram name for pragma%", Assoc);
10010 ----------------------
10011 -- Set_Inline_Flags --
10012 ----------------------
10014 procedure Set_Inline_Flags (Subp : Entity_Id) is
10016 -- First set the Has_Pragma_XXX flags and issue the appropriate
10017 -- errors and warnings for suspicious combinations.
10019 if Prag_Id = Pragma_No_Inline then
10020 if Has_Pragma_Inline_Always (Subp) then
10022 ("Inline_Always and No_Inline are mutually exclusive", N);
10023 elsif Has_Pragma_Inline (Subp) then
10025 ("Inline and No_Inline both specified for& ??",
10026 N, Entity (Subp_Id));
10029 Set_Has_Pragma_No_Inline (Subp);
10031 if Prag_Id = Pragma_Inline_Always then
10032 if Has_Pragma_No_Inline (Subp) then
10034 ("Inline_Always and No_Inline are mutually exclusive",
10038 Set_Has_Pragma_Inline_Always (Subp);
10040 if Has_Pragma_No_Inline (Subp) then
10042 ("Inline and No_Inline both specified for& ??",
10043 N, Entity (Subp_Id));
10047 Set_Has_Pragma_Inline (Subp);
10050 -- Then adjust the Is_Inlined flag. It can never be set if the
10051 -- subprogram is subject to pragma No_Inline.
10055 Set_Is_Inlined (Subp, False);
10061 if not Has_Pragma_No_Inline (Subp) then
10062 Set_Is_Inlined (Subp, True);
10066 -- A pragma that applies to a Ghost entity becomes Ghost for the
10067 -- purposes of legality checks and removal of ignored Ghost code.
10069 Mark_Ghost_Pragma (N, Subp);
10071 -- Capture the entity of the first Ghost subprogram being
10072 -- processed for error detection purposes.
10074 if Is_Ghost_Entity (Subp) then
10075 if No (Ghost_Id) then
10079 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
10080 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
10082 elsif Present (Ghost_Id) and then not Ghost_Error_Posted then
10083 Ghost_Error_Posted := True;
10085 Error_Msg_Name_1 := Pname;
10087 ("pragma % cannot mention ghost and non-ghost subprograms",
10090 Error_Msg_Sloc := Sloc (Ghost_Id);
10091 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
10093 Error_Msg_Sloc := Sloc (Subp);
10094 Error_Msg_NE ("\& # declared as non-ghost", N, Subp);
10096 end Set_Inline_Flags;
10098 -- Start of processing for Process_Inline
10101 -- An inlined subprogram may grant access to its private enclosing
10102 -- context depending on the placement of its body. From elaboration
10103 -- point of view, the flow of execution may enter this private
10104 -- context, and then reach an external unit, thus producing a
10105 -- dependency on that external unit. For such a path to be properly
10106 -- discovered and encoded in the ALI file of the main unit, let the
10107 -- ABE mechanism process the body of the main unit, and encode all
10108 -- relevant invocation constructs and the relations between them.
10110 Mark_Save_Invocation_Graph_Of_Body;
10112 Check_No_Identifiers;
10113 Check_At_Least_N_Arguments (1);
10115 if Status = Enabled then
10116 Inline_Processing_Required := True;
10120 while Present (Assoc) loop
10121 Subp_Id := Get_Pragma_Arg (Assoc);
10125 if Is_Entity_Name (Subp_Id) then
10126 Subp := Entity (Subp_Id);
10128 if Subp = Any_Id then
10130 -- If previous error, avoid cascaded errors
10132 Check_Error_Detected;
10136 -- Check for RM 13.1(9.2/4): If a [...] aspect_specification
10137 -- is given that directly specifies an aspect of an entity,
10138 -- then it is illegal to give another [...]
10139 -- aspect_specification that directly specifies the same
10140 -- aspect of the entity.
10141 -- We only check Subp directly as per "directly specifies"
10142 -- above and because the case of pragma Inline is really
10143 -- special given its pre aspect usage.
10145 Check_Duplicate_Pragma (Subp);
10146 Record_Rep_Item (Subp, N);
10148 Make_Inline (Subp);
10150 -- For the pragma case, climb homonym chain. This is
10151 -- what implements allowing the pragma in the renaming
10152 -- case, with the result applying to the ancestors, and
10153 -- also allows Inline to apply to all previous homonyms.
10155 if not From_Aspect_Specification (N) then
10156 while Present (Homonym (Subp))
10157 and then Scope (Homonym (Subp)) = Current_Scope
10159 Subp := Homonym (Subp);
10160 Make_Inline (Subp);
10166 if not Applies then
10167 Error_Pragma_Arg ("inappropriate argument for pragma%", Assoc);
10173 -- If the context is a package declaration, the pragma indicates
10174 -- that inlining will require the presence of the corresponding
10175 -- body. (this may be further refined).
10178 and then Nkind (Unit (Cunit (Current_Sem_Unit))) =
10179 N_Package_Declaration
10181 Set_Body_Needed_For_Inlining (Cunit_Entity (Current_Sem_Unit));
10183 end Process_Inline;
10185 ----------------------------
10186 -- Process_Interface_Name --
10187 ----------------------------
10189 procedure Process_Interface_Name
10190 (Subprogram_Def : Entity_Id;
10192 Link_Arg : Node_Id;
10196 Link_Nam : Node_Id;
10197 String_Val : String_Id;
10199 procedure Check_Form_Of_Interface_Name (SN : Node_Id);
10200 -- SN is a string literal node for an interface name. This routine
10201 -- performs some minimal checks that the name is reasonable. In
10202 -- particular that no spaces or other obviously incorrect characters
10203 -- appear. This is only a warning, since any characters are allowed.
10205 ----------------------------------
10206 -- Check_Form_Of_Interface_Name --
10207 ----------------------------------
10209 procedure Check_Form_Of_Interface_Name (SN : Node_Id) is
10210 S : constant String_Id := Strval (Expr_Value_S (SN));
10211 SL : constant Nat := String_Length (S);
10216 Error_Msg_N ("interface name cannot be null string", SN);
10219 for J in 1 .. SL loop
10220 C := Get_String_Char (S, J);
10222 -- Look for dubious character and issue unconditional warning.
10223 -- Definitely dubious if not in character range.
10225 if not In_Character_Range (C)
10227 -- Commas, spaces and (back)slashes are dubious
10229 or else Get_Character (C) = ','
10230 or else Get_Character (C) = '\'
10231 or else Get_Character (C) = ' '
10232 or else Get_Character (C) = '/'
10235 ("??interface name contains illegal character",
10236 Sloc (SN) + Source_Ptr (J));
10239 end Check_Form_Of_Interface_Name;
10241 -- Start of processing for Process_Interface_Name
10244 -- If we are looking at a pragma that comes from an aspect then it
10245 -- needs to have its corresponding aspect argument expressions
10246 -- analyzed in addition to the generated pragma so that aspects
10247 -- within generic units get properly resolved.
10249 if Present (Prag) and then From_Aspect_Specification (Prag) then
10251 Asp : constant Node_Id := Corresponding_Aspect (Prag);
10259 -- Obtain all interfacing aspects used to construct the pragma
10261 Get_Interfacing_Aspects
10262 (Asp, Dummy_1, EN, Dummy_2, Dummy_3, LN);
10264 -- Analyze the expression of aspect External_Name
10266 if Present (EN) then
10267 Analyze (Expression (EN));
10270 -- Analyze the expressio of aspect Link_Name
10272 if Present (LN) then
10273 Analyze (Expression (LN));
10278 if No (Link_Arg) then
10279 if No (Ext_Arg) then
10282 elsif Chars (Ext_Arg) = Name_Link_Name then
10284 Link_Nam := Expression (Ext_Arg);
10287 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
10288 Ext_Nam := Expression (Ext_Arg);
10293 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
10294 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
10295 Ext_Nam := Expression (Ext_Arg);
10296 Link_Nam := Expression (Link_Arg);
10299 -- Check expressions for external name and link name are static
10301 if Present (Ext_Nam) then
10302 Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String);
10303 Check_Form_Of_Interface_Name (Ext_Nam);
10305 -- Verify that external name is not the name of a local entity,
10306 -- which would hide the imported one and could lead to run-time
10307 -- surprises. The problem can only arise for entities declared in
10308 -- a package body (otherwise the external name is fully qualified
10309 -- and will not conflict).
10317 if Prag_Id = Pragma_Import then
10318 Nam := String_To_Name (Strval (Expr_Value_S (Ext_Nam)));
10319 E := Entity_Id (Get_Name_Table_Int (Nam));
10321 if Nam /= Chars (Subprogram_Def)
10322 and then Present (E)
10323 and then not Is_Overloadable (E)
10324 and then Is_Immediately_Visible (E)
10325 and then not Is_Imported (E)
10326 and then Ekind (Scope (E)) = E_Package
10329 while Present (Par) loop
10330 if Nkind (Par) = N_Package_Body then
10331 Error_Msg_Sloc := Sloc (E);
10333 ("imported entity is hidden by & declared#",
10338 Par := Parent (Par);
10345 if Present (Link_Nam) then
10346 Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String);
10347 Check_Form_Of_Interface_Name (Link_Nam);
10350 -- If there is no link name, just set the external name
10352 if No (Link_Nam) then
10353 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
10355 -- For the Link_Name case, the given literal is preceded by an
10356 -- asterisk, which indicates to GCC that the given name should be
10357 -- taken literally, and in particular that no prepending of
10358 -- underlines should occur, even in systems where this is the
10363 Store_String_Char (Get_Char_Code ('*'));
10364 String_Val := Strval (Expr_Value_S (Link_Nam));
10365 Store_String_Chars (String_Val);
10367 Make_String_Literal (Sloc (Link_Nam),
10368 Strval => End_String);
10371 -- Set the interface name. If the entity is a generic instance, use
10372 -- its alias, which is the callable entity.
10374 if Is_Generic_Instance (Subprogram_Def) then
10375 Set_Encoded_Interface_Name
10376 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
10378 Set_Encoded_Interface_Name
10379 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
10382 Check_Duplicated_Export_Name (Link_Nam);
10383 end Process_Interface_Name;
10385 -----------------------------------------
10386 -- Process_Interrupt_Or_Attach_Handler --
10387 -----------------------------------------
10389 procedure Process_Interrupt_Or_Attach_Handler is
10390 Handler : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1));
10391 Prot_Typ : constant Entity_Id := Scope (Handler);
10394 -- A pragma that applies to a Ghost entity becomes Ghost for the
10395 -- purposes of legality checks and removal of ignored Ghost code.
10397 Mark_Ghost_Pragma (N, Handler);
10398 Set_Is_Interrupt_Handler (Handler);
10400 pragma Assert (Ekind (Prot_Typ) = E_Protected_Type);
10402 Record_Rep_Item (Prot_Typ, N);
10404 -- Chain the pragma on the contract for completeness
10406 Add_Contract_Item (N, Handler);
10407 end Process_Interrupt_Or_Attach_Handler;
10409 --------------------------------------------------
10410 -- Process_Restrictions_Or_Restriction_Warnings --
10411 --------------------------------------------------
10413 -- Note: some of the simple identifier cases were handled in par-prag,
10414 -- but it is harmless (and more straightforward) to simply handle all
10415 -- cases here, even if it means we repeat a bit of work in some cases.
10417 procedure Process_Restrictions_Or_Restriction_Warnings
10421 R_Id : Restriction_Id;
10427 -- Ignore all Restrictions pragmas in CodePeer mode
10429 if CodePeer_Mode then
10433 Check_Ada_83_Warning;
10434 Check_At_Least_N_Arguments (1);
10435 Check_Valid_Configuration_Pragma;
10438 while Present (Arg) loop
10440 Expr := Get_Pragma_Arg (Arg);
10442 -- Case of no restriction identifier present
10444 if Id = No_Name then
10445 if Nkind (Expr) /= N_Identifier then
10447 ("invalid form for restriction", Arg);
10452 (Process_Restriction_Synonyms (Expr));
10454 if R_Id not in All_Boolean_Restrictions then
10455 Error_Msg_Name_1 := Pname;
10457 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
10459 -- Check for possible misspelling
10461 for J in Restriction_Id loop
10463 Rnm : constant String := Restriction_Id'Image (J);
10466 Name_Buffer (1 .. Rnm'Length) := Rnm;
10467 Name_Len := Rnm'Length;
10468 Set_Casing (All_Lower_Case);
10470 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
10473 (Source_Index (Current_Sem_Unit)));
10474 Error_Msg_String (1 .. Rnm'Length) :=
10475 Name_Buffer (1 .. Name_Len);
10476 Error_Msg_Strlen := Rnm'Length;
10477 Error_Msg_N -- CODEFIX
10478 ("\possible misspelling of ""~""",
10479 Get_Pragma_Arg (Arg));
10488 if Implementation_Restriction (R_Id) then
10489 Check_Restriction (No_Implementation_Restrictions, Arg);
10492 -- Special processing for No_Elaboration_Code restriction
10494 if R_Id = No_Elaboration_Code then
10496 -- Restriction is only recognized within a configuration
10497 -- pragma file, or within a unit of the main extended
10498 -- program. Note: the test for Main_Unit is needed to
10499 -- properly include the case of configuration pragma files.
10501 if not (Current_Sem_Unit = Main_Unit
10502 or else In_Extended_Main_Source_Unit (N))
10506 -- Don't allow in a subunit unless already specified in
10509 elsif Nkind (Parent (N)) = N_Compilation_Unit
10510 and then Nkind (Unit (Parent (N))) = N_Subunit
10511 and then not Restriction_Active (No_Elaboration_Code)
10514 ("invalid specification of ""No_Elaboration_Code""",
10517 ("\restriction cannot be specified in a subunit", N);
10519 ("\unless also specified in body or spec", N);
10522 -- If we accept a No_Elaboration_Code restriction, then it
10523 -- needs to be added to the configuration restriction set so
10524 -- that we get proper application to other units in the main
10525 -- extended source as required.
10528 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
10531 -- Special processing for No_Tasking restriction placed in
10532 -- a configuration pragmas file.
10534 elsif R_Id = No_Tasking and then No (Cunit (Main_Unit)) then
10535 Set_Global_No_Tasking;
10538 Set_Restriction (R_Id, N, Warn);
10540 if R_Id = No_Dynamic_CPU_Assignment
10541 or else R_Id = No_Tasks_Unassigned_To_CPU
10543 -- These imply No_Dependence =>
10544 -- "System.Multiprocessors.Dispatching_Domains".
10545 -- This is not strictly what the AI says, but it eliminates
10546 -- the need for run-time checks, which are undesirable in
10549 Set_Restriction_No_Dependence
10551 (Sel_Comp ("system", "multiprocessors", Loc),
10552 "dispatching_domains"),
10556 if R_Id = No_Tasks_Unassigned_To_CPU then
10557 -- Likewise, imply No_Dynamic_CPU_Assignment
10559 Set_Restriction (No_Dynamic_CPU_Assignment, N, Warn);
10562 -- Check for obsolescent restrictions in Ada 2005 mode
10565 and then Ada_Version >= Ada_2005
10566 and then (R_Id = No_Asynchronous_Control
10568 R_Id = No_Unchecked_Deallocation
10570 R_Id = No_Unchecked_Conversion)
10572 Check_Restriction (No_Obsolescent_Features, N);
10575 -- A very special case that must be processed here: pragma
10576 -- Restrictions (No_Exceptions) turns off all run-time
10577 -- checking. This is a bit dubious in terms of the formal
10578 -- language definition, but it is what is intended by RM
10579 -- H.4(12). Restriction_Warnings never affects generated code
10580 -- so this is done only in the real restriction case.
10582 -- Atomic_Synchronization is not a real check, so it is not
10583 -- affected by this processing).
10585 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
10586 -- run-time checks in CodePeer and GNATprove modes: we want to
10587 -- generate checks for analysis purposes, as set respectively
10588 -- by -gnatC and -gnatd.F
10591 and then not (CodePeer_Mode or GNATprove_Mode)
10592 and then R_Id = No_Exceptions
10594 for J in Scope_Suppress.Suppress'Range loop
10595 if J /= Atomic_Synchronization then
10596 Scope_Suppress.Suppress (J) := True;
10601 -- Case of No_Dependence => unit-name. Note that the parser
10602 -- already made the necessary entry in the No_Dependence table.
10604 elsif Id = Name_No_Dependence then
10605 if not OK_No_Dependence_Unit_Name (Expr) then
10609 -- Case of No_Specification_Of_Aspect => aspect-identifier
10611 elsif Id = Name_No_Specification_Of_Aspect then
10616 if Nkind (Expr) /= N_Identifier then
10619 A_Id := Get_Aspect_Id (Chars (Expr));
10622 if A_Id = No_Aspect then
10623 Error_Pragma_Arg ("invalid restriction name", Arg);
10625 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
10629 -- Case of No_Use_Of_Attribute => attribute-identifier
10631 elsif Id = Name_No_Use_Of_Attribute then
10632 if Nkind (Expr) /= N_Identifier
10633 or else not Is_Attribute_Name (Chars (Expr))
10635 Error_Msg_N ("unknown attribute name??", Expr);
10638 Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
10641 -- Case of No_Use_Of_Entity => fully-qualified-name
10643 elsif Id = Name_No_Use_Of_Entity then
10645 -- Restriction is only recognized within a configuration
10646 -- pragma file, or within a unit of the main extended
10647 -- program. Note: the test for Main_Unit is needed to
10648 -- properly include the case of configuration pragma files.
10650 if Current_Sem_Unit = Main_Unit
10651 or else In_Extended_Main_Source_Unit (N)
10653 if not OK_No_Dependence_Unit_Name (Expr) then
10654 Error_Msg_N ("wrong form for entity name", Expr);
10656 Set_Restriction_No_Use_Of_Entity
10657 (Expr, Warn, No_Profile);
10661 -- Case of No_Use_Of_Pragma => pragma-identifier
10663 elsif Id = Name_No_Use_Of_Pragma then
10664 if Nkind (Expr) /= N_Identifier
10665 or else not Is_Pragma_Name (Chars (Expr))
10667 Error_Msg_N ("unknown pragma name??", Expr);
10669 Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
10672 -- All other cases of restriction identifier present
10675 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
10676 Analyze_And_Resolve (Expr, Any_Integer);
10678 if R_Id not in All_Parameter_Restrictions then
10680 ("invalid restriction parameter identifier", Arg);
10682 elsif not Is_OK_Static_Expression (Expr) then
10683 Flag_Non_Static_Expr
10684 ("value must be static expression!", Expr);
10687 elsif not Is_Integer_Type (Etype (Expr))
10688 or else Expr_Value (Expr) < 0
10691 ("value must be non-negative integer", Arg);
10694 -- Restriction pragma is active
10696 Val := Expr_Value (Expr);
10698 if not UI_Is_In_Int_Range (Val) then
10700 ("pragma ignored, value too large??", Arg);
10703 Set_Restriction (R_Id, N, Warn, Integer (UI_To_Int (Val)));
10708 end Process_Restrictions_Or_Restriction_Warnings;
10710 ---------------------------------
10711 -- Process_Suppress_Unsuppress --
10712 ---------------------------------
10714 -- Note: this procedure makes entries in the check suppress data
10715 -- structures managed by Sem. See spec of package Sem for full
10716 -- details on how we handle recording of check suppression.
10718 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
10723 In_Package_Spec : constant Boolean :=
10724 Is_Package_Or_Generic_Package (Current_Scope)
10725 and then not In_Package_Body (Current_Scope);
10727 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
10728 -- Used to suppress a single check on the given entity
10730 --------------------------------
10731 -- Suppress_Unsuppress_Echeck --
10732 --------------------------------
10734 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
10736 -- Check for error of trying to set atomic synchronization for
10737 -- a non-atomic variable.
10739 if C = Atomic_Synchronization
10740 and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
10743 ("pragma & requires atomic type or variable",
10744 Pragma_Identifier (Original_Node (N)));
10747 Set_Checks_May_Be_Suppressed (E);
10749 if In_Package_Spec then
10750 Push_Global_Suppress_Stack_Entry
10753 Suppress => Suppress_Case);
10755 Push_Local_Suppress_Stack_Entry
10758 Suppress => Suppress_Case);
10761 -- If this is a first subtype, and the base type is distinct,
10762 -- then also set the suppress flags on the base type.
10764 if Is_First_Subtype (E) and then Etype (E) /= E then
10765 Suppress_Unsuppress_Echeck (Etype (E), C);
10767 end Suppress_Unsuppress_Echeck;
10769 -- Start of processing for Process_Suppress_Unsuppress
10772 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
10773 -- on user code: we want to generate checks for analysis purposes, as
10774 -- set respectively by -gnatC and -gnatd.F
10776 if Comes_From_Source (N)
10777 and then (CodePeer_Mode or GNATprove_Mode)
10782 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
10783 -- declarative part or a package spec (RM 11.5(5)).
10785 if not Is_Configuration_Pragma then
10786 Check_Is_In_Decl_Part_Or_Package_Spec;
10789 Check_At_Least_N_Arguments (1);
10790 Check_At_Most_N_Arguments (2);
10791 Check_No_Identifier (Arg1);
10792 Check_Arg_Is_Identifier (Arg1);
10794 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
10796 if C = No_Check_Id then
10798 ("argument of pragma% is not valid check name", Arg1);
10801 -- Warn that suppress of Elaboration_Check has no effect in SPARK
10803 if C = Elaboration_Check and then SPARK_Mode = On then
10805 ("Suppress of Elaboration_Check ignored in SPARK??",
10806 "\elaboration checking rules are statically enforced "
10807 & "(SPARK RM 7.7)", Arg1);
10810 -- One-argument case
10812 if Arg_Count = 1 then
10814 -- Make an entry in the local scope suppress table. This is the
10815 -- table that directly shows the current value of the scope
10816 -- suppress check for any check id value.
10818 if C = All_Checks then
10820 -- For All_Checks, we set all specific predefined checks with
10821 -- the exception of Elaboration_Check, which is handled
10822 -- specially because of not wanting All_Checks to have the
10823 -- effect of deactivating static elaboration order processing.
10824 -- Atomic_Synchronization is also not affected, since this is
10825 -- not a real check.
10827 for J in Scope_Suppress.Suppress'Range loop
10828 if J /= Elaboration_Check
10830 J /= Atomic_Synchronization
10832 Scope_Suppress.Suppress (J) := Suppress_Case;
10836 -- If not All_Checks, and predefined check, then set appropriate
10837 -- scope entry. Note that we will set Elaboration_Check if this
10838 -- is explicitly specified. Atomic_Synchronization is allowed
10839 -- only if internally generated and entity is atomic.
10841 elsif C in Predefined_Check_Id
10842 and then (not Comes_From_Source (N)
10843 or else C /= Atomic_Synchronization)
10845 Scope_Suppress.Suppress (C) := Suppress_Case;
10848 -- Also make an entry in the Local_Entity_Suppress table
10850 Push_Local_Suppress_Stack_Entry
10853 Suppress => Suppress_Case);
10855 -- Case of two arguments present, where the check is suppressed for
10856 -- a specified entity (given as the second argument of the pragma)
10859 -- This is obsolescent in Ada 2005 mode
10861 if Ada_Version >= Ada_2005 then
10862 Check_Restriction (No_Obsolescent_Features, Arg2);
10865 Check_Optional_Identifier (Arg2, Name_On);
10866 E_Id := Get_Pragma_Arg (Arg2);
10869 if not Is_Entity_Name (E_Id) then
10871 ("second argument of pragma% must be entity name", Arg2);
10874 E := Entity (E_Id);
10880 -- A pragma that applies to a Ghost entity becomes Ghost for the
10881 -- purposes of legality checks and removal of ignored Ghost code.
10883 Mark_Ghost_Pragma (N, E);
10885 -- Enforce RM 11.5(7) which requires that for a pragma that
10886 -- appears within a package spec, the named entity must be
10887 -- within the package spec. We allow the package name itself
10888 -- to be mentioned since that makes sense, although it is not
10889 -- strictly allowed by 11.5(7).
10892 and then E /= Current_Scope
10893 and then Scope (E) /= Current_Scope
10896 ("entity in pragma% is not in package spec (RM 11.5(7))",
10900 -- Loop through homonyms. As noted below, in the case of a package
10901 -- spec, only homonyms within the package spec are considered.
10904 Suppress_Unsuppress_Echeck (E, C);
10906 if Is_Generic_Instance (E)
10907 and then Is_Subprogram (E)
10908 and then Present (Alias (E))
10910 Suppress_Unsuppress_Echeck (Alias (E), C);
10913 -- Move to next homonym if not aspect spec case
10915 exit when From_Aspect_Specification (N);
10919 -- If we are within a package specification, the pragma only
10920 -- applies to homonyms in the same scope.
10922 exit when In_Package_Spec
10923 and then Scope (E) /= Current_Scope;
10926 end Process_Suppress_Unsuppress;
10928 -------------------------------
10929 -- Record_Independence_Check --
10930 -------------------------------
10932 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id) is
10933 pragma Unreferenced (N, E);
10935 -- For GCC back ends the validation is done a priori
10936 -- ??? This code is dead, might be useful in the future
10938 -- if not AAMP_On_Target then
10942 -- Independence_Checks.Append ((N, E));
10945 end Record_Independence_Check;
10951 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
10953 if Is_Imported (E) then
10955 ("cannot export entity& that was previously imported", Arg);
10957 elsif Present (Address_Clause (E))
10958 and then not Relaxed_RM_Semantics
10961 ("cannot export entity& that has an address clause", Arg);
10964 Set_Is_Exported (E);
10966 -- Generate a reference for entity explicitly, because the
10967 -- identifier may be overloaded and name resolution will not
10970 Generate_Reference (E, Arg);
10972 -- Deal with exporting non-library level entity
10974 if not Is_Library_Level_Entity (E) then
10976 -- Not allowed at all for subprograms
10978 if Is_Subprogram (E) then
10979 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
10981 -- Otherwise set public and statically allocated
10985 Set_Is_Statically_Allocated (E);
10987 -- Warn if the corresponding W flag is set
10989 if Warn_On_Export_Import
10991 -- Only do this for something that was in the source. Not
10992 -- clear if this can be False now (there used for sure to be
10993 -- cases on some systems where it was False), but anyway the
10994 -- test is harmless if not needed, so it is retained.
10996 and then Comes_From_Source (Arg)
10999 ("?x?& has been made static as a result of Export",
11002 ("\?x?this usage is non-standard and non-portable",
11008 if Warn_On_Export_Import and then Is_Type (E) then
11009 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
11012 if Warn_On_Export_Import and Inside_A_Generic then
11014 ("all instances of& will have the same external name?x?",
11019 ----------------------------------------------
11020 -- Set_Extended_Import_Export_External_Name --
11021 ----------------------------------------------
11023 procedure Set_Extended_Import_Export_External_Name
11024 (Internal_Ent : Entity_Id;
11025 Arg_External : Node_Id)
11027 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
11028 New_Name : Node_Id;
11031 if No (Arg_External) then
11035 Check_Arg_Is_External_Name (Arg_External);
11037 if Nkind (Arg_External) = N_String_Literal then
11038 if String_Length (Strval (Arg_External)) = 0 then
11041 New_Name := Adjust_External_Name_Case (Arg_External);
11044 elsif Nkind (Arg_External) = N_Identifier then
11045 New_Name := Get_Default_External_Name (Arg_External);
11047 -- Check_Arg_Is_External_Name should let through only identifiers and
11048 -- string literals or static string expressions (which are folded to
11049 -- string literals).
11052 raise Program_Error;
11055 -- If we already have an external name set (by a prior normal Import
11056 -- or Export pragma), then the external names must match
11058 if Present (Interface_Name (Internal_Ent)) then
11060 -- Ignore mismatching names in CodePeer mode, to support some
11061 -- old compilers which would export the same procedure under
11062 -- different names, e.g:
11064 -- pragma Export_Procedure (P, "a");
11065 -- pragma Export_Procedure (P, "b");
11067 if CodePeer_Mode then
11071 Check_Matching_Internal_Names : declare
11072 S1 : constant String_Id := Strval (Old_Name);
11073 S2 : constant String_Id := Strval (New_Name);
11075 procedure Mismatch;
11076 pragma No_Return (Mismatch);
11077 -- Called if names do not match
11083 procedure Mismatch is
11085 Error_Msg_Sloc := Sloc (Old_Name);
11087 ("external name does not match that given #",
11091 -- Start of processing for Check_Matching_Internal_Names
11094 if String_Length (S1) /= String_Length (S2) then
11098 for J in 1 .. String_Length (S1) loop
11099 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
11104 end Check_Matching_Internal_Names;
11106 -- Otherwise set the given name
11109 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
11110 Check_Duplicated_Export_Name (New_Name);
11112 end Set_Extended_Import_Export_External_Name;
11118 procedure Set_Imported (E : Entity_Id) is
11120 -- Error message if already imported or exported
11122 if Is_Exported (E) or else Is_Imported (E) then
11124 -- Error if being set Exported twice
11126 if Is_Exported (E) then
11127 Error_Msg_NE ("entity& was previously exported", N, E);
11129 -- Ignore error in CodePeer mode where we treat all imported
11130 -- subprograms as unknown.
11132 elsif CodePeer_Mode then
11135 -- OK if Import/Interface case
11137 elsif Import_Interface_Present (N) then
11140 -- Error if being set Imported twice
11143 Error_Msg_NE ("entity& was previously imported", N, E);
11146 Error_Msg_Name_1 := Pname;
11148 ("\(pragma% applies to all previous entities)", N);
11150 Error_Msg_Sloc := Sloc (E);
11151 Error_Msg_NE ("\import not allowed for& declared#", N, E);
11153 -- Here if not previously imported or exported, OK to import
11156 Set_Is_Imported (E);
11158 -- For subprogram, set Import_Pragma field
11160 if Is_Subprogram (E) then
11161 Set_Import_Pragma (E, N);
11164 -- If the entity is an object that is not at the library level,
11165 -- then it is statically allocated. We do not worry about objects
11166 -- with address clauses in this context since they are not really
11167 -- imported in the linker sense.
11170 and then not Is_Library_Level_Entity (E)
11171 and then No (Address_Clause (E))
11173 Set_Is_Statically_Allocated (E);
11180 -------------------------
11181 -- Set_Mechanism_Value --
11182 -------------------------
11184 -- Note: the mechanism name has not been analyzed (and cannot indeed be
11185 -- analyzed, since it is semantic nonsense), so we get it in the exact
11186 -- form created by the parser.
11188 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
11189 procedure Bad_Mechanism;
11190 pragma No_Return (Bad_Mechanism);
11191 -- Signal bad mechanism name
11193 -------------------
11194 -- Bad_Mechanism --
11195 -------------------
11197 procedure Bad_Mechanism is
11199 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
11202 -- Start of processing for Set_Mechanism_Value
11205 if Mechanism (Ent) /= Default_Mechanism then
11207 ("mechanism for & has already been set", Mech_Name, Ent);
11210 -- MECHANISM_NAME ::= value | reference
11212 if Nkind (Mech_Name) = N_Identifier then
11213 if Chars (Mech_Name) = Name_Value then
11214 Set_Mechanism (Ent, By_Copy);
11217 elsif Chars (Mech_Name) = Name_Reference then
11218 Set_Mechanism (Ent, By_Reference);
11221 elsif Chars (Mech_Name) = Name_Copy then
11223 ("bad mechanism name, Value assumed", Mech_Name);
11232 end Set_Mechanism_Value;
11234 --------------------------
11235 -- Set_Rational_Profile --
11236 --------------------------
11238 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
11239 -- extension to the semantics of renaming declarations.
11241 procedure Set_Rational_Profile is
11243 Implicit_Packing := True;
11244 Overriding_Renamings := True;
11245 Use_VADS_Size := True;
11246 end Set_Rational_Profile;
11248 ---------------------------
11249 -- Set_Ravenscar_Profile --
11250 ---------------------------
11252 -- The tasks to be done here are
11254 -- Set required policies
11256 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11257 -- (For Ravenscar, Jorvik, and GNAT_Extended_Ravenscar profiles)
11258 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11259 -- (For GNAT_Ravenscar_EDF profile)
11260 -- pragma Locking_Policy (Ceiling_Locking)
11262 -- Set Detect_Blocking mode
11264 -- Set required restrictions (see System.Rident for detailed list)
11266 -- Set the No_Dependence rules
11267 -- No_Dependence => Ada.Asynchronous_Task_Control
11268 -- No_Dependence => Ada.Calendar
11269 -- No_Dependence => Ada.Execution_Time.Group_Budget
11270 -- No_Dependence => Ada.Execution_Time.Timers
11271 -- No_Dependence => Ada.Task_Attributes
11272 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11274 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id) is
11275 procedure Set_Error_Msg_To_Profile_Name;
11276 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
11279 -----------------------------------
11280 -- Set_Error_Msg_To_Profile_Name --
11281 -----------------------------------
11283 procedure Set_Error_Msg_To_Profile_Name is
11284 Prof_Nam : constant Node_Id :=
11286 (First (Pragma_Argument_Associations (N)));
11289 Get_Name_String (Chars (Prof_Nam));
11290 Adjust_Name_Case (Global_Name_Buffer, Sloc (Prof_Nam));
11291 Error_Msg_Strlen := Name_Len;
11292 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
11293 end Set_Error_Msg_To_Profile_Name;
11295 Profile_Dispatching_Policy : Character;
11297 -- Start of processing for Set_Ravenscar_Profile
11300 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11302 if Profile = GNAT_Ravenscar_EDF then
11303 Profile_Dispatching_Policy := 'E';
11305 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11308 Profile_Dispatching_Policy := 'F';
11311 if Task_Dispatching_Policy /= ' '
11312 and then Task_Dispatching_Policy /= Profile_Dispatching_Policy
11314 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
11315 Set_Error_Msg_To_Profile_Name;
11316 Error_Pragma ("Profile (~) incompatible with policy#");
11318 -- Set the FIFO_Within_Priorities policy, but always preserve
11319 -- System_Location since we like the error message with the run time
11323 Task_Dispatching_Policy := Profile_Dispatching_Policy;
11325 if Task_Dispatching_Policy_Sloc /= System_Location then
11326 Task_Dispatching_Policy_Sloc := Loc;
11330 -- pragma Locking_Policy (Ceiling_Locking)
11332 if Locking_Policy /= ' '
11333 and then Locking_Policy /= 'C'
11335 Error_Msg_Sloc := Locking_Policy_Sloc;
11336 Set_Error_Msg_To_Profile_Name;
11337 Error_Pragma ("Profile (~) incompatible with policy#");
11339 -- Set the Ceiling_Locking policy, but preserve System_Location since
11340 -- we like the error message with the run time name.
11343 Locking_Policy := 'C';
11345 if Locking_Policy_Sloc /= System_Location then
11346 Locking_Policy_Sloc := Loc;
11350 -- pragma Detect_Blocking
11352 Detect_Blocking := True;
11354 -- Set the corresponding restrictions
11356 Set_Profile_Restrictions
11357 (Profile, N, Warn => Treat_Restrictions_As_Warnings);
11359 -- Set the No_Dependence restrictions
11361 -- The following No_Dependence restrictions:
11362 -- No_Dependence => Ada.Asynchronous_Task_Control
11363 -- No_Dependence => Ada.Calendar
11364 -- No_Dependence => Ada.Task_Attributes
11365 -- are already set by previous call to Set_Profile_Restrictions.
11368 -- Set the following restrictions which were added to Ada 2005:
11369 -- No_Dependence => Ada.Execution_Time.Group_Budget
11370 -- No_Dependence => Ada.Execution_Time.Timers
11372 if Ada_Version >= Ada_2005 then
11374 Execution_Time : constant Node_Id :=
11375 Sel_Comp ("ada", "execution_time", Loc);
11376 Group_Budgets : constant Node_Id :=
11377 Sel_Comp (Execution_Time, "group_budgets");
11378 Timers : constant Node_Id :=
11379 Sel_Comp (Execution_Time, "timers");
11381 Set_Restriction_No_Dependence
11382 (Unit => Group_Budgets,
11383 Warn => Treat_Restrictions_As_Warnings,
11384 Profile => Ravenscar);
11385 Set_Restriction_No_Dependence
11387 Warn => Treat_Restrictions_As_Warnings,
11388 Profile => Ravenscar);
11392 -- Set the following restriction which was added to Ada 2012 (see
11394 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11396 if Ada_Version >= Ada_2012 then
11397 Set_Restriction_No_Dependence
11399 (Sel_Comp ("system", "multiprocessors", Loc),
11400 "dispatching_domains"),
11401 Warn => Treat_Restrictions_As_Warnings,
11402 Profile => Ravenscar);
11404 -- Set the following restriction which was added to Ada 2020,
11405 -- but as a binding interpretation:
11406 -- No_Dependence => Ada.Synchronous_Barriers
11407 -- for Ravenscar (and therefore for Ravenscar variants) but not
11408 -- for Jorvik. The unit Ada.Synchronous_Barriers was introduced
11409 -- in Ada2012 (AI05-0174).
11411 if Profile /= Jorvik then
11412 Set_Restriction_No_Dependence
11413 (Sel_Comp ("ada", "synchronous_barriers", Loc),
11414 Warn => Treat_Restrictions_As_Warnings,
11415 Profile => Ravenscar);
11419 end Set_Ravenscar_Profile;
11421 -- Start of processing for Analyze_Pragma
11424 -- The following code is a defense against recursion. Not clear that
11425 -- this can happen legitimately, but perhaps some error situations can
11426 -- cause it, and we did see this recursion during testing.
11428 if Analyzed (N) then
11434 Check_Restriction_No_Use_Of_Pragma (N);
11436 if Get_Aspect_Id (Chars (Pragma_Identifier (N))) /= No_Aspect then
11437 -- 6.1/3 No_Specification_of_Aspect: Identifies an aspect for which
11438 -- no aspect_specification, attribute_definition_clause, or pragma
11440 Check_Restriction_No_Specification_Of_Aspect (N);
11443 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
11444 -- Default_Scalar_Storage_Order if the -gnatI switch was given.
11446 if Should_Ignore_Pragma_Sem (N)
11447 or else (Prag_Id = Pragma_Default_Scalar_Storage_Order
11448 and then Ignore_Rep_Clauses)
11453 -- Deal with unrecognized pragma
11455 if not Is_Pragma_Name (Pname) then
11456 if Warn_On_Unrecognized_Pragma then
11457 Error_Msg_Name_1 := Pname;
11458 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
11460 for PN in First_Pragma_Name .. Last_Pragma_Name loop
11461 if Is_Bad_Spelling_Of (Pname, PN) then
11462 Error_Msg_Name_1 := PN;
11463 Error_Msg_N -- CODEFIX
11464 ("\?g?possible misspelling of %!", Pragma_Identifier (N));
11473 -- Here to start processing for recognized pragma
11475 Pname := Original_Aspect_Pragma_Name (N);
11477 -- Capture setting of Opt.Uneval_Old
11479 case Opt.Uneval_Old is
11481 Set_Uneval_Old_Accept (N);
11487 Set_Uneval_Old_Warn (N);
11490 raise Program_Error;
11493 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
11494 -- is already set, indicating that we have already checked the policy
11495 -- at the right point. This happens for example in the case of a pragma
11496 -- that is derived from an Aspect.
11498 if Is_Ignored (N) or else Is_Checked (N) then
11501 -- For a pragma that is a rewriting of another pragma, copy the
11502 -- Is_Checked/Is_Ignored status from the rewritten pragma.
11504 elsif Is_Rewrite_Substitution (N)
11505 and then Nkind (Original_Node (N)) = N_Pragma
11507 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
11508 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
11510 -- Otherwise query the applicable policy at this point
11513 Check_Applicable_Policy (N);
11515 -- If pragma is disabled, rewrite as NULL and skip analysis
11517 if Is_Disabled (N) then
11518 Rewrite (N, Make_Null_Statement (Loc));
11524 -- Preset arguments
11533 if Present (Pragma_Argument_Associations (N)) then
11534 Arg_Count := List_Length (Pragma_Argument_Associations (N));
11535 Arg1 := First (Pragma_Argument_Associations (N));
11537 if Present (Arg1) then
11538 Arg2 := Next (Arg1);
11540 if Present (Arg2) then
11541 Arg3 := Next (Arg2);
11543 if Present (Arg3) then
11544 Arg4 := Next (Arg3);
11546 if Present (Arg4) then
11547 Arg5 := Next (Arg4);
11554 -- An enumeration type defines the pragmas that are supported by the
11555 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
11556 -- into the corresponding enumeration value for the following case.
11564 -- pragma Abort_Defer;
11566 when Pragma_Abort_Defer =>
11568 Check_Arg_Count (0);
11570 -- The only required semantic processing is to check the
11571 -- placement. This pragma must appear at the start of the
11572 -- statement sequence of a handled sequence of statements.
11574 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
11575 or else N /= First (Statements (Parent (N)))
11580 --------------------
11581 -- Abstract_State --
11582 --------------------
11584 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
11586 -- ABSTRACT_STATE_LIST ::=
11588 -- | STATE_NAME_WITH_OPTIONS
11589 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
11591 -- STATE_NAME_WITH_OPTIONS ::=
11593 -- | (STATE_NAME with OPTION_LIST)
11595 -- OPTION_LIST ::= OPTION {, OPTION}
11599 -- | NAME_VALUE_OPTION
11601 -- SIMPLE_OPTION ::= Ghost | Relaxed_Initialization | Synchronous
11603 -- NAME_VALUE_OPTION ::=
11604 -- Part_Of => ABSTRACT_STATE
11605 -- | External [=> EXTERNAL_PROPERTY_LIST]
11607 -- EXTERNAL_PROPERTY_LIST ::=
11608 -- EXTERNAL_PROPERTY
11609 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
11611 -- EXTERNAL_PROPERTY ::=
11612 -- Async_Readers [=> boolean_EXPRESSION]
11613 -- | Async_Writers [=> boolean_EXPRESSION]
11614 -- | Effective_Reads [=> boolean_EXPRESSION]
11615 -- | Effective_Writes [=> boolean_EXPRESSION]
11616 -- others => boolean_EXPRESSION
11618 -- STATE_NAME ::= defining_identifier
11620 -- ABSTRACT_STATE ::= name
11622 -- Characteristics:
11624 -- * Analysis - The annotation is fully analyzed immediately upon
11625 -- elaboration as it cannot forward reference entities.
11627 -- * Expansion - None.
11629 -- * Template - The annotation utilizes the generic template of the
11630 -- related package declaration.
11632 -- * Globals - The annotation cannot reference global entities.
11634 -- * Instance - The annotation is instantiated automatically when
11635 -- the related generic package is instantiated.
11637 when Pragma_Abstract_State => Abstract_State : declare
11638 Missing_Parentheses : Boolean := False;
11639 -- Flag set when a state declaration with options is not properly
11642 -- Flags used to verify the consistency of states
11644 Non_Null_Seen : Boolean := False;
11645 Null_Seen : Boolean := False;
11647 procedure Analyze_Abstract_State
11649 Pack_Id : Entity_Id);
11650 -- Verify the legality of a single state declaration. Create and
11651 -- decorate a state abstraction entity and introduce it into the
11652 -- visibility chain. Pack_Id denotes the entity or the related
11653 -- package where pragma Abstract_State appears.
11655 procedure Malformed_State_Error (State : Node_Id);
11656 -- Emit an error concerning the illegal declaration of abstract
11657 -- state State. This routine diagnoses syntax errors that lead to
11658 -- a different parse tree. The error is issued regardless of the
11659 -- SPARK mode in effect.
11661 ----------------------------
11662 -- Analyze_Abstract_State --
11663 ----------------------------
11665 procedure Analyze_Abstract_State
11667 Pack_Id : Entity_Id)
11669 -- Flags used to verify the consistency of options
11671 AR_Seen : Boolean := False;
11672 AW_Seen : Boolean := False;
11673 ER_Seen : Boolean := False;
11674 EW_Seen : Boolean := False;
11675 External_Seen : Boolean := False;
11676 Ghost_Seen : Boolean := False;
11677 Others_Seen : Boolean := False;
11678 Part_Of_Seen : Boolean := False;
11679 Relaxed_Initialization_Seen : Boolean := False;
11680 Synchronous_Seen : Boolean := False;
11682 -- Flags used to store the static value of all external states'
11685 AR_Val : Boolean := False;
11686 AW_Val : Boolean := False;
11687 ER_Val : Boolean := False;
11688 EW_Val : Boolean := False;
11690 State_Id : Entity_Id := Empty;
11691 -- The entity to be generated for the current state declaration
11693 procedure Analyze_External_Option (Opt : Node_Id);
11694 -- Verify the legality of option External
11696 procedure Analyze_External_Property
11698 Expr : Node_Id := Empty);
11699 -- Verify the legailty of a single external property. Prop
11700 -- denotes the external property. Expr is the expression used
11701 -- to set the property.
11703 procedure Analyze_Part_Of_Option (Opt : Node_Id);
11704 -- Verify the legality of option Part_Of
11706 procedure Check_Duplicate_Option
11708 Status : in out Boolean);
11709 -- Flag Status denotes whether a particular option has been
11710 -- seen while processing a state. This routine verifies that
11711 -- Opt is not a duplicate option and sets the flag Status
11712 -- (SPARK RM 7.1.4(1)).
11714 procedure Check_Duplicate_Property
11716 Status : in out Boolean);
11717 -- Flag Status denotes whether a particular property has been
11718 -- seen while processing option External. This routine verifies
11719 -- that Prop is not a duplicate property and sets flag Status.
11720 -- Opt is not a duplicate property and sets the flag Status.
11721 -- (SPARK RM 7.1.4(2))
11723 procedure Check_Ghost_Synchronous;
11724 -- Ensure that the abstract state is not subject to both Ghost
11725 -- and Synchronous simple options. Emit an error if this is the
11728 procedure Create_Abstract_State
11732 Is_Null : Boolean);
11733 -- Generate an abstract state entity with name Nam and enter it
11734 -- into visibility. Decl is the "declaration" of the state as
11735 -- it appears in pragma Abstract_State. Loc is the location of
11736 -- the related state "declaration". Flag Is_Null should be set
11737 -- when the associated Abstract_State pragma defines a null
11740 -----------------------------
11741 -- Analyze_External_Option --
11742 -----------------------------
11744 procedure Analyze_External_Option (Opt : Node_Id) is
11745 Errors : constant Nat := Serious_Errors_Detected;
11747 Props : Node_Id := Empty;
11750 if Nkind (Opt) = N_Component_Association then
11751 Props := Expression (Opt);
11754 -- External state with properties
11756 if Present (Props) then
11758 -- Multiple properties appear as an aggregate
11760 if Nkind (Props) = N_Aggregate then
11762 -- Simple property form
11764 Prop := First (Expressions (Props));
11765 while Present (Prop) loop
11766 Analyze_External_Property (Prop);
11770 -- Property with expression form
11772 Prop := First (Component_Associations (Props));
11773 while Present (Prop) loop
11774 Analyze_External_Property
11775 (Prop => First (Choices (Prop)),
11776 Expr => Expression (Prop));
11784 Analyze_External_Property (Props);
11787 -- An external state defined without any properties defaults
11788 -- all properties to True.
11797 -- Once all external properties have been processed, verify
11798 -- their mutual interaction. Do not perform the check when
11799 -- at least one of the properties is illegal as this will
11800 -- produce a bogus error.
11802 if Errors = Serious_Errors_Detected then
11803 Check_External_Properties
11804 (State, AR_Val, AW_Val, ER_Val, EW_Val);
11806 end Analyze_External_Option;
11808 -------------------------------
11809 -- Analyze_External_Property --
11810 -------------------------------
11812 procedure Analyze_External_Property
11814 Expr : Node_Id := Empty)
11816 Expr_Val : Boolean;
11819 -- Check the placement of "others" (if available)
11821 if Nkind (Prop) = N_Others_Choice then
11822 if Others_Seen then
11824 ("only one others choice allowed in option External",
11827 Others_Seen := True;
11830 elsif Others_Seen then
11832 ("others must be the last property in option External",
11835 -- The only remaining legal options are the four predefined
11836 -- external properties.
11838 elsif Nkind (Prop) = N_Identifier
11839 and then Chars (Prop) in Name_Async_Readers
11840 | Name_Async_Writers
11841 | Name_Effective_Reads
11842 | Name_Effective_Writes
11846 -- Otherwise the construct is not a valid property
11849 SPARK_Msg_N ("invalid external state property", Prop);
11853 -- Ensure that the expression of the external state property
11854 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
11856 if Present (Expr) then
11857 Analyze_And_Resolve (Expr, Standard_Boolean);
11859 if Is_OK_Static_Expression (Expr) then
11860 Expr_Val := Is_True (Expr_Value (Expr));
11863 ("expression of external state property must be "
11868 -- The lack of expression defaults the property to True
11874 -- Named properties
11876 if Nkind (Prop) = N_Identifier then
11877 if Chars (Prop) = Name_Async_Readers then
11878 Check_Duplicate_Property (Prop, AR_Seen);
11879 AR_Val := Expr_Val;
11881 elsif Chars (Prop) = Name_Async_Writers then
11882 Check_Duplicate_Property (Prop, AW_Seen);
11883 AW_Val := Expr_Val;
11885 elsif Chars (Prop) = Name_Effective_Reads then
11886 Check_Duplicate_Property (Prop, ER_Seen);
11887 ER_Val := Expr_Val;
11890 Check_Duplicate_Property (Prop, EW_Seen);
11891 EW_Val := Expr_Val;
11894 -- The handling of property "others" must take into account
11895 -- all other named properties that have been encountered so
11896 -- far. Only those that have not been seen are affected by
11900 if not AR_Seen then
11901 AR_Val := Expr_Val;
11904 if not AW_Seen then
11905 AW_Val := Expr_Val;
11908 if not ER_Seen then
11909 ER_Val := Expr_Val;
11912 if not EW_Seen then
11913 EW_Val := Expr_Val;
11916 end Analyze_External_Property;
11918 ----------------------------
11919 -- Analyze_Part_Of_Option --
11920 ----------------------------
11922 procedure Analyze_Part_Of_Option (Opt : Node_Id) is
11923 Encap : constant Node_Id := Expression (Opt);
11924 Constits : Elist_Id;
11925 Encap_Id : Entity_Id;
11929 Check_Duplicate_Option (Opt, Part_Of_Seen);
11932 (Indic => First (Choices (Opt)),
11933 Item_Id => State_Id,
11935 Encap_Id => Encap_Id,
11938 -- The Part_Of indicator transforms the abstract state into
11939 -- a constituent of the encapsulating state or single
11940 -- concurrent type.
11943 pragma Assert (Present (Encap_Id));
11944 Constits := Part_Of_Constituents (Encap_Id);
11946 if No (Constits) then
11947 Constits := New_Elmt_List;
11948 Set_Part_Of_Constituents (Encap_Id, Constits);
11951 Append_Elmt (State_Id, Constits);
11952 Set_Encapsulating_State (State_Id, Encap_Id);
11954 end Analyze_Part_Of_Option;
11956 ----------------------------
11957 -- Check_Duplicate_Option --
11958 ----------------------------
11960 procedure Check_Duplicate_Option
11962 Status : in out Boolean)
11966 SPARK_Msg_N ("duplicate state option", Opt);
11970 end Check_Duplicate_Option;
11972 ------------------------------
11973 -- Check_Duplicate_Property --
11974 ------------------------------
11976 procedure Check_Duplicate_Property
11978 Status : in out Boolean)
11982 SPARK_Msg_N ("duplicate external property", Prop);
11986 end Check_Duplicate_Property;
11988 -----------------------------
11989 -- Check_Ghost_Synchronous --
11990 -----------------------------
11992 procedure Check_Ghost_Synchronous is
11994 -- A synchronized abstract state cannot be Ghost and vice
11995 -- versa (SPARK RM 6.9(19)).
11997 if Ghost_Seen and Synchronous_Seen then
11998 SPARK_Msg_N ("synchronized state cannot be ghost", State);
12000 end Check_Ghost_Synchronous;
12002 ---------------------------
12003 -- Create_Abstract_State --
12004 ---------------------------
12006 procedure Create_Abstract_State
12013 -- The abstract state may be semi-declared when the related
12014 -- package was withed through a limited with clause. In that
12015 -- case reuse the entity to fully declare the state.
12017 if Present (Decl) and then Present (Entity (Decl)) then
12018 State_Id := Entity (Decl);
12020 -- Otherwise the elaboration of pragma Abstract_State
12021 -- declares the state.
12024 State_Id := Make_Defining_Identifier (Loc, Nam);
12026 if Present (Decl) then
12027 Set_Entity (Decl, State_Id);
12031 -- Null states never come from source
12033 Set_Comes_From_Source (State_Id, not Is_Null);
12034 Set_Parent (State_Id, State);
12035 Set_Ekind (State_Id, E_Abstract_State);
12036 Set_Etype (State_Id, Standard_Void_Type);
12037 Set_Encapsulating_State (State_Id, Empty);
12039 -- Set the SPARK mode from the current context
12041 Set_SPARK_Pragma (State_Id, SPARK_Mode_Pragma);
12042 Set_SPARK_Pragma_Inherited (State_Id);
12044 -- An abstract state declared within a Ghost region becomes
12045 -- Ghost (SPARK RM 6.9(2)).
12047 if Ghost_Mode > None or else Is_Ghost_Entity (Pack_Id) then
12048 Set_Is_Ghost_Entity (State_Id);
12051 -- Establish a link between the state declaration and the
12052 -- abstract state entity. Note that a null state remains as
12053 -- N_Null and does not carry any linkages.
12055 if not Is_Null then
12056 if Present (Decl) then
12057 Set_Entity (Decl, State_Id);
12058 Set_Etype (Decl, Standard_Void_Type);
12061 -- Every non-null state must be defined, nameable and
12064 Push_Scope (Pack_Id);
12065 Generate_Definition (State_Id);
12066 Enter_Name (State_Id);
12069 end Create_Abstract_State;
12076 -- Start of processing for Analyze_Abstract_State
12079 -- A package with a null abstract state is not allowed to
12080 -- declare additional states.
12084 ("package & has null abstract state", State, Pack_Id);
12086 -- Null states appear as internally generated entities
12088 elsif Nkind (State) = N_Null then
12089 Create_Abstract_State
12090 (Nam => New_Internal_Name ('S'),
12092 Loc => Sloc (State),
12096 -- Catch a case where a null state appears in a list of
12097 -- non-null states.
12099 if Non_Null_Seen then
12101 ("package & has non-null abstract state",
12105 -- Simple state declaration
12107 elsif Nkind (State) = N_Identifier then
12108 Create_Abstract_State
12109 (Nam => Chars (State),
12111 Loc => Sloc (State),
12113 Non_Null_Seen := True;
12115 -- State declaration with various options. This construct
12116 -- appears as an extension aggregate in the tree.
12118 elsif Nkind (State) = N_Extension_Aggregate then
12119 if Nkind (Ancestor_Part (State)) = N_Identifier then
12120 Create_Abstract_State
12121 (Nam => Chars (Ancestor_Part (State)),
12122 Decl => Ancestor_Part (State),
12123 Loc => Sloc (Ancestor_Part (State)),
12125 Non_Null_Seen := True;
12128 ("state name must be an identifier",
12129 Ancestor_Part (State));
12132 -- Options External, Ghost and Synchronous appear as
12135 Opt := First (Expressions (State));
12136 while Present (Opt) loop
12137 if Nkind (Opt) = N_Identifier then
12141 if Chars (Opt) = Name_External then
12142 Check_Duplicate_Option (Opt, External_Seen);
12143 Analyze_External_Option (Opt);
12147 elsif Chars (Opt) = Name_Ghost then
12148 Check_Duplicate_Option (Opt, Ghost_Seen);
12149 Check_Ghost_Synchronous;
12151 if Present (State_Id) then
12152 Set_Is_Ghost_Entity (State_Id);
12157 elsif Chars (Opt) = Name_Synchronous then
12158 Check_Duplicate_Option (Opt, Synchronous_Seen);
12159 Check_Ghost_Synchronous;
12161 -- Relaxed_Initialization
12163 elsif Chars (Opt) = Name_Relaxed_Initialization then
12164 Check_Duplicate_Option
12165 (Opt, Relaxed_Initialization_Seen);
12167 -- Option Part_Of without an encapsulating state is
12168 -- illegal (SPARK RM 7.1.4(8)).
12170 elsif Chars (Opt) = Name_Part_Of then
12172 ("indicator Part_Of must denote abstract state, "
12173 & "single protected type or single task type",
12176 -- Do not emit an error message when a previous state
12177 -- declaration with options was not parenthesized as
12178 -- the option is actually another state declaration.
12180 -- with Abstract_State
12181 -- (State_1 with ..., -- missing parentheses
12182 -- (State_2 with ...),
12183 -- State_3) -- ok state declaration
12185 elsif Missing_Parentheses then
12188 -- Otherwise the option is not allowed. Note that it
12189 -- is not possible to distinguish between an option
12190 -- and a state declaration when a previous state with
12191 -- options not properly parentheses.
12193 -- with Abstract_State
12194 -- (State_1 with ..., -- missing parentheses
12195 -- State_2); -- could be an option
12199 ("simple option not allowed in state declaration",
12203 -- Catch a case where missing parentheses around a state
12204 -- declaration with options cause a subsequent state
12205 -- declaration with options to be treated as an option.
12207 -- with Abstract_State
12208 -- (State_1 with ..., -- missing parentheses
12209 -- (State_2 with ...))
12211 elsif Nkind (Opt) = N_Extension_Aggregate then
12212 Missing_Parentheses := True;
12214 ("state declaration must be parenthesized",
12215 Ancestor_Part (State));
12217 -- Otherwise the option is malformed
12220 SPARK_Msg_N ("malformed option", Opt);
12226 -- Options External and Part_Of appear as component
12229 Opt := First (Component_Associations (State));
12230 while Present (Opt) loop
12231 Opt_Nam := First (Choices (Opt));
12233 if Nkind (Opt_Nam) = N_Identifier then
12234 if Chars (Opt_Nam) = Name_External then
12235 Analyze_External_Option (Opt);
12237 elsif Chars (Opt_Nam) = Name_Part_Of then
12238 Analyze_Part_Of_Option (Opt);
12241 SPARK_Msg_N ("invalid state option", Opt);
12244 SPARK_Msg_N ("invalid state option", Opt);
12250 -- Any other attempt to declare a state is illegal
12253 Malformed_State_Error (State);
12257 -- Guard against a junk state. In such cases no entity is
12258 -- generated and the subsequent checks cannot be applied.
12260 if Present (State_Id) then
12262 -- Verify whether the state does not introduce an illegal
12263 -- hidden state within a package subject to a null abstract
12266 Check_No_Hidden_State (State_Id);
12268 -- Check whether the lack of option Part_Of agrees with the
12269 -- placement of the abstract state with respect to the state
12272 if not Part_Of_Seen then
12273 Check_Missing_Part_Of (State_Id);
12276 -- Associate the state with its related package
12278 if No (Abstract_States (Pack_Id)) then
12279 Set_Abstract_States (Pack_Id, New_Elmt_List);
12282 Append_Elmt (State_Id, Abstract_States (Pack_Id));
12284 end Analyze_Abstract_State;
12286 ---------------------------
12287 -- Malformed_State_Error --
12288 ---------------------------
12290 procedure Malformed_State_Error (State : Node_Id) is
12292 Error_Msg_N ("malformed abstract state declaration", State);
12294 -- An abstract state with a simple option is being declared
12295 -- with "=>" rather than the legal "with". The state appears
12296 -- as a component association.
12298 if Nkind (State) = N_Component_Association then
12299 Error_Msg_N ("\use WITH to specify simple option", State);
12301 end Malformed_State_Error;
12305 Pack_Decl : Node_Id;
12306 Pack_Id : Entity_Id;
12310 -- Start of processing for Abstract_State
12314 Check_No_Identifiers;
12315 Check_Arg_Count (1);
12317 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
12319 if Nkind (Pack_Decl) not in
12320 N_Generic_Package_Declaration | N_Package_Declaration
12326 Pack_Id := Defining_Entity (Pack_Decl);
12328 -- A pragma that applies to a Ghost entity becomes Ghost for the
12329 -- purposes of legality checks and removal of ignored Ghost code.
12331 Mark_Ghost_Pragma (N, Pack_Id);
12332 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
12334 -- Chain the pragma on the contract for completeness
12336 Add_Contract_Item (N, Pack_Id);
12338 -- The legality checks of pragmas Abstract_State, Initializes, and
12339 -- Initial_Condition are affected by the SPARK mode in effect. In
12340 -- addition, these three pragmas are subject to an inherent order:
12342 -- 1) Abstract_State
12344 -- 3) Initial_Condition
12346 -- Analyze all these pragmas in the order outlined above
12348 Analyze_If_Present (Pragma_SPARK_Mode);
12349 States := Expression (Get_Argument (N, Pack_Id));
12351 -- Multiple non-null abstract states appear as an aggregate
12353 if Nkind (States) = N_Aggregate then
12354 State := First (Expressions (States));
12355 while Present (State) loop
12356 Analyze_Abstract_State (State, Pack_Id);
12360 -- An abstract state with a simple option is being illegaly
12361 -- declared with "=>" rather than "with". In this case the
12362 -- state declaration appears as a component association.
12364 if Present (Component_Associations (States)) then
12365 State := First (Component_Associations (States));
12366 while Present (State) loop
12367 Malformed_State_Error (State);
12372 -- Various forms of a single abstract state. Note that these may
12373 -- include malformed state declarations.
12376 Analyze_Abstract_State (States, Pack_Id);
12379 Analyze_If_Present (Pragma_Initializes);
12380 Analyze_If_Present (Pragma_Initial_Condition);
12381 end Abstract_State;
12389 -- Note: this pragma also has some specific processing in Par.Prag
12390 -- because we want to set the Ada version mode during parsing.
12392 when Pragma_Ada_83 =>
12394 Check_Arg_Count (0);
12396 -- We really should check unconditionally for proper configuration
12397 -- pragma placement, since we really don't want mixed Ada modes
12398 -- within a single unit, and the GNAT reference manual has always
12399 -- said this was a configuration pragma, but we did not check and
12400 -- are hesitant to add the check now.
12402 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
12403 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
12404 -- or Ada 2012 mode.
12406 if Ada_Version >= Ada_2005 then
12407 Check_Valid_Configuration_Pragma;
12410 -- Now set Ada 83 mode
12412 if Latest_Ada_Only then
12413 Error_Pragma ("??pragma% ignored");
12415 Ada_Version := Ada_83;
12416 Ada_Version_Explicit := Ada_83;
12417 Ada_Version_Pragma := N;
12426 -- Note: this pragma also has some specific processing in Par.Prag
12427 -- because we want to set the Ada 83 version mode during parsing.
12429 when Pragma_Ada_95 =>
12431 Check_Arg_Count (0);
12433 -- We really should check unconditionally for proper configuration
12434 -- pragma placement, since we really don't want mixed Ada modes
12435 -- within a single unit, and the GNAT reference manual has always
12436 -- said this was a configuration pragma, but we did not check and
12437 -- are hesitant to add the check now.
12439 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
12440 -- or Ada 95, so we must check if we are in Ada 2005 mode.
12442 if Ada_Version >= Ada_2005 then
12443 Check_Valid_Configuration_Pragma;
12446 -- Now set Ada 95 mode
12448 if Latest_Ada_Only then
12449 Error_Pragma ("??pragma% ignored");
12451 Ada_Version := Ada_95;
12452 Ada_Version_Explicit := Ada_95;
12453 Ada_Version_Pragma := N;
12456 ---------------------
12457 -- Ada_05/Ada_2005 --
12458 ---------------------
12461 -- pragma Ada_05 (LOCAL_NAME);
12463 -- pragma Ada_2005;
12464 -- pragma Ada_2005 (LOCAL_NAME):
12466 -- Note: these pragmas also have some specific processing in Par.Prag
12467 -- because we want to set the Ada 2005 version mode during parsing.
12469 -- The one argument form is used for managing the transition from
12470 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
12471 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
12472 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
12473 -- mode, a preference rule is established which does not choose
12474 -- such an entity unless it is unambiguously specified. This avoids
12475 -- extra subprograms marked this way from generating ambiguities in
12476 -- otherwise legal pre-Ada_2005 programs. The one argument form is
12477 -- intended for exclusive use in the GNAT run-time library.
12488 if Arg_Count = 1 then
12489 Check_Arg_Is_Local_Name (Arg1);
12490 E_Id := Get_Pragma_Arg (Arg1);
12492 if Etype (E_Id) = Any_Type then
12496 Set_Is_Ada_2005_Only (Entity (E_Id));
12497 Record_Rep_Item (Entity (E_Id), N);
12500 Check_Arg_Count (0);
12502 -- For Ada_2005 we unconditionally enforce the documented
12503 -- configuration pragma placement, since we do not want to
12504 -- tolerate mixed modes in a unit involving Ada 2005. That
12505 -- would cause real difficulties for those cases where there
12506 -- are incompatibilities between Ada 95 and Ada 2005.
12508 Check_Valid_Configuration_Pragma;
12510 -- Now set appropriate Ada mode
12512 if Latest_Ada_Only then
12513 Error_Pragma ("??pragma% ignored");
12515 Ada_Version := Ada_2005;
12516 Ada_Version_Explicit := Ada_2005;
12517 Ada_Version_Pragma := N;
12522 ---------------------
12523 -- Ada_12/Ada_2012 --
12524 ---------------------
12527 -- pragma Ada_12 (LOCAL_NAME);
12529 -- pragma Ada_2012;
12530 -- pragma Ada_2012 (LOCAL_NAME):
12532 -- Note: these pragmas also have some specific processing in Par.Prag
12533 -- because we want to set the Ada 2012 version mode during parsing.
12535 -- The one argument form is used for managing the transition from Ada
12536 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
12537 -- as Ada_2012 only, then referencing the entity in any pre-Ada_2012
12538 -- mode will generate a warning. In addition, in any pre-Ada_2012
12539 -- mode, a preference rule is established which does not choose
12540 -- such an entity unless it is unambiguously specified. This avoids
12541 -- extra subprograms marked this way from generating ambiguities in
12542 -- otherwise legal pre-Ada_2012 programs. The one argument form is
12543 -- intended for exclusive use in the GNAT run-time library.
12554 if Arg_Count = 1 then
12555 Check_Arg_Is_Local_Name (Arg1);
12556 E_Id := Get_Pragma_Arg (Arg1);
12558 if Etype (E_Id) = Any_Type then
12562 Set_Is_Ada_2012_Only (Entity (E_Id));
12563 Record_Rep_Item (Entity (E_Id), N);
12566 Check_Arg_Count (0);
12568 -- For Ada_2012 we unconditionally enforce the documented
12569 -- configuration pragma placement, since we do not want to
12570 -- tolerate mixed modes in a unit involving Ada 2012. That
12571 -- would cause real difficulties for those cases where there
12572 -- are incompatibilities between Ada 95 and Ada 2012. We could
12573 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
12575 Check_Valid_Configuration_Pragma;
12577 -- Now set appropriate Ada mode
12579 Ada_Version := Ada_2012;
12580 Ada_Version_Explicit := Ada_2012;
12581 Ada_Version_Pragma := N;
12589 -- pragma Ada_2020;
12591 -- Note: this pragma also has some specific processing in Par.Prag
12592 -- because we want to set the Ada 2020 version mode during parsing.
12594 when Pragma_Ada_2020 =>
12597 Check_Arg_Count (0);
12599 Check_Valid_Configuration_Pragma;
12601 -- Now set appropriate Ada mode
12603 Ada_Version := Ada_2020;
12604 Ada_Version_Explicit := Ada_2020;
12605 Ada_Version_Pragma := N;
12607 -------------------------------------
12608 -- Aggregate_Individually_Assign --
12609 -------------------------------------
12611 -- pragma Aggregate_Individually_Assign;
12613 when Pragma_Aggregate_Individually_Assign =>
12615 Check_Arg_Count (0);
12616 Check_Valid_Configuration_Pragma;
12617 Aggregate_Individually_Assign := True;
12619 ----------------------
12620 -- All_Calls_Remote --
12621 ----------------------
12623 -- pragma All_Calls_Remote [(library_package_NAME)];
12625 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
12626 Lib_Entity : Entity_Id;
12629 Check_Ada_83_Warning;
12630 Check_Valid_Library_Unit_Pragma;
12632 if Nkind (N) = N_Null_Statement then
12636 Lib_Entity := Find_Lib_Unit_Name;
12638 -- A pragma that applies to a Ghost entity becomes Ghost for the
12639 -- purposes of legality checks and removal of ignored Ghost code.
12641 Mark_Ghost_Pragma (N, Lib_Entity);
12643 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
12645 if Present (Lib_Entity) and then not Debug_Flag_U then
12646 if not Is_Remote_Call_Interface (Lib_Entity) then
12647 Error_Pragma ("pragma% only apply to rci unit");
12649 -- Set flag for entity of the library unit
12652 Set_Has_All_Calls_Remote (Lib_Entity);
12655 end All_Calls_Remote;
12657 ---------------------------
12658 -- Allow_Integer_Address --
12659 ---------------------------
12661 -- pragma Allow_Integer_Address;
12663 when Pragma_Allow_Integer_Address =>
12665 Check_Valid_Configuration_Pragma;
12666 Check_Arg_Count (0);
12668 -- If Address is a private type, then set the flag to allow
12669 -- integer address values. If Address is not private, then this
12670 -- pragma has no purpose, so it is simply ignored. Not clear if
12671 -- there are any such targets now.
12673 if Opt.Address_Is_Private then
12674 Opt.Allow_Integer_Address := True;
12682 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
12683 -- ARG ::= NAME | EXPRESSION
12685 -- The first two arguments are by convention intended to refer to an
12686 -- external tool and a tool-specific function. These arguments are
12689 when Pragma_Annotate => Annotate : declare
12694 --------------------------
12695 -- Inferred_String_Type --
12696 --------------------------
12698 function Preferred_String_Type (Expr : Node_Id) return Entity_Id;
12699 -- Infer the type to use for a string literal or a concatentation
12700 -- of operands whose types can be inferred. For such expressions,
12701 -- returns the "narrowest" of the three predefined string types
12702 -- that can represent the characters occurring in the expression.
12703 -- For other expressions, returns Empty.
12705 function Preferred_String_Type (Expr : Node_Id) return Entity_Id is
12707 case Nkind (Expr) is
12708 when N_String_Literal =>
12709 if Has_Wide_Wide_Character (Expr) then
12710 return Standard_Wide_Wide_String;
12711 elsif Has_Wide_Character (Expr) then
12712 return Standard_Wide_String;
12714 return Standard_String;
12717 when N_Op_Concat =>
12719 L_Type : constant Entity_Id
12720 := Preferred_String_Type (Left_Opnd (Expr));
12721 R_Type : constant Entity_Id
12722 := Preferred_String_Type (Right_Opnd (Expr));
12724 Type_Table : constant array (1 .. 4) of Entity_Id
12726 Standard_Wide_Wide_String,
12727 Standard_Wide_String,
12730 for Idx in Type_Table'Range loop
12731 if (L_Type = Type_Table (Idx)) or
12732 (R_Type = Type_Table (Idx))
12734 return Type_Table (Idx);
12737 raise Program_Error;
12743 end Preferred_String_Type;
12746 Check_At_Least_N_Arguments (1);
12748 Nam_Arg := Last (Pragma_Argument_Associations (N));
12750 -- Determine whether the last argument is "Entity => local_NAME"
12751 -- and if it is, perform the required semantic checks. Remove the
12752 -- argument from further processing.
12754 if Nkind (Nam_Arg) = N_Pragma_Argument_Association
12755 and then Chars (Nam_Arg) = Name_Entity
12757 Check_Arg_Is_Local_Name (Nam_Arg);
12758 Arg_Count := Arg_Count - 1;
12760 -- A pragma that applies to a Ghost entity becomes Ghost for
12761 -- the purposes of legality checks and removal of ignored Ghost
12764 if Is_Entity_Name (Get_Pragma_Arg (Nam_Arg))
12765 and then Present (Entity (Get_Pragma_Arg (Nam_Arg)))
12767 Mark_Ghost_Pragma (N, Entity (Get_Pragma_Arg (Nam_Arg)));
12770 -- Not allowed in compiler units (bootstrap issues)
12772 Check_Compiler_Unit ("Entity for pragma Annotate", N);
12775 -- Continue the processing with last argument removed for now
12777 Check_Arg_Is_Identifier (Arg1);
12778 Check_No_Identifiers;
12781 -- The second parameter is optional, it is never analyzed
12786 -- Otherwise there is a second parameter
12789 -- The second parameter must be an identifier
12791 Check_Arg_Is_Identifier (Arg2);
12793 -- Process the remaining parameters (if any)
12795 Arg := Next (Arg2);
12796 while Present (Arg) loop
12797 Expr := Get_Pragma_Arg (Arg);
12800 if Is_Entity_Name (Expr) then
12803 -- For string literals and concatenations of string literals
12804 -- we assume Standard_String as the type, unless the string
12805 -- contains wide or wide_wide characters.
12807 elsif Present (Preferred_String_Type (Expr)) then
12808 Resolve (Expr, Preferred_String_Type (Expr));
12810 elsif Is_Overloaded (Expr) then
12811 Error_Pragma_Arg ("ambiguous argument for pragma%", Expr);
12822 -------------------------------------------------
12823 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
12824 -------------------------------------------------
12827 -- ( [Check => ] Boolean_EXPRESSION
12828 -- [, [Message =>] Static_String_EXPRESSION]);
12830 -- pragma Assert_And_Cut
12831 -- ( [Check => ] Boolean_EXPRESSION
12832 -- [, [Message =>] Static_String_EXPRESSION]);
12835 -- ( [Check => ] Boolean_EXPRESSION
12836 -- [, [Message =>] Static_String_EXPRESSION]);
12838 -- pragma Loop_Invariant
12839 -- ( [Check => ] Boolean_EXPRESSION
12840 -- [, [Message =>] Static_String_EXPRESSION]);
12843 | Pragma_Assert_And_Cut
12845 | Pragma_Loop_Invariant
12848 function Contains_Loop_Entry (Expr : Node_Id) return Boolean;
12849 -- Determine whether expression Expr contains a Loop_Entry
12850 -- attribute reference.
12852 -------------------------
12853 -- Contains_Loop_Entry --
12854 -------------------------
12856 function Contains_Loop_Entry (Expr : Node_Id) return Boolean is
12857 Has_Loop_Entry : Boolean := False;
12859 function Process (N : Node_Id) return Traverse_Result;
12860 -- Process function for traversal to look for Loop_Entry
12866 function Process (N : Node_Id) return Traverse_Result is
12868 if Nkind (N) = N_Attribute_Reference
12869 and then Attribute_Name (N) = Name_Loop_Entry
12871 Has_Loop_Entry := True;
12878 procedure Traverse is new Traverse_Proc (Process);
12880 -- Start of processing for Contains_Loop_Entry
12884 return Has_Loop_Entry;
12885 end Contains_Loop_Entry;
12890 New_Args : List_Id;
12892 -- Start of processing for Assert
12895 -- Assert is an Ada 2005 RM-defined pragma
12897 if Prag_Id = Pragma_Assert then
12900 -- The remaining ones are GNAT pragmas
12906 Check_At_Least_N_Arguments (1);
12907 Check_At_Most_N_Arguments (2);
12908 Check_Arg_Order ((Name_Check, Name_Message));
12909 Check_Optional_Identifier (Arg1, Name_Check);
12910 Expr := Get_Pragma_Arg (Arg1);
12912 -- Special processing for Loop_Invariant, Loop_Variant or for
12913 -- other cases where a Loop_Entry attribute is present. If the
12914 -- assertion pragma contains attribute Loop_Entry, ensure that
12915 -- the related pragma is within a loop.
12917 if Prag_Id = Pragma_Loop_Invariant
12918 or else Prag_Id = Pragma_Loop_Variant
12919 or else Contains_Loop_Entry (Expr)
12921 Check_Loop_Pragma_Placement;
12923 -- Perform preanalysis to deal with embedded Loop_Entry
12926 Preanalyze_Assert_Expression (Expr, Any_Boolean);
12929 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
12930 -- a corresponding Check pragma:
12932 -- pragma Check (name, condition [, msg]);
12934 -- Where name is the identifier matching the pragma name. So
12935 -- rewrite pragma in this manner, transfer the message argument
12936 -- if present, and analyze the result
12938 -- Note: When dealing with a semantically analyzed tree, the
12939 -- information that a Check node N corresponds to a source Assert,
12940 -- Assume, or Assert_And_Cut pragma can be retrieved from the
12941 -- pragma kind of Original_Node(N).
12943 New_Args := New_List (
12944 Make_Pragma_Argument_Association (Loc,
12945 Expression => Make_Identifier (Loc, Pname)),
12946 Make_Pragma_Argument_Association (Sloc (Expr),
12947 Expression => Expr));
12949 if Arg_Count > 1 then
12950 Check_Optional_Identifier (Arg2, Name_Message);
12952 -- Provide semantic annotations for optional argument, for
12953 -- ASIS use, before rewriting.
12954 -- Is this still needed???
12956 Preanalyze_And_Resolve (Expression (Arg2), Standard_String);
12957 Append_To (New_Args, New_Copy_Tree (Arg2));
12960 -- Rewrite as Check pragma
12964 Chars => Name_Check,
12965 Pragma_Argument_Associations => New_Args));
12970 ----------------------
12971 -- Assertion_Policy --
12972 ----------------------
12974 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
12976 -- The following form is Ada 2012 only, but we allow it in all modes
12978 -- Pragma Assertion_Policy (
12979 -- ASSERTION_KIND => POLICY_IDENTIFIER
12980 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
12982 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
12984 -- RM_ASSERTION_KIND ::= Assert |
12985 -- Static_Predicate |
12986 -- Dynamic_Predicate |
12991 -- Type_Invariant |
12992 -- Type_Invariant'Class
12994 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
12996 -- Contract_Cases |
12998 -- Default_Initial_Condition |
13000 -- Initial_Condition |
13001 -- Loop_Invariant |
13007 -- Statement_Assertions
13009 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
13010 -- ID_ASSERTION_KIND list contains implementation-defined additions
13011 -- recognized by GNAT. The effect is to control the behavior of
13012 -- identically named aspects and pragmas, depending on the specified
13013 -- policy identifier:
13015 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
13017 -- Note: Check and Ignore are language-defined. Disable is a GNAT
13018 -- implementation-defined addition that results in totally ignoring
13019 -- the corresponding assertion. If Disable is specified, then the
13020 -- argument of the assertion is not even analyzed. This is useful
13021 -- when the aspect/pragma argument references entities in a with'ed
13022 -- package that is replaced by a dummy package in the final build.
13024 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
13025 -- and Type_Invariant'Class were recognized by the parser and
13026 -- transformed into references to the special internal identifiers
13027 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
13028 -- processing is required here.
13030 when Pragma_Assertion_Policy => Assertion_Policy : declare
13031 procedure Resolve_Suppressible (Policy : Node_Id);
13032 -- Converts the assertion policy 'Suppressible' to either Check or
13033 -- Ignore based on whether checks are suppressed via -gnatp.
13035 --------------------------
13036 -- Resolve_Suppressible --
13037 --------------------------
13039 procedure Resolve_Suppressible (Policy : Node_Id) is
13040 Arg : constant Node_Id := Get_Pragma_Arg (Policy);
13044 -- Transform policy argument Suppressible into either Ignore or
13045 -- Check depending on whether checks are enabled or suppressed.
13047 if Chars (Arg) = Name_Suppressible then
13048 if Suppress_Checks then
13049 Nam := Name_Ignore;
13054 Rewrite (Arg, Make_Identifier (Sloc (Arg), Nam));
13056 end Resolve_Suppressible;
13068 -- This can always appear as a configuration pragma
13070 if Is_Configuration_Pragma then
13073 -- It can also appear in a declarative part or package spec in Ada
13074 -- 2012 mode. We allow this in other modes, but in that case we
13075 -- consider that we have an Ada 2012 pragma on our hands.
13078 Check_Is_In_Decl_Part_Or_Package_Spec;
13082 -- One argument case with no identifier (first form above)
13085 and then (Nkind (Arg1) /= N_Pragma_Argument_Association
13086 or else Chars (Arg1) = No_Name)
13088 Check_Arg_Is_One_Of (Arg1,
13089 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
13091 Resolve_Suppressible (Arg1);
13093 -- Treat one argument Assertion_Policy as equivalent to:
13095 -- pragma Check_Policy (Assertion, policy)
13097 -- So rewrite pragma in that manner and link on to the chain
13098 -- of Check_Policy pragmas, marking the pragma as analyzed.
13100 Policy := Get_Pragma_Arg (Arg1);
13104 Chars => Name_Check_Policy,
13105 Pragma_Argument_Associations => New_List (
13106 Make_Pragma_Argument_Association (Loc,
13107 Expression => Make_Identifier (Loc, Name_Assertion)),
13109 Make_Pragma_Argument_Association (Loc,
13111 Make_Identifier (Sloc (Policy), Chars (Policy))))));
13114 -- Here if we have two or more arguments
13117 Check_At_Least_N_Arguments (1);
13120 -- Loop through arguments
13123 while Present (Arg) loop
13124 LocP := Sloc (Arg);
13126 -- Kind must be specified
13128 if Nkind (Arg) /= N_Pragma_Argument_Association
13129 or else Chars (Arg) = No_Name
13132 ("missing assertion kind for pragma%", Arg);
13135 -- Check Kind and Policy have allowed forms
13137 Kind := Chars (Arg);
13138 Policy := Get_Pragma_Arg (Arg);
13140 if not Is_Valid_Assertion_Kind (Kind) then
13142 ("invalid assertion kind for pragma%", Arg);
13145 Check_Arg_Is_One_Of (Arg,
13146 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
13148 Resolve_Suppressible (Arg);
13150 if Kind = Name_Ghost then
13152 -- The Ghost policy must be either Check or Ignore
13153 -- (SPARK RM 6.9(6)).
13155 if Chars (Policy) not in Name_Check | Name_Ignore then
13157 ("argument of pragma % Ghost must be Check or "
13158 & "Ignore", Policy);
13161 -- Pragma Assertion_Policy specifying a Ghost policy
13162 -- cannot occur within a Ghost subprogram or package
13163 -- (SPARK RM 6.9(14)).
13165 if Ghost_Mode > None then
13167 ("pragma % cannot appear within ghost subprogram or "
13172 -- Rewrite the Assertion_Policy pragma as a series of
13173 -- Check_Policy pragmas of the form:
13175 -- Check_Policy (Kind, Policy);
13177 -- Note: the insertion of the pragmas cannot be done with
13178 -- Insert_Action because in the configuration case, there
13179 -- are no scopes on the scope stack and the mechanism will
13182 Insert_Before_And_Analyze (N,
13184 Chars => Name_Check_Policy,
13185 Pragma_Argument_Associations => New_List (
13186 Make_Pragma_Argument_Association (LocP,
13187 Expression => Make_Identifier (LocP, Kind)),
13188 Make_Pragma_Argument_Association (LocP,
13189 Expression => Policy))));
13194 -- Rewrite the Assertion_Policy pragma as null since we have
13195 -- now inserted all the equivalent Check pragmas.
13197 Rewrite (N, Make_Null_Statement (Loc));
13200 end Assertion_Policy;
13202 ------------------------------
13203 -- Assume_No_Invalid_Values --
13204 ------------------------------
13206 -- pragma Assume_No_Invalid_Values (On | Off);
13208 when Pragma_Assume_No_Invalid_Values =>
13210 Check_Valid_Configuration_Pragma;
13211 Check_Arg_Count (1);
13212 Check_No_Identifiers;
13213 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
13215 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
13216 Assume_No_Invalid_Values := True;
13218 Assume_No_Invalid_Values := False;
13221 --------------------------
13222 -- Attribute_Definition --
13223 --------------------------
13225 -- pragma Attribute_Definition
13226 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
13227 -- [Entity =>] LOCAL_NAME,
13228 -- [Expression =>] EXPRESSION | NAME);
13230 when Pragma_Attribute_Definition => Attribute_Definition : declare
13231 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
13236 Check_Arg_Count (3);
13237 Check_Optional_Identifier (Arg1, "attribute");
13238 Check_Optional_Identifier (Arg2, "entity");
13239 Check_Optional_Identifier (Arg3, "expression");
13241 if Nkind (Attribute_Designator) /= N_Identifier then
13242 Error_Msg_N ("attribute name expected", Attribute_Designator);
13246 Check_Arg_Is_Local_Name (Arg2);
13248 -- If the attribute is not recognized, then issue a warning (not
13249 -- an error), and ignore the pragma.
13251 Aname := Chars (Attribute_Designator);
13253 if not Is_Attribute_Name (Aname) then
13254 Bad_Attribute (Attribute_Designator, Aname, Warn => True);
13258 -- Otherwise, rewrite the pragma as an attribute definition clause
13261 Make_Attribute_Definition_Clause (Loc,
13262 Name => Get_Pragma_Arg (Arg2),
13264 Expression => Get_Pragma_Arg (Arg3)));
13266 end Attribute_Definition;
13268 ------------------------------------------------------------------
13269 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
13271 ------------------------------------------------------------------
13273 -- pragma Async_Readers [ (boolean_EXPRESSION) ];
13274 -- pragma Async_Writers [ (boolean_EXPRESSION) ];
13275 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
13276 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
13277 -- pragma No_Caching [ (boolean_EXPRESSION) ];
13279 when Pragma_Async_Readers
13280 | Pragma_Async_Writers
13281 | Pragma_Effective_Reads
13282 | Pragma_Effective_Writes
13283 | Pragma_No_Caching
13285 Async_Effective : declare
13286 Obj_Or_Type_Decl : Node_Id;
13287 Obj_Or_Type_Id : Entity_Id;
13290 Check_No_Identifiers;
13291 Check_At_Most_N_Arguments (1);
13293 Obj_Or_Type_Decl := Find_Related_Context (N, Do_Checks => True);
13295 -- Pragma must apply to a object declaration or to a type
13296 -- declaration (only the former in the No_Caching case).
13297 -- Original_Node is necessary to account for untagged derived
13298 -- types that are rewritten as subtypes of their
13299 -- respective root types.
13301 if Nkind (Obj_Or_Type_Decl) /= N_Object_Declaration then
13302 if Prag_Id = Pragma_No_Caching
13303 or else Nkind (Original_Node (Obj_Or_Type_Decl)) not in
13304 N_Full_Type_Declaration |
13305 N_Private_Type_Declaration |
13306 N_Formal_Type_Declaration |
13307 N_Task_Type_Declaration |
13308 N_Protected_Type_Declaration
13315 Obj_Or_Type_Id := Defining_Entity (Obj_Or_Type_Decl);
13317 -- Perform minimal verification to ensure that the argument is at
13318 -- least a variable or a type. Subsequent finer grained checks
13319 -- will be done at the end of the declarative region that
13320 -- contains the pragma.
13322 if Ekind (Obj_Or_Type_Id) = E_Variable
13323 or else Is_Type (Obj_Or_Type_Id)
13326 -- In the case of a type, pragma is a type-related
13327 -- representation item and so requires checks common to
13328 -- all type-related representation items.
13330 if Is_Type (Obj_Or_Type_Id)
13331 and then Rep_Item_Too_Late (Obj_Or_Type_Id, N)
13336 -- A pragma that applies to a Ghost entity becomes Ghost for
13337 -- the purposes of legality checks and removal of ignored Ghost
13340 Mark_Ghost_Pragma (N, Obj_Or_Type_Id);
13342 -- Chain the pragma on the contract for further processing by
13343 -- Analyze_External_Property_In_Decl_Part.
13345 Add_Contract_Item (N, Obj_Or_Type_Id);
13347 -- Analyze the Boolean expression (if any)
13349 if Present (Arg1) then
13350 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
13353 -- Otherwise the external property applies to a constant
13357 ("pragma % must apply to a volatile type or object");
13359 end Async_Effective;
13365 -- pragma Asynchronous (LOCAL_NAME);
13367 when Pragma_Asynchronous => Asynchronous : declare
13370 Formal : Entity_Id;
13375 procedure Process_Async_Pragma;
13376 -- Common processing for procedure and access-to-procedure case
13378 --------------------------
13379 -- Process_Async_Pragma --
13380 --------------------------
13382 procedure Process_Async_Pragma is
13385 Set_Is_Asynchronous (Nm);
13389 -- The formals should be of mode IN (RM E.4.1(6))
13392 while Present (S) loop
13393 Formal := Defining_Identifier (S);
13395 if Nkind (Formal) = N_Defining_Identifier
13396 and then Ekind (Formal) /= E_In_Parameter
13399 ("pragma% procedure can only have IN parameter",
13406 Set_Is_Asynchronous (Nm);
13407 end Process_Async_Pragma;
13409 -- Start of processing for pragma Asynchronous
13412 Check_Ada_83_Warning;
13413 Check_No_Identifiers;
13414 Check_Arg_Count (1);
13415 Check_Arg_Is_Local_Name (Arg1);
13417 if Debug_Flag_U then
13421 C_Ent := Cunit_Entity (Current_Sem_Unit);
13422 Analyze (Get_Pragma_Arg (Arg1));
13423 Nm := Entity (Get_Pragma_Arg (Arg1));
13425 -- A pragma that applies to a Ghost entity becomes Ghost for the
13426 -- purposes of legality checks and removal of ignored Ghost code.
13428 Mark_Ghost_Pragma (N, Nm);
13430 if not Is_Remote_Call_Interface (C_Ent)
13431 and then not Is_Remote_Types (C_Ent)
13433 -- This pragma should only appear in an RCI or Remote Types
13434 -- unit (RM E.4.1(4)).
13437 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
13440 if Ekind (Nm) = E_Procedure
13441 and then Nkind (Parent (Nm)) = N_Procedure_Specification
13443 if not Is_Remote_Call_Interface (Nm) then
13445 ("pragma% cannot be applied on non-remote procedure",
13449 L := Parameter_Specifications (Parent (Nm));
13450 Process_Async_Pragma;
13453 elsif Ekind (Nm) = E_Function then
13455 ("pragma% cannot be applied to function", Arg1);
13457 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
13458 if Is_Record_Type (Nm) then
13460 -- A record type that is the Equivalent_Type for a remote
13461 -- access-to-subprogram type.
13463 Decl := Declaration_Node (Corresponding_Remote_Type (Nm));
13466 -- A non-expanded RAS type (distribution is not enabled)
13468 Decl := Declaration_Node (Nm);
13471 if Nkind (Decl) = N_Full_Type_Declaration
13472 and then Nkind (Type_Definition (Decl)) =
13473 N_Access_Procedure_Definition
13475 L := Parameter_Specifications (Type_Definition (Decl));
13476 Process_Async_Pragma;
13478 if Is_Asynchronous (Nm)
13479 and then Expander_Active
13480 and then Get_PCS_Name /= Name_No_DSA
13482 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
13487 ("pragma% cannot reference access-to-function type",
13491 -- Only other possibility is Access-to-class-wide type
13493 elsif Is_Access_Type (Nm)
13494 and then Is_Class_Wide_Type (Designated_Type (Nm))
13496 Check_First_Subtype (Arg1);
13497 Set_Is_Asynchronous (Nm);
13498 if Expander_Active then
13499 RACW_Type_Is_Asynchronous (Nm);
13503 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
13511 -- pragma Atomic (LOCAL_NAME);
13513 when Pragma_Atomic =>
13514 Process_Atomic_Independent_Shared_Volatile;
13516 -----------------------
13517 -- Atomic_Components --
13518 -----------------------
13520 -- pragma Atomic_Components (array_LOCAL_NAME);
13522 -- This processing is shared by Volatile_Components
13524 when Pragma_Atomic_Components
13525 | Pragma_Volatile_Components
13527 Atomic_Components : declare
13533 Check_Ada_83_Warning;
13534 Check_No_Identifiers;
13535 Check_Arg_Count (1);
13536 Check_Arg_Is_Local_Name (Arg1);
13537 E_Id := Get_Pragma_Arg (Arg1);
13539 if Etype (E_Id) = Any_Type then
13543 E := Entity (E_Id);
13545 -- A pragma that applies to a Ghost entity becomes Ghost for the
13546 -- purposes of legality checks and removal of ignored Ghost code.
13548 Mark_Ghost_Pragma (N, E);
13549 Check_Duplicate_Pragma (E);
13551 if Rep_Item_Too_Early (E, N)
13553 Rep_Item_Too_Late (E, N)
13558 D := Declaration_Node (E);
13560 if (Nkind (D) = N_Full_Type_Declaration and then Is_Array_Type (E))
13562 (Nkind (D) = N_Object_Declaration
13563 and then Ekind (E) in E_Constant | E_Variable
13564 and then Nkind (Object_Definition (D)) =
13565 N_Constrained_Array_Definition)
13567 (Ada_Version >= Ada_2020
13568 and then Nkind (D) = N_Formal_Type_Declaration)
13570 -- The flag is set on the base type, or on the object
13572 if Nkind (D) = N_Full_Type_Declaration then
13573 E := Base_Type (E);
13576 -- Atomic implies both Independent and Volatile
13578 if Prag_Id = Pragma_Atomic_Components then
13579 if Ada_Version >= Ada_2020 then
13581 (Component_Type (Etype (E)), VFA => False);
13584 Set_Has_Atomic_Components (E);
13585 Set_Has_Independent_Components (E);
13588 Set_Has_Volatile_Components (E);
13591 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
13593 end Atomic_Components;
13595 --------------------
13596 -- Attach_Handler --
13597 --------------------
13599 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
13601 when Pragma_Attach_Handler =>
13602 Check_Ada_83_Warning;
13603 Check_No_Identifiers;
13604 Check_Arg_Count (2);
13606 if No_Run_Time_Mode then
13607 Error_Msg_CRT ("Attach_Handler pragma", N);
13609 Check_Interrupt_Or_Attach_Handler;
13611 -- The expression that designates the attribute may depend on a
13612 -- discriminant, and is therefore a per-object expression, to
13613 -- be expanded in the init proc. If expansion is enabled, then
13614 -- perform semantic checks on a copy only.
13619 Parg2 : constant Node_Id := Get_Pragma_Arg (Arg2);
13622 -- In Relaxed_RM_Semantics mode, we allow any static
13623 -- integer value, for compatibility with other compilers.
13625 if Relaxed_RM_Semantics
13626 and then Nkind (Parg2) = N_Integer_Literal
13628 Typ := Standard_Integer;
13630 Typ := RTE (RE_Interrupt_ID);
13633 if Expander_Active then
13634 Temp := New_Copy_Tree (Parg2);
13635 Set_Parent (Temp, N);
13636 Preanalyze_And_Resolve (Temp, Typ);
13639 Resolve (Parg2, Typ);
13643 Process_Interrupt_Or_Attach_Handler;
13646 --------------------
13647 -- C_Pass_By_Copy --
13648 --------------------
13650 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
13652 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
13658 Check_Valid_Configuration_Pragma;
13659 Check_Arg_Count (1);
13660 Check_Optional_Identifier (Arg1, "max_size");
13662 Arg := Get_Pragma_Arg (Arg1);
13663 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
13665 Val := Expr_Value (Arg);
13669 ("maximum size for pragma% must be positive", Arg1);
13671 elsif UI_Is_In_Int_Range (Val) then
13672 Default_C_Record_Mechanism := UI_To_Int (Val);
13674 -- If a giant value is given, Int'Last will do well enough.
13675 -- If sometime someone complains that a record larger than
13676 -- two gigabytes is not copied, we will worry about it then.
13679 Default_C_Record_Mechanism := Mechanism_Type'Last;
13681 end C_Pass_By_Copy;
13687 -- pragma Check ([Name =>] CHECK_KIND,
13688 -- [Check =>] Boolean_EXPRESSION
13689 -- [,[Message =>] String_EXPRESSION]);
13691 -- CHECK_KIND ::= IDENTIFIER |
13694 -- Invariant'Class |
13695 -- Type_Invariant'Class
13697 -- The identifiers Assertions and Statement_Assertions are not
13698 -- allowed, since they have special meaning for Check_Policy.
13700 -- WARNING: The code below manages Ghost regions. Return statements
13701 -- must be replaced by gotos which jump to the end of the code and
13702 -- restore the Ghost mode.
13704 when Pragma_Check => Check : declare
13705 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
13706 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
13707 -- Save the Ghost-related attributes to restore on exit
13713 pragma Warnings (Off, Str);
13716 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
13717 -- the mode now to ensure that any nodes generated during analysis
13718 -- and expansion are marked as Ghost.
13720 Set_Ghost_Mode (N);
13723 Check_At_Least_N_Arguments (2);
13724 Check_At_Most_N_Arguments (3);
13725 Check_Optional_Identifier (Arg1, Name_Name);
13726 Check_Optional_Identifier (Arg2, Name_Check);
13728 if Arg_Count = 3 then
13729 Check_Optional_Identifier (Arg3, Name_Message);
13730 Str := Get_Pragma_Arg (Arg3);
13733 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
13734 Check_Arg_Is_Identifier (Arg1);
13735 Cname := Chars (Get_Pragma_Arg (Arg1));
13737 -- Check forbidden name Assertions or Statement_Assertions
13740 when Name_Assertions =>
13742 ("""Assertions"" is not allowed as a check kind for "
13743 & "pragma%", Arg1);
13745 when Name_Statement_Assertions =>
13747 ("""Statement_Assertions"" is not allowed as a check kind "
13748 & "for pragma%", Arg1);
13754 -- Check applicable policy. We skip this if Checked/Ignored status
13755 -- is already set (e.g. in the case of a pragma from an aspect).
13757 if Is_Checked (N) or else Is_Ignored (N) then
13760 -- For a non-source pragma that is a rewriting of another pragma,
13761 -- copy the Is_Checked/Ignored status from the rewritten pragma.
13763 elsif Is_Rewrite_Substitution (N)
13764 and then Nkind (Original_Node (N)) = N_Pragma
13766 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
13767 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
13769 -- Otherwise query the applicable policy at this point
13772 case Check_Kind (Cname) is
13773 when Name_Ignore =>
13774 Set_Is_Ignored (N, True);
13775 Set_Is_Checked (N, False);
13778 Set_Is_Ignored (N, False);
13779 Set_Is_Checked (N, True);
13781 -- For disable, rewrite pragma as null statement and skip
13782 -- rest of the analysis of the pragma.
13784 when Name_Disable =>
13785 Rewrite (N, Make_Null_Statement (Loc));
13789 -- No other possibilities
13792 raise Program_Error;
13796 -- If check kind was not Disable, then continue pragma analysis
13798 Expr := Get_Pragma_Arg (Arg2);
13800 -- Mark the pragma (or, if rewritten from an aspect, the original
13801 -- aspect) as enabled. Nothing to do for an internally generated
13802 -- check for a dynamic predicate.
13805 and then not Split_PPC (N)
13806 and then Cname /= Name_Dynamic_Predicate
13808 Set_SCO_Pragma_Enabled (Loc);
13811 -- Deal with analyzing the string argument. If checks are not
13812 -- on we don't want any expansion (since such expansion would
13813 -- not get properly deleted) but we do want to analyze (to get
13814 -- proper references). The Preanalyze_And_Resolve routine does
13815 -- just what we want. Ditto if pragma is active, because it will
13816 -- be rewritten as an if-statement whose analysis will complete
13817 -- analysis and expansion of the string message. This makes a
13818 -- difference in the unusual case where the expression for the
13819 -- string may have a side effect, such as raising an exception.
13820 -- This is mandated by RM 11.4.2, which specifies that the string
13821 -- expression is only evaluated if the check fails and
13822 -- Assertion_Error is to be raised.
13824 if Arg_Count = 3 then
13825 Preanalyze_And_Resolve (Str, Standard_String);
13828 -- Now you might think we could just do the same with the Boolean
13829 -- expression if checks are off (and expansion is on) and then
13830 -- rewrite the check as a null statement. This would work but we
13831 -- would lose the useful warnings about an assertion being bound
13832 -- to fail even if assertions are turned off.
13834 -- So instead we wrap the boolean expression in an if statement
13835 -- that looks like:
13837 -- if False and then condition then
13841 -- The reason we do this rewriting during semantic analysis rather
13842 -- than as part of normal expansion is that we cannot analyze and
13843 -- expand the code for the boolean expression directly, or it may
13844 -- cause insertion of actions that would escape the attempt to
13845 -- suppress the check code.
13847 -- Note that the Sloc for the if statement corresponds to the
13848 -- argument condition, not the pragma itself. The reason for
13849 -- this is that we may generate a warning if the condition is
13850 -- False at compile time, and we do not want to delete this
13851 -- warning when we delete the if statement.
13853 if Expander_Active and Is_Ignored (N) then
13854 Eloc := Sloc (Expr);
13857 Make_If_Statement (Eloc,
13859 Make_And_Then (Eloc,
13860 Left_Opnd => Make_Identifier (Eloc, Name_False),
13861 Right_Opnd => Expr),
13862 Then_Statements => New_List (
13863 Make_Null_Statement (Eloc))));
13865 -- Now go ahead and analyze the if statement
13867 In_Assertion_Expr := In_Assertion_Expr + 1;
13869 -- One rather special treatment. If we are now in Eliminated
13870 -- overflow mode, then suppress overflow checking since we do
13871 -- not want to drag in the bignum stuff if we are in Ignore
13872 -- mode anyway. This is particularly important if we are using
13873 -- a configurable run time that does not support bignum ops.
13875 if Scope_Suppress.Overflow_Mode_Assertions = Eliminated then
13877 Svo : constant Boolean :=
13878 Scope_Suppress.Suppress (Overflow_Check);
13880 Scope_Suppress.Overflow_Mode_Assertions := Strict;
13881 Scope_Suppress.Suppress (Overflow_Check) := True;
13883 Scope_Suppress.Suppress (Overflow_Check) := Svo;
13884 Scope_Suppress.Overflow_Mode_Assertions := Eliminated;
13887 -- Not that special case
13893 -- All done with this check
13895 In_Assertion_Expr := In_Assertion_Expr - 1;
13897 -- Check is active or expansion not active. In these cases we can
13898 -- just go ahead and analyze the boolean with no worries.
13901 In_Assertion_Expr := In_Assertion_Expr + 1;
13902 Analyze_And_Resolve (Expr, Any_Boolean);
13903 In_Assertion_Expr := In_Assertion_Expr - 1;
13906 Restore_Ghost_Region (Saved_GM, Saved_IGR);
13909 --------------------------
13910 -- Check_Float_Overflow --
13911 --------------------------
13913 -- pragma Check_Float_Overflow;
13915 when Pragma_Check_Float_Overflow =>
13917 Check_Valid_Configuration_Pragma;
13918 Check_Arg_Count (0);
13919 Check_Float_Overflow := not Machine_Overflows_On_Target;
13925 -- pragma Check_Name (check_IDENTIFIER);
13927 when Pragma_Check_Name =>
13929 Check_No_Identifiers;
13930 Check_Valid_Configuration_Pragma;
13931 Check_Arg_Count (1);
13932 Check_Arg_Is_Identifier (Arg1);
13935 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
13938 for J in Check_Names.First .. Check_Names.Last loop
13939 if Check_Names.Table (J) = Nam then
13944 Check_Names.Append (Nam);
13951 -- This is the old style syntax, which is still allowed in all modes:
13953 -- pragma Check_Policy ([Name =>] CHECK_KIND
13954 -- [Policy =>] POLICY_IDENTIFIER);
13956 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
13958 -- CHECK_KIND ::= IDENTIFIER |
13961 -- Type_Invariant'Class |
13964 -- This is the new style syntax, compatible with Assertion_Policy
13965 -- and also allowed in all modes.
13967 -- Pragma Check_Policy (
13968 -- CHECK_KIND => POLICY_IDENTIFIER
13969 -- {, CHECK_KIND => POLICY_IDENTIFIER});
13971 -- Note: the identifiers Name and Policy are not allowed as
13972 -- Check_Kind values. This avoids ambiguities between the old and
13973 -- new form syntax.
13975 when Pragma_Check_Policy => Check_Policy : declare
13980 Check_At_Least_N_Arguments (1);
13982 -- A Check_Policy pragma can appear either as a configuration
13983 -- pragma, or in a declarative part or a package spec (see RM
13984 -- 11.5(5) for rules for Suppress/Unsuppress which are also
13985 -- followed for Check_Policy).
13987 if not Is_Configuration_Pragma then
13988 Check_Is_In_Decl_Part_Or_Package_Spec;
13991 -- Figure out if we have the old or new syntax. We have the
13992 -- old syntax if the first argument has no identifier, or the
13993 -- identifier is Name.
13995 if Nkind (Arg1) /= N_Pragma_Argument_Association
13996 or else Chars (Arg1) in No_Name | Name_Name
14000 Check_Arg_Count (2);
14001 Check_Optional_Identifier (Arg1, Name_Name);
14002 Kind := Get_Pragma_Arg (Arg1);
14003 Rewrite_Assertion_Kind (Kind,
14004 From_Policy => Comes_From_Source (N));
14005 Check_Arg_Is_Identifier (Arg1);
14007 -- Check forbidden check kind
14009 if Chars (Kind) in Name_Name | Name_Policy then
14010 Error_Msg_Name_2 := Chars (Kind);
14012 ("pragma% does not allow% as check name", Arg1);
14017 Check_Optional_Identifier (Arg2, Name_Policy);
14018 Check_Arg_Is_One_Of
14020 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
14022 -- And chain pragma on the Check_Policy_List for search
14024 Set_Next_Pragma (N, Opt.Check_Policy_List);
14025 Opt.Check_Policy_List := N;
14027 -- For the new syntax, what we do is to convert each argument to
14028 -- an old syntax equivalent. We do that because we want to chain
14029 -- old style Check_Policy pragmas for the search (we don't want
14030 -- to have to deal with multiple arguments in the search).
14041 while Present (Arg) loop
14042 LocP := Sloc (Arg);
14043 Argx := Get_Pragma_Arg (Arg);
14045 -- Kind must be specified
14047 if Nkind (Arg) /= N_Pragma_Argument_Association
14048 or else Chars (Arg) = No_Name
14051 ("missing assertion kind for pragma%", Arg);
14054 -- Construct equivalent old form syntax Check_Policy
14055 -- pragma and insert it to get remaining checks.
14059 Chars => Name_Check_Policy,
14060 Pragma_Argument_Associations => New_List (
14061 Make_Pragma_Argument_Association (LocP,
14063 Make_Identifier (LocP, Chars (Arg))),
14064 Make_Pragma_Argument_Association (Sloc (Argx),
14065 Expression => Argx)));
14069 -- For a configuration pragma, insert old form in
14070 -- the corresponding file.
14072 if Is_Configuration_Pragma then
14073 Insert_After (N, New_P);
14077 Insert_Action (N, New_P);
14081 -- Rewrite original Check_Policy pragma to null, since we
14082 -- have converted it into a series of old syntax pragmas.
14084 Rewrite (N, Make_Null_Statement (Loc));
14094 -- pragma Comment (static_string_EXPRESSION)
14096 -- Processing for pragma Comment shares the circuitry for pragma
14097 -- Ident. The only differences are that Ident enforces a limit of 31
14098 -- characters on its argument, and also enforces limitations on
14099 -- placement for DEC compatibility. Pragma Comment shares neither of
14100 -- these restrictions.
14102 -------------------
14103 -- Common_Object --
14104 -------------------
14106 -- pragma Common_Object (
14107 -- [Internal =>] LOCAL_NAME
14108 -- [, [External =>] EXTERNAL_SYMBOL]
14109 -- [, [Size =>] EXTERNAL_SYMBOL]);
14111 -- Processing for this pragma is shared with Psect_Object
14113 ----------------------------------------------
14114 -- Compile_Time_Error, Compile_Time_Warning --
14115 ----------------------------------------------
14117 -- pragma Compile_Time_Error
14118 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14120 -- pragma Compile_Time_Warning
14121 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14123 when Pragma_Compile_Time_Error | Pragma_Compile_Time_Warning =>
14125 Process_Compile_Time_Warning_Or_Error;
14127 ---------------------------
14128 -- Compiler_Unit_Warning --
14129 ---------------------------
14131 -- pragma Compiler_Unit_Warning;
14135 -- Originally, we had only pragma Compiler_Unit, and it resulted in
14136 -- errors not warnings. This means that we had introduced a big extra
14137 -- inertia to compiler changes, since even if we implemented a new
14138 -- feature, and even if all versions to be used for bootstrapping
14139 -- implemented this new feature, we could not use it, since old
14140 -- compilers would give errors for using this feature in units
14141 -- having Compiler_Unit pragmas.
14143 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
14144 -- problem. We no longer have any units mentioning Compiler_Unit,
14145 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
14146 -- and thus generates a warning which can be ignored. So that deals
14147 -- with the problem of old compilers not implementing the newer form
14150 -- Newer compilers recognize the new pragma, but generate warning
14151 -- messages instead of errors, which again can be ignored in the
14152 -- case of an old compiler which implements a wanted new feature
14153 -- but at the time felt like warning about it for older compilers.
14155 -- We retain Compiler_Unit so that new compilers can be used to build
14156 -- older run-times that use this pragma. That's an unusual case, but
14157 -- it's easy enough to handle, so why not?
14159 when Pragma_Compiler_Unit
14160 | Pragma_Compiler_Unit_Warning
14163 Check_Arg_Count (0);
14165 -- Only recognized in main unit
14167 if Current_Sem_Unit = Main_Unit then
14168 Compiler_Unit := True;
14171 -----------------------------
14172 -- Complete_Representation --
14173 -----------------------------
14175 -- pragma Complete_Representation;
14177 when Pragma_Complete_Representation =>
14179 Check_Arg_Count (0);
14181 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
14183 ("pragma & must appear within record representation clause");
14186 ----------------------------
14187 -- Complex_Representation --
14188 ----------------------------
14190 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
14192 when Pragma_Complex_Representation => Complex_Representation : declare
14199 Check_Arg_Count (1);
14200 Check_Optional_Identifier (Arg1, Name_Entity);
14201 Check_Arg_Is_Local_Name (Arg1);
14202 E_Id := Get_Pragma_Arg (Arg1);
14204 if Etype (E_Id) = Any_Type then
14208 E := Entity (E_Id);
14210 if not Is_Record_Type (E) then
14212 ("argument for pragma% must be record type", Arg1);
14215 Ent := First_Entity (E);
14218 or else No (Next_Entity (Ent))
14219 or else Present (Next_Entity (Next_Entity (Ent)))
14220 or else not Is_Floating_Point_Type (Etype (Ent))
14221 or else Etype (Ent) /= Etype (Next_Entity (Ent))
14224 ("record for pragma% must have two fields of the same "
14225 & "floating-point type", Arg1);
14228 Set_Has_Complex_Representation (Base_Type (E));
14230 -- We need to treat the type has having a non-standard
14231 -- representation, for back-end purposes, even though in
14232 -- general a complex will have the default representation
14233 -- of a record with two real components.
14235 Set_Has_Non_Standard_Rep (Base_Type (E));
14237 end Complex_Representation;
14239 -------------------------
14240 -- Component_Alignment --
14241 -------------------------
14243 -- pragma Component_Alignment (
14244 -- [Form =>] ALIGNMENT_CHOICE
14245 -- [, [Name =>] type_LOCAL_NAME]);
14247 -- ALIGNMENT_CHOICE ::=
14249 -- | Component_Size_4
14253 when Pragma_Component_Alignment => Component_AlignmentP : declare
14254 Args : Args_List (1 .. 2);
14255 Names : constant Name_List (1 .. 2) := (
14259 Form : Node_Id renames Args (1);
14260 Name : Node_Id renames Args (2);
14262 Atype : Component_Alignment_Kind;
14267 Gather_Associations (Names, Args);
14270 Error_Pragma ("missing Form argument for pragma%");
14273 Check_Arg_Is_Identifier (Form);
14275 -- Get proper alignment, note that Default = Component_Size on all
14276 -- machines we have so far, and we want to set this value rather
14277 -- than the default value to indicate that it has been explicitly
14278 -- set (and thus will not get overridden by the default component
14279 -- alignment for the current scope)
14281 if Chars (Form) = Name_Component_Size then
14282 Atype := Calign_Component_Size;
14284 elsif Chars (Form) = Name_Component_Size_4 then
14285 Atype := Calign_Component_Size_4;
14287 elsif Chars (Form) = Name_Default then
14288 Atype := Calign_Component_Size;
14290 elsif Chars (Form) = Name_Storage_Unit then
14291 Atype := Calign_Storage_Unit;
14295 ("invalid Form parameter for pragma%", Form);
14298 -- The pragma appears in a configuration file
14300 if No (Parent (N)) then
14301 Check_Valid_Configuration_Pragma;
14303 -- Capture the component alignment in a global variable when
14304 -- the pragma appears in a configuration file. Note that the
14305 -- scope stack is empty at this point and cannot be used to
14306 -- store the alignment value.
14308 Configuration_Component_Alignment := Atype;
14310 -- Case with no name, supplied, affects scope table entry
14312 elsif No (Name) then
14314 (Scope_Stack.Last).Component_Alignment_Default := Atype;
14316 -- Case of name supplied
14319 Check_Arg_Is_Local_Name (Name);
14321 Typ := Entity (Name);
14324 or else Rep_Item_Too_Early (Typ, N)
14328 Typ := Underlying_Type (Typ);
14331 if not Is_Record_Type (Typ)
14332 and then not Is_Array_Type (Typ)
14335 ("Name parameter of pragma% must identify record or "
14336 & "array type", Name);
14339 -- An explicit Component_Alignment pragma overrides an
14340 -- implicit pragma Pack, but not an explicit one.
14342 if not Has_Pragma_Pack (Base_Type (Typ)) then
14343 Set_Is_Packed (Base_Type (Typ), False);
14344 Set_Component_Alignment (Base_Type (Typ), Atype);
14347 end Component_AlignmentP;
14349 --------------------------------
14350 -- Constant_After_Elaboration --
14351 --------------------------------
14353 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
14355 when Pragma_Constant_After_Elaboration => Constant_After_Elaboration :
14357 Obj_Decl : Node_Id;
14358 Obj_Id : Entity_Id;
14362 Check_No_Identifiers;
14363 Check_At_Most_N_Arguments (1);
14365 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
14367 if Nkind (Obj_Decl) /= N_Object_Declaration then
14372 Obj_Id := Defining_Entity (Obj_Decl);
14374 -- The object declaration must be a library-level variable which
14375 -- is either explicitly initialized or obtains a value during the
14376 -- elaboration of a package body (SPARK RM 3.3.1).
14378 if Ekind (Obj_Id) = E_Variable then
14379 if not Is_Library_Level_Entity (Obj_Id) then
14381 ("pragma % must apply to a library level variable");
14385 -- Otherwise the pragma applies to a constant, which is illegal
14388 Error_Pragma ("pragma % must apply to a variable declaration");
14392 -- A pragma that applies to a Ghost entity becomes Ghost for the
14393 -- purposes of legality checks and removal of ignored Ghost code.
14395 Mark_Ghost_Pragma (N, Obj_Id);
14397 -- Chain the pragma on the contract for completeness
14399 Add_Contract_Item (N, Obj_Id);
14401 -- Analyze the Boolean expression (if any)
14403 if Present (Arg1) then
14404 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
14406 end Constant_After_Elaboration;
14408 --------------------
14409 -- Contract_Cases --
14410 --------------------
14412 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
14414 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
14416 -- CASE_GUARD ::= boolean_EXPRESSION | others
14418 -- CONSEQUENCE ::= boolean_EXPRESSION
14420 -- Characteristics:
14422 -- * Analysis - The annotation undergoes initial checks to verify
14423 -- the legal placement and context. Secondary checks preanalyze the
14426 -- Analyze_Contract_Cases_In_Decl_Part
14428 -- * Expansion - The annotation is expanded during the expansion of
14429 -- the related subprogram [body] contract as performed in:
14431 -- Expand_Subprogram_Contract
14433 -- * Template - The annotation utilizes the generic template of the
14434 -- related subprogram [body] when it is:
14436 -- aspect on subprogram declaration
14437 -- aspect on stand-alone subprogram body
14438 -- pragma on stand-alone subprogram body
14440 -- The annotation must prepare its own template when it is:
14442 -- pragma on subprogram declaration
14444 -- * Globals - Capture of global references must occur after full
14447 -- * Instance - The annotation is instantiated automatically when
14448 -- the related generic subprogram [body] is instantiated except for
14449 -- the "pragma on subprogram declaration" case. In that scenario
14450 -- the annotation must instantiate itself.
14452 when Pragma_Contract_Cases => Contract_Cases : declare
14453 Spec_Id : Entity_Id;
14454 Subp_Decl : Node_Id;
14455 Subp_Spec : Node_Id;
14459 Check_No_Identifiers;
14460 Check_Arg_Count (1);
14462 -- Ensure the proper placement of the pragma. Contract_Cases must
14463 -- be associated with a subprogram declaration or a body that acts
14467 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
14471 if Nkind (Subp_Decl) = N_Entry_Declaration then
14474 -- Generic subprogram
14476 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
14479 -- Body acts as spec
14481 elsif Nkind (Subp_Decl) = N_Subprogram_Body
14482 and then No (Corresponding_Spec (Subp_Decl))
14486 -- Body stub acts as spec
14488 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
14489 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
14495 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
14496 Subp_Spec := Specification (Subp_Decl);
14498 -- Pragma Contract_Cases is forbidden on null procedures, as
14499 -- this may lead to potential ambiguities in behavior when
14500 -- interface null procedures are involved.
14502 if Nkind (Subp_Spec) = N_Procedure_Specification
14503 and then Null_Present (Subp_Spec)
14505 Error_Msg_N (Fix_Error
14506 ("pragma % cannot apply to null procedure"), N);
14515 Spec_Id := Unique_Defining_Entity (Subp_Decl);
14517 -- A pragma that applies to a Ghost entity becomes Ghost for the
14518 -- purposes of legality checks and removal of ignored Ghost code.
14520 Mark_Ghost_Pragma (N, Spec_Id);
14521 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
14523 -- Chain the pragma on the contract for further processing by
14524 -- Analyze_Contract_Cases_In_Decl_Part.
14526 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
14528 -- Fully analyze the pragma when it appears inside an entry
14529 -- or subprogram body because it cannot benefit from forward
14532 if Nkind (Subp_Decl) in N_Entry_Body
14533 | N_Subprogram_Body
14534 | N_Subprogram_Body_Stub
14536 -- The legality checks of pragma Contract_Cases are affected by
14537 -- the SPARK mode in effect and the volatility of the context.
14538 -- Analyze all pragmas in a specific order.
14540 Analyze_If_Present (Pragma_SPARK_Mode);
14541 Analyze_If_Present (Pragma_Volatile_Function);
14542 Analyze_Contract_Cases_In_Decl_Part (N);
14544 end Contract_Cases;
14550 -- pragma Controlled (first_subtype_LOCAL_NAME);
14552 when Pragma_Controlled => Controlled : declare
14556 Check_No_Identifiers;
14557 Check_Arg_Count (1);
14558 Check_Arg_Is_Local_Name (Arg1);
14559 Arg := Get_Pragma_Arg (Arg1);
14561 if not Is_Entity_Name (Arg)
14562 or else not Is_Access_Type (Entity (Arg))
14564 Error_Pragma_Arg ("pragma% requires access type", Arg1);
14566 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
14574 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
14575 -- [Entity =>] LOCAL_NAME);
14577 when Pragma_Convention => Convention : declare
14580 pragma Warnings (Off, C);
14581 pragma Warnings (Off, E);
14584 Check_Arg_Order ((Name_Convention, Name_Entity));
14585 Check_Ada_83_Warning;
14586 Check_Arg_Count (2);
14587 Process_Convention (C, E);
14589 -- A pragma that applies to a Ghost entity becomes Ghost for the
14590 -- purposes of legality checks and removal of ignored Ghost code.
14592 Mark_Ghost_Pragma (N, E);
14595 ---------------------------
14596 -- Convention_Identifier --
14597 ---------------------------
14599 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
14600 -- [Convention =>] convention_IDENTIFIER);
14602 when Pragma_Convention_Identifier => Convention_Identifier : declare
14608 Check_Arg_Order ((Name_Name, Name_Convention));
14609 Check_Arg_Count (2);
14610 Check_Optional_Identifier (Arg1, Name_Name);
14611 Check_Optional_Identifier (Arg2, Name_Convention);
14612 Check_Arg_Is_Identifier (Arg1);
14613 Check_Arg_Is_Identifier (Arg2);
14614 Idnam := Chars (Get_Pragma_Arg (Arg1));
14615 Cname := Chars (Get_Pragma_Arg (Arg2));
14617 if Is_Convention_Name (Cname) then
14618 Record_Convention_Identifier
14619 (Idnam, Get_Convention_Id (Cname));
14622 ("second arg for % pragma must be convention", Arg2);
14624 end Convention_Identifier;
14630 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
14632 when Pragma_CPP_Class =>
14635 if Warn_On_Obsolescent_Feature then
14637 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
14638 & "effect; replace it by pragma import?j?", N);
14641 Check_Arg_Count (1);
14645 Chars => Name_Import,
14646 Pragma_Argument_Associations => New_List (
14647 Make_Pragma_Argument_Association (Loc,
14648 Expression => Make_Identifier (Loc, Name_CPP)),
14649 New_Copy (First (Pragma_Argument_Associations (N))))));
14652 ---------------------
14653 -- CPP_Constructor --
14654 ---------------------
14656 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
14657 -- [, [External_Name =>] static_string_EXPRESSION ]
14658 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14660 when Pragma_CPP_Constructor => CPP_Constructor : declare
14663 Def_Id : Entity_Id;
14664 Tag_Typ : Entity_Id;
14668 Check_At_Least_N_Arguments (1);
14669 Check_At_Most_N_Arguments (3);
14670 Check_Optional_Identifier (Arg1, Name_Entity);
14671 Check_Arg_Is_Local_Name (Arg1);
14673 Id := Get_Pragma_Arg (Arg1);
14674 Find_Program_Unit_Name (Id);
14676 -- If we did not find the name, we are done
14678 if Etype (Id) = Any_Type then
14682 Def_Id := Entity (Id);
14684 -- Check if already defined as constructor
14686 if Is_Constructor (Def_Id) then
14688 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
14692 if Ekind (Def_Id) = E_Function
14693 and then (Is_CPP_Class (Etype (Def_Id))
14694 or else (Is_Class_Wide_Type (Etype (Def_Id))
14696 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
14698 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
14700 ("'C'P'P constructor must be defined in the scope of "
14701 & "its returned type", Arg1);
14704 if Arg_Count >= 2 then
14705 Set_Imported (Def_Id);
14706 Set_Is_Public (Def_Id);
14707 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
14710 Set_Has_Completion (Def_Id);
14711 Set_Is_Constructor (Def_Id);
14712 Set_Convention (Def_Id, Convention_CPP);
14714 -- Imported C++ constructors are not dispatching primitives
14715 -- because in C++ they don't have a dispatch table slot.
14716 -- However, in Ada the constructor has the profile of a
14717 -- function that returns a tagged type and therefore it has
14718 -- been treated as a primitive operation during semantic
14719 -- analysis. We now remove it from the list of primitive
14720 -- operations of the type.
14722 if Is_Tagged_Type (Etype (Def_Id))
14723 and then not Is_Class_Wide_Type (Etype (Def_Id))
14724 and then Is_Dispatching_Operation (Def_Id)
14726 Tag_Typ := Etype (Def_Id);
14728 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
14729 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
14733 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
14734 Set_Is_Dispatching_Operation (Def_Id, False);
14737 -- For backward compatibility, if the constructor returns a
14738 -- class wide type, and we internally change the return type to
14739 -- the corresponding root type.
14741 if Is_Class_Wide_Type (Etype (Def_Id)) then
14742 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
14746 ("pragma% requires function returning a 'C'P'P_Class type",
14749 end CPP_Constructor;
14755 when Pragma_CPP_Virtual =>
14758 if Warn_On_Obsolescent_Feature then
14760 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
14764 --------------------
14766 --------------------
14768 -- pragma CUDA_Execute (PROCEDURE_CALL_STATEMENT,
14772 -- [, EXPRESSION]]);
14774 when Pragma_CUDA_Execute => CUDA_Execute : declare
14776 function Is_Acceptable_Dim3 (N : Node_Id) return Boolean;
14777 -- Returns True if N is an acceptable argument for CUDA_Execute,
14778 -- False otherwise.
14780 ------------------------
14781 -- Is_Acceptable_Dim3 --
14782 ------------------------
14784 function Is_Acceptable_Dim3 (N : Node_Id) return Boolean is
14787 if Is_RTE (Etype (N), RE_Dim3)
14788 or else Is_Integer_Type (Etype (N))
14793 if Nkind (N) = N_Aggregate
14794 and then List_Length (Expressions (N)) = 3
14796 Expr := First (Expressions (N));
14797 while Present (Expr) loop
14798 Analyze_And_Resolve (Expr, Any_Integer);
14805 end Is_Acceptable_Dim3;
14809 Block_Dimensions : constant Node_Id := Get_Pragma_Arg (Arg3);
14810 Grid_Dimensions : constant Node_Id := Get_Pragma_Arg (Arg2);
14811 Kernel_Call : constant Node_Id := Get_Pragma_Arg (Arg1);
14812 Shared_Memory : Node_Id;
14815 -- Start of processing for CUDA_Execute
14819 Check_At_Least_N_Arguments (3);
14820 Check_At_Most_N_Arguments (5);
14822 Analyze_And_Resolve (Kernel_Call);
14823 if Nkind (Kernel_Call) /= N_Function_Call
14824 or else Etype (Kernel_Call) /= Standard_Void_Type
14826 -- In `pragma CUDA_Execute (Kernel_Call (...), ...)`,
14827 -- GNAT sees Kernel_Call as an N_Function_Call since
14828 -- Kernel_Call "looks" like an expression. However, only
14829 -- procedures can be kernels, so to make things easier for the
14830 -- user the error message complains about Kernel_Call not being
14831 -- a procedure call.
14833 Error_Msg_N ("first argument of & must be a procedure call", N);
14836 Analyze (Grid_Dimensions);
14837 if not Is_Acceptable_Dim3 (Grid_Dimensions) then
14839 ("second argument of & must be an Integer, Dim3 or aggregate "
14840 & "containing 3 Integers", N);
14843 Analyze (Block_Dimensions);
14844 if not Is_Acceptable_Dim3 (Block_Dimensions) then
14846 ("third argument of & must be an Integer, Dim3 or aggregate "
14847 & "containing 3 Integers", N);
14850 if Present (Arg4) then
14851 Shared_Memory := Get_Pragma_Arg (Arg4);
14852 Analyze_And_Resolve (Shared_Memory, Any_Integer);
14854 if Present (Arg5) then
14855 Stream := Get_Pragma_Arg (Arg5);
14856 Analyze_And_Resolve (Stream, RTE (RE_Stream_T));
14865 -- pragma CUDA_Global (IDENTIFIER);
14867 when Pragma_CUDA_Global => CUDA_Global : declare
14868 Arg_Node : Node_Id;
14869 Kernel_Proc : Entity_Id;
14870 Pack_Id : Entity_Id;
14873 Check_At_Least_N_Arguments (1);
14874 Check_At_Most_N_Arguments (1);
14875 Check_Optional_Identifier (Arg1, Name_Entity);
14876 Check_Arg_Is_Local_Name (Arg1);
14878 Arg_Node := Get_Pragma_Arg (Arg1);
14879 Analyze (Arg_Node);
14881 Kernel_Proc := Entity (Arg_Node);
14882 Pack_Id := Scope (Kernel_Proc);
14884 if Ekind (Kernel_Proc) /= E_Procedure then
14885 Error_Msg_NE ("& must be a procedure", N, Kernel_Proc);
14887 elsif Ekind (Pack_Id) /= E_Package
14888 or else not Is_Library_Level_Entity (Pack_Id)
14891 ("& must reside in a library-level package", N, Kernel_Proc);
14894 Set_Is_CUDA_Kernel (Kernel_Proc);
14902 when Pragma_CPP_Vtable =>
14905 if Warn_On_Obsolescent_Feature then
14907 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
14915 -- pragma CPU (EXPRESSION);
14917 when Pragma_CPU => CPU : declare
14918 P : constant Node_Id := Parent (N);
14924 Check_No_Identifiers;
14925 Check_Arg_Count (1);
14926 Arg := Get_Pragma_Arg (Arg1);
14930 if Nkind (P) = N_Subprogram_Body then
14931 Check_In_Main_Program;
14933 Analyze_And_Resolve (Arg, Any_Integer);
14935 Ent := Defining_Unit_Name (Specification (P));
14937 if Nkind (Ent) = N_Defining_Program_Unit_Name then
14938 Ent := Defining_Identifier (Ent);
14943 if not Is_OK_Static_Expression (Arg) then
14944 Flag_Non_Static_Expr
14945 ("main subprogram affinity is not static!", Arg);
14948 -- If constraint error, then we already signalled an error
14950 elsif Raises_Constraint_Error (Arg) then
14953 -- Otherwise check in range
14957 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
14958 -- This is the entity System.Multiprocessors.CPU_Range;
14960 Val : constant Uint := Expr_Value (Arg);
14963 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
14965 Val > Expr_Value (Type_High_Bound (CPU_Id))
14968 ("main subprogram CPU is out of range", Arg1);
14974 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
14978 elsif Nkind (P) = N_Task_Definition then
14979 Ent := Defining_Identifier (Parent (P));
14981 -- The expression must be analyzed in the special manner
14982 -- described in "Handling of Default and Per-Object
14983 -- Expressions" in sem.ads.
14985 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
14987 -- See comment in Sem_Ch13 about the following restrictions
14989 if Is_OK_Static_Expression (Arg) then
14990 if Expr_Value (Arg) = Uint_0 then
14991 Check_Restriction (No_Tasks_Unassigned_To_CPU, N);
14994 Check_Restriction (No_Dynamic_CPU_Assignment, N);
14997 -- Anything else is incorrect
15003 -- Check duplicate pragma before we chain the pragma in the Rep
15004 -- Item chain of Ent.
15006 Check_Duplicate_Pragma (Ent);
15007 Record_Rep_Item (Ent, N);
15010 --------------------
15011 -- Deadline_Floor --
15012 --------------------
15014 -- pragma Deadline_Floor (time_span_EXPRESSION);
15016 when Pragma_Deadline_Floor => Deadline_Floor : declare
15017 P : constant Node_Id := Parent (N);
15023 Check_No_Identifiers;
15024 Check_Arg_Count (1);
15026 Arg := Get_Pragma_Arg (Arg1);
15028 -- The expression must be analyzed in the special manner described
15029 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
15031 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
15033 -- Only protected types allowed
15035 if Nkind (P) /= N_Protected_Definition then
15039 Ent := Defining_Identifier (Parent (P));
15041 -- Check duplicate pragma before we chain the pragma in the Rep
15042 -- Item chain of Ent.
15044 Check_Duplicate_Pragma (Ent);
15045 Record_Rep_Item (Ent, N);
15047 end Deadline_Floor;
15053 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
15055 when Pragma_Debug => Debug : declare
15062 -- The condition for executing the call is that the expander
15063 -- is active and that we are not ignoring this debug pragma.
15068 (Expander_Active and then not Is_Ignored (N)),
15071 if not Is_Ignored (N) then
15072 Set_SCO_Pragma_Enabled (Loc);
15075 if Arg_Count = 2 then
15077 Make_And_Then (Loc,
15078 Left_Opnd => Relocate_Node (Cond),
15079 Right_Opnd => Get_Pragma_Arg (Arg1));
15080 Call := Get_Pragma_Arg (Arg2);
15082 Call := Get_Pragma_Arg (Arg1);
15085 if Nkind (Call) in N_Expanded_Name
15088 | N_Indexed_Component
15089 | N_Selected_Component
15091 -- If this pragma Debug comes from source, its argument was
15092 -- parsed as a name form (which is syntactically identical).
15093 -- In a generic context a parameterless call will be left as
15094 -- an expanded name (if global) or selected_component if local.
15095 -- Change it to a procedure call statement now.
15097 Change_Name_To_Procedure_Call_Statement (Call);
15099 elsif Nkind (Call) = N_Procedure_Call_Statement then
15101 -- Already in the form of a procedure call statement: nothing
15102 -- to do (could happen in case of an internally generated
15108 -- All other cases: diagnose error
15111 ("argument of pragma ""Debug"" is not procedure call",
15116 -- Rewrite into a conditional with an appropriate condition. We
15117 -- wrap the procedure call in a block so that overhead from e.g.
15118 -- use of the secondary stack does not generate execution overhead
15119 -- for suppressed conditions.
15121 -- Normally the analysis that follows will freeze the subprogram
15122 -- being called. However, if the call is to a null procedure,
15123 -- we want to freeze it before creating the block, because the
15124 -- analysis that follows may be done with expansion disabled, in
15125 -- which case the body will not be generated, leading to spurious
15128 if Nkind (Call) = N_Procedure_Call_Statement
15129 and then Is_Entity_Name (Name (Call))
15131 Analyze (Name (Call));
15132 Freeze_Before (N, Entity (Name (Call)));
15136 Make_Implicit_If_Statement (N,
15138 Then_Statements => New_List (
15139 Make_Block_Statement (Loc,
15140 Handled_Statement_Sequence =>
15141 Make_Handled_Sequence_Of_Statements (Loc,
15142 Statements => New_List (Relocate_Node (Call)))))));
15145 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
15146 -- after analysis of the normally rewritten node, to capture all
15147 -- references to entities, which avoids issuing wrong warnings
15148 -- about unused entities.
15150 if GNATprove_Mode then
15151 Rewrite (N, Make_Null_Statement (Loc));
15159 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
15161 when Pragma_Debug_Policy =>
15163 Check_Arg_Count (1);
15164 Check_No_Identifiers;
15165 Check_Arg_Is_Identifier (Arg1);
15167 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
15168 -- rewrite it that way, and let the rest of the checking come
15169 -- from analyzing the rewritten pragma.
15173 Chars => Name_Check_Policy,
15174 Pragma_Argument_Associations => New_List (
15175 Make_Pragma_Argument_Association (Loc,
15176 Expression => Make_Identifier (Loc, Name_Debug)),
15178 Make_Pragma_Argument_Association (Loc,
15179 Expression => Get_Pragma_Arg (Arg1)))));
15182 -------------------------------
15183 -- Default_Initial_Condition --
15184 -------------------------------
15186 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
15188 when Pragma_Default_Initial_Condition => DIC : declare
15195 Check_No_Identifiers;
15196 Check_At_Most_N_Arguments (1);
15200 while Present (Stmt) loop
15202 -- Skip prior pragmas, but check for duplicates
15204 if Nkind (Stmt) = N_Pragma then
15205 if Pragma_Name (Stmt) = Pname then
15212 -- Skip internally generated code. Note that derived type
15213 -- declarations of untagged types with discriminants are
15214 -- rewritten as private type declarations.
15216 elsif not Comes_From_Source (Stmt)
15217 and then Nkind (Stmt) /= N_Private_Type_Declaration
15221 -- The associated private type [extension] has been found, stop
15224 elsif Nkind (Stmt) in N_Private_Extension_Declaration
15225 | N_Private_Type_Declaration
15227 Typ := Defining_Entity (Stmt);
15230 -- The pragma does not apply to a legal construct, issue an
15231 -- error and stop the analysis.
15238 Stmt := Prev (Stmt);
15241 -- The pragma does not apply to a legal construct, issue an error
15242 -- and stop the analysis.
15249 -- A pragma that applies to a Ghost entity becomes Ghost for the
15250 -- purposes of legality checks and removal of ignored Ghost code.
15252 Mark_Ghost_Pragma (N, Typ);
15254 -- The pragma signals that the type defines its own DIC assertion
15257 Set_Has_Own_DIC (Typ);
15259 -- Chain the pragma on the rep item chain for further processing
15261 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
15263 -- Create the declaration of the procedure which verifies the
15264 -- assertion expression of pragma DIC at runtime.
15266 Build_DIC_Procedure_Declaration (Typ);
15269 ----------------------------------
15270 -- Default_Scalar_Storage_Order --
15271 ----------------------------------
15273 -- pragma Default_Scalar_Storage_Order
15274 -- (High_Order_First | Low_Order_First);
15276 when Pragma_Default_Scalar_Storage_Order => DSSO : declare
15277 Default : Character;
15281 Check_Arg_Count (1);
15283 -- Default_Scalar_Storage_Order can appear as a configuration
15284 -- pragma, or in a declarative part of a package spec.
15286 if not Is_Configuration_Pragma then
15287 Check_Is_In_Decl_Part_Or_Package_Spec;
15290 Check_No_Identifiers;
15291 Check_Arg_Is_One_Of
15292 (Arg1, Name_High_Order_First, Name_Low_Order_First);
15293 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
15294 Default := Fold_Upper (Name_Buffer (1));
15296 if not Support_Nondefault_SSO_On_Target
15297 and then (Ttypes.Bytes_Big_Endian /= (Default = 'H'))
15299 if Warn_On_Unrecognized_Pragma then
15301 ("non-default Scalar_Storage_Order not supported "
15302 & "on target?g?", N);
15304 ("\pragma Default_Scalar_Storage_Order ignored?g?", N);
15307 -- Here set the specified default
15310 Opt.Default_SSO := Default;
15314 --------------------------
15315 -- Default_Storage_Pool --
15316 --------------------------
15318 -- pragma Default_Storage_Pool (storage_pool_NAME | null | Standard);
15320 when Pragma_Default_Storage_Pool => Default_Storage_Pool : declare
15325 Check_Arg_Count (1);
15327 -- Default_Storage_Pool can appear as a configuration pragma, or
15328 -- in a declarative part of a package spec.
15330 if not Is_Configuration_Pragma then
15331 Check_Is_In_Decl_Part_Or_Package_Spec;
15334 if From_Aspect_Specification (N) then
15336 E : constant Entity_Id := Entity (Corresponding_Aspect (N));
15338 if not In_Open_Scopes (E) then
15340 ("aspect must apply to package or subprogram", N);
15345 if Present (Arg1) then
15346 Pool := Get_Pragma_Arg (Arg1);
15348 -- Case of Default_Storage_Pool (null);
15350 if Nkind (Pool) = N_Null then
15353 -- This is an odd case, this is not really an expression,
15354 -- so we don't have a type for it. So just set the type to
15357 Set_Etype (Pool, Empty);
15359 -- Case of Default_Storage_Pool (Standard);
15361 elsif Nkind (Pool) = N_Identifier
15362 and then Chars (Pool) = Name_Standard
15366 if Entity (Pool) /= Standard_Standard then
15368 ("package Standard is not directly visible", Arg1);
15371 -- Case of Default_Storage_Pool (storage_pool_NAME);
15374 -- If it's a configuration pragma, then the only allowed
15375 -- argument is "null".
15377 if Is_Configuration_Pragma then
15378 Error_Pragma_Arg ("NULL or Standard expected", Arg1);
15381 -- The expected type for a non-"null" argument is
15382 -- Root_Storage_Pool'Class, and the pool must be a variable.
15384 Analyze_And_Resolve
15385 (Pool, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
15387 if Is_Variable (Pool) then
15389 -- A pragma that applies to a Ghost entity becomes Ghost
15390 -- for the purposes of legality checks and removal of
15391 -- ignored Ghost code.
15393 Mark_Ghost_Pragma (N, Entity (Pool));
15397 ("default storage pool must be a variable", Arg1);
15401 -- Record the pool name (or null). Freeze.Freeze_Entity for an
15402 -- access type will use this information to set the appropriate
15403 -- attributes of the access type. If the pragma appears in a
15404 -- generic unit it is ignored, given that it may refer to a
15407 if not Inside_A_Generic then
15408 Default_Pool := Pool;
15411 end Default_Storage_Pool;
15417 -- pragma Depends (DEPENDENCY_RELATION);
15419 -- DEPENDENCY_RELATION ::=
15421 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
15423 -- DEPENDENCY_CLAUSE ::=
15424 -- OUTPUT_LIST =>[+] INPUT_LIST
15425 -- | NULL_DEPENDENCY_CLAUSE
15427 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
15429 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
15431 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
15433 -- OUTPUT ::= NAME | FUNCTION_RESULT
15436 -- where FUNCTION_RESULT is a function Result attribute_reference
15438 -- Characteristics:
15440 -- * Analysis - The annotation undergoes initial checks to verify
15441 -- the legal placement and context. Secondary checks fully analyze
15442 -- the dependency clauses in:
15444 -- Analyze_Depends_In_Decl_Part
15446 -- * Expansion - None.
15448 -- * Template - The annotation utilizes the generic template of the
15449 -- related subprogram [body] when it is:
15451 -- aspect on subprogram declaration
15452 -- aspect on stand-alone subprogram body
15453 -- pragma on stand-alone subprogram body
15455 -- The annotation must prepare its own template when it is:
15457 -- pragma on subprogram declaration
15459 -- * Globals - Capture of global references must occur after full
15462 -- * Instance - The annotation is instantiated automatically when
15463 -- the related generic subprogram [body] is instantiated except for
15464 -- the "pragma on subprogram declaration" case. In that scenario
15465 -- the annotation must instantiate itself.
15467 when Pragma_Depends => Depends : declare
15469 Spec_Id : Entity_Id;
15470 Subp_Decl : Node_Id;
15473 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
15477 -- Chain the pragma on the contract for further processing by
15478 -- Analyze_Depends_In_Decl_Part.
15480 Add_Contract_Item (N, Spec_Id);
15482 -- Fully analyze the pragma when it appears inside an entry
15483 -- or subprogram body because it cannot benefit from forward
15486 if Nkind (Subp_Decl) in N_Entry_Body
15487 | N_Subprogram_Body
15488 | N_Subprogram_Body_Stub
15490 -- The legality checks of pragmas Depends and Global are
15491 -- affected by the SPARK mode in effect and the volatility
15492 -- of the context. In addition these two pragmas are subject
15493 -- to an inherent order:
15498 -- Analyze all these pragmas in the order outlined above
15500 Analyze_If_Present (Pragma_SPARK_Mode);
15501 Analyze_If_Present (Pragma_Volatile_Function);
15502 Analyze_If_Present (Pragma_Global);
15503 Analyze_Depends_In_Decl_Part (N);
15508 ---------------------
15509 -- Detect_Blocking --
15510 ---------------------
15512 -- pragma Detect_Blocking;
15514 when Pragma_Detect_Blocking =>
15516 Check_Arg_Count (0);
15517 Check_Valid_Configuration_Pragma;
15518 Detect_Blocking := True;
15520 ------------------------------------
15521 -- Disable_Atomic_Synchronization --
15522 ------------------------------------
15524 -- pragma Disable_Atomic_Synchronization [(Entity)];
15526 when Pragma_Disable_Atomic_Synchronization =>
15528 Process_Disable_Enable_Atomic_Sync (Name_Suppress);
15530 -------------------
15531 -- Discard_Names --
15532 -------------------
15534 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
15536 when Pragma_Discard_Names => Discard_Names : declare
15541 Check_Ada_83_Warning;
15543 -- Deal with configuration pragma case
15545 if Arg_Count = 0 and then Is_Configuration_Pragma then
15546 Global_Discard_Names := True;
15549 -- Otherwise, check correct appropriate context
15552 Check_Is_In_Decl_Part_Or_Package_Spec;
15554 if Arg_Count = 0 then
15556 -- If there is no parameter, then from now on this pragma
15557 -- applies to any enumeration, exception or tagged type
15558 -- defined in the current declarative part, and recursively
15559 -- to any nested scope.
15561 Set_Discard_Names (Current_Scope);
15565 Check_Arg_Count (1);
15566 Check_Optional_Identifier (Arg1, Name_On);
15567 Check_Arg_Is_Local_Name (Arg1);
15569 E_Id := Get_Pragma_Arg (Arg1);
15571 if Etype (E_Id) = Any_Type then
15575 E := Entity (E_Id);
15577 -- A pragma that applies to a Ghost entity becomes Ghost for
15578 -- the purposes of legality checks and removal of ignored
15581 Mark_Ghost_Pragma (N, E);
15583 if (Is_First_Subtype (E)
15585 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
15586 or else Ekind (E) = E_Exception
15588 Set_Discard_Names (E);
15589 Record_Rep_Item (E, N);
15593 ("inappropriate entity for pragma%", Arg1);
15599 ------------------------
15600 -- Dispatching_Domain --
15601 ------------------------
15603 -- pragma Dispatching_Domain (EXPRESSION);
15605 when Pragma_Dispatching_Domain => Dispatching_Domain : declare
15606 P : constant Node_Id := Parent (N);
15612 Check_No_Identifiers;
15613 Check_Arg_Count (1);
15615 -- This pragma is born obsolete, but not the aspect
15617 if not From_Aspect_Specification (N) then
15619 (No_Obsolescent_Features, Pragma_Identifier (N));
15622 if Nkind (P) = N_Task_Definition then
15623 Arg := Get_Pragma_Arg (Arg1);
15624 Ent := Defining_Identifier (Parent (P));
15626 -- A pragma that applies to a Ghost entity becomes Ghost for
15627 -- the purposes of legality checks and removal of ignored Ghost
15630 Mark_Ghost_Pragma (N, Ent);
15632 -- The expression must be analyzed in the special manner
15633 -- described in "Handling of Default and Per-Object
15634 -- Expressions" in sem.ads.
15636 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
15638 -- Check duplicate pragma before we chain the pragma in the Rep
15639 -- Item chain of Ent.
15641 Check_Duplicate_Pragma (Ent);
15642 Record_Rep_Item (Ent, N);
15644 -- Anything else is incorrect
15649 end Dispatching_Domain;
15655 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
15657 when Pragma_Elaborate => Elaborate : declare
15662 -- Pragma must be in context items list of a compilation unit
15664 if not Is_In_Context_Clause then
15668 -- Must be at least one argument
15670 if Arg_Count = 0 then
15671 Error_Pragma ("pragma% requires at least one argument");
15674 -- In Ada 83 mode, there can be no items following it in the
15675 -- context list except other pragmas and implicit with clauses
15676 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
15677 -- placement rule does not apply.
15679 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
15681 while Present (Citem) loop
15682 if Nkind (Citem) = N_Pragma
15683 or else (Nkind (Citem) = N_With_Clause
15684 and then Implicit_With (Citem))
15689 ("(Ada 83) pragma% must be at end of context clause");
15696 -- Finally, the arguments must all be units mentioned in a with
15697 -- clause in the same context clause. Note we already checked (in
15698 -- Par.Prag) that the arguments are all identifiers or selected
15702 Outer : while Present (Arg) loop
15703 Citem := First (List_Containing (N));
15704 Inner : while Citem /= N loop
15705 if Nkind (Citem) = N_With_Clause
15706 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
15708 Set_Elaborate_Present (Citem, True);
15709 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
15711 -- With the pragma present, elaboration calls on
15712 -- subprograms from the named unit need no further
15713 -- checks, as long as the pragma appears in the current
15714 -- compilation unit. If the pragma appears in some unit
15715 -- in the context, there might still be a need for an
15716 -- Elaborate_All_Desirable from the current compilation
15717 -- to the named unit, so we keep the check enabled. This
15718 -- does not apply in SPARK mode, where we allow pragma
15719 -- Elaborate, but we don't trust it to be right so we
15720 -- will still insist on the Elaborate_All.
15722 if Legacy_Elaboration_Checks
15723 and then In_Extended_Main_Source_Unit (N)
15724 and then SPARK_Mode /= On
15726 Set_Suppress_Elaboration_Warnings
15727 (Entity (Name (Citem)));
15738 ("argument of pragma% is not withed unit", Arg);
15745 -------------------
15746 -- Elaborate_All --
15747 -------------------
15749 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
15751 when Pragma_Elaborate_All => Elaborate_All : declare
15756 Check_Ada_83_Warning;
15758 -- Pragma must be in context items list of a compilation unit
15760 if not Is_In_Context_Clause then
15764 -- Must be at least one argument
15766 if Arg_Count = 0 then
15767 Error_Pragma ("pragma% requires at least one argument");
15770 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
15771 -- have to appear at the end of the context clause, but may
15772 -- appear mixed in with other items, even in Ada 83 mode.
15774 -- Final check: the arguments must all be units mentioned in
15775 -- a with clause in the same context clause. Note that we
15776 -- already checked (in Par.Prag) that all the arguments are
15777 -- either identifiers or selected components.
15780 Outr : while Present (Arg) loop
15781 Citem := First (List_Containing (N));
15782 Innr : while Citem /= N loop
15783 if Nkind (Citem) = N_With_Clause
15784 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
15786 Set_Elaborate_All_Present (Citem, True);
15787 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
15789 -- Suppress warnings and elaboration checks on the named
15790 -- unit if the pragma is in the current compilation, as
15791 -- for pragma Elaborate.
15793 if Legacy_Elaboration_Checks
15794 and then In_Extended_Main_Source_Unit (N)
15796 Set_Suppress_Elaboration_Warnings
15797 (Entity (Name (Citem)));
15807 Set_Error_Posted (N);
15809 ("argument of pragma% is not withed unit", Arg);
15816 --------------------
15817 -- Elaborate_Body --
15818 --------------------
15820 -- pragma Elaborate_Body [( library_unit_NAME )];
15822 when Pragma_Elaborate_Body => Elaborate_Body : declare
15823 Cunit_Node : Node_Id;
15824 Cunit_Ent : Entity_Id;
15827 Check_Ada_83_Warning;
15828 Check_Valid_Library_Unit_Pragma;
15830 if Nkind (N) = N_Null_Statement then
15834 Cunit_Node := Cunit (Current_Sem_Unit);
15835 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
15837 -- A pragma that applies to a Ghost entity becomes Ghost for the
15838 -- purposes of legality checks and removal of ignored Ghost code.
15840 Mark_Ghost_Pragma (N, Cunit_Ent);
15842 if Nkind (Unit (Cunit_Node)) in
15843 N_Package_Body | N_Subprogram_Body
15845 Error_Pragma ("pragma% must refer to a spec, not a body");
15847 Set_Body_Required (Cunit_Node);
15848 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
15850 -- If we are in dynamic elaboration mode, then we suppress
15851 -- elaboration warnings for the unit, since it is definitely
15852 -- fine NOT to do dynamic checks at the first level (and such
15853 -- checks will be suppressed because no elaboration boolean
15854 -- is created for Elaborate_Body packages).
15856 -- But in the static model of elaboration, Elaborate_Body is
15857 -- definitely NOT good enough to ensure elaboration safety on
15858 -- its own, since the body may WITH other units that are not
15859 -- safe from an elaboration point of view, so a client must
15860 -- still do an Elaborate_All on such units.
15862 -- Debug flag -gnatdD restores the old behavior of 3.13, where
15863 -- Elaborate_Body always suppressed elab warnings.
15865 if Legacy_Elaboration_Checks
15866 and then (Dynamic_Elaboration_Checks or Debug_Flag_DD)
15868 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
15871 end Elaborate_Body;
15873 ------------------------
15874 -- Elaboration_Checks --
15875 ------------------------
15877 -- pragma Elaboration_Checks (Static | Dynamic);
15879 when Pragma_Elaboration_Checks => Elaboration_Checks : declare
15880 procedure Check_Duplicate_Elaboration_Checks_Pragma;
15881 -- Emit an error if the current context list already contains
15882 -- a previous Elaboration_Checks pragma. This routine raises
15883 -- Pragma_Exit if a duplicate is found.
15885 procedure Ignore_Elaboration_Checks_Pragma;
15886 -- Warn that the effects of the pragma are ignored. This routine
15887 -- raises Pragma_Exit.
15889 -----------------------------------------------
15890 -- Check_Duplicate_Elaboration_Checks_Pragma --
15891 -----------------------------------------------
15893 procedure Check_Duplicate_Elaboration_Checks_Pragma is
15898 while Present (Item) loop
15899 if Nkind (Item) = N_Pragma
15900 and then Pragma_Name (Item) = Name_Elaboration_Checks
15910 end Check_Duplicate_Elaboration_Checks_Pragma;
15912 --------------------------------------
15913 -- Ignore_Elaboration_Checks_Pragma --
15914 --------------------------------------
15916 procedure Ignore_Elaboration_Checks_Pragma is
15918 Error_Msg_Name_1 := Pname;
15919 Error_Msg_N ("??effects of pragma % are ignored", N);
15921 ("\place pragma on initial declaration of library unit", N);
15924 end Ignore_Elaboration_Checks_Pragma;
15928 Context : constant Node_Id := Parent (N);
15931 -- Start of processing for Elaboration_Checks
15935 Check_Arg_Count (1);
15936 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
15938 -- The pragma appears in a configuration file
15940 if No (Context) then
15941 Check_Valid_Configuration_Pragma;
15942 Check_Duplicate_Elaboration_Checks_Pragma;
15944 -- The pragma acts as a configuration pragma in a compilation unit
15946 -- pragma Elaboration_Checks (...);
15947 -- package Pack is ...;
15949 elsif Nkind (Context) = N_Compilation_Unit
15950 and then List_Containing (N) = Context_Items (Context)
15952 Check_Valid_Configuration_Pragma;
15953 Check_Duplicate_Elaboration_Checks_Pragma;
15955 Unt := Unit (Context);
15957 -- The pragma must appear on the initial declaration of a unit.
15958 -- If this is not the case, warn that the effects of the pragma
15961 if Nkind (Unt) = N_Package_Body then
15962 Ignore_Elaboration_Checks_Pragma;
15964 -- Check the Acts_As_Spec flag of the compilation units itself
15965 -- to determine whether the subprogram body completes since it
15966 -- has not been analyzed yet. This is safe because compilation
15967 -- units are not overloadable.
15969 elsif Nkind (Unt) = N_Subprogram_Body
15970 and then not Acts_As_Spec (Context)
15972 Ignore_Elaboration_Checks_Pragma;
15974 elsif Nkind (Unt) = N_Subunit then
15975 Ignore_Elaboration_Checks_Pragma;
15978 -- Otherwise the pragma does not appear at the configuration level
15985 -- At this point the pragma is not a duplicate, and appears in the
15986 -- proper context. Set the elaboration model in effect.
15988 Dynamic_Elaboration_Checks :=
15989 Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic;
15990 end Elaboration_Checks;
15996 -- pragma Eliminate (
15997 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
15998 -- [Entity =>] IDENTIFIER |
15999 -- SELECTED_COMPONENT |
16001 -- [, Source_Location => SOURCE_TRACE]);
16003 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
16004 -- SOURCE_TRACE ::= STRING_LITERAL
16006 when Pragma_Eliminate => Eliminate : declare
16007 Args : Args_List (1 .. 5);
16008 Names : constant Name_List (1 .. 5) := (
16011 Name_Parameter_Types,
16013 Name_Source_Location);
16015 -- Note : Parameter_Types and Result_Type are leftovers from
16016 -- prior implementations of the pragma. They are not generated
16017 -- by the gnatelim tool, and play no role in selecting which
16018 -- of a set of overloaded names is chosen for elimination.
16020 Unit_Name : Node_Id renames Args (1);
16021 Entity : Node_Id renames Args (2);
16022 Parameter_Types : Node_Id renames Args (3);
16023 Result_Type : Node_Id renames Args (4);
16024 Source_Location : Node_Id renames Args (5);
16028 Check_Valid_Configuration_Pragma;
16029 Gather_Associations (Names, Args);
16031 if No (Unit_Name) then
16032 Error_Pragma ("missing Unit_Name argument for pragma%");
16036 and then (Present (Parameter_Types)
16038 Present (Result_Type)
16040 Present (Source_Location))
16042 Error_Pragma ("missing Entity argument for pragma%");
16045 if (Present (Parameter_Types)
16047 Present (Result_Type))
16049 Present (Source_Location)
16052 ("parameter profile and source location cannot be used "
16053 & "together in pragma%");
16056 Process_Eliminate_Pragma
16065 -----------------------------------
16066 -- Enable_Atomic_Synchronization --
16067 -----------------------------------
16069 -- pragma Enable_Atomic_Synchronization [(Entity)];
16071 when Pragma_Enable_Atomic_Synchronization =>
16073 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
16080 -- [ Convention =>] convention_IDENTIFIER,
16081 -- [ Entity =>] LOCAL_NAME
16082 -- [, [External_Name =>] static_string_EXPRESSION ]
16083 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16085 when Pragma_Export => Export : declare
16087 Def_Id : Entity_Id;
16089 pragma Warnings (Off, C);
16092 Check_Ada_83_Warning;
16096 Name_External_Name,
16099 Check_At_Least_N_Arguments (2);
16100 Check_At_Most_N_Arguments (4);
16102 -- In Relaxed_RM_Semantics, support old Ada 83 style:
16103 -- pragma Export (Entity, "external name");
16105 if Relaxed_RM_Semantics
16106 and then Arg_Count = 2
16107 and then Nkind (Expression (Arg2)) = N_String_Literal
16110 Def_Id := Get_Pragma_Arg (Arg1);
16113 if not Is_Entity_Name (Def_Id) then
16114 Error_Pragma_Arg ("entity name required", Arg1);
16117 Def_Id := Entity (Def_Id);
16118 Set_Exported (Def_Id, Arg1);
16121 Process_Convention (C, Def_Id);
16123 -- A pragma that applies to a Ghost entity becomes Ghost for
16124 -- the purposes of legality checks and removal of ignored Ghost
16127 Mark_Ghost_Pragma (N, Def_Id);
16129 if Ekind (Def_Id) /= E_Constant then
16130 Note_Possible_Modification
16131 (Get_Pragma_Arg (Arg2), Sure => False);
16134 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
16135 Set_Exported (Def_Id, Arg2);
16138 -- If the entity is a deferred constant, propagate the information
16139 -- to the full view, because gigi elaborates the full view only.
16141 if Ekind (Def_Id) = E_Constant
16142 and then Present (Full_View (Def_Id))
16145 Id2 : constant Entity_Id := Full_View (Def_Id);
16147 Set_Is_Exported (Id2, Is_Exported (Def_Id));
16148 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
16149 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
16154 ---------------------
16155 -- Export_Function --
16156 ---------------------
16158 -- pragma Export_Function (
16159 -- [Internal =>] LOCAL_NAME
16160 -- [, [External =>] EXTERNAL_SYMBOL]
16161 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16162 -- [, [Result_Type =>] TYPE_DESIGNATOR]
16163 -- [, [Mechanism =>] MECHANISM]
16164 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
16166 -- EXTERNAL_SYMBOL ::=
16168 -- | static_string_EXPRESSION
16170 -- PARAMETER_TYPES ::=
16172 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16174 -- TYPE_DESIGNATOR ::=
16176 -- | subtype_Name ' Access
16180 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16182 -- MECHANISM_ASSOCIATION ::=
16183 -- [formal_parameter_NAME =>] MECHANISM_NAME
16185 -- MECHANISM_NAME ::=
16189 when Pragma_Export_Function => Export_Function : declare
16190 Args : Args_List (1 .. 6);
16191 Names : constant Name_List (1 .. 6) := (
16194 Name_Parameter_Types,
16197 Name_Result_Mechanism);
16199 Internal : Node_Id renames Args (1);
16200 External : Node_Id renames Args (2);
16201 Parameter_Types : Node_Id renames Args (3);
16202 Result_Type : Node_Id renames Args (4);
16203 Mechanism : Node_Id renames Args (5);
16204 Result_Mechanism : Node_Id renames Args (6);
16208 Gather_Associations (Names, Args);
16209 Process_Extended_Import_Export_Subprogram_Pragma (
16210 Arg_Internal => Internal,
16211 Arg_External => External,
16212 Arg_Parameter_Types => Parameter_Types,
16213 Arg_Result_Type => Result_Type,
16214 Arg_Mechanism => Mechanism,
16215 Arg_Result_Mechanism => Result_Mechanism);
16216 end Export_Function;
16218 -------------------
16219 -- Export_Object --
16220 -------------------
16222 -- pragma Export_Object (
16223 -- [Internal =>] LOCAL_NAME
16224 -- [, [External =>] EXTERNAL_SYMBOL]
16225 -- [, [Size =>] EXTERNAL_SYMBOL]);
16227 -- EXTERNAL_SYMBOL ::=
16229 -- | static_string_EXPRESSION
16231 -- PARAMETER_TYPES ::=
16233 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16235 -- TYPE_DESIGNATOR ::=
16237 -- | subtype_Name ' Access
16241 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16243 -- MECHANISM_ASSOCIATION ::=
16244 -- [formal_parameter_NAME =>] MECHANISM_NAME
16246 -- MECHANISM_NAME ::=
16250 when Pragma_Export_Object => Export_Object : declare
16251 Args : Args_List (1 .. 3);
16252 Names : constant Name_List (1 .. 3) := (
16257 Internal : Node_Id renames Args (1);
16258 External : Node_Id renames Args (2);
16259 Size : Node_Id renames Args (3);
16263 Gather_Associations (Names, Args);
16264 Process_Extended_Import_Export_Object_Pragma (
16265 Arg_Internal => Internal,
16266 Arg_External => External,
16270 ----------------------
16271 -- Export_Procedure --
16272 ----------------------
16274 -- pragma Export_Procedure (
16275 -- [Internal =>] LOCAL_NAME
16276 -- [, [External =>] EXTERNAL_SYMBOL]
16277 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16278 -- [, [Mechanism =>] MECHANISM]);
16280 -- EXTERNAL_SYMBOL ::=
16282 -- | static_string_EXPRESSION
16284 -- PARAMETER_TYPES ::=
16286 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16288 -- TYPE_DESIGNATOR ::=
16290 -- | subtype_Name ' Access
16294 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16296 -- MECHANISM_ASSOCIATION ::=
16297 -- [formal_parameter_NAME =>] MECHANISM_NAME
16299 -- MECHANISM_NAME ::=
16303 when Pragma_Export_Procedure => Export_Procedure : declare
16304 Args : Args_List (1 .. 4);
16305 Names : constant Name_List (1 .. 4) := (
16308 Name_Parameter_Types,
16311 Internal : Node_Id renames Args (1);
16312 External : Node_Id renames Args (2);
16313 Parameter_Types : Node_Id renames Args (3);
16314 Mechanism : Node_Id renames Args (4);
16318 Gather_Associations (Names, Args);
16319 Process_Extended_Import_Export_Subprogram_Pragma (
16320 Arg_Internal => Internal,
16321 Arg_External => External,
16322 Arg_Parameter_Types => Parameter_Types,
16323 Arg_Mechanism => Mechanism);
16324 end Export_Procedure;
16330 -- pragma Export_Value (
16331 -- [Value =>] static_integer_EXPRESSION,
16332 -- [Link_Name =>] static_string_EXPRESSION);
16334 when Pragma_Export_Value =>
16336 Check_Arg_Order ((Name_Value, Name_Link_Name));
16337 Check_Arg_Count (2);
16339 Check_Optional_Identifier (Arg1, Name_Value);
16340 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
16342 Check_Optional_Identifier (Arg2, Name_Link_Name);
16343 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
16345 -----------------------------
16346 -- Export_Valued_Procedure --
16347 -----------------------------
16349 -- pragma Export_Valued_Procedure (
16350 -- [Internal =>] LOCAL_NAME
16351 -- [, [External =>] EXTERNAL_SYMBOL,]
16352 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16353 -- [, [Mechanism =>] MECHANISM]);
16355 -- EXTERNAL_SYMBOL ::=
16357 -- | static_string_EXPRESSION
16359 -- PARAMETER_TYPES ::=
16361 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16363 -- TYPE_DESIGNATOR ::=
16365 -- | subtype_Name ' Access
16369 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16371 -- MECHANISM_ASSOCIATION ::=
16372 -- [formal_parameter_NAME =>] MECHANISM_NAME
16374 -- MECHANISM_NAME ::=
16378 when Pragma_Export_Valued_Procedure =>
16379 Export_Valued_Procedure : declare
16380 Args : Args_List (1 .. 4);
16381 Names : constant Name_List (1 .. 4) := (
16384 Name_Parameter_Types,
16387 Internal : Node_Id renames Args (1);
16388 External : Node_Id renames Args (2);
16389 Parameter_Types : Node_Id renames Args (3);
16390 Mechanism : Node_Id renames Args (4);
16394 Gather_Associations (Names, Args);
16395 Process_Extended_Import_Export_Subprogram_Pragma (
16396 Arg_Internal => Internal,
16397 Arg_External => External,
16398 Arg_Parameter_Types => Parameter_Types,
16399 Arg_Mechanism => Mechanism);
16400 end Export_Valued_Procedure;
16402 -------------------
16403 -- Extend_System --
16404 -------------------
16406 -- pragma Extend_System ([Name =>] Identifier);
16408 when Pragma_Extend_System =>
16410 Check_Valid_Configuration_Pragma;
16411 Check_Arg_Count (1);
16412 Check_Optional_Identifier (Arg1, Name_Name);
16413 Check_Arg_Is_Identifier (Arg1);
16415 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
16418 and then Name_Buffer (1 .. 4) = "aux_"
16420 if Present (System_Extend_Pragma_Arg) then
16421 if Chars (Get_Pragma_Arg (Arg1)) =
16422 Chars (Expression (System_Extend_Pragma_Arg))
16426 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
16427 Error_Pragma ("pragma% conflicts with that #");
16431 System_Extend_Pragma_Arg := Arg1;
16433 if not GNAT_Mode then
16434 System_Extend_Unit := Arg1;
16438 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
16441 ------------------------
16442 -- Extensions_Allowed --
16443 ------------------------
16445 -- pragma Extensions_Allowed (ON | OFF);
16447 when Pragma_Extensions_Allowed =>
16449 Check_Arg_Count (1);
16450 Check_No_Identifiers;
16451 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
16453 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
16454 Extensions_Allowed := True;
16455 Ada_Version := Ada_Version_Type'Last;
16458 Extensions_Allowed := False;
16459 Ada_Version := Ada_Version_Explicit;
16460 Ada_Version_Pragma := Empty;
16463 ------------------------
16464 -- Extensions_Visible --
16465 ------------------------
16467 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
16469 -- Characteristics:
16471 -- * Analysis - The annotation is fully analyzed immediately upon
16472 -- elaboration as its expression must be static.
16474 -- * Expansion - None.
16476 -- * Template - The annotation utilizes the generic template of the
16477 -- related subprogram [body] when it is:
16479 -- aspect on subprogram declaration
16480 -- aspect on stand-alone subprogram body
16481 -- pragma on stand-alone subprogram body
16483 -- The annotation must prepare its own template when it is:
16485 -- pragma on subprogram declaration
16487 -- * Globals - Capture of global references must occur after full
16490 -- * Instance - The annotation is instantiated automatically when
16491 -- the related generic subprogram [body] is instantiated except for
16492 -- the "pragma on subprogram declaration" case. In that scenario
16493 -- the annotation must instantiate itself.
16495 when Pragma_Extensions_Visible => Extensions_Visible : declare
16496 Formal : Entity_Id;
16497 Has_OK_Formal : Boolean := False;
16498 Spec_Id : Entity_Id;
16499 Subp_Decl : Node_Id;
16503 Check_No_Identifiers;
16504 Check_At_Most_N_Arguments (1);
16507 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
16509 -- Abstract subprogram declaration
16511 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
16514 -- Generic subprogram declaration
16516 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
16519 -- Body acts as spec
16521 elsif Nkind (Subp_Decl) = N_Subprogram_Body
16522 and then No (Corresponding_Spec (Subp_Decl))
16526 -- Body stub acts as spec
16528 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
16529 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
16533 -- Subprogram declaration
16535 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
16538 -- Otherwise the pragma is associated with an illegal construct
16541 Error_Pragma ("pragma % must apply to a subprogram");
16545 -- Mark the pragma as Ghost if the related subprogram is also
16546 -- Ghost. This also ensures that any expansion performed further
16547 -- below will produce Ghost nodes.
16549 Spec_Id := Unique_Defining_Entity (Subp_Decl);
16550 Mark_Ghost_Pragma (N, Spec_Id);
16552 -- Chain the pragma on the contract for completeness
16554 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
16556 -- The legality checks of pragma Extension_Visible are affected
16557 -- by the SPARK mode in effect. Analyze all pragmas in specific
16560 Analyze_If_Present (Pragma_SPARK_Mode);
16562 -- Examine the formals of the related subprogram
16564 Formal := First_Formal (Spec_Id);
16565 while Present (Formal) loop
16567 -- At least one of the formals is of a specific tagged type,
16568 -- the pragma is legal.
16570 if Is_Specific_Tagged_Type (Etype (Formal)) then
16571 Has_OK_Formal := True;
16574 -- A generic subprogram with at least one formal of a private
16575 -- type ensures the legality of the pragma because the actual
16576 -- may be specifically tagged. Note that this is verified by
16577 -- the check above at instantiation time.
16579 elsif Is_Private_Type (Etype (Formal))
16580 and then Is_Generic_Type (Etype (Formal))
16582 Has_OK_Formal := True;
16586 Next_Formal (Formal);
16589 if not Has_OK_Formal then
16590 Error_Msg_Name_1 := Pname;
16591 Error_Msg_N (Fix_Error ("incorrect placement of pragma %"), N);
16593 ("\subprogram & lacks parameter of specific tagged or "
16594 & "generic private type", N, Spec_Id);
16599 -- Analyze the Boolean expression (if any)
16601 if Present (Arg1) then
16602 Check_Static_Boolean_Expression
16603 (Expression (Get_Argument (N, Spec_Id)));
16605 end Extensions_Visible;
16611 -- pragma External (
16612 -- [ Convention =>] convention_IDENTIFIER,
16613 -- [ Entity =>] LOCAL_NAME
16614 -- [, [External_Name =>] static_string_EXPRESSION ]
16615 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16617 when Pragma_External => External : declare
16620 pragma Warnings (Off, C);
16627 Name_External_Name,
16629 Check_At_Least_N_Arguments (2);
16630 Check_At_Most_N_Arguments (4);
16631 Process_Convention (C, E);
16633 -- A pragma that applies to a Ghost entity becomes Ghost for the
16634 -- purposes of legality checks and removal of ignored Ghost code.
16636 Mark_Ghost_Pragma (N, E);
16638 Note_Possible_Modification
16639 (Get_Pragma_Arg (Arg2), Sure => False);
16640 Process_Interface_Name (E, Arg3, Arg4, N);
16641 Set_Exported (E, Arg2);
16644 --------------------------
16645 -- External_Name_Casing --
16646 --------------------------
16648 -- pragma External_Name_Casing (
16649 -- UPPERCASE | LOWERCASE
16650 -- [, AS_IS | UPPERCASE | LOWERCASE]);
16652 when Pragma_External_Name_Casing =>
16654 Check_No_Identifiers;
16656 if Arg_Count = 2 then
16657 Check_Arg_Is_One_Of
16658 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
16660 case Chars (Get_Pragma_Arg (Arg2)) is
16662 Opt.External_Name_Exp_Casing := As_Is;
16664 when Name_Uppercase =>
16665 Opt.External_Name_Exp_Casing := Uppercase;
16667 when Name_Lowercase =>
16668 Opt.External_Name_Exp_Casing := Lowercase;
16675 Check_Arg_Count (1);
16678 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
16680 case Chars (Get_Pragma_Arg (Arg1)) is
16681 when Name_Uppercase =>
16682 Opt.External_Name_Imp_Casing := Uppercase;
16684 when Name_Lowercase =>
16685 Opt.External_Name_Imp_Casing := Lowercase;
16695 -- pragma Fast_Math;
16697 when Pragma_Fast_Math =>
16699 Check_No_Identifiers;
16700 Check_Valid_Configuration_Pragma;
16703 --------------------------
16704 -- Favor_Top_Level --
16705 --------------------------
16707 -- pragma Favor_Top_Level (type_NAME);
16709 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
16714 Check_No_Identifiers;
16715 Check_Arg_Count (1);
16716 Check_Arg_Is_Local_Name (Arg1);
16717 Typ := Entity (Get_Pragma_Arg (Arg1));
16719 -- A pragma that applies to a Ghost entity becomes Ghost for the
16720 -- purposes of legality checks and removal of ignored Ghost code.
16722 Mark_Ghost_Pragma (N, Typ);
16724 -- If it's an access-to-subprogram type (in particular, not a
16725 -- subtype), set the flag on that type.
16727 if Is_Access_Subprogram_Type (Typ) then
16728 Set_Can_Use_Internal_Rep (Typ, False);
16730 -- Otherwise it's an error (name denotes the wrong sort of entity)
16734 ("access-to-subprogram type expected",
16735 Get_Pragma_Arg (Arg1));
16737 end Favor_Top_Level;
16739 ---------------------------
16740 -- Finalize_Storage_Only --
16741 ---------------------------
16743 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
16745 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
16746 Assoc : constant Node_Id := Arg1;
16747 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
16752 Check_No_Identifiers;
16753 Check_Arg_Count (1);
16754 Check_Arg_Is_Local_Name (Arg1);
16756 Find_Type (Type_Id);
16757 Typ := Entity (Type_Id);
16760 or else Rep_Item_Too_Early (Typ, N)
16764 Typ := Underlying_Type (Typ);
16767 if not Is_Controlled (Typ) then
16768 Error_Pragma ("pragma% must specify controlled type");
16771 Check_First_Subtype (Arg1);
16773 if Finalize_Storage_Only (Typ) then
16774 Error_Pragma ("duplicate pragma%, only one allowed");
16776 elsif not Rep_Item_Too_Late (Typ, N) then
16777 Set_Finalize_Storage_Only (Base_Type (Typ), True);
16779 end Finalize_Storage;
16785 -- pragma Ghost [ (boolean_EXPRESSION) ];
16787 when Pragma_Ghost => Ghost : declare
16791 Orig_Stmt : Node_Id;
16792 Prev_Id : Entity_Id;
16797 Check_No_Identifiers;
16798 Check_At_Most_N_Arguments (1);
16802 while Present (Stmt) loop
16804 -- Skip prior pragmas, but check for duplicates
16806 if Nkind (Stmt) = N_Pragma then
16807 if Pragma_Name (Stmt) = Pname then
16814 -- Task unit declared without a definition cannot be subject to
16815 -- pragma Ghost (SPARK RM 6.9(19)).
16817 elsif Nkind (Stmt) in
16818 N_Single_Task_Declaration | N_Task_Type_Declaration
16820 Error_Pragma ("pragma % cannot apply to a task type");
16823 -- Skip internally generated code
16825 elsif not Comes_From_Source (Stmt) then
16826 Orig_Stmt := Original_Node (Stmt);
16828 -- When pragma Ghost applies to an untagged derivation, the
16829 -- derivation is transformed into a [sub]type declaration.
16832 N_Full_Type_Declaration | N_Subtype_Declaration
16833 and then Comes_From_Source (Orig_Stmt)
16834 and then Nkind (Orig_Stmt) = N_Full_Type_Declaration
16835 and then Nkind (Type_Definition (Orig_Stmt)) =
16836 N_Derived_Type_Definition
16838 Id := Defining_Entity (Stmt);
16841 -- When pragma Ghost applies to an object declaration which
16842 -- is initialized by means of a function call that returns
16843 -- on the secondary stack, the object declaration becomes a
16846 elsif Nkind (Stmt) = N_Object_Renaming_Declaration
16847 and then Comes_From_Source (Orig_Stmt)
16848 and then Nkind (Orig_Stmt) = N_Object_Declaration
16850 Id := Defining_Entity (Stmt);
16853 -- When pragma Ghost applies to an expression function, the
16854 -- expression function is transformed into a subprogram.
16856 elsif Nkind (Stmt) = N_Subprogram_Declaration
16857 and then Comes_From_Source (Orig_Stmt)
16858 and then Nkind (Orig_Stmt) = N_Expression_Function
16860 Id := Defining_Entity (Stmt);
16864 -- The pragma applies to a legal construct, stop the traversal
16866 elsif Nkind (Stmt) in N_Abstract_Subprogram_Declaration
16867 | N_Full_Type_Declaration
16868 | N_Generic_Subprogram_Declaration
16869 | N_Object_Declaration
16870 | N_Private_Extension_Declaration
16871 | N_Private_Type_Declaration
16872 | N_Subprogram_Declaration
16873 | N_Subtype_Declaration
16875 Id := Defining_Entity (Stmt);
16878 -- The pragma does not apply to a legal construct, issue an
16879 -- error and stop the analysis.
16883 ("pragma % must apply to an object, package, subprogram "
16888 Stmt := Prev (Stmt);
16891 Context := Parent (N);
16893 -- Handle compilation units
16895 if Nkind (Context) = N_Compilation_Unit_Aux then
16896 Context := Unit (Parent (Context));
16899 -- Protected and task types cannot be subject to pragma Ghost
16900 -- (SPARK RM 6.9(19)).
16902 if Nkind (Context) in N_Protected_Body | N_Protected_Definition
16904 Error_Pragma ("pragma % cannot apply to a protected type");
16907 elsif Nkind (Context) in N_Task_Body | N_Task_Definition then
16908 Error_Pragma ("pragma % cannot apply to a task type");
16914 -- When pragma Ghost is associated with a [generic] package, it
16915 -- appears in the visible declarations.
16917 if Nkind (Context) = N_Package_Specification
16918 and then Present (Visible_Declarations (Context))
16919 and then List_Containing (N) = Visible_Declarations (Context)
16921 Id := Defining_Entity (Context);
16923 -- Pragma Ghost applies to a stand-alone subprogram body
16925 elsif Nkind (Context) = N_Subprogram_Body
16926 and then No (Corresponding_Spec (Context))
16928 Id := Defining_Entity (Context);
16930 -- Pragma Ghost applies to a subprogram declaration that acts
16931 -- as a compilation unit.
16933 elsif Nkind (Context) = N_Subprogram_Declaration then
16934 Id := Defining_Entity (Context);
16936 -- Pragma Ghost applies to a generic subprogram
16938 elsif Nkind (Context) = N_Generic_Subprogram_Declaration then
16939 Id := Defining_Entity (Specification (Context));
16945 ("pragma % must apply to an object, package, subprogram or "
16950 -- Handle completions of types and constants that are subject to
16953 if Is_Record_Type (Id) or else Ekind (Id) = E_Constant then
16954 Prev_Id := Incomplete_Or_Partial_View (Id);
16956 if Present (Prev_Id) and then not Is_Ghost_Entity (Prev_Id) then
16957 Error_Msg_Name_1 := Pname;
16959 -- The full declaration of a deferred constant cannot be
16960 -- subject to pragma Ghost unless the deferred declaration
16961 -- is also Ghost (SPARK RM 6.9(9)).
16963 if Ekind (Prev_Id) = E_Constant then
16964 Error_Msg_Name_1 := Pname;
16965 Error_Msg_NE (Fix_Error
16966 ("pragma % must apply to declaration of deferred "
16967 & "constant &"), N, Id);
16970 -- Pragma Ghost may appear on the full view of an incomplete
16971 -- type because the incomplete declaration lacks aspects and
16972 -- cannot be subject to pragma Ghost.
16974 elsif Ekind (Prev_Id) = E_Incomplete_Type then
16977 -- The full declaration of a type cannot be subject to
16978 -- pragma Ghost unless the partial view is also Ghost
16979 -- (SPARK RM 6.9(9)).
16982 Error_Msg_NE (Fix_Error
16983 ("pragma % must apply to partial view of type &"),
16989 -- A synchronized object cannot be subject to pragma Ghost
16990 -- (SPARK RM 6.9(19)).
16992 elsif Ekind (Id) = E_Variable then
16993 if Is_Protected_Type (Etype (Id)) then
16994 Error_Pragma ("pragma % cannot apply to a protected object");
16997 elsif Is_Task_Type (Etype (Id)) then
16998 Error_Pragma ("pragma % cannot apply to a task object");
17003 -- Analyze the Boolean expression (if any)
17005 if Present (Arg1) then
17006 Expr := Get_Pragma_Arg (Arg1);
17008 Analyze_And_Resolve (Expr, Standard_Boolean);
17010 if Is_OK_Static_Expression (Expr) then
17012 -- "Ghostness" cannot be turned off once enabled within a
17013 -- region (SPARK RM 6.9(6)).
17015 if Is_False (Expr_Value (Expr))
17016 and then Ghost_Mode > None
17019 ("pragma % with value False cannot appear in enabled "
17024 -- Otherwise the expression is not static
17028 ("expression of pragma % must be static", Expr);
17033 Set_Is_Ghost_Entity (Id);
17040 -- pragma Global (GLOBAL_SPECIFICATION);
17042 -- GLOBAL_SPECIFICATION ::=
17045 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
17047 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
17049 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
17050 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
17051 -- GLOBAL_ITEM ::= NAME
17053 -- Characteristics:
17055 -- * Analysis - The annotation undergoes initial checks to verify
17056 -- the legal placement and context. Secondary checks fully analyze
17057 -- the dependency clauses in:
17059 -- Analyze_Global_In_Decl_Part
17061 -- * Expansion - None.
17063 -- * Template - The annotation utilizes the generic template of the
17064 -- related subprogram [body] when it is:
17066 -- aspect on subprogram declaration
17067 -- aspect on stand-alone subprogram body
17068 -- pragma on stand-alone subprogram body
17070 -- The annotation must prepare its own template when it is:
17072 -- pragma on subprogram declaration
17074 -- * Globals - Capture of global references must occur after full
17077 -- * Instance - The annotation is instantiated automatically when
17078 -- the related generic subprogram [body] is instantiated except for
17079 -- the "pragma on subprogram declaration" case. In that scenario
17080 -- the annotation must instantiate itself.
17082 when Pragma_Global => Global : declare
17084 Spec_Id : Entity_Id;
17085 Subp_Decl : Node_Id;
17088 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
17092 -- Chain the pragma on the contract for further processing by
17093 -- Analyze_Global_In_Decl_Part.
17095 Add_Contract_Item (N, Spec_Id);
17097 -- Fully analyze the pragma when it appears inside an entry
17098 -- or subprogram body because it cannot benefit from forward
17101 if Nkind (Subp_Decl) in N_Entry_Body
17102 | N_Subprogram_Body
17103 | N_Subprogram_Body_Stub
17105 -- The legality checks of pragmas Depends and Global are
17106 -- affected by the SPARK mode in effect and the volatility
17107 -- of the context. In addition these two pragmas are subject
17108 -- to an inherent order:
17113 -- Analyze all these pragmas in the order outlined above
17115 Analyze_If_Present (Pragma_SPARK_Mode);
17116 Analyze_If_Present (Pragma_Volatile_Function);
17117 Analyze_Global_In_Decl_Part (N);
17118 Analyze_If_Present (Pragma_Depends);
17127 -- pragma Ident (static_string_EXPRESSION)
17129 -- Note: pragma Comment shares this processing. Pragma Ident is
17130 -- identical in effect to pragma Commment.
17132 when Pragma_Comment
17140 Check_Arg_Count (1);
17141 Check_No_Identifiers;
17142 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
17145 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
17152 GP := Parent (Parent (N));
17155 N_Package_Declaration | N_Generic_Package_Declaration
17160 -- If we have a compilation unit, then record the ident value,
17161 -- checking for improper duplication.
17163 if Nkind (GP) = N_Compilation_Unit then
17164 CS := Ident_String (Current_Sem_Unit);
17166 if Present (CS) then
17168 -- If we have multiple instances, concatenate them.
17170 Start_String (Strval (CS));
17171 Store_String_Char (' ');
17172 Store_String_Chars (Strval (Str));
17173 Set_Strval (CS, End_String);
17176 Set_Ident_String (Current_Sem_Unit, Str);
17179 -- For subunits, we just ignore the Ident, since in GNAT these
17180 -- are not separate object files, and hence not separate units
17181 -- in the unit table.
17183 elsif Nkind (GP) = N_Subunit then
17189 -------------------
17190 -- Ignore_Pragma --
17191 -------------------
17193 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
17195 -- Entirely handled in the parser, nothing to do here
17197 when Pragma_Ignore_Pragma =>
17200 ----------------------------
17201 -- Implementation_Defined --
17202 ----------------------------
17204 -- pragma Implementation_Defined (LOCAL_NAME);
17206 -- Marks previously declared entity as implementation defined. For
17207 -- an overloaded entity, applies to the most recent homonym.
17209 -- pragma Implementation_Defined;
17211 -- The form with no arguments appears anywhere within a scope, most
17212 -- typically a package spec, and indicates that all entities that are
17213 -- defined within the package spec are Implementation_Defined.
17215 when Pragma_Implementation_Defined => Implementation_Defined : declare
17220 Check_No_Identifiers;
17222 -- Form with no arguments
17224 if Arg_Count = 0 then
17225 Set_Is_Implementation_Defined (Current_Scope);
17227 -- Form with one argument
17230 Check_Arg_Count (1);
17231 Check_Arg_Is_Local_Name (Arg1);
17232 Ent := Entity (Get_Pragma_Arg (Arg1));
17233 Set_Is_Implementation_Defined (Ent);
17235 end Implementation_Defined;
17241 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
17243 -- IMPLEMENTATION_KIND ::=
17244 -- By_Entry | By_Protected_Procedure | By_Any | Optional
17246 -- "By_Any" and "Optional" are treated as synonyms in order to
17247 -- support Ada 2012 aspect Synchronization.
17249 when Pragma_Implemented => Implemented : declare
17250 Proc_Id : Entity_Id;
17255 Check_Arg_Count (2);
17256 Check_No_Identifiers;
17257 Check_Arg_Is_Identifier (Arg1);
17258 Check_Arg_Is_Local_Name (Arg1);
17259 Check_Arg_Is_One_Of (Arg2,
17262 Name_By_Protected_Procedure,
17265 -- Extract the name of the local procedure
17267 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
17269 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
17270 -- primitive procedure of a synchronized tagged type.
17272 if Ekind (Proc_Id) = E_Procedure
17273 and then Is_Primitive (Proc_Id)
17274 and then Present (First_Formal (Proc_Id))
17276 Typ := Etype (First_Formal (Proc_Id));
17278 if Is_Tagged_Type (Typ)
17281 -- Check for a protected, a synchronized or a task interface
17283 ((Is_Interface (Typ)
17284 and then Is_Synchronized_Interface (Typ))
17286 -- Check for a protected type or a task type that implements
17290 (Is_Concurrent_Record_Type (Typ)
17291 and then Present (Interfaces (Typ)))
17293 -- In analysis-only mode, examine original protected type
17296 (Nkind (Parent (Typ)) = N_Protected_Type_Declaration
17297 and then Present (Interface_List (Parent (Typ))))
17299 -- Check for a private record extension with keyword
17303 (Ekind (Typ) in E_Record_Type_With_Private
17304 | E_Record_Subtype_With_Private
17305 and then Synchronized_Present (Parent (Typ))))
17310 ("controlling formal must be of synchronized tagged type",
17315 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
17316 -- By_Protected_Procedure to the primitive procedure of a task
17319 if Chars (Get_Pragma_Arg (Arg2)) = Name_By_Protected_Procedure
17320 and then Is_Interface (Typ)
17321 and then Is_Task_Interface (Typ)
17324 ("implementation kind By_Protected_Procedure cannot be "
17325 & "applied to a task interface primitive", Arg2);
17329 -- Procedures declared inside a protected type must be accepted
17331 elsif Ekind (Proc_Id) = E_Procedure
17332 and then Is_Protected_Type (Scope (Proc_Id))
17336 -- The first argument is not a primitive procedure
17340 ("pragma % must be applied to a primitive procedure", Arg1);
17344 -- Ada 2012 (AI12-0279): Cannot apply the implementation_kind
17345 -- By_Protected_Procedure to a procedure that has aspect Yield
17347 if Chars (Get_Pragma_Arg (Arg2)) = Name_By_Protected_Procedure
17348 and then Has_Yield_Aspect (Proc_Id)
17351 ("implementation kind By_Protected_Procedure cannot be "
17352 & "applied to entities with aspect 'Yield", Arg2);
17356 Record_Rep_Item (Proc_Id, N);
17359 ----------------------
17360 -- Implicit_Packing --
17361 ----------------------
17363 -- pragma Implicit_Packing;
17365 when Pragma_Implicit_Packing =>
17367 Check_Arg_Count (0);
17368 Implicit_Packing := True;
17375 -- [Convention =>] convention_IDENTIFIER,
17376 -- [Entity =>] LOCAL_NAME
17377 -- [, [External_Name =>] static_string_EXPRESSION ]
17378 -- [, [Link_Name =>] static_string_EXPRESSION ]);
17380 when Pragma_Import =>
17381 Check_Ada_83_Warning;
17385 Name_External_Name,
17388 Check_At_Least_N_Arguments (2);
17389 Check_At_Most_N_Arguments (4);
17390 Process_Import_Or_Interface;
17392 ---------------------
17393 -- Import_Function --
17394 ---------------------
17396 -- pragma Import_Function (
17397 -- [Internal =>] LOCAL_NAME,
17398 -- [, [External =>] EXTERNAL_SYMBOL]
17399 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17400 -- [, [Result_Type =>] SUBTYPE_MARK]
17401 -- [, [Mechanism =>] MECHANISM]
17402 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
17404 -- EXTERNAL_SYMBOL ::=
17406 -- | static_string_EXPRESSION
17408 -- PARAMETER_TYPES ::=
17410 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17412 -- TYPE_DESIGNATOR ::=
17414 -- | subtype_Name ' Access
17418 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17420 -- MECHANISM_ASSOCIATION ::=
17421 -- [formal_parameter_NAME =>] MECHANISM_NAME
17423 -- MECHANISM_NAME ::=
17427 when Pragma_Import_Function => Import_Function : declare
17428 Args : Args_List (1 .. 6);
17429 Names : constant Name_List (1 .. 6) := (
17432 Name_Parameter_Types,
17435 Name_Result_Mechanism);
17437 Internal : Node_Id renames Args (1);
17438 External : Node_Id renames Args (2);
17439 Parameter_Types : Node_Id renames Args (3);
17440 Result_Type : Node_Id renames Args (4);
17441 Mechanism : Node_Id renames Args (5);
17442 Result_Mechanism : Node_Id renames Args (6);
17446 Gather_Associations (Names, Args);
17447 Process_Extended_Import_Export_Subprogram_Pragma (
17448 Arg_Internal => Internal,
17449 Arg_External => External,
17450 Arg_Parameter_Types => Parameter_Types,
17451 Arg_Result_Type => Result_Type,
17452 Arg_Mechanism => Mechanism,
17453 Arg_Result_Mechanism => Result_Mechanism);
17454 end Import_Function;
17456 -------------------
17457 -- Import_Object --
17458 -------------------
17460 -- pragma Import_Object (
17461 -- [Internal =>] LOCAL_NAME
17462 -- [, [External =>] EXTERNAL_SYMBOL]
17463 -- [, [Size =>] EXTERNAL_SYMBOL]);
17465 -- EXTERNAL_SYMBOL ::=
17467 -- | static_string_EXPRESSION
17469 when Pragma_Import_Object => Import_Object : declare
17470 Args : Args_List (1 .. 3);
17471 Names : constant Name_List (1 .. 3) := (
17476 Internal : Node_Id renames Args (1);
17477 External : Node_Id renames Args (2);
17478 Size : Node_Id renames Args (3);
17482 Gather_Associations (Names, Args);
17483 Process_Extended_Import_Export_Object_Pragma (
17484 Arg_Internal => Internal,
17485 Arg_External => External,
17489 ----------------------
17490 -- Import_Procedure --
17491 ----------------------
17493 -- pragma Import_Procedure (
17494 -- [Internal =>] LOCAL_NAME
17495 -- [, [External =>] EXTERNAL_SYMBOL]
17496 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17497 -- [, [Mechanism =>] MECHANISM]);
17499 -- EXTERNAL_SYMBOL ::=
17501 -- | static_string_EXPRESSION
17503 -- PARAMETER_TYPES ::=
17505 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17507 -- TYPE_DESIGNATOR ::=
17509 -- | subtype_Name ' Access
17513 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17515 -- MECHANISM_ASSOCIATION ::=
17516 -- [formal_parameter_NAME =>] MECHANISM_NAME
17518 -- MECHANISM_NAME ::=
17522 when Pragma_Import_Procedure => Import_Procedure : declare
17523 Args : Args_List (1 .. 4);
17524 Names : constant Name_List (1 .. 4) := (
17527 Name_Parameter_Types,
17530 Internal : Node_Id renames Args (1);
17531 External : Node_Id renames Args (2);
17532 Parameter_Types : Node_Id renames Args (3);
17533 Mechanism : Node_Id renames Args (4);
17537 Gather_Associations (Names, Args);
17538 Process_Extended_Import_Export_Subprogram_Pragma (
17539 Arg_Internal => Internal,
17540 Arg_External => External,
17541 Arg_Parameter_Types => Parameter_Types,
17542 Arg_Mechanism => Mechanism);
17543 end Import_Procedure;
17545 -----------------------------
17546 -- Import_Valued_Procedure --
17547 -----------------------------
17549 -- pragma Import_Valued_Procedure (
17550 -- [Internal =>] LOCAL_NAME
17551 -- [, [External =>] EXTERNAL_SYMBOL]
17552 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17553 -- [, [Mechanism =>] MECHANISM]);
17555 -- EXTERNAL_SYMBOL ::=
17557 -- | static_string_EXPRESSION
17559 -- PARAMETER_TYPES ::=
17561 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17563 -- TYPE_DESIGNATOR ::=
17565 -- | subtype_Name ' Access
17569 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17571 -- MECHANISM_ASSOCIATION ::=
17572 -- [formal_parameter_NAME =>] MECHANISM_NAME
17574 -- MECHANISM_NAME ::=
17578 when Pragma_Import_Valued_Procedure =>
17579 Import_Valued_Procedure : declare
17580 Args : Args_List (1 .. 4);
17581 Names : constant Name_List (1 .. 4) := (
17584 Name_Parameter_Types,
17587 Internal : Node_Id renames Args (1);
17588 External : Node_Id renames Args (2);
17589 Parameter_Types : Node_Id renames Args (3);
17590 Mechanism : Node_Id renames Args (4);
17594 Gather_Associations (Names, Args);
17595 Process_Extended_Import_Export_Subprogram_Pragma (
17596 Arg_Internal => Internal,
17597 Arg_External => External,
17598 Arg_Parameter_Types => Parameter_Types,
17599 Arg_Mechanism => Mechanism);
17600 end Import_Valued_Procedure;
17606 -- pragma Independent (LOCAL_NAME);
17608 when Pragma_Independent =>
17609 Process_Atomic_Independent_Shared_Volatile;
17611 ----------------------------
17612 -- Independent_Components --
17613 ----------------------------
17615 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
17617 when Pragma_Independent_Components => Independent_Components : declare
17624 Check_Ada_83_Warning;
17626 Check_No_Identifiers;
17627 Check_Arg_Count (1);
17628 Check_Arg_Is_Local_Name (Arg1);
17629 E_Id := Get_Pragma_Arg (Arg1);
17631 if Etype (E_Id) = Any_Type then
17635 E := Entity (E_Id);
17637 -- A record type with a self-referential component of anonymous
17638 -- access type is given an incomplete view in order to handle the
17641 -- type Rec is record
17642 -- Self : access Rec;
17648 -- type Ptr is access Rec;
17649 -- type Rec is record
17653 -- Since the incomplete view is now the initial view of the type,
17654 -- the argument of the pragma will reference the incomplete view,
17655 -- but this view is illegal according to the semantics of the
17658 -- Obtain the full view of an internally-generated incomplete type
17659 -- only. This way an attempt to associate the pragma with a source
17660 -- incomplete type is still caught.
17662 if Ekind (E) = E_Incomplete_Type
17663 and then not Comes_From_Source (E)
17664 and then Present (Full_View (E))
17666 E := Full_View (E);
17669 -- A pragma that applies to a Ghost entity becomes Ghost for the
17670 -- purposes of legality checks and removal of ignored Ghost code.
17672 Mark_Ghost_Pragma (N, E);
17674 -- Check duplicate before we chain ourselves
17676 Check_Duplicate_Pragma (E);
17678 -- Check appropriate entity
17680 if Rep_Item_Too_Early (E, N)
17682 Rep_Item_Too_Late (E, N)
17687 D := Declaration_Node (E);
17689 -- The flag is set on the base type, or on the object
17691 if Nkind (D) = N_Full_Type_Declaration
17692 and then (Is_Array_Type (E) or else Is_Record_Type (E))
17694 Set_Has_Independent_Components (Base_Type (E));
17695 Record_Independence_Check (N, Base_Type (E));
17697 -- For record type, set all components independent
17699 if Is_Record_Type (E) then
17700 C := First_Component (E);
17701 while Present (C) loop
17702 Set_Is_Independent (C);
17703 Next_Component (C);
17707 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
17708 and then Nkind (D) = N_Object_Declaration
17709 and then Nkind (Object_Definition (D)) =
17710 N_Constrained_Array_Definition
17712 Set_Has_Independent_Components (E);
17713 Record_Independence_Check (N, E);
17716 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
17718 end Independent_Components;
17720 -----------------------
17721 -- Initial_Condition --
17722 -----------------------
17724 -- pragma Initial_Condition (boolean_EXPRESSION);
17726 -- Characteristics:
17728 -- * Analysis - The annotation undergoes initial checks to verify
17729 -- the legal placement and context. Secondary checks preanalyze the
17732 -- Analyze_Initial_Condition_In_Decl_Part
17734 -- * Expansion - The annotation is expanded during the expansion of
17735 -- the package body whose declaration is subject to the annotation
17738 -- Expand_Pragma_Initial_Condition
17740 -- * Template - The annotation utilizes the generic template of the
17741 -- related package declaration.
17743 -- * Globals - Capture of global references must occur after full
17746 -- * Instance - The annotation is instantiated automatically when
17747 -- the related generic package is instantiated.
17749 when Pragma_Initial_Condition => Initial_Condition : declare
17750 Pack_Decl : Node_Id;
17751 Pack_Id : Entity_Id;
17755 Check_No_Identifiers;
17756 Check_Arg_Count (1);
17758 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
17760 if Nkind (Pack_Decl) not in
17761 N_Generic_Package_Declaration | N_Package_Declaration
17767 Pack_Id := Defining_Entity (Pack_Decl);
17769 -- A pragma that applies to a Ghost entity becomes Ghost for the
17770 -- purposes of legality checks and removal of ignored Ghost code.
17772 Mark_Ghost_Pragma (N, Pack_Id);
17774 -- Chain the pragma on the contract for further processing by
17775 -- Analyze_Initial_Condition_In_Decl_Part.
17777 Add_Contract_Item (N, Pack_Id);
17779 -- The legality checks of pragmas Abstract_State, Initializes, and
17780 -- Initial_Condition are affected by the SPARK mode in effect. In
17781 -- addition, these three pragmas are subject to an inherent order:
17783 -- 1) Abstract_State
17785 -- 3) Initial_Condition
17787 -- Analyze all these pragmas in the order outlined above
17789 Analyze_If_Present (Pragma_SPARK_Mode);
17790 Analyze_If_Present (Pragma_Abstract_State);
17791 Analyze_If_Present (Pragma_Initializes);
17792 end Initial_Condition;
17794 ------------------------
17795 -- Initialize_Scalars --
17796 ------------------------
17798 -- pragma Initialize_Scalars
17799 -- [ ( TYPE_VALUE_PAIR {, TYPE_VALUE_PAIR} ) ];
17801 -- TYPE_VALUE_PAIR ::=
17802 -- SCALAR_TYPE => static_EXPRESSION
17808 -- | Long_Long_Flat
17818 when Pragma_Initialize_Scalars => Do_Initialize_Scalars : declare
17819 Seen : array (Scalar_Id) of Node_Id := (others => Empty);
17820 -- This collection holds the individual pairs which specify the
17821 -- invalid values of their respective scalar types.
17823 procedure Analyze_Float_Value
17824 (Scal_Typ : Float_Scalar_Id;
17825 Val_Expr : Node_Id);
17826 -- Analyze a type value pair associated with float type Scal_Typ
17827 -- and expression Val_Expr.
17829 procedure Analyze_Integer_Value
17830 (Scal_Typ : Integer_Scalar_Id;
17831 Val_Expr : Node_Id);
17832 -- Analyze a type value pair associated with integer type Scal_Typ
17833 -- and expression Val_Expr.
17835 procedure Analyze_Type_Value_Pair (Pair : Node_Id);
17836 -- Analyze type value pair Pair
17838 -------------------------
17839 -- Analyze_Float_Value --
17840 -------------------------
17842 procedure Analyze_Float_Value
17843 (Scal_Typ : Float_Scalar_Id;
17844 Val_Expr : Node_Id)
17847 Analyze_And_Resolve (Val_Expr, Any_Real);
17849 if Is_OK_Static_Expression (Val_Expr) then
17850 Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value_R (Val_Expr));
17853 Error_Msg_Name_1 := Scal_Typ;
17854 Error_Msg_N ("value for type % must be static", Val_Expr);
17856 end Analyze_Float_Value;
17858 ---------------------------
17859 -- Analyze_Integer_Value --
17860 ---------------------------
17862 procedure Analyze_Integer_Value
17863 (Scal_Typ : Integer_Scalar_Id;
17864 Val_Expr : Node_Id)
17867 Analyze_And_Resolve (Val_Expr, Any_Integer);
17869 if Is_OK_Static_Expression (Val_Expr) then
17870 Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value (Val_Expr));
17873 Error_Msg_Name_1 := Scal_Typ;
17874 Error_Msg_N ("value for type % must be static", Val_Expr);
17876 end Analyze_Integer_Value;
17878 -----------------------------
17879 -- Analyze_Type_Value_Pair --
17880 -----------------------------
17882 procedure Analyze_Type_Value_Pair (Pair : Node_Id) is
17883 Scal_Typ : constant Name_Id := Chars (Pair);
17884 Val_Expr : constant Node_Id := Expression (Pair);
17885 Prev_Pair : Node_Id;
17888 if Scal_Typ in Scalar_Id then
17889 Prev_Pair := Seen (Scal_Typ);
17891 -- Prevent multiple attempts to set a value for a scalar
17894 if Present (Prev_Pair) then
17895 Error_Msg_Name_1 := Scal_Typ;
17897 ("cannot specify multiple invalid values for type %",
17900 Error_Msg_Sloc := Sloc (Prev_Pair);
17901 Error_Msg_N ("previous value set #", Pair);
17903 -- Ignore the effects of the pair, but do not halt the
17904 -- analysis of the pragma altogether.
17908 -- Otherwise capture the first pair for this scalar type
17911 Seen (Scal_Typ) := Pair;
17914 if Scal_Typ in Float_Scalar_Id then
17915 Analyze_Float_Value (Scal_Typ, Val_Expr);
17917 else pragma Assert (Scal_Typ in Integer_Scalar_Id);
17918 Analyze_Integer_Value (Scal_Typ, Val_Expr);
17921 -- Otherwise the scalar family is illegal
17924 Error_Msg_Name_1 := Pname;
17926 ("argument of pragma % must denote valid scalar family",
17929 end Analyze_Type_Value_Pair;
17933 Pairs : constant List_Id := Pragma_Argument_Associations (N);
17936 -- Start of processing for Do_Initialize_Scalars
17940 Check_Valid_Configuration_Pragma;
17941 Check_Restriction (No_Initialize_Scalars, N);
17943 -- Ignore the effects of the pragma when No_Initialize_Scalars is
17946 if Restriction_Active (No_Initialize_Scalars) then
17949 -- Initialize_Scalars creates false positives in CodePeer, and
17950 -- incorrect negative results in GNATprove mode, so ignore this
17951 -- pragma in these modes.
17953 elsif CodePeer_Mode or GNATprove_Mode then
17956 -- Otherwise analyze the pragma
17959 if Present (Pairs) then
17961 -- Install Standard in order to provide access to primitive
17962 -- types in case the expressions contain attributes such as
17965 Push_Scope (Standard_Standard);
17967 Pair := First (Pairs);
17968 while Present (Pair) loop
17969 Analyze_Type_Value_Pair (Pair);
17978 Init_Or_Norm_Scalars := True;
17979 Initialize_Scalars := True;
17981 end Do_Initialize_Scalars;
17987 -- pragma Initializes (INITIALIZATION_LIST);
17989 -- INITIALIZATION_LIST ::=
17991 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
17993 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
17998 -- | (INPUT {, INPUT})
18002 -- Characteristics:
18004 -- * Analysis - The annotation undergoes initial checks to verify
18005 -- the legal placement and context. Secondary checks preanalyze the
18008 -- Analyze_Initializes_In_Decl_Part
18010 -- * Expansion - None.
18012 -- * Template - The annotation utilizes the generic template of the
18013 -- related package declaration.
18015 -- * Globals - Capture of global references must occur after full
18018 -- * Instance - The annotation is instantiated automatically when
18019 -- the related generic package is instantiated.
18021 when Pragma_Initializes => Initializes : declare
18022 Pack_Decl : Node_Id;
18023 Pack_Id : Entity_Id;
18027 Check_No_Identifiers;
18028 Check_Arg_Count (1);
18030 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
18032 if Nkind (Pack_Decl) not in
18033 N_Generic_Package_Declaration | N_Package_Declaration
18039 Pack_Id := Defining_Entity (Pack_Decl);
18041 -- A pragma that applies to a Ghost entity becomes Ghost for the
18042 -- purposes of legality checks and removal of ignored Ghost code.
18044 Mark_Ghost_Pragma (N, Pack_Id);
18045 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
18047 -- Chain the pragma on the contract for further processing by
18048 -- Analyze_Initializes_In_Decl_Part.
18050 Add_Contract_Item (N, Pack_Id);
18052 -- The legality checks of pragmas Abstract_State, Initializes, and
18053 -- Initial_Condition are affected by the SPARK mode in effect. In
18054 -- addition, these three pragmas are subject to an inherent order:
18056 -- 1) Abstract_State
18058 -- 3) Initial_Condition
18060 -- Analyze all these pragmas in the order outlined above
18062 Analyze_If_Present (Pragma_SPARK_Mode);
18063 Analyze_If_Present (Pragma_Abstract_State);
18064 Analyze_If_Present (Pragma_Initial_Condition);
18071 -- pragma Inline ( NAME {, NAME} );
18073 when Pragma_Inline =>
18075 -- Pragma always active unless in GNATprove mode. It is disabled
18076 -- in GNATprove mode because frontend inlining is applied
18077 -- independently of pragmas Inline and Inline_Always for
18078 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
18081 if not GNATprove_Mode then
18083 -- Inline status is Enabled if option -gnatn is specified.
18084 -- However this status determines only the value of the
18085 -- Is_Inlined flag on the subprogram and does not prevent
18086 -- the pragma itself from being recorded for later use,
18087 -- in particular for a later modification of Is_Inlined
18088 -- independently of the -gnatn option.
18090 -- In other words, if -gnatn is specified for a unit, then
18091 -- all Inline pragmas processed for the compilation of this
18092 -- unit, including those in the spec of other units, are
18093 -- activated, so subprograms will be inlined across units.
18095 -- If -gnatn is not specified, no Inline pragma is activated
18096 -- here, which means that subprograms will not be inlined
18097 -- across units. The Is_Inlined flag will nevertheless be
18098 -- set later when bodies are analyzed, so subprograms will
18099 -- be inlined within the unit.
18101 if Inline_Active then
18102 Process_Inline (Enabled);
18104 Process_Inline (Disabled);
18108 -------------------
18109 -- Inline_Always --
18110 -------------------
18112 -- pragma Inline_Always ( NAME {, NAME} );
18114 when Pragma_Inline_Always =>
18117 -- Pragma always active unless in CodePeer mode or GNATprove
18118 -- mode. It is disabled in CodePeer mode because inlining is
18119 -- not helpful, and enabling it caused walk order issues. It
18120 -- is disabled in GNATprove mode because frontend inlining is
18121 -- applied independently of pragmas Inline and Inline_Always for
18122 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
18125 if not CodePeer_Mode and not GNATprove_Mode then
18126 Process_Inline (Enabled);
18129 --------------------
18130 -- Inline_Generic --
18131 --------------------
18133 -- pragma Inline_Generic (NAME {, NAME});
18135 when Pragma_Inline_Generic =>
18137 Process_Generic_List;
18139 ----------------------
18140 -- Inspection_Point --
18141 ----------------------
18143 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
18145 when Pragma_Inspection_Point => Inspection_Point : declare
18152 if Arg_Count > 0 then
18155 Exp := Get_Pragma_Arg (Arg);
18158 if not Is_Entity_Name (Exp)
18159 or else not Is_Object (Entity (Exp))
18161 Error_Pragma_Arg ("object name required", Arg);
18165 exit when No (Arg);
18168 end Inspection_Point;
18174 -- pragma Interface (
18175 -- [ Convention =>] convention_IDENTIFIER,
18176 -- [ Entity =>] LOCAL_NAME
18177 -- [, [External_Name =>] static_string_EXPRESSION ]
18178 -- [, [Link_Name =>] static_string_EXPRESSION ]);
18180 when Pragma_Interface =>
18185 Name_External_Name,
18187 Check_At_Least_N_Arguments (2);
18188 Check_At_Most_N_Arguments (4);
18189 Process_Import_Or_Interface;
18191 -- In Ada 2005, the permission to use Interface (a reserved word)
18192 -- as a pragma name is considered an obsolescent feature, and this
18193 -- pragma was already obsolescent in Ada 95.
18195 if Ada_Version >= Ada_95 then
18197 (No_Obsolescent_Features, Pragma_Identifier (N));
18199 if Warn_On_Obsolescent_Feature then
18201 ("pragma Interface is an obsolescent feature?j?", N);
18203 ("|use pragma Import instead?j?", N);
18207 --------------------
18208 -- Interface_Name --
18209 --------------------
18211 -- pragma Interface_Name (
18212 -- [ Entity =>] LOCAL_NAME
18213 -- [,[External_Name =>] static_string_EXPRESSION ]
18214 -- [,[Link_Name =>] static_string_EXPRESSION ]);
18216 when Pragma_Interface_Name => Interface_Name : declare
18218 Def_Id : Entity_Id;
18219 Hom_Id : Entity_Id;
18225 ((Name_Entity, Name_External_Name, Name_Link_Name));
18226 Check_At_Least_N_Arguments (2);
18227 Check_At_Most_N_Arguments (3);
18228 Id := Get_Pragma_Arg (Arg1);
18231 -- This is obsolete from Ada 95 on, but it is an implementation
18232 -- defined pragma, so we do not consider that it violates the
18233 -- restriction (No_Obsolescent_Features).
18235 if Ada_Version >= Ada_95 then
18236 if Warn_On_Obsolescent_Feature then
18238 ("pragma Interface_Name is an obsolescent feature?j?", N);
18240 ("|use pragma Import instead?j?", N);
18244 if not Is_Entity_Name (Id) then
18246 ("first argument for pragma% must be entity name", Arg1);
18247 elsif Etype (Id) = Any_Type then
18250 Def_Id := Entity (Id);
18253 -- Special DEC-compatible processing for the object case, forces
18254 -- object to be imported.
18256 if Ekind (Def_Id) = E_Variable then
18257 Kill_Size_Check_Code (Def_Id);
18258 Note_Possible_Modification (Id, Sure => False);
18260 -- Initialization is not allowed for imported variable
18262 if Present (Expression (Parent (Def_Id)))
18263 and then Comes_From_Source (Expression (Parent (Def_Id)))
18265 Error_Msg_Sloc := Sloc (Def_Id);
18267 ("no initialization allowed for declaration of& #",
18271 -- For compatibility, support VADS usage of providing both
18272 -- pragmas Interface and Interface_Name to obtain the effect
18273 -- of a single Import pragma.
18275 if Is_Imported (Def_Id)
18276 and then Present (First_Rep_Item (Def_Id))
18277 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
18278 and then Pragma_Name (First_Rep_Item (Def_Id)) =
18283 Set_Imported (Def_Id);
18286 Set_Is_Public (Def_Id);
18287 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
18290 -- Otherwise must be subprogram
18292 elsif not Is_Subprogram (Def_Id) then
18294 ("argument of pragma% is not subprogram", Arg1);
18297 Check_At_Most_N_Arguments (3);
18301 -- Loop through homonyms
18304 Def_Id := Get_Base_Subprogram (Hom_Id);
18306 if Is_Imported (Def_Id) then
18307 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
18311 exit when From_Aspect_Specification (N);
18312 Hom_Id := Homonym (Hom_Id);
18314 exit when No (Hom_Id)
18315 or else Scope (Hom_Id) /= Current_Scope;
18320 ("argument of pragma% is not imported subprogram",
18324 end Interface_Name;
18326 -----------------------
18327 -- Interrupt_Handler --
18328 -----------------------
18330 -- pragma Interrupt_Handler (handler_NAME);
18332 when Pragma_Interrupt_Handler =>
18333 Check_Ada_83_Warning;
18334 Check_Arg_Count (1);
18335 Check_No_Identifiers;
18337 if No_Run_Time_Mode then
18338 Error_Msg_CRT ("Interrupt_Handler pragma", N);
18340 Check_Interrupt_Or_Attach_Handler;
18341 Process_Interrupt_Or_Attach_Handler;
18344 ------------------------
18345 -- Interrupt_Priority --
18346 ------------------------
18348 -- pragma Interrupt_Priority [(EXPRESSION)];
18350 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
18351 P : constant Node_Id := Parent (N);
18356 Check_Ada_83_Warning;
18358 if Arg_Count /= 0 then
18359 Arg := Get_Pragma_Arg (Arg1);
18360 Check_Arg_Count (1);
18361 Check_No_Identifiers;
18363 -- The expression must be analyzed in the special manner
18364 -- described in "Handling of Default and Per-Object
18365 -- Expressions" in sem.ads.
18367 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
18370 if Nkind (P) not in N_Task_Definition | N_Protected_Definition then
18375 Ent := Defining_Identifier (Parent (P));
18377 -- Check duplicate pragma before we chain the pragma in the Rep
18378 -- Item chain of Ent.
18380 Check_Duplicate_Pragma (Ent);
18381 Record_Rep_Item (Ent, N);
18383 -- Check the No_Task_At_Interrupt_Priority restriction
18385 if Nkind (P) = N_Task_Definition then
18386 Check_Restriction (No_Task_At_Interrupt_Priority, N);
18389 end Interrupt_Priority;
18391 ---------------------
18392 -- Interrupt_State --
18393 ---------------------
18395 -- pragma Interrupt_State (
18396 -- [Name =>] INTERRUPT_ID,
18397 -- [State =>] INTERRUPT_STATE);
18399 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
18400 -- INTERRUPT_STATE => System | Runtime | User
18402 -- Note: if the interrupt id is given as an identifier, then it must
18403 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
18404 -- given as a static integer expression which must be in the range of
18405 -- Ada.Interrupts.Interrupt_ID.
18407 when Pragma_Interrupt_State => Interrupt_State : declare
18408 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
18409 -- This is the entity Ada.Interrupts.Interrupt_ID;
18411 State_Type : Character;
18412 -- Set to 's'/'r'/'u' for System/Runtime/User
18415 -- Index to entry in Interrupt_States table
18418 -- Value of interrupt
18420 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
18421 -- The first argument to the pragma
18423 Int_Ent : Entity_Id;
18424 -- Interrupt entity in Ada.Interrupts.Names
18428 Check_Arg_Order ((Name_Name, Name_State));
18429 Check_Arg_Count (2);
18431 Check_Optional_Identifier (Arg1, Name_Name);
18432 Check_Optional_Identifier (Arg2, Name_State);
18433 Check_Arg_Is_Identifier (Arg2);
18435 -- First argument is identifier
18437 if Nkind (Arg1X) = N_Identifier then
18439 -- Search list of names in Ada.Interrupts.Names
18441 Int_Ent := First_Entity (RTE (RE_Names));
18443 if No (Int_Ent) then
18444 Error_Pragma_Arg ("invalid interrupt name", Arg1);
18446 elsif Chars (Int_Ent) = Chars (Arg1X) then
18447 Int_Val := Expr_Value (Constant_Value (Int_Ent));
18451 Next_Entity (Int_Ent);
18454 -- First argument is not an identifier, so it must be a static
18455 -- expression of type Ada.Interrupts.Interrupt_ID.
18458 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
18459 Int_Val := Expr_Value (Arg1X);
18461 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
18463 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
18466 ("value not in range of type "
18467 & """Ada.Interrupts.Interrupt_'I'D""", Arg1);
18473 case Chars (Get_Pragma_Arg (Arg2)) is
18474 when Name_Runtime => State_Type := 'r';
18475 when Name_System => State_Type := 's';
18476 when Name_User => State_Type := 'u';
18479 Error_Pragma_Arg ("invalid interrupt state", Arg2);
18482 -- Check if entry is already stored
18484 IST_Num := Interrupt_States.First;
18486 -- If entry not found, add it
18488 if IST_Num > Interrupt_States.Last then
18489 Interrupt_States.Append
18490 ((Interrupt_Number => UI_To_Int (Int_Val),
18491 Interrupt_State => State_Type,
18492 Pragma_Loc => Loc));
18495 -- Case of entry for the same entry
18497 elsif Int_Val = Interrupt_States.Table (IST_Num).
18500 -- If state matches, done, no need to make redundant entry
18503 State_Type = Interrupt_States.Table (IST_Num).
18506 -- Otherwise if state does not match, error
18509 Interrupt_States.Table (IST_Num).Pragma_Loc;
18511 ("state conflicts with that given #", Arg2);
18515 IST_Num := IST_Num + 1;
18517 end Interrupt_State;
18523 -- pragma Invariant
18524 -- ([Entity =>] type_LOCAL_NAME,
18525 -- [Check =>] EXPRESSION
18526 -- [,[Message =>] String_Expression]);
18528 when Pragma_Invariant => Invariant : declare
18535 Check_At_Least_N_Arguments (2);
18536 Check_At_Most_N_Arguments (3);
18537 Check_Optional_Identifier (Arg1, Name_Entity);
18538 Check_Optional_Identifier (Arg2, Name_Check);
18540 if Arg_Count = 3 then
18541 Check_Optional_Identifier (Arg3, Name_Message);
18542 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
18545 Check_Arg_Is_Local_Name (Arg1);
18547 Typ_Arg := Get_Pragma_Arg (Arg1);
18548 Find_Type (Typ_Arg);
18549 Typ := Entity (Typ_Arg);
18551 -- Nothing to do of the related type is erroneous in some way
18553 if Typ = Any_Type then
18556 -- AI12-0041: Invariants are allowed in interface types
18558 elsif Is_Interface (Typ) then
18561 -- An invariant must apply to a private type, or appear in the
18562 -- private part of a package spec and apply to a completion.
18563 -- a class-wide invariant can only appear on a private declaration
18564 -- or private extension, not a completion.
18566 -- A [class-wide] invariant may be associated a [limited] private
18567 -- type or a private extension.
18569 elsif Ekind (Typ) in E_Limited_Private_Type
18571 | E_Record_Type_With_Private
18575 -- A non-class-wide invariant may be associated with the full view
18576 -- of a [limited] private type or a private extension.
18578 elsif Has_Private_Declaration (Typ)
18579 and then not Class_Present (N)
18583 -- A class-wide invariant may appear on the partial view only
18585 elsif Class_Present (N) then
18587 ("pragma % only allowed for private type", Arg1);
18590 -- A regular invariant may appear on both views
18594 ("pragma % only allowed for private type or corresponding "
18595 & "full view", Arg1);
18599 -- An invariant associated with an abstract type (this includes
18600 -- interfaces) must be class-wide.
18602 if Is_Abstract_Type (Typ) and then not Class_Present (N) then
18604 ("pragma % not allowed for abstract type", Arg1);
18608 -- A pragma that applies to a Ghost entity becomes Ghost for the
18609 -- purposes of legality checks and removal of ignored Ghost code.
18611 Mark_Ghost_Pragma (N, Typ);
18613 -- The pragma defines a type-specific invariant, the type is said
18614 -- to have invariants of its "own".
18616 Set_Has_Own_Invariants (Typ);
18618 -- If the invariant is class-wide, then it can be inherited by
18619 -- derived or interface implementing types. The type is said to
18620 -- have "inheritable" invariants.
18622 if Class_Present (N) then
18623 Set_Has_Inheritable_Invariants (Typ);
18626 -- Chain the pragma on to the rep item chain, for processing when
18627 -- the type is frozen.
18629 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
18631 -- Create the declaration of the invariant procedure that will
18632 -- verify the invariant at run time. Interfaces are treated as the
18633 -- partial view of a private type in order to achieve uniformity
18634 -- with the general case. As a result, an interface receives only
18635 -- a "partial" invariant procedure, which is never called.
18637 Build_Invariant_Procedure_Declaration
18639 Partial_Invariant => Is_Interface (Typ));
18646 -- pragma Keep_Names ([On => ] LOCAL_NAME);
18648 when Pragma_Keep_Names => Keep_Names : declare
18653 Check_Arg_Count (1);
18654 Check_Optional_Identifier (Arg1, Name_On);
18655 Check_Arg_Is_Local_Name (Arg1);
18657 Arg := Get_Pragma_Arg (Arg1);
18660 if Etype (Arg) = Any_Type then
18664 if not Is_Entity_Name (Arg)
18665 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
18668 ("pragma% requires a local enumeration type", Arg1);
18671 Set_Discard_Names (Entity (Arg), False);
18678 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
18680 when Pragma_License =>
18683 -- Do not analyze pragma any further in CodePeer mode, to avoid
18684 -- extraneous errors in this implementation-dependent pragma,
18685 -- which has a different profile on other compilers.
18687 if CodePeer_Mode then
18691 Check_Arg_Count (1);
18692 Check_No_Identifiers;
18693 Check_Valid_Configuration_Pragma;
18694 Check_Arg_Is_Identifier (Arg1);
18697 Sind : constant Source_File_Index :=
18698 Source_Index (Current_Sem_Unit);
18701 case Chars (Get_Pragma_Arg (Arg1)) is
18703 Set_License (Sind, GPL);
18705 when Name_Modified_GPL =>
18706 Set_License (Sind, Modified_GPL);
18708 when Name_Restricted =>
18709 Set_License (Sind, Restricted);
18711 when Name_Unrestricted =>
18712 Set_License (Sind, Unrestricted);
18715 Error_Pragma_Arg ("invalid license name", Arg1);
18723 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
18725 when Pragma_Link_With => Link_With : declare
18731 if Operating_Mode = Generate_Code
18732 and then In_Extended_Main_Source_Unit (N)
18734 Check_At_Least_N_Arguments (1);
18735 Check_No_Identifiers;
18736 Check_Is_In_Decl_Part_Or_Package_Spec;
18737 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
18741 while Present (Arg) loop
18742 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
18744 -- Store argument, converting sequences of spaces to a
18745 -- single null character (this is one of the differences
18746 -- in processing between Link_With and Linker_Options).
18748 Arg_Store : declare
18749 C : constant Char_Code := Get_Char_Code (' ');
18750 S : constant String_Id :=
18751 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
18752 L : constant Nat := String_Length (S);
18755 procedure Skip_Spaces;
18756 -- Advance F past any spaces
18762 procedure Skip_Spaces is
18764 while F <= L and then Get_String_Char (S, F) = C loop
18769 -- Start of processing for Arg_Store
18772 Skip_Spaces; -- skip leading spaces
18774 -- Loop through characters, changing any embedded
18775 -- sequence of spaces to a single null character (this
18776 -- is how Link_With/Linker_Options differ)
18779 if Get_String_Char (S, F) = C then
18782 Store_String_Char (ASCII.NUL);
18785 Store_String_Char (Get_String_Char (S, F));
18793 if Present (Arg) then
18794 Store_String_Char (ASCII.NUL);
18798 Store_Linker_Option_String (End_String);
18806 -- pragma Linker_Alias (
18807 -- [Entity =>] LOCAL_NAME
18808 -- [Target =>] static_string_EXPRESSION);
18810 when Pragma_Linker_Alias =>
18812 Check_Arg_Order ((Name_Entity, Name_Target));
18813 Check_Arg_Count (2);
18814 Check_Optional_Identifier (Arg1, Name_Entity);
18815 Check_Optional_Identifier (Arg2, Name_Target);
18816 Check_Arg_Is_Library_Level_Local_Name (Arg1);
18817 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
18819 -- The only processing required is to link this item on to the
18820 -- list of rep items for the given entity. This is accomplished
18821 -- by the call to Rep_Item_Too_Late (when no error is detected
18822 -- and False is returned).
18824 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
18827 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
18830 ------------------------
18831 -- Linker_Constructor --
18832 ------------------------
18834 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
18836 -- Code is shared with Linker_Destructor
18838 -----------------------
18839 -- Linker_Destructor --
18840 -----------------------
18842 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
18844 when Pragma_Linker_Constructor
18845 | Pragma_Linker_Destructor
18847 Linker_Constructor : declare
18853 Check_Arg_Count (1);
18854 Check_No_Identifiers;
18855 Check_Arg_Is_Local_Name (Arg1);
18856 Arg1_X := Get_Pragma_Arg (Arg1);
18858 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
18860 if not Is_Library_Level_Entity (Proc) then
18862 ("argument for pragma% must be library level entity", Arg1);
18865 -- The only processing required is to link this item on to the
18866 -- list of rep items for the given entity. This is accomplished
18867 -- by the call to Rep_Item_Too_Late (when no error is detected
18868 -- and False is returned).
18870 if Rep_Item_Too_Late (Proc, N) then
18873 Set_Has_Gigi_Rep_Item (Proc);
18875 end Linker_Constructor;
18877 --------------------
18878 -- Linker_Options --
18879 --------------------
18881 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
18883 when Pragma_Linker_Options => Linker_Options : declare
18887 Check_Ada_83_Warning;
18888 Check_No_Identifiers;
18889 Check_Arg_Count (1);
18890 Check_Is_In_Decl_Part_Or_Package_Spec;
18891 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
18892 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
18895 while Present (Arg) loop
18896 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
18897 Store_String_Char (ASCII.NUL);
18899 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
18903 if Operating_Mode = Generate_Code
18904 and then In_Extended_Main_Source_Unit (N)
18906 Store_Linker_Option_String (End_String);
18908 end Linker_Options;
18910 --------------------
18911 -- Linker_Section --
18912 --------------------
18914 -- pragma Linker_Section (
18915 -- [Entity =>] LOCAL_NAME
18916 -- [Section =>] static_string_EXPRESSION);
18918 when Pragma_Linker_Section => Linker_Section : declare
18923 Ghost_Error_Posted : Boolean := False;
18924 -- Flag set when an error concerning the illegal mix of Ghost and
18925 -- non-Ghost subprograms is emitted.
18927 Ghost_Id : Entity_Id := Empty;
18928 -- The entity of the first Ghost subprogram encountered while
18929 -- processing the arguments of the pragma.
18933 Check_Arg_Order ((Name_Entity, Name_Section));
18934 Check_Arg_Count (2);
18935 Check_Optional_Identifier (Arg1, Name_Entity);
18936 Check_Optional_Identifier (Arg2, Name_Section);
18937 Check_Arg_Is_Library_Level_Local_Name (Arg1);
18938 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
18940 -- Check kind of entity
18942 Arg := Get_Pragma_Arg (Arg1);
18943 Ent := Entity (Arg);
18945 case Ekind (Ent) is
18947 -- Objects (constants and variables) and types. For these cases
18948 -- all we need to do is to set the Linker_Section_pragma field,
18949 -- checking that we do not have a duplicate.
18955 LPE := Linker_Section_Pragma (Ent);
18957 if Present (LPE) then
18958 Error_Msg_Sloc := Sloc (LPE);
18960 ("Linker_Section already specified for &#", Arg1, Ent);
18963 Set_Linker_Section_Pragma (Ent, N);
18965 -- A pragma that applies to a Ghost entity becomes Ghost for
18966 -- the purposes of legality checks and removal of ignored
18969 Mark_Ghost_Pragma (N, Ent);
18973 when Subprogram_Kind =>
18975 -- Aspect case, entity already set
18977 if From_Aspect_Specification (N) then
18978 Set_Linker_Section_Pragma
18979 (Entity (Corresponding_Aspect (N)), N);
18981 -- Propagate it to its ultimate aliased entity to
18982 -- facilitate the backend processing this attribute
18983 -- in instantiations of generic subprograms.
18985 if Present (Alias (Entity (Corresponding_Aspect (N))))
18987 Set_Linker_Section_Pragma
18989 (Entity (Corresponding_Aspect (N))), N);
18992 -- Pragma case, we must climb the homonym chain, but skip
18993 -- any for which the linker section is already set.
18997 if No (Linker_Section_Pragma (Ent)) then
18998 Set_Linker_Section_Pragma (Ent, N);
19000 -- Propagate it to its ultimate aliased entity to
19001 -- facilitate the backend processing this attribute
19002 -- in instantiations of generic subprograms.
19004 if Present (Alias (Ent)) then
19005 Set_Linker_Section_Pragma
19006 (Ultimate_Alias (Ent), N);
19009 -- A pragma that applies to a Ghost entity becomes
19010 -- Ghost for the purposes of legality checks and
19011 -- removal of ignored Ghost code.
19013 Mark_Ghost_Pragma (N, Ent);
19015 -- Capture the entity of the first Ghost subprogram
19016 -- being processed for error detection purposes.
19018 if Is_Ghost_Entity (Ent) then
19019 if No (Ghost_Id) then
19023 -- Otherwise the subprogram is non-Ghost. It is
19024 -- illegal to mix references to Ghost and non-Ghost
19025 -- entities (SPARK RM 6.9).
19027 elsif Present (Ghost_Id)
19028 and then not Ghost_Error_Posted
19030 Ghost_Error_Posted := True;
19032 Error_Msg_Name_1 := Pname;
19034 ("pragma % cannot mention ghost and "
19035 & "non-ghost subprograms", N);
19037 Error_Msg_Sloc := Sloc (Ghost_Id);
19039 ("\& # declared as ghost", N, Ghost_Id);
19041 Error_Msg_Sloc := Sloc (Ent);
19043 ("\& # declared as non-ghost", N, Ent);
19047 Ent := Homonym (Ent);
19049 or else Scope (Ent) /= Current_Scope;
19053 -- All other cases are illegal
19057 ("pragma% applies only to objects, subprograms, and types",
19060 end Linker_Section;
19066 -- pragma List (On | Off)
19068 -- There is nothing to do here, since we did all the processing for
19069 -- this pragma in Par.Prag (so that it works properly even in syntax
19072 when Pragma_List =>
19079 -- pragma Lock_Free [(Boolean_EXPRESSION)];
19081 when Pragma_Lock_Free => Lock_Free : declare
19082 P : constant Node_Id := Parent (N);
19088 Check_No_Identifiers;
19089 Check_At_Most_N_Arguments (1);
19091 -- Protected definition case
19093 if Nkind (P) = N_Protected_Definition then
19094 Ent := Defining_Identifier (Parent (P));
19098 if Arg_Count = 1 then
19099 Arg := Get_Pragma_Arg (Arg1);
19100 Val := Is_True (Static_Boolean (Arg));
19102 -- No arguments (expression is considered to be True)
19108 -- Check duplicate pragma before we chain the pragma in the Rep
19109 -- Item chain of Ent.
19111 Check_Duplicate_Pragma (Ent);
19112 Record_Rep_Item (Ent, N);
19113 Set_Uses_Lock_Free (Ent, Val);
19115 -- Anything else is incorrect placement
19122 --------------------
19123 -- Locking_Policy --
19124 --------------------
19126 -- pragma Locking_Policy (policy_IDENTIFIER);
19128 when Pragma_Locking_Policy => declare
19129 subtype LP_Range is Name_Id
19130 range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
19135 Check_Ada_83_Warning;
19136 Check_Arg_Count (1);
19137 Check_No_Identifiers;
19138 Check_Arg_Is_Locking_Policy (Arg1);
19139 Check_Valid_Configuration_Pragma;
19140 LP_Val := Chars (Get_Pragma_Arg (Arg1));
19143 when Name_Ceiling_Locking => LP := 'C';
19144 when Name_Concurrent_Readers_Locking => LP := 'R';
19145 when Name_Inheritance_Locking => LP := 'I';
19148 if Locking_Policy /= ' '
19149 and then Locking_Policy /= LP
19151 Error_Msg_Sloc := Locking_Policy_Sloc;
19152 Error_Pragma ("locking policy incompatible with policy#");
19154 -- Set new policy, but always preserve System_Location since we
19155 -- like the error message with the run time name.
19158 Locking_Policy := LP;
19160 if Locking_Policy_Sloc /= System_Location then
19161 Locking_Policy_Sloc := Loc;
19166 -------------------
19167 -- Loop_Optimize --
19168 -------------------
19170 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
19172 -- OPTIMIZATION_HINT ::=
19173 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
19175 when Pragma_Loop_Optimize => Loop_Optimize : declare
19180 Check_At_Least_N_Arguments (1);
19181 Check_No_Identifiers;
19183 Hint := First (Pragma_Argument_Associations (N));
19184 while Present (Hint) loop
19185 Check_Arg_Is_One_Of (Hint, Name_Ivdep,
19193 Check_Loop_Pragma_Placement;
19200 -- pragma Loop_Variant
19201 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
19203 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
19205 -- CHANGE_DIRECTION ::= Increases | Decreases
19207 when Pragma_Loop_Variant => Loop_Variant : declare
19212 Check_At_Least_N_Arguments (1);
19213 Check_Loop_Pragma_Placement;
19215 -- Process all increasing / decreasing expressions
19217 Variant := First (Pragma_Argument_Associations (N));
19218 while Present (Variant) loop
19219 if Chars (Variant) = No_Name then
19220 Error_Pragma_Arg_Ident ("expect name `Increases`", Variant);
19222 elsif Chars (Variant) not in Name_Decreases | Name_Increases
19225 Name : String := Get_Name_String (Chars (Variant));
19228 -- It is a common mistake to write "Increasing" for
19229 -- "Increases" or "Decreasing" for "Decreases". Recognize
19230 -- specially names starting with "incr" or "decr" to
19231 -- suggest the corresponding name.
19233 System.Case_Util.To_Lower (Name);
19235 if Name'Length >= 4
19236 and then Name (1 .. 4) = "incr"
19238 Error_Pragma_Arg_Ident
19239 ("expect name `Increases`", Variant);
19241 elsif Name'Length >= 4
19242 and then Name (1 .. 4) = "decr"
19244 Error_Pragma_Arg_Ident
19245 ("expect name `Decreases`", Variant);
19248 Error_Pragma_Arg_Ident
19249 ("expect name `Increases` or `Decreases`", Variant);
19254 Preanalyze_Assert_Expression
19255 (Expression (Variant), Any_Discrete);
19261 -----------------------
19262 -- Machine_Attribute --
19263 -----------------------
19265 -- pragma Machine_Attribute (
19266 -- [Entity =>] LOCAL_NAME,
19267 -- [Attribute_Name =>] static_string_EXPRESSION
19268 -- [, [Info =>] static_EXPRESSION {, static_EXPRESSION}] );
19270 when Pragma_Machine_Attribute => Machine_Attribute : declare
19272 Def_Id : Entity_Id;
19276 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
19278 if Arg_Count >= 3 then
19279 Check_Optional_Identifier (Arg3, Name_Info);
19281 while Present (Arg) loop
19282 Check_Arg_Is_OK_Static_Expression (Arg);
19286 Check_Arg_Count (2);
19289 Check_Optional_Identifier (Arg1, Name_Entity);
19290 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
19291 Check_Arg_Is_Local_Name (Arg1);
19292 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
19293 Def_Id := Entity (Get_Pragma_Arg (Arg1));
19295 if Is_Access_Type (Def_Id) then
19296 Def_Id := Designated_Type (Def_Id);
19299 if Rep_Item_Too_Early (Def_Id, N) then
19303 Def_Id := Underlying_Type (Def_Id);
19305 -- The only processing required is to link this item on to the
19306 -- list of rep items for the given entity. This is accomplished
19307 -- by the call to Rep_Item_Too_Late (when no error is detected
19308 -- and False is returned).
19310 if Rep_Item_Too_Late (Def_Id, N) then
19313 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
19315 end Machine_Attribute;
19322 -- (MAIN_OPTION [, MAIN_OPTION]);
19325 -- [STACK_SIZE =>] static_integer_EXPRESSION
19326 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
19327 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
19329 when Pragma_Main => Main : declare
19330 Args : Args_List (1 .. 3);
19331 Names : constant Name_List (1 .. 3) := (
19333 Name_Task_Stack_Size_Default,
19334 Name_Time_Slicing_Enabled);
19340 Gather_Associations (Names, Args);
19342 for J in 1 .. 2 loop
19343 if Present (Args (J)) then
19344 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
19348 if Present (Args (3)) then
19349 Check_Arg_Is_OK_Static_Expression (Args (3), Standard_Boolean);
19353 while Present (Nod) loop
19354 if Nkind (Nod) = N_Pragma
19355 and then Pragma_Name (Nod) = Name_Main
19357 Error_Msg_Name_1 := Pname;
19358 Error_Msg_N ("duplicate pragma% not permitted", Nod);
19369 -- pragma Main_Storage
19370 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
19372 -- MAIN_STORAGE_OPTION ::=
19373 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
19374 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
19376 when Pragma_Main_Storage => Main_Storage : declare
19377 Args : Args_List (1 .. 2);
19378 Names : constant Name_List (1 .. 2) := (
19379 Name_Working_Storage,
19386 Gather_Associations (Names, Args);
19388 for J in 1 .. 2 loop
19389 if Present (Args (J)) then
19390 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
19394 Check_In_Main_Program;
19397 while Present (Nod) loop
19398 if Nkind (Nod) = N_Pragma
19399 and then Pragma_Name (Nod) = Name_Main_Storage
19401 Error_Msg_Name_1 := Pname;
19402 Error_Msg_N ("duplicate pragma% not permitted", Nod);
19409 ----------------------------
19410 -- Max_Entry_Queue_Length --
19411 ----------------------------
19413 -- pragma Max_Entry_Queue_Length (static_integer_EXPRESSION);
19415 -- This processing is shared by Pragma_Max_Entry_Queue_Depth and
19416 -- Pragma_Max_Queue_Length.
19418 when Pragma_Max_Entry_Queue_Length
19419 | Pragma_Max_Entry_Queue_Depth
19420 | Pragma_Max_Queue_Length
19422 Max_Entry_Queue_Length : declare
19424 Entry_Decl : Node_Id;
19425 Entry_Id : Entity_Id;
19429 if Prag_Id = Pragma_Max_Entry_Queue_Depth
19430 or else Prag_Id = Pragma_Max_Queue_Length
19435 Check_Arg_Count (1);
19438 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
19440 -- Entry declaration
19442 if Nkind (Entry_Decl) = N_Entry_Declaration then
19444 -- Entry illegally within a task
19446 if Nkind (Parent (N)) = N_Task_Definition then
19447 Error_Pragma ("pragma % cannot apply to task entries");
19451 Entry_Id := Defining_Entity (Entry_Decl);
19453 -- Otherwise the pragma is associated with an illegal construct
19457 ("pragma % must apply to a protected entry declaration");
19461 -- Mark the pragma as Ghost if the related subprogram is also
19462 -- Ghost. This also ensures that any expansion performed further
19463 -- below will produce Ghost nodes.
19465 Mark_Ghost_Pragma (N, Entry_Id);
19467 -- Analyze the Integer expression
19469 Arg := Get_Pragma_Arg (Arg1);
19470 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
19472 Val := Expr_Value (Arg);
19476 ("argument for pragma% cannot be less than -1", Arg1);
19478 elsif not UI_Is_In_Int_Range (Val) then
19480 ("argument for pragma% out of range of Integer", Arg1);
19484 Record_Rep_Item (Entry_Id, N);
19485 end Max_Entry_Queue_Length;
19491 -- pragma Memory_Size (NUMERIC_LITERAL)
19493 when Pragma_Memory_Size =>
19496 -- Memory size is simply ignored
19498 Check_No_Identifiers;
19499 Check_Arg_Count (1);
19500 Check_Arg_Is_Integer_Literal (Arg1);
19508 -- The only correct use of this pragma is on its own in a file, in
19509 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
19510 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
19511 -- check for a file containing nothing but a No_Body pragma). If we
19512 -- attempt to process it during normal semantics processing, it means
19513 -- it was misplaced.
19515 when Pragma_No_Body =>
19519 -----------------------------
19520 -- No_Elaboration_Code_All --
19521 -----------------------------
19523 -- pragma No_Elaboration_Code_All;
19525 when Pragma_No_Elaboration_Code_All =>
19527 Check_Valid_Library_Unit_Pragma;
19529 if Nkind (N) = N_Null_Statement then
19533 -- Must appear for a spec or generic spec
19535 if Nkind (Unit (Cunit (Current_Sem_Unit))) not in
19536 N_Generic_Package_Declaration |
19537 N_Generic_Subprogram_Declaration |
19538 N_Package_Declaration |
19539 N_Subprogram_Declaration
19543 ("pragma% can only occur for package "
19544 & "or subprogram spec"));
19547 -- Set flag in unit table
19549 Set_No_Elab_Code_All (Current_Sem_Unit);
19551 -- Set restriction No_Elaboration_Code if this is the main unit
19553 if Current_Sem_Unit = Main_Unit then
19554 Set_Restriction (No_Elaboration_Code, N);
19557 -- If we are in the main unit or in an extended main source unit,
19558 -- then we also add it to the configuration restrictions so that
19559 -- it will apply to all units in the extended main source.
19561 if Current_Sem_Unit = Main_Unit
19562 or else In_Extended_Main_Source_Unit (N)
19564 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
19567 -- If in main extended unit, activate transitive with test
19569 if In_Extended_Main_Source_Unit (N) then
19570 Opt.No_Elab_Code_All_Pragma := N;
19573 -----------------------------
19574 -- No_Component_Reordering --
19575 -----------------------------
19577 -- pragma No_Component_Reordering [([Entity =>] type_LOCAL_NAME)];
19579 when Pragma_No_Component_Reordering => No_Comp_Reordering : declare
19585 Check_At_Most_N_Arguments (1);
19587 if Arg_Count = 0 then
19588 Check_Valid_Configuration_Pragma;
19589 Opt.No_Component_Reordering := True;
19592 Check_Optional_Identifier (Arg2, Name_Entity);
19593 Check_Arg_Is_Local_Name (Arg1);
19594 E_Id := Get_Pragma_Arg (Arg1);
19596 if Etype (E_Id) = Any_Type then
19600 E := Entity (E_Id);
19602 if not Is_Record_Type (E) then
19603 Error_Pragma_Arg ("pragma% requires record type", Arg1);
19606 Set_No_Reordering (Base_Type (E));
19608 end No_Comp_Reordering;
19610 --------------------------
19611 -- No_Heap_Finalization --
19612 --------------------------
19614 -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];
19616 when Pragma_No_Heap_Finalization => No_Heap_Finalization : declare
19617 Context : constant Node_Id := Parent (N);
19618 Typ_Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
19624 Check_No_Identifiers;
19626 -- The pragma appears in a configuration file
19628 if No (Context) then
19629 Check_Arg_Count (0);
19630 Check_Valid_Configuration_Pragma;
19632 -- Detect a duplicate pragma
19634 if Present (No_Heap_Finalization_Pragma) then
19637 Prev => No_Heap_Finalization_Pragma);
19641 No_Heap_Finalization_Pragma := N;
19643 -- Otherwise the pragma should be associated with a library-level
19644 -- named access-to-object type.
19647 Check_Arg_Count (1);
19648 Check_Arg_Is_Local_Name (Arg1);
19650 Find_Type (Typ_Arg);
19651 Typ := Entity (Typ_Arg);
19653 -- The type being subjected to the pragma is erroneous
19655 if Typ = Any_Type then
19656 Error_Pragma ("cannot find type referenced by pragma %");
19658 -- The pragma is applied to an incomplete or generic formal
19659 -- type way too early.
19661 elsif Rep_Item_Too_Early (Typ, N) then
19665 Typ := Underlying_Type (Typ);
19668 -- The pragma must apply to an access-to-object type
19670 if Ekind (Typ) in E_Access_Type | E_General_Access_Type then
19673 -- Give a detailed error message on all other access type kinds
19675 elsif Ekind (Typ) = E_Access_Protected_Subprogram_Type then
19677 ("pragma % cannot apply to access protected subprogram "
19680 elsif Ekind (Typ) = E_Access_Subprogram_Type then
19682 ("pragma % cannot apply to access subprogram type");
19684 elsif Is_Anonymous_Access_Type (Typ) then
19686 ("pragma % cannot apply to anonymous access type");
19688 -- Give a general error message in case the pragma applies to a
19689 -- non-access type.
19693 ("pragma % must apply to library level access type");
19696 -- At this point the argument denotes an access-to-object type.
19697 -- Ensure that the type is declared at the library level.
19699 if Is_Library_Level_Entity (Typ) then
19702 -- Quietly ignore an access-to-object type originally declared
19703 -- at the library level within a generic, but instantiated at
19704 -- a non-library level. As a result the access-to-object type
19705 -- "loses" its No_Heap_Finalization property.
19707 elsif In_Instance then
19712 ("pragma % must apply to library level access type");
19715 -- Detect a duplicate pragma
19717 if Present (No_Heap_Finalization_Pragma) then
19720 Prev => No_Heap_Finalization_Pragma);
19724 Prev := Get_Pragma (Typ, Pragma_No_Heap_Finalization);
19726 if Present (Prev) then
19734 Record_Rep_Item (Typ, N);
19736 end No_Heap_Finalization;
19742 -- pragma No_Inline ( NAME {, NAME} );
19744 when Pragma_No_Inline =>
19746 Process_Inline (Suppressed);
19752 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
19754 when Pragma_No_Return => No_Return : declare
19760 Ghost_Error_Posted : Boolean := False;
19761 -- Flag set when an error concerning the illegal mix of Ghost and
19762 -- non-Ghost subprograms is emitted.
19764 Ghost_Id : Entity_Id := Empty;
19765 -- The entity of the first Ghost procedure encountered while
19766 -- processing the arguments of the pragma.
19770 Check_At_Least_N_Arguments (1);
19772 -- Loop through arguments of pragma
19775 while Present (Arg) loop
19776 Check_Arg_Is_Local_Name (Arg);
19777 Id := Get_Pragma_Arg (Arg);
19780 if not Is_Entity_Name (Id) then
19781 Error_Pragma_Arg ("entity name required", Arg);
19784 if Etype (Id) = Any_Type then
19788 -- Loop to find matching procedures or functions (Ada 2020)
19794 and then Scope (E) = Current_Scope
19796 -- Ada 2020 (AI12-0269): A function can be No_Return
19798 if Ekind (E) in E_Generic_Procedure | E_Procedure
19799 or else (Ada_Version >= Ada_2020
19801 Ekind (E) in E_Generic_Function | E_Function)
19803 -- Check that the pragma is not applied to a body.
19804 -- First check the specless body case, to give a
19805 -- different error message. These checks do not apply
19806 -- if Relaxed_RM_Semantics, to accommodate other Ada
19807 -- compilers. Disable these checks under -gnatd.J.
19809 if not Debug_Flag_Dot_JJ then
19810 if Nkind (Parent (Declaration_Node (E))) =
19812 and then not Relaxed_RM_Semantics
19815 ("pragma% requires separate spec and must come "
19819 -- Now the "specful" body case
19821 if Rep_Item_Too_Late (E, N) then
19828 -- A pragma that applies to a Ghost entity becomes Ghost
19829 -- for the purposes of legality checks and removal of
19830 -- ignored Ghost code.
19832 Mark_Ghost_Pragma (N, E);
19834 -- Capture the entity of the first Ghost procedure being
19835 -- processed for error detection purposes.
19837 if Is_Ghost_Entity (E) then
19838 if No (Ghost_Id) then
19842 -- Otherwise the subprogram is non-Ghost. It is illegal
19843 -- to mix references to Ghost and non-Ghost entities
19846 elsif Present (Ghost_Id)
19847 and then not Ghost_Error_Posted
19849 Ghost_Error_Posted := True;
19851 Error_Msg_Name_1 := Pname;
19853 ("pragma % cannot mention ghost and non-ghost "
19854 & "procedures", N);
19856 Error_Msg_Sloc := Sloc (Ghost_Id);
19857 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
19859 Error_Msg_Sloc := Sloc (E);
19860 Error_Msg_NE ("\& # declared as non-ghost", N, E);
19863 -- Set flag on any alias as well
19865 if Is_Overloadable (E) and then Present (Alias (E)) then
19866 Set_No_Return (Alias (E));
19872 exit when From_Aspect_Specification (N);
19876 -- If entity in not in current scope it may be the enclosing
19877 -- suprogram body to which the aspect applies.
19880 if Entity (Id) = Current_Scope
19881 and then From_Aspect_Specification (N)
19883 Set_No_Return (Entity (Id));
19885 elsif Ada_Version >= Ada_2020 then
19887 ("no subprogram& found for pragma%", Arg);
19890 Error_Pragma_Arg ("no procedure& found for pragma%", Arg);
19902 -- pragma No_Run_Time;
19904 -- Note: this pragma is retained for backwards compatibility. See
19905 -- body of Rtsfind for full details on its handling.
19907 when Pragma_No_Run_Time =>
19909 Check_Valid_Configuration_Pragma;
19910 Check_Arg_Count (0);
19912 -- Remove backward compatibility if Build_Type is FSF or GPL and
19913 -- generate a warning.
19916 Ignore : constant Boolean := Build_Type in FSF .. GPL;
19919 Error_Pragma ("pragma% is ignored, has no effect??");
19921 No_Run_Time_Mode := True;
19922 Configurable_Run_Time_Mode := True;
19924 -- Set Duration to 32 bits if word size is 32
19926 if Ttypes.System_Word_Size = 32 then
19927 Duration_32_Bits_On_Target := True;
19930 -- Set appropriate restrictions
19932 Set_Restriction (No_Finalization, N);
19933 Set_Restriction (No_Exception_Handlers, N);
19934 Set_Restriction (Max_Tasks, N, 0);
19935 Set_Restriction (No_Tasking, N);
19939 -----------------------
19940 -- No_Tagged_Streams --
19941 -----------------------
19943 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
19945 when Pragma_No_Tagged_Streams => No_Tagged_Strms : declare
19951 Check_At_Most_N_Arguments (1);
19953 -- One argument case
19955 if Arg_Count = 1 then
19956 Check_Optional_Identifier (Arg1, Name_Entity);
19957 Check_Arg_Is_Local_Name (Arg1);
19958 E_Id := Get_Pragma_Arg (Arg1);
19960 if Etype (E_Id) = Any_Type then
19964 E := Entity (E_Id);
19966 Check_Duplicate_Pragma (E);
19968 if not Is_Tagged_Type (E) or else Is_Derived_Type (E) then
19970 ("argument for pragma% must be root tagged type", Arg1);
19973 if Rep_Item_Too_Early (E, N)
19975 Rep_Item_Too_Late (E, N)
19979 Set_No_Tagged_Streams_Pragma (E, N);
19982 -- Zero argument case
19985 Check_Is_In_Decl_Part_Or_Package_Spec;
19986 No_Tagged_Streams := N;
19988 end No_Tagged_Strms;
19990 ------------------------
19991 -- No_Strict_Aliasing --
19992 ------------------------
19994 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
19996 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
20002 Check_At_Most_N_Arguments (1);
20004 if Arg_Count = 0 then
20005 Check_Valid_Configuration_Pragma;
20006 Opt.No_Strict_Aliasing := True;
20009 Check_Optional_Identifier (Arg2, Name_Entity);
20010 Check_Arg_Is_Local_Name (Arg1);
20011 E_Id := Get_Pragma_Arg (Arg1);
20013 if Etype (E_Id) = Any_Type then
20017 E := Entity (E_Id);
20019 if not Is_Access_Type (E) then
20020 Error_Pragma_Arg ("pragma% requires access type", Arg1);
20023 Set_No_Strict_Aliasing (Base_Type (E));
20025 end No_Strict_Aliasing;
20027 -----------------------
20028 -- Normalize_Scalars --
20029 -----------------------
20031 -- pragma Normalize_Scalars;
20033 when Pragma_Normalize_Scalars =>
20034 Check_Ada_83_Warning;
20035 Check_Arg_Count (0);
20036 Check_Valid_Configuration_Pragma;
20038 -- Normalize_Scalars creates false positives in CodePeer, and
20039 -- incorrect negative results in GNATprove mode, so ignore this
20040 -- pragma in these modes.
20042 if not (CodePeer_Mode or GNATprove_Mode) then
20043 Normalize_Scalars := True;
20044 Init_Or_Norm_Scalars := True;
20051 -- pragma Obsolescent;
20053 -- pragma Obsolescent (
20054 -- [Message =>] static_string_EXPRESSION
20055 -- [,[Version =>] Ada_05]]);
20057 -- pragma Obsolescent (
20058 -- [Entity =>] NAME
20059 -- [,[Message =>] static_string_EXPRESSION
20060 -- [,[Version =>] Ada_05]] );
20062 when Pragma_Obsolescent => Obsolescent : declare
20066 procedure Set_Obsolescent (E : Entity_Id);
20067 -- Given an entity Ent, mark it as obsolescent if appropriate
20069 ---------------------
20070 -- Set_Obsolescent --
20071 ---------------------
20073 procedure Set_Obsolescent (E : Entity_Id) is
20082 -- A pragma that applies to a Ghost entity becomes Ghost for
20083 -- the purposes of legality checks and removal of ignored Ghost
20086 Mark_Ghost_Pragma (N, E);
20088 -- Entity name was given
20090 if Present (Ename) then
20092 -- If entity name matches, we are fine.
20094 if Chars (Ename) = Chars (Ent) then
20095 Set_Entity (Ename, Ent);
20096 Generate_Reference (Ent, Ename);
20098 -- If entity name does not match, only possibility is an
20099 -- enumeration literal from an enumeration type declaration.
20101 elsif Ekind (Ent) /= E_Enumeration_Type then
20103 ("pragma % entity name does not match declaration");
20106 Ent := First_Literal (E);
20110 ("pragma % entity name does not match any "
20111 & "enumeration literal");
20113 elsif Chars (Ent) = Chars (Ename) then
20114 Set_Entity (Ename, Ent);
20115 Generate_Reference (Ent, Ename);
20119 Next_Literal (Ent);
20125 -- Ent points to entity to be marked
20127 if Arg_Count >= 1 then
20129 -- Deal with static string argument
20131 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
20132 S := Strval (Get_Pragma_Arg (Arg1));
20134 for J in 1 .. String_Length (S) loop
20135 if not In_Character_Range (Get_String_Char (S, J)) then
20137 ("pragma% argument does not allow wide characters",
20142 Obsolescent_Warnings.Append
20143 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
20145 -- Check for Ada_05 parameter
20147 if Arg_Count /= 1 then
20148 Check_Arg_Count (2);
20151 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
20154 Check_Arg_Is_Identifier (Argx);
20156 if Chars (Argx) /= Name_Ada_05 then
20157 Error_Msg_Name_2 := Name_Ada_05;
20159 ("only allowed argument for pragma% is %", Argx);
20162 if Ada_Version_Explicit < Ada_2005
20163 or else not Warn_On_Ada_2005_Compatibility
20171 -- Set flag if pragma active
20174 Set_Is_Obsolescent (Ent);
20178 end Set_Obsolescent;
20180 -- Start of processing for pragma Obsolescent
20185 Check_At_Most_N_Arguments (3);
20187 -- See if first argument specifies an entity name
20191 (Chars (Arg1) = Name_Entity
20193 Nkind (Get_Pragma_Arg (Arg1)) in
20194 N_Character_Literal | N_Identifier | N_Operator_Symbol)
20196 Ename := Get_Pragma_Arg (Arg1);
20198 -- Eliminate first argument, so we can share processing
20202 Arg_Count := Arg_Count - 1;
20204 -- No Entity name argument given
20210 if Arg_Count >= 1 then
20211 Check_Optional_Identifier (Arg1, Name_Message);
20213 if Arg_Count = 2 then
20214 Check_Optional_Identifier (Arg2, Name_Version);
20218 -- Get immediately preceding declaration
20221 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
20225 -- Cases where we do not follow anything other than another pragma
20229 -- First case: library level compilation unit declaration with
20230 -- the pragma immediately following the declaration.
20232 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
20234 (Defining_Entity (Unit (Parent (Parent (N)))));
20237 -- Case 2: library unit placement for package
20241 Ent : constant Entity_Id := Find_Lib_Unit_Name;
20243 if Is_Package_Or_Generic_Package (Ent) then
20244 Set_Obsolescent (Ent);
20250 -- Cases where we must follow a declaration, including an
20251 -- abstract subprogram declaration, which is not in the
20252 -- other node subtypes.
20255 if Nkind (Decl) not in N_Declaration
20256 and then Nkind (Decl) not in N_Later_Decl_Item
20257 and then Nkind (Decl) not in N_Generic_Declaration
20258 and then Nkind (Decl) not in N_Renaming_Declaration
20259 and then Nkind (Decl) /= N_Abstract_Subprogram_Declaration
20262 ("pragma% misplaced, "
20263 & "must immediately follow a declaration");
20266 Set_Obsolescent (Defining_Entity (Decl));
20276 -- pragma Optimize (Time | Space | Off);
20278 -- The actual check for optimize is done in Gigi. Note that this
20279 -- pragma does not actually change the optimization setting, it
20280 -- simply checks that it is consistent with the pragma.
20282 when Pragma_Optimize =>
20283 Check_No_Identifiers;
20284 Check_Arg_Count (1);
20285 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
20287 ------------------------
20288 -- Optimize_Alignment --
20289 ------------------------
20291 -- pragma Optimize_Alignment (Time | Space | Off);
20293 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
20295 Check_No_Identifiers;
20296 Check_Arg_Count (1);
20297 Check_Valid_Configuration_Pragma;
20300 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
20303 when Name_Off => Opt.Optimize_Alignment := 'O';
20304 when Name_Space => Opt.Optimize_Alignment := 'S';
20305 when Name_Time => Opt.Optimize_Alignment := 'T';
20308 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
20312 -- Set indication that mode is set locally. If we are in fact in a
20313 -- configuration pragma file, this setting is harmless since the
20314 -- switch will get reset anyway at the start of each unit.
20316 Optimize_Alignment_Local := True;
20317 end Optimize_Alignment;
20323 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
20325 when Pragma_Ordered => Ordered : declare
20326 Assoc : constant Node_Id := Arg1;
20332 Check_No_Identifiers;
20333 Check_Arg_Count (1);
20334 Check_Arg_Is_Local_Name (Arg1);
20336 Type_Id := Get_Pragma_Arg (Assoc);
20337 Find_Type (Type_Id);
20338 Typ := Entity (Type_Id);
20340 if Typ = Any_Type then
20343 Typ := Underlying_Type (Typ);
20346 if not Is_Enumeration_Type (Typ) then
20347 Error_Pragma ("pragma% must specify enumeration type");
20350 Check_First_Subtype (Arg1);
20351 Set_Has_Pragma_Ordered (Base_Type (Typ));
20354 -------------------
20355 -- Overflow_Mode --
20356 -------------------
20358 -- pragma Overflow_Mode
20359 -- ([General => ] MODE [, [Assertions => ] MODE]);
20361 -- MODE := STRICT | MINIMIZED | ELIMINATED
20363 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
20364 -- since System.Bignums makes this assumption. This is true of nearly
20365 -- all (all?) targets.
20367 when Pragma_Overflow_Mode => Overflow_Mode : declare
20368 function Get_Overflow_Mode
20370 Arg : Node_Id) return Overflow_Mode_Type;
20371 -- Function to process one pragma argument, Arg. If an identifier
20372 -- is present, it must be Name. Mode type is returned if a valid
20373 -- argument exists, otherwise an error is signalled.
20375 -----------------------
20376 -- Get_Overflow_Mode --
20377 -----------------------
20379 function Get_Overflow_Mode
20381 Arg : Node_Id) return Overflow_Mode_Type
20383 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
20386 Check_Optional_Identifier (Arg, Name);
20387 Check_Arg_Is_Identifier (Argx);
20389 if Chars (Argx) = Name_Strict then
20392 elsif Chars (Argx) = Name_Minimized then
20395 elsif Chars (Argx) = Name_Eliminated then
20396 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then
20398 ("Eliminated not implemented on this target", Argx);
20404 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
20406 end Get_Overflow_Mode;
20408 -- Start of processing for Overflow_Mode
20412 Check_At_Least_N_Arguments (1);
20413 Check_At_Most_N_Arguments (2);
20415 -- Process first argument
20417 Scope_Suppress.Overflow_Mode_General :=
20418 Get_Overflow_Mode (Name_General, Arg1);
20420 -- Case of only one argument
20422 if Arg_Count = 1 then
20423 Scope_Suppress.Overflow_Mode_Assertions :=
20424 Scope_Suppress.Overflow_Mode_General;
20426 -- Case of two arguments present
20429 Scope_Suppress.Overflow_Mode_Assertions :=
20430 Get_Overflow_Mode (Name_Assertions, Arg2);
20434 --------------------------
20435 -- Overriding Renamings --
20436 --------------------------
20438 -- pragma Overriding_Renamings;
20440 when Pragma_Overriding_Renamings =>
20442 Check_Arg_Count (0);
20443 Check_Valid_Configuration_Pragma;
20444 Overriding_Renamings := True;
20450 -- pragma Pack (first_subtype_LOCAL_NAME);
20452 when Pragma_Pack => Pack : declare
20453 Assoc : constant Node_Id := Arg1;
20455 Ignore : Boolean := False;
20460 Check_No_Identifiers;
20461 Check_Arg_Count (1);
20462 Check_Arg_Is_Local_Name (Arg1);
20463 Type_Id := Get_Pragma_Arg (Assoc);
20465 if not Is_Entity_Name (Type_Id)
20466 or else not Is_Type (Entity (Type_Id))
20469 ("argument for pragma% must be type or subtype", Arg1);
20472 Find_Type (Type_Id);
20473 Typ := Entity (Type_Id);
20476 or else Rep_Item_Too_Early (Typ, N)
20480 Typ := Underlying_Type (Typ);
20483 -- A pragma that applies to a Ghost entity becomes Ghost for the
20484 -- purposes of legality checks and removal of ignored Ghost code.
20486 Mark_Ghost_Pragma (N, Typ);
20488 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
20489 Error_Pragma ("pragma% must specify array or record type");
20492 Check_First_Subtype (Arg1);
20493 Check_Duplicate_Pragma (Typ);
20497 if Is_Array_Type (Typ) then
20498 Ctyp := Component_Type (Typ);
20500 -- Ignore pack that does nothing
20502 if Known_Static_Esize (Ctyp)
20503 and then Known_Static_RM_Size (Ctyp)
20504 and then Esize (Ctyp) = RM_Size (Ctyp)
20505 and then Addressable (Esize (Ctyp))
20510 -- Process OK pragma Pack. Note that if there is a separate
20511 -- component clause present, the Pack will be cancelled. This
20512 -- processing is in Freeze.
20514 if not Rep_Item_Too_Late (Typ, N) then
20516 -- In CodePeer mode, we do not need complex front-end
20517 -- expansions related to pragma Pack, so disable handling
20520 if CodePeer_Mode then
20523 -- Normal case where we do the pack action
20527 Set_Is_Packed (Base_Type (Typ));
20528 Set_Has_Non_Standard_Rep (Base_Type (Typ));
20531 Set_Has_Pragma_Pack (Base_Type (Typ));
20535 -- For record types, the pack is always effective
20537 else pragma Assert (Is_Record_Type (Typ));
20538 if not Rep_Item_Too_Late (Typ, N) then
20539 Set_Is_Packed (Base_Type (Typ));
20540 Set_Has_Pragma_Pack (Base_Type (Typ));
20541 Set_Has_Non_Standard_Rep (Base_Type (Typ));
20552 -- There is nothing to do here, since we did all the processing for
20553 -- this pragma in Par.Prag (so that it works properly even in syntax
20556 when Pragma_Page =>
20563 -- pragma Part_Of (ABSTRACT_STATE);
20565 -- ABSTRACT_STATE ::= NAME
20567 when Pragma_Part_Of => Part_Of : declare
20568 procedure Propagate_Part_Of
20569 (Pack_Id : Entity_Id;
20570 State_Id : Entity_Id;
20571 Instance : Node_Id);
20572 -- Propagate the Part_Of indicator to all abstract states and
20573 -- objects declared in the visible state space of a package
20574 -- denoted by Pack_Id. State_Id is the encapsulating state.
20575 -- Instance is the package instantiation node.
20577 -----------------------
20578 -- Propagate_Part_Of --
20579 -----------------------
20581 procedure Propagate_Part_Of
20582 (Pack_Id : Entity_Id;
20583 State_Id : Entity_Id;
20584 Instance : Node_Id)
20586 Has_Item : Boolean := False;
20587 -- Flag set when the visible state space contains at least one
20588 -- abstract state or variable.
20590 procedure Propagate_Part_Of (Pack_Id : Entity_Id);
20591 -- Propagate the Part_Of indicator to all abstract states and
20592 -- objects declared in the visible state space of a package
20593 -- denoted by Pack_Id.
20595 -----------------------
20596 -- Propagate_Part_Of --
20597 -----------------------
20599 procedure Propagate_Part_Of (Pack_Id : Entity_Id) is
20600 Constits : Elist_Id;
20601 Item_Id : Entity_Id;
20604 -- Traverse the entity chain of the package and set relevant
20605 -- attributes of abstract states and objects declared in the
20606 -- visible state space of the package.
20608 Item_Id := First_Entity (Pack_Id);
20609 while Present (Item_Id)
20610 and then not In_Private_Part (Item_Id)
20612 -- Do not consider internally generated items
20614 if not Comes_From_Source (Item_Id) then
20617 -- Do not consider generic formals or their corresponding
20618 -- actuals because they are not part of a visible state.
20619 -- Note that both entities are marked as hidden.
20621 elsif Is_Hidden (Item_Id) then
20624 -- The Part_Of indicator turns an abstract state or an
20625 -- object into a constituent of the encapsulating state.
20626 -- Note that constants are considered here even though
20627 -- they may not depend on variable input. This check is
20628 -- left to the SPARK prover.
20630 elsif Ekind (Item_Id) in
20631 E_Abstract_State | E_Constant | E_Variable
20634 Constits := Part_Of_Constituents (State_Id);
20636 if No (Constits) then
20637 Constits := New_Elmt_List;
20638 Set_Part_Of_Constituents (State_Id, Constits);
20641 Append_Elmt (Item_Id, Constits);
20642 Set_Encapsulating_State (Item_Id, State_Id);
20644 -- Recursively handle nested packages and instantiations
20646 elsif Ekind (Item_Id) = E_Package then
20647 Propagate_Part_Of (Item_Id);
20650 Next_Entity (Item_Id);
20652 end Propagate_Part_Of;
20654 -- Start of processing for Propagate_Part_Of
20657 Propagate_Part_Of (Pack_Id);
20659 -- Detect a package instantiation that is subject to a Part_Of
20660 -- indicator, but has no visible state.
20662 if not Has_Item then
20664 ("package instantiation & has Part_Of indicator but "
20665 & "lacks visible state", Instance, Pack_Id);
20667 end Propagate_Part_Of;
20671 Constits : Elist_Id;
20673 Encap_Id : Entity_Id;
20674 Item_Id : Entity_Id;
20678 -- Start of processing for Part_Of
20682 Check_No_Identifiers;
20683 Check_Arg_Count (1);
20685 Stmt := Find_Related_Context (N, Do_Checks => True);
20687 -- Object declaration
20689 if Nkind (Stmt) = N_Object_Declaration then
20692 -- Package instantiation
20694 elsif Nkind (Stmt) = N_Package_Instantiation then
20697 -- Single concurrent type declaration
20699 elsif Is_Single_Concurrent_Type_Declaration (Stmt) then
20702 -- Otherwise the pragma is associated with an illegal construct
20709 -- Extract the entity of the related object declaration or package
20710 -- instantiation. In the case of the instantiation, use the entity
20711 -- of the instance spec.
20713 if Nkind (Stmt) = N_Package_Instantiation then
20714 Stmt := Instance_Spec (Stmt);
20717 Item_Id := Defining_Entity (Stmt);
20719 -- A pragma that applies to a Ghost entity becomes Ghost for the
20720 -- purposes of legality checks and removal of ignored Ghost code.
20722 Mark_Ghost_Pragma (N, Item_Id);
20724 -- Chain the pragma on the contract for further processing by
20725 -- Analyze_Part_Of_In_Decl_Part or for completeness.
20727 Add_Contract_Item (N, Item_Id);
20729 -- A variable may act as constituent of a single concurrent type
20730 -- which in turn could be declared after the variable. Due to this
20731 -- discrepancy, the full analysis of indicator Part_Of is delayed
20732 -- until the end of the enclosing declarative region (see routine
20733 -- Analyze_Part_Of_In_Decl_Part).
20735 if Ekind (Item_Id) = E_Variable then
20738 -- Otherwise indicator Part_Of applies to a constant or a package
20742 Encap := Get_Pragma_Arg (Arg1);
20744 -- Detect any discrepancies between the placement of the
20745 -- constant or package instantiation with respect to state
20746 -- space and the encapsulating state.
20750 Item_Id => Item_Id,
20752 Encap_Id => Encap_Id,
20756 pragma Assert (Present (Encap_Id));
20758 if Ekind (Item_Id) = E_Constant then
20759 Constits := Part_Of_Constituents (Encap_Id);
20761 if No (Constits) then
20762 Constits := New_Elmt_List;
20763 Set_Part_Of_Constituents (Encap_Id, Constits);
20766 Append_Elmt (Item_Id, Constits);
20767 Set_Encapsulating_State (Item_Id, Encap_Id);
20769 -- Propagate the Part_Of indicator to the visible state
20770 -- space of the package instantiation.
20774 (Pack_Id => Item_Id,
20775 State_Id => Encap_Id,
20782 ----------------------------------
20783 -- Partition_Elaboration_Policy --
20784 ----------------------------------
20786 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
20788 when Pragma_Partition_Elaboration_Policy => PEP : declare
20789 subtype PEP_Range is Name_Id
20790 range First_Partition_Elaboration_Policy_Name
20791 .. Last_Partition_Elaboration_Policy_Name;
20792 PEP_Val : PEP_Range;
20797 Check_Arg_Count (1);
20798 Check_No_Identifiers;
20799 Check_Arg_Is_Partition_Elaboration_Policy (Arg1);
20800 Check_Valid_Configuration_Pragma;
20801 PEP_Val := Chars (Get_Pragma_Arg (Arg1));
20804 when Name_Concurrent => PEP := 'C';
20805 when Name_Sequential => PEP := 'S';
20808 if Partition_Elaboration_Policy /= ' '
20809 and then Partition_Elaboration_Policy /= PEP
20811 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc;
20813 ("partition elaboration policy incompatible with policy#");
20815 -- Set new policy, but always preserve System_Location since we
20816 -- like the error message with the run time name.
20819 Partition_Elaboration_Policy := PEP;
20821 if Partition_Elaboration_Policy_Sloc /= System_Location then
20822 Partition_Elaboration_Policy_Sloc := Loc;
20831 -- pragma Passive [(PASSIVE_FORM)];
20833 -- PASSIVE_FORM ::= Semaphore | No
20835 when Pragma_Passive =>
20838 if Nkind (Parent (N)) /= N_Task_Definition then
20839 Error_Pragma ("pragma% must be within task definition");
20842 if Arg_Count /= 0 then
20843 Check_Arg_Count (1);
20844 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
20847 ----------------------------------
20848 -- Preelaborable_Initialization --
20849 ----------------------------------
20851 -- pragma Preelaborable_Initialization (DIRECT_NAME);
20853 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
20858 Check_Arg_Count (1);
20859 Check_No_Identifiers;
20860 Check_Arg_Is_Identifier (Arg1);
20861 Check_Arg_Is_Local_Name (Arg1);
20862 Check_First_Subtype (Arg1);
20863 Ent := Entity (Get_Pragma_Arg (Arg1));
20865 -- A pragma that applies to a Ghost entity becomes Ghost for the
20866 -- purposes of legality checks and removal of ignored Ghost code.
20868 Mark_Ghost_Pragma (N, Ent);
20870 -- The pragma may come from an aspect on a private declaration,
20871 -- even if the freeze point at which this is analyzed in the
20872 -- private part after the full view.
20874 if Has_Private_Declaration (Ent)
20875 and then From_Aspect_Specification (N)
20879 -- Check appropriate type argument
20881 elsif Is_Private_Type (Ent)
20882 or else Is_Protected_Type (Ent)
20883 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))
20885 -- AI05-0028: The pragma applies to all composite types. Note
20886 -- that we apply this binding interpretation to earlier versions
20887 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
20888 -- choice since there are other compilers that do the same.
20890 or else Is_Composite_Type (Ent)
20896 ("pragma % can only be applied to private, formal derived, "
20897 & "protected, or composite type", Arg1);
20900 -- Give an error if the pragma is applied to a protected type that
20901 -- does not qualify (due to having entries, or due to components
20902 -- that do not qualify).
20904 if Is_Protected_Type (Ent)
20905 and then not Has_Preelaborable_Initialization (Ent)
20908 ("protected type & does not have preelaborable "
20909 & "initialization", Ent);
20911 -- Otherwise mark the type as definitely having preelaborable
20915 Set_Known_To_Have_Preelab_Init (Ent);
20918 if Has_Pragma_Preelab_Init (Ent)
20919 and then Warn_On_Redundant_Constructs
20921 Error_Pragma ("?r?duplicate pragma%!");
20923 Set_Has_Pragma_Preelab_Init (Ent);
20927 --------------------
20928 -- Persistent_BSS --
20929 --------------------
20931 -- pragma Persistent_BSS [(object_NAME)];
20933 when Pragma_Persistent_BSS => Persistent_BSS : declare
20940 Check_At_Most_N_Arguments (1);
20942 -- Case of application to specific object (one argument)
20944 if Arg_Count = 1 then
20945 Check_Arg_Is_Library_Level_Local_Name (Arg1);
20947 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
20949 Ekind (Entity (Get_Pragma_Arg (Arg1))) not in
20950 E_Variable | E_Constant
20952 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
20955 Ent := Entity (Get_Pragma_Arg (Arg1));
20957 -- A pragma that applies to a Ghost entity becomes Ghost for
20958 -- the purposes of legality checks and removal of ignored Ghost
20961 Mark_Ghost_Pragma (N, Ent);
20963 -- Check for duplication before inserting in list of
20964 -- representation items.
20966 Check_Duplicate_Pragma (Ent);
20968 if Rep_Item_Too_Late (Ent, N) then
20972 Decl := Parent (Ent);
20974 if Present (Expression (Decl)) then
20975 -- Variables in Persistent_BSS cannot be initialized, so
20976 -- turn off any initialization that might be caused by
20977 -- pragmas Initialize_Scalars or Normalize_Scalars.
20979 if Kill_Range_Check (Expression (Decl)) then
20982 Name_Suppress_Initialization,
20983 Pragma_Argument_Associations => New_List (
20984 Make_Pragma_Argument_Association (Loc,
20985 Expression => New_Occurrence_Of (Ent, Loc))));
20986 Insert_Before (N, Prag);
20991 ("object for pragma% cannot have initialization", Arg1);
20995 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
20997 ("object type for pragma% is not potentially persistent",
21002 Make_Linker_Section_Pragma
21003 (Ent, Loc, ".persistent.bss");
21004 Insert_After (N, Prag);
21007 -- Case of use as configuration pragma with no arguments
21010 Check_Valid_Configuration_Pragma;
21011 Persistent_BSS_Mode := True;
21013 end Persistent_BSS;
21015 --------------------
21016 -- Rename_Pragma --
21017 --------------------
21019 -- pragma Rename_Pragma (
21020 -- [New_Name =>] IDENTIFIER,
21021 -- [Renamed =>] pragma_IDENTIFIER);
21023 when Pragma_Rename_Pragma => Rename_Pragma : declare
21024 New_Name : constant Node_Id := Get_Pragma_Arg (Arg1);
21025 Old_Name : constant Node_Id := Get_Pragma_Arg (Arg2);
21029 Check_Valid_Configuration_Pragma;
21030 Check_Arg_Count (2);
21031 Check_Optional_Identifier (Arg1, Name_New_Name);
21032 Check_Optional_Identifier (Arg2, Name_Renamed);
21034 if Nkind (New_Name) /= N_Identifier then
21035 Error_Pragma_Arg ("identifier expected", Arg1);
21038 if Nkind (Old_Name) /= N_Identifier then
21039 Error_Pragma_Arg ("identifier expected", Arg2);
21042 -- The New_Name arg should not be an existing pragma (but we allow
21043 -- it; it's just a warning). The Old_Name arg must be an existing
21046 if Is_Pragma_Name (Chars (New_Name)) then
21047 Error_Pragma_Arg ("??pragma is already defined", Arg1);
21050 if not Is_Pragma_Name (Chars (Old_Name)) then
21051 Error_Pragma_Arg ("existing pragma name expected", Arg1);
21054 Map_Pragma_Name (From => Chars (New_Name), To => Chars (Old_Name));
21057 -----------------------------------
21058 -- Post/Post_Class/Postcondition --
21059 -----------------------------------
21061 -- pragma Post (Boolean_EXPRESSION);
21062 -- pragma Post_Class (Boolean_EXPRESSION);
21063 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
21064 -- [,[Message =>] String_EXPRESSION]);
21066 -- Characteristics:
21068 -- * Analysis - The annotation undergoes initial checks to verify
21069 -- the legal placement and context. Secondary checks preanalyze the
21072 -- Analyze_Pre_Post_Condition_In_Decl_Part
21074 -- * Expansion - The annotation is expanded during the expansion of
21075 -- the related subprogram [body] contract as performed in:
21077 -- Expand_Subprogram_Contract
21079 -- * Template - The annotation utilizes the generic template of the
21080 -- related subprogram [body] when it is:
21082 -- aspect on subprogram declaration
21083 -- aspect on stand-alone subprogram body
21084 -- pragma on stand-alone subprogram body
21086 -- The annotation must prepare its own template when it is:
21088 -- pragma on subprogram declaration
21090 -- * Globals - Capture of global references must occur after full
21093 -- * Instance - The annotation is instantiated automatically when
21094 -- the related generic subprogram [body] is instantiated except for
21095 -- the "pragma on subprogram declaration" case. In that scenario
21096 -- the annotation must instantiate itself.
21099 | Pragma_Post_Class
21100 | Pragma_Postcondition
21102 Analyze_Pre_Post_Condition;
21104 --------------------------------
21105 -- Pre/Pre_Class/Precondition --
21106 --------------------------------
21108 -- pragma Pre (Boolean_EXPRESSION);
21109 -- pragma Pre_Class (Boolean_EXPRESSION);
21110 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
21111 -- [,[Message =>] String_EXPRESSION]);
21113 -- Characteristics:
21115 -- * Analysis - The annotation undergoes initial checks to verify
21116 -- the legal placement and context. Secondary checks preanalyze the
21119 -- Analyze_Pre_Post_Condition_In_Decl_Part
21121 -- * Expansion - The annotation is expanded during the expansion of
21122 -- the related subprogram [body] contract as performed in:
21124 -- Expand_Subprogram_Contract
21126 -- * Template - The annotation utilizes the generic template of the
21127 -- related subprogram [body] when it is:
21129 -- aspect on subprogram declaration
21130 -- aspect on stand-alone subprogram body
21131 -- pragma on stand-alone subprogram body
21133 -- The annotation must prepare its own template when it is:
21135 -- pragma on subprogram declaration
21137 -- * Globals - Capture of global references must occur after full
21140 -- * Instance - The annotation is instantiated automatically when
21141 -- the related generic subprogram [body] is instantiated except for
21142 -- the "pragma on subprogram declaration" case. In that scenario
21143 -- the annotation must instantiate itself.
21147 | Pragma_Precondition
21149 Analyze_Pre_Post_Condition;
21155 -- pragma Predicate
21156 -- ([Entity =>] type_LOCAL_NAME,
21157 -- [Check =>] boolean_EXPRESSION);
21159 when Pragma_Predicate => Predicate : declare
21166 Check_Arg_Count (2);
21167 Check_Optional_Identifier (Arg1, Name_Entity);
21168 Check_Optional_Identifier (Arg2, Name_Check);
21170 Check_Arg_Is_Local_Name (Arg1);
21172 Type_Id := Get_Pragma_Arg (Arg1);
21173 Find_Type (Type_Id);
21174 Typ := Entity (Type_Id);
21176 if Typ = Any_Type then
21180 -- A pragma that applies to a Ghost entity becomes Ghost for the
21181 -- purposes of legality checks and removal of ignored Ghost code.
21183 Mark_Ghost_Pragma (N, Typ);
21185 -- The remaining processing is simply to link the pragma on to
21186 -- the rep item chain, for processing when the type is frozen.
21187 -- This is accomplished by a call to Rep_Item_Too_Late. We also
21188 -- mark the type as having predicates.
21190 -- If the current policy for predicate checking is Ignore mark the
21191 -- subtype accordingly. In the case of predicates we consider them
21192 -- enabled unless Ignore is specified (either directly or with a
21193 -- general Assertion_Policy pragma) to preserve existing warnings.
21195 Set_Has_Predicates (Typ);
21197 -- Indicate that the pragma must be processed at the point the
21198 -- type is frozen, as is done for the corresponding aspect.
21200 Set_Has_Delayed_Aspects (Typ);
21201 Set_Has_Delayed_Freeze (Typ);
21203 Set_Predicates_Ignored (Typ,
21204 Policy_In_Effect (Name_Dynamic_Predicate) = Name_Ignore);
21205 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
21208 -----------------------
21209 -- Predicate_Failure --
21210 -----------------------
21212 -- pragma Predicate_Failure
21213 -- ([Entity =>] type_LOCAL_NAME,
21214 -- [Message =>] string_EXPRESSION);
21216 when Pragma_Predicate_Failure => Predicate_Failure : declare
21223 Check_Arg_Count (2);
21224 Check_Optional_Identifier (Arg1, Name_Entity);
21225 Check_Optional_Identifier (Arg2, Name_Message);
21227 Check_Arg_Is_Local_Name (Arg1);
21229 Type_Id := Get_Pragma_Arg (Arg1);
21230 Find_Type (Type_Id);
21231 Typ := Entity (Type_Id);
21233 if Typ = Any_Type then
21237 -- A pragma that applies to a Ghost entity becomes Ghost for the
21238 -- purposes of legality checks and removal of ignored Ghost code.
21240 Mark_Ghost_Pragma (N, Typ);
21242 -- The remaining processing is simply to link the pragma on to
21243 -- the rep item chain, for processing when the type is frozen.
21244 -- This is accomplished by a call to Rep_Item_Too_Late.
21246 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
21247 end Predicate_Failure;
21253 -- pragma Preelaborate [(library_unit_NAME)];
21255 -- Set the flag Is_Preelaborated of program unit name entity
21257 when Pragma_Preelaborate => Preelaborate : declare
21258 Pa : constant Node_Id := Parent (N);
21259 Pk : constant Node_Kind := Nkind (Pa);
21263 Check_Ada_83_Warning;
21264 Check_Valid_Library_Unit_Pragma;
21266 if Nkind (N) = N_Null_Statement then
21270 Ent := Find_Lib_Unit_Name;
21272 -- A pragma that applies to a Ghost entity becomes Ghost for the
21273 -- purposes of legality checks and removal of ignored Ghost code.
21275 Mark_Ghost_Pragma (N, Ent);
21276 Check_Duplicate_Pragma (Ent);
21278 -- This filters out pragmas inside generic parents that show up
21279 -- inside instantiations. Pragmas that come from aspects in the
21280 -- unit are not ignored.
21282 if Present (Ent) then
21283 if Pk = N_Package_Specification
21284 and then Present (Generic_Parent (Pa))
21285 and then not From_Aspect_Specification (N)
21290 if not Debug_Flag_U then
21291 Set_Is_Preelaborated (Ent);
21293 if Legacy_Elaboration_Checks then
21294 Set_Suppress_Elaboration_Warnings (Ent);
21301 -------------------------------
21302 -- Prefix_Exception_Messages --
21303 -------------------------------
21305 -- pragma Prefix_Exception_Messages;
21307 when Pragma_Prefix_Exception_Messages =>
21309 Check_Valid_Configuration_Pragma;
21310 Check_Arg_Count (0);
21311 Prefix_Exception_Messages := True;
21317 -- pragma Priority (EXPRESSION);
21319 when Pragma_Priority => Priority : declare
21320 P : constant Node_Id := Parent (N);
21325 Check_No_Identifiers;
21326 Check_Arg_Count (1);
21330 if Nkind (P) = N_Subprogram_Body then
21331 Check_In_Main_Program;
21333 Ent := Defining_Unit_Name (Specification (P));
21335 if Nkind (Ent) = N_Defining_Program_Unit_Name then
21336 Ent := Defining_Identifier (Ent);
21339 Arg := Get_Pragma_Arg (Arg1);
21340 Analyze_And_Resolve (Arg, Standard_Integer);
21344 if not Is_OK_Static_Expression (Arg) then
21345 Flag_Non_Static_Expr
21346 ("main subprogram priority is not static!", Arg);
21349 -- If constraint error, then we already signalled an error
21351 elsif Raises_Constraint_Error (Arg) then
21354 -- Otherwise check in range except if Relaxed_RM_Semantics
21355 -- where we ignore the value if out of range.
21358 if not Relaxed_RM_Semantics
21359 and then not Is_In_Range (Arg, RTE (RE_Priority))
21362 ("main subprogram priority is out of range", Arg1);
21365 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
21369 -- Load an arbitrary entity from System.Tasking.Stages or
21370 -- System.Tasking.Restricted.Stages (depending on the
21371 -- supported profile) to make sure that one of these packages
21372 -- is implicitly with'ed, since we need to have the tasking
21373 -- run time active for the pragma Priority to have any effect.
21374 -- Previously we with'ed the package System.Tasking, but this
21375 -- package does not trigger the required initialization of the
21376 -- run-time library.
21379 Discard : Entity_Id;
21380 pragma Warnings (Off, Discard);
21382 if Restricted_Profile then
21383 Discard := RTE (RE_Activate_Restricted_Tasks);
21385 Discard := RTE (RE_Activate_Tasks);
21389 -- Task or Protected, must be of type Integer
21391 elsif Nkind (P) in N_Protected_Definition | N_Task_Definition then
21392 Arg := Get_Pragma_Arg (Arg1);
21393 Ent := Defining_Identifier (Parent (P));
21395 -- The expression must be analyzed in the special manner
21396 -- described in "Handling of Default and Per-Object
21397 -- Expressions" in sem.ads.
21399 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority));
21401 if not Is_OK_Static_Expression (Arg) then
21402 Check_Restriction (Static_Priorities, Arg);
21405 -- Anything else is incorrect
21411 -- Check duplicate pragma before we chain the pragma in the Rep
21412 -- Item chain of Ent.
21414 Check_Duplicate_Pragma (Ent);
21415 Record_Rep_Item (Ent, N);
21418 -----------------------------------
21419 -- Priority_Specific_Dispatching --
21420 -----------------------------------
21422 -- pragma Priority_Specific_Dispatching (
21423 -- policy_IDENTIFIER,
21424 -- first_priority_EXPRESSION,
21425 -- last_priority_EXPRESSION);
21427 when Pragma_Priority_Specific_Dispatching =>
21428 Priority_Specific_Dispatching : declare
21429 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
21430 -- This is the entity System.Any_Priority;
21433 Lower_Bound : Node_Id;
21434 Upper_Bound : Node_Id;
21440 Check_Arg_Count (3);
21441 Check_No_Identifiers;
21442 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
21443 Check_Valid_Configuration_Pragma;
21444 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
21445 DP := Fold_Upper (Name_Buffer (1));
21447 Lower_Bound := Get_Pragma_Arg (Arg2);
21448 Check_Arg_Is_OK_Static_Expression (Lower_Bound, Standard_Integer);
21449 Lower_Val := Expr_Value (Lower_Bound);
21451 Upper_Bound := Get_Pragma_Arg (Arg3);
21452 Check_Arg_Is_OK_Static_Expression (Upper_Bound, Standard_Integer);
21453 Upper_Val := Expr_Value (Upper_Bound);
21455 -- It is not allowed to use Task_Dispatching_Policy and
21456 -- Priority_Specific_Dispatching in the same partition.
21458 if Task_Dispatching_Policy /= ' ' then
21459 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
21461 ("pragma% incompatible with Task_Dispatching_Policy#");
21463 -- Check lower bound in range
21465 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
21467 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
21470 ("first_priority is out of range", Arg2);
21472 -- Check upper bound in range
21474 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
21476 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
21479 ("last_priority is out of range", Arg3);
21481 -- Check that the priority range is valid
21483 elsif Lower_Val > Upper_Val then
21485 ("last_priority_expression must be greater than or equal to "
21486 & "first_priority_expression");
21488 -- Store the new policy, but always preserve System_Location since
21489 -- we like the error message with the run-time name.
21492 -- Check overlapping in the priority ranges specified in other
21493 -- Priority_Specific_Dispatching pragmas within the same
21494 -- partition. We can only check those we know about.
21497 Specific_Dispatching.First .. Specific_Dispatching.Last
21499 if Specific_Dispatching.Table (J).First_Priority in
21500 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
21501 or else Specific_Dispatching.Table (J).Last_Priority in
21502 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
21505 Specific_Dispatching.Table (J).Pragma_Loc;
21507 ("priority range overlaps with "
21508 & "Priority_Specific_Dispatching#");
21512 -- The use of Priority_Specific_Dispatching is incompatible
21513 -- with Task_Dispatching_Policy.
21515 if Task_Dispatching_Policy /= ' ' then
21516 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
21518 ("Priority_Specific_Dispatching incompatible "
21519 & "with Task_Dispatching_Policy#");
21522 -- The use of Priority_Specific_Dispatching forces ceiling
21525 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
21526 Error_Msg_Sloc := Locking_Policy_Sloc;
21528 ("Priority_Specific_Dispatching incompatible "
21529 & "with Locking_Policy#");
21531 -- Set the Ceiling_Locking policy, but preserve System_Location
21532 -- since we like the error message with the run time name.
21535 Locking_Policy := 'C';
21537 if Locking_Policy_Sloc /= System_Location then
21538 Locking_Policy_Sloc := Loc;
21542 -- Add entry in the table
21544 Specific_Dispatching.Append
21545 ((Dispatching_Policy => DP,
21546 First_Priority => UI_To_Int (Lower_Val),
21547 Last_Priority => UI_To_Int (Upper_Val),
21548 Pragma_Loc => Loc));
21550 end Priority_Specific_Dispatching;
21556 -- pragma Profile (profile_IDENTIFIER);
21558 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
21560 when Pragma_Profile =>
21562 Check_Arg_Count (1);
21563 Check_Valid_Configuration_Pragma;
21564 Check_No_Identifiers;
21567 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21570 if Chars (Argx) = Name_Ravenscar then
21571 Set_Ravenscar_Profile (Ravenscar, N);
21573 elsif Chars (Argx) = Name_Jorvik then
21574 Set_Ravenscar_Profile (Jorvik, N);
21576 elsif Chars (Argx) = Name_Gnat_Extended_Ravenscar then
21577 Set_Ravenscar_Profile (GNAT_Extended_Ravenscar, N);
21579 elsif Chars (Argx) = Name_Gnat_Ravenscar_EDF then
21580 Set_Ravenscar_Profile (GNAT_Ravenscar_EDF, N);
21582 elsif Chars (Argx) = Name_Restricted then
21583 Set_Profile_Restrictions
21585 N, Warn => Treat_Restrictions_As_Warnings);
21587 elsif Chars (Argx) = Name_Rational then
21588 Set_Rational_Profile;
21590 elsif Chars (Argx) = Name_No_Implementation_Extensions then
21591 Set_Profile_Restrictions
21592 (No_Implementation_Extensions,
21593 N, Warn => Treat_Restrictions_As_Warnings);
21596 Error_Pragma_Arg ("& is not a valid profile", Argx);
21600 ----------------------
21601 -- Profile_Warnings --
21602 ----------------------
21604 -- pragma Profile_Warnings (profile_IDENTIFIER);
21606 -- profile_IDENTIFIER => Restricted | Ravenscar
21608 when Pragma_Profile_Warnings =>
21610 Check_Arg_Count (1);
21611 Check_Valid_Configuration_Pragma;
21612 Check_No_Identifiers;
21615 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21618 if Chars (Argx) = Name_Ravenscar then
21619 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
21621 elsif Chars (Argx) = Name_Restricted then
21622 Set_Profile_Restrictions (Restricted, N, Warn => True);
21624 elsif Chars (Argx) = Name_No_Implementation_Extensions then
21625 Set_Profile_Restrictions
21626 (No_Implementation_Extensions, N, Warn => True);
21629 Error_Pragma_Arg ("& is not a valid profile", Argx);
21633 --------------------------
21634 -- Propagate_Exceptions --
21635 --------------------------
21637 -- pragma Propagate_Exceptions;
21639 -- Note: this pragma is obsolete and has no effect
21641 when Pragma_Propagate_Exceptions =>
21643 Check_Arg_Count (0);
21645 if Warn_On_Obsolescent_Feature then
21647 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
21648 "and has no effect?j?", N);
21651 -----------------------------
21652 -- Provide_Shift_Operators --
21653 -----------------------------
21655 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
21657 when Pragma_Provide_Shift_Operators =>
21658 Provide_Shift_Operators : declare
21661 procedure Declare_Shift_Operator (Nam : Name_Id);
21662 -- Insert declaration and pragma Instrinsic for named shift op
21664 ----------------------------
21665 -- Declare_Shift_Operator --
21666 ----------------------------
21668 procedure Declare_Shift_Operator (Nam : Name_Id) is
21674 Make_Subprogram_Declaration (Loc,
21675 Make_Function_Specification (Loc,
21676 Defining_Unit_Name =>
21677 Make_Defining_Identifier (Loc, Chars => Nam),
21679 Result_Definition =>
21680 Make_Identifier (Loc, Chars => Chars (Ent)),
21682 Parameter_Specifications => New_List (
21683 Make_Parameter_Specification (Loc,
21684 Defining_Identifier =>
21685 Make_Defining_Identifier (Loc, Name_Value),
21687 Make_Identifier (Loc, Chars => Chars (Ent))),
21689 Make_Parameter_Specification (Loc,
21690 Defining_Identifier =>
21691 Make_Defining_Identifier (Loc, Name_Amount),
21693 New_Occurrence_Of (Standard_Natural, Loc)))));
21697 Chars => Name_Import,
21698 Pragma_Argument_Associations => New_List (
21699 Make_Pragma_Argument_Association (Loc,
21700 Expression => Make_Identifier (Loc, Name_Intrinsic)),
21701 Make_Pragma_Argument_Association (Loc,
21702 Expression => Make_Identifier (Loc, Nam))));
21704 Insert_After (N, Import);
21705 Insert_After (N, Func);
21706 end Declare_Shift_Operator;
21708 -- Start of processing for Provide_Shift_Operators
21712 Check_Arg_Count (1);
21713 Check_Arg_Is_Local_Name (Arg1);
21715 Arg1 := Get_Pragma_Arg (Arg1);
21717 -- We must have an entity name
21719 if not Is_Entity_Name (Arg1) then
21721 ("pragma % must apply to integer first subtype", Arg1);
21724 -- If no Entity, means there was a prior error so ignore
21726 if Present (Entity (Arg1)) then
21727 Ent := Entity (Arg1);
21729 -- Apply error checks
21731 if not Is_First_Subtype (Ent) then
21733 ("cannot apply pragma %",
21734 "\& is not a first subtype",
21737 elsif not Is_Integer_Type (Ent) then
21739 ("cannot apply pragma %",
21740 "\& is not an integer type",
21743 elsif Has_Shift_Operator (Ent) then
21745 ("cannot apply pragma %",
21746 "\& already has declared shift operators",
21749 elsif Is_Frozen (Ent) then
21751 ("pragma % appears too late",
21752 "\& is already frozen",
21756 -- Now declare the operators. We do this during analysis rather
21757 -- than expansion, since we want the operators available if we
21758 -- are operating in -gnatc mode.
21760 Declare_Shift_Operator (Name_Rotate_Left);
21761 Declare_Shift_Operator (Name_Rotate_Right);
21762 Declare_Shift_Operator (Name_Shift_Left);
21763 Declare_Shift_Operator (Name_Shift_Right);
21764 Declare_Shift_Operator (Name_Shift_Right_Arithmetic);
21766 end Provide_Shift_Operators;
21772 -- pragma Psect_Object (
21773 -- [Internal =>] LOCAL_NAME,
21774 -- [, [External =>] EXTERNAL_SYMBOL]
21775 -- [, [Size =>] EXTERNAL_SYMBOL]);
21777 when Pragma_Common_Object
21778 | Pragma_Psect_Object
21780 Psect_Object : declare
21781 Args : Args_List (1 .. 3);
21782 Names : constant Name_List (1 .. 3) := (
21787 Internal : Node_Id renames Args (1);
21788 External : Node_Id renames Args (2);
21789 Size : Node_Id renames Args (3);
21791 Def_Id : Entity_Id;
21793 procedure Check_Arg (Arg : Node_Id);
21794 -- Checks that argument is either a string literal or an
21795 -- identifier, and posts error message if not.
21801 procedure Check_Arg (Arg : Node_Id) is
21803 if Nkind (Original_Node (Arg)) not in
21804 N_String_Literal | N_Identifier
21807 ("inappropriate argument for pragma %", Arg);
21811 -- Start of processing for Common_Object/Psect_Object
21815 Gather_Associations (Names, Args);
21816 Process_Extended_Import_Export_Internal_Arg (Internal);
21818 Def_Id := Entity (Internal);
21820 if Ekind (Def_Id) not in E_Constant | E_Variable then
21822 ("pragma% must designate an object", Internal);
21825 Check_Arg (Internal);
21827 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
21829 ("cannot use pragma% for imported/exported object",
21833 if Is_Concurrent_Type (Etype (Internal)) then
21835 ("cannot specify pragma % for task/protected object",
21839 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
21841 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
21843 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N);
21846 if Ekind (Def_Id) = E_Constant then
21848 ("cannot specify pragma % for a constant", Internal);
21851 if Is_Record_Type (Etype (Internal)) then
21857 Ent := First_Entity (Etype (Internal));
21858 while Present (Ent) loop
21859 Decl := Declaration_Node (Ent);
21861 if Ekind (Ent) = E_Component
21862 and then Nkind (Decl) = N_Component_Declaration
21863 and then Present (Expression (Decl))
21864 and then Warn_On_Export_Import
21867 ("?x?object for pragma % has defaults", Internal);
21877 if Present (Size) then
21881 if Present (External) then
21882 Check_Arg_Is_External_Name (External);
21885 -- If all error tests pass, link pragma on to the rep item chain
21887 Record_Rep_Item (Def_Id, N);
21894 -- pragma Pure [(library_unit_NAME)];
21896 when Pragma_Pure => Pure : declare
21900 Check_Ada_83_Warning;
21902 -- If the pragma comes from a subprogram instantiation, nothing to
21903 -- check, this can happen at any level of nesting.
21905 if Is_Wrapper_Package (Current_Scope) then
21908 Check_Valid_Library_Unit_Pragma;
21911 if Nkind (N) = N_Null_Statement then
21915 Ent := Find_Lib_Unit_Name;
21917 -- A pragma that applies to a Ghost entity becomes Ghost for the
21918 -- purposes of legality checks and removal of ignored Ghost code.
21920 Mark_Ghost_Pragma (N, Ent);
21922 if not Debug_Flag_U then
21924 Set_Has_Pragma_Pure (Ent);
21926 if Legacy_Elaboration_Checks then
21927 Set_Suppress_Elaboration_Warnings (Ent);
21932 -------------------
21933 -- Pure_Function --
21934 -------------------
21936 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
21938 when Pragma_Pure_Function => Pure_Function : declare
21939 Def_Id : Entity_Id;
21942 Effective : Boolean := False;
21943 Orig_Def : Entity_Id;
21944 Same_Decl : Boolean := False;
21948 Check_Arg_Count (1);
21949 Check_Optional_Identifier (Arg1, Name_Entity);
21950 Check_Arg_Is_Local_Name (Arg1);
21951 E_Id := Get_Pragma_Arg (Arg1);
21953 if Etype (E_Id) = Any_Type then
21957 -- Loop through homonyms (overloadings) of referenced entity
21959 E := Entity (E_Id);
21961 -- A pragma that applies to a Ghost entity becomes Ghost for the
21962 -- purposes of legality checks and removal of ignored Ghost code.
21964 Mark_Ghost_Pragma (N, E);
21966 if Present (E) then
21968 Def_Id := Get_Base_Subprogram (E);
21970 if Ekind (Def_Id) not in
21971 E_Function | E_Generic_Function | E_Operator
21974 ("pragma% requires a function name", Arg1);
21977 -- When we have a generic function we must jump up a level
21978 -- to the declaration of the wrapper package itself.
21980 Orig_Def := Def_Id;
21982 if Is_Generic_Instance (Def_Id) then
21983 while Nkind (Orig_Def) /= N_Package_Declaration loop
21984 Orig_Def := Parent (Orig_Def);
21988 if In_Same_Declarative_Part (Parent (N), Orig_Def) then
21990 Set_Is_Pure (Def_Id);
21992 if not Has_Pragma_Pure_Function (Def_Id) then
21993 Set_Has_Pragma_Pure_Function (Def_Id);
21998 exit when From_Aspect_Specification (N);
22000 exit when No (E) or else Scope (E) /= Current_Scope;
22004 and then Warn_On_Redundant_Constructs
22007 ("pragma Pure_Function on& is redundant?r?",
22010 elsif not Same_Decl then
22012 ("pragma% argument must be in same declarative part",
22018 --------------------
22019 -- Queuing_Policy --
22020 --------------------
22022 -- pragma Queuing_Policy (policy_IDENTIFIER);
22024 when Pragma_Queuing_Policy => declare
22028 Check_Ada_83_Warning;
22029 Check_Arg_Count (1);
22030 Check_No_Identifiers;
22031 Check_Arg_Is_Queuing_Policy (Arg1);
22032 Check_Valid_Configuration_Pragma;
22033 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
22034 QP := Fold_Upper (Name_Buffer (1));
22036 if Queuing_Policy /= ' '
22037 and then Queuing_Policy /= QP
22039 Error_Msg_Sloc := Queuing_Policy_Sloc;
22040 Error_Pragma ("queuing policy incompatible with policy#");
22042 -- Set new policy, but always preserve System_Location since we
22043 -- like the error message with the run time name.
22046 Queuing_Policy := QP;
22048 if Queuing_Policy_Sloc /= System_Location then
22049 Queuing_Policy_Sloc := Loc;
22058 -- pragma Rational, for compatibility with foreign compiler
22060 when Pragma_Rational =>
22061 Set_Rational_Profile;
22063 ---------------------
22064 -- Refined_Depends --
22065 ---------------------
22067 -- pragma Refined_Depends (DEPENDENCY_RELATION);
22069 -- DEPENDENCY_RELATION ::=
22071 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
22073 -- DEPENDENCY_CLAUSE ::=
22074 -- OUTPUT_LIST =>[+] INPUT_LIST
22075 -- | NULL_DEPENDENCY_CLAUSE
22077 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
22079 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
22081 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
22083 -- OUTPUT ::= NAME | FUNCTION_RESULT
22086 -- where FUNCTION_RESULT is a function Result attribute_reference
22088 -- Characteristics:
22090 -- * Analysis - The annotation undergoes initial checks to verify
22091 -- the legal placement and context. Secondary checks fully analyze
22092 -- the dependency clauses/global list in:
22094 -- Analyze_Refined_Depends_In_Decl_Part
22096 -- * Expansion - None.
22098 -- * Template - The annotation utilizes the generic template of the
22099 -- related subprogram body.
22101 -- * Globals - Capture of global references must occur after full
22104 -- * Instance - The annotation is instantiated automatically when
22105 -- the related generic subprogram body is instantiated.
22107 when Pragma_Refined_Depends => Refined_Depends : declare
22108 Body_Id : Entity_Id;
22110 Spec_Id : Entity_Id;
22113 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
22117 -- Chain the pragma on the contract for further processing by
22118 -- Analyze_Refined_Depends_In_Decl_Part.
22120 Add_Contract_Item (N, Body_Id);
22122 -- The legality checks of pragmas Refined_Depends and
22123 -- Refined_Global are affected by the SPARK mode in effect and
22124 -- the volatility of the context. In addition these two pragmas
22125 -- are subject to an inherent order:
22127 -- 1) Refined_Global
22128 -- 2) Refined_Depends
22130 -- Analyze all these pragmas in the order outlined above
22132 Analyze_If_Present (Pragma_SPARK_Mode);
22133 Analyze_If_Present (Pragma_Volatile_Function);
22134 Analyze_If_Present (Pragma_Refined_Global);
22135 Analyze_Refined_Depends_In_Decl_Part (N);
22137 end Refined_Depends;
22139 --------------------
22140 -- Refined_Global --
22141 --------------------
22143 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
22145 -- GLOBAL_SPECIFICATION ::=
22148 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
22150 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
22152 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
22153 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
22154 -- GLOBAL_ITEM ::= NAME
22156 -- Characteristics:
22158 -- * Analysis - The annotation undergoes initial checks to verify
22159 -- the legal placement and context. Secondary checks fully analyze
22160 -- the dependency clauses/global list in:
22162 -- Analyze_Refined_Global_In_Decl_Part
22164 -- * Expansion - None.
22166 -- * Template - The annotation utilizes the generic template of the
22167 -- related subprogram body.
22169 -- * Globals - Capture of global references must occur after full
22172 -- * Instance - The annotation is instantiated automatically when
22173 -- the related generic subprogram body is instantiated.
22175 when Pragma_Refined_Global => Refined_Global : declare
22176 Body_Id : Entity_Id;
22178 Spec_Id : Entity_Id;
22181 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
22185 -- Chain the pragma on the contract for further processing by
22186 -- Analyze_Refined_Global_In_Decl_Part.
22188 Add_Contract_Item (N, Body_Id);
22190 -- The legality checks of pragmas Refined_Depends and
22191 -- Refined_Global are affected by the SPARK mode in effect and
22192 -- the volatility of the context. In addition these two pragmas
22193 -- are subject to an inherent order:
22195 -- 1) Refined_Global
22196 -- 2) Refined_Depends
22198 -- Analyze all these pragmas in the order outlined above
22200 Analyze_If_Present (Pragma_SPARK_Mode);
22201 Analyze_If_Present (Pragma_Volatile_Function);
22202 Analyze_Refined_Global_In_Decl_Part (N);
22203 Analyze_If_Present (Pragma_Refined_Depends);
22205 end Refined_Global;
22211 -- pragma Refined_Post (boolean_EXPRESSION);
22213 -- Characteristics:
22215 -- * Analysis - The annotation is fully analyzed immediately upon
22216 -- elaboration as it cannot forward reference entities.
22218 -- * Expansion - The annotation is expanded during the expansion of
22219 -- the related subprogram body contract as performed in:
22221 -- Expand_Subprogram_Contract
22223 -- * Template - The annotation utilizes the generic template of the
22224 -- related subprogram body.
22226 -- * Globals - Capture of global references must occur after full
22229 -- * Instance - The annotation is instantiated automatically when
22230 -- the related generic subprogram body is instantiated.
22232 when Pragma_Refined_Post => Refined_Post : declare
22233 Body_Id : Entity_Id;
22235 Spec_Id : Entity_Id;
22238 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
22240 -- Fully analyze the pragma when it appears inside a subprogram
22241 -- body because it cannot benefit from forward references.
22245 -- Chain the pragma on the contract for completeness
22247 Add_Contract_Item (N, Body_Id);
22249 -- The legality checks of pragma Refined_Post are affected by
22250 -- the SPARK mode in effect and the volatility of the context.
22251 -- Analyze all pragmas in a specific order.
22253 Analyze_If_Present (Pragma_SPARK_Mode);
22254 Analyze_If_Present (Pragma_Volatile_Function);
22255 Analyze_Pre_Post_Condition_In_Decl_Part (N);
22257 -- Currently it is not possible to inline pre/postconditions on
22258 -- a subprogram subject to pragma Inline_Always.
22260 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
22264 -------------------
22265 -- Refined_State --
22266 -------------------
22268 -- pragma Refined_State (REFINEMENT_LIST);
22270 -- REFINEMENT_LIST ::=
22271 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
22273 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
22275 -- CONSTITUENT_LIST ::=
22278 -- | (CONSTITUENT {, CONSTITUENT})
22280 -- CONSTITUENT ::= object_NAME | state_NAME
22282 -- Characteristics:
22284 -- * Analysis - The annotation undergoes initial checks to verify
22285 -- the legal placement and context. Secondary checks preanalyze the
22286 -- refinement clauses in:
22288 -- Analyze_Refined_State_In_Decl_Part
22290 -- * Expansion - None.
22292 -- * Template - The annotation utilizes the template of the related
22295 -- * Globals - Capture of global references must occur after full
22298 -- * Instance - The annotation is instantiated automatically when
22299 -- the related generic package body is instantiated.
22301 when Pragma_Refined_State => Refined_State : declare
22302 Pack_Decl : Node_Id;
22303 Spec_Id : Entity_Id;
22307 Check_No_Identifiers;
22308 Check_Arg_Count (1);
22310 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
22312 if Nkind (Pack_Decl) /= N_Package_Body then
22317 Spec_Id := Corresponding_Spec (Pack_Decl);
22319 -- A pragma that applies to a Ghost entity becomes Ghost for the
22320 -- purposes of legality checks and removal of ignored Ghost code.
22322 Mark_Ghost_Pragma (N, Spec_Id);
22324 -- Chain the pragma on the contract for further processing by
22325 -- Analyze_Refined_State_In_Decl_Part.
22327 Add_Contract_Item (N, Defining_Entity (Pack_Decl));
22329 -- The legality checks of pragma Refined_State are affected by the
22330 -- SPARK mode in effect. Analyze all pragmas in a specific order.
22332 Analyze_If_Present (Pragma_SPARK_Mode);
22334 -- State refinement is allowed only when the corresponding package
22335 -- declaration has non-null pragma Abstract_State. Refinement not
22336 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
22338 if SPARK_Mode /= Off
22340 (No (Abstract_States (Spec_Id))
22341 or else Has_Null_Abstract_State (Spec_Id))
22344 ("useless refinement, package & does not define abstract "
22345 & "states", N, Spec_Id);
22350 -----------------------
22351 -- Relative_Deadline --
22352 -----------------------
22354 -- pragma Relative_Deadline (time_span_EXPRESSION);
22356 when Pragma_Relative_Deadline => Relative_Deadline : declare
22357 P : constant Node_Id := Parent (N);
22362 Check_No_Identifiers;
22363 Check_Arg_Count (1);
22365 Arg := Get_Pragma_Arg (Arg1);
22367 -- The expression must be analyzed in the special manner described
22368 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
22370 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
22374 if Nkind (P) = N_Subprogram_Body then
22375 Check_In_Main_Program;
22377 -- Only Task and subprogram cases allowed
22379 elsif Nkind (P) /= N_Task_Definition then
22383 -- Check duplicate pragma before we set the corresponding flag
22385 if Has_Relative_Deadline_Pragma (P) then
22386 Error_Pragma ("duplicate pragma% not allowed");
22389 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
22390 -- Relative_Deadline pragma node cannot be inserted in the Rep
22391 -- Item chain of Ent since it is rewritten by the expander as a
22392 -- procedure call statement that will break the chain.
22394 Set_Has_Relative_Deadline_Pragma (P);
22395 end Relative_Deadline;
22397 ------------------------
22398 -- Remote_Access_Type --
22399 ------------------------
22401 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
22403 when Pragma_Remote_Access_Type => Remote_Access_Type : declare
22408 Check_Arg_Count (1);
22409 Check_Optional_Identifier (Arg1, Name_Entity);
22410 Check_Arg_Is_Local_Name (Arg1);
22412 E := Entity (Get_Pragma_Arg (Arg1));
22414 -- A pragma that applies to a Ghost entity becomes Ghost for the
22415 -- purposes of legality checks and removal of ignored Ghost code.
22417 Mark_Ghost_Pragma (N, E);
22419 if Nkind (Parent (E)) = N_Formal_Type_Declaration
22420 and then Ekind (E) = E_General_Access_Type
22421 and then Is_Class_Wide_Type (Directly_Designated_Type (E))
22422 and then Scope (Root_Type (Directly_Designated_Type (E)))
22424 and then Is_Valid_Remote_Object_Type
22425 (Root_Type (Directly_Designated_Type (E)))
22427 Set_Is_Remote_Types (E);
22431 ("pragma% applies only to formal access-to-class-wide types",
22434 end Remote_Access_Type;
22436 ---------------------------
22437 -- Remote_Call_Interface --
22438 ---------------------------
22440 -- pragma Remote_Call_Interface [(library_unit_NAME)];
22442 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
22443 Cunit_Node : Node_Id;
22444 Cunit_Ent : Entity_Id;
22448 Check_Ada_83_Warning;
22449 Check_Valid_Library_Unit_Pragma;
22451 if Nkind (N) = N_Null_Statement then
22455 Cunit_Node := Cunit (Current_Sem_Unit);
22456 K := Nkind (Unit (Cunit_Node));
22457 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22459 -- A pragma that applies to a Ghost entity becomes Ghost for the
22460 -- purposes of legality checks and removal of ignored Ghost code.
22462 Mark_Ghost_Pragma (N, Cunit_Ent);
22464 if K = N_Package_Declaration
22465 or else K = N_Generic_Package_Declaration
22466 or else K = N_Subprogram_Declaration
22467 or else K = N_Generic_Subprogram_Declaration
22468 or else (K = N_Subprogram_Body
22469 and then Acts_As_Spec (Unit (Cunit_Node)))
22474 "pragma% must apply to package or subprogram declaration");
22477 Set_Is_Remote_Call_Interface (Cunit_Ent);
22478 end Remote_Call_Interface;
22484 -- pragma Remote_Types [(library_unit_NAME)];
22486 when Pragma_Remote_Types => Remote_Types : declare
22487 Cunit_Node : Node_Id;
22488 Cunit_Ent : Entity_Id;
22491 Check_Ada_83_Warning;
22492 Check_Valid_Library_Unit_Pragma;
22494 if Nkind (N) = N_Null_Statement then
22498 Cunit_Node := Cunit (Current_Sem_Unit);
22499 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22501 -- A pragma that applies to a Ghost entity becomes Ghost for the
22502 -- purposes of legality checks and removal of ignored Ghost code.
22504 Mark_Ghost_Pragma (N, Cunit_Ent);
22506 if Nkind (Unit (Cunit_Node)) not in
22507 N_Package_Declaration | N_Generic_Package_Declaration
22510 ("pragma% can only apply to a package declaration");
22513 Set_Is_Remote_Types (Cunit_Ent);
22520 -- pragma Ravenscar;
22522 when Pragma_Ravenscar =>
22524 Check_Arg_Count (0);
22525 Check_Valid_Configuration_Pragma;
22526 Set_Ravenscar_Profile (Ravenscar, N);
22528 if Warn_On_Obsolescent_Feature then
22530 ("pragma Ravenscar is an obsolescent feature?j?", N);
22532 ("|use pragma Profile (Ravenscar) instead?j?", N);
22535 -------------------------
22536 -- Restricted_Run_Time --
22537 -------------------------
22539 -- pragma Restricted_Run_Time;
22541 when Pragma_Restricted_Run_Time =>
22543 Check_Arg_Count (0);
22544 Check_Valid_Configuration_Pragma;
22545 Set_Profile_Restrictions
22546 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
22548 if Warn_On_Obsolescent_Feature then
22550 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
22553 ("|use pragma Profile (Restricted) instead?j?", N);
22560 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
22563 -- restriction_IDENTIFIER
22564 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22566 when Pragma_Restrictions =>
22567 Process_Restrictions_Or_Restriction_Warnings
22568 (Warn => Treat_Restrictions_As_Warnings);
22570 --------------------------
22571 -- Restriction_Warnings --
22572 --------------------------
22574 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
22577 -- restriction_IDENTIFIER
22578 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22580 when Pragma_Restriction_Warnings =>
22582 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
22588 -- pragma Reviewable;
22590 when Pragma_Reviewable =>
22591 Check_Ada_83_Warning;
22592 Check_Arg_Count (0);
22594 -- Call dummy debugging function rv. This is done to assist front
22595 -- end debugging. By placing a Reviewable pragma in the source
22596 -- program, a breakpoint on rv catches this place in the source,
22597 -- allowing convenient stepping to the point of interest.
22601 --------------------------
22602 -- Secondary_Stack_Size --
22603 --------------------------
22605 -- pragma Secondary_Stack_Size (EXPRESSION);
22607 when Pragma_Secondary_Stack_Size => Secondary_Stack_Size : declare
22608 P : constant Node_Id := Parent (N);
22614 Check_No_Identifiers;
22615 Check_Arg_Count (1);
22617 if Nkind (P) = N_Task_Definition then
22618 Arg := Get_Pragma_Arg (Arg1);
22619 Ent := Defining_Identifier (Parent (P));
22621 -- The expression must be analyzed in the special manner
22622 -- described in "Handling of Default Expressions" in sem.ads.
22624 Preanalyze_Spec_Expression (Arg, Any_Integer);
22626 -- The pragma cannot appear if the No_Secondary_Stack
22627 -- restriction is in effect.
22629 Check_Restriction (No_Secondary_Stack, Arg);
22631 -- Anything else is incorrect
22637 -- Check duplicate pragma before we chain the pragma in the Rep
22638 -- Item chain of Ent.
22640 Check_Duplicate_Pragma (Ent);
22641 Record_Rep_Item (Ent, N);
22642 end Secondary_Stack_Size;
22644 --------------------------
22645 -- Short_Circuit_And_Or --
22646 --------------------------
22648 -- pragma Short_Circuit_And_Or;
22650 when Pragma_Short_Circuit_And_Or =>
22652 Check_Arg_Count (0);
22653 Check_Valid_Configuration_Pragma;
22654 Short_Circuit_And_Or := True;
22656 -------------------
22657 -- Share_Generic --
22658 -------------------
22660 -- pragma Share_Generic (GNAME {, GNAME});
22662 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
22664 when Pragma_Share_Generic =>
22666 Process_Generic_List;
22672 -- pragma Shared (LOCAL_NAME);
22674 when Pragma_Shared =>
22676 Process_Atomic_Independent_Shared_Volatile;
22678 --------------------
22679 -- Shared_Passive --
22680 --------------------
22682 -- pragma Shared_Passive [(library_unit_NAME)];
22684 -- Set the flag Is_Shared_Passive of program unit name entity
22686 when Pragma_Shared_Passive => Shared_Passive : declare
22687 Cunit_Node : Node_Id;
22688 Cunit_Ent : Entity_Id;
22691 Check_Ada_83_Warning;
22692 Check_Valid_Library_Unit_Pragma;
22694 if Nkind (N) = N_Null_Statement then
22698 Cunit_Node := Cunit (Current_Sem_Unit);
22699 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22701 -- A pragma that applies to a Ghost entity becomes Ghost for the
22702 -- purposes of legality checks and removal of ignored Ghost code.
22704 Mark_Ghost_Pragma (N, Cunit_Ent);
22706 if Nkind (Unit (Cunit_Node)) not in
22707 N_Package_Declaration | N_Generic_Package_Declaration
22710 ("pragma% can only apply to a package declaration");
22713 Set_Is_Shared_Passive (Cunit_Ent);
22714 end Shared_Passive;
22716 -----------------------
22717 -- Short_Descriptors --
22718 -----------------------
22720 -- pragma Short_Descriptors;
22722 -- Recognize and validate, but otherwise ignore
22724 when Pragma_Short_Descriptors =>
22726 Check_Arg_Count (0);
22727 Check_Valid_Configuration_Pragma;
22729 ------------------------------
22730 -- Simple_Storage_Pool_Type --
22731 ------------------------------
22733 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
22735 when Pragma_Simple_Storage_Pool_Type =>
22736 Simple_Storage_Pool_Type : declare
22742 Check_Arg_Count (1);
22743 Check_Arg_Is_Library_Level_Local_Name (Arg1);
22745 Type_Id := Get_Pragma_Arg (Arg1);
22746 Find_Type (Type_Id);
22747 Typ := Entity (Type_Id);
22749 if Typ = Any_Type then
22753 -- A pragma that applies to a Ghost entity becomes Ghost for the
22754 -- purposes of legality checks and removal of ignored Ghost code.
22756 Mark_Ghost_Pragma (N, Typ);
22758 -- We require the pragma to apply to a type declared in a package
22759 -- declaration, but not (immediately) within a package body.
22761 if Ekind (Current_Scope) /= E_Package
22762 or else In_Package_Body (Current_Scope)
22765 ("pragma% can only apply to type declared immediately "
22766 & "within a package declaration");
22769 -- A simple storage pool type must be an immutably limited record
22770 -- or private type. If the pragma is given for a private type,
22771 -- the full type is similarly restricted (which is checked later
22772 -- in Freeze_Entity).
22774 if Is_Record_Type (Typ)
22775 and then not Is_Limited_View (Typ)
22778 ("pragma% can only apply to explicitly limited record type");
22780 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
22782 ("pragma% can only apply to a private type that is limited");
22784 elsif not Is_Record_Type (Typ)
22785 and then not Is_Private_Type (Typ)
22788 ("pragma% can only apply to limited record or private type");
22791 Record_Rep_Item (Typ, N);
22792 end Simple_Storage_Pool_Type;
22794 ----------------------
22795 -- Source_File_Name --
22796 ----------------------
22798 -- There are five forms for this pragma:
22800 -- pragma Source_File_Name (
22801 -- [UNIT_NAME =>] unit_NAME,
22802 -- BODY_FILE_NAME => STRING_LITERAL
22803 -- [, [INDEX =>] INTEGER_LITERAL]);
22805 -- pragma Source_File_Name (
22806 -- [UNIT_NAME =>] unit_NAME,
22807 -- SPEC_FILE_NAME => STRING_LITERAL
22808 -- [, [INDEX =>] INTEGER_LITERAL]);
22810 -- pragma Source_File_Name (
22811 -- BODY_FILE_NAME => STRING_LITERAL
22812 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22813 -- [, CASING => CASING_SPEC]);
22815 -- pragma Source_File_Name (
22816 -- SPEC_FILE_NAME => STRING_LITERAL
22817 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22818 -- [, CASING => CASING_SPEC]);
22820 -- pragma Source_File_Name (
22821 -- SUBUNIT_FILE_NAME => STRING_LITERAL
22822 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22823 -- [, CASING => CASING_SPEC]);
22825 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
22827 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
22828 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
22829 -- only be used when no project file is used, while SFNP can only be
22830 -- used when a project file is used.
22832 -- No processing here. Processing was completed during parsing, since
22833 -- we need to have file names set as early as possible. Units are
22834 -- loaded well before semantic processing starts.
22836 -- The only processing we defer to this point is the check for
22837 -- correct placement.
22839 when Pragma_Source_File_Name =>
22841 Check_Valid_Configuration_Pragma;
22843 ------------------------------
22844 -- Source_File_Name_Project --
22845 ------------------------------
22847 -- See Source_File_Name for syntax
22849 -- No processing here. Processing was completed during parsing, since
22850 -- we need to have file names set as early as possible. Units are
22851 -- loaded well before semantic processing starts.
22853 -- The only processing we defer to this point is the check for
22854 -- correct placement.
22856 when Pragma_Source_File_Name_Project =>
22858 Check_Valid_Configuration_Pragma;
22860 -- Check that a pragma Source_File_Name_Project is used only in a
22861 -- configuration pragmas file.
22863 -- Pragmas Source_File_Name_Project should only be generated by
22864 -- the Project Manager in configuration pragmas files.
22866 -- This is really an ugly test. It seems to depend on some
22867 -- accidental and undocumented property. At the very least it
22868 -- needs to be documented, but it would be better to have a
22869 -- clean way of testing if we are in a configuration file???
22871 if Present (Parent (N)) then
22873 ("pragma% can only appear in a configuration pragmas file");
22876 ----------------------
22877 -- Source_Reference --
22878 ----------------------
22880 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
22882 -- Nothing to do, all processing completed in Par.Prag, since we need
22883 -- the information for possible parser messages that are output.
22885 when Pragma_Source_Reference =>
22892 -- pragma SPARK_Mode [(On | Off)];
22894 when Pragma_SPARK_Mode => Do_SPARK_Mode : declare
22895 Mode_Id : SPARK_Mode_Type;
22897 procedure Check_Pragma_Conformance
22898 (Context_Pragma : Node_Id;
22899 Entity : Entity_Id;
22900 Entity_Pragma : Node_Id);
22901 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
22902 -- conformance of pragma N depending the following scenarios:
22904 -- If pragma Context_Pragma is not Empty, verify that pragma N is
22905 -- compatible with the pragma Context_Pragma that was inherited
22906 -- from the context:
22907 -- * If the mode of Context_Pragma is ON, then the new mode can
22909 -- * If the mode of Context_Pragma is OFF, then the only allowed
22910 -- new mode is also OFF. Emit error if this is not the case.
22912 -- If Entity is not Empty, verify that pragma N is compatible with
22913 -- pragma Entity_Pragma that belongs to Entity.
22914 -- * If Entity_Pragma is Empty, always issue an error as this
22915 -- corresponds to the case where a previous section of Entity
22916 -- has no SPARK_Mode set.
22917 -- * If the mode of Entity_Pragma is ON, then the new mode can
22919 -- * If the mode of Entity_Pragma is OFF, then the only allowed
22920 -- new mode is also OFF. Emit error if this is not the case.
22922 procedure Check_Library_Level_Entity (E : Entity_Id);
22923 -- Subsidiary to routines Process_xxx. Verify that the related
22924 -- entity E subject to pragma SPARK_Mode is library-level.
22926 procedure Process_Body (Decl : Node_Id);
22927 -- Verify the legality of pragma SPARK_Mode when it appears as the
22928 -- top of the body declarations of entry, package, protected unit,
22929 -- subprogram or task unit body denoted by Decl.
22931 procedure Process_Overloadable (Decl : Node_Id);
22932 -- Verify the legality of pragma SPARK_Mode when it applies to an
22933 -- entry or [generic] subprogram declaration denoted by Decl.
22935 procedure Process_Private_Part (Decl : Node_Id);
22936 -- Verify the legality of pragma SPARK_Mode when it appears at the
22937 -- top of the private declarations of a package spec, protected or
22938 -- task unit declaration denoted by Decl.
22940 procedure Process_Statement_Part (Decl : Node_Id);
22941 -- Verify the legality of pragma SPARK_Mode when it appears at the
22942 -- top of the statement sequence of a package body denoted by node
22945 procedure Process_Visible_Part (Decl : Node_Id);
22946 -- Verify the legality of pragma SPARK_Mode when it appears at the
22947 -- top of the visible declarations of a package spec, protected or
22948 -- task unit declaration denoted by Decl. The routine is also used
22949 -- on protected or task units declared without a definition.
22951 procedure Set_SPARK_Context;
22952 -- Subsidiary to routines Process_xxx. Set the global variables
22953 -- which represent the mode of the context from pragma N. Ensure
22954 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
22956 ------------------------------
22957 -- Check_Pragma_Conformance --
22958 ------------------------------
22960 procedure Check_Pragma_Conformance
22961 (Context_Pragma : Node_Id;
22962 Entity : Entity_Id;
22963 Entity_Pragma : Node_Id)
22965 Err_Id : Entity_Id;
22969 -- The current pragma may appear without an argument. If this
22970 -- is the case, associate all error messages with the pragma
22973 if Present (Arg1) then
22979 -- The mode of the current pragma is compared against that of
22980 -- an enclosing context.
22982 if Present (Context_Pragma) then
22983 pragma Assert (Nkind (Context_Pragma) = N_Pragma);
22985 -- Issue an error if the new mode is less restrictive than
22986 -- that of the context.
22988 if Get_SPARK_Mode_From_Annotation (Context_Pragma) = Off
22989 and then Get_SPARK_Mode_From_Annotation (N) = On
22992 ("cannot change SPARK_Mode from Off to On", Err_N);
22993 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
22994 Error_Msg_N ("\SPARK_Mode was set to Off#", Err_N);
22999 -- The mode of the current pragma is compared against that of
23000 -- an initial package, protected type, subprogram or task type
23003 if Present (Entity) then
23005 -- A simple protected or task type is transformed into an
23006 -- anonymous type whose name cannot be used to issue error
23007 -- messages. Recover the original entity of the type.
23009 if Ekind (Entity) in E_Protected_Type | E_Task_Type then
23012 (Original_Node (Unit_Declaration_Node (Entity)));
23017 -- Both the initial declaration and the completion carry
23018 -- SPARK_Mode pragmas.
23020 if Present (Entity_Pragma) then
23021 pragma Assert (Nkind (Entity_Pragma) = N_Pragma);
23023 -- Issue an error if the new mode is less restrictive
23024 -- than that of the initial declaration.
23026 if Get_SPARK_Mode_From_Annotation (Entity_Pragma) = Off
23027 and then Get_SPARK_Mode_From_Annotation (N) = On
23029 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
23030 Error_Msg_Sloc := Sloc (Entity_Pragma);
23032 ("\value Off was set for SPARK_Mode on&#",
23037 -- Otherwise the initial declaration lacks a SPARK_Mode
23038 -- pragma in which case the current pragma is illegal as
23039 -- it cannot "complete".
23041 elsif Get_SPARK_Mode_From_Annotation (N) = Off
23042 and then (Is_Generic_Unit (Entity) or else In_Instance)
23047 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
23048 Error_Msg_Sloc := Sloc (Err_Id);
23050 ("\no value was set for SPARK_Mode on&#",
23055 end Check_Pragma_Conformance;
23057 --------------------------------
23058 -- Check_Library_Level_Entity --
23059 --------------------------------
23061 procedure Check_Library_Level_Entity (E : Entity_Id) is
23062 procedure Add_Entity_To_Name_Buffer;
23063 -- Add the E_Kind of entity E to the name buffer
23065 -------------------------------
23066 -- Add_Entity_To_Name_Buffer --
23067 -------------------------------
23069 procedure Add_Entity_To_Name_Buffer is
23071 if Ekind (E) in E_Entry | E_Entry_Family then
23072 Add_Str_To_Name_Buffer ("entry");
23074 elsif Ekind (E) in E_Generic_Package
23078 Add_Str_To_Name_Buffer ("package");
23080 elsif Ekind (E) in E_Protected_Body | E_Protected_Type then
23081 Add_Str_To_Name_Buffer ("protected type");
23083 elsif Ekind (E) in E_Function
23084 | E_Generic_Function
23085 | E_Generic_Procedure
23087 | E_Subprogram_Body
23089 Add_Str_To_Name_Buffer ("subprogram");
23092 pragma Assert (Ekind (E) in E_Task_Body | E_Task_Type);
23093 Add_Str_To_Name_Buffer ("task type");
23095 end Add_Entity_To_Name_Buffer;
23099 Msg_1 : constant String := "incorrect placement of pragma%";
23102 -- Start of processing for Check_Library_Level_Entity
23105 -- A SPARK_Mode of On shall only apply to library-level
23106 -- entities, except for those in generic instances, which are
23107 -- ignored (even if the entity gets SPARK_Mode pragma attached
23108 -- in the AST, its effect is not taken into account unless the
23109 -- context already provides SPARK_Mode of On in GNATprove).
23111 if Get_SPARK_Mode_From_Annotation (N) = On
23112 and then not Is_Library_Level_Entity (E)
23113 and then Instantiation_Location (Sloc (N)) = No_Location
23115 Error_Msg_Name_1 := Pname;
23116 Error_Msg_N (Fix_Error (Msg_1), N);
23119 Add_Str_To_Name_Buffer ("\& is not a library-level ");
23120 Add_Entity_To_Name_Buffer;
23122 Msg_2 := Name_Find;
23123 Error_Msg_NE (Get_Name_String (Msg_2), N, E);
23127 end Check_Library_Level_Entity;
23133 procedure Process_Body (Decl : Node_Id) is
23134 Body_Id : constant Entity_Id := Defining_Entity (Decl);
23135 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl);
23138 -- Ignore pragma when applied to the special body created for
23139 -- inlining, recognized by its internal name _Parent.
23141 if Chars (Body_Id) = Name_uParent then
23145 Check_Library_Level_Entity (Body_Id);
23147 -- For entry bodies, verify the legality against:
23148 -- * The mode of the context
23149 -- * The mode of the spec (if any)
23151 if Nkind (Decl) in N_Entry_Body | N_Subprogram_Body then
23153 -- A stand-alone subprogram body
23155 if Body_Id = Spec_Id then
23156 Check_Pragma_Conformance
23157 (Context_Pragma => SPARK_Pragma (Body_Id),
23159 Entity_Pragma => Empty);
23161 -- An entry or subprogram body that completes a previous
23165 Check_Pragma_Conformance
23166 (Context_Pragma => SPARK_Pragma (Body_Id),
23168 Entity_Pragma => SPARK_Pragma (Spec_Id));
23172 Set_SPARK_Pragma (Body_Id, N);
23173 Set_SPARK_Pragma_Inherited (Body_Id, False);
23175 -- For package bodies, verify the legality against:
23176 -- * The mode of the context
23177 -- * The mode of the private part
23179 -- This case is separated from protected and task bodies
23180 -- because the statement part of the package body inherits
23181 -- the mode of the body declarations.
23183 elsif Nkind (Decl) = N_Package_Body then
23184 Check_Pragma_Conformance
23185 (Context_Pragma => SPARK_Pragma (Body_Id),
23187 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
23190 Set_SPARK_Pragma (Body_Id, N);
23191 Set_SPARK_Pragma_Inherited (Body_Id, False);
23192 Set_SPARK_Aux_Pragma (Body_Id, N);
23193 Set_SPARK_Aux_Pragma_Inherited (Body_Id, True);
23195 -- For protected and task bodies, verify the legality against:
23196 -- * The mode of the context
23197 -- * The mode of the private part
23201 (Nkind (Decl) in N_Protected_Body | N_Task_Body);
23203 Check_Pragma_Conformance
23204 (Context_Pragma => SPARK_Pragma (Body_Id),
23206 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
23209 Set_SPARK_Pragma (Body_Id, N);
23210 Set_SPARK_Pragma_Inherited (Body_Id, False);
23214 --------------------------
23215 -- Process_Overloadable --
23216 --------------------------
23218 procedure Process_Overloadable (Decl : Node_Id) is
23219 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
23220 Spec_Typ : constant Entity_Id := Etype (Spec_Id);
23223 Check_Library_Level_Entity (Spec_Id);
23225 -- Verify the legality against:
23226 -- * The mode of the context
23228 Check_Pragma_Conformance
23229 (Context_Pragma => SPARK_Pragma (Spec_Id),
23231 Entity_Pragma => Empty);
23233 Set_SPARK_Pragma (Spec_Id, N);
23234 Set_SPARK_Pragma_Inherited (Spec_Id, False);
23236 -- When the pragma applies to the anonymous object created for
23237 -- a single task type, decorate the type as well. This scenario
23238 -- arises when the single task type lacks a task definition,
23239 -- therefore there is no issue with respect to a potential
23240 -- pragma SPARK_Mode in the private part.
23242 -- task type Anon_Task_Typ;
23243 -- Obj : Anon_Task_Typ;
23244 -- pragma SPARK_Mode ...;
23246 if Is_Single_Task_Object (Spec_Id) then
23247 Set_SPARK_Pragma (Spec_Typ, N);
23248 Set_SPARK_Pragma_Inherited (Spec_Typ, False);
23249 Set_SPARK_Aux_Pragma (Spec_Typ, N);
23250 Set_SPARK_Aux_Pragma_Inherited (Spec_Typ, True);
23252 end Process_Overloadable;
23254 --------------------------
23255 -- Process_Private_Part --
23256 --------------------------
23258 procedure Process_Private_Part (Decl : Node_Id) is
23259 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
23262 Check_Library_Level_Entity (Spec_Id);
23264 -- Verify the legality against:
23265 -- * The mode of the visible declarations
23267 Check_Pragma_Conformance
23268 (Context_Pragma => Empty,
23270 Entity_Pragma => SPARK_Pragma (Spec_Id));
23273 Set_SPARK_Aux_Pragma (Spec_Id, N);
23274 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False);
23275 end Process_Private_Part;
23277 ----------------------------
23278 -- Process_Statement_Part --
23279 ----------------------------
23281 procedure Process_Statement_Part (Decl : Node_Id) is
23282 Body_Id : constant Entity_Id := Defining_Entity (Decl);
23285 Check_Library_Level_Entity (Body_Id);
23287 -- Verify the legality against:
23288 -- * The mode of the body declarations
23290 Check_Pragma_Conformance
23291 (Context_Pragma => Empty,
23293 Entity_Pragma => SPARK_Pragma (Body_Id));
23296 Set_SPARK_Aux_Pragma (Body_Id, N);
23297 Set_SPARK_Aux_Pragma_Inherited (Body_Id, False);
23298 end Process_Statement_Part;
23300 --------------------------
23301 -- Process_Visible_Part --
23302 --------------------------
23304 procedure Process_Visible_Part (Decl : Node_Id) is
23305 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
23306 Obj_Id : Entity_Id;
23309 Check_Library_Level_Entity (Spec_Id);
23311 -- Verify the legality against:
23312 -- * The mode of the context
23314 Check_Pragma_Conformance
23315 (Context_Pragma => SPARK_Pragma (Spec_Id),
23317 Entity_Pragma => Empty);
23319 -- A task unit declared without a definition does not set the
23320 -- SPARK_Mode of the context because the task does not have any
23321 -- entries that could inherit the mode.
23323 if Nkind (Decl) not in
23324 N_Single_Task_Declaration | N_Task_Type_Declaration
23329 Set_SPARK_Pragma (Spec_Id, N);
23330 Set_SPARK_Pragma_Inherited (Spec_Id, False);
23331 Set_SPARK_Aux_Pragma (Spec_Id, N);
23332 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True);
23334 -- When the pragma applies to a single protected or task type,
23335 -- decorate the corresponding anonymous object as well.
23337 -- protected Anon_Prot_Typ is
23338 -- pragma SPARK_Mode ...;
23340 -- end Anon_Prot_Typ;
23342 -- Obj : Anon_Prot_Typ;
23344 if Is_Single_Concurrent_Type (Spec_Id) then
23345 Obj_Id := Anonymous_Object (Spec_Id);
23347 Set_SPARK_Pragma (Obj_Id, N);
23348 Set_SPARK_Pragma_Inherited (Obj_Id, False);
23350 end Process_Visible_Part;
23352 -----------------------
23353 -- Set_SPARK_Context --
23354 -----------------------
23356 procedure Set_SPARK_Context is
23358 SPARK_Mode := Mode_Id;
23359 SPARK_Mode_Pragma := N;
23360 end Set_SPARK_Context;
23368 -- Start of processing for Do_SPARK_Mode
23372 Check_No_Identifiers;
23373 Check_At_Most_N_Arguments (1);
23375 -- Check the legality of the mode (no argument = ON)
23377 if Arg_Count = 1 then
23378 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23379 Mode := Chars (Get_Pragma_Arg (Arg1));
23384 Mode_Id := Get_SPARK_Mode_Type (Mode);
23385 Context := Parent (N);
23387 -- When a SPARK_Mode pragma appears inside an instantiation whose
23388 -- enclosing context has SPARK_Mode set to "off", the pragma has
23389 -- no semantic effect.
23391 if Ignore_SPARK_Mode_Pragmas_In_Instance
23392 and then Mode_Id /= Off
23394 Rewrite (N, Make_Null_Statement (Loc));
23399 -- The pragma appears in a configuration file
23401 if No (Context) then
23402 Check_Valid_Configuration_Pragma;
23404 if Present (SPARK_Mode_Pragma) then
23407 Prev => SPARK_Mode_Pragma);
23413 -- The pragma acts as a configuration pragma in a compilation unit
23415 -- pragma SPARK_Mode ...;
23416 -- package Pack is ...;
23418 elsif Nkind (Context) = N_Compilation_Unit
23419 and then List_Containing (N) = Context_Items (Context)
23421 Check_Valid_Configuration_Pragma;
23424 -- Otherwise the placement of the pragma within the tree dictates
23425 -- its associated construct. Inspect the declarative list where
23426 -- the pragma resides to find a potential construct.
23430 while Present (Stmt) loop
23432 -- Skip prior pragmas, but check for duplicates. Note that
23433 -- this also takes care of pragmas generated for aspects.
23435 if Nkind (Stmt) = N_Pragma then
23436 if Pragma_Name (Stmt) = Pname then
23443 -- The pragma applies to an expression function that has
23444 -- already been rewritten into a subprogram declaration.
23446 -- function Expr_Func return ... is (...);
23447 -- pragma SPARK_Mode ...;
23449 elsif Nkind (Stmt) = N_Subprogram_Declaration
23450 and then Nkind (Original_Node (Stmt)) =
23451 N_Expression_Function
23453 Process_Overloadable (Stmt);
23456 -- The pragma applies to the anonymous object created for a
23457 -- single concurrent type.
23459 -- protected type Anon_Prot_Typ ...;
23460 -- Obj : Anon_Prot_Typ;
23461 -- pragma SPARK_Mode ...;
23463 elsif Nkind (Stmt) = N_Object_Declaration
23464 and then Is_Single_Concurrent_Object
23465 (Defining_Entity (Stmt))
23467 Process_Overloadable (Stmt);
23470 -- Skip internally generated code
23472 elsif not Comes_From_Source (Stmt) then
23475 -- The pragma applies to an entry or [generic] subprogram
23479 -- pragma SPARK_Mode ...;
23482 -- procedure Proc ...;
23483 -- pragma SPARK_Mode ...;
23485 elsif Nkind (Stmt) in N_Generic_Subprogram_Declaration
23486 | N_Subprogram_Declaration
23487 or else (Nkind (Stmt) = N_Entry_Declaration
23488 and then Is_Protected_Type
23489 (Scope (Defining_Entity (Stmt))))
23491 Process_Overloadable (Stmt);
23494 -- Otherwise the pragma does not apply to a legal construct
23495 -- or it does not appear at the top of a declarative or a
23496 -- statement list. Issue an error and stop the analysis.
23506 -- The pragma applies to a package or a subprogram that acts as
23507 -- a compilation unit.
23509 -- procedure Proc ...;
23510 -- pragma SPARK_Mode ...;
23512 if Nkind (Context) = N_Compilation_Unit_Aux then
23513 Context := Unit (Parent (Context));
23516 -- The pragma appears at the top of entry, package, protected
23517 -- unit, subprogram or task unit body declarations.
23519 -- entry Ent when ... is
23520 -- pragma SPARK_Mode ...;
23522 -- package body Pack is
23523 -- pragma SPARK_Mode ...;
23525 -- procedure Proc ... is
23526 -- pragma SPARK_Mode;
23528 -- protected body Prot is
23529 -- pragma SPARK_Mode ...;
23531 if Nkind (Context) in N_Entry_Body
23534 | N_Subprogram_Body
23537 Process_Body (Context);
23539 -- The pragma appears at the top of the visible or private
23540 -- declaration of a package spec, protected or task unit.
23543 -- pragma SPARK_Mode ...;
23545 -- pragma SPARK_Mode ...;
23547 -- protected [type] Prot is
23548 -- pragma SPARK_Mode ...;
23550 -- pragma SPARK_Mode ...;
23552 elsif Nkind (Context) in N_Package_Specification
23553 | N_Protected_Definition
23554 | N_Task_Definition
23556 if List_Containing (N) = Visible_Declarations (Context) then
23557 Process_Visible_Part (Parent (Context));
23559 Process_Private_Part (Parent (Context));
23562 -- The pragma appears at the top of package body statements
23564 -- package body Pack is
23566 -- pragma SPARK_Mode;
23568 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
23569 and then Nkind (Parent (Context)) = N_Package_Body
23571 Process_Statement_Part (Parent (Context));
23573 -- The pragma appeared as an aspect of a [generic] subprogram
23574 -- declaration that acts as a compilation unit.
23577 -- procedure Proc ...;
23578 -- pragma SPARK_Mode ...;
23580 elsif Nkind (Context) in N_Generic_Subprogram_Declaration
23581 | N_Subprogram_Declaration
23583 Process_Overloadable (Context);
23585 -- The pragma does not apply to a legal construct, issue error
23593 --------------------------------
23594 -- Static_Elaboration_Desired --
23595 --------------------------------
23597 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
23599 when Pragma_Static_Elaboration_Desired =>
23601 Check_At_Most_N_Arguments (1);
23603 if Is_Compilation_Unit (Current_Scope)
23604 and then Ekind (Current_Scope) = E_Package
23606 Set_Static_Elaboration_Desired (Current_Scope, True);
23608 Error_Pragma ("pragma% must apply to a library-level package");
23615 -- pragma Storage_Size (EXPRESSION);
23617 when Pragma_Storage_Size => Storage_Size : declare
23618 P : constant Node_Id := Parent (N);
23622 Check_No_Identifiers;
23623 Check_Arg_Count (1);
23625 -- The expression must be analyzed in the special manner described
23626 -- in "Handling of Default Expressions" in sem.ads.
23628 Arg := Get_Pragma_Arg (Arg1);
23629 Preanalyze_Spec_Expression (Arg, Any_Integer);
23631 if not Is_OK_Static_Expression (Arg) then
23632 Check_Restriction (Static_Storage_Size, Arg);
23635 if Nkind (P) /= N_Task_Definition then
23640 if Has_Storage_Size_Pragma (P) then
23641 Error_Pragma ("duplicate pragma% not allowed");
23643 Set_Has_Storage_Size_Pragma (P, True);
23646 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
23654 -- pragma Storage_Unit (NUMERIC_LITERAL);
23656 -- Only permitted argument is System'Storage_Unit value
23658 when Pragma_Storage_Unit =>
23659 Check_No_Identifiers;
23660 Check_Arg_Count (1);
23661 Check_Arg_Is_Integer_Literal (Arg1);
23663 if Intval (Get_Pragma_Arg (Arg1)) /=
23664 UI_From_Int (Ttypes.System_Storage_Unit)
23666 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
23668 ("the only allowed argument for pragma% is ^", Arg1);
23671 --------------------
23672 -- Stream_Convert --
23673 --------------------
23675 -- pragma Stream_Convert (
23676 -- [Entity =>] type_LOCAL_NAME,
23677 -- [Read =>] function_NAME,
23678 -- [Write =>] function NAME);
23680 when Pragma_Stream_Convert => Stream_Convert : declare
23681 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
23682 -- Check that the given argument is the name of a local function
23683 -- of one argument that is not overloaded earlier in the current
23684 -- local scope. A check is also made that the argument is a
23685 -- function with one parameter.
23687 --------------------------------------
23688 -- Check_OK_Stream_Convert_Function --
23689 --------------------------------------
23691 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
23695 Check_Arg_Is_Local_Name (Arg);
23696 Ent := Entity (Get_Pragma_Arg (Arg));
23698 if Has_Homonym (Ent) then
23700 ("argument for pragma% may not be overloaded", Arg);
23703 if Ekind (Ent) /= E_Function
23704 or else No (First_Formal (Ent))
23705 or else Present (Next_Formal (First_Formal (Ent)))
23708 ("argument for pragma% must be function of one argument",
23710 elsif Is_Abstract_Subprogram (Ent) then
23712 ("argument for pragma% cannot be abstract", Arg);
23714 end Check_OK_Stream_Convert_Function;
23716 -- Start of processing for Stream_Convert
23720 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
23721 Check_Arg_Count (3);
23722 Check_Optional_Identifier (Arg1, Name_Entity);
23723 Check_Optional_Identifier (Arg2, Name_Read);
23724 Check_Optional_Identifier (Arg3, Name_Write);
23725 Check_Arg_Is_Local_Name (Arg1);
23726 Check_OK_Stream_Convert_Function (Arg2);
23727 Check_OK_Stream_Convert_Function (Arg3);
23730 Typ : constant Entity_Id :=
23731 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
23732 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
23733 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
23736 Check_First_Subtype (Arg1);
23738 -- Check for too early or too late. Note that we don't enforce
23739 -- the rule about primitive operations in this case, since, as
23740 -- is the case for explicit stream attributes themselves, these
23741 -- restrictions are not appropriate. Note that the chaining of
23742 -- the pragma by Rep_Item_Too_Late is actually the critical
23743 -- processing done for this pragma.
23745 if Rep_Item_Too_Early (Typ, N)
23747 Rep_Item_Too_Late (Typ, N, FOnly => True)
23752 -- Return if previous error
23754 if Etype (Typ) = Any_Type
23756 Etype (Read) = Any_Type
23758 Etype (Write) = Any_Type
23765 if Underlying_Type (Etype (Read)) /= Typ then
23767 ("incorrect return type for function&", Arg2);
23770 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
23772 ("incorrect parameter type for function&", Arg3);
23775 if Underlying_Type (Etype (First_Formal (Read))) /=
23776 Underlying_Type (Etype (Write))
23779 ("result type of & does not match Read parameter type",
23783 end Stream_Convert;
23789 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
23791 -- This is processed by the parser since some of the style checks
23792 -- take place during source scanning and parsing. This means that
23793 -- we don't need to issue error messages here.
23795 when Pragma_Style_Checks => Style_Checks : declare
23796 A : constant Node_Id := Get_Pragma_Arg (Arg1);
23802 Check_No_Identifiers;
23804 -- Two argument form
23806 if Arg_Count = 2 then
23807 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23814 E_Id := Get_Pragma_Arg (Arg2);
23817 if not Is_Entity_Name (E_Id) then
23819 ("second argument of pragma% must be entity name",
23823 E := Entity (E_Id);
23825 if not Ignore_Style_Checks_Pragmas then
23830 Set_Suppress_Style_Checks
23831 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off);
23832 exit when No (Homonym (E));
23839 -- One argument form
23842 Check_Arg_Count (1);
23844 if Nkind (A) = N_String_Literal then
23848 Slen : constant Natural := Natural (String_Length (S));
23849 Options : String (1 .. Slen);
23855 C := Get_String_Char (S, Pos (J));
23856 exit when not In_Character_Range (C);
23857 Options (J) := Get_Character (C);
23859 -- If at end of string, set options. As per discussion
23860 -- above, no need to check for errors, since we issued
23861 -- them in the parser.
23864 if not Ignore_Style_Checks_Pragmas then
23865 Set_Style_Check_Options (Options);
23875 elsif Nkind (A) = N_Identifier then
23876 if Chars (A) = Name_All_Checks then
23877 if not Ignore_Style_Checks_Pragmas then
23879 Set_GNAT_Style_Check_Options;
23881 Set_Default_Style_Check_Options;
23885 elsif Chars (A) = Name_On then
23886 if not Ignore_Style_Checks_Pragmas then
23887 Style_Check := True;
23890 elsif Chars (A) = Name_Off then
23891 if not Ignore_Style_Checks_Pragmas then
23892 Style_Check := False;
23903 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
23905 when Pragma_Subtitle =>
23907 Check_Arg_Count (1);
23908 Check_Optional_Identifier (Arg1, Name_Subtitle);
23909 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
23916 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
23918 when Pragma_Suppress =>
23919 Process_Suppress_Unsuppress (Suppress_Case => True);
23925 -- pragma Suppress_All;
23927 -- The only check made here is that the pragma has no arguments.
23928 -- There are no placement rules, and the processing required (setting
23929 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
23930 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
23931 -- then creates and inserts a pragma Suppress (All_Checks).
23933 when Pragma_Suppress_All =>
23935 Check_Arg_Count (0);
23937 -------------------------
23938 -- Suppress_Debug_Info --
23939 -------------------------
23941 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
23943 when Pragma_Suppress_Debug_Info => Suppress_Debug_Info : declare
23944 Nam_Id : Entity_Id;
23948 Check_Arg_Count (1);
23949 Check_Optional_Identifier (Arg1, Name_Entity);
23950 Check_Arg_Is_Local_Name (Arg1);
23952 Nam_Id := Entity (Get_Pragma_Arg (Arg1));
23954 -- A pragma that applies to a Ghost entity becomes Ghost for the
23955 -- purposes of legality checks and removal of ignored Ghost code.
23957 Mark_Ghost_Pragma (N, Nam_Id);
23958 Set_Debug_Info_Off (Nam_Id);
23959 end Suppress_Debug_Info;
23961 ----------------------------------
23962 -- Suppress_Exception_Locations --
23963 ----------------------------------
23965 -- pragma Suppress_Exception_Locations;
23967 when Pragma_Suppress_Exception_Locations =>
23969 Check_Arg_Count (0);
23970 Check_Valid_Configuration_Pragma;
23971 Exception_Locations_Suppressed := True;
23973 -----------------------------
23974 -- Suppress_Initialization --
23975 -----------------------------
23977 -- pragma Suppress_Initialization ([Entity =>] type_Name);
23979 when Pragma_Suppress_Initialization => Suppress_Init : declare
23985 Check_Arg_Count (1);
23986 Check_Optional_Identifier (Arg1, Name_Entity);
23987 Check_Arg_Is_Local_Name (Arg1);
23989 E_Id := Get_Pragma_Arg (Arg1);
23991 if Etype (E_Id) = Any_Type then
23995 E := Entity (E_Id);
23997 -- A pragma that applies to a Ghost entity becomes Ghost for the
23998 -- purposes of legality checks and removal of ignored Ghost code.
24000 Mark_Ghost_Pragma (N, E);
24002 if not Is_Type (E) and then Ekind (E) /= E_Variable then
24004 ("pragma% requires variable, type or subtype", Arg1);
24007 if Rep_Item_Too_Early (E, N)
24009 Rep_Item_Too_Late (E, N, FOnly => True)
24014 -- For incomplete/private type, set flag on full view
24016 if Is_Incomplete_Or_Private_Type (E) then
24017 if No (Full_View (Base_Type (E))) then
24019 ("argument of pragma% cannot be an incomplete type", Arg1);
24021 Set_Suppress_Initialization (Full_View (E));
24024 -- For first subtype, set flag on base type
24026 elsif Is_First_Subtype (E) then
24027 Set_Suppress_Initialization (Base_Type (E));
24029 -- For other than first subtype, set flag on subtype or variable
24032 Set_Suppress_Initialization (E);
24040 -- pragma System_Name (DIRECT_NAME);
24042 -- Syntax check: one argument, which must be the identifier GNAT or
24043 -- the identifier GCC, no other identifiers are acceptable.
24045 when Pragma_System_Name =>
24047 Check_No_Identifiers;
24048 Check_Arg_Count (1);
24049 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
24051 -----------------------------
24052 -- Task_Dispatching_Policy --
24053 -----------------------------
24055 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
24057 when Pragma_Task_Dispatching_Policy => declare
24061 Check_Ada_83_Warning;
24062 Check_Arg_Count (1);
24063 Check_No_Identifiers;
24064 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
24065 Check_Valid_Configuration_Pragma;
24066 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
24067 DP := Fold_Upper (Name_Buffer (1));
24069 if Task_Dispatching_Policy /= ' '
24070 and then Task_Dispatching_Policy /= DP
24072 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
24074 ("task dispatching policy incompatible with policy#");
24076 -- Set new policy, but always preserve System_Location since we
24077 -- like the error message with the run time name.
24080 Task_Dispatching_Policy := DP;
24082 if Task_Dispatching_Policy_Sloc /= System_Location then
24083 Task_Dispatching_Policy_Sloc := Loc;
24092 -- pragma Task_Info (EXPRESSION);
24094 when Pragma_Task_Info => Task_Info : declare
24095 P : constant Node_Id := Parent (N);
24101 if Warn_On_Obsolescent_Feature then
24103 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
24104 & "instead?j?", N);
24107 if Nkind (P) /= N_Task_Definition then
24108 Error_Pragma ("pragma% must appear in task definition");
24111 Check_No_Identifiers;
24112 Check_Arg_Count (1);
24114 Analyze_And_Resolve
24115 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
24117 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
24121 Ent := Defining_Identifier (Parent (P));
24123 -- Check duplicate pragma before we chain the pragma in the Rep
24124 -- Item chain of Ent.
24127 (Ent, Name_Task_Info, Check_Parents => False)
24129 Error_Pragma ("duplicate pragma% not allowed");
24132 Record_Rep_Item (Ent, N);
24139 -- pragma Task_Name (string_EXPRESSION);
24141 when Pragma_Task_Name => Task_Name : declare
24142 P : constant Node_Id := Parent (N);
24147 Check_No_Identifiers;
24148 Check_Arg_Count (1);
24150 Arg := Get_Pragma_Arg (Arg1);
24152 -- The expression is used in the call to Create_Task, and must be
24153 -- expanded there, not in the context of the current spec. It must
24154 -- however be analyzed to capture global references, in case it
24155 -- appears in a generic context.
24157 Preanalyze_And_Resolve (Arg, Standard_String);
24159 if Nkind (P) /= N_Task_Definition then
24163 Ent := Defining_Identifier (Parent (P));
24165 -- Check duplicate pragma before we chain the pragma in the Rep
24166 -- Item chain of Ent.
24169 (Ent, Name_Task_Name, Check_Parents => False)
24171 Error_Pragma ("duplicate pragma% not allowed");
24174 Record_Rep_Item (Ent, N);
24181 -- pragma Task_Storage (
24182 -- [Task_Type =>] LOCAL_NAME,
24183 -- [Top_Guard =>] static_integer_EXPRESSION);
24185 when Pragma_Task_Storage => Task_Storage : declare
24186 Args : Args_List (1 .. 2);
24187 Names : constant Name_List (1 .. 2) := (
24191 Task_Type : Node_Id renames Args (1);
24192 Top_Guard : Node_Id renames Args (2);
24198 Gather_Associations (Names, Args);
24200 if No (Task_Type) then
24202 ("missing task_type argument for pragma%");
24205 Check_Arg_Is_Local_Name (Task_Type);
24207 Ent := Entity (Task_Type);
24209 if not Is_Task_Type (Ent) then
24211 ("argument for pragma% must be task type", Task_Type);
24214 if No (Top_Guard) then
24216 ("pragma% takes two arguments", Task_Type);
24218 Check_Arg_Is_OK_Static_Expression (Top_Guard, Any_Integer);
24221 Check_First_Subtype (Task_Type);
24223 if Rep_Item_Too_Late (Ent, N) then
24232 -- pragma Test_Case
24233 -- ([Name =>] Static_String_EXPRESSION
24234 -- ,[Mode =>] MODE_TYPE
24235 -- [, Requires => Boolean_EXPRESSION]
24236 -- [, Ensures => Boolean_EXPRESSION]);
24238 -- MODE_TYPE ::= Nominal | Robustness
24240 -- Characteristics:
24242 -- * Analysis - The annotation undergoes initial checks to verify
24243 -- the legal placement and context. Secondary checks preanalyze the
24246 -- Analyze_Test_Case_In_Decl_Part
24248 -- * Expansion - None.
24250 -- * Template - The annotation utilizes the generic template of the
24251 -- related subprogram when it is:
24253 -- aspect on subprogram declaration
24255 -- The annotation must prepare its own template when it is:
24257 -- pragma on subprogram declaration
24259 -- * Globals - Capture of global references must occur after full
24262 -- * Instance - The annotation is instantiated automatically when
24263 -- the related generic subprogram is instantiated except for the
24264 -- "pragma on subprogram declaration" case. In that scenario the
24265 -- annotation must instantiate itself.
24267 when Pragma_Test_Case => Test_Case : declare
24268 procedure Check_Distinct_Name (Subp_Id : Entity_Id);
24269 -- Ensure that the contract of subprogram Subp_Id does not contain
24270 -- another Test_Case pragma with the same Name as the current one.
24272 -------------------------
24273 -- Check_Distinct_Name --
24274 -------------------------
24276 procedure Check_Distinct_Name (Subp_Id : Entity_Id) is
24277 Items : constant Node_Id := Contract (Subp_Id);
24278 Name : constant String_Id := Get_Name_From_CTC_Pragma (N);
24282 -- Inspect all Test_Case pragma of the related subprogram
24283 -- looking for one with a duplicate "Name" argument.
24285 if Present (Items) then
24286 Prag := Contract_Test_Cases (Items);
24287 while Present (Prag) loop
24288 if Pragma_Name (Prag) = Name_Test_Case
24290 and then String_Equal
24291 (Name, Get_Name_From_CTC_Pragma (Prag))
24293 Error_Msg_Sloc := Sloc (Prag);
24294 Error_Pragma ("name for pragma % is already used #");
24297 Prag := Next_Pragma (Prag);
24300 end Check_Distinct_Name;
24304 Pack_Decl : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
24307 Subp_Decl : Node_Id;
24308 Subp_Id : Entity_Id;
24310 -- Start of processing for Test_Case
24314 Check_At_Least_N_Arguments (2);
24315 Check_At_Most_N_Arguments (4);
24317 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
24321 Check_Optional_Identifier (Arg1, Name_Name);
24322 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
24326 Check_Optional_Identifier (Arg2, Name_Mode);
24327 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
24329 -- Arguments "Requires" and "Ensures"
24331 if Present (Arg3) then
24332 if Present (Arg4) then
24333 Check_Identifier (Arg3, Name_Requires);
24334 Check_Identifier (Arg4, Name_Ensures);
24336 Check_Identifier_Is_One_Of
24337 (Arg3, Name_Requires, Name_Ensures);
24341 -- Pragma Test_Case must be associated with a subprogram declared
24342 -- in a library-level package. First determine whether the current
24343 -- compilation unit is a legal context.
24345 if Nkind (Pack_Decl) in N_Package_Declaration
24346 | N_Generic_Package_Declaration
24350 -- Otherwise the placement is illegal
24354 ("pragma % must be specified within a package declaration");
24358 Subp_Decl := Find_Related_Declaration_Or_Body (N);
24360 -- Find the enclosing context
24362 Context := Parent (Subp_Decl);
24364 if Present (Context) then
24365 Context := Parent (Context);
24368 -- Verify the placement of the pragma
24370 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
24372 ("pragma % cannot be applied to abstract subprogram");
24375 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
24376 Error_Pragma ("pragma % cannot be applied to entry");
24379 -- The context is a [generic] subprogram declared at the top level
24380 -- of the [generic] package unit.
24382 elsif Nkind (Subp_Decl) in N_Generic_Subprogram_Declaration
24383 | N_Subprogram_Declaration
24384 and then Present (Context)
24385 and then Nkind (Context) in N_Generic_Package_Declaration
24386 | N_Package_Declaration
24390 -- Otherwise the placement is illegal
24394 ("pragma % must be applied to a library-level subprogram "
24399 Subp_Id := Defining_Entity (Subp_Decl);
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, Subp_Id);
24406 -- Chain the pragma on the contract for further processing by
24407 -- Analyze_Test_Case_In_Decl_Part.
24409 Add_Contract_Item (N, Subp_Id);
24411 -- Preanalyze the original aspect argument "Name" for a generic
24412 -- subprogram to properly capture global references.
24414 if Is_Generic_Subprogram (Subp_Id) then
24415 Asp_Arg := Test_Case_Arg (N, Name_Name, From_Aspect => True);
24417 if Present (Asp_Arg) then
24419 -- The argument appears with an identifier in association
24422 if Nkind (Asp_Arg) = N_Component_Association then
24423 Asp_Arg := Expression (Asp_Arg);
24426 Check_Expr_Is_OK_Static_Expression
24427 (Asp_Arg, Standard_String);
24431 -- Ensure that the all Test_Case pragmas of the related subprogram
24432 -- have distinct names.
24434 Check_Distinct_Name (Subp_Id);
24436 -- Fully analyze the pragma when it appears inside an entry
24437 -- or subprogram body because it cannot benefit from forward
24440 if Nkind (Subp_Decl) in N_Entry_Body
24441 | N_Subprogram_Body
24442 | N_Subprogram_Body_Stub
24444 -- The legality checks of pragma Test_Case are affected by the
24445 -- SPARK mode in effect and the volatility of the context.
24446 -- Analyze all pragmas in a specific order.
24448 Analyze_If_Present (Pragma_SPARK_Mode);
24449 Analyze_If_Present (Pragma_Volatile_Function);
24450 Analyze_Test_Case_In_Decl_Part (N);
24454 --------------------------
24455 -- Thread_Local_Storage --
24456 --------------------------
24458 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
24460 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
24466 Check_Arg_Count (1);
24467 Check_Optional_Identifier (Arg1, Name_Entity);
24468 Check_Arg_Is_Library_Level_Local_Name (Arg1);
24470 Id := Get_Pragma_Arg (Arg1);
24473 if not Is_Entity_Name (Id)
24474 or else Ekind (Entity (Id)) /= E_Variable
24476 Error_Pragma_Arg ("local variable name required", Arg1);
24481 -- A pragma that applies to a Ghost entity becomes Ghost for the
24482 -- purposes of legality checks and removal of ignored Ghost code.
24484 Mark_Ghost_Pragma (N, E);
24486 if Rep_Item_Too_Early (E, N)
24488 Rep_Item_Too_Late (E, N)
24493 Set_Has_Pragma_Thread_Local_Storage (E);
24494 Set_Has_Gigi_Rep_Item (E);
24495 end Thread_Local_Storage;
24501 -- pragma Time_Slice (static_duration_EXPRESSION);
24503 when Pragma_Time_Slice => Time_Slice : declare
24509 Check_Arg_Count (1);
24510 Check_No_Identifiers;
24511 Check_In_Main_Program;
24512 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_Duration);
24514 if not Error_Posted (Arg1) then
24516 while Present (Nod) loop
24517 if Nkind (Nod) = N_Pragma
24518 and then Pragma_Name (Nod) = Name_Time_Slice
24520 Error_Msg_Name_1 := Pname;
24521 Error_Msg_N ("duplicate pragma% not permitted", Nod);
24528 -- Process only if in main unit
24530 if Get_Source_Unit (Loc) = Main_Unit then
24531 Opt.Time_Slice_Set := True;
24532 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
24534 if Val <= Ureal_0 then
24535 Opt.Time_Slice_Value := 0;
24537 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
24538 Opt.Time_Slice_Value := 1_000_000_000;
24541 Opt.Time_Slice_Value :=
24542 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
24551 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
24553 -- TITLING_OPTION ::=
24554 -- [Title =>] STRING_LITERAL
24555 -- | [Subtitle =>] STRING_LITERAL
24557 when Pragma_Title => Title : declare
24558 Args : Args_List (1 .. 2);
24559 Names : constant Name_List (1 .. 2) := (
24565 Gather_Associations (Names, Args);
24568 for J in 1 .. 2 loop
24569 if Present (Args (J)) then
24570 Check_Arg_Is_OK_Static_Expression
24571 (Args (J), Standard_String);
24576 ----------------------------
24577 -- Type_Invariant[_Class] --
24578 ----------------------------
24580 -- pragma Type_Invariant[_Class]
24581 -- ([Entity =>] type_LOCAL_NAME,
24582 -- [Check =>] EXPRESSION);
24584 when Pragma_Type_Invariant
24585 | Pragma_Type_Invariant_Class
24587 Type_Invariant : declare
24588 I_Pragma : Node_Id;
24591 Check_Arg_Count (2);
24593 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
24594 -- setting Class_Present for the Type_Invariant_Class case.
24596 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class);
24597 I_Pragma := New_Copy (N);
24598 Set_Pragma_Identifier
24599 (I_Pragma, Make_Identifier (Loc, Name_Invariant));
24600 Rewrite (N, I_Pragma);
24601 Set_Analyzed (N, False);
24603 end Type_Invariant;
24605 ---------------------
24606 -- Unchecked_Union --
24607 ---------------------
24609 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
24611 when Pragma_Unchecked_Union => Unchecked_Union : declare
24612 Assoc : constant Node_Id := Arg1;
24613 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
24623 Check_No_Identifiers;
24624 Check_Arg_Count (1);
24625 Check_Arg_Is_Local_Name (Arg1);
24627 Find_Type (Type_Id);
24629 Typ := Entity (Type_Id);
24631 -- A pragma that applies to a Ghost entity becomes Ghost for the
24632 -- purposes of legality checks and removal of ignored Ghost code.
24634 Mark_Ghost_Pragma (N, Typ);
24637 or else Rep_Item_Too_Early (Typ, N)
24641 Typ := Underlying_Type (Typ);
24644 if Rep_Item_Too_Late (Typ, N) then
24648 Check_First_Subtype (Arg1);
24650 -- Note remaining cases are references to a type in the current
24651 -- declarative part. If we find an error, we post the error on
24652 -- the relevant type declaration at an appropriate point.
24654 if not Is_Record_Type (Typ) then
24655 Error_Msg_N ("unchecked union must be record type", Typ);
24658 elsif Is_Tagged_Type (Typ) then
24659 Error_Msg_N ("unchecked union must not be tagged", Typ);
24662 elsif not Has_Discriminants (Typ) then
24664 ("unchecked union must have one discriminant", Typ);
24667 -- Note: in previous versions of GNAT we used to check for limited
24668 -- types and give an error, but in fact the standard does allow
24669 -- Unchecked_Union on limited types, so this check was removed.
24671 -- Similarly, GNAT used to require that all discriminants have
24672 -- default values, but this is not mandated by the RM.
24674 -- Proceed with basic error checks completed
24677 Tdef := Type_Definition (Declaration_Node (Typ));
24678 Clist := Component_List (Tdef);
24680 -- Check presence of component list and variant part
24682 if No (Clist) or else No (Variant_Part (Clist)) then
24684 ("unchecked union must have variant part", Tdef);
24688 -- Check components
24690 Comp := First_Non_Pragma (Component_Items (Clist));
24691 while Present (Comp) loop
24692 Check_Component (Comp, Typ);
24693 Next_Non_Pragma (Comp);
24696 -- Check variant part
24698 Vpart := Variant_Part (Clist);
24700 Variant := First_Non_Pragma (Variants (Vpart));
24701 while Present (Variant) loop
24702 Check_Variant (Variant, Typ);
24703 Next_Non_Pragma (Variant);
24707 Set_Is_Unchecked_Union (Typ);
24708 Set_Convention (Typ, Convention_C);
24709 Set_Has_Unchecked_Union (Base_Type (Typ));
24710 Set_Is_Unchecked_Union (Base_Type (Typ));
24711 end Unchecked_Union;
24713 ----------------------------
24714 -- Unevaluated_Use_Of_Old --
24715 ----------------------------
24717 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
24719 when Pragma_Unevaluated_Use_Of_Old =>
24721 Check_Arg_Count (1);
24722 Check_No_Identifiers;
24723 Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow);
24725 -- Suppress/Unsuppress can appear as a configuration pragma, or in
24726 -- a declarative part or a package spec.
24728 if not Is_Configuration_Pragma then
24729 Check_Is_In_Decl_Part_Or_Package_Spec;
24732 -- Store proper setting of Uneval_Old
24734 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
24735 Uneval_Old := Fold_Upper (Name_Buffer (1));
24737 ------------------------
24738 -- Unimplemented_Unit --
24739 ------------------------
24741 -- pragma Unimplemented_Unit;
24743 -- Note: this only gives an error if we are generating code, or if
24744 -- we are in a generic library unit (where the pragma appears in the
24745 -- body, not in the spec).
24747 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
24748 Cunitent : constant Entity_Id :=
24749 Cunit_Entity (Get_Source_Unit (Loc));
24750 Ent_Kind : constant Entity_Kind := Ekind (Cunitent);
24754 Check_Arg_Count (0);
24756 if Operating_Mode = Generate_Code
24757 or else Ent_Kind = E_Generic_Function
24758 or else Ent_Kind = E_Generic_Procedure
24759 or else Ent_Kind = E_Generic_Package
24761 Get_Name_String (Chars (Cunitent));
24762 Set_Casing (Mixed_Case);
24763 Write_Str (Name_Buffer (1 .. Name_Len));
24764 Write_Str (" is not supported in this configuration");
24766 raise Unrecoverable_Error;
24768 end Unimplemented_Unit;
24770 ------------------------
24771 -- Universal_Aliasing --
24772 ------------------------
24774 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
24776 when Pragma_Universal_Aliasing => Universal_Alias : declare
24782 Check_Arg_Count (1);
24783 Check_Optional_Identifier (Arg2, Name_Entity);
24784 Check_Arg_Is_Local_Name (Arg1);
24785 E_Id := Get_Pragma_Arg (Arg1);
24787 if Etype (E_Id) = Any_Type then
24791 E := Entity (E_Id);
24793 if not Is_Type (E) then
24794 Error_Pragma_Arg ("pragma% requires type", Arg1);
24797 -- A pragma that applies to a Ghost entity becomes Ghost for the
24798 -- purposes of legality checks and removal of ignored Ghost code.
24800 Mark_Ghost_Pragma (N, E);
24801 Set_Universal_Aliasing (Base_Type (E));
24802 Record_Rep_Item (E, N);
24803 end Universal_Alias;
24805 --------------------
24806 -- Universal_Data --
24807 --------------------
24809 -- pragma Universal_Data [(library_unit_NAME)];
24811 when Pragma_Universal_Data =>
24813 Error_Pragma ("??pragma% ignored (applies only to AAMP)");
24819 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
24821 when Pragma_Unmodified =>
24822 Analyze_Unmodified_Or_Unused;
24828 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
24830 -- or when used in a context clause:
24832 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
24834 when Pragma_Unreferenced =>
24835 Analyze_Unreferenced_Or_Unused;
24837 --------------------------
24838 -- Unreferenced_Objects --
24839 --------------------------
24841 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
24843 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
24845 Arg_Expr : Node_Id;
24846 Arg_Id : Entity_Id;
24848 Ghost_Error_Posted : Boolean := False;
24849 -- Flag set when an error concerning the illegal mix of Ghost and
24850 -- non-Ghost types is emitted.
24852 Ghost_Id : Entity_Id := Empty;
24853 -- The entity of the first Ghost type encountered while processing
24854 -- the arguments of the pragma.
24858 Check_At_Least_N_Arguments (1);
24861 while Present (Arg) loop
24862 Check_No_Identifier (Arg);
24863 Check_Arg_Is_Local_Name (Arg);
24864 Arg_Expr := Get_Pragma_Arg (Arg);
24866 if Is_Entity_Name (Arg_Expr) then
24867 Arg_Id := Entity (Arg_Expr);
24869 if Is_Type (Arg_Id) then
24870 Set_Has_Pragma_Unreferenced_Objects (Arg_Id);
24872 -- A pragma that applies to a Ghost entity becomes Ghost
24873 -- for the purposes of legality checks and removal of
24874 -- ignored Ghost code.
24876 Mark_Ghost_Pragma (N, Arg_Id);
24878 -- Capture the entity of the first Ghost type being
24879 -- processed for error detection purposes.
24881 if Is_Ghost_Entity (Arg_Id) then
24882 if No (Ghost_Id) then
24883 Ghost_Id := Arg_Id;
24886 -- Otherwise the type is non-Ghost. It is illegal to mix
24887 -- references to Ghost and non-Ghost entities
24890 elsif Present (Ghost_Id)
24891 and then not Ghost_Error_Posted
24893 Ghost_Error_Posted := True;
24895 Error_Msg_Name_1 := Pname;
24897 ("pragma % cannot mention ghost and non-ghost types",
24900 Error_Msg_Sloc := Sloc (Ghost_Id);
24901 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
24903 Error_Msg_Sloc := Sloc (Arg_Id);
24904 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
24908 ("argument for pragma% must be type or subtype", Arg);
24912 ("argument for pragma% must be type or subtype", Arg);
24917 end Unreferenced_Objects;
24919 ------------------------------
24920 -- Unreserve_All_Interrupts --
24921 ------------------------------
24923 -- pragma Unreserve_All_Interrupts;
24925 when Pragma_Unreserve_All_Interrupts =>
24927 Check_Arg_Count (0);
24929 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
24930 Unreserve_All_Interrupts := True;
24937 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
24939 when Pragma_Unsuppress =>
24941 Process_Suppress_Unsuppress (Suppress_Case => False);
24947 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
24949 when Pragma_Unused =>
24950 Analyze_Unmodified_Or_Unused (Is_Unused => True);
24951 Analyze_Unreferenced_Or_Unused (Is_Unused => True);
24953 -------------------
24954 -- Use_VADS_Size --
24955 -------------------
24957 -- pragma Use_VADS_Size;
24959 when Pragma_Use_VADS_Size =>
24961 Check_Arg_Count (0);
24962 Check_Valid_Configuration_Pragma;
24963 Use_VADS_Size := True;
24965 ---------------------
24966 -- Validity_Checks --
24967 ---------------------
24969 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
24971 when Pragma_Validity_Checks => Validity_Checks : declare
24972 A : constant Node_Id := Get_Pragma_Arg (Arg1);
24978 Check_Arg_Count (1);
24979 Check_No_Identifiers;
24981 -- Pragma always active unless in CodePeer or GNATprove modes,
24982 -- which use a fixed configuration of validity checks.
24984 if not (CodePeer_Mode or GNATprove_Mode) then
24985 if Nkind (A) = N_String_Literal then
24989 Slen : constant Natural := Natural (String_Length (S));
24990 Options : String (1 .. Slen);
24994 -- Couldn't we use a for loop here over Options'Range???
24998 C := Get_String_Char (S, Pos (J));
25000 -- This is a weird test, it skips setting validity
25001 -- checks entirely if any element of S is out of
25002 -- range of Character, what is that about ???
25004 exit when not In_Character_Range (C);
25005 Options (J) := Get_Character (C);
25008 Set_Validity_Check_Options (Options);
25016 elsif Nkind (A) = N_Identifier then
25017 if Chars (A) = Name_All_Checks then
25018 Set_Validity_Check_Options ("a");
25019 elsif Chars (A) = Name_On then
25020 Validity_Checks_On := True;
25021 elsif Chars (A) = Name_Off then
25022 Validity_Checks_On := False;
25026 end Validity_Checks;
25032 -- pragma Volatile (LOCAL_NAME);
25034 when Pragma_Volatile =>
25035 Process_Atomic_Independent_Shared_Volatile;
25037 -------------------------
25038 -- Volatile_Components --
25039 -------------------------
25041 -- pragma Volatile_Components (array_LOCAL_NAME);
25043 -- Volatile is handled by the same circuit as Atomic_Components
25045 --------------------------
25046 -- Volatile_Full_Access --
25047 --------------------------
25049 -- pragma Volatile_Full_Access (LOCAL_NAME);
25051 when Pragma_Volatile_Full_Access =>
25053 Process_Atomic_Independent_Shared_Volatile;
25055 -----------------------
25056 -- Volatile_Function --
25057 -----------------------
25059 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
25061 when Pragma_Volatile_Function => Volatile_Function : declare
25062 Over_Id : Entity_Id;
25063 Spec_Id : Entity_Id;
25064 Subp_Decl : Node_Id;
25068 Check_No_Identifiers;
25069 Check_At_Most_N_Arguments (1);
25072 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
25074 -- Generic subprogram
25076 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
25079 -- Body acts as spec
25081 elsif Nkind (Subp_Decl) = N_Subprogram_Body
25082 and then No (Corresponding_Spec (Subp_Decl))
25086 -- Body stub acts as spec
25088 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
25089 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
25095 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
25103 Spec_Id := Unique_Defining_Entity (Subp_Decl);
25105 if Ekind (Spec_Id) not in E_Function | E_Generic_Function then
25110 -- A pragma that applies to a Ghost entity becomes Ghost for the
25111 -- purposes of legality checks and removal of ignored Ghost code.
25113 Mark_Ghost_Pragma (N, Spec_Id);
25115 -- Chain the pragma on the contract for completeness
25117 Add_Contract_Item (N, Spec_Id);
25119 -- The legality checks of pragma Volatile_Function are affected by
25120 -- the SPARK mode in effect. Analyze all pragmas in a specific
25123 Analyze_If_Present (Pragma_SPARK_Mode);
25125 -- A volatile function cannot override a non-volatile function
25126 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
25127 -- in New_Overloaded_Entity, however at that point the pragma has
25128 -- not been processed yet.
25130 Over_Id := Overridden_Operation (Spec_Id);
25132 if Present (Over_Id)
25133 and then not Is_Volatile_Function (Over_Id)
25136 ("incompatible volatile function values in effect", Spec_Id);
25138 Error_Msg_Sloc := Sloc (Over_Id);
25140 ("\& declared # with Volatile_Function value False",
25143 Error_Msg_Sloc := Sloc (Spec_Id);
25145 ("\overridden # with Volatile_Function value True",
25149 -- Analyze the Boolean expression (if any)
25151 if Present (Arg1) then
25152 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
25154 end Volatile_Function;
25156 ----------------------
25157 -- Warning_As_Error --
25158 ----------------------
25160 -- pragma Warning_As_Error (static_string_EXPRESSION);
25162 when Pragma_Warning_As_Error =>
25164 Check_Arg_Count (1);
25165 Check_No_Identifiers;
25166 Check_Valid_Configuration_Pragma;
25168 if not Is_Static_String_Expression (Arg1) then
25170 ("argument of pragma% must be static string expression",
25173 -- OK static string expression
25176 Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1;
25177 Warnings_As_Errors (Warnings_As_Errors_Count) :=
25178 new String'(Acquire_Warning_Match_String
25179 (Expr_Value_S (Get_Pragma_Arg (Arg1))));
25186 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
25188 -- DETAILS ::= On | Off
25189 -- DETAILS ::= On | Off, local_NAME
25190 -- DETAILS ::= static_string_EXPRESSION
25191 -- DETAILS ::= On | Off, static_string_EXPRESSION
25193 -- TOOL_NAME ::= GNAT | GNATprove
25195 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
25197 -- Note: If the first argument matches an allowed tool name, it is
25198 -- always considered to be a tool name, even if there is a string
25199 -- variable of that name.
25201 -- Note if the second argument of DETAILS is a local_NAME then the
25202 -- second form is always understood. If the intention is to use
25203 -- the fourth form, then you can write NAME & "" to force the
25204 -- intepretation as a static_string_EXPRESSION.
25206 when Pragma_Warnings => Warnings : declare
25207 Reason : String_Id;
25211 Check_At_Least_N_Arguments (1);
25213 -- See if last argument is labeled Reason. If so, make sure we
25214 -- have a string literal or a concatenation of string literals,
25215 -- and acquire the REASON string. Then remove the REASON argument
25216 -- by decreasing Num_Args by one; Remaining processing looks only
25217 -- at first Num_Args arguments).
25220 Last_Arg : constant Node_Id :=
25221 Last (Pragma_Argument_Associations (N));
25224 if Nkind (Last_Arg) = N_Pragma_Argument_Association
25225 and then Chars (Last_Arg) = Name_Reason
25228 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
25229 Reason := End_String;
25230 Arg_Count := Arg_Count - 1;
25232 -- Not allowed in compiler units (bootstrap issues)
25234 Check_Compiler_Unit ("Reason for pragma Warnings", N);
25236 -- No REASON string, set null string as reason
25239 Reason := Null_String_Id;
25243 -- Now proceed with REASON taken care of and eliminated
25245 Check_No_Identifiers;
25247 -- If debug flag -gnatd.i is set, pragma is ignored
25249 if Debug_Flag_Dot_I then
25253 -- Process various forms of the pragma
25256 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
25257 Shifted_Args : List_Id;
25260 -- See if first argument is a tool name, currently either
25261 -- GNAT or GNATprove. If so, either ignore the pragma if the
25262 -- tool used does not match, or continue as if no tool name
25263 -- was given otherwise, by shifting the arguments.
25265 if Nkind (Argx) = N_Identifier
25266 and then Chars (Argx) in Name_Gnat | Name_Gnatprove
25268 if Chars (Argx) = Name_Gnat then
25269 if CodePeer_Mode or GNATprove_Mode then
25270 Rewrite (N, Make_Null_Statement (Loc));
25275 elsif Chars (Argx) = Name_Gnatprove then
25276 if not GNATprove_Mode then
25277 Rewrite (N, Make_Null_Statement (Loc));
25283 raise Program_Error;
25286 -- At this point, the pragma Warnings applies to the tool,
25287 -- so continue with shifted arguments.
25289 Arg_Count := Arg_Count - 1;
25291 if Arg_Count = 1 then
25292 Shifted_Args := New_List (New_Copy (Arg2));
25293 elsif Arg_Count = 2 then
25294 Shifted_Args := New_List (New_Copy (Arg2),
25296 elsif Arg_Count = 3 then
25297 Shifted_Args := New_List (New_Copy (Arg2),
25301 raise Program_Error;
25306 Chars => Name_Warnings,
25307 Pragma_Argument_Associations => Shifted_Args));
25312 -- One argument case
25314 if Arg_Count = 1 then
25316 -- On/Off one argument case was processed by parser
25318 if Nkind (Argx) = N_Identifier
25319 and then Chars (Argx) in Name_On | Name_Off
25323 -- One argument case must be ON/OFF or static string expr
25325 elsif not Is_Static_String_Expression (Arg1) then
25327 ("argument of pragma% must be On/Off or static string "
25328 & "expression", Arg1);
25330 -- One argument string expression case
25334 Lit : constant Node_Id := Expr_Value_S (Argx);
25335 Str : constant String_Id := Strval (Lit);
25336 Len : constant Nat := String_Length (Str);
25344 while J <= Len loop
25345 C := Get_String_Char (Str, J);
25346 OK := In_Character_Range (C);
25349 Chr := Get_Character (C);
25351 -- Dash case: only -Wxxx is accepted
25358 C := Get_String_Char (Str, J);
25359 Chr := Get_Character (C);
25360 exit when Chr = 'W';
25365 elsif J < Len and then Chr = '.' then
25367 C := Get_String_Char (Str, J);
25368 Chr := Get_Character (C);
25370 if not Set_Dot_Warning_Switch (Chr) then
25372 ("invalid warning switch character "
25373 & '.' & Chr, Arg1);
25379 OK := Set_Warning_Switch (Chr);
25384 ("invalid warning switch character " & Chr,
25390 ("invalid wide character in warning switch ",
25399 -- Two or more arguments (must be two)
25402 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
25403 Check_Arg_Count (2);
25411 E_Id := Get_Pragma_Arg (Arg2);
25414 -- In the expansion of an inlined body, a reference to
25415 -- the formal may be wrapped in a conversion if the
25416 -- actual is a conversion. Retrieve the real entity name.
25418 if (In_Instance_Body or In_Inlined_Body)
25419 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
25421 E_Id := Expression (E_Id);
25424 -- Entity name case
25426 if Is_Entity_Name (E_Id) then
25427 E := Entity (E_Id);
25434 (E, (Chars (Get_Pragma_Arg (Arg1)) =
25437 -- Suppress elaboration warnings if the entity
25438 -- denotes an elaboration target.
25440 if Is_Elaboration_Target (E) then
25441 Set_Is_Elaboration_Warnings_OK_Id (E, False);
25444 -- For OFF case, make entry in warnings off
25445 -- pragma table for later processing. But we do
25446 -- not do that within an instance, since these
25447 -- warnings are about what is needed in the
25448 -- template, not an instance of it.
25450 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
25451 and then Warn_On_Warnings_Off
25452 and then not In_Instance
25454 Warnings_Off_Pragmas.Append ((N, E, Reason));
25457 if Is_Enumeration_Type (E) then
25461 Lit := First_Literal (E);
25462 while Present (Lit) loop
25463 Set_Warnings_Off (Lit);
25464 Next_Literal (Lit);
25469 exit when No (Homonym (E));
25474 -- Error if not entity or static string expression case
25476 elsif not Is_Static_String_Expression (Arg2) then
25478 ("second argument of pragma% must be entity name "
25479 & "or static string expression", Arg2);
25481 -- Static string expression case
25484 -- Note on configuration pragma case: If this is a
25485 -- configuration pragma, then for an OFF pragma, we
25486 -- just set Config True in the call, which is all
25487 -- that needs to be done. For the case of ON, this
25488 -- is normally an error, unless it is canceling the
25489 -- effect of a previous OFF pragma in the same file.
25490 -- In any other case, an error will be signalled (ON
25491 -- with no matching OFF).
25493 -- Note: We set Used if we are inside a generic to
25494 -- disable the test that the non-config case actually
25495 -- cancels a warning. That's because we can't be sure
25496 -- there isn't an instantiation in some other unit
25497 -- where a warning is suppressed.
25499 -- We could do a little better here by checking if the
25500 -- generic unit we are inside is public, but for now
25501 -- we don't bother with that refinement.
25504 Message : constant String :=
25505 Acquire_Warning_Match_String
25506 (Expr_Value_S (Get_Pragma_Arg (Arg2)));
25508 if Chars (Argx) = Name_Off then
25509 Set_Specific_Warning_Off
25510 (Loc, Message, Reason,
25511 Config => Is_Configuration_Pragma,
25512 Used => Inside_A_Generic or else In_Instance);
25514 elsif Chars (Argx) = Name_On then
25515 Set_Specific_Warning_On (Loc, Message, Err);
25519 ("??pragma Warnings On with no matching "
25520 & "Warnings Off", Loc);
25530 -------------------
25531 -- Weak_External --
25532 -------------------
25534 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
25536 when Pragma_Weak_External => Weak_External : declare
25541 Check_Arg_Count (1);
25542 Check_Optional_Identifier (Arg1, Name_Entity);
25543 Check_Arg_Is_Library_Level_Local_Name (Arg1);
25544 Ent := Entity (Get_Pragma_Arg (Arg1));
25546 if Rep_Item_Too_Early (Ent, N) then
25549 Ent := Underlying_Type (Ent);
25552 -- The pragma applies to entities with addresses
25554 if Is_Type (Ent) then
25555 Error_Pragma ("pragma applies to objects and subprograms");
25558 -- The only processing required is to link this item on to the
25559 -- list of rep items for the given entity. This is accomplished
25560 -- by the call to Rep_Item_Too_Late (when no error is detected
25561 -- and False is returned).
25563 if Rep_Item_Too_Late (Ent, N) then
25566 Set_Has_Gigi_Rep_Item (Ent);
25570 -----------------------------
25571 -- Wide_Character_Encoding --
25572 -----------------------------
25574 -- pragma Wide_Character_Encoding (IDENTIFIER);
25576 when Pragma_Wide_Character_Encoding =>
25579 -- Nothing to do, handled in parser. Note that we do not enforce
25580 -- configuration pragma placement, this pragma can appear at any
25581 -- place in the source, allowing mixed encodings within a single
25586 --------------------
25587 -- Unknown_Pragma --
25588 --------------------
25590 -- Should be impossible, since the case of an unknown pragma is
25591 -- separately processed before the case statement is entered.
25593 when Unknown_Pragma =>
25594 raise Program_Error;
25597 -- AI05-0144: detect dangerous order dependence. Disabled for now,
25598 -- until AI is formally approved.
25600 -- Check_Order_Dependence;
25603 when Pragma_Exit => null;
25604 end Analyze_Pragma;
25606 ---------------------------------------------
25607 -- Analyze_Pre_Post_Condition_In_Decl_Part --
25608 ---------------------------------------------
25610 -- WARNING: This routine manages Ghost regions. Return statements must be
25611 -- replaced by gotos which jump to the end of the routine and restore the
25614 procedure Analyze_Pre_Post_Condition_In_Decl_Part
25616 Freeze_Id : Entity_Id := Empty)
25618 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
25619 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
25621 Disp_Typ : Entity_Id;
25622 -- The dispatching type of the subprogram subject to the pre- or
25625 function Check_References (Nod : Node_Id) return Traverse_Result;
25626 -- Check that expression Nod does not mention non-primitives of the
25627 -- type, global objects of the type, or other illegalities described
25628 -- and implied by AI12-0113.
25630 ----------------------
25631 -- Check_References --
25632 ----------------------
25634 function Check_References (Nod : Node_Id) return Traverse_Result is
25636 if Nkind (Nod) = N_Function_Call
25637 and then Is_Entity_Name (Name (Nod))
25640 Func : constant Entity_Id := Entity (Name (Nod));
25644 -- An operation of the type must be a primitive
25646 if No (Find_Dispatching_Type (Func)) then
25647 Form := First_Formal (Func);
25648 while Present (Form) loop
25649 if Etype (Form) = Disp_Typ then
25651 ("operation in class-wide condition must be "
25652 & "primitive of &", Nod, Disp_Typ);
25655 Next_Formal (Form);
25658 -- A return object of the type is illegal as well
25660 if Etype (Func) = Disp_Typ
25661 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
25664 ("operation in class-wide condition must be primitive "
25665 & "of &", Nod, Disp_Typ);
25668 -- Otherwise we have a call to an overridden primitive, and we
25669 -- will create a common class-wide clone for the body of
25670 -- original operation and its eventual inherited versions. If
25671 -- the original operation dispatches on result it is never
25672 -- inherited and there is no need for a clone. There is not
25673 -- need for a clone either in GNATprove mode, as cases that
25674 -- would require it are rejected (when an inherited primitive
25675 -- calls an overridden operation in a class-wide contract), and
25676 -- the clone would make proof impossible in some cases.
25678 elsif not Is_Abstract_Subprogram (Spec_Id)
25679 and then No (Class_Wide_Clone (Spec_Id))
25680 and then not Has_Controlling_Result (Spec_Id)
25681 and then not GNATprove_Mode
25683 Build_Class_Wide_Clone_Decl (Spec_Id);
25687 elsif Is_Entity_Name (Nod)
25689 (Etype (Nod) = Disp_Typ
25690 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
25691 and then Ekind (Entity (Nod)) in E_Constant | E_Variable
25694 ("object in class-wide condition must be formal of type &",
25697 elsif Nkind (Nod) = N_Explicit_Dereference
25698 and then (Etype (Nod) = Disp_Typ
25699 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
25700 and then (not Is_Entity_Name (Prefix (Nod))
25701 or else not Is_Formal (Entity (Prefix (Nod))))
25704 ("operation in class-wide condition must be primitive of &",
25709 end Check_References;
25711 procedure Check_Class_Wide_Condition is
25712 new Traverse_Proc (Check_References);
25716 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
25718 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
25719 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
25720 -- Save the Ghost-related attributes to restore on exit
25723 Restore_Scope : Boolean := False;
25725 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
25728 -- Do not analyze the pragma multiple times
25730 if Is_Analyzed_Pragma (N) then
25734 -- Set the Ghost mode in effect from the pragma. Due to the delayed
25735 -- analysis of the pragma, the Ghost mode at point of declaration and
25736 -- point of analysis may not necessarily be the same. Use the mode in
25737 -- effect at the point of declaration.
25739 Set_Ghost_Mode (N);
25741 -- Ensure that the subprogram and its formals are visible when analyzing
25742 -- the expression of the pragma.
25744 if not In_Open_Scopes (Spec_Id) then
25745 Restore_Scope := True;
25746 Push_Scope (Spec_Id);
25748 if Is_Generic_Subprogram (Spec_Id) then
25749 Install_Generic_Formals (Spec_Id);
25751 Install_Formals (Spec_Id);
25755 Errors := Serious_Errors_Detected;
25756 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
25758 -- Emit a clarification message when the expression contains at least
25759 -- one undefined reference, possibly due to contract freezing.
25761 if Errors /= Serious_Errors_Detected
25762 and then Present (Freeze_Id)
25763 and then Has_Undefined_Reference (Expr)
25765 Contract_Freeze_Error (Spec_Id, Freeze_Id);
25768 if Class_Present (N) then
25770 -- Verify that a class-wide condition is legal, i.e. the operation is
25771 -- a primitive of a tagged type. Note that a generic subprogram is
25772 -- not a primitive operation.
25774 Disp_Typ := Find_Dispatching_Type (Spec_Id);
25776 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
25777 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
25779 if From_Aspect_Specification (N) then
25781 ("aspect % can only be specified for a primitive operation "
25782 & "of a tagged type", Corresponding_Aspect (N));
25784 -- The pragma is a source construct
25788 ("pragma % can only be specified for a primitive operation "
25789 & "of a tagged type", N);
25792 -- Remaining semantic checks require a full tree traversal
25795 Check_Class_Wide_Condition (Expr);
25800 if Restore_Scope then
25804 -- If analysis of the condition indicates that a class-wide clone
25805 -- has been created, build and analyze its declaration.
25807 if Is_Subprogram (Spec_Id)
25808 and then Present (Class_Wide_Clone (Spec_Id))
25810 Analyze (Unit_Declaration_Node (Class_Wide_Clone (Spec_Id)));
25813 -- Currently it is not possible to inline pre/postconditions on a
25814 -- subprogram subject to pragma Inline_Always.
25816 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
25817 Set_Is_Analyzed_Pragma (N);
25819 Restore_Ghost_Region (Saved_GM, Saved_IGR);
25820 end Analyze_Pre_Post_Condition_In_Decl_Part;
25822 ------------------------------------------
25823 -- Analyze_Refined_Depends_In_Decl_Part --
25824 ------------------------------------------
25826 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
25827 procedure Check_Dependency_Clause
25828 (Spec_Id : Entity_Id;
25829 Dep_Clause : Node_Id;
25830 Dep_States : Elist_Id;
25831 Refinements : List_Id;
25832 Matched_Items : in out Elist_Id);
25833 -- Try to match a single dependency clause Dep_Clause against one or
25834 -- more refinement clauses found in list Refinements. Each successful
25835 -- match eliminates at least one refinement clause from Refinements.
25836 -- Spec_Id denotes the entity of the related subprogram. Dep_States
25837 -- denotes the entities of all abstract states which appear in pragma
25838 -- Depends. Matched_Items contains the entities of all successfully
25839 -- matched items found in pragma Depends.
25841 procedure Check_Output_States
25842 (Spec_Inputs : Elist_Id;
25843 Spec_Outputs : Elist_Id;
25844 Body_Inputs : Elist_Id;
25845 Body_Outputs : Elist_Id);
25846 -- Determine whether pragma Depends contains an output state with a
25847 -- visible refinement and if so, ensure that pragma Refined_Depends
25848 -- mentions all its constituents as outputs. Spec_Inputs and
25849 -- Spec_Outputs denote the inputs and outputs of the subprogram spec
25850 -- synthesized from pragma Depends. Body_Inputs and Body_Outputs denote
25851 -- the inputs and outputs of the subprogram body synthesized from pragma
25852 -- Refined_Depends.
25854 function Collect_States (Clauses : List_Id) return Elist_Id;
25855 -- Given a normalized list of dependencies obtained from calling
25856 -- Normalize_Clauses, return a list containing the entities of all
25857 -- states appearing in dependencies. It helps in checking refinements
25858 -- involving a state and a corresponding constituent which is not a
25859 -- direct constituent of the state.
25861 procedure Normalize_Clauses (Clauses : List_Id);
25862 -- Given a list of dependence or refinement clauses Clauses, normalize
25863 -- each clause by creating multiple dependencies with exactly one input
25866 procedure Remove_Extra_Clauses
25867 (Clauses : List_Id;
25868 Matched_Items : Elist_Id);
25869 -- Given a list of refinement clauses Clauses, remove all clauses whose
25870 -- inputs and/or outputs have been previously matched. See the body for
25871 -- all special cases. Matched_Items contains the entities of all matched
25872 -- items found in pragma Depends.
25874 procedure Report_Extra_Clauses (Clauses : List_Id);
25875 -- Emit an error for each extra clause found in list Clauses
25877 -----------------------------
25878 -- Check_Dependency_Clause --
25879 -----------------------------
25881 procedure Check_Dependency_Clause
25882 (Spec_Id : Entity_Id;
25883 Dep_Clause : Node_Id;
25884 Dep_States : Elist_Id;
25885 Refinements : List_Id;
25886 Matched_Items : in out Elist_Id)
25888 Dep_Input : constant Node_Id := Expression (Dep_Clause);
25889 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
25891 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
25892 -- Determine whether dependency item Dep_Item has been matched in a
25893 -- previous clause.
25895 function Is_In_Out_State_Clause return Boolean;
25896 -- Determine whether dependence clause Dep_Clause denotes an abstract
25897 -- state that depends on itself (State => State).
25899 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
25900 -- Determine whether item Item denotes an abstract state with visible
25901 -- null refinement.
25903 procedure Match_Items
25904 (Dep_Item : Node_Id;
25905 Ref_Item : Node_Id;
25906 Matched : out Boolean);
25907 -- Try to match dependence item Dep_Item against refinement item
25908 -- Ref_Item. To match against a possible null refinement (see 2, 9),
25909 -- set Ref_Item to Empty. Flag Matched is set to True when one of
25910 -- the following conformance scenarios is in effect:
25911 -- 1) Both items denote null
25912 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
25913 -- 3) Both items denote attribute 'Result
25914 -- 4) Both items denote the same object
25915 -- 5) Both items denote the same formal parameter
25916 -- 6) Both items denote the same current instance of a type
25917 -- 7) Both items denote the same discriminant
25918 -- 8) Dep_Item is an abstract state with visible null refinement
25919 -- and Ref_Item denotes null.
25920 -- 9) Dep_Item is an abstract state with visible null refinement
25921 -- and Ref_Item is Empty (special case).
25922 -- 10) Dep_Item is an abstract state with full or partial visible
25923 -- non-null refinement and Ref_Item denotes one of its
25925 -- 11) Dep_Item is an abstract state without a full visible
25926 -- refinement and Ref_Item denotes the same state.
25927 -- When scenario 10 is in effect, the entity of the abstract state
25928 -- denoted by Dep_Item is added to list Refined_States.
25930 procedure Record_Item (Item_Id : Entity_Id);
25931 -- Store the entity of an item denoted by Item_Id in Matched_Items
25933 ------------------------
25934 -- Is_Already_Matched --
25935 ------------------------
25937 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean is
25938 Item_Id : Entity_Id := Empty;
25941 -- When the dependency item denotes attribute 'Result, check for
25942 -- the entity of the related subprogram.
25944 if Is_Attribute_Result (Dep_Item) then
25945 Item_Id := Spec_Id;
25947 elsif Is_Entity_Name (Dep_Item) then
25948 Item_Id := Available_View (Entity_Of (Dep_Item));
25952 Present (Item_Id) and then Contains (Matched_Items, Item_Id);
25953 end Is_Already_Matched;
25955 ----------------------------
25956 -- Is_In_Out_State_Clause --
25957 ----------------------------
25959 function Is_In_Out_State_Clause return Boolean is
25960 Dep_Input_Id : Entity_Id;
25961 Dep_Output_Id : Entity_Id;
25964 -- Detect the following clause:
25967 if Is_Entity_Name (Dep_Input)
25968 and then Is_Entity_Name (Dep_Output)
25970 -- Handle abstract views generated for limited with clauses
25972 Dep_Input_Id := Available_View (Entity_Of (Dep_Input));
25973 Dep_Output_Id := Available_View (Entity_Of (Dep_Output));
25976 Ekind (Dep_Input_Id) = E_Abstract_State
25977 and then Dep_Input_Id = Dep_Output_Id;
25981 end Is_In_Out_State_Clause;
25983 ---------------------------
25984 -- Is_Null_Refined_State --
25985 ---------------------------
25987 function Is_Null_Refined_State (Item : Node_Id) return Boolean is
25988 Item_Id : Entity_Id;
25991 if Is_Entity_Name (Item) then
25993 -- Handle abstract views generated for limited with clauses
25995 Item_Id := Available_View (Entity_Of (Item));
25998 Ekind (Item_Id) = E_Abstract_State
25999 and then Has_Null_Visible_Refinement (Item_Id);
26003 end Is_Null_Refined_State;
26009 procedure Match_Items
26010 (Dep_Item : Node_Id;
26011 Ref_Item : Node_Id;
26012 Matched : out Boolean)
26014 Dep_Item_Id : Entity_Id;
26015 Ref_Item_Id : Entity_Id;
26018 -- Assume that the two items do not match
26022 -- A null matches null or Empty (special case)
26024 if Nkind (Dep_Item) = N_Null
26025 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
26029 -- Attribute 'Result matches attribute 'Result
26031 elsif Is_Attribute_Result (Dep_Item)
26032 and then Is_Attribute_Result (Ref_Item)
26034 -- Put the entity of the related function on the list of
26035 -- matched items because attribute 'Result does not carry
26036 -- an entity similar to states and constituents.
26038 Record_Item (Spec_Id);
26041 -- Abstract states, current instances of concurrent types,
26042 -- discriminants, formal parameters and objects.
26044 elsif Is_Entity_Name (Dep_Item) then
26046 -- Handle abstract views generated for limited with clauses
26048 Dep_Item_Id := Available_View (Entity_Of (Dep_Item));
26050 if Ekind (Dep_Item_Id) = E_Abstract_State then
26052 -- An abstract state with visible null refinement matches
26053 -- null or Empty (special case).
26055 if Has_Null_Visible_Refinement (Dep_Item_Id)
26056 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
26058 Record_Item (Dep_Item_Id);
26061 -- An abstract state with visible non-null refinement
26062 -- matches one of its constituents, or itself for an
26063 -- abstract state with partial visible refinement.
26065 elsif Has_Non_Null_Visible_Refinement (Dep_Item_Id) then
26066 if Is_Entity_Name (Ref_Item) then
26067 Ref_Item_Id := Entity_Of (Ref_Item);
26069 if Ekind (Ref_Item_Id) in
26070 E_Abstract_State | E_Constant | E_Variable
26071 and then Present (Encapsulating_State (Ref_Item_Id))
26072 and then Find_Encapsulating_State
26073 (Dep_States, Ref_Item_Id) = Dep_Item_Id
26075 Record_Item (Dep_Item_Id);
26078 elsif not Has_Visible_Refinement (Dep_Item_Id)
26079 and then Ref_Item_Id = Dep_Item_Id
26081 Record_Item (Dep_Item_Id);
26086 -- An abstract state without a visible refinement matches
26089 elsif Is_Entity_Name (Ref_Item)
26090 and then Entity_Of (Ref_Item) = Dep_Item_Id
26092 Record_Item (Dep_Item_Id);
26096 -- A current instance of a concurrent type, discriminant,
26097 -- formal parameter or an object matches itself.
26099 elsif Is_Entity_Name (Ref_Item)
26100 and then Entity_Of (Ref_Item) = Dep_Item_Id
26102 Record_Item (Dep_Item_Id);
26112 procedure Record_Item (Item_Id : Entity_Id) is
26114 if No (Matched_Items) then
26115 Matched_Items := New_Elmt_List;
26118 Append_Unique_Elmt (Item_Id, Matched_Items);
26123 Clause_Matched : Boolean := False;
26124 Dummy : Boolean := False;
26125 Inputs_Match : Boolean;
26126 Next_Ref_Clause : Node_Id;
26127 Outputs_Match : Boolean;
26128 Ref_Clause : Node_Id;
26129 Ref_Input : Node_Id;
26130 Ref_Output : Node_Id;
26132 -- Start of processing for Check_Dependency_Clause
26135 -- Do not perform this check in an instance because it was already
26136 -- performed successfully in the generic template.
26138 if In_Instance then
26142 -- Examine all refinement clauses and compare them against the
26143 -- dependence clause.
26145 Ref_Clause := First (Refinements);
26146 while Present (Ref_Clause) loop
26147 Next_Ref_Clause := Next (Ref_Clause);
26149 -- Obtain the attributes of the current refinement clause
26151 Ref_Input := Expression (Ref_Clause);
26152 Ref_Output := First (Choices (Ref_Clause));
26154 -- The current refinement clause matches the dependence clause
26155 -- when both outputs match and both inputs match. See routine
26156 -- Match_Items for all possible conformance scenarios.
26158 -- Depends Dep_Output => Dep_Input
26162 -- Refined_Depends Ref_Output => Ref_Input
26165 (Dep_Item => Dep_Input,
26166 Ref_Item => Ref_Input,
26167 Matched => Inputs_Match);
26170 (Dep_Item => Dep_Output,
26171 Ref_Item => Ref_Output,
26172 Matched => Outputs_Match);
26174 -- An In_Out state clause may be matched against a refinement with
26175 -- a null input or null output as long as the non-null side of the
26176 -- relation contains a valid constituent of the In_Out_State.
26178 if Is_In_Out_State_Clause then
26180 -- Depends => (State => State)
26181 -- Refined_Depends => (null => Constit) -- OK
26184 and then not Outputs_Match
26185 and then Nkind (Ref_Output) = N_Null
26187 Outputs_Match := True;
26190 -- Depends => (State => State)
26191 -- Refined_Depends => (Constit => null) -- OK
26193 if not Inputs_Match
26194 and then Outputs_Match
26195 and then Nkind (Ref_Input) = N_Null
26197 Inputs_Match := True;
26201 -- The current refinement clause is legally constructed following
26202 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
26203 -- the pool of candidates. The seach continues because a single
26204 -- dependence clause may have multiple matching refinements.
26206 if Inputs_Match and Outputs_Match then
26207 Clause_Matched := True;
26208 Remove (Ref_Clause);
26211 Ref_Clause := Next_Ref_Clause;
26214 -- Depending on the order or composition of refinement clauses, an
26215 -- In_Out state clause may not be directly refinable.
26217 -- Refined_State => (State => (Constit_1, Constit_2))
26218 -- Depends => ((Output, State) => (Input, State))
26219 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
26221 -- Matching normalized clause (State => State) fails because there is
26222 -- no direct refinement capable of satisfying this relation. Another
26223 -- similar case arises when clauses (Constit_1 => Input) and (Output
26224 -- => Constit_2) are matched first, leaving no candidates for clause
26225 -- (State => State). Both scenarios are legal as long as one of the
26226 -- previous clauses mentioned a valid constituent of State.
26228 if not Clause_Matched
26229 and then Is_In_Out_State_Clause
26230 and then Is_Already_Matched (Dep_Input)
26232 Clause_Matched := True;
26235 -- A clause where the input is an abstract state with visible null
26236 -- refinement or a 'Result attribute is implicitly matched when the
26237 -- output has already been matched in a previous clause.
26239 -- Refined_State => (State => null)
26240 -- Depends => (Output => State) -- implicitly OK
26241 -- Refined_Depends => (Output => ...)
26242 -- Depends => (...'Result => State) -- implicitly OK
26243 -- Refined_Depends => (...'Result => ...)
26245 if not Clause_Matched
26246 and then Is_Null_Refined_State (Dep_Input)
26247 and then Is_Already_Matched (Dep_Output)
26249 Clause_Matched := True;
26252 -- A clause where the output is an abstract state with visible null
26253 -- refinement is implicitly matched when the input has already been
26254 -- matched in a previous clause.
26256 -- Refined_State => (State => null)
26257 -- Depends => (State => Input) -- implicitly OK
26258 -- Refined_Depends => (... => Input)
26260 if not Clause_Matched
26261 and then Is_Null_Refined_State (Dep_Output)
26262 and then Is_Already_Matched (Dep_Input)
26264 Clause_Matched := True;
26267 -- At this point either all refinement clauses have been examined or
26268 -- pragma Refined_Depends contains a solitary null. Only an abstract
26269 -- state with null refinement can possibly match these cases.
26271 -- Refined_State => (State => null)
26272 -- Depends => (State => null)
26273 -- Refined_Depends => null -- OK
26275 if not Clause_Matched then
26277 (Dep_Item => Dep_Input,
26279 Matched => Inputs_Match);
26282 (Dep_Item => Dep_Output,
26284 Matched => Outputs_Match);
26286 Clause_Matched := Inputs_Match and Outputs_Match;
26289 -- If the contents of Refined_Depends are legal, then the current
26290 -- dependence clause should be satisfied either by an explicit match
26291 -- or by one of the special cases.
26293 if not Clause_Matched then
26295 (Fix_Msg (Spec_Id, "dependence clause of subprogram & has no "
26296 & "matching refinement in body"), Dep_Clause, Spec_Id);
26298 end Check_Dependency_Clause;
26300 -------------------------
26301 -- Check_Output_States --
26302 -------------------------
26304 procedure Check_Output_States
26305 (Spec_Inputs : Elist_Id;
26306 Spec_Outputs : Elist_Id;
26307 Body_Inputs : Elist_Id;
26308 Body_Outputs : Elist_Id)
26310 procedure Check_Constituent_Usage (State_Id : Entity_Id);
26311 -- Determine whether all constituents of state State_Id with full
26312 -- visible refinement are used as outputs in pragma Refined_Depends.
26313 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
26315 -----------------------------
26316 -- Check_Constituent_Usage --
26317 -----------------------------
26319 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
26320 Constits : constant Elist_Id :=
26321 Partial_Refinement_Constituents (State_Id);
26322 Constit_Elmt : Elmt_Id;
26323 Constit_Id : Entity_Id;
26324 Only_Partial : constant Boolean :=
26325 not Has_Visible_Refinement (State_Id);
26326 Posted : Boolean := False;
26329 if Present (Constits) then
26330 Constit_Elmt := First_Elmt (Constits);
26331 while Present (Constit_Elmt) loop
26332 Constit_Id := Node (Constit_Elmt);
26334 -- Issue an error when a constituent of State_Id is used,
26335 -- and State_Id has only partial visible refinement
26336 -- (SPARK RM 7.2.4(3d)).
26338 if Only_Partial then
26339 if (Present (Body_Inputs)
26340 and then Appears_In (Body_Inputs, Constit_Id))
26342 (Present (Body_Outputs)
26343 and then Appears_In (Body_Outputs, Constit_Id))
26345 Error_Msg_Name_1 := Chars (State_Id);
26347 ("constituent & of state % cannot be used in "
26348 & "dependence refinement", N, Constit_Id);
26349 Error_Msg_Name_1 := Chars (State_Id);
26350 SPARK_Msg_N ("\use state % instead", N);
26353 -- The constituent acts as an input (SPARK RM 7.2.5(3))
26355 elsif Present (Body_Inputs)
26356 and then Appears_In (Body_Inputs, Constit_Id)
26358 Error_Msg_Name_1 := Chars (State_Id);
26360 ("constituent & of state % must act as output in "
26361 & "dependence refinement", N, Constit_Id);
26363 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
26365 elsif No (Body_Outputs)
26366 or else not Appears_In (Body_Outputs, Constit_Id)
26371 ("output state & must be replaced by all its "
26372 & "constituents in dependence refinement",
26377 ("\constituent & is missing in output list",
26381 Next_Elmt (Constit_Elmt);
26384 end Check_Constituent_Usage;
26389 Item_Elmt : Elmt_Id;
26390 Item_Id : Entity_Id;
26392 -- Start of processing for Check_Output_States
26395 -- Do not perform this check in an instance because it was already
26396 -- performed successfully in the generic template.
26398 if In_Instance then
26401 -- Inspect the outputs of pragma Depends looking for a state with a
26402 -- visible refinement.
26404 elsif Present (Spec_Outputs) then
26405 Item_Elmt := First_Elmt (Spec_Outputs);
26406 while Present (Item_Elmt) loop
26407 Item := Node (Item_Elmt);
26409 -- Deal with the mixed nature of the input and output lists
26411 if Nkind (Item) = N_Defining_Identifier then
26414 Item_Id := Available_View (Entity_Of (Item));
26417 if Ekind (Item_Id) = E_Abstract_State then
26419 -- The state acts as an input-output, skip it
26421 if Present (Spec_Inputs)
26422 and then Appears_In (Spec_Inputs, Item_Id)
26426 -- Ensure that all of the constituents are utilized as
26427 -- outputs in pragma Refined_Depends.
26429 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
26430 Check_Constituent_Usage (Item_Id);
26434 Next_Elmt (Item_Elmt);
26437 end Check_Output_States;
26439 --------------------
26440 -- Collect_States --
26441 --------------------
26443 function Collect_States (Clauses : List_Id) return Elist_Id is
26444 procedure Collect_State
26446 States : in out Elist_Id);
26447 -- Add the entity of Item to list States when it denotes to a state
26449 -------------------
26450 -- Collect_State --
26451 -------------------
26453 procedure Collect_State
26455 States : in out Elist_Id)
26460 if Is_Entity_Name (Item) then
26461 Id := Entity_Of (Item);
26463 if Ekind (Id) = E_Abstract_State then
26464 if No (States) then
26465 States := New_Elmt_List;
26468 Append_Unique_Elmt (Id, States);
26478 States : Elist_Id := No_Elist;
26480 -- Start of processing for Collect_States
26483 Clause := First (Clauses);
26484 while Present (Clause) loop
26485 Input := Expression (Clause);
26486 Output := First (Choices (Clause));
26488 Collect_State (Input, States);
26489 Collect_State (Output, States);
26495 end Collect_States;
26497 -----------------------
26498 -- Normalize_Clauses --
26499 -----------------------
26501 procedure Normalize_Clauses (Clauses : List_Id) is
26502 procedure Normalize_Inputs (Clause : Node_Id);
26503 -- Normalize clause Clause by creating multiple clauses for each
26504 -- input item of Clause. It is assumed that Clause has exactly one
26505 -- output. The transformation is as follows:
26507 -- Output => (Input_1, Input_2) -- original
26509 -- Output => Input_1 -- normalizations
26510 -- Output => Input_2
26512 procedure Normalize_Outputs (Clause : Node_Id);
26513 -- Normalize clause Clause by creating multiple clause for each
26514 -- output item of Clause. The transformation is as follows:
26516 -- (Output_1, Output_2) => Input -- original
26518 -- Output_1 => Input -- normalization
26519 -- Output_2 => Input
26521 ----------------------
26522 -- Normalize_Inputs --
26523 ----------------------
26525 procedure Normalize_Inputs (Clause : Node_Id) is
26526 Inputs : constant Node_Id := Expression (Clause);
26527 Loc : constant Source_Ptr := Sloc (Clause);
26528 Output : constant List_Id := Choices (Clause);
26529 Last_Input : Node_Id;
26531 New_Clause : Node_Id;
26532 Next_Input : Node_Id;
26535 -- Normalization is performed only when the original clause has
26536 -- more than one input. Multiple inputs appear as an aggregate.
26538 if Nkind (Inputs) = N_Aggregate then
26539 Last_Input := Last (Expressions (Inputs));
26541 -- Create a new clause for each input
26543 Input := First (Expressions (Inputs));
26544 while Present (Input) loop
26545 Next_Input := Next (Input);
26547 -- Unhook the current input from the original input list
26548 -- because it will be relocated to a new clause.
26552 -- Special processing for the last input. At this point the
26553 -- original aggregate has been stripped down to one element.
26554 -- Replace the aggregate by the element itself.
26556 if Input = Last_Input then
26557 Rewrite (Inputs, Input);
26559 -- Generate a clause of the form:
26564 Make_Component_Association (Loc,
26565 Choices => New_Copy_List_Tree (Output),
26566 Expression => Input);
26568 -- The new clause contains replicated content that has
26569 -- already been analyzed, mark the clause as analyzed.
26571 Set_Analyzed (New_Clause);
26572 Insert_After (Clause, New_Clause);
26575 Input := Next_Input;
26578 end Normalize_Inputs;
26580 -----------------------
26581 -- Normalize_Outputs --
26582 -----------------------
26584 procedure Normalize_Outputs (Clause : Node_Id) is
26585 Inputs : constant Node_Id := Expression (Clause);
26586 Loc : constant Source_Ptr := Sloc (Clause);
26587 Outputs : constant Node_Id := First (Choices (Clause));
26588 Last_Output : Node_Id;
26589 New_Clause : Node_Id;
26590 Next_Output : Node_Id;
26594 -- Multiple outputs appear as an aggregate. Nothing to do when
26595 -- the clause has exactly one output.
26597 if Nkind (Outputs) = N_Aggregate then
26598 Last_Output := Last (Expressions (Outputs));
26600 -- Create a clause for each output. Note that each time a new
26601 -- clause is created, the original output list slowly shrinks
26602 -- until there is one item left.
26604 Output := First (Expressions (Outputs));
26605 while Present (Output) loop
26606 Next_Output := Next (Output);
26608 -- Unhook the output from the original output list as it
26609 -- will be relocated to a new clause.
26613 -- Special processing for the last output. At this point
26614 -- the original aggregate has been stripped down to one
26615 -- element. Replace the aggregate by the element itself.
26617 if Output = Last_Output then
26618 Rewrite (Outputs, Output);
26621 -- Generate a clause of the form:
26622 -- (Output => Inputs)
26625 Make_Component_Association (Loc,
26626 Choices => New_List (Output),
26627 Expression => New_Copy_Tree (Inputs));
26629 -- The new clause contains replicated content that has
26630 -- already been analyzed. There is not need to reanalyze
26633 Set_Analyzed (New_Clause);
26634 Insert_After (Clause, New_Clause);
26637 Output := Next_Output;
26640 end Normalize_Outputs;
26646 -- Start of processing for Normalize_Clauses
26649 Clause := First (Clauses);
26650 while Present (Clause) loop
26651 Normalize_Outputs (Clause);
26655 Clause := First (Clauses);
26656 while Present (Clause) loop
26657 Normalize_Inputs (Clause);
26660 end Normalize_Clauses;
26662 --------------------------
26663 -- Remove_Extra_Clauses --
26664 --------------------------
26666 procedure Remove_Extra_Clauses
26667 (Clauses : List_Id;
26668 Matched_Items : Elist_Id)
26672 Input_Id : Entity_Id;
26673 Next_Clause : Node_Id;
26675 State_Id : Entity_Id;
26678 Clause := First (Clauses);
26679 while Present (Clause) loop
26680 Next_Clause := Next (Clause);
26682 Input := Expression (Clause);
26683 Output := First (Choices (Clause));
26685 -- Recognize a clause of the form
26689 -- where Input is a constituent of a state which was already
26690 -- successfully matched. This clause must be removed because it
26691 -- simply indicates that some of the constituents of the state
26694 -- Refined_State => (State => (Constit_1, Constit_2))
26695 -- Depends => (Output => State)
26696 -- Refined_Depends => ((Output => Constit_1), -- State matched
26697 -- (null => Constit_2)) -- OK
26699 if Nkind (Output) = N_Null and then Is_Entity_Name (Input) then
26701 -- Handle abstract views generated for limited with clauses
26703 Input_Id := Available_View (Entity_Of (Input));
26705 -- The input must be a constituent of a state
26707 if Ekind (Input_Id) in
26708 E_Abstract_State | E_Constant | E_Variable
26709 and then Present (Encapsulating_State (Input_Id))
26711 State_Id := Encapsulating_State (Input_Id);
26713 -- The state must have a non-null visible refinement and be
26714 -- matched in a previous clause.
26716 if Has_Non_Null_Visible_Refinement (State_Id)
26717 and then Contains (Matched_Items, State_Id)
26723 -- Recognize a clause of the form
26727 -- where Output is an arbitrary item. This clause must be removed
26728 -- because a null input legitimately matches anything.
26730 elsif Nkind (Input) = N_Null then
26734 Clause := Next_Clause;
26736 end Remove_Extra_Clauses;
26738 --------------------------
26739 -- Report_Extra_Clauses --
26740 --------------------------
26742 procedure Report_Extra_Clauses (Clauses : List_Id) is
26746 -- Do not perform this check in an instance because it was already
26747 -- performed successfully in the generic template.
26749 if In_Instance then
26752 elsif Present (Clauses) then
26753 Clause := First (Clauses);
26754 while Present (Clause) loop
26756 ("unmatched or extra clause in dependence refinement",
26762 end Report_Extra_Clauses;
26766 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
26767 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
26768 Errors : constant Nat := Serious_Errors_Detected;
26775 Body_Inputs : Elist_Id := No_Elist;
26776 Body_Outputs : Elist_Id := No_Elist;
26777 -- The inputs and outputs of the subprogram body synthesized from pragma
26778 -- Refined_Depends.
26780 Dependencies : List_Id := No_List;
26782 -- The corresponding Depends pragma along with its clauses
26784 Matched_Items : Elist_Id := No_Elist;
26785 -- A list containing the entities of all successfully matched items
26786 -- found in pragma Depends.
26788 Refinements : List_Id := No_List;
26789 -- The clauses of pragma Refined_Depends
26791 Spec_Id : Entity_Id;
26792 -- The entity of the subprogram subject to pragma Refined_Depends
26794 Spec_Inputs : Elist_Id := No_Elist;
26795 Spec_Outputs : Elist_Id := No_Elist;
26796 -- The inputs and outputs of the subprogram spec synthesized from pragma
26799 States : Elist_Id := No_Elist;
26800 -- A list containing the entities of all states whose constituents
26801 -- appear in pragma Depends.
26803 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
26806 -- Do not analyze the pragma multiple times
26808 if Is_Analyzed_Pragma (N) then
26812 Spec_Id := Unique_Defining_Entity (Body_Decl);
26814 -- Use the anonymous object as the proper spec when Refined_Depends
26815 -- applies to the body of a single task type. The object carries the
26816 -- proper Chars as well as all non-refined versions of pragmas.
26818 if Is_Single_Concurrent_Type (Spec_Id) then
26819 Spec_Id := Anonymous_Object (Spec_Id);
26822 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
26824 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
26825 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
26827 if No (Depends) then
26829 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
26830 & "& lacks aspect or pragma Depends"), N, Spec_Id);
26834 Deps := Expression (Get_Argument (Depends, Spec_Id));
26836 -- A null dependency relation renders the refinement useless because it
26837 -- cannot possibly mention abstract states with visible refinement. Note
26838 -- that the inverse is not true as states may be refined to null
26839 -- (SPARK RM 7.2.5(2)).
26841 if Nkind (Deps) = N_Null then
26843 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
26844 & "depend on abstract state with visible refinement"), N, Spec_Id);
26848 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
26849 -- This ensures that the categorization of all refined dependency items
26850 -- is consistent with their role.
26852 Analyze_Depends_In_Decl_Part (N);
26854 -- Do not match dependencies against refinements if Refined_Depends is
26855 -- illegal to avoid emitting misleading error.
26857 if Serious_Errors_Detected = Errors then
26859 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
26860 -- the inputs and outputs of the subprogram spec and body to verify
26861 -- the use of states with visible refinement and their constituents.
26863 if No (Get_Pragma (Spec_Id, Pragma_Global))
26864 or else No (Get_Pragma (Body_Id, Pragma_Refined_Global))
26866 Collect_Subprogram_Inputs_Outputs
26867 (Subp_Id => Spec_Id,
26868 Synthesize => True,
26869 Subp_Inputs => Spec_Inputs,
26870 Subp_Outputs => Spec_Outputs,
26871 Global_Seen => Dummy);
26873 Collect_Subprogram_Inputs_Outputs
26874 (Subp_Id => Body_Id,
26875 Synthesize => True,
26876 Subp_Inputs => Body_Inputs,
26877 Subp_Outputs => Body_Outputs,
26878 Global_Seen => Dummy);
26880 -- For an output state with a visible refinement, ensure that all
26881 -- constituents appear as outputs in the dependency refinement.
26883 Check_Output_States
26884 (Spec_Inputs => Spec_Inputs,
26885 Spec_Outputs => Spec_Outputs,
26886 Body_Inputs => Body_Inputs,
26887 Body_Outputs => Body_Outputs);
26890 -- Multiple dependency clauses appear as component associations of an
26891 -- aggregate. Note that the clauses are copied because the algorithm
26892 -- modifies them and this should not be visible in Depends.
26894 pragma Assert (Nkind (Deps) = N_Aggregate);
26895 Dependencies := New_Copy_List_Tree (Component_Associations (Deps));
26896 Normalize_Clauses (Dependencies);
26898 -- Gather all states which appear in Depends
26900 States := Collect_States (Dependencies);
26902 Refs := Expression (Get_Argument (N, Spec_Id));
26904 if Nkind (Refs) = N_Null then
26905 Refinements := No_List;
26907 -- Multiple dependency clauses appear as component associations of an
26908 -- aggregate. Note that the clauses are copied because the algorithm
26909 -- modifies them and this should not be visible in Refined_Depends.
26911 else pragma Assert (Nkind (Refs) = N_Aggregate);
26912 Refinements := New_Copy_List_Tree (Component_Associations (Refs));
26913 Normalize_Clauses (Refinements);
26916 -- At this point the clauses of pragmas Depends and Refined_Depends
26917 -- have been normalized into simple dependencies between one output
26918 -- and one input. Examine all clauses of pragma Depends looking for
26919 -- matching clauses in pragma Refined_Depends.
26921 Clause := First (Dependencies);
26922 while Present (Clause) loop
26923 Check_Dependency_Clause
26924 (Spec_Id => Spec_Id,
26925 Dep_Clause => Clause,
26926 Dep_States => States,
26927 Refinements => Refinements,
26928 Matched_Items => Matched_Items);
26933 -- Pragma Refined_Depends may contain multiple clarification clauses
26934 -- which indicate that certain constituents do not influence the data
26935 -- flow in any way. Such clauses must be removed as long as the state
26936 -- has been matched, otherwise they will be incorrectly flagged as
26939 -- Refined_State => (State => (Constit_1, Constit_2))
26940 -- Depends => (Output => State)
26941 -- Refined_Depends => ((Output => Constit_1), -- State matched
26942 -- (null => Constit_2)) -- must be removed
26944 Remove_Extra_Clauses (Refinements, Matched_Items);
26946 if Serious_Errors_Detected = Errors then
26947 Report_Extra_Clauses (Refinements);
26952 Set_Is_Analyzed_Pragma (N);
26953 end Analyze_Refined_Depends_In_Decl_Part;
26955 -----------------------------------------
26956 -- Analyze_Refined_Global_In_Decl_Part --
26957 -----------------------------------------
26959 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is
26961 -- The corresponding Global pragma
26963 Has_In_State : Boolean := False;
26964 Has_In_Out_State : Boolean := False;
26965 Has_Out_State : Boolean := False;
26966 Has_Proof_In_State : Boolean := False;
26967 -- These flags are set when the corresponding Global pragma has a state
26968 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
26971 Has_Null_State : Boolean := False;
26972 -- This flag is set when the corresponding Global pragma has at least
26973 -- one state with a null refinement.
26975 In_Constits : Elist_Id := No_Elist;
26976 In_Out_Constits : Elist_Id := No_Elist;
26977 Out_Constits : Elist_Id := No_Elist;
26978 Proof_In_Constits : Elist_Id := No_Elist;
26979 -- These lists contain the entities of all Input, In_Out, Output and
26980 -- Proof_In constituents that appear in Refined_Global and participate
26981 -- in state refinement.
26983 In_Items : Elist_Id := No_Elist;
26984 In_Out_Items : Elist_Id := No_Elist;
26985 Out_Items : Elist_Id := No_Elist;
26986 Proof_In_Items : Elist_Id := No_Elist;
26987 -- These lists contain the entities of all Input, In_Out, Output and
26988 -- Proof_In items defined in the corresponding Global pragma.
26990 Repeat_Items : Elist_Id := No_Elist;
26991 -- A list of all global items without full visible refinement found
26992 -- in pragma Global. These states should be repeated in the global
26993 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
26994 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
26996 Spec_Id : Entity_Id;
26997 -- The entity of the subprogram subject to pragma Refined_Global
26999 States : Elist_Id := No_Elist;
27000 -- A list of all states with full or partial visible refinement found in
27003 procedure Check_In_Out_States;
27004 -- Determine whether the corresponding Global pragma mentions In_Out
27005 -- states with visible refinement and if so, ensure that one of the
27006 -- following completions apply to the constituents of the state:
27007 -- 1) there is at least one constituent of mode In_Out
27008 -- 2) there is at least one Input and one Output constituent
27009 -- 3) not all constituents are present and one of them is of mode
27011 -- This routine may remove elements from In_Constits, In_Out_Constits,
27012 -- Out_Constits and Proof_In_Constits.
27014 procedure Check_Input_States;
27015 -- Determine whether the corresponding Global pragma mentions Input
27016 -- states with visible refinement and if so, ensure that at least one of
27017 -- its constituents appears as an Input item in Refined_Global.
27018 -- This routine may remove elements from In_Constits, In_Out_Constits,
27019 -- Out_Constits and Proof_In_Constits.
27021 procedure Check_Output_States;
27022 -- Determine whether the corresponding Global pragma mentions Output
27023 -- states with visible refinement and if so, ensure that all of its
27024 -- constituents appear as Output items in Refined_Global.
27025 -- This routine may remove elements from In_Constits, In_Out_Constits,
27026 -- Out_Constits and Proof_In_Constits.
27028 procedure Check_Proof_In_States;
27029 -- Determine whether the corresponding Global pragma mentions Proof_In
27030 -- states with visible refinement and if so, ensure that at least one of
27031 -- its constituents appears as a Proof_In item in Refined_Global.
27032 -- This routine may remove elements from In_Constits, In_Out_Constits,
27033 -- Out_Constits and Proof_In_Constits.
27035 procedure Check_Refined_Global_List
27037 Global_Mode : Name_Id := Name_Input);
27038 -- Verify the legality of a single global list declaration. Global_Mode
27039 -- denotes the current mode in effect.
27041 procedure Collect_Global_Items
27043 Mode : Name_Id := Name_Input);
27044 -- Gather all Input, In_Out, Output and Proof_In items from node List
27045 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
27046 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
27047 -- and Has_Proof_In_State are set when there is at least one abstract
27048 -- state with full or partial visible refinement available in the
27049 -- corresponding mode. Flag Has_Null_State is set when at least state
27050 -- has a null refinement. Mode denotes the current global mode in
27053 function Present_Then_Remove
27055 Item : Entity_Id) return Boolean;
27056 -- Search List for a particular entity Item. If Item has been found,
27057 -- remove it from List. This routine is used to strip lists In_Constits,
27058 -- In_Out_Constits and Out_Constits of valid constituents.
27060 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id);
27061 -- Same as function Present_Then_Remove, but do not report the presence
27062 -- of Item in List.
27064 procedure Report_Extra_Constituents;
27065 -- Emit an error for each constituent found in lists In_Constits,
27066 -- In_Out_Constits and Out_Constits.
27068 procedure Report_Missing_Items;
27069 -- Emit an error for each global item not repeated found in list
27072 -------------------------
27073 -- Check_In_Out_States --
27074 -------------------------
27076 procedure Check_In_Out_States is
27077 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27078 -- Determine whether one of the following coverage scenarios is in
27080 -- 1) there is at least one constituent of mode In_Out or Output
27081 -- 2) there is at least one pair of constituents with modes Input
27082 -- and Output, or Proof_In and Output.
27083 -- 3) there is at least one constituent of mode Output and not all
27084 -- constituents are present.
27085 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
27087 -----------------------------
27088 -- Check_Constituent_Usage --
27089 -----------------------------
27091 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27092 Constits : constant Elist_Id :=
27093 Partial_Refinement_Constituents (State_Id);
27094 Constit_Elmt : Elmt_Id;
27095 Constit_Id : Entity_Id;
27096 Has_Missing : Boolean := False;
27097 In_Out_Seen : Boolean := False;
27098 Input_Seen : Boolean := False;
27099 Output_Seen : Boolean := False;
27100 Proof_In_Seen : Boolean := False;
27103 -- Process all the constituents of the state and note their modes
27104 -- within the global refinement.
27106 if Present (Constits) then
27107 Constit_Elmt := First_Elmt (Constits);
27108 while Present (Constit_Elmt) loop
27109 Constit_Id := Node (Constit_Elmt);
27111 if Present_Then_Remove (In_Constits, Constit_Id) then
27112 Input_Seen := True;
27114 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then
27115 In_Out_Seen := True;
27117 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
27118 Output_Seen := True;
27120 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
27122 Proof_In_Seen := True;
27125 Has_Missing := True;
27128 Next_Elmt (Constit_Elmt);
27132 -- An In_Out constituent is a valid completion
27134 if In_Out_Seen then
27137 -- A pair of one Input/Proof_In and one Output constituent is a
27138 -- valid completion.
27140 elsif (Input_Seen or Proof_In_Seen) and Output_Seen then
27143 elsif Output_Seen then
27145 -- A single Output constituent is a valid completion only when
27146 -- some of the other constituents are missing.
27148 if Has_Missing then
27151 -- Otherwise all constituents are of mode Output
27155 ("global refinement of state & must include at least one "
27156 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
27160 -- The state lacks a completion. When full refinement is visible,
27161 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
27162 -- refinement is visible, emit an error if the abstract state
27163 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
27164 -- both are utilized, Check_State_And_Constituent_Use. will issue
27167 elsif not Input_Seen
27168 and then not In_Out_Seen
27169 and then not Output_Seen
27170 and then not Proof_In_Seen
27172 if Has_Visible_Refinement (State_Id)
27173 or else Contains (Repeat_Items, State_Id)
27176 ("missing global refinement of state &", N, State_Id);
27179 -- Otherwise the state has a malformed completion where at least
27180 -- one of the constituents has a different mode.
27184 ("global refinement of state & redefines the mode of its "
27185 & "constituents", N, State_Id);
27187 end Check_Constituent_Usage;
27191 Item_Elmt : Elmt_Id;
27192 Item_Id : Entity_Id;
27194 -- Start of processing for Check_In_Out_States
27197 -- Do not perform this check in an instance because it was already
27198 -- performed successfully in the generic template.
27200 if In_Instance then
27203 -- Inspect the In_Out items of the corresponding Global pragma
27204 -- looking for a state with a visible refinement.
27206 elsif Has_In_Out_State and then Present (In_Out_Items) then
27207 Item_Elmt := First_Elmt (In_Out_Items);
27208 while Present (Item_Elmt) loop
27209 Item_Id := Node (Item_Elmt);
27211 -- Ensure that one of the three coverage variants is satisfied
27213 if Ekind (Item_Id) = E_Abstract_State
27214 and then Has_Non_Null_Visible_Refinement (Item_Id)
27216 Check_Constituent_Usage (Item_Id);
27219 Next_Elmt (Item_Elmt);
27222 end Check_In_Out_States;
27224 ------------------------
27225 -- Check_Input_States --
27226 ------------------------
27228 procedure Check_Input_States is
27229 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27230 -- Determine whether at least one constituent of state State_Id with
27231 -- full or partial visible refinement is used and has mode Input.
27232 -- Ensure that the remaining constituents do not have In_Out or
27233 -- Output modes. Emit an error if this is not the case
27234 -- (SPARK RM 7.2.4(5)).
27236 -----------------------------
27237 -- Check_Constituent_Usage --
27238 -----------------------------
27240 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27241 Constits : constant Elist_Id :=
27242 Partial_Refinement_Constituents (State_Id);
27243 Constit_Elmt : Elmt_Id;
27244 Constit_Id : Entity_Id;
27245 In_Seen : Boolean := False;
27248 if Present (Constits) then
27249 Constit_Elmt := First_Elmt (Constits);
27250 while Present (Constit_Elmt) loop
27251 Constit_Id := Node (Constit_Elmt);
27253 -- At least one of the constituents appears as an Input
27255 if Present_Then_Remove (In_Constits, Constit_Id) then
27258 -- A Proof_In constituent can refine an Input state as long
27259 -- as there is at least one Input constituent present.
27261 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
27265 -- The constituent appears in the global refinement, but has
27266 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
27268 elsif Present_Then_Remove (In_Out_Constits, Constit_Id)
27269 or else Present_Then_Remove (Out_Constits, Constit_Id)
27271 Error_Msg_Name_1 := Chars (State_Id);
27273 ("constituent & of state % must have mode `Input` in "
27274 & "global refinement", N, Constit_Id);
27277 Next_Elmt (Constit_Elmt);
27281 -- Not one of the constituents appeared as Input. Always emit an
27282 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
27283 -- When only partial refinement is visible, emit an error if the
27284 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27285 -- the case where both are utilized, an error will be issued in
27286 -- Check_State_And_Constituent_Use.
27289 and then (Has_Visible_Refinement (State_Id)
27290 or else Contains (Repeat_Items, State_Id))
27293 ("global refinement of state & must include at least one "
27294 & "constituent of mode `Input`", N, State_Id);
27296 end Check_Constituent_Usage;
27300 Item_Elmt : Elmt_Id;
27301 Item_Id : Entity_Id;
27303 -- Start of processing for Check_Input_States
27306 -- Do not perform this check in an instance because it was already
27307 -- performed successfully in the generic template.
27309 if In_Instance then
27312 -- Inspect the Input items of the corresponding Global pragma looking
27313 -- for a state with a visible refinement.
27315 elsif Has_In_State and then Present (In_Items) then
27316 Item_Elmt := First_Elmt (In_Items);
27317 while Present (Item_Elmt) loop
27318 Item_Id := Node (Item_Elmt);
27320 -- When full refinement is visible, ensure that at least one of
27321 -- the constituents is utilized and is of mode Input. When only
27322 -- partial refinement is visible, ensure that either one of
27323 -- the constituents is utilized and is of mode Input, or the
27324 -- abstract state is repeated and no constituent is utilized.
27326 if Ekind (Item_Id) = E_Abstract_State
27327 and then Has_Non_Null_Visible_Refinement (Item_Id)
27329 Check_Constituent_Usage (Item_Id);
27332 Next_Elmt (Item_Elmt);
27335 end Check_Input_States;
27337 -------------------------
27338 -- Check_Output_States --
27339 -------------------------
27341 procedure Check_Output_States is
27342 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27343 -- Determine whether all constituents of state State_Id with full
27344 -- visible refinement are used and have mode Output. Emit an error
27345 -- if this is not the case (SPARK RM 7.2.4(5)).
27347 -----------------------------
27348 -- Check_Constituent_Usage --
27349 -----------------------------
27351 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27352 Constits : constant Elist_Id :=
27353 Partial_Refinement_Constituents (State_Id);
27354 Only_Partial : constant Boolean :=
27355 not Has_Visible_Refinement (State_Id);
27356 Constit_Elmt : Elmt_Id;
27357 Constit_Id : Entity_Id;
27358 Posted : Boolean := False;
27361 if Present (Constits) then
27362 Constit_Elmt := First_Elmt (Constits);
27363 while Present (Constit_Elmt) loop
27364 Constit_Id := Node (Constit_Elmt);
27366 -- Issue an error when a constituent of State_Id is utilized
27367 -- and State_Id has only partial visible refinement
27368 -- (SPARK RM 7.2.4(3d)).
27370 if Only_Partial then
27371 if Present_Then_Remove (Out_Constits, Constit_Id)
27372 or else Present_Then_Remove (In_Constits, Constit_Id)
27374 Present_Then_Remove (In_Out_Constits, Constit_Id)
27376 Present_Then_Remove (Proof_In_Constits, Constit_Id)
27378 Error_Msg_Name_1 := Chars (State_Id);
27380 ("constituent & of state % cannot be used in global "
27381 & "refinement", N, Constit_Id);
27382 Error_Msg_Name_1 := Chars (State_Id);
27383 SPARK_Msg_N ("\use state % instead", N);
27386 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
27389 -- The constituent appears in the global refinement, but has
27390 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
27392 elsif Present_Then_Remove (In_Constits, Constit_Id)
27393 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
27394 or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
27396 Error_Msg_Name_1 := Chars (State_Id);
27398 ("constituent & of state % must have mode `Output` in "
27399 & "global refinement", N, Constit_Id);
27401 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
27407 ("`Output` state & must be replaced by all its "
27408 & "constituents in global refinement", N, State_Id);
27412 ("\constituent & is missing in output list",
27416 Next_Elmt (Constit_Elmt);
27419 end Check_Constituent_Usage;
27423 Item_Elmt : Elmt_Id;
27424 Item_Id : Entity_Id;
27426 -- Start of processing for Check_Output_States
27429 -- Do not perform this check in an instance because it was already
27430 -- performed successfully in the generic template.
27432 if In_Instance then
27435 -- Inspect the Output items of the corresponding Global pragma
27436 -- looking for a state with a visible refinement.
27438 elsif Has_Out_State and then Present (Out_Items) then
27439 Item_Elmt := First_Elmt (Out_Items);
27440 while Present (Item_Elmt) loop
27441 Item_Id := Node (Item_Elmt);
27443 -- When full refinement is visible, ensure that all of the
27444 -- constituents are utilized and they have mode Output. When
27445 -- only partial refinement is visible, ensure that no
27446 -- constituent is utilized.
27448 if Ekind (Item_Id) = E_Abstract_State
27449 and then Has_Non_Null_Visible_Refinement (Item_Id)
27451 Check_Constituent_Usage (Item_Id);
27454 Next_Elmt (Item_Elmt);
27457 end Check_Output_States;
27459 ---------------------------
27460 -- Check_Proof_In_States --
27461 ---------------------------
27463 procedure Check_Proof_In_States is
27464 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27465 -- Determine whether at least one constituent of state State_Id with
27466 -- full or partial visible refinement is used and has mode Proof_In.
27467 -- Ensure that the remaining constituents do not have Input, In_Out,
27468 -- or Output modes. Emit an error if this is not the case
27469 -- (SPARK RM 7.2.4(5)).
27471 -----------------------------
27472 -- Check_Constituent_Usage --
27473 -----------------------------
27475 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27476 Constits : constant Elist_Id :=
27477 Partial_Refinement_Constituents (State_Id);
27478 Constit_Elmt : Elmt_Id;
27479 Constit_Id : Entity_Id;
27480 Proof_In_Seen : Boolean := False;
27483 if Present (Constits) then
27484 Constit_Elmt := First_Elmt (Constits);
27485 while Present (Constit_Elmt) loop
27486 Constit_Id := Node (Constit_Elmt);
27488 -- At least one of the constituents appears as Proof_In
27490 if Present_Then_Remove (Proof_In_Constits, Constit_Id) then
27491 Proof_In_Seen := True;
27493 -- The constituent appears in the global refinement, but has
27494 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
27496 elsif Present_Then_Remove (In_Constits, Constit_Id)
27497 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
27498 or else Present_Then_Remove (Out_Constits, Constit_Id)
27500 Error_Msg_Name_1 := Chars (State_Id);
27502 ("constituent & of state % must have mode `Proof_In` "
27503 & "in global refinement", N, Constit_Id);
27506 Next_Elmt (Constit_Elmt);
27510 -- Not one of the constituents appeared as Proof_In. Always emit
27511 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
27512 -- When only partial refinement is visible, emit an error if the
27513 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27514 -- the case where both are utilized, an error will be issued by
27515 -- Check_State_And_Constituent_Use.
27517 if not Proof_In_Seen
27518 and then (Has_Visible_Refinement (State_Id)
27519 or else Contains (Repeat_Items, State_Id))
27522 ("global refinement of state & must include at least one "
27523 & "constituent of mode `Proof_In`", N, State_Id);
27525 end Check_Constituent_Usage;
27529 Item_Elmt : Elmt_Id;
27530 Item_Id : Entity_Id;
27532 -- Start of processing for Check_Proof_In_States
27535 -- Do not perform this check in an instance because it was already
27536 -- performed successfully in the generic template.
27538 if In_Instance then
27541 -- Inspect the Proof_In items of the corresponding Global pragma
27542 -- looking for a state with a visible refinement.
27544 elsif Has_Proof_In_State and then Present (Proof_In_Items) then
27545 Item_Elmt := First_Elmt (Proof_In_Items);
27546 while Present (Item_Elmt) loop
27547 Item_Id := Node (Item_Elmt);
27549 -- Ensure that at least one of the constituents is utilized
27550 -- and is of mode Proof_In. When only partial refinement is
27551 -- visible, ensure that either one of the constituents is
27552 -- utilized and is of mode Proof_In, or the abstract state
27553 -- is repeated and no constituent is utilized.
27555 if Ekind (Item_Id) = E_Abstract_State
27556 and then Has_Non_Null_Visible_Refinement (Item_Id)
27558 Check_Constituent_Usage (Item_Id);
27561 Next_Elmt (Item_Elmt);
27564 end Check_Proof_In_States;
27566 -------------------------------
27567 -- Check_Refined_Global_List --
27568 -------------------------------
27570 procedure Check_Refined_Global_List
27572 Global_Mode : Name_Id := Name_Input)
27574 procedure Check_Refined_Global_Item
27576 Global_Mode : Name_Id);
27577 -- Verify the legality of a single global item declaration. Parameter
27578 -- Global_Mode denotes the current mode in effect.
27580 -------------------------------
27581 -- Check_Refined_Global_Item --
27582 -------------------------------
27584 procedure Check_Refined_Global_Item
27586 Global_Mode : Name_Id)
27588 Item_Id : constant Entity_Id := Entity_Of (Item);
27590 procedure Inconsistent_Mode_Error (Expect : Name_Id);
27591 -- Issue a common error message for all mode mismatches. Expect
27592 -- denotes the expected mode.
27594 -----------------------------
27595 -- Inconsistent_Mode_Error --
27596 -----------------------------
27598 procedure Inconsistent_Mode_Error (Expect : Name_Id) is
27601 ("global item & has inconsistent modes", Item, Item_Id);
27603 Error_Msg_Name_1 := Global_Mode;
27604 Error_Msg_Name_2 := Expect;
27605 SPARK_Msg_N ("\expected mode %, found mode %", Item);
27606 end Inconsistent_Mode_Error;
27610 Enc_State : Entity_Id := Empty;
27611 -- Encapsulating state for constituent, Empty otherwise
27613 -- Start of processing for Check_Refined_Global_Item
27616 if Ekind (Item_Id) in E_Abstract_State | E_Constant | E_Variable
27618 Enc_State := Find_Encapsulating_State (States, Item_Id);
27621 -- When the state or object acts as a constituent of another
27622 -- state with a visible refinement, collect it for the state
27623 -- completeness checks performed later on. Note that the item
27624 -- acts as a constituent only when the encapsulating state is
27625 -- present in pragma Global.
27627 if Present (Enc_State)
27628 and then (Has_Visible_Refinement (Enc_State)
27629 or else Has_Partial_Visible_Refinement (Enc_State))
27630 and then Contains (States, Enc_State)
27632 -- If the state has only partial visible refinement, remove it
27633 -- from the list of items that should be repeated from pragma
27636 if not Has_Visible_Refinement (Enc_State) then
27637 Present_Then_Remove (Repeat_Items, Enc_State);
27640 if Global_Mode = Name_Input then
27641 Append_New_Elmt (Item_Id, In_Constits);
27643 elsif Global_Mode = Name_In_Out then
27644 Append_New_Elmt (Item_Id, In_Out_Constits);
27646 elsif Global_Mode = Name_Output then
27647 Append_New_Elmt (Item_Id, Out_Constits);
27649 elsif Global_Mode = Name_Proof_In then
27650 Append_New_Elmt (Item_Id, Proof_In_Constits);
27653 -- When not a constituent, ensure that both occurrences of the
27654 -- item in pragmas Global and Refined_Global match. Also remove
27655 -- it when present from the list of items that should be repeated
27656 -- from pragma Global.
27659 Present_Then_Remove (Repeat_Items, Item_Id);
27661 if Contains (In_Items, Item_Id) then
27662 if Global_Mode /= Name_Input then
27663 Inconsistent_Mode_Error (Name_Input);
27666 elsif Contains (In_Out_Items, Item_Id) then
27667 if Global_Mode /= Name_In_Out then
27668 Inconsistent_Mode_Error (Name_In_Out);
27671 elsif Contains (Out_Items, Item_Id) then
27672 if Global_Mode /= Name_Output then
27673 Inconsistent_Mode_Error (Name_Output);
27676 elsif Contains (Proof_In_Items, Item_Id) then
27679 -- The item does not appear in the corresponding Global pragma,
27680 -- it must be an extra (SPARK RM 7.2.4(3)).
27683 pragma Assert (Present (Global));
27684 Error_Msg_Sloc := Sloc (Global);
27686 ("extra global item & does not refine or repeat any "
27687 & "global item #", Item, Item_Id);
27690 end Check_Refined_Global_Item;
27696 -- Start of processing for Check_Refined_Global_List
27699 -- Do not perform this check in an instance because it was already
27700 -- performed successfully in the generic template.
27702 if In_Instance then
27705 elsif Nkind (List) = N_Null then
27708 -- Single global item declaration
27710 elsif Nkind (List) in N_Expanded_Name
27712 | N_Selected_Component
27714 Check_Refined_Global_Item (List, Global_Mode);
27716 -- Simple global list or moded global list declaration
27718 elsif Nkind (List) = N_Aggregate then
27720 -- The declaration of a simple global list appear as a collection
27723 if Present (Expressions (List)) then
27724 Item := First (Expressions (List));
27725 while Present (Item) loop
27726 Check_Refined_Global_Item (Item, Global_Mode);
27730 -- The declaration of a moded global list appears as a collection
27731 -- of component associations where individual choices denote
27734 elsif Present (Component_Associations (List)) then
27735 Item := First (Component_Associations (List));
27736 while Present (Item) loop
27737 Check_Refined_Global_List
27738 (List => Expression (Item),
27739 Global_Mode => Chars (First (Choices (Item))));
27747 raise Program_Error;
27753 raise Program_Error;
27755 end Check_Refined_Global_List;
27757 --------------------------
27758 -- Collect_Global_Items --
27759 --------------------------
27761 procedure Collect_Global_Items
27763 Mode : Name_Id := Name_Input)
27765 procedure Collect_Global_Item
27767 Item_Mode : Name_Id);
27768 -- Add a single item to the appropriate list. Item_Mode denotes the
27769 -- current mode in effect.
27771 -------------------------
27772 -- Collect_Global_Item --
27773 -------------------------
27775 procedure Collect_Global_Item
27777 Item_Mode : Name_Id)
27779 Item_Id : constant Entity_Id := Available_View (Entity_Of (Item));
27780 -- The above handles abstract views of variables and states built
27781 -- for limited with clauses.
27784 -- Signal that the global list contains at least one abstract
27785 -- state with a visible refinement. Note that the refinement may
27786 -- be null in which case there are no constituents.
27788 if Ekind (Item_Id) = E_Abstract_State then
27789 if Has_Null_Visible_Refinement (Item_Id) then
27790 Has_Null_State := True;
27792 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
27793 Append_New_Elmt (Item_Id, States);
27795 if Item_Mode = Name_Input then
27796 Has_In_State := True;
27797 elsif Item_Mode = Name_In_Out then
27798 Has_In_Out_State := True;
27799 elsif Item_Mode = Name_Output then
27800 Has_Out_State := True;
27801 elsif Item_Mode = Name_Proof_In then
27802 Has_Proof_In_State := True;
27807 -- Record global items without full visible refinement found in
27808 -- pragma Global which should be repeated in the global refinement
27809 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
27811 if Ekind (Item_Id) /= E_Abstract_State
27812 or else not Has_Visible_Refinement (Item_Id)
27814 Append_New_Elmt (Item_Id, Repeat_Items);
27817 -- Add the item to the proper list
27819 if Item_Mode = Name_Input then
27820 Append_New_Elmt (Item_Id, In_Items);
27821 elsif Item_Mode = Name_In_Out then
27822 Append_New_Elmt (Item_Id, In_Out_Items);
27823 elsif Item_Mode = Name_Output then
27824 Append_New_Elmt (Item_Id, Out_Items);
27825 elsif Item_Mode = Name_Proof_In then
27826 Append_New_Elmt (Item_Id, Proof_In_Items);
27828 end Collect_Global_Item;
27834 -- Start of processing for Collect_Global_Items
27837 if Nkind (List) = N_Null then
27840 -- Single global item declaration
27842 elsif Nkind (List) in N_Expanded_Name
27844 | N_Selected_Component
27846 Collect_Global_Item (List, Mode);
27848 -- Single global list or moded global list declaration
27850 elsif Nkind (List) = N_Aggregate then
27852 -- The declaration of a simple global list appear as a collection
27855 if Present (Expressions (List)) then
27856 Item := First (Expressions (List));
27857 while Present (Item) loop
27858 Collect_Global_Item (Item, Mode);
27862 -- The declaration of a moded global list appears as a collection
27863 -- of component associations where individual choices denote mode.
27865 elsif Present (Component_Associations (List)) then
27866 Item := First (Component_Associations (List));
27867 while Present (Item) loop
27868 Collect_Global_Items
27869 (List => Expression (Item),
27870 Mode => Chars (First (Choices (Item))));
27878 raise Program_Error;
27881 -- To accommodate partial decoration of disabled SPARK features, this
27882 -- routine may be called with illegal input. If this is the case, do
27883 -- not raise Program_Error.
27888 end Collect_Global_Items;
27890 -------------------------
27891 -- Present_Then_Remove --
27892 -------------------------
27894 function Present_Then_Remove
27896 Item : Entity_Id) return Boolean
27901 if Present (List) then
27902 Elmt := First_Elmt (List);
27903 while Present (Elmt) loop
27904 if Node (Elmt) = Item then
27905 Remove_Elmt (List, Elmt);
27914 end Present_Then_Remove;
27916 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id) is
27919 Ignore := Present_Then_Remove (List, Item);
27920 end Present_Then_Remove;
27922 -------------------------------
27923 -- Report_Extra_Constituents --
27924 -------------------------------
27926 procedure Report_Extra_Constituents is
27927 procedure Report_Extra_Constituents_In_List (List : Elist_Id);
27928 -- Emit an error for every element of List
27930 ---------------------------------------
27931 -- Report_Extra_Constituents_In_List --
27932 ---------------------------------------
27934 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is
27935 Constit_Elmt : Elmt_Id;
27938 if Present (List) then
27939 Constit_Elmt := First_Elmt (List);
27940 while Present (Constit_Elmt) loop
27941 SPARK_Msg_NE ("extra constituent &", N, Node (Constit_Elmt));
27942 Next_Elmt (Constit_Elmt);
27945 end Report_Extra_Constituents_In_List;
27947 -- Start of processing for Report_Extra_Constituents
27950 -- Do not perform this check in an instance because it was already
27951 -- performed successfully in the generic template.
27953 if In_Instance then
27957 Report_Extra_Constituents_In_List (In_Constits);
27958 Report_Extra_Constituents_In_List (In_Out_Constits);
27959 Report_Extra_Constituents_In_List (Out_Constits);
27960 Report_Extra_Constituents_In_List (Proof_In_Constits);
27962 end Report_Extra_Constituents;
27964 --------------------------
27965 -- Report_Missing_Items --
27966 --------------------------
27968 procedure Report_Missing_Items is
27969 Item_Elmt : Elmt_Id;
27970 Item_Id : Entity_Id;
27973 -- Do not perform this check in an instance because it was already
27974 -- performed successfully in the generic template.
27976 if In_Instance then
27980 if Present (Repeat_Items) then
27981 Item_Elmt := First_Elmt (Repeat_Items);
27982 while Present (Item_Elmt) loop
27983 Item_Id := Node (Item_Elmt);
27984 SPARK_Msg_NE ("missing global item &", N, Item_Id);
27985 Next_Elmt (Item_Elmt);
27989 end Report_Missing_Items;
27993 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
27994 Errors : constant Nat := Serious_Errors_Detected;
27996 No_Constit : Boolean;
27998 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
28001 -- Do not analyze the pragma multiple times
28003 if Is_Analyzed_Pragma (N) then
28007 Spec_Id := Unique_Defining_Entity (Body_Decl);
28009 -- Use the anonymous object as the proper spec when Refined_Global
28010 -- applies to the body of a single task type. The object carries the
28011 -- proper Chars as well as all non-refined versions of pragmas.
28013 if Is_Single_Concurrent_Type (Spec_Id) then
28014 Spec_Id := Anonymous_Object (Spec_Id);
28017 Global := Get_Pragma (Spec_Id, Pragma_Global);
28018 Items := Expression (Get_Argument (N, Spec_Id));
28020 -- The subprogram declaration lacks pragma Global. This renders
28021 -- Refined_Global useless as there is nothing to refine.
28023 if No (Global) then
28025 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
28026 & "& lacks aspect or pragma Global"), N, Spec_Id);
28030 -- Extract all relevant items from the corresponding Global pragma
28032 Collect_Global_Items (Expression (Get_Argument (Global, Spec_Id)));
28034 -- Package and subprogram bodies are instantiated individually in
28035 -- a separate compiler pass. Due to this mode of instantiation, the
28036 -- refinement of a state may no longer be visible when a subprogram
28037 -- body contract is instantiated. Since the generic template is legal,
28038 -- do not perform this check in the instance to circumvent this oddity.
28040 if In_Instance then
28043 -- Non-instance case
28046 -- The corresponding Global pragma must mention at least one
28047 -- state with a visible refinement at the point Refined_Global
28048 -- is processed. States with null refinements need Refined_Global
28049 -- pragma (SPARK RM 7.2.4(2)).
28051 if not Has_In_State
28052 and then not Has_In_Out_State
28053 and then not Has_Out_State
28054 and then not Has_Proof_In_State
28055 and then not Has_Null_State
28058 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
28059 & "depend on abstract state with visible refinement"),
28063 -- The global refinement of inputs and outputs cannot be null when
28064 -- the corresponding Global pragma contains at least one item except
28065 -- in the case where we have states with null refinements.
28067 elsif Nkind (Items) = N_Null
28069 (Present (In_Items)
28070 or else Present (In_Out_Items)
28071 or else Present (Out_Items)
28072 or else Present (Proof_In_Items))
28073 and then not Has_Null_State
28076 (Fix_Msg (Spec_Id, "refinement cannot be null, subprogram & has "
28077 & "global items"), N, Spec_Id);
28082 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
28083 -- This ensures that the categorization of all refined global items is
28084 -- consistent with their role.
28086 Analyze_Global_In_Decl_Part (N);
28088 -- Perform all refinement checks with respect to completeness and mode
28091 if Serious_Errors_Detected = Errors then
28092 Check_Refined_Global_List (Items);
28095 -- Store the information that no constituent is used in the global
28096 -- refinement, prior to calling checking procedures which remove items
28097 -- from the list of constituents.
28101 and then No (In_Out_Constits)
28102 and then No (Out_Constits)
28103 and then No (Proof_In_Constits);
28105 -- For Input states with visible refinement, at least one constituent
28106 -- must be used as an Input in the global refinement.
28108 if Serious_Errors_Detected = Errors then
28109 Check_Input_States;
28112 -- Verify all possible completion variants for In_Out states with
28113 -- visible refinement.
28115 if Serious_Errors_Detected = Errors then
28116 Check_In_Out_States;
28119 -- For Output states with visible refinement, all constituents must be
28120 -- used as Outputs in the global refinement.
28122 if Serious_Errors_Detected = Errors then
28123 Check_Output_States;
28126 -- For Proof_In states with visible refinement, at least one constituent
28127 -- must be used as Proof_In in the global refinement.
28129 if Serious_Errors_Detected = Errors then
28130 Check_Proof_In_States;
28133 -- Emit errors for all constituents that belong to other states with
28134 -- visible refinement that do not appear in Global.
28136 if Serious_Errors_Detected = Errors then
28137 Report_Extra_Constituents;
28140 -- Emit errors for all items in Global that are not repeated in the
28141 -- global refinement and for which there is no full visible refinement
28142 -- and, in the case of states with partial visible refinement, no
28143 -- constituent is mentioned in the global refinement.
28145 if Serious_Errors_Detected = Errors then
28146 Report_Missing_Items;
28149 -- Emit an error if no constituent is used in the global refinement
28150 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
28151 -- one may be issued by the checking procedures. Do not perform this
28152 -- check in an instance because it was already performed successfully
28153 -- in the generic template.
28155 if Serious_Errors_Detected = Errors
28156 and then not In_Instance
28157 and then not Has_Null_State
28158 and then No_Constit
28160 SPARK_Msg_N ("missing refinement", N);
28164 Set_Is_Analyzed_Pragma (N);
28165 end Analyze_Refined_Global_In_Decl_Part;
28167 ----------------------------------------
28168 -- Analyze_Refined_State_In_Decl_Part --
28169 ----------------------------------------
28171 procedure Analyze_Refined_State_In_Decl_Part
28173 Freeze_Id : Entity_Id := Empty)
28175 Body_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
28176 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
28177 Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl);
28179 Available_States : Elist_Id := No_Elist;
28180 -- A list of all abstract states defined in the package declaration that
28181 -- are available for refinement. The list is used to report unrefined
28184 Body_States : Elist_Id := No_Elist;
28185 -- A list of all hidden states that appear in the body of the related
28186 -- package. The list is used to report unused hidden states.
28188 Constituents_Seen : Elist_Id := No_Elist;
28189 -- A list that contains all constituents processed so far. The list is
28190 -- used to detect multiple uses of the same constituent.
28192 Freeze_Posted : Boolean := False;
28193 -- A flag that controls the output of a freezing-related error (see use
28196 Refined_States_Seen : Elist_Id := No_Elist;
28197 -- A list that contains all refined states processed so far. The list is
28198 -- used to detect duplicate refinements.
28200 procedure Analyze_Refinement_Clause (Clause : Node_Id);
28201 -- Perform full analysis of a single refinement clause
28203 procedure Report_Unrefined_States (States : Elist_Id);
28204 -- Emit errors for all unrefined abstract states found in list States
28206 -------------------------------
28207 -- Analyze_Refinement_Clause --
28208 -------------------------------
28210 procedure Analyze_Refinement_Clause (Clause : Node_Id) is
28211 AR_Constit : Entity_Id := Empty;
28212 AW_Constit : Entity_Id := Empty;
28213 ER_Constit : Entity_Id := Empty;
28214 EW_Constit : Entity_Id := Empty;
28215 -- The entities of external constituents that contain one of the
28216 -- following enabled properties: Async_Readers, Async_Writers,
28217 -- Effective_Reads and Effective_Writes.
28219 External_Constit_Seen : Boolean := False;
28220 -- Flag used to mark when at least one external constituent is part
28221 -- of the state refinement.
28223 Non_Null_Seen : Boolean := False;
28224 Null_Seen : Boolean := False;
28225 -- Flags used to detect multiple uses of null in a single clause or a
28226 -- mixture of null and non-null constituents.
28228 Part_Of_Constits : Elist_Id := No_Elist;
28229 -- A list of all candidate constituents subject to indicator Part_Of
28230 -- where the encapsulating state is the current state.
28233 State_Id : Entity_Id;
28234 -- The current state being refined
28236 procedure Analyze_Constituent (Constit : Node_Id);
28237 -- Perform full analysis of a single constituent
28239 procedure Check_External_Property
28240 (Prop_Nam : Name_Id;
28242 Constit : Entity_Id);
28243 -- Determine whether a property denoted by name Prop_Nam is present
28244 -- in the refined state. Emit an error if this is not the case. Flag
28245 -- Enabled should be set when the property applies to the refined
28246 -- state. Constit denotes the constituent (if any) which introduces
28247 -- the property in the refinement.
28249 procedure Match_State;
28250 -- Determine whether the state being refined appears in list
28251 -- Available_States. Emit an error when attempting to re-refine the
28252 -- state or when the state is not defined in the package declaration,
28253 -- otherwise remove the state from Available_States.
28255 procedure Report_Unused_Constituents (Constits : Elist_Id);
28256 -- Emit errors for all unused Part_Of constituents in list Constits
28258 -------------------------
28259 -- Analyze_Constituent --
28260 -------------------------
28262 procedure Analyze_Constituent (Constit : Node_Id) is
28263 procedure Match_Constituent (Constit_Id : Entity_Id);
28264 -- Determine whether constituent Constit denoted by its entity
28265 -- Constit_Id appears in Body_States. Emit an error when the
28266 -- constituent is not a valid hidden state of the related package
28267 -- or when it is used more than once. Otherwise remove the
28268 -- constituent from Body_States.
28270 -----------------------
28271 -- Match_Constituent --
28272 -----------------------
28274 procedure Match_Constituent (Constit_Id : Entity_Id) is
28275 procedure Collect_Constituent;
28276 -- Verify the legality of constituent Constit_Id and add it to
28277 -- the refinements of State_Id.
28279 -------------------------
28280 -- Collect_Constituent --
28281 -------------------------
28283 procedure Collect_Constituent is
28284 Constits : Elist_Id;
28287 -- The Ghost policy in effect at the point of abstract state
28288 -- declaration and constituent must match (SPARK RM 6.9(15))
28290 Check_Ghost_Refinement
28291 (State, State_Id, Constit, Constit_Id);
28293 -- A synchronized state must be refined by a synchronized
28294 -- object or another synchronized state (SPARK RM 9.6).
28296 if Is_Synchronized_State (State_Id)
28297 and then not Is_Synchronized_Object (Constit_Id)
28298 and then not Is_Synchronized_State (Constit_Id)
28301 ("constituent of synchronized state & must be "
28302 & "synchronized", Constit, State_Id);
28305 -- Add the constituent to the list of processed items to aid
28306 -- with the detection of duplicates.
28308 Append_New_Elmt (Constit_Id, Constituents_Seen);
28310 -- Collect the constituent in the list of refinement items
28311 -- and establish a relation between the refined state and
28314 Constits := Refinement_Constituents (State_Id);
28316 if No (Constits) then
28317 Constits := New_Elmt_List;
28318 Set_Refinement_Constituents (State_Id, Constits);
28321 Append_Elmt (Constit_Id, Constits);
28322 Set_Encapsulating_State (Constit_Id, State_Id);
28324 -- The state has at least one legal constituent, mark the
28325 -- start of the refinement region. The region ends when the
28326 -- body declarations end (see routine Analyze_Declarations).
28328 Set_Has_Visible_Refinement (State_Id);
28330 -- When the constituent is external, save its relevant
28331 -- property for further checks.
28333 if Async_Readers_Enabled (Constit_Id) then
28334 AR_Constit := Constit_Id;
28335 External_Constit_Seen := True;
28338 if Async_Writers_Enabled (Constit_Id) then
28339 AW_Constit := Constit_Id;
28340 External_Constit_Seen := True;
28343 if Effective_Reads_Enabled (Constit_Id) then
28344 ER_Constit := Constit_Id;
28345 External_Constit_Seen := True;
28348 if Effective_Writes_Enabled (Constit_Id) then
28349 EW_Constit := Constit_Id;
28350 External_Constit_Seen := True;
28352 end Collect_Constituent;
28356 State_Elmt : Elmt_Id;
28358 -- Start of processing for Match_Constituent
28361 -- Detect a duplicate use of a constituent
28363 if Contains (Constituents_Seen, Constit_Id) then
28365 ("duplicate use of constituent &", Constit, Constit_Id);
28369 -- The constituent is subject to a Part_Of indicator
28371 if Present (Encapsulating_State (Constit_Id)) then
28372 if Encapsulating_State (Constit_Id) = State_Id then
28373 Remove (Part_Of_Constits, Constit_Id);
28374 Collect_Constituent;
28376 -- The constituent is part of another state and is used
28377 -- incorrectly in the refinement of the current state.
28380 Error_Msg_Name_1 := Chars (State_Id);
28382 ("& cannot act as constituent of state %",
28383 Constit, Constit_Id);
28385 ("\Part_Of indicator specifies encapsulator &",
28386 Constit, Encapsulating_State (Constit_Id));
28389 -- The only other source of legal constituents is the body
28390 -- state space of the related package.
28393 if Present (Body_States) then
28394 State_Elmt := First_Elmt (Body_States);
28395 while Present (State_Elmt) loop
28397 -- Consume a valid constituent to signal that it has
28398 -- been encountered.
28400 if Node (State_Elmt) = Constit_Id then
28401 Remove_Elmt (Body_States, State_Elmt);
28402 Collect_Constituent;
28406 Next_Elmt (State_Elmt);
28410 -- At this point it is known that the constituent is not
28411 -- part of the package hidden state and cannot be used in
28412 -- a refinement (SPARK RM 7.2.2(9)).
28414 Error_Msg_Name_1 := Chars (Spec_Id);
28416 ("cannot use & in refinement, constituent is not a hidden "
28417 & "state of package %", Constit, Constit_Id);
28419 end Match_Constituent;
28423 Constit_Id : Entity_Id;
28424 Constits : Elist_Id;
28426 -- Start of processing for Analyze_Constituent
28429 -- Detect multiple uses of null in a single refinement clause or a
28430 -- mixture of null and non-null constituents.
28432 if Nkind (Constit) = N_Null then
28435 ("multiple null constituents not allowed", Constit);
28437 elsif Non_Null_Seen then
28439 ("cannot mix null and non-null constituents", Constit);
28444 -- Collect the constituent in the list of refinement items
28446 Constits := Refinement_Constituents (State_Id);
28448 if No (Constits) then
28449 Constits := New_Elmt_List;
28450 Set_Refinement_Constituents (State_Id, Constits);
28453 Append_Elmt (Constit, Constits);
28455 -- The state has at least one legal constituent, mark the
28456 -- start of the refinement region. The region ends when the
28457 -- body declarations end (see Analyze_Declarations).
28459 Set_Has_Visible_Refinement (State_Id);
28462 -- Non-null constituents
28465 Non_Null_Seen := True;
28469 ("cannot mix null and non-null constituents", Constit);
28473 Resolve_State (Constit);
28475 -- Ensure that the constituent denotes a valid state or a
28476 -- whole object (SPARK RM 7.2.2(5)).
28478 if Is_Entity_Name (Constit) then
28479 Constit_Id := Entity_Of (Constit);
28481 -- When a constituent is declared after a subprogram body
28482 -- that caused freezing of the related contract where
28483 -- pragma Refined_State resides, the constituent appears
28484 -- undefined and carries Any_Id as its entity.
28486 -- package body Pack
28487 -- with Refined_State => (State => Constit)
28490 -- with Refined_Global => (Input => Constit)
28498 if Constit_Id = Any_Id then
28499 SPARK_Msg_NE ("& is undefined", Constit, Constit_Id);
28501 -- Emit a specialized info message when the contract of
28502 -- the related package body was "frozen" by another body.
28503 -- Note that it is not possible to precisely identify why
28504 -- the constituent is undefined because it is not visible
28505 -- when pragma Refined_State is analyzed. This message is
28506 -- a reasonable approximation.
28508 if Present (Freeze_Id) and then not Freeze_Posted then
28509 Freeze_Posted := True;
28511 Error_Msg_Name_1 := Chars (Body_Id);
28512 Error_Msg_Sloc := Sloc (Freeze_Id);
28514 ("body & declared # freezes the contract of %",
28517 ("\all constituents must be declared before body #",
28520 -- A misplaced constituent is a critical error because
28521 -- pragma Refined_Depends or Refined_Global depends on
28522 -- the proper link between a state and a constituent.
28523 -- Stop the compilation, as this leads to a multitude
28524 -- of misleading cascaded errors.
28526 raise Unrecoverable_Error;
28529 -- The constituent is a valid state or object
28531 elsif Ekind (Constit_Id) in
28532 E_Abstract_State | E_Constant | E_Variable
28534 Match_Constituent (Constit_Id);
28536 -- The variable may eventually become a constituent of a
28537 -- single protected/task type. Record the reference now
28538 -- and verify its legality when analyzing the contract of
28539 -- the variable (SPARK RM 9.3).
28541 if Ekind (Constit_Id) = E_Variable then
28542 Record_Possible_Part_Of_Reference
28543 (Var_Id => Constit_Id,
28547 -- Otherwise the constituent is illegal
28551 ("constituent & must denote object or state",
28552 Constit, Constit_Id);
28555 -- The constituent is illegal
28558 SPARK_Msg_N ("malformed constituent", Constit);
28561 end Analyze_Constituent;
28563 -----------------------------
28564 -- Check_External_Property --
28565 -----------------------------
28567 procedure Check_External_Property
28568 (Prop_Nam : Name_Id;
28570 Constit : Entity_Id)
28573 -- The property is missing in the declaration of the state, but
28574 -- a constituent is introducing it in the state refinement
28575 -- (SPARK RM 7.2.8(2)).
28577 if not Enabled and then Present (Constit) then
28578 Error_Msg_Name_1 := Prop_Nam;
28579 Error_Msg_Name_2 := Chars (State_Id);
28581 ("constituent & introduces external property % in refinement "
28582 & "of state %", State, Constit);
28584 Error_Msg_Sloc := Sloc (State_Id);
28586 ("\property is missing in abstract state declaration #",
28589 end Check_External_Property;
28595 procedure Match_State is
28596 State_Elmt : Elmt_Id;
28599 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
28601 if Contains (Refined_States_Seen, State_Id) then
28603 ("duplicate refinement of state &", State, State_Id);
28607 -- Inspect the abstract states defined in the package declaration
28608 -- looking for a match.
28610 State_Elmt := First_Elmt (Available_States);
28611 while Present (State_Elmt) loop
28613 -- A valid abstract state is being refined in the body. Add
28614 -- the state to the list of processed refined states to aid
28615 -- with the detection of duplicate refinements. Remove the
28616 -- state from Available_States to signal that it has already
28619 if Node (State_Elmt) = State_Id then
28620 Append_New_Elmt (State_Id, Refined_States_Seen);
28621 Remove_Elmt (Available_States, State_Elmt);
28625 Next_Elmt (State_Elmt);
28628 -- If we get here, we are refining a state that is not defined in
28629 -- the package declaration.
28631 Error_Msg_Name_1 := Chars (Spec_Id);
28633 ("cannot refine state, & is not defined in package %",
28637 --------------------------------
28638 -- Report_Unused_Constituents --
28639 --------------------------------
28641 procedure Report_Unused_Constituents (Constits : Elist_Id) is
28642 Constit_Elmt : Elmt_Id;
28643 Constit_Id : Entity_Id;
28644 Posted : Boolean := False;
28647 if Present (Constits) then
28648 Constit_Elmt := First_Elmt (Constits);
28649 while Present (Constit_Elmt) loop
28650 Constit_Id := Node (Constit_Elmt);
28652 -- Generate an error message of the form:
28654 -- state ... has unused Part_Of constituents
28655 -- abstract state ... defined at ...
28656 -- constant ... defined at ...
28657 -- variable ... defined at ...
28662 ("state & has unused Part_Of constituents",
28666 Error_Msg_Sloc := Sloc (Constit_Id);
28668 if Ekind (Constit_Id) = E_Abstract_State then
28670 ("\abstract state & defined #", State, Constit_Id);
28672 elsif Ekind (Constit_Id) = E_Constant then
28674 ("\constant & defined #", State, Constit_Id);
28677 pragma Assert (Ekind (Constit_Id) = E_Variable);
28678 SPARK_Msg_NE ("\variable & defined #", State, Constit_Id);
28681 Next_Elmt (Constit_Elmt);
28684 end Report_Unused_Constituents;
28686 -- Local declarations
28688 Body_Ref : Node_Id;
28689 Body_Ref_Elmt : Elmt_Id;
28691 Extra_State : Node_Id;
28693 -- Start of processing for Analyze_Refinement_Clause
28696 -- A refinement clause appears as a component association where the
28697 -- sole choice is the state and the expressions are the constituents.
28698 -- This is a syntax error, always report.
28700 if Nkind (Clause) /= N_Component_Association then
28701 Error_Msg_N ("malformed state refinement clause", Clause);
28705 -- Analyze the state name of a refinement clause
28707 State := First (Choices (Clause));
28710 Resolve_State (State);
28712 -- Ensure that the state name denotes a valid abstract state that is
28713 -- defined in the spec of the related package.
28715 if Is_Entity_Name (State) then
28716 State_Id := Entity_Of (State);
28718 -- When the abstract state is undefined, it appears as Any_Id. Do
28719 -- not continue with the analysis of the clause.
28721 if State_Id = Any_Id then
28724 -- Catch any attempts to re-refine a state or refine a state that
28725 -- is not defined in the package declaration.
28727 elsif Ekind (State_Id) = E_Abstract_State then
28731 SPARK_Msg_NE ("& must denote abstract state", State, State_Id);
28735 -- References to a state with visible refinement are illegal.
28736 -- When nested packages are involved, detecting such references is
28737 -- tricky because pragma Refined_State is analyzed later than the
28738 -- offending pragma Depends or Global. References that occur in
28739 -- such nested context are stored in a list. Emit errors for all
28740 -- references found in Body_References (SPARK RM 6.1.4(8)).
28742 if Present (Body_References (State_Id)) then
28743 Body_Ref_Elmt := First_Elmt (Body_References (State_Id));
28744 while Present (Body_Ref_Elmt) loop
28745 Body_Ref := Node (Body_Ref_Elmt);
28747 SPARK_Msg_N ("reference to & not allowed", Body_Ref);
28748 Error_Msg_Sloc := Sloc (State);
28749 SPARK_Msg_N ("\refinement of & is visible#", Body_Ref);
28751 Next_Elmt (Body_Ref_Elmt);
28755 -- The state name is illegal. This is a syntax error, always report.
28758 Error_Msg_N ("malformed state name in refinement clause", State);
28762 -- A refinement clause may only refine one state at a time
28764 Extra_State := Next (State);
28766 if Present (Extra_State) then
28768 ("refinement clause cannot cover multiple states", Extra_State);
28771 -- Replicate the Part_Of constituents of the refined state because
28772 -- the algorithm will consume items.
28774 Part_Of_Constits := New_Copy_Elist (Part_Of_Constituents (State_Id));
28776 -- Analyze all constituents of the refinement. Multiple constituents
28777 -- appear as an aggregate.
28779 Constit := Expression (Clause);
28781 if Nkind (Constit) = N_Aggregate then
28782 if Present (Component_Associations (Constit)) then
28784 ("constituents of refinement clause must appear in "
28785 & "positional form", Constit);
28787 else pragma Assert (Present (Expressions (Constit)));
28788 Constit := First (Expressions (Constit));
28789 while Present (Constit) loop
28790 Analyze_Constituent (Constit);
28795 -- Various forms of a single constituent. Note that these may include
28796 -- malformed constituents.
28799 Analyze_Constituent (Constit);
28802 -- Verify that external constituents do not introduce new external
28803 -- property in the state refinement (SPARK RM 7.2.8(2)).
28805 if Is_External_State (State_Id) then
28806 Check_External_Property
28807 (Prop_Nam => Name_Async_Readers,
28808 Enabled => Async_Readers_Enabled (State_Id),
28809 Constit => AR_Constit);
28811 Check_External_Property
28812 (Prop_Nam => Name_Async_Writers,
28813 Enabled => Async_Writers_Enabled (State_Id),
28814 Constit => AW_Constit);
28816 Check_External_Property
28817 (Prop_Nam => Name_Effective_Reads,
28818 Enabled => Effective_Reads_Enabled (State_Id),
28819 Constit => ER_Constit);
28821 Check_External_Property
28822 (Prop_Nam => Name_Effective_Writes,
28823 Enabled => Effective_Writes_Enabled (State_Id),
28824 Constit => EW_Constit);
28826 -- When a refined state is not external, it should not have external
28827 -- constituents (SPARK RM 7.2.8(1)).
28829 elsif External_Constit_Seen then
28831 ("non-external state & cannot contain external constituents in "
28832 & "refinement", State, State_Id);
28835 -- Ensure that all Part_Of candidate constituents have been mentioned
28836 -- in the refinement clause.
28838 Report_Unused_Constituents (Part_Of_Constits);
28839 end Analyze_Refinement_Clause;
28841 -----------------------------
28842 -- Report_Unrefined_States --
28843 -----------------------------
28845 procedure Report_Unrefined_States (States : Elist_Id) is
28846 State_Elmt : Elmt_Id;
28849 if Present (States) then
28850 State_Elmt := First_Elmt (States);
28851 while Present (State_Elmt) loop
28853 ("abstract state & must be refined", Node (State_Elmt));
28855 Next_Elmt (State_Elmt);
28858 end Report_Unrefined_States;
28860 -- Local declarations
28862 Clauses : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
28865 -- Start of processing for Analyze_Refined_State_In_Decl_Part
28868 -- Do not analyze the pragma multiple times
28870 if Is_Analyzed_Pragma (N) then
28874 -- Save the scenario for examination by the ABE Processing phase
28876 Record_Elaboration_Scenario (N);
28878 -- Replicate the abstract states declared by the package because the
28879 -- matching algorithm will consume states.
28881 Available_States := New_Copy_Elist (Abstract_States (Spec_Id));
28883 -- Gather all abstract states and objects declared in the visible
28884 -- state space of the package body. These items must be utilized as
28885 -- constituents in a state refinement.
28887 Body_States := Collect_Body_States (Body_Id);
28889 -- Multiple non-null state refinements appear as an aggregate
28891 if Nkind (Clauses) = N_Aggregate then
28892 if Present (Expressions (Clauses)) then
28894 ("state refinements must appear as component associations",
28897 else pragma Assert (Present (Component_Associations (Clauses)));
28898 Clause := First (Component_Associations (Clauses));
28899 while Present (Clause) loop
28900 Analyze_Refinement_Clause (Clause);
28905 -- Various forms of a single state refinement. Note that these may
28906 -- include malformed refinements.
28909 Analyze_Refinement_Clause (Clauses);
28912 -- List all abstract states that were left unrefined
28914 Report_Unrefined_States (Available_States);
28916 Set_Is_Analyzed_Pragma (N);
28917 end Analyze_Refined_State_In_Decl_Part;
28919 ------------------------------------
28920 -- Analyze_Test_Case_In_Decl_Part --
28921 ------------------------------------
28923 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id) is
28924 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
28925 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
28927 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id);
28928 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
28929 -- denoted by Arg_Nam.
28931 ------------------------------
28932 -- Preanalyze_Test_Case_Arg --
28933 ------------------------------
28935 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id) is
28939 -- Preanalyze the original aspect argument for a generic subprogram
28940 -- to properly capture global references.
28942 if Is_Generic_Subprogram (Spec_Id) then
28946 Arg_Nam => Arg_Nam,
28947 From_Aspect => True);
28949 if Present (Arg) then
28950 Preanalyze_Assert_Expression
28951 (Expression (Arg), Standard_Boolean);
28955 Arg := Test_Case_Arg (N, Arg_Nam);
28957 if Present (Arg) then
28958 Preanalyze_Assert_Expression (Expression (Arg), Standard_Boolean);
28960 end Preanalyze_Test_Case_Arg;
28964 Restore_Scope : Boolean := False;
28966 -- Start of processing for Analyze_Test_Case_In_Decl_Part
28969 -- Do not analyze the pragma multiple times
28971 if Is_Analyzed_Pragma (N) then
28975 -- Ensure that the formal parameters are visible when analyzing all
28976 -- clauses. This falls out of the general rule of aspects pertaining
28977 -- to subprogram declarations.
28979 if not In_Open_Scopes (Spec_Id) then
28980 Restore_Scope := True;
28981 Push_Scope (Spec_Id);
28983 if Is_Generic_Subprogram (Spec_Id) then
28984 Install_Generic_Formals (Spec_Id);
28986 Install_Formals (Spec_Id);
28990 Preanalyze_Test_Case_Arg (Name_Requires);
28991 Preanalyze_Test_Case_Arg (Name_Ensures);
28993 if Restore_Scope then
28997 -- Currently it is not possible to inline pre/postconditions on a
28998 -- subprogram subject to pragma Inline_Always.
29000 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
29002 Set_Is_Analyzed_Pragma (N);
29003 end Analyze_Test_Case_In_Decl_Part;
29009 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is
29014 if Present (List) then
29015 Elmt := First_Elmt (List);
29016 while Present (Elmt) loop
29017 if Nkind (Node (Elmt)) = N_Defining_Identifier then
29020 Id := Entity_Of (Node (Elmt));
29023 if Id = Item_Id then
29034 -----------------------------------
29035 -- Build_Pragma_Check_Equivalent --
29036 -----------------------------------
29038 function Build_Pragma_Check_Equivalent
29040 Subp_Id : Entity_Id := Empty;
29041 Inher_Id : Entity_Id := Empty;
29042 Keep_Pragma_Id : Boolean := False) return Node_Id
29044 function Suppress_Reference (N : Node_Id) return Traverse_Result;
29045 -- Detect whether node N references a formal parameter subject to
29046 -- pragma Unreferenced. If this is the case, set Comes_From_Source
29047 -- to False to suppress the generation of a reference when analyzing
29050 ------------------------
29051 -- Suppress_Reference --
29052 ------------------------
29054 function Suppress_Reference (N : Node_Id) return Traverse_Result is
29055 Formal : Entity_Id;
29058 if Is_Entity_Name (N) and then Present (Entity (N)) then
29059 Formal := Entity (N);
29061 -- The formal parameter is subject to pragma Unreferenced. Prevent
29062 -- the generation of references by resetting the Comes_From_Source
29065 if Is_Formal (Formal)
29066 and then Has_Pragma_Unreferenced (Formal)
29068 Set_Comes_From_Source (N, False);
29073 end Suppress_Reference;
29075 procedure Suppress_References is
29076 new Traverse_Proc (Suppress_Reference);
29080 Loc : constant Source_Ptr := Sloc (Prag);
29081 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
29082 Check_Prag : Node_Id;
29086 Needs_Wrapper : Boolean;
29087 pragma Unreferenced (Needs_Wrapper);
29089 -- Start of processing for Build_Pragma_Check_Equivalent
29092 -- When the pre- or postcondition is inherited, map the formals of the
29093 -- inherited subprogram to those of the current subprogram. In addition,
29094 -- map primitive operations of the parent type into the corresponding
29095 -- primitive operations of the descendant.
29097 if Present (Inher_Id) then
29098 pragma Assert (Present (Subp_Id));
29100 Update_Primitives_Mapping (Inher_Id, Subp_Id);
29102 -- Use generic machinery to copy inherited pragma, as if it were an
29103 -- instantiation, resetting source locations appropriately, so that
29104 -- expressions inside the inherited pragma use chained locations.
29105 -- This is used in particular in GNATprove to locate precisely
29106 -- messages on a given inherited pragma.
29108 Set_Copied_Sloc_For_Inherited_Pragma
29109 (Unit_Declaration_Node (Subp_Id), Inher_Id);
29110 Check_Prag := New_Copy_Tree (Source => Prag);
29112 -- Build the inherited class-wide condition
29114 Build_Class_Wide_Expression
29115 (Prag => Check_Prag,
29117 Par_Subp => Inher_Id,
29118 Adjust_Sloc => True,
29119 Needs_Wrapper => Needs_Wrapper);
29121 -- If not an inherited condition simply copy the original pragma
29124 Check_Prag := New_Copy_Tree (Source => Prag);
29127 -- Mark the pragma as being internally generated and reset the Analyzed
29130 Set_Analyzed (Check_Prag, False);
29131 Set_Comes_From_Source (Check_Prag, False);
29133 -- The tree of the original pragma may contain references to the
29134 -- formal parameters of the related subprogram. At the same time
29135 -- the corresponding body may mark the formals as unreferenced:
29137 -- procedure Proc (Formal : ...)
29138 -- with Pre => Formal ...;
29140 -- procedure Proc (Formal : ...) is
29141 -- pragma Unreferenced (Formal);
29144 -- This creates problems because all pragma Check equivalents are
29145 -- analyzed at the end of the body declarations. Since all source
29146 -- references have already been accounted for, reset any references
29147 -- to such formals in the generated pragma Check equivalent.
29149 Suppress_References (Check_Prag);
29151 if Present (Corresponding_Aspect (Prag)) then
29152 Nam := Chars (Identifier (Corresponding_Aspect (Prag)));
29157 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
29158 -- the copied pragma in the newly created pragma, convert the copy into
29159 -- pragma Check by correcting the name and adding a check_kind argument.
29161 if not Keep_Pragma_Id then
29162 Set_Class_Present (Check_Prag, False);
29164 Set_Pragma_Identifier
29165 (Check_Prag, Make_Identifier (Loc, Name_Check));
29167 Prepend_To (Pragma_Argument_Associations (Check_Prag),
29168 Make_Pragma_Argument_Association (Loc,
29169 Expression => Make_Identifier (Loc, Nam)));
29172 -- Update the error message when the pragma is inherited
29174 if Present (Inher_Id) then
29175 Msg_Arg := Last (Pragma_Argument_Associations (Check_Prag));
29177 if Chars (Msg_Arg) = Name_Message then
29178 String_To_Name_Buffer (Strval (Expression (Msg_Arg)));
29180 -- Insert "inherited" to improve the error message
29182 if Name_Buffer (1 .. 8) = "failed p" then
29183 Insert_Str_In_Name_Buffer ("inherited ", 8);
29184 Set_Strval (Expression (Msg_Arg), String_From_Name_Buffer);
29190 end Build_Pragma_Check_Equivalent;
29192 -----------------------------
29193 -- Check_Applicable_Policy --
29194 -----------------------------
29196 procedure Check_Applicable_Policy (N : Node_Id) is
29200 Ename : constant Name_Id := Original_Aspect_Pragma_Name (N);
29203 -- No effect if not valid assertion kind name
29205 if not Is_Valid_Assertion_Kind (Ename) then
29209 -- Loop through entries in check policy list
29211 PP := Opt.Check_Policy_List;
29212 while Present (PP) loop
29214 PPA : constant List_Id := Pragma_Argument_Associations (PP);
29215 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
29219 or else Pnm = Name_Assertion
29220 or else (Pnm = Name_Statement_Assertions
29221 and then Ename in Name_Assert
29222 | Name_Assert_And_Cut
29224 | Name_Loop_Invariant
29225 | Name_Loop_Variant)
29227 Policy := Chars (Get_Pragma_Arg (Last (PPA)));
29233 -- In CodePeer mode and GNATprove mode, we need to
29234 -- consider all assertions, unless they are disabled.
29235 -- Force Is_Checked on ignored assertions, in particular
29236 -- because transformations of the AST may depend on
29237 -- assertions being checked (e.g. the translation of
29238 -- attribute 'Loop_Entry).
29240 if CodePeer_Mode or GNATprove_Mode then
29241 Set_Is_Checked (N, True);
29242 Set_Is_Ignored (N, False);
29244 Set_Is_Checked (N, False);
29245 Set_Is_Ignored (N, True);
29251 Set_Is_Checked (N, True);
29252 Set_Is_Ignored (N, False);
29254 when Name_Disable =>
29255 Set_Is_Ignored (N, True);
29256 Set_Is_Checked (N, False);
29257 Set_Is_Disabled (N, True);
29259 -- That should be exhaustive, the null here is a defence
29260 -- against a malformed tree from previous errors.
29269 PP := Next_Pragma (PP);
29273 -- If there are no specific entries that matched, then we let the
29274 -- setting of assertions govern. Note that this provides the needed
29275 -- compatibility with the RM for the cases of assertion, invariant,
29276 -- precondition, predicate, and postcondition. Note also that
29277 -- Assertions_Enabled is forced in CodePeer mode and GNATprove mode.
29279 if Assertions_Enabled then
29280 Set_Is_Checked (N, True);
29281 Set_Is_Ignored (N, False);
29283 Set_Is_Checked (N, False);
29284 Set_Is_Ignored (N, True);
29286 end Check_Applicable_Policy;
29288 -------------------------------
29289 -- Check_External_Properties --
29290 -------------------------------
29292 procedure Check_External_Properties
29300 -- All properties enabled
29302 if AR and AW and ER and EW then
29305 -- Async_Readers + Effective_Writes
29306 -- Async_Readers + Async_Writers + Effective_Writes
29308 elsif AR and EW and not ER then
29311 -- Async_Writers + Effective_Reads
29312 -- Async_Readers + Async_Writers + Effective_Reads
29314 elsif AW and ER and not EW then
29317 -- Async_Readers + Async_Writers
29319 elsif AR and AW and not ER and not EW then
29324 elsif AR and not AW and not ER and not EW then
29329 elsif AW and not AR and not ER and not EW then
29334 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
29337 end Check_External_Properties;
29343 function Check_Kind (Nam : Name_Id) return Name_Id is
29347 -- Loop through entries in check policy list
29349 PP := Opt.Check_Policy_List;
29350 while Present (PP) loop
29352 PPA : constant List_Id := Pragma_Argument_Associations (PP);
29353 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
29357 or else (Pnm = Name_Assertion
29358 and then Is_Valid_Assertion_Kind (Nam))
29359 or else (Pnm = Name_Statement_Assertions
29360 and then Nam in Name_Assert
29361 | Name_Assert_And_Cut
29363 | Name_Loop_Invariant
29364 | Name_Loop_Variant)
29366 case (Chars (Get_Pragma_Arg (Last (PPA)))) is
29375 return Name_Ignore;
29377 when Name_Disable =>
29378 return Name_Disable;
29381 raise Program_Error;
29385 PP := Next_Pragma (PP);
29390 -- If there are no specific entries that matched, then we let the
29391 -- setting of assertions govern. Note that this provides the needed
29392 -- compatibility with the RM for the cases of assertion, invariant,
29393 -- precondition, predicate, and postcondition.
29395 if Assertions_Enabled then
29398 return Name_Ignore;
29402 ---------------------------
29403 -- Check_Missing_Part_Of --
29404 ---------------------------
29406 procedure Check_Missing_Part_Of (Item_Id : Entity_Id) is
29407 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean;
29408 -- Determine whether a package denoted by Pack_Id declares at least one
29411 -----------------------
29412 -- Has_Visible_State --
29413 -----------------------
29415 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean is
29416 Item_Id : Entity_Id;
29419 -- Traverse the entity chain of the package trying to find at least
29420 -- one visible abstract state, variable or a package [instantiation]
29421 -- that declares a visible state.
29423 Item_Id := First_Entity (Pack_Id);
29424 while Present (Item_Id)
29425 and then not In_Private_Part (Item_Id)
29427 -- Do not consider internally generated items
29429 if not Comes_From_Source (Item_Id) then
29432 -- Do not consider generic formals or their corresponding actuals
29433 -- because they are not part of a visible state. Note that both
29434 -- entities are marked as hidden.
29436 elsif Is_Hidden (Item_Id) then
29439 -- A visible state has been found. Note that constants are not
29440 -- considered here because it is not possible to determine whether
29441 -- they depend on variable input. This check is left to the SPARK
29444 elsif Ekind (Item_Id) in E_Abstract_State | E_Variable then
29447 -- Recursively peek into nested packages and instantiations
29449 elsif Ekind (Item_Id) = E_Package
29450 and then Has_Visible_State (Item_Id)
29455 Next_Entity (Item_Id);
29459 end Has_Visible_State;
29463 Pack_Id : Entity_Id;
29464 Placement : State_Space_Kind;
29466 -- Start of processing for Check_Missing_Part_Of
29469 -- Do not consider abstract states, variables or package instantiations
29470 -- coming from an instance as those always inherit the Part_Of indicator
29471 -- of the instance itself.
29473 if In_Instance then
29476 -- Do not consider internally generated entities as these can never
29477 -- have a Part_Of indicator.
29479 elsif not Comes_From_Source (Item_Id) then
29482 -- Perform these checks only when SPARK_Mode is enabled as they will
29483 -- interfere with standard Ada rules and produce false positives.
29485 elsif SPARK_Mode /= On then
29488 -- Do not consider constants, because the compiler cannot accurately
29489 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
29490 -- act as a hidden state of a package.
29492 elsif Ekind (Item_Id) = E_Constant then
29496 -- Find where the abstract state, variable or package instantiation
29497 -- lives with respect to the state space.
29499 Find_Placement_In_State_Space
29500 (Item_Id => Item_Id,
29501 Placement => Placement,
29502 Pack_Id => Pack_Id);
29504 -- Items that appear in a non-package construct (subprogram, block, etc)
29505 -- do not require a Part_Of indicator because they can never act as a
29508 if Placement = Not_In_Package then
29511 -- An item declared in the body state space of a package always act as a
29512 -- constituent and does not need explicit Part_Of indicator.
29514 elsif Placement = Body_State_Space then
29517 -- In general an item declared in the visible state space of a package
29518 -- does not require a Part_Of indicator. The only exception is when the
29519 -- related package is a nongeneric private child unit, in which case
29520 -- Part_Of must denote a state in the parent unit or in one of its
29523 elsif Placement = Visible_State_Space then
29524 if Is_Child_Unit (Pack_Id)
29525 and then not Is_Generic_Unit (Pack_Id)
29526 and then Is_Private_Descendant (Pack_Id)
29528 -- A package instantiation does not need a Part_Of indicator when
29529 -- the related generic template has no visible state.
29531 if Ekind (Item_Id) = E_Package
29532 and then Is_Generic_Instance (Item_Id)
29533 and then not Has_Visible_State (Item_Id)
29537 -- All other cases require Part_Of
29541 ("indicator Part_Of is required in this context "
29542 & "(SPARK RM 7.2.6(3))", Item_Id);
29543 Error_Msg_Name_1 := Chars (Pack_Id);
29545 ("\& is declared in the visible part of private child "
29546 & "unit %", Item_Id);
29550 -- When the item appears in the private state space of a package, it
29551 -- must be a part of some state declared by the said package.
29553 else pragma Assert (Placement = Private_State_Space);
29555 -- The related package does not declare a state, the item cannot act
29556 -- as a Part_Of constituent.
29558 if No (Get_Pragma (Pack_Id, Pragma_Abstract_State)) then
29561 -- A package instantiation does not need a Part_Of indicator when the
29562 -- related generic template has no visible state.
29564 elsif Ekind (Item_Id) = E_Package
29565 and then Is_Generic_Instance (Item_Id)
29566 and then not Has_Visible_State (Item_Id)
29570 -- All other cases require Part_Of
29574 ("indicator Part_Of is required in this context "
29575 & "(SPARK RM 7.2.6(2))", Item_Id);
29576 Error_Msg_Name_1 := Chars (Pack_Id);
29578 ("\& is declared in the private part of package %", Item_Id);
29581 end Check_Missing_Part_Of;
29583 ---------------------------------------------------
29584 -- Check_Postcondition_Use_In_Inlined_Subprogram --
29585 ---------------------------------------------------
29587 procedure Check_Postcondition_Use_In_Inlined_Subprogram
29589 Spec_Id : Entity_Id)
29592 if Warn_On_Redundant_Constructs
29593 and then Has_Pragma_Inline_Always (Spec_Id)
29594 and then Assertions_Enabled
29596 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
29598 if From_Aspect_Specification (Prag) then
29600 ("aspect % not enforced on inlined subprogram &?r?",
29601 Corresponding_Aspect (Prag), Spec_Id);
29604 ("pragma % not enforced on inlined subprogram &?r?",
29608 end Check_Postcondition_Use_In_Inlined_Subprogram;
29610 -------------------------------------
29611 -- Check_State_And_Constituent_Use --
29612 -------------------------------------
29614 procedure Check_State_And_Constituent_Use
29615 (States : Elist_Id;
29616 Constits : Elist_Id;
29619 Constit_Elmt : Elmt_Id;
29620 Constit_Id : Entity_Id;
29621 State_Id : Entity_Id;
29624 -- Nothing to do if there are no states or constituents
29626 if No (States) or else No (Constits) then
29630 -- Inspect the list of constituents and try to determine whether its
29631 -- encapsulating state is in list States.
29633 Constit_Elmt := First_Elmt (Constits);
29634 while Present (Constit_Elmt) loop
29635 Constit_Id := Node (Constit_Elmt);
29637 -- Determine whether the constituent is part of an encapsulating
29638 -- state that appears in the same context and if this is the case,
29639 -- emit an error (SPARK RM 7.2.6(7)).
29641 State_Id := Find_Encapsulating_State (States, Constit_Id);
29643 if Present (State_Id) then
29644 Error_Msg_Name_1 := Chars (Constit_Id);
29646 ("cannot mention state & and its constituent % in the same "
29647 & "context", Context, State_Id);
29651 Next_Elmt (Constit_Elmt);
29653 end Check_State_And_Constituent_Use;
29655 ---------------------------------------------
29656 -- Collect_Inherited_Class_Wide_Conditions --
29657 ---------------------------------------------
29659 procedure Collect_Inherited_Class_Wide_Conditions (Subp : Entity_Id) is
29660 Parent_Subp : constant Entity_Id :=
29661 Ultimate_Alias (Overridden_Operation (Subp));
29662 -- The Overridden_Operation may itself be inherited and as such have no
29663 -- explicit contract.
29665 Prags : constant Node_Id := Contract (Parent_Subp);
29666 In_Spec_Expr : Boolean := In_Spec_Expression;
29667 Installed : Boolean;
29669 New_Prag : Node_Id;
29672 Installed := False;
29674 -- Iterate over the contract of the overridden subprogram to find all
29675 -- inherited class-wide pre- and postconditions.
29677 if Present (Prags) then
29678 Prag := Pre_Post_Conditions (Prags);
29680 while Present (Prag) loop
29681 if Pragma_Name_Unmapped (Prag)
29682 in Name_Precondition | Name_Postcondition
29683 and then Class_Present (Prag)
29685 -- The generated pragma must be analyzed in the context of
29686 -- the subprogram, to make its formals visible. In addition,
29687 -- we must inhibit freezing and full analysis because the
29688 -- controlling type of the subprogram is not frozen yet, and
29689 -- may have further primitives.
29691 if not Installed then
29694 Install_Formals (Subp);
29695 In_Spec_Expr := In_Spec_Expression;
29696 In_Spec_Expression := True;
29700 Build_Pragma_Check_Equivalent
29701 (Prag, Subp, Parent_Subp, Keep_Pragma_Id => True);
29703 Insert_After (Unit_Declaration_Node (Subp), New_Prag);
29704 Preanalyze (New_Prag);
29706 -- Prevent further analysis in subsequent processing of the
29707 -- current list of declarations
29709 Set_Analyzed (New_Prag);
29712 Prag := Next_Pragma (Prag);
29716 In_Spec_Expression := In_Spec_Expr;
29720 end Collect_Inherited_Class_Wide_Conditions;
29722 ---------------------------------------
29723 -- Collect_Subprogram_Inputs_Outputs --
29724 ---------------------------------------
29726 procedure Collect_Subprogram_Inputs_Outputs
29727 (Subp_Id : Entity_Id;
29728 Synthesize : Boolean := False;
29729 Subp_Inputs : in out Elist_Id;
29730 Subp_Outputs : in out Elist_Id;
29731 Global_Seen : out Boolean)
29733 procedure Collect_Dependency_Clause (Clause : Node_Id);
29734 -- Collect all relevant items from a dependency clause
29736 procedure Collect_Global_List
29738 Mode : Name_Id := Name_Input);
29739 -- Collect all relevant items from a global list
29741 -------------------------------
29742 -- Collect_Dependency_Clause --
29743 -------------------------------
29745 procedure Collect_Dependency_Clause (Clause : Node_Id) is
29746 procedure Collect_Dependency_Item
29748 Is_Input : Boolean);
29749 -- Add an item to the proper subprogram input or output collection
29751 -----------------------------
29752 -- Collect_Dependency_Item --
29753 -----------------------------
29755 procedure Collect_Dependency_Item
29757 Is_Input : Boolean)
29762 -- Nothing to collect when the item is null
29764 if Nkind (Item) = N_Null then
29767 -- Ditto for attribute 'Result
29769 elsif Is_Attribute_Result (Item) then
29772 -- Multiple items appear as an aggregate
29774 elsif Nkind (Item) = N_Aggregate then
29775 Extra := First (Expressions (Item));
29776 while Present (Extra) loop
29777 Collect_Dependency_Item (Extra, Is_Input);
29781 -- Otherwise this is a solitary item
29785 Append_New_Elmt (Item, Subp_Inputs);
29787 Append_New_Elmt (Item, Subp_Outputs);
29790 end Collect_Dependency_Item;
29792 -- Start of processing for Collect_Dependency_Clause
29795 if Nkind (Clause) = N_Null then
29798 -- A dependency clause appears as component association
29800 elsif Nkind (Clause) = N_Component_Association then
29801 Collect_Dependency_Item
29802 (Item => Expression (Clause),
29805 Collect_Dependency_Item
29806 (Item => First (Choices (Clause)),
29807 Is_Input => False);
29809 -- To accommodate partial decoration of disabled SPARK features, this
29810 -- routine may be called with illegal input. If this is the case, do
29811 -- not raise Program_Error.
29816 end Collect_Dependency_Clause;
29818 -------------------------
29819 -- Collect_Global_List --
29820 -------------------------
29822 procedure Collect_Global_List
29824 Mode : Name_Id := Name_Input)
29826 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id);
29827 -- Add an item to the proper subprogram input or output collection
29829 -------------------------
29830 -- Collect_Global_Item --
29831 -------------------------
29833 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is
29835 if Mode in Name_In_Out | Name_Input then
29836 Append_New_Elmt (Item, Subp_Inputs);
29839 if Mode in Name_In_Out | Name_Output then
29840 Append_New_Elmt (Item, Subp_Outputs);
29842 end Collect_Global_Item;
29849 -- Start of processing for Collect_Global_List
29852 if Nkind (List) = N_Null then
29855 -- Single global item declaration
29857 elsif Nkind (List) in N_Expanded_Name
29859 | N_Selected_Component
29861 Collect_Global_Item (List, Mode);
29863 -- Simple global list or moded global list declaration
29865 elsif Nkind (List) = N_Aggregate then
29866 if Present (Expressions (List)) then
29867 Item := First (Expressions (List));
29868 while Present (Item) loop
29869 Collect_Global_Item (Item, Mode);
29874 Assoc := First (Component_Associations (List));
29875 while Present (Assoc) loop
29876 Collect_Global_List
29877 (List => Expression (Assoc),
29878 Mode => Chars (First (Choices (Assoc))));
29883 -- To accommodate partial decoration of disabled SPARK features, this
29884 -- routine may be called with illegal input. If this is the case, do
29885 -- not raise Program_Error.
29890 end Collect_Global_List;
29897 Formal : Entity_Id;
29899 Spec_Id : Entity_Id := Empty;
29900 Subp_Decl : Node_Id;
29903 -- Start of processing for Collect_Subprogram_Inputs_Outputs
29906 Global_Seen := False;
29908 -- Process all formal parameters of entries, [generic] subprograms, and
29911 if Ekind (Subp_Id) in E_Entry
29914 | E_Generic_Function
29915 | E_Generic_Procedure
29917 | E_Subprogram_Body
29919 Subp_Decl := Unit_Declaration_Node (Subp_Id);
29920 Spec_Id := Unique_Defining_Entity (Subp_Decl);
29922 -- Process all formal parameters
29924 Formal := First_Entity (Spec_Id);
29925 while Present (Formal) loop
29926 if Ekind (Formal) in E_In_Out_Parameter | E_In_Parameter then
29927 Append_New_Elmt (Formal, Subp_Inputs);
29930 if Ekind (Formal) in E_In_Out_Parameter | E_Out_Parameter then
29931 Append_New_Elmt (Formal, Subp_Outputs);
29933 -- Out parameters can act as inputs when the related type is
29934 -- tagged, unconstrained array, unconstrained record, or record
29935 -- with unconstrained components.
29937 if Ekind (Formal) = E_Out_Parameter
29938 and then Is_Unconstrained_Or_Tagged_Item (Formal)
29940 Append_New_Elmt (Formal, Subp_Inputs);
29944 Next_Entity (Formal);
29947 -- Otherwise the input denotes a task type, a task body, or the
29948 -- anonymous object created for a single task type.
29950 elsif Ekind (Subp_Id) in E_Task_Type | E_Task_Body
29951 or else Is_Single_Task_Object (Subp_Id)
29953 Subp_Decl := Declaration_Node (Subp_Id);
29954 Spec_Id := Unique_Defining_Entity (Subp_Decl);
29957 -- When processing an entry, subprogram or task body, look for pragmas
29958 -- Refined_Depends and Refined_Global as they specify the inputs and
29961 if Is_Entry_Body (Subp_Id)
29962 or else Ekind (Subp_Id) in E_Subprogram_Body | E_Task_Body
29964 Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends);
29965 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global);
29967 -- Subprogram declaration or stand-alone body case, look for pragmas
29968 -- Depends and Global
29971 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
29972 Global := Get_Pragma (Spec_Id, Pragma_Global);
29975 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
29976 -- because it provides finer granularity of inputs and outputs.
29978 if Present (Global) then
29979 Global_Seen := True;
29980 Collect_Global_List (Expression (Get_Argument (Global, Spec_Id)));
29982 -- When the related subprogram lacks pragma [Refined_]Global, fall back
29983 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
29984 -- the inputs and outputs from [Refined_]Depends.
29986 elsif Synthesize and then Present (Depends) then
29987 Clauses := Expression (Get_Argument (Depends, Spec_Id));
29989 -- Multiple dependency clauses appear as an aggregate
29991 if Nkind (Clauses) = N_Aggregate then
29992 Clause := First (Component_Associations (Clauses));
29993 while Present (Clause) loop
29994 Collect_Dependency_Clause (Clause);
29998 -- Otherwise this is a single dependency clause
30001 Collect_Dependency_Clause (Clauses);
30005 -- The current instance of a protected type acts as a formal parameter
30006 -- of mode IN for functions and IN OUT for entries and procedures
30007 -- (SPARK RM 6.1.4).
30009 if Ekind (Scope (Spec_Id)) = E_Protected_Type then
30010 Typ := Scope (Spec_Id);
30012 -- Use the anonymous object when the type is single protected
30014 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
30015 Typ := Anonymous_Object (Typ);
30018 Append_New_Elmt (Typ, Subp_Inputs);
30020 if Ekind (Spec_Id) in E_Entry | E_Entry_Family | E_Procedure then
30021 Append_New_Elmt (Typ, Subp_Outputs);
30024 -- The current instance of a task type acts as a formal parameter of
30025 -- mode IN OUT (SPARK RM 6.1.4).
30027 elsif Ekind (Spec_Id) = E_Task_Type then
30030 -- Use the anonymous object when the type is single task
30032 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
30033 Typ := Anonymous_Object (Typ);
30036 Append_New_Elmt (Typ, Subp_Inputs);
30037 Append_New_Elmt (Typ, Subp_Outputs);
30039 elsif Is_Single_Task_Object (Spec_Id) then
30040 Append_New_Elmt (Spec_Id, Subp_Inputs);
30041 Append_New_Elmt (Spec_Id, Subp_Outputs);
30043 end Collect_Subprogram_Inputs_Outputs;
30045 ---------------------------
30046 -- Contract_Freeze_Error --
30047 ---------------------------
30049 procedure Contract_Freeze_Error
30050 (Contract_Id : Entity_Id;
30051 Freeze_Id : Entity_Id)
30054 Error_Msg_Name_1 := Chars (Contract_Id);
30055 Error_Msg_Sloc := Sloc (Freeze_Id);
30058 ("body & declared # freezes the contract of%", Contract_Id, Freeze_Id);
30060 ("\all contractual items must be declared before body #", Contract_Id);
30061 end Contract_Freeze_Error;
30063 ---------------------------------
30064 -- Delay_Config_Pragma_Analyze --
30065 ---------------------------------
30067 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
30069 return Pragma_Name_Unmapped (N)
30070 in Name_Interrupt_State | Name_Priority_Specific_Dispatching;
30071 end Delay_Config_Pragma_Analyze;
30073 -----------------------
30074 -- Duplication_Error --
30075 -----------------------
30077 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id) is
30078 Prag_From_Asp : constant Boolean := From_Aspect_Specification (Prag);
30079 Prev_From_Asp : constant Boolean := From_Aspect_Specification (Prev);
30082 Error_Msg_Sloc := Sloc (Prev);
30083 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
30085 -- Emit a precise message to distinguish between source pragmas and
30086 -- pragmas generated from aspects. The ordering of the two pragmas is
30090 -- Prag -- duplicate
30092 -- No error is emitted when both pragmas come from aspects because this
30093 -- is already detected by the general aspect analysis mechanism.
30095 if Prag_From_Asp and Prev_From_Asp then
30097 elsif Prag_From_Asp then
30098 Error_Msg_N ("aspect % duplicates pragma declared #", Prag);
30099 elsif Prev_From_Asp then
30100 Error_Msg_N ("pragma % duplicates aspect declared #", Prag);
30102 Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
30104 end Duplication_Error;
30106 ------------------------------
30107 -- Find_Encapsulating_State --
30108 ------------------------------
30110 function Find_Encapsulating_State
30111 (States : Elist_Id;
30112 Constit_Id : Entity_Id) return Entity_Id
30114 State_Id : Entity_Id;
30117 -- Since a constituent may be part of a larger constituent set, climb
30118 -- the encapsulating state chain looking for a state that appears in
30121 State_Id := Encapsulating_State (Constit_Id);
30122 while Present (State_Id) loop
30123 if Contains (States, State_Id) then
30127 State_Id := Encapsulating_State (State_Id);
30131 end Find_Encapsulating_State;
30133 --------------------------
30134 -- Find_Related_Context --
30135 --------------------------
30137 function Find_Related_Context
30139 Do_Checks : Boolean := False) return Node_Id
30144 Stmt := Prev (Prag);
30145 while Present (Stmt) loop
30147 -- Skip prior pragmas, but check for duplicates
30149 if Nkind (Stmt) = N_Pragma then
30151 and then Pragma_Name (Stmt) = Pragma_Name (Prag)
30158 -- Skip internally generated code
30160 elsif not Comes_From_Source (Stmt)
30161 and then not Comes_From_Source (Original_Node (Stmt))
30164 -- The anonymous object created for a single concurrent type is a
30165 -- suitable context.
30167 if Nkind (Stmt) = N_Object_Declaration
30168 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
30173 -- Return the current source construct
30183 end Find_Related_Context;
30185 --------------------------------------
30186 -- Find_Related_Declaration_Or_Body --
30187 --------------------------------------
30189 function Find_Related_Declaration_Or_Body
30191 Do_Checks : Boolean := False) return Node_Id
30193 Prag_Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
30195 procedure Expression_Function_Error;
30196 -- Emit an error concerning pragma Prag that illegaly applies to an
30197 -- expression function.
30199 -------------------------------
30200 -- Expression_Function_Error --
30201 -------------------------------
30203 procedure Expression_Function_Error is
30205 Error_Msg_Name_1 := Prag_Nam;
30207 -- Emit a precise message to distinguish between source pragmas and
30208 -- pragmas generated from aspects.
30210 if From_Aspect_Specification (Prag) then
30212 ("aspect % cannot apply to a stand alone expression function",
30216 ("pragma % cannot apply to a stand alone expression function",
30219 end Expression_Function_Error;
30223 Context : constant Node_Id := Parent (Prag);
30226 Look_For_Body : constant Boolean :=
30227 Prag_Nam in Name_Refined_Depends
30228 | Name_Refined_Global
30229 | Name_Refined_Post
30230 | Name_Refined_State;
30231 -- Refinement pragmas must be associated with a subprogram body [stub]
30233 -- Start of processing for Find_Related_Declaration_Or_Body
30236 Stmt := Prev (Prag);
30237 while Present (Stmt) loop
30239 -- Skip prior pragmas, but check for duplicates. Pragmas produced
30240 -- by splitting a complex pre/postcondition are not considered to
30243 if Nkind (Stmt) = N_Pragma then
30245 and then not Split_PPC (Stmt)
30246 and then Original_Aspect_Pragma_Name (Stmt) = Prag_Nam
30253 -- Emit an error when a refinement pragma appears on an expression
30254 -- function without a completion.
30257 and then Look_For_Body
30258 and then Nkind (Stmt) = N_Subprogram_Declaration
30259 and then Nkind (Original_Node (Stmt)) = N_Expression_Function
30260 and then not Has_Completion (Defining_Entity (Stmt))
30262 Expression_Function_Error;
30265 -- The refinement pragma applies to a subprogram body stub
30267 elsif Look_For_Body
30268 and then Nkind (Stmt) = N_Subprogram_Body_Stub
30272 -- Skip internally generated code
30274 elsif not Comes_From_Source (Stmt) then
30276 -- The anonymous object created for a single concurrent type is a
30277 -- suitable context.
30279 if Nkind (Stmt) = N_Object_Declaration
30280 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
30284 elsif Nkind (Stmt) = N_Subprogram_Declaration then
30286 -- The subprogram declaration is an internally generated spec
30287 -- for an expression function.
30289 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
30292 -- The subprogram declaration is an internally generated spec
30293 -- for a stand-alone subrogram body declared inside a protected
30296 elsif Present (Corresponding_Body (Stmt))
30297 and then Comes_From_Source (Corresponding_Body (Stmt))
30298 and then Is_Protected_Type (Current_Scope)
30302 -- The subprogram is actually an instance housed within an
30303 -- anonymous wrapper package.
30305 elsif Present (Generic_Parent (Specification (Stmt))) then
30308 -- Ada 2020: contract on formal subprogram or on generated
30309 -- Access_Subprogram_Wrapper, which appears after the related
30310 -- Access_Subprogram declaration.
30312 elsif Is_Generic_Actual_Subprogram (Defining_Entity (Stmt))
30313 and then Ada_Version >= Ada_2020
30317 elsif Is_Access_Subprogram_Wrapper (Defining_Entity (Stmt))
30318 and then Ada_Version >= Ada_2020
30324 -- Return the current construct which is either a subprogram body,
30325 -- a subprogram declaration or is illegal.
30334 -- If we fall through, then the pragma was either the first declaration
30335 -- or it was preceded by other pragmas and no source constructs.
30337 -- The pragma is associated with a library-level subprogram
30339 if Nkind (Context) = N_Compilation_Unit_Aux then
30340 return Unit (Parent (Context));
30342 -- The pragma appears inside the declarations of an entry body
30344 elsif Nkind (Context) = N_Entry_Body then
30347 -- The pragma appears inside the statements of a subprogram body. This
30348 -- placement is the result of subprogram contract expansion.
30350 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then
30351 return Parent (Context);
30353 -- The pragma appears inside the declarative part of a package body
30355 elsif Nkind (Context) = N_Package_Body then
30358 -- The pragma appears inside the declarative part of a subprogram body
30360 elsif Nkind (Context) = N_Subprogram_Body then
30363 -- The pragma appears inside the declarative part of a task body
30365 elsif Nkind (Context) = N_Task_Body then
30368 -- The pragma appears inside the visible part of a package specification
30370 elsif Nkind (Context) = N_Package_Specification then
30371 return Parent (Context);
30373 -- The pragma is a byproduct of aspect expansion, return the related
30374 -- context of the original aspect. This case has a lower priority as
30375 -- the above circuitry pinpoints precisely the related context.
30377 elsif Present (Corresponding_Aspect (Prag)) then
30378 return Parent (Corresponding_Aspect (Prag));
30380 -- No candidate subprogram [body] found
30385 end Find_Related_Declaration_Or_Body;
30387 ----------------------------------
30388 -- Find_Related_Package_Or_Body --
30389 ----------------------------------
30391 function Find_Related_Package_Or_Body
30393 Do_Checks : Boolean := False) return Node_Id
30395 Context : constant Node_Id := Parent (Prag);
30396 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
30400 Stmt := Prev (Prag);
30401 while Present (Stmt) loop
30403 -- Skip prior pragmas, but check for duplicates
30405 if Nkind (Stmt) = N_Pragma then
30406 if Do_Checks and then Pragma_Name (Stmt) = Prag_Nam then
30412 -- Skip internally generated code
30414 elsif not Comes_From_Source (Stmt) then
30415 if Nkind (Stmt) = N_Subprogram_Declaration then
30417 -- The subprogram declaration is an internally generated spec
30418 -- for an expression function.
30420 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
30423 -- The subprogram is actually an instance housed within an
30424 -- anonymous wrapper package.
30426 elsif Present (Generic_Parent (Specification (Stmt))) then
30431 -- Return the current source construct which is illegal
30440 -- If we fall through, then the pragma was either the first declaration
30441 -- or it was preceded by other pragmas and no source constructs.
30443 -- The pragma is associated with a package. The immediate context in
30444 -- this case is the specification of the package.
30446 if Nkind (Context) = N_Package_Specification then
30447 return Parent (Context);
30449 -- The pragma appears in the declarations of a package body
30451 elsif Nkind (Context) = N_Package_Body then
30454 -- The pragma appears in the statements of a package body
30456 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
30457 and then Nkind (Parent (Context)) = N_Package_Body
30459 return Parent (Context);
30461 -- The pragma is a byproduct of aspect expansion, return the related
30462 -- context of the original aspect. This case has a lower priority as
30463 -- the above circuitry pinpoints precisely the related context.
30465 elsif Present (Corresponding_Aspect (Prag)) then
30466 return Parent (Corresponding_Aspect (Prag));
30468 -- No candidate package [body] found
30473 end Find_Related_Package_Or_Body;
30479 function Get_Argument
30481 Context_Id : Entity_Id := Empty) return Node_Id
30483 Args : constant List_Id := Pragma_Argument_Associations (Prag);
30486 -- Use the expression of the original aspect when analyzing the template
30487 -- of a generic unit. In both cases the aspect's tree must be decorated
30488 -- to save the global references in the generic context.
30490 if From_Aspect_Specification (Prag)
30491 and then (Present (Context_Id) and then Is_Generic_Unit (Context_Id))
30493 return Corresponding_Aspect (Prag);
30495 -- Otherwise use the expression of the pragma
30497 elsif Present (Args) then
30498 return First (Args);
30505 -------------------------
30506 -- Get_Base_Subprogram --
30507 -------------------------
30509 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
30511 -- Follow subprogram renaming chain
30513 if Is_Subprogram (Def_Id)
30514 and then Nkind (Parent (Declaration_Node (Def_Id))) =
30515 N_Subprogram_Renaming_Declaration
30516 and then Present (Alias (Def_Id))
30518 return Alias (Def_Id);
30522 end Get_Base_Subprogram;
30524 -----------------------
30525 -- Get_SPARK_Mode_Type --
30526 -----------------------
30528 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is
30530 if N = Name_On then
30532 elsif N = Name_Off then
30535 -- Any other argument is illegal. Assume that no SPARK mode applies to
30536 -- avoid potential cascaded errors.
30541 end Get_SPARK_Mode_Type;
30543 ------------------------------------
30544 -- Get_SPARK_Mode_From_Annotation --
30545 ------------------------------------
30547 function Get_SPARK_Mode_From_Annotation
30548 (N : Node_Id) return SPARK_Mode_Type
30553 if Nkind (N) = N_Aspect_Specification then
30554 Mode := Expression (N);
30556 else pragma Assert (Nkind (N) = N_Pragma);
30557 Mode := First (Pragma_Argument_Associations (N));
30559 if Present (Mode) then
30560 Mode := Get_Pragma_Arg (Mode);
30564 -- Aspect or pragma SPARK_Mode specifies an explicit mode
30566 if Present (Mode) then
30567 if Nkind (Mode) = N_Identifier then
30568 return Get_SPARK_Mode_Type (Chars (Mode));
30570 -- In case of a malformed aspect or pragma, return the default None
30576 -- Otherwise the lack of an expression defaults SPARK_Mode to On
30581 end Get_SPARK_Mode_From_Annotation;
30583 ---------------------------
30584 -- Has_Extra_Parentheses --
30585 ---------------------------
30587 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean is
30591 -- The aggregate should not have an expression list because a clause
30592 -- is always interpreted as a component association. The only way an
30593 -- expression list can sneak in is by adding extra parentheses around
30594 -- the individual clauses:
30596 -- Depends (Output => Input) -- proper form
30597 -- Depends ((Output => Input)) -- extra parentheses
30599 -- Since the extra parentheses are not allowed by the syntax of the
30600 -- pragma, flag them now to avoid emitting misleading errors down the
30603 if Nkind (Clause) = N_Aggregate
30604 and then Present (Expressions (Clause))
30606 Expr := First (Expressions (Clause));
30607 while Present (Expr) loop
30609 -- A dependency clause surrounded by extra parentheses appears
30610 -- as an aggregate of component associations with an optional
30611 -- Paren_Count set.
30613 if Nkind (Expr) = N_Aggregate
30614 and then Present (Component_Associations (Expr))
30617 ("dependency clause contains extra parentheses", Expr);
30619 -- Otherwise the expression is a malformed construct
30622 SPARK_Msg_N ("malformed dependency clause", Expr);
30632 end Has_Extra_Parentheses;
30638 procedure Initialize is
30641 Compile_Time_Warnings_Errors.Init;
30650 Dummy := Dummy + 1;
30653 -----------------------------
30654 -- Is_Config_Static_String --
30655 -----------------------------
30657 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
30659 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
30660 -- This is an internal recursive function that is just like the outer
30661 -- function except that it adds the string to the name buffer rather
30662 -- than placing the string in the name buffer.
30664 ------------------------------
30665 -- Add_Config_Static_String --
30666 ------------------------------
30668 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
30675 if Nkind (N) = N_Op_Concat then
30676 if Add_Config_Static_String (Left_Opnd (N)) then
30677 N := Right_Opnd (N);
30683 if Nkind (N) /= N_String_Literal then
30684 Error_Msg_N ("string literal expected for pragma argument", N);
30688 for J in 1 .. String_Length (Strval (N)) loop
30689 C := Get_String_Char (Strval (N), J);
30691 if not In_Character_Range (C) then
30693 ("string literal contains invalid wide character",
30694 Sloc (N) + 1 + Source_Ptr (J));
30698 Add_Char_To_Name_Buffer (Get_Character (C));
30703 end Add_Config_Static_String;
30705 -- Start of processing for Is_Config_Static_String
30710 return Add_Config_Static_String (Arg);
30711 end Is_Config_Static_String;
30713 -------------------------------
30714 -- Is_Elaboration_SPARK_Mode --
30715 -------------------------------
30717 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is
30720 (Nkind (N) = N_Pragma
30721 and then Pragma_Name (N) = Name_SPARK_Mode
30722 and then Is_List_Member (N));
30724 -- Pragma SPARK_Mode affects the elaboration of a package body when it
30725 -- appears in the statement part of the body.
30728 Present (Parent (N))
30729 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
30730 and then List_Containing (N) = Statements (Parent (N))
30731 and then Present (Parent (Parent (N)))
30732 and then Nkind (Parent (Parent (N))) = N_Package_Body;
30733 end Is_Elaboration_SPARK_Mode;
30735 -----------------------
30736 -- Is_Enabled_Pragma --
30737 -----------------------
30739 function Is_Enabled_Pragma (Prag : Node_Id) return Boolean is
30743 if Present (Prag) then
30744 Arg := First (Pragma_Argument_Associations (Prag));
30746 if Present (Arg) then
30747 return Is_True (Expr_Value (Get_Pragma_Arg (Arg)));
30749 -- The lack of a Boolean argument automatically enables the pragma
30755 -- The pragma is missing, therefore it is not enabled
30760 end Is_Enabled_Pragma;
30762 -----------------------------------------
30763 -- Is_Non_Significant_Pragma_Reference --
30764 -----------------------------------------
30766 -- This function makes use of the following static table which indicates
30767 -- whether appearance of some name in a given pragma is to be considered
30768 -- as a reference for the purposes of warnings about unreferenced objects.
30770 -- -1 indicates that appearence in any argument is significant
30771 -- 0 indicates that appearance in any argument is not significant
30772 -- +n indicates that appearance as argument n is significant, but all
30773 -- other arguments are not significant
30774 -- 9n arguments from n on are significant, before n insignificant
30776 Sig_Flags : constant array (Pragma_Id) of Int :=
30777 (Pragma_Abort_Defer => -1,
30778 Pragma_Abstract_State => -1,
30779 Pragma_Ada_83 => -1,
30780 Pragma_Ada_95 => -1,
30781 Pragma_Ada_05 => -1,
30782 Pragma_Ada_2005 => -1,
30783 Pragma_Ada_12 => -1,
30784 Pragma_Ada_2012 => -1,
30785 Pragma_Ada_2020 => -1,
30786 Pragma_Aggregate_Individually_Assign => 0,
30787 Pragma_All_Calls_Remote => -1,
30788 Pragma_Allow_Integer_Address => -1,
30789 Pragma_Annotate => 93,
30790 Pragma_Assert => -1,
30791 Pragma_Assert_And_Cut => -1,
30792 Pragma_Assertion_Policy => 0,
30793 Pragma_Assume => -1,
30794 Pragma_Assume_No_Invalid_Values => 0,
30795 Pragma_Async_Readers => 0,
30796 Pragma_Async_Writers => 0,
30797 Pragma_Asynchronous => 0,
30798 Pragma_Atomic => 0,
30799 Pragma_Atomic_Components => 0,
30800 Pragma_Attach_Handler => -1,
30801 Pragma_Attribute_Definition => 92,
30802 Pragma_Check => -1,
30803 Pragma_Check_Float_Overflow => 0,
30804 Pragma_Check_Name => 0,
30805 Pragma_Check_Policy => 0,
30806 Pragma_CPP_Class => 0,
30807 Pragma_CPP_Constructor => 0,
30808 Pragma_CPP_Virtual => 0,
30809 Pragma_CPP_Vtable => 0,
30811 Pragma_C_Pass_By_Copy => 0,
30812 Pragma_Comment => -1,
30813 Pragma_Common_Object => 0,
30814 Pragma_CUDA_Execute => -1,
30815 Pragma_CUDA_Global => -1,
30816 Pragma_Compile_Time_Error => -1,
30817 Pragma_Compile_Time_Warning => -1,
30818 Pragma_Compiler_Unit => -1,
30819 Pragma_Compiler_Unit_Warning => -1,
30820 Pragma_Complete_Representation => 0,
30821 Pragma_Complex_Representation => 0,
30822 Pragma_Component_Alignment => 0,
30823 Pragma_Constant_After_Elaboration => 0,
30824 Pragma_Contract_Cases => -1,
30825 Pragma_Controlled => 0,
30826 Pragma_Convention => 0,
30827 Pragma_Convention_Identifier => 0,
30828 Pragma_Deadline_Floor => -1,
30829 Pragma_Debug => -1,
30830 Pragma_Debug_Policy => 0,
30831 Pragma_Default_Initial_Condition => -1,
30832 Pragma_Default_Scalar_Storage_Order => 0,
30833 Pragma_Default_Storage_Pool => 0,
30834 Pragma_Depends => -1,
30835 Pragma_Detect_Blocking => 0,
30836 Pragma_Disable_Atomic_Synchronization => 0,
30837 Pragma_Discard_Names => 0,
30838 Pragma_Dispatching_Domain => -1,
30839 Pragma_Effective_Reads => 0,
30840 Pragma_Effective_Writes => 0,
30841 Pragma_Elaborate => 0,
30842 Pragma_Elaborate_All => 0,
30843 Pragma_Elaborate_Body => 0,
30844 Pragma_Elaboration_Checks => 0,
30845 Pragma_Eliminate => 0,
30846 Pragma_Enable_Atomic_Synchronization => 0,
30847 Pragma_Export => -1,
30848 Pragma_Export_Function => -1,
30849 Pragma_Export_Object => -1,
30850 Pragma_Export_Procedure => -1,
30851 Pragma_Export_Value => -1,
30852 Pragma_Export_Valued_Procedure => -1,
30853 Pragma_Extend_System => -1,
30854 Pragma_Extensions_Allowed => 0,
30855 Pragma_Extensions_Visible => 0,
30856 Pragma_External => -1,
30857 Pragma_External_Name_Casing => 0,
30858 Pragma_Fast_Math => 0,
30859 Pragma_Favor_Top_Level => 0,
30860 Pragma_Finalize_Storage_Only => 0,
30862 Pragma_Global => -1,
30863 Pragma_Ident => -1,
30864 Pragma_Ignore_Pragma => 0,
30865 Pragma_Implementation_Defined => -1,
30866 Pragma_Implemented => -1,
30867 Pragma_Implicit_Packing => 0,
30868 Pragma_Import => 93,
30869 Pragma_Import_Function => 0,
30870 Pragma_Import_Object => 0,
30871 Pragma_Import_Procedure => 0,
30872 Pragma_Import_Valued_Procedure => 0,
30873 Pragma_Independent => 0,
30874 Pragma_Independent_Components => 0,
30875 Pragma_Initial_Condition => -1,
30876 Pragma_Initialize_Scalars => 0,
30877 Pragma_Initializes => -1,
30878 Pragma_Inline => 0,
30879 Pragma_Inline_Always => 0,
30880 Pragma_Inline_Generic => 0,
30881 Pragma_Inspection_Point => -1,
30882 Pragma_Interface => 92,
30883 Pragma_Interface_Name => 0,
30884 Pragma_Interrupt_Handler => -1,
30885 Pragma_Interrupt_Priority => -1,
30886 Pragma_Interrupt_State => -1,
30887 Pragma_Invariant => -1,
30888 Pragma_Keep_Names => 0,
30889 Pragma_License => 0,
30890 Pragma_Link_With => -1,
30891 Pragma_Linker_Alias => -1,
30892 Pragma_Linker_Constructor => -1,
30893 Pragma_Linker_Destructor => -1,
30894 Pragma_Linker_Options => -1,
30895 Pragma_Linker_Section => -1,
30897 Pragma_Lock_Free => 0,
30898 Pragma_Locking_Policy => 0,
30899 Pragma_Loop_Invariant => -1,
30900 Pragma_Loop_Optimize => 0,
30901 Pragma_Loop_Variant => -1,
30902 Pragma_Machine_Attribute => -1,
30904 Pragma_Main_Storage => -1,
30905 Pragma_Max_Entry_Queue_Depth => 0,
30906 Pragma_Max_Entry_Queue_Length => 0,
30907 Pragma_Max_Queue_Length => 0,
30908 Pragma_Memory_Size => 0,
30909 Pragma_No_Body => 0,
30910 Pragma_No_Caching => 0,
30911 Pragma_No_Component_Reordering => -1,
30912 Pragma_No_Elaboration_Code_All => 0,
30913 Pragma_No_Heap_Finalization => 0,
30914 Pragma_No_Inline => 0,
30915 Pragma_No_Return => 0,
30916 Pragma_No_Run_Time => -1,
30917 Pragma_No_Strict_Aliasing => -1,
30918 Pragma_No_Tagged_Streams => 0,
30919 Pragma_Normalize_Scalars => 0,
30920 Pragma_Obsolescent => 0,
30921 Pragma_Optimize => 0,
30922 Pragma_Optimize_Alignment => 0,
30923 Pragma_Ordered => 0,
30924 Pragma_Overflow_Mode => 0,
30925 Pragma_Overriding_Renamings => 0,
30928 Pragma_Part_Of => 0,
30929 Pragma_Partition_Elaboration_Policy => 0,
30930 Pragma_Passive => 0,
30931 Pragma_Persistent_BSS => 0,
30933 Pragma_Postcondition => -1,
30934 Pragma_Post_Class => -1,
30936 Pragma_Precondition => -1,
30937 Pragma_Predicate => -1,
30938 Pragma_Predicate_Failure => -1,
30939 Pragma_Preelaborable_Initialization => -1,
30940 Pragma_Preelaborate => 0,
30941 Pragma_Prefix_Exception_Messages => 0,
30942 Pragma_Pre_Class => -1,
30943 Pragma_Priority => -1,
30944 Pragma_Priority_Specific_Dispatching => 0,
30945 Pragma_Profile => 0,
30946 Pragma_Profile_Warnings => 0,
30947 Pragma_Propagate_Exceptions => 0,
30948 Pragma_Provide_Shift_Operators => 0,
30949 Pragma_Psect_Object => 0,
30951 Pragma_Pure_Function => 0,
30952 Pragma_Queuing_Policy => 0,
30953 Pragma_Rational => 0,
30954 Pragma_Ravenscar => 0,
30955 Pragma_Refined_Depends => -1,
30956 Pragma_Refined_Global => -1,
30957 Pragma_Refined_Post => -1,
30958 Pragma_Refined_State => -1,
30959 Pragma_Relative_Deadline => 0,
30960 Pragma_Remote_Access_Type => -1,
30961 Pragma_Remote_Call_Interface => -1,
30962 Pragma_Remote_Types => -1,
30963 Pragma_Rename_Pragma => 0,
30964 Pragma_Restricted_Run_Time => 0,
30965 Pragma_Restriction_Warnings => 0,
30966 Pragma_Restrictions => 0,
30967 Pragma_Reviewable => -1,
30968 Pragma_Secondary_Stack_Size => -1,
30969 Pragma_Share_Generic => 0,
30970 Pragma_Shared => 0,
30971 Pragma_Shared_Passive => 0,
30972 Pragma_Short_Circuit_And_Or => 0,
30973 Pragma_Short_Descriptors => 0,
30974 Pragma_Simple_Storage_Pool_Type => 0,
30975 Pragma_Source_File_Name => 0,
30976 Pragma_Source_File_Name_Project => 0,
30977 Pragma_Source_Reference => 0,
30978 Pragma_SPARK_Mode => 0,
30979 Pragma_Static_Elaboration_Desired => 0,
30980 Pragma_Storage_Size => -1,
30981 Pragma_Storage_Unit => 0,
30982 Pragma_Stream_Convert => 0,
30983 Pragma_Style_Checks => 0,
30984 Pragma_Subtitle => 0,
30985 Pragma_Suppress => 0,
30986 Pragma_Suppress_All => 0,
30987 Pragma_Suppress_Debug_Info => 0,
30988 Pragma_Suppress_Exception_Locations => 0,
30989 Pragma_Suppress_Initialization => 0,
30990 Pragma_System_Name => 0,
30991 Pragma_Task_Dispatching_Policy => 0,
30992 Pragma_Task_Info => -1,
30993 Pragma_Task_Name => -1,
30994 Pragma_Task_Storage => -1,
30995 Pragma_Test_Case => -1,
30996 Pragma_Thread_Local_Storage => -1,
30997 Pragma_Time_Slice => -1,
30999 Pragma_Type_Invariant => -1,
31000 Pragma_Type_Invariant_Class => -1,
31001 Pragma_Unchecked_Union => 0,
31002 Pragma_Unevaluated_Use_Of_Old => 0,
31003 Pragma_Unimplemented_Unit => 0,
31004 Pragma_Universal_Aliasing => 0,
31005 Pragma_Universal_Data => 0,
31006 Pragma_Unmodified => 0,
31007 Pragma_Unreferenced => 0,
31008 Pragma_Unreferenced_Objects => 0,
31009 Pragma_Unreserve_All_Interrupts => 0,
31010 Pragma_Unsuppress => 0,
31011 Pragma_Unused => 0,
31012 Pragma_Use_VADS_Size => 0,
31013 Pragma_Validity_Checks => 0,
31014 Pragma_Volatile => 0,
31015 Pragma_Volatile_Components => 0,
31016 Pragma_Volatile_Full_Access => 0,
31017 Pragma_Volatile_Function => 0,
31018 Pragma_Warning_As_Error => 0,
31019 Pragma_Warnings => 0,
31020 Pragma_Weak_External => 0,
31021 Pragma_Wide_Character_Encoding => 0,
31022 Unknown_Pragma => 0);
31024 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
31030 function Arg_No return Nat;
31031 -- Returns an integer showing what argument we are in. A value of
31032 -- zero means we are not in any of the arguments.
31038 function Arg_No return Nat is
31043 A := First (Pragma_Argument_Associations (Parent (P)));
31057 -- Start of processing for Non_Significant_Pragma_Reference
31062 if Nkind (P) /= N_Pragma_Argument_Association then
31066 Id := Get_Pragma_Id (Parent (P));
31067 C := Sig_Flags (Id);
31082 return AN < (C - 90);
31088 end Is_Non_Significant_Pragma_Reference;
31090 ------------------------------
31091 -- Is_Pragma_String_Literal --
31092 ------------------------------
31094 -- This function returns true if the corresponding pragma argument is a
31095 -- static string expression. These are the only cases in which string
31096 -- literals can appear as pragma arguments. We also allow a string literal
31097 -- as the first argument to pragma Assert (although it will of course
31098 -- always generate a type error).
31100 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
31101 Pragn : constant Node_Id := Parent (Par);
31102 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
31103 Pname : constant Name_Id := Pragma_Name (Pragn);
31109 N := First (Assoc);
31116 if Pname = Name_Assert then
31119 elsif Pname = Name_Export then
31122 elsif Pname = Name_Ident then
31125 elsif Pname = Name_Import then
31128 elsif Pname = Name_Interface_Name then
31131 elsif Pname = Name_Linker_Alias then
31134 elsif Pname = Name_Linker_Section then
31137 elsif Pname = Name_Machine_Attribute then
31140 elsif Pname = Name_Source_File_Name then
31143 elsif Pname = Name_Source_Reference then
31146 elsif Pname = Name_Title then
31149 elsif Pname = Name_Subtitle then
31155 end Is_Pragma_String_Literal;
31157 ---------------------------
31158 -- Is_Private_SPARK_Mode --
31159 ---------------------------
31161 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is
31164 (Nkind (N) = N_Pragma
31165 and then Pragma_Name (N) = Name_SPARK_Mode
31166 and then Is_List_Member (N));
31168 -- For pragma SPARK_Mode to be private, it has to appear in the private
31169 -- declarations of a package.
31172 Present (Parent (N))
31173 and then Nkind (Parent (N)) = N_Package_Specification
31174 and then List_Containing (N) = Private_Declarations (Parent (N));
31175 end Is_Private_SPARK_Mode;
31177 -------------------------------------
31178 -- Is_Unconstrained_Or_Tagged_Item --
31179 -------------------------------------
31181 function Is_Unconstrained_Or_Tagged_Item
31182 (Item : Entity_Id) return Boolean
31184 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean;
31185 -- Determine whether record type Typ has at least one unconstrained
31188 ---------------------------------
31189 -- Has_Unconstrained_Component --
31190 ---------------------------------
31192 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is
31196 Comp := First_Component (Typ);
31197 while Present (Comp) loop
31198 if Is_Unconstrained_Or_Tagged_Item (Comp) then
31202 Next_Component (Comp);
31206 end Has_Unconstrained_Component;
31210 Typ : constant Entity_Id := Etype (Item);
31212 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
31215 if Is_Tagged_Type (Typ) then
31218 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
31221 elsif Is_Record_Type (Typ) then
31222 if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then
31225 return Has_Unconstrained_Component (Typ);
31228 elsif Is_Private_Type (Typ) and then Has_Discriminants (Typ) then
31234 end Is_Unconstrained_Or_Tagged_Item;
31236 -----------------------------
31237 -- Is_Valid_Assertion_Kind --
31238 -----------------------------
31240 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is
31247 | Name_Assertion_Policy
31248 | Name_Static_Predicate
31249 | Name_Dynamic_Predicate
31254 | Name_Type_Invariant
31255 | Name_uType_Invariant
31259 | Name_Assert_And_Cut
31261 | Name_Contract_Cases
31263 | Name_Default_Initial_Condition
31265 | Name_Initial_Condition
31268 | Name_Loop_Invariant
31269 | Name_Loop_Variant
31270 | Name_Postcondition
31271 | Name_Precondition
31273 | Name_Refined_Post
31274 | Name_Statement_Assertions
31281 end Is_Valid_Assertion_Kind;
31283 --------------------------------------
31284 -- Process_Compilation_Unit_Pragmas --
31285 --------------------------------------
31287 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
31289 -- A special check for pragma Suppress_All, a very strange DEC pragma,
31290 -- strange because it comes at the end of the unit. Rational has the
31291 -- same name for a pragma, but treats it as a program unit pragma, In
31292 -- GNAT we just decide to allow it anywhere at all. If it appeared then
31293 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
31294 -- node, and we insert a pragma Suppress (All_Checks) at the start of
31295 -- the context clause to ensure the correct processing.
31297 if Has_Pragma_Suppress_All (N) then
31298 Prepend_To (Context_Items (N),
31299 Make_Pragma (Sloc (N),
31300 Chars => Name_Suppress,
31301 Pragma_Argument_Associations => New_List (
31302 Make_Pragma_Argument_Association (Sloc (N),
31303 Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
31306 -- Nothing else to do at the current time
31308 end Process_Compilation_Unit_Pragmas;
31310 --------------------------------------------
31311 -- Validate_Compile_Time_Warning_Or_Error --
31312 --------------------------------------------
31314 procedure Validate_Compile_Time_Warning_Or_Error
31318 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
31319 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
31320 Arg2 : constant Node_Id := Next (Arg1);
31322 Pname : constant Name_Id := Pragma_Name_Unmapped (N);
31323 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
31326 Analyze_And_Resolve (Arg1x, Standard_Boolean);
31328 if Compile_Time_Known_Value (Arg1x) then
31329 if Is_True (Expr_Value (Arg1x)) then
31331 -- We have already verified that the second argument is a static
31332 -- string expression. Its string value must be retrieved
31333 -- explicitly if it is a declared constant, otherwise it has
31334 -- been constant-folded previously.
31337 Cent : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
31338 Str : constant String_Id :=
31339 Strval (Expr_Value_S (Get_Pragma_Arg (Arg2)));
31340 Str_Len : constant Nat := String_Length (Str);
31342 Force : constant Boolean :=
31343 Prag_Id = Pragma_Compile_Time_Warning
31344 and then Is_Spec_Name (Unit_Name (Current_Sem_Unit))
31345 and then (Ekind (Cent) /= E_Package
31346 or else not In_Private_Part (Cent));
31347 -- Set True if this is the warning case, and we are in the
31348 -- visible part of a package spec, or in a subprogram spec,
31349 -- in which case we want to force the client to see the
31350 -- warning, even though it is not in the main unit.
31358 -- Loop through segments of message separated by line feeds.
31359 -- We output these segments as separate messages with
31360 -- continuation marks for all but the first.
31365 Error_Msg_Strlen := 0;
31367 -- Loop to copy characters from argument to error message
31371 exit when Ptr > Str_Len;
31372 CC := Get_String_Char (Str, Ptr);
31375 -- Ignore wide chars ??? else store character
31377 if In_Character_Range (CC) then
31378 C := Get_Character (CC);
31379 exit when C = ASCII.LF;
31380 Error_Msg_Strlen := Error_Msg_Strlen + 1;
31381 Error_Msg_String (Error_Msg_Strlen) := C;
31385 -- Here with one line ready to go
31387 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
31389 -- If this is a warning in a spec, then we want clients
31390 -- to see the warning, so mark the message with the
31391 -- special sequence !! to force the warning. In the case
31392 -- of a package spec, we do not force this if we are in
31393 -- the private part of the spec.
31396 if Cont = False then
31398 ("<<~!!", Eloc, Is_Compile_Time_Pragma => True);
31402 ("\<<~!!", Eloc, Is_Compile_Time_Pragma => True);
31405 -- Error, rather than warning, or in a body, so we do not
31406 -- need to force visibility for client (error will be
31407 -- output in any case, and this is the situation in which
31408 -- we do not want a client to get a warning, since the
31409 -- warning is in the body or the spec private part).
31412 if Cont = False then
31414 ("<<~", Eloc, Is_Compile_Time_Pragma => True);
31418 ("\<<~", Eloc, Is_Compile_Time_Pragma => True);
31422 exit when Ptr > Str_Len;
31427 -- Arg1x is not known at compile time, so possibly issue an error
31428 -- or warning. This can happen only if the pragma's processing
31429 -- was deferred until after the back end is run (see
31430 -- Process_Compile_Time_Warning_Or_Error). Note that the warning
31431 -- control switch applies to only the warning case.
31433 elsif Prag_Id = Pragma_Compile_Time_Error then
31434 Error_Msg_N ("condition is not known at compile time", Arg1x);
31436 elsif Warn_On_Unknown_Compile_Time_Warning then
31437 Error_Msg_N ("??condition is not known at compile time", Arg1x);
31439 end Validate_Compile_Time_Warning_Or_Error;
31441 ------------------------------------
31442 -- Record_Possible_Body_Reference --
31443 ------------------------------------
31445 procedure Record_Possible_Body_Reference
31446 (State_Id : Entity_Id;
31450 Spec_Id : Entity_Id;
31453 -- Ensure that we are dealing with a reference to a state
31455 pragma Assert (Ekind (State_Id) = E_Abstract_State);
31457 -- Climb the tree starting from the reference looking for a package body
31458 -- whose spec declares the referenced state. This criteria automatically
31459 -- excludes references in package specs which are legal. Note that it is
31460 -- not wise to emit an error now as the package body may lack pragma
31461 -- Refined_State or the referenced state may not be mentioned in the
31462 -- refinement. This approach avoids the generation of misleading errors.
31465 while Present (Context) loop
31466 if Nkind (Context) = N_Package_Body then
31467 Spec_Id := Corresponding_Spec (Context);
31469 if Present (Abstract_States (Spec_Id))
31470 and then Contains (Abstract_States (Spec_Id), State_Id)
31472 if No (Body_References (State_Id)) then
31473 Set_Body_References (State_Id, New_Elmt_List);
31476 Append_Elmt (Ref, To => Body_References (State_Id));
31481 Context := Parent (Context);
31483 end Record_Possible_Body_Reference;
31485 ------------------------------------------
31486 -- Relocate_Pragmas_To_Anonymous_Object --
31487 ------------------------------------------
31489 procedure Relocate_Pragmas_To_Anonymous_Object
31490 (Typ_Decl : Node_Id;
31491 Obj_Decl : Node_Id)
31495 Next_Decl : Node_Id;
31498 if Nkind (Typ_Decl) = N_Protected_Type_Declaration then
31499 Def := Protected_Definition (Typ_Decl);
31501 pragma Assert (Nkind (Typ_Decl) = N_Task_Type_Declaration);
31502 Def := Task_Definition (Typ_Decl);
31505 -- The concurrent definition has a visible declaration list. Inspect it
31506 -- and relocate all canidate pragmas.
31508 if Present (Def) and then Present (Visible_Declarations (Def)) then
31509 Decl := First (Visible_Declarations (Def));
31510 while Present (Decl) loop
31512 -- Preserve the following declaration for iteration purposes due
31513 -- to possible relocation of a pragma.
31515 Next_Decl := Next (Decl);
31517 if Nkind (Decl) = N_Pragma
31518 and then Pragma_On_Anonymous_Object_OK (Get_Pragma_Id (Decl))
31521 Insert_After (Obj_Decl, Decl);
31523 -- Skip internally generated code
31525 elsif not Comes_From_Source (Decl) then
31528 -- No candidate pragmas are available for relocation
31537 end Relocate_Pragmas_To_Anonymous_Object;
31539 ------------------------------
31540 -- Relocate_Pragmas_To_Body --
31541 ------------------------------
31543 procedure Relocate_Pragmas_To_Body
31544 (Subp_Body : Node_Id;
31545 Target_Body : Node_Id := Empty)
31547 procedure Relocate_Pragma (Prag : Node_Id);
31548 -- Remove a single pragma from its current list and add it to the
31549 -- declarations of the proper body (either Subp_Body or Target_Body).
31551 ---------------------
31552 -- Relocate_Pragma --
31553 ---------------------
31555 procedure Relocate_Pragma (Prag : Node_Id) is
31560 -- When subprogram stubs or expression functions are involves, the
31561 -- destination declaration list belongs to the proper body.
31563 if Present (Target_Body) then
31564 Target := Target_Body;
31566 Target := Subp_Body;
31569 Decls := Declarations (Target);
31573 Set_Declarations (Target, Decls);
31576 -- Unhook the pragma from its current list
31579 Prepend (Prag, Decls);
31580 end Relocate_Pragma;
31584 Body_Id : constant Entity_Id :=
31585 Defining_Unit_Name (Specification (Subp_Body));
31586 Next_Stmt : Node_Id;
31589 -- Start of processing for Relocate_Pragmas_To_Body
31592 -- Do not process a body that comes from a separate unit as no construct
31593 -- can possibly follow it.
31595 if not Is_List_Member (Subp_Body) then
31598 -- Do not relocate pragmas that follow a stub if the stub does not have
31601 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub
31602 and then No (Target_Body)
31606 -- Do not process internally generated routine _Postconditions
31608 elsif Ekind (Body_Id) = E_Procedure
31609 and then Chars (Body_Id) = Name_uPostconditions
31614 -- Look at what is following the body. We are interested in certain kind
31615 -- of pragmas (either from source or byproducts of expansion) that can
31616 -- apply to a body [stub].
31618 Stmt := Next (Subp_Body);
31619 while Present (Stmt) loop
31621 -- Preserve the following statement for iteration purposes due to a
31622 -- possible relocation of a pragma.
31624 Next_Stmt := Next (Stmt);
31626 -- Move a candidate pragma following the body to the declarations of
31629 if Nkind (Stmt) = N_Pragma
31630 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt))
31633 -- If a source pragma Warnings follows the body, it applies to
31634 -- following statements and does not belong in the body.
31636 if Get_Pragma_Id (Stmt) = Pragma_Warnings
31637 and then Comes_From_Source (Stmt)
31641 Relocate_Pragma (Stmt);
31644 -- Skip internally generated code
31646 elsif not Comes_From_Source (Stmt) then
31649 -- No candidate pragmas are available for relocation
31657 end Relocate_Pragmas_To_Body;
31659 -------------------
31660 -- Resolve_State --
31661 -------------------
31663 procedure Resolve_State (N : Node_Id) is
31668 if Is_Entity_Name (N) and then Present (Entity (N)) then
31669 Func := Entity (N);
31671 -- Handle overloading of state names by functions. Traverse the
31672 -- homonym chain looking for an abstract state.
31674 if Ekind (Func) = E_Function and then Has_Homonym (Func) then
31675 pragma Assert (Is_Overloaded (N));
31677 State := Homonym (Func);
31678 while Present (State) loop
31679 if Ekind (State) = E_Abstract_State then
31681 -- Resolve the overloading by setting the proper entity of
31682 -- the reference to that of the state.
31684 Set_Etype (N, Standard_Void_Type);
31685 Set_Entity (N, State);
31686 Set_Is_Overloaded (N, False);
31688 Generate_Reference (State, N);
31692 State := Homonym (State);
31695 -- A function can never act as a state. If the homonym chain does
31696 -- not contain a corresponding state, then something went wrong in
31697 -- the overloading mechanism.
31699 raise Program_Error;
31704 ----------------------------
31705 -- Rewrite_Assertion_Kind --
31706 ----------------------------
31708 procedure Rewrite_Assertion_Kind
31710 From_Policy : Boolean := False)
31716 if Nkind (N) = N_Attribute_Reference
31717 and then Attribute_Name (N) = Name_Class
31718 and then Nkind (Prefix (N)) = N_Identifier
31720 case Chars (Prefix (N)) is
31727 when Name_Type_Invariant =>
31728 Nam := Name_uType_Invariant;
31730 when Name_Invariant =>
31731 Nam := Name_uInvariant;
31737 -- Recommend standard use of aspect names Pre/Post
31739 elsif Nkind (N) = N_Identifier
31740 and then From_Policy
31741 and then Serious_Errors_Detected = 0
31743 if Chars (N) = Name_Precondition
31744 or else Chars (N) = Name_Postcondition
31746 Error_Msg_N ("Check_Policy is a non-standard pragma??", N);
31748 ("\use Assertion_Policy and aspect names Pre/Post for "
31749 & "Ada2012 conformance?", N);
31755 if Nam /= No_Name then
31756 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam));
31758 end Rewrite_Assertion_Kind;
31766 Dummy := Dummy + 1;
31769 --------------------------------
31770 -- Set_Encoded_Interface_Name --
31771 --------------------------------
31773 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
31774 Str : constant String_Id := Strval (S);
31775 Len : constant Nat := String_Length (Str);
31780 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
31783 -- Stores encoded value of character code CC. The encoding we use an
31784 -- underscore followed by four lower case hex digits.
31790 procedure Encode is
31792 Store_String_Char (Get_Char_Code ('_'));
31794 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
31796 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
31798 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
31800 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
31803 -- Start of processing for Set_Encoded_Interface_Name
31806 -- If first character is asterisk, this is a link name, and we leave it
31807 -- completely unmodified. We also ignore null strings (the latter case
31808 -- happens only in error cases).
31811 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
31813 Set_Interface_Name (E, S);
31818 CC := Get_String_Char (Str, J);
31820 exit when not In_Character_Range (CC);
31822 C := Get_Character (CC);
31824 exit when C /= '_' and then C /= '$'
31825 and then C not in '0' .. '9'
31826 and then C not in 'a' .. 'z'
31827 and then C not in 'A' .. 'Z';
31830 Set_Interface_Name (E, S);
31838 -- Here we need to encode. The encoding we use as follows:
31839 -- three underscores + four hex digits (lower case)
31843 for J in 1 .. String_Length (Str) loop
31844 CC := Get_String_Char (Str, J);
31846 if not In_Character_Range (CC) then
31849 C := Get_Character (CC);
31851 if C = '_' or else C = '$'
31852 or else C in '0' .. '9'
31853 or else C in 'a' .. 'z'
31854 or else C in 'A' .. 'Z'
31856 Store_String_Char (CC);
31863 Set_Interface_Name (E,
31864 Make_String_Literal (Sloc (S),
31865 Strval => End_String));
31867 end Set_Encoded_Interface_Name;
31869 ------------------------
31870 -- Set_Elab_Unit_Name --
31871 ------------------------
31873 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id) is
31878 if Nkind (N) = N_Identifier
31879 and then Nkind (With_Item) = N_Identifier
31881 Set_Entity (N, Entity (With_Item));
31883 elsif Nkind (N) = N_Selected_Component then
31884 Change_Selected_Component_To_Expanded_Name (N);
31885 Set_Entity (N, Entity (With_Item));
31886 Set_Entity (Selector_Name (N), Entity (N));
31888 Pref := Prefix (N);
31889 Scop := Scope (Entity (N));
31890 while Nkind (Pref) = N_Selected_Component loop
31891 Change_Selected_Component_To_Expanded_Name (Pref);
31892 Set_Entity (Selector_Name (Pref), Scop);
31893 Set_Entity (Pref, Scop);
31894 Pref := Prefix (Pref);
31895 Scop := Scope (Scop);
31898 Set_Entity (Pref, Scop);
31901 Generate_Reference (Entity (With_Item), N, Set_Ref => False);
31902 end Set_Elab_Unit_Name;
31904 -----------------------
31905 -- Set_Overflow_Mode --
31906 -----------------------
31908 procedure Set_Overflow_Mode (N : Node_Id) is
31910 function Get_Overflow_Mode (Arg : Node_Id) return Overflow_Mode_Type;
31911 -- Function to process one pragma argument, Arg
31913 -----------------------
31914 -- Get_Overflow_Mode --
31915 -----------------------
31917 function Get_Overflow_Mode (Arg : Node_Id) return Overflow_Mode_Type is
31918 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
31921 if Chars (Argx) = Name_Strict then
31924 elsif Chars (Argx) = Name_Minimized then
31927 elsif Chars (Argx) = Name_Eliminated then
31931 raise Program_Error;
31933 end Get_Overflow_Mode;
31937 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
31938 Arg2 : constant Node_Id := Next (Arg1);
31940 -- Start of processing for Set_Overflow_Mode
31943 -- Process first argument
31945 Scope_Suppress.Overflow_Mode_General :=
31946 Get_Overflow_Mode (Arg1);
31948 -- Case of only one argument
31951 Scope_Suppress.Overflow_Mode_Assertions :=
31952 Scope_Suppress.Overflow_Mode_General;
31954 -- Case of two arguments present
31957 Scope_Suppress.Overflow_Mode_Assertions :=
31958 Get_Overflow_Mode (Arg2);
31960 end Set_Overflow_Mode;
31962 -------------------
31963 -- Test_Case_Arg --
31964 -------------------
31966 function Test_Case_Arg
31969 From_Aspect : Boolean := False) return Node_Id
31971 Aspect : constant Node_Id := Corresponding_Aspect (Prag);
31977 (Arg_Nam in Name_Ensures | Name_Mode | Name_Name | Name_Requires);
31979 -- The caller requests the aspect argument
31981 if From_Aspect then
31982 if Present (Aspect)
31983 and then Nkind (Expression (Aspect)) = N_Aggregate
31985 Args := Expression (Aspect);
31987 -- "Name" and "Mode" may appear without an identifier as a
31988 -- positional association.
31990 if Present (Expressions (Args)) then
31991 Arg := First (Expressions (Args));
31993 if Present (Arg) and then Arg_Nam = Name_Name then
32001 if Present (Arg) and then Arg_Nam = Name_Mode then
32006 -- Some or all arguments may appear as component associatons
32008 if Present (Component_Associations (Args)) then
32009 Arg := First (Component_Associations (Args));
32010 while Present (Arg) loop
32011 if Chars (First (Choices (Arg))) = Arg_Nam then
32020 -- Otherwise retrieve the argument directly from the pragma
32023 Arg := First (Pragma_Argument_Associations (Prag));
32025 if Present (Arg) and then Arg_Nam = Name_Name then
32029 -- Skip argument "Name"
32033 if Present (Arg) and then Arg_Nam = Name_Mode then
32037 -- Skip argument "Mode"
32041 -- Arguments "Requires" and "Ensures" are optional and may not be
32044 while Present (Arg) loop
32045 if Chars (Arg) = Arg_Nam then
32056 --------------------------------------------
32057 -- Defer_Compile_Time_Warning_Error_To_BE --
32058 --------------------------------------------
32060 procedure Defer_Compile_Time_Warning_Error_To_BE (N : Node_Id) is
32061 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
32063 Compile_Time_Warnings_Errors.Append
32064 (New_Val => CTWE_Entry'(Eloc => Sloc (Arg1),
32065 Scope => Current_Scope,
32068 -- If the Boolean expression contains T'Size, and we're not in the main
32069 -- unit being compiled, then we need to copy the pragma into the main
32070 -- unit, because otherwise T'Size might never be computed, leaving it
32073 if not In_Extended_Main_Code_Unit (N) then
32074 Insert_Library_Level_Action (New_Copy_Tree (N));
32076 end Defer_Compile_Time_Warning_Error_To_BE;
32078 ------------------------------------------
32079 -- Validate_Compile_Time_Warning_Errors --
32080 ------------------------------------------
32082 procedure Validate_Compile_Time_Warning_Errors is
32083 procedure Set_Scope (S : Entity_Id);
32084 -- Install all enclosing scopes of S along with S itself
32086 procedure Unset_Scope (S : Entity_Id);
32087 -- Uninstall all enclosing scopes of S along with S itself
32093 procedure Set_Scope (S : Entity_Id) is
32095 if S /= Standard_Standard then
32096 Set_Scope (Scope (S));
32106 procedure Unset_Scope (S : Entity_Id) is
32108 if S /= Standard_Standard then
32109 Unset_Scope (Scope (S));
32115 -- Start of processing for Validate_Compile_Time_Warning_Errors
32118 Expander_Mode_Save_And_Set (False);
32119 In_Compile_Time_Warning_Or_Error := True;
32121 for N in Compile_Time_Warnings_Errors.First ..
32122 Compile_Time_Warnings_Errors.Last
32125 T : CTWE_Entry renames Compile_Time_Warnings_Errors.Table (N);
32128 Set_Scope (T.Scope);
32129 Reset_Analyzed_Flags (T.Prag);
32130 Validate_Compile_Time_Warning_Or_Error (T.Prag, T.Eloc);
32131 Unset_Scope (T.Scope);
32135 In_Compile_Time_Warning_Or_Error := False;
32136 Expander_Mode_Restore;
32137 end Validate_Compile_Time_Warning_Errors;