1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This unit contains the semantic processing for all pragmas, both language
27 -- and implementation defined. For most pragmas, the parser only does the
28 -- most basic job of checking the syntax, so Sem_Prag also contains the code
29 -- to complete the syntax checks. Certain pragmas are handled partially or
30 -- completely by the parser (see Par.Prag for further details).
32 with Aspects; use Aspects;
33 with Atree; use Atree;
34 with Casing; use Casing;
35 with Checks; use Checks;
36 with Contracts; use Contracts;
37 with Csets; use Csets;
38 with Debug; use Debug;
39 with Einfo; use Einfo;
40 with Elists; use Elists;
41 with Errout; use Errout;
42 with Exp_Dist; use Exp_Dist;
43 with Exp_Util; use Exp_Util;
44 with Expander; use Expander;
45 with Freeze; use Freeze;
46 with Ghost; use Ghost;
47 with Gnatvsn; use Gnatvsn;
49 with Lib.Writ; use Lib.Writ;
50 with Lib.Xref; use Lib.Xref;
51 with Namet.Sp; use Namet.Sp;
52 with Nlists; use Nlists;
53 with Nmake; use Nmake;
54 with Output; use Output;
55 with Par_SCO; use Par_SCO;
56 with Restrict; use Restrict;
57 with Rident; use Rident;
58 with Rtsfind; use Rtsfind;
60 with Sem_Aux; use Sem_Aux;
61 with Sem_Ch3; use Sem_Ch3;
62 with Sem_Ch6; use Sem_Ch6;
63 with Sem_Ch8; use Sem_Ch8;
64 with Sem_Ch12; use Sem_Ch12;
65 with Sem_Ch13; use Sem_Ch13;
66 with Sem_Disp; use Sem_Disp;
67 with Sem_Dist; use Sem_Dist;
68 with Sem_Elab; use Sem_Elab;
69 with Sem_Elim; use Sem_Elim;
70 with Sem_Eval; use Sem_Eval;
71 with Sem_Intr; use Sem_Intr;
72 with Sem_Mech; use Sem_Mech;
73 with Sem_Res; use Sem_Res;
74 with Sem_Type; use Sem_Type;
75 with Sem_Util; use Sem_Util;
76 with Sem_Warn; use Sem_Warn;
77 with Stand; use Stand;
78 with Sinfo; use Sinfo;
79 with Sinfo.CN; use Sinfo.CN;
80 with Sinput; use Sinput;
81 with Stringt; use Stringt;
82 with Stylesw; use Stylesw;
84 with Targparm; use Targparm;
85 with Tbuild; use Tbuild;
87 with Uintp; use Uintp;
88 with Uname; use Uname;
89 with Urealp; use Urealp;
90 with Validsw; use Validsw;
91 with Warnsw; use Warnsw;
93 with System.Case_Util;
95 package body Sem_Prag is
97 ----------------------------------------------
98 -- Common Handling of Import-Export Pragmas --
99 ----------------------------------------------
101 -- In the following section, a number of Import_xxx and Export_xxx pragmas
102 -- are defined by GNAT. These are compatible with the DEC pragmas of the
103 -- same name, and all have the following common form and processing:
106 -- [Internal =>] LOCAL_NAME
107 -- [, [External =>] EXTERNAL_SYMBOL]
108 -- [, other optional parameters ]);
111 -- [Internal =>] LOCAL_NAME
112 -- [, [External =>] EXTERNAL_SYMBOL]
113 -- [, other optional parameters ]);
115 -- EXTERNAL_SYMBOL ::=
117 -- | static_string_EXPRESSION
119 -- The internal LOCAL_NAME designates the entity that is imported or
120 -- exported, and must refer to an entity in the current declarative
121 -- part (as required by the rules for LOCAL_NAME).
123 -- The external linker name is designated by the External parameter if
124 -- given, or the Internal parameter if not (if there is no External
125 -- parameter, the External parameter is a copy of the Internal name).
127 -- If the External parameter is given as a string, then this string is
128 -- treated as an external name (exactly as though it had been given as an
129 -- External_Name parameter for a normal Import pragma).
131 -- If the External parameter is given as an identifier (or there is no
132 -- External parameter, so that the Internal identifier is used), then
133 -- the external name is the characters of the identifier, translated
134 -- to all lower case letters.
136 -- Note: the external name specified or implied by any of these special
137 -- Import_xxx or Export_xxx pragmas override an external or link name
138 -- specified in a previous Import or Export pragma.
140 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
141 -- named notation, following the standard rules for subprogram calls, i.e.
142 -- parameters can be given in any order if named notation is used, and
143 -- positional and named notation can be mixed, subject to the rule that all
144 -- positional parameters must appear first.
146 -- Note: All these pragmas are implemented exactly following the DEC design
147 -- and implementation and are intended to be fully compatible with the use
148 -- of these pragmas in the DEC Ada compiler.
150 --------------------------------------------
151 -- Checking for Duplicated External Names --
152 --------------------------------------------
154 -- It is suspicious if two separate Export pragmas use the same external
155 -- name. The following table is used to diagnose this situation so that
156 -- an appropriate warning can be issued.
158 -- The Node_Id stored is for the N_String_Literal node created to hold
159 -- the value of the external name. The Sloc of this node is used to
160 -- cross-reference the location of the duplication.
162 package Externals is new Table.Table (
163 Table_Component_Type => Node_Id,
164 Table_Index_Type => Int,
165 Table_Low_Bound => 0,
166 Table_Initial => 100,
167 Table_Increment => 100,
168 Table_Name => "Name_Externals");
170 -------------------------------------
171 -- Local Subprograms and Variables --
172 -------------------------------------
174 function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
175 -- This routine is used for possible casing adjustment of an explicit
176 -- external name supplied as a string literal (the node N), according to
177 -- the casing requirement of Opt.External_Name_Casing. If this is set to
178 -- As_Is, then the string literal is returned unchanged, but if it is set
179 -- to Uppercase or Lowercase, then a new string literal with appropriate
180 -- casing is constructed.
182 procedure Analyze_Part_Of
186 Encap_Id : out Entity_Id;
187 Legal : out Boolean);
188 -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and
189 -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the
190 -- Part_Of indicator. Item_Id is the entity of an abstract state, object or
191 -- package instantiation. Encap denotes the encapsulating state or single
192 -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when
193 -- the indicator is legal.
195 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean;
196 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
197 -- Query whether a particular item appears in a mixed list of nodes and
198 -- entities. It is assumed that all nodes in the list have entities.
200 procedure Check_Postcondition_Use_In_Inlined_Subprogram
202 Spec_Id : Entity_Id);
203 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
204 -- Precondition, Refined_Post, and Test_Case. Emit a warning when pragma
205 -- Prag is associated with subprogram Spec_Id subject to Inline_Always,
206 -- and assertions are enabled.
208 procedure Check_State_And_Constituent_Use
212 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
213 -- Global and Initializes. Determine whether a state from list States and a
214 -- corresponding constituent from list Constits (if any) appear in the same
215 -- context denoted by Context. If this is the case, emit an error.
217 procedure Contract_Freeze_Error
218 (Contract_Id : Entity_Id;
219 Freeze_Id : Entity_Id);
220 -- Subsidiary to the analysis of pragmas Contract_Cases, Part_Of, Post, and
221 -- Pre. Emit a freezing-related error message where Freeze_Id is the entity
222 -- of a body which caused contract freezing and Contract_Id denotes the
223 -- entity of the affected contstruct.
225 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id);
226 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
227 -- Prag that duplicates previous pragma Prev.
229 function Find_Encapsulating_State
231 Constit_Id : Entity_Id) return Entity_Id;
232 -- Given the entity of a constituent Constit_Id, find the corresponding
233 -- encapsulating state which appears in States. The routine returns Empty
234 -- if no such state is found.
236 function Find_Related_Context
238 Do_Checks : Boolean := False) return Node_Id;
239 -- Subsidiary to the analysis of pragmas
242 -- Constant_After_Elaboration
246 -- Find the first source declaration or statement found while traversing
247 -- the previous node chain starting from pragma Prag. If flag Do_Checks is
248 -- set, the routine reports duplicate pragmas. The routine returns Empty
249 -- when reaching the start of the node chain.
251 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
252 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
253 -- original one, following the renaming chain) is returned. Otherwise the
254 -- entity is returned unchanged. Should be in Einfo???
256 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type;
257 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
258 -- Get_SPARK_Mode_From_Annotation. Convert a name into a corresponding
259 -- value of type SPARK_Mode_Type.
261 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean;
262 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
263 -- Determine whether dependency clause Clause is surrounded by extra
264 -- parentheses. If this is the case, issue an error message.
266 function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean;
267 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
268 -- pragma Depends. Determine whether the type of dependency item Item is
269 -- tagged, unconstrained array, unconstrained record or a record with at
270 -- least one unconstrained component.
272 procedure Record_Possible_Body_Reference
273 (State_Id : Entity_Id;
275 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
276 -- Global. Given an abstract state denoted by State_Id and a reference Ref
277 -- to it, determine whether the reference appears in a package body that
278 -- will eventually refine the state. If this is the case, record the
279 -- reference for future checks (see Analyze_Refined_State_In_Decls).
281 procedure Resolve_State (N : Node_Id);
282 -- Handle the overloading of state names by functions. When N denotes a
283 -- function, this routine finds the corresponding state and sets the entity
284 -- of N to that of the state.
286 procedure Rewrite_Assertion_Kind
288 From_Policy : Boolean := False);
289 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
290 -- then it is rewritten as an identifier with the corresponding special
291 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
292 -- and Check_Policy. If the names are Precondition or Postcondition, this
293 -- combination is deprecated in favor of Assertion_Policy and Ada2012
294 -- Aspect names. The parameter From_Policy indicates that the pragma
295 -- is the old non-standard Check_Policy and not a rewritten pragma.
297 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id);
298 -- Place semantic information on the argument of an Elaborate/Elaborate_All
299 -- pragma. Entity name for unit and its parents is taken from item in
300 -- previous with_clause that mentions the unit.
302 procedure Validate_Compile_Time_Warning_Or_Error
305 -- Common processing for Compile_Time_Error and Compile_Time_Warning of
306 -- pragma N. Called when the pragma is processed as part of its regular
307 -- analysis but also called after calling the back end to validate these
308 -- pragmas for size and alignment appropriateness.
310 procedure Defer_Compile_Time_Warning_Error_To_BE (N : Node_Id);
311 -- N is a pragma Compile_Time_Error or Compile_Warning_Error whose boolean
312 -- expression is not known at compile time during the front end. This
313 -- procedure makes an entry in a table. The actual checking is performed by
314 -- Validate_Compile_Time_Warning_Errors, which is invoked after calling the
317 Dummy : Integer := 0;
318 pragma Volatile (Dummy);
319 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
322 pragma No_Inline (ip);
323 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
324 -- is just to help debugging the front end. If a pragma Inspection_Point
325 -- is added to a source program, then breaking on ip will get you to that
326 -- point in the program.
329 pragma No_Inline (rv);
330 -- This is a dummy function called by the processing for pragma Reviewable.
331 -- It is there for assisting front end debugging. By placing a Reviewable
332 -- pragma in the source program, a breakpoint on rv catches this place in
333 -- the source, allowing convenient stepping to the point of interest.
335 ------------------------------------------------------
336 -- Table for Defer_Compile_Time_Warning_Error_To_BE --
337 ------------------------------------------------------
339 -- The following table collects pragmas Compile_Time_Error and Compile_
340 -- Time_Warning for validation. Entries are made by calls to subprogram
341 -- Defer_Compile_Time_Warning_Error_To_BE, and the call to the procedure
342 -- Validate_Compile_Time_Warning_Errors does the actual error checking
343 -- and posting of warning and error messages. The reason for this delayed
344 -- processing is to take advantage of back-annotations of attributes size
345 -- and alignment values performed by the back end.
347 -- Note: the reason we store a Source_Ptr value instead of a Node_Id is
348 -- that by the time Validate_Compile_Time_Warning_Errors is called, Sprint
349 -- will already have modified all Sloc values if the -gnatD option is set.
351 type CTWE_Entry is record
353 -- Source location used in warnings and error messages
356 -- Pragma Compile_Time_Error or Compile_Time_Warning
359 -- The scope which encloses the pragma
362 package Compile_Time_Warnings_Errors is new Table.Table (
363 Table_Component_Type => CTWE_Entry,
364 Table_Index_Type => Int,
365 Table_Low_Bound => 1,
367 Table_Increment => 200,
368 Table_Name => "Compile_Time_Warnings_Errors");
370 -------------------------------
371 -- Adjust_External_Name_Case --
372 -------------------------------
374 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
378 -- Adjust case of literal if required
380 if Opt.External_Name_Exp_Casing = As_Is then
384 -- Copy existing string
390 for J in 1 .. String_Length (Strval (N)) loop
391 CC := Get_String_Char (Strval (N), J);
393 if Opt.External_Name_Exp_Casing = Uppercase
394 and then CC >= Get_Char_Code ('a')
395 and then CC <= Get_Char_Code ('z')
397 Store_String_Char (CC - 32);
399 elsif Opt.External_Name_Exp_Casing = Lowercase
400 and then CC >= Get_Char_Code ('A')
401 and then CC <= Get_Char_Code ('Z')
403 Store_String_Char (CC + 32);
406 Store_String_Char (CC);
411 Make_String_Literal (Sloc (N),
412 Strval => End_String);
414 end Adjust_External_Name_Case;
416 -----------------------------------------
417 -- Analyze_Contract_Cases_In_Decl_Part --
418 -----------------------------------------
420 -- WARNING: This routine manages Ghost regions. Return statements must be
421 -- replaced by gotos which jump to the end of the routine and restore the
424 procedure Analyze_Contract_Cases_In_Decl_Part
426 Freeze_Id : Entity_Id := Empty)
428 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
429 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
431 Others_Seen : Boolean := False;
432 -- This flag is set when an "others" choice is encountered. It is used
433 -- to detect multiple illegal occurrences of "others".
435 procedure Analyze_Contract_Case (CCase : Node_Id);
436 -- Verify the legality of a single contract case
438 ---------------------------
439 -- Analyze_Contract_Case --
440 ---------------------------
442 procedure Analyze_Contract_Case (CCase : Node_Id) is
443 Case_Guard : Node_Id;
446 Extra_Guard : Node_Id;
449 if Nkind (CCase) = N_Component_Association then
450 Case_Guard := First (Choices (CCase));
451 Conseq := Expression (CCase);
453 -- Each contract case must have exactly one case guard
455 Extra_Guard := Next (Case_Guard);
457 if Present (Extra_Guard) then
459 ("contract case must have exactly one case guard",
463 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
465 if Nkind (Case_Guard) = N_Others_Choice then
468 ("only one others choice allowed in contract cases",
474 elsif Others_Seen then
476 ("others must be the last choice in contract cases", N);
479 -- Preanalyze the case guard and consequence
481 if Nkind (Case_Guard) /= N_Others_Choice then
482 Errors := Serious_Errors_Detected;
483 Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean);
485 -- Emit a clarification message when the case guard contains
486 -- at least one undefined reference, possibly due to contract
489 if Errors /= Serious_Errors_Detected
490 and then Present (Freeze_Id)
491 and then Has_Undefined_Reference (Case_Guard)
493 Contract_Freeze_Error (Spec_Id, Freeze_Id);
497 Errors := Serious_Errors_Detected;
498 Preanalyze_Assert_Expression (Conseq, Standard_Boolean);
500 -- Emit a clarification message when the consequence contains
501 -- at least one undefined reference, possibly due to contract
504 if Errors /= Serious_Errors_Detected
505 and then Present (Freeze_Id)
506 and then Has_Undefined_Reference (Conseq)
508 Contract_Freeze_Error (Spec_Id, Freeze_Id);
511 -- The contract case is malformed
514 Error_Msg_N ("wrong syntax in contract case", CCase);
516 end Analyze_Contract_Case;
520 CCases : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
522 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
523 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
524 -- Save the Ghost-related attributes to restore on exit
527 Restore_Scope : Boolean := False;
529 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
532 -- Do not analyze the pragma multiple times
534 if Is_Analyzed_Pragma (N) then
538 -- Set the Ghost mode in effect from the pragma. Due to the delayed
539 -- analysis of the pragma, the Ghost mode at point of declaration and
540 -- point of analysis may not necessarily be the same. Use the mode in
541 -- effect at the point of declaration.
545 -- Single and multiple contract cases must appear in aggregate form. If
546 -- this is not the case, then either the parser of the analysis of the
547 -- pragma failed to produce an aggregate.
549 pragma Assert (Nkind (CCases) = N_Aggregate);
551 if Present (Component_Associations (CCases)) then
553 -- Ensure that the formal parameters are visible when analyzing all
554 -- clauses. This falls out of the general rule of aspects pertaining
555 -- to subprogram declarations.
557 if not In_Open_Scopes (Spec_Id) then
558 Restore_Scope := True;
559 Push_Scope (Spec_Id);
561 if Is_Generic_Subprogram (Spec_Id) then
562 Install_Generic_Formals (Spec_Id);
564 Install_Formals (Spec_Id);
568 CCase := First (Component_Associations (CCases));
569 while Present (CCase) loop
570 Analyze_Contract_Case (CCase);
574 if Restore_Scope then
578 -- Currently it is not possible to inline pre/postconditions on a
579 -- subprogram subject to pragma Inline_Always.
581 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
583 -- Otherwise the pragma is illegal
586 Error_Msg_N ("wrong syntax for constract cases", N);
589 Set_Is_Analyzed_Pragma (N);
591 Restore_Ghost_Region (Saved_GM, Saved_IGR);
592 end Analyze_Contract_Cases_In_Decl_Part;
594 ----------------------------------
595 -- Analyze_Depends_In_Decl_Part --
596 ----------------------------------
598 procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is
599 Loc : constant Source_Ptr := Sloc (N);
600 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
601 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
603 All_Inputs_Seen : Elist_Id := No_Elist;
604 -- A list containing the entities of all the inputs processed so far.
605 -- The list is populated with unique entities because the same input
606 -- may appear in multiple input lists.
608 All_Outputs_Seen : Elist_Id := No_Elist;
609 -- A list containing the entities of all the outputs processed so far.
610 -- The list is populated with unique entities because output items are
611 -- unique in a dependence relation.
613 Constits_Seen : Elist_Id := No_Elist;
614 -- A list containing the entities of all constituents processed so far.
615 -- It aids in detecting illegal usage of a state and a corresponding
616 -- constituent in pragma [Refinde_]Depends.
618 Global_Seen : Boolean := False;
619 -- A flag set when pragma Global has been processed
621 Null_Output_Seen : Boolean := False;
622 -- A flag used to track the legality of a null output
624 Result_Seen : Boolean := False;
625 -- A flag set when Spec_Id'Result is processed
627 States_Seen : Elist_Id := No_Elist;
628 -- A list containing the entities of all states processed so far. It
629 -- helps in detecting illegal usage of a state and a corresponding
630 -- constituent in pragma [Refined_]Depends.
632 Subp_Inputs : Elist_Id := No_Elist;
633 Subp_Outputs : Elist_Id := No_Elist;
634 -- Two lists containing the full set of inputs and output of the related
635 -- subprograms. Note that these lists contain both nodes and entities.
637 Task_Input_Seen : Boolean := False;
638 Task_Output_Seen : Boolean := False;
639 -- Flags used to track the implicit dependence of a task unit on itself
641 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id);
642 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
643 -- to the name buffer. The individual kinds are as follows:
644 -- E_Abstract_State - "state"
645 -- E_Constant - "constant"
646 -- E_Generic_In_Out_Parameter - "generic parameter"
647 -- E_Generic_In_Parameter - "generic parameter"
648 -- E_In_Parameter - "parameter"
649 -- E_In_Out_Parameter - "parameter"
650 -- E_Loop_Parameter - "loop parameter"
651 -- E_Out_Parameter - "parameter"
652 -- E_Protected_Type - "current instance of protected type"
653 -- E_Task_Type - "current instance of task type"
654 -- E_Variable - "global"
656 procedure Analyze_Dependency_Clause
659 -- Verify the legality of a single dependency clause. Flag Is_Last
660 -- denotes whether Clause is the last clause in the relation.
662 procedure Check_Function_Return;
663 -- Verify that Funtion'Result appears as one of the outputs
664 -- (SPARK RM 6.1.5(10)).
671 -- Ensure that an item fulfills its designated input and/or output role
672 -- as specified by pragma Global (if any) or the enclosing context. If
673 -- this is not the case, emit an error. Item and Item_Id denote the
674 -- attributes of an item. Flag Is_Input should be set when item comes
675 -- from an input list. Flag Self_Ref should be set when the item is an
676 -- output and the dependency clause has operator "+".
678 procedure Check_Usage
679 (Subp_Items : Elist_Id;
680 Used_Items : Elist_Id;
682 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
683 -- error if this is not the case.
685 procedure Normalize_Clause (Clause : Node_Id);
686 -- Remove a self-dependency "+" from the input list of a clause
688 -----------------------------
689 -- Add_Item_To_Name_Buffer --
690 -----------------------------
692 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id) is
694 if Ekind (Item_Id) = E_Abstract_State then
695 Add_Str_To_Name_Buffer ("state");
697 elsif Ekind (Item_Id) = E_Constant then
698 Add_Str_To_Name_Buffer ("constant");
700 elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
701 E_Generic_In_Parameter)
703 Add_Str_To_Name_Buffer ("generic parameter");
705 elsif Is_Formal (Item_Id) then
706 Add_Str_To_Name_Buffer ("parameter");
708 elsif Ekind (Item_Id) = E_Loop_Parameter then
709 Add_Str_To_Name_Buffer ("loop parameter");
711 elsif Ekind (Item_Id) = E_Protected_Type
712 or else Is_Single_Protected_Object (Item_Id)
714 Add_Str_To_Name_Buffer ("current instance of protected type");
716 elsif Ekind (Item_Id) = E_Task_Type
717 or else Is_Single_Task_Object (Item_Id)
719 Add_Str_To_Name_Buffer ("current instance of task type");
721 elsif Ekind (Item_Id) = E_Variable then
722 Add_Str_To_Name_Buffer ("global");
724 -- The routine should not be called with non-SPARK items
729 end Add_Item_To_Name_Buffer;
731 -------------------------------
732 -- Analyze_Dependency_Clause --
733 -------------------------------
735 procedure Analyze_Dependency_Clause
739 procedure Analyze_Input_List (Inputs : Node_Id);
740 -- Verify the legality of a single input list
742 procedure Analyze_Input_Output
747 Seen : in out Elist_Id;
748 Null_Seen : in out Boolean;
749 Non_Null_Seen : in out Boolean);
750 -- Verify the legality of a single input or output item. Flag
751 -- Is_Input should be set whenever Item is an input, False when it
752 -- denotes an output. Flag Self_Ref should be set when the item is an
753 -- output and the dependency clause has a "+". Flag Top_Level should
754 -- be set whenever Item appears immediately within an input or output
755 -- list. Seen is a collection of all abstract states, objects and
756 -- formals processed so far. Flag Null_Seen denotes whether a null
757 -- input or output has been encountered. Flag Non_Null_Seen denotes
758 -- whether a non-null input or output has been encountered.
760 ------------------------
761 -- Analyze_Input_List --
762 ------------------------
764 procedure Analyze_Input_List (Inputs : Node_Id) is
765 Inputs_Seen : Elist_Id := No_Elist;
766 -- A list containing the entities of all inputs that appear in the
767 -- current input list.
769 Non_Null_Input_Seen : Boolean := False;
770 Null_Input_Seen : Boolean := False;
771 -- Flags used to check the legality of an input list
776 -- Multiple inputs appear as an aggregate
778 if Nkind (Inputs) = N_Aggregate then
779 if Present (Component_Associations (Inputs)) then
781 ("nested dependency relations not allowed", Inputs);
783 elsif Present (Expressions (Inputs)) then
784 Input := First (Expressions (Inputs));
785 while Present (Input) loop
792 Null_Seen => Null_Input_Seen,
793 Non_Null_Seen => Non_Null_Input_Seen);
798 -- Syntax error, always report
801 Error_Msg_N ("malformed input dependency list", Inputs);
804 -- Process a solitary input
813 Null_Seen => Null_Input_Seen,
814 Non_Null_Seen => Non_Null_Input_Seen);
817 -- Detect an illegal dependency clause of the form
821 if Null_Output_Seen and then Null_Input_Seen then
823 ("null dependency clause cannot have a null input list",
826 end Analyze_Input_List;
828 --------------------------
829 -- Analyze_Input_Output --
830 --------------------------
832 procedure Analyze_Input_Output
837 Seen : in out Elist_Id;
838 Null_Seen : in out Boolean;
839 Non_Null_Seen : in out Boolean)
841 procedure Current_Task_Instance_Seen;
842 -- Set the appropriate global flag when the current instance of a
843 -- task unit is encountered.
845 --------------------------------
846 -- Current_Task_Instance_Seen --
847 --------------------------------
849 procedure Current_Task_Instance_Seen is
852 Task_Input_Seen := True;
854 Task_Output_Seen := True;
856 end Current_Task_Instance_Seen;
860 Is_Output : constant Boolean := not Is_Input;
864 -- Start of processing for Analyze_Input_Output
867 -- Multiple input or output items appear as an aggregate
869 if Nkind (Item) = N_Aggregate then
870 if not Top_Level then
871 SPARK_Msg_N ("nested grouping of items not allowed", Item);
873 elsif Present (Component_Associations (Item)) then
875 ("nested dependency relations not allowed", Item);
877 -- Recursively analyze the grouped items
879 elsif Present (Expressions (Item)) then
880 Grouped := First (Expressions (Item));
881 while Present (Grouped) loop
884 Is_Input => Is_Input,
885 Self_Ref => Self_Ref,
888 Null_Seen => Null_Seen,
889 Non_Null_Seen => Non_Null_Seen);
894 -- Syntax error, always report
897 Error_Msg_N ("malformed dependency list", Item);
900 -- Process attribute 'Result in the context of a dependency clause
902 elsif Is_Attribute_Result (Item) then
903 Non_Null_Seen := True;
907 -- Attribute 'Result is allowed to appear on the output side of
908 -- a dependency clause (SPARK RM 6.1.5(6)).
911 SPARK_Msg_N ("function result cannot act as input", Item);
915 ("cannot mix null and non-null dependency items", Item);
921 -- Detect multiple uses of null in a single dependency list or
922 -- throughout the whole relation. Verify the placement of a null
923 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
925 elsif Nkind (Item) = N_Null then
928 ("multiple null dependency relations not allowed", Item);
930 elsif Non_Null_Seen then
932 ("cannot mix null and non-null dependency items", Item);
940 ("null output list must be the last clause in a "
941 & "dependency relation", Item);
943 -- Catch a useless dependence of the form:
948 ("useless dependence, null depends on itself", Item);
956 Non_Null_Seen := True;
959 SPARK_Msg_N ("cannot mix null and non-null items", Item);
963 Resolve_State (Item);
965 -- Find the entity of the item. If this is a renaming, climb
966 -- the renaming chain to reach the root object. Renamings of
967 -- non-entire objects do not yield an entity (Empty).
969 Item_Id := Entity_Of (Item);
971 if Present (Item_Id) then
975 if Ekind_In (Item_Id, E_Constant, E_Loop_Parameter)
978 -- Current instances of concurrent types
980 Ekind_In (Item_Id, E_Protected_Type, E_Task_Type)
985 Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
986 E_Generic_In_Parameter,
994 Ekind_In (Item_Id, E_Abstract_State, E_Variable)
996 -- A [generic] function is not allowed to have Output
997 -- items in its dependency relations. Note that "null"
998 -- and attribute 'Result are still valid items.
1000 if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
1001 and then not Is_Input
1004 ("output item is not applicable to function", Item);
1007 -- The item denotes a concurrent type. Note that single
1008 -- protected/task types are not considered here because
1009 -- they behave as objects in the context of pragma
1010 -- [Refined_]Depends.
1012 if Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then
1014 -- This use is legal as long as the concurrent type is
1015 -- the current instance of an enclosing type.
1017 if Is_CCT_Instance (Item_Id, Spec_Id) then
1019 -- The dependence of a task unit on itself is
1020 -- implicit and may or may not be explicitly
1021 -- specified (SPARK RM 6.1.4).
1023 if Ekind (Item_Id) = E_Task_Type then
1024 Current_Task_Instance_Seen;
1027 -- Otherwise this is not the current instance
1031 ("invalid use of subtype mark in dependency "
1032 & "relation", Item);
1035 -- The dependency of a task unit on itself is implicit
1036 -- and may or may not be explicitly specified
1037 -- (SPARK RM 6.1.4).
1039 elsif Is_Single_Task_Object (Item_Id)
1040 and then Is_CCT_Instance (Etype (Item_Id), Spec_Id)
1042 Current_Task_Instance_Seen;
1045 -- Ensure that the item fulfills its role as input and/or
1046 -- output as specified by pragma Global or the enclosing
1049 Check_Role (Item, Item_Id, Is_Input, Self_Ref);
1051 -- Detect multiple uses of the same state, variable or
1052 -- formal parameter. If this is not the case, add the
1053 -- item to the list of processed relations.
1055 if Contains (Seen, Item_Id) then
1057 ("duplicate use of item &", Item, Item_Id);
1059 Append_New_Elmt (Item_Id, Seen);
1062 -- Detect illegal use of an input related to a null
1063 -- output. Such input items cannot appear in other
1064 -- input lists (SPARK RM 6.1.5(13)).
1067 and then Null_Output_Seen
1068 and then Contains (All_Inputs_Seen, Item_Id)
1071 ("input of a null output list cannot appear in "
1072 & "multiple input lists", Item);
1075 -- Add an input or a self-referential output to the list
1076 -- of all processed inputs.
1078 if Is_Input or else Self_Ref then
1079 Append_New_Elmt (Item_Id, All_Inputs_Seen);
1082 -- State related checks (SPARK RM 6.1.5(3))
1084 if Ekind (Item_Id) = E_Abstract_State then
1086 -- Package and subprogram bodies are instantiated
1087 -- individually in a separate compiler pass. Due to
1088 -- this mode of instantiation, the refinement of a
1089 -- state may no longer be visible when a subprogram
1090 -- body contract is instantiated. Since the generic
1091 -- template is legal, do not perform this check in
1092 -- the instance to circumvent this oddity.
1094 if Is_Generic_Instance (Spec_Id) then
1097 -- An abstract state with visible refinement cannot
1098 -- appear in pragma [Refined_]Depends as its place
1099 -- must be taken by some of its constituents
1100 -- (SPARK RM 6.1.4(7)).
1102 elsif Has_Visible_Refinement (Item_Id) then
1104 ("cannot mention state & in dependence relation",
1106 SPARK_Msg_N ("\use its constituents instead", Item);
1109 -- If the reference to the abstract state appears in
1110 -- an enclosing package body that will eventually
1111 -- refine the state, record the reference for future
1115 Record_Possible_Body_Reference
1116 (State_Id => Item_Id,
1121 -- When the item renames an entire object, replace the
1122 -- item with a reference to the object.
1124 if Entity (Item) /= Item_Id then
1126 New_Occurrence_Of (Item_Id, Sloc (Item)));
1130 -- Add the entity of the current item to the list of
1133 if Ekind (Item_Id) = E_Abstract_State then
1134 Append_New_Elmt (Item_Id, States_Seen);
1136 -- The variable may eventually become a constituent of a
1137 -- single protected/task type. Record the reference now
1138 -- and verify its legality when analyzing the contract of
1139 -- the variable (SPARK RM 9.3).
1141 elsif Ekind (Item_Id) = E_Variable then
1142 Record_Possible_Part_Of_Reference
1147 if Ekind_In (Item_Id, E_Abstract_State,
1150 and then Present (Encapsulating_State (Item_Id))
1152 Append_New_Elmt (Item_Id, Constits_Seen);
1155 -- All other input/output items are illegal
1156 -- (SPARK RM 6.1.5(1)).
1160 ("item must denote parameter, variable, state or "
1161 & "current instance of concurrent type", Item);
1164 -- All other input/output items are illegal
1165 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
1169 ("item must denote parameter, variable, state or current "
1170 & "instance of concurrent type", Item);
1173 end Analyze_Input_Output;
1181 Non_Null_Output_Seen : Boolean := False;
1182 -- Flag used to check the legality of an output list
1184 -- Start of processing for Analyze_Dependency_Clause
1187 Inputs := Expression (Clause);
1190 -- An input list with a self-dependency appears as operator "+" where
1191 -- the actuals inputs are the right operand.
1193 if Nkind (Inputs) = N_Op_Plus then
1194 Inputs := Right_Opnd (Inputs);
1198 -- Process the output_list of a dependency_clause
1200 Output := First (Choices (Clause));
1201 while Present (Output) loop
1202 Analyze_Input_Output
1205 Self_Ref => Self_Ref,
1207 Seen => All_Outputs_Seen,
1208 Null_Seen => Null_Output_Seen,
1209 Non_Null_Seen => Non_Null_Output_Seen);
1214 -- Process the input_list of a dependency_clause
1216 Analyze_Input_List (Inputs);
1217 end Analyze_Dependency_Clause;
1219 ---------------------------
1220 -- Check_Function_Return --
1221 ---------------------------
1223 procedure Check_Function_Return is
1225 if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
1226 and then not Result_Seen
1229 ("result of & must appear in exactly one output list",
1232 end Check_Function_Return;
1238 procedure Check_Role
1240 Item_Id : Entity_Id;
1245 (Item_Is_Input : out Boolean;
1246 Item_Is_Output : out Boolean);
1247 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1248 -- Item_Is_Output are set depending on the role.
1250 procedure Role_Error
1251 (Item_Is_Input : Boolean;
1252 Item_Is_Output : Boolean);
1253 -- Emit an error message concerning the incorrect use of Item in
1254 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1255 -- denote whether the item is an input and/or an output.
1262 (Item_Is_Input : out Boolean;
1263 Item_Is_Output : out Boolean)
1266 case Ekind (Item_Id) is
1270 when E_Abstract_State =>
1272 -- When pragma Global is present it determines the mode of
1273 -- the abstract state.
1276 Item_Is_Input := Appears_In (Subp_Inputs, Item_Id);
1277 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1279 -- Otherwise the state has a default IN OUT mode, because it
1280 -- behaves as a variable.
1283 Item_Is_Input := True;
1284 Item_Is_Output := True;
1287 -- Constants and IN parameters
1290 | E_Generic_In_Parameter
1294 -- When pragma Global is present it determines the mode
1295 -- of constant objects as inputs (and such objects cannot
1296 -- appear as outputs in the Global contract).
1299 Item_Is_Input := Appears_In (Subp_Inputs, Item_Id);
1301 Item_Is_Input := True;
1304 Item_Is_Output := False;
1306 -- Variables and IN OUT parameters
1308 when E_Generic_In_Out_Parameter
1309 | E_In_Out_Parameter
1312 -- When pragma Global is present it determines the mode of
1317 -- A variable has mode IN when its type is unconstrained
1318 -- or tagged because array bounds, discriminants or tags
1322 Appears_In (Subp_Inputs, Item_Id)
1323 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1325 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1327 -- Otherwise the variable has a default IN OUT mode
1330 Item_Is_Input := True;
1331 Item_Is_Output := True;
1334 when E_Out_Parameter =>
1336 -- An OUT parameter of the related subprogram; it cannot
1337 -- appear in Global.
1339 if Scope (Item_Id) = Spec_Id then
1341 -- The parameter has mode IN if its type is unconstrained
1342 -- or tagged because array bounds, discriminants or tags
1346 Is_Unconstrained_Or_Tagged_Item (Item_Id);
1348 Item_Is_Output := True;
1350 -- An OUT parameter of an enclosing subprogram; it can
1351 -- appear in Global and behaves as a read-write variable.
1354 -- When pragma Global is present it determines the mode
1359 -- A variable has mode IN when its type is
1360 -- unconstrained or tagged because array
1361 -- bounds, discriminants or tags can be read.
1364 Appears_In (Subp_Inputs, Item_Id)
1365 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1367 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1369 -- Otherwise the variable has a default IN OUT mode
1372 Item_Is_Input := True;
1373 Item_Is_Output := True;
1379 when E_Protected_Type =>
1382 -- A variable has mode IN when its type is unconstrained
1383 -- or tagged because array bounds, discriminants or tags
1387 Appears_In (Subp_Inputs, Item_Id)
1388 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1390 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1393 -- A protected type acts as a formal parameter of mode IN
1394 -- when it applies to a protected function.
1396 if Ekind (Spec_Id) = E_Function then
1397 Item_Is_Input := True;
1398 Item_Is_Output := False;
1400 -- Otherwise the protected type acts as a formal of mode
1404 Item_Is_Input := True;
1405 Item_Is_Output := True;
1413 -- When pragma Global is present it determines the mode of
1418 Appears_In (Subp_Inputs, Item_Id)
1419 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1421 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1423 -- Otherwise task types act as IN OUT parameters
1426 Item_Is_Input := True;
1427 Item_Is_Output := True;
1431 raise Program_Error;
1439 procedure Role_Error
1440 (Item_Is_Input : Boolean;
1441 Item_Is_Output : Boolean)
1443 Error_Msg : Name_Id;
1448 -- When the item is not part of the input and the output set of
1449 -- the related subprogram, then it appears as extra in pragma
1450 -- [Refined_]Depends.
1452 if not Item_Is_Input and then not Item_Is_Output then
1453 Add_Item_To_Name_Buffer (Item_Id);
1454 Add_Str_To_Name_Buffer
1455 (" & cannot appear in dependence relation");
1457 Error_Msg := Name_Find;
1458 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1460 Error_Msg_Name_1 := Chars (Spec_Id);
1462 (Fix_Msg (Spec_Id, "\& is not part of the input or output "
1463 & "set of subprogram %"), Item, Item_Id);
1465 -- The mode of the item and its role in pragma [Refined_]Depends
1466 -- are in conflict. Construct a detailed message explaining the
1467 -- illegality (SPARK RM 6.1.5(5-6)).
1470 if Item_Is_Input then
1471 Add_Str_To_Name_Buffer ("read-only");
1473 Add_Str_To_Name_Buffer ("write-only");
1476 Add_Char_To_Name_Buffer (' ');
1477 Add_Item_To_Name_Buffer (Item_Id);
1478 Add_Str_To_Name_Buffer (" & cannot appear as ");
1480 if Item_Is_Input then
1481 Add_Str_To_Name_Buffer ("output");
1483 Add_Str_To_Name_Buffer ("input");
1486 Add_Str_To_Name_Buffer (" in dependence relation");
1487 Error_Msg := Name_Find;
1488 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1494 Item_Is_Input : Boolean;
1495 Item_Is_Output : Boolean;
1497 -- Start of processing for Check_Role
1500 Find_Role (Item_Is_Input, Item_Is_Output);
1505 if not Item_Is_Input then
1506 Role_Error (Item_Is_Input, Item_Is_Output);
1509 -- Self-referential item
1512 if not Item_Is_Input or else not Item_Is_Output then
1513 Role_Error (Item_Is_Input, Item_Is_Output);
1518 elsif not Item_Is_Output then
1519 Role_Error (Item_Is_Input, Item_Is_Output);
1527 procedure Check_Usage
1528 (Subp_Items : Elist_Id;
1529 Used_Items : Elist_Id;
1532 procedure Usage_Error (Item_Id : Entity_Id);
1533 -- Emit an error concerning the illegal usage of an item
1539 procedure Usage_Error (Item_Id : Entity_Id) is
1540 Error_Msg : Name_Id;
1547 -- Unconstrained and tagged items are not part of the explicit
1548 -- input set of the related subprogram, they do not have to be
1549 -- present in a dependence relation and should not be flagged
1550 -- (SPARK RM 6.1.5(5)).
1552 if not Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1555 Add_Item_To_Name_Buffer (Item_Id);
1556 Add_Str_To_Name_Buffer
1557 (" & is missing from input dependence list");
1559 Error_Msg := Name_Find;
1560 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1562 ("\add `null ='> &` dependency to ignore this input",
1566 -- Output case (SPARK RM 6.1.5(10))
1571 Add_Item_To_Name_Buffer (Item_Id);
1572 Add_Str_To_Name_Buffer
1573 (" & is missing from output dependence list");
1575 Error_Msg := Name_Find;
1576 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1584 Item_Id : Entity_Id;
1586 -- Start of processing for Check_Usage
1589 if No (Subp_Items) then
1593 -- Each input or output of the subprogram must appear in a dependency
1596 Elmt := First_Elmt (Subp_Items);
1597 while Present (Elmt) loop
1598 Item := Node (Elmt);
1600 if Nkind (Item) = N_Defining_Identifier then
1603 Item_Id := Entity_Of (Item);
1606 -- The item does not appear in a dependency
1608 if Present (Item_Id)
1609 and then not Contains (Used_Items, Item_Id)
1611 if Is_Formal (Item_Id) then
1612 Usage_Error (Item_Id);
1614 -- The current instance of a protected type behaves as a formal
1615 -- parameter (SPARK RM 6.1.4).
1617 elsif Ekind (Item_Id) = E_Protected_Type
1618 or else Is_Single_Protected_Object (Item_Id)
1620 Usage_Error (Item_Id);
1622 -- The current instance of a task type behaves as a formal
1623 -- parameter (SPARK RM 6.1.4).
1625 elsif Ekind (Item_Id) = E_Task_Type
1626 or else Is_Single_Task_Object (Item_Id)
1628 -- The dependence of a task unit on itself is implicit and
1629 -- may or may not be explicitly specified (SPARK RM 6.1.4).
1630 -- Emit an error if only one input/output is present.
1632 if Task_Input_Seen /= Task_Output_Seen then
1633 Usage_Error (Item_Id);
1636 -- States and global objects are not used properly only when
1637 -- the subprogram is subject to pragma Global.
1639 elsif Global_Seen then
1640 Usage_Error (Item_Id);
1648 ----------------------
1649 -- Normalize_Clause --
1650 ----------------------
1652 procedure Normalize_Clause (Clause : Node_Id) is
1653 procedure Create_Or_Modify_Clause
1659 Multiple : Boolean);
1660 -- Create a brand new clause to represent the self-reference or
1661 -- modify the input and/or output lists of an existing clause. Output
1662 -- denotes a self-referencial output. Outputs is the output list of a
1663 -- clause. Inputs is the input list of a clause. After denotes the
1664 -- clause after which the new clause is to be inserted. Flag In_Place
1665 -- should be set when normalizing the last output of an output list.
1666 -- Flag Multiple should be set when Output comes from a list with
1669 -----------------------------
1670 -- Create_Or_Modify_Clause --
1671 -----------------------------
1673 procedure Create_Or_Modify_Clause
1681 procedure Propagate_Output
1684 -- Handle the various cases of output propagation to the input
1685 -- list. Output denotes a self-referencial output item. Inputs
1686 -- is the input list of a clause.
1688 ----------------------
1689 -- Propagate_Output --
1690 ----------------------
1692 procedure Propagate_Output
1696 function In_Input_List
1698 Inputs : List_Id) return Boolean;
1699 -- Determine whether a particulat item appears in the input
1700 -- list of a clause.
1706 function In_Input_List
1708 Inputs : List_Id) return Boolean
1713 Elmt := First (Inputs);
1714 while Present (Elmt) loop
1715 if Entity_Of (Elmt) = Item then
1727 Output_Id : constant Entity_Id := Entity_Of (Output);
1730 -- Start of processing for Propagate_Output
1733 -- The clause is of the form:
1735 -- (Output =>+ null)
1737 -- Remove null input and replace it with a copy of the output:
1739 -- (Output => Output)
1741 if Nkind (Inputs) = N_Null then
1742 Rewrite (Inputs, New_Copy_Tree (Output));
1744 -- The clause is of the form:
1746 -- (Output =>+ (Input1, ..., InputN))
1748 -- Determine whether the output is not already mentioned in the
1749 -- input list and if not, add it to the list of inputs:
1751 -- (Output => (Output, Input1, ..., InputN))
1753 elsif Nkind (Inputs) = N_Aggregate then
1754 Grouped := Expressions (Inputs);
1756 if not In_Input_List
1760 Prepend_To (Grouped, New_Copy_Tree (Output));
1763 -- The clause is of the form:
1765 -- (Output =>+ Input)
1767 -- If the input does not mention the output, group the two
1770 -- (Output => (Output, Input))
1772 elsif Entity_Of (Inputs) /= Output_Id then
1774 Make_Aggregate (Loc,
1775 Expressions => New_List (
1776 New_Copy_Tree (Output),
1777 New_Copy_Tree (Inputs))));
1779 end Propagate_Output;
1783 Loc : constant Source_Ptr := Sloc (Clause);
1784 New_Clause : Node_Id;
1786 -- Start of processing for Create_Or_Modify_Clause
1789 -- A null output depending on itself does not require any
1792 if Nkind (Output) = N_Null then
1795 -- A function result cannot depend on itself because it cannot
1796 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1798 elsif Is_Attribute_Result (Output) then
1799 SPARK_Msg_N ("function result cannot depend on itself", Output);
1803 -- When performing the transformation in place, simply add the
1804 -- output to the list of inputs (if not already there). This
1805 -- case arises when dealing with the last output of an output
1806 -- list. Perform the normalization in place to avoid generating
1807 -- a malformed tree.
1810 Propagate_Output (Output, Inputs);
1812 -- A list with multiple outputs is slowly trimmed until only
1813 -- one element remains. When this happens, replace aggregate
1814 -- with the element itself.
1818 Rewrite (Outputs, Output);
1824 -- Unchain the output from its output list as it will appear in
1825 -- a new clause. Note that we cannot simply rewrite the output
1826 -- as null because this will violate the semantics of pragma
1831 -- Generate a new clause of the form:
1832 -- (Output => Inputs)
1835 Make_Component_Association (Loc,
1836 Choices => New_List (Output),
1837 Expression => New_Copy_Tree (Inputs));
1839 -- The new clause contains replicated content that has already
1840 -- been analyzed. There is not need to reanalyze or renormalize
1843 Set_Analyzed (New_Clause);
1846 (Output => First (Choices (New_Clause)),
1847 Inputs => Expression (New_Clause));
1849 Insert_After (After, New_Clause);
1851 end Create_Or_Modify_Clause;
1855 Outputs : constant Node_Id := First (Choices (Clause));
1857 Last_Output : Node_Id;
1858 Next_Output : Node_Id;
1861 -- Start of processing for Normalize_Clause
1864 -- A self-dependency appears as operator "+". Remove the "+" from the
1865 -- tree by moving the real inputs to their proper place.
1867 if Nkind (Expression (Clause)) = N_Op_Plus then
1868 Rewrite (Expression (Clause), Right_Opnd (Expression (Clause)));
1869 Inputs := Expression (Clause);
1871 -- Multiple outputs appear as an aggregate
1873 if Nkind (Outputs) = N_Aggregate then
1874 Last_Output := Last (Expressions (Outputs));
1876 Output := First (Expressions (Outputs));
1877 while Present (Output) loop
1879 -- Normalization may remove an output from its list,
1880 -- preserve the subsequent output now.
1882 Next_Output := Next (Output);
1884 Create_Or_Modify_Clause
1889 In_Place => Output = Last_Output,
1892 Output := Next_Output;
1898 Create_Or_Modify_Clause
1907 end Normalize_Clause;
1911 Deps : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
1912 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
1916 Last_Clause : Node_Id;
1917 Restore_Scope : Boolean := False;
1919 -- Start of processing for Analyze_Depends_In_Decl_Part
1922 -- Do not analyze the pragma multiple times
1924 if Is_Analyzed_Pragma (N) then
1928 -- Empty dependency list
1930 if Nkind (Deps) = N_Null then
1932 -- Gather all states, objects and formal parameters that the
1933 -- subprogram may depend on. These items are obtained from the
1934 -- parameter profile or pragma [Refined_]Global (if available).
1936 Collect_Subprogram_Inputs_Outputs
1937 (Subp_Id => Subp_Id,
1938 Subp_Inputs => Subp_Inputs,
1939 Subp_Outputs => Subp_Outputs,
1940 Global_Seen => Global_Seen);
1942 -- Verify that every input or output of the subprogram appear in a
1945 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1946 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1947 Check_Function_Return;
1949 -- Dependency clauses appear as component associations of an aggregate
1951 elsif Nkind (Deps) = N_Aggregate then
1953 -- Do not attempt to perform analysis of a syntactically illegal
1954 -- clause as this will lead to misleading errors.
1956 if Has_Extra_Parentheses (Deps) then
1960 if Present (Component_Associations (Deps)) then
1961 Last_Clause := Last (Component_Associations (Deps));
1963 -- Gather all states, objects and formal parameters that the
1964 -- subprogram may depend on. These items are obtained from the
1965 -- parameter profile or pragma [Refined_]Global (if available).
1967 Collect_Subprogram_Inputs_Outputs
1968 (Subp_Id => Subp_Id,
1969 Subp_Inputs => Subp_Inputs,
1970 Subp_Outputs => Subp_Outputs,
1971 Global_Seen => Global_Seen);
1973 -- When pragma [Refined_]Depends appears on a single concurrent
1974 -- type, it is relocated to the anonymous object.
1976 if Is_Single_Concurrent_Object (Spec_Id) then
1979 -- Ensure that the formal parameters are visible when analyzing
1980 -- all clauses. This falls out of the general rule of aspects
1981 -- pertaining to subprogram declarations.
1983 elsif not In_Open_Scopes (Spec_Id) then
1984 Restore_Scope := True;
1985 Push_Scope (Spec_Id);
1987 if Ekind (Spec_Id) = E_Task_Type then
1988 if Has_Discriminants (Spec_Id) then
1989 Install_Discriminants (Spec_Id);
1992 elsif Is_Generic_Subprogram (Spec_Id) then
1993 Install_Generic_Formals (Spec_Id);
1996 Install_Formals (Spec_Id);
2000 Clause := First (Component_Associations (Deps));
2001 while Present (Clause) loop
2002 Errors := Serious_Errors_Detected;
2004 -- The normalization mechanism may create extra clauses that
2005 -- contain replicated input and output names. There is no need
2006 -- to reanalyze them.
2008 if not Analyzed (Clause) then
2009 Set_Analyzed (Clause);
2011 Analyze_Dependency_Clause
2013 Is_Last => Clause = Last_Clause);
2016 -- Do not normalize a clause if errors were detected (count
2017 -- of Serious_Errors has increased) because the inputs and/or
2018 -- outputs may denote illegal items. Normalization is disabled
2019 -- in ASIS mode as it alters the tree by introducing new nodes
2020 -- similar to expansion.
2022 if Serious_Errors_Detected = Errors and then not ASIS_Mode then
2023 Normalize_Clause (Clause);
2029 if Restore_Scope then
2033 -- Verify that every input or output of the subprogram appear in a
2036 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
2037 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
2038 Check_Function_Return;
2040 -- The dependency list is malformed. This is a syntax error, always
2044 Error_Msg_N ("malformed dependency relation", Deps);
2048 -- The top level dependency relation is malformed. This is a syntax
2049 -- error, always report.
2052 Error_Msg_N ("malformed dependency relation", Deps);
2056 -- Ensure that a state and a corresponding constituent do not appear
2057 -- together in pragma [Refined_]Depends.
2059 Check_State_And_Constituent_Use
2060 (States => States_Seen,
2061 Constits => Constits_Seen,
2065 Set_Is_Analyzed_Pragma (N);
2066 end Analyze_Depends_In_Decl_Part;
2068 --------------------------------------------
2069 -- Analyze_External_Property_In_Decl_Part --
2070 --------------------------------------------
2072 procedure Analyze_External_Property_In_Decl_Part
2074 Expr_Val : out Boolean)
2076 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pragma_Name (N));
2077 Arg1 : constant Node_Id :=
2078 First (Pragma_Argument_Associations (N));
2079 Obj_Decl : constant Node_Id := Find_Related_Context (N);
2080 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
2086 -- Do not analyze the pragma multiple times
2088 if Is_Analyzed_Pragma (N) then
2092 Error_Msg_Name_1 := Pragma_Name (N);
2094 -- An external property pragma must apply to an effectively volatile
2095 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
2096 -- The check is performed at the end of the declarative region due to a
2097 -- possible out-of-order arrangement of pragmas:
2100 -- pragma Async_Readers (Obj);
2101 -- pragma Volatile (Obj);
2103 if Prag_Id /= Pragma_No_Caching
2104 and then not Is_Effectively_Volatile (Obj_Id)
2106 if No_Caching_Enabled (Obj_Id) then
2108 ("illegal combination of external property % and property "
2109 & """No_Caching"" (SPARK RM 7.1.2(6))", N);
2112 ("external property % must apply to a volatile object", N);
2115 -- Pragma No_Caching should only apply to volatile variables of
2116 -- a non-effectively volatile type (SPARK RM 7.1.2).
2118 elsif Prag_Id = Pragma_No_Caching then
2119 if Is_Effectively_Volatile (Etype (Obj_Id)) then
2120 SPARK_Msg_N ("property % must not apply to an object of "
2121 & "an effectively volatile type", N);
2122 elsif not Is_Volatile (Obj_Id) then
2123 SPARK_Msg_N ("property % must apply to a volatile object", N);
2127 -- Ensure that the Boolean expression (if present) is static. A missing
2128 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
2132 if Present (Arg1) then
2133 Expr := Get_Pragma_Arg (Arg1);
2135 if Is_OK_Static_Expression (Expr) then
2136 Expr_Val := Is_True (Expr_Value (Expr));
2140 Set_Is_Analyzed_Pragma (N);
2141 end Analyze_External_Property_In_Decl_Part;
2143 ---------------------------------
2144 -- Analyze_Global_In_Decl_Part --
2145 ---------------------------------
2147 procedure Analyze_Global_In_Decl_Part (N : Node_Id) is
2148 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
2149 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
2150 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
2152 Constits_Seen : Elist_Id := No_Elist;
2153 -- A list containing the entities of all constituents processed so far.
2154 -- It aids in detecting illegal usage of a state and a corresponding
2155 -- constituent in pragma [Refinde_]Global.
2157 Seen : Elist_Id := No_Elist;
2158 -- A list containing the entities of all the items processed so far. It
2159 -- plays a role in detecting distinct entities.
2161 States_Seen : Elist_Id := No_Elist;
2162 -- A list containing the entities of all states processed so far. It
2163 -- helps in detecting illegal usage of a state and a corresponding
2164 -- constituent in pragma [Refined_]Global.
2166 In_Out_Seen : Boolean := False;
2167 Input_Seen : Boolean := False;
2168 Output_Seen : Boolean := False;
2169 Proof_Seen : Boolean := False;
2170 -- Flags used to verify the consistency of modes
2172 procedure Analyze_Global_List
2174 Global_Mode : Name_Id := Name_Input);
2175 -- Verify the legality of a single global list declaration. Global_Mode
2176 -- denotes the current mode in effect.
2178 -------------------------
2179 -- Analyze_Global_List --
2180 -------------------------
2182 procedure Analyze_Global_List
2184 Global_Mode : Name_Id := Name_Input)
2186 procedure Analyze_Global_Item
2188 Global_Mode : Name_Id);
2189 -- Verify the legality of a single global item declaration denoted by
2190 -- Item. Global_Mode denotes the current mode in effect.
2192 procedure Check_Duplicate_Mode
2194 Status : in out Boolean);
2195 -- Flag Status denotes whether a particular mode has been seen while
2196 -- processing a global list. This routine verifies that Mode is not a
2197 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2199 procedure Check_Mode_Restriction_In_Enclosing_Context
2201 Item_Id : Entity_Id);
2202 -- Verify that an item of mode In_Out or Output does not appear as
2203 -- an input in the Global aspect of an enclosing subprogram or task
2204 -- unit. If this is the case, emit an error. Item and Item_Id are
2205 -- respectively the item and its entity.
2207 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id);
2208 -- Mode denotes either In_Out or Output. Depending on the kind of the
2209 -- related subprogram, emit an error if those two modes apply to a
2210 -- function (SPARK RM 6.1.4(10)).
2212 -------------------------
2213 -- Analyze_Global_Item --
2214 -------------------------
2216 procedure Analyze_Global_Item
2218 Global_Mode : Name_Id)
2220 Item_Id : Entity_Id;
2223 -- Detect one of the following cases
2225 -- with Global => (null, Name)
2226 -- with Global => (Name_1, null, Name_2)
2227 -- with Global => (Name, null)
2229 if Nkind (Item) = N_Null then
2230 SPARK_Msg_N ("cannot mix null and non-null global items", Item);
2235 Resolve_State (Item);
2237 -- Find the entity of the item. If this is a renaming, climb the
2238 -- renaming chain to reach the root object. Renamings of non-
2239 -- entire objects do not yield an entity (Empty).
2241 Item_Id := Entity_Of (Item);
2243 if Present (Item_Id) then
2245 -- A global item may denote a formal parameter of an enclosing
2246 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2247 -- provide a better error diagnostic.
2249 if Is_Formal (Item_Id) then
2250 if Scope (Item_Id) = Spec_Id then
2252 (Fix_Msg (Spec_Id, "global item cannot reference "
2253 & "parameter of subprogram &"), Item, Spec_Id);
2257 -- A global item may denote a concurrent type as long as it is
2258 -- the current instance of an enclosing protected or task type
2259 -- (SPARK RM 6.1.4).
2261 elsif Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then
2262 if Is_CCT_Instance (Item_Id, Spec_Id) then
2264 -- Pragma [Refined_]Global associated with a protected
2265 -- subprogram cannot mention the current instance of a
2266 -- protected type because the instance behaves as a
2267 -- formal parameter.
2269 if Ekind (Item_Id) = E_Protected_Type then
2270 if Scope (Spec_Id) = Item_Id then
2271 Error_Msg_Name_1 := Chars (Item_Id);
2273 (Fix_Msg (Spec_Id, "global item of subprogram & "
2274 & "cannot reference current instance of "
2275 & "protected type %"), Item, Spec_Id);
2279 -- Pragma [Refined_]Global associated with a task type
2280 -- cannot mention the current instance of a task type
2281 -- because the instance behaves as a formal parameter.
2283 else pragma Assert (Ekind (Item_Id) = E_Task_Type);
2284 if Spec_Id = Item_Id then
2285 Error_Msg_Name_1 := Chars (Item_Id);
2287 (Fix_Msg (Spec_Id, "global item of subprogram & "
2288 & "cannot reference current instance of task "
2289 & "type %"), Item, Spec_Id);
2294 -- Otherwise the global item denotes a subtype mark that is
2295 -- not a current instance.
2299 ("invalid use of subtype mark in global list", Item);
2303 -- A global item may denote the anonymous object created for a
2304 -- single protected/task type as long as the current instance
2305 -- is the same single type (SPARK RM 6.1.4).
2307 elsif Is_Single_Concurrent_Object (Item_Id)
2308 and then Is_CCT_Instance (Etype (Item_Id), Spec_Id)
2310 -- Pragma [Refined_]Global associated with a protected
2311 -- subprogram cannot mention the current instance of a
2312 -- protected type because the instance behaves as a formal
2315 if Is_Single_Protected_Object (Item_Id) then
2316 if Scope (Spec_Id) = Etype (Item_Id) then
2317 Error_Msg_Name_1 := Chars (Item_Id);
2319 (Fix_Msg (Spec_Id, "global item of subprogram & "
2320 & "cannot reference current instance of protected "
2321 & "type %"), Item, Spec_Id);
2325 -- Pragma [Refined_]Global associated with a task type
2326 -- cannot mention the current instance of a task type
2327 -- because the instance behaves as a formal parameter.
2329 else pragma Assert (Is_Single_Task_Object (Item_Id));
2330 if Spec_Id = Item_Id then
2331 Error_Msg_Name_1 := Chars (Item_Id);
2333 (Fix_Msg (Spec_Id, "global item of subprogram & "
2334 & "cannot reference current instance of task "
2335 & "type %"), Item, Spec_Id);
2340 -- A formal object may act as a global item inside a generic
2342 elsif Is_Formal_Object (Item_Id) then
2345 -- The only legal references are those to abstract states,
2346 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2348 elsif not Ekind_In (Item_Id, E_Abstract_State,
2354 ("global item must denote object, state or current "
2355 & "instance of concurrent type", Item);
2357 if Ekind (Item_Id) in Named_Kind then
2359 ("\named number & is not an object", Item, Item);
2365 -- State related checks
2367 if Ekind (Item_Id) = E_Abstract_State then
2369 -- Package and subprogram bodies are instantiated
2370 -- individually in a separate compiler pass. Due to this
2371 -- mode of instantiation, the refinement of a state may
2372 -- no longer be visible when a subprogram body contract
2373 -- is instantiated. Since the generic template is legal,
2374 -- do not perform this check in the instance to circumvent
2377 if Is_Generic_Instance (Spec_Id) then
2380 -- An abstract state with visible refinement cannot appear
2381 -- in pragma [Refined_]Global as its place must be taken by
2382 -- some of its constituents (SPARK RM 6.1.4(7)).
2384 elsif Has_Visible_Refinement (Item_Id) then
2386 ("cannot mention state & in global refinement",
2388 SPARK_Msg_N ("\use its constituents instead", Item);
2391 -- An external state cannot appear as a global item of a
2392 -- nonvolatile function (SPARK RM 7.1.3(8)).
2394 elsif Is_External_State (Item_Id)
2395 and then Ekind_In (Spec_Id, E_Function, E_Generic_Function)
2396 and then not Is_Volatile_Function (Spec_Id)
2399 ("external state & cannot act as global item of "
2400 & "nonvolatile function", Item, Item_Id);
2403 -- If the reference to the abstract state appears in an
2404 -- enclosing package body that will eventually refine the
2405 -- state, record the reference for future checks.
2408 Record_Possible_Body_Reference
2409 (State_Id => Item_Id,
2413 -- Constant related checks
2415 elsif Ekind (Item_Id) = E_Constant then
2417 -- A constant is a read-only item, therefore it cannot act
2420 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2422 ("constant & cannot act as output", Item, Item_Id);
2426 -- Loop parameter related checks
2428 elsif Ekind (Item_Id) = E_Loop_Parameter then
2430 -- A loop parameter is a read-only item, therefore it cannot
2431 -- act as an output.
2433 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2435 ("loop parameter & cannot act as output",
2440 -- Variable related checks. These are only relevant when
2441 -- SPARK_Mode is on as they are not standard Ada legality
2444 elsif SPARK_Mode = On
2445 and then Ekind (Item_Id) = E_Variable
2446 and then Is_Effectively_Volatile (Item_Id)
2448 -- An effectively volatile object cannot appear as a global
2449 -- item of a nonvolatile function (SPARK RM 7.1.3(8)).
2451 if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
2452 and then not Is_Volatile_Function (Spec_Id)
2455 ("volatile object & cannot act as global item of a "
2456 & "function", Item, Item_Id);
2459 -- An effectively volatile object with external property
2460 -- Effective_Reads set to True must have mode Output or
2461 -- In_Out (SPARK RM 7.1.3(10)).
2463 elsif Effective_Reads_Enabled (Item_Id)
2464 and then Global_Mode = Name_Input
2467 ("volatile object & with property Effective_Reads must "
2468 & "have mode In_Out or Output", Item, Item_Id);
2473 -- When the item renames an entire object, replace the item
2474 -- with a reference to the object.
2476 if Entity (Item) /= Item_Id then
2477 Rewrite (Item, New_Occurrence_Of (Item_Id, Sloc (Item)));
2481 -- Some form of illegal construct masquerading as a name
2482 -- (SPARK RM 6.1.4(4)).
2486 ("global item must denote object, state or current instance "
2487 & "of concurrent type", Item);
2491 -- Verify that an output does not appear as an input in an
2492 -- enclosing subprogram.
2494 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2495 Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id);
2498 -- The same entity might be referenced through various way.
2499 -- Check the entity of the item rather than the item itself
2500 -- (SPARK RM 6.1.4(10)).
2502 if Contains (Seen, Item_Id) then
2503 SPARK_Msg_N ("duplicate global item", Item);
2505 -- Add the entity of the current item to the list of processed
2509 Append_New_Elmt (Item_Id, Seen);
2511 if Ekind (Item_Id) = E_Abstract_State then
2512 Append_New_Elmt (Item_Id, States_Seen);
2514 -- The variable may eventually become a constituent of a single
2515 -- protected/task type. Record the reference now and verify its
2516 -- legality when analyzing the contract of the variable
2519 elsif Ekind (Item_Id) = E_Variable then
2520 Record_Possible_Part_Of_Reference
2525 if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable)
2526 and then Present (Encapsulating_State (Item_Id))
2528 Append_New_Elmt (Item_Id, Constits_Seen);
2531 end Analyze_Global_Item;
2533 --------------------------
2534 -- Check_Duplicate_Mode --
2535 --------------------------
2537 procedure Check_Duplicate_Mode
2539 Status : in out Boolean)
2543 SPARK_Msg_N ("duplicate global mode", Mode);
2547 end Check_Duplicate_Mode;
2549 -------------------------------------------------
2550 -- Check_Mode_Restriction_In_Enclosing_Context --
2551 -------------------------------------------------
2553 procedure Check_Mode_Restriction_In_Enclosing_Context
2555 Item_Id : Entity_Id)
2557 Context : Entity_Id;
2559 Inputs : Elist_Id := No_Elist;
2560 Outputs : Elist_Id := No_Elist;
2563 -- Traverse the scope stack looking for enclosing subprograms or
2564 -- tasks subject to pragma [Refined_]Global.
2566 Context := Scope (Subp_Id);
2567 while Present (Context) and then Context /= Standard_Standard loop
2569 -- For a single task type, retrieve the corresponding object to
2570 -- which pragma [Refined_]Global is attached.
2572 if Ekind (Context) = E_Task_Type
2573 and then Is_Single_Concurrent_Type (Context)
2575 Context := Anonymous_Object (Context);
2578 if (Is_Subprogram (Context)
2579 or else Ekind (Context) = E_Task_Type
2580 or else Is_Single_Task_Object (Context))
2582 (Present (Get_Pragma (Context, Pragma_Global))
2584 Present (Get_Pragma (Context, Pragma_Refined_Global)))
2586 Collect_Subprogram_Inputs_Outputs
2587 (Subp_Id => Context,
2588 Subp_Inputs => Inputs,
2589 Subp_Outputs => Outputs,
2590 Global_Seen => Dummy);
2592 -- The item is classified as In_Out or Output but appears as
2593 -- an Input in an enclosing subprogram or task unit (SPARK
2596 if Appears_In (Inputs, Item_Id)
2597 and then not Appears_In (Outputs, Item_Id)
2600 ("global item & cannot have mode In_Out or Output",
2603 if Is_Subprogram (Context) then
2605 (Fix_Msg (Subp_Id, "\item already appears as input "
2606 & "of subprogram &"), Item, Context);
2609 (Fix_Msg (Subp_Id, "\item already appears as input "
2610 & "of task &"), Item, Context);
2613 -- Stop the traversal once an error has been detected
2619 Context := Scope (Context);
2621 end Check_Mode_Restriction_In_Enclosing_Context;
2623 ----------------------------------------
2624 -- Check_Mode_Restriction_In_Function --
2625 ----------------------------------------
2627 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
2629 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
2631 ("global mode & is not applicable to functions", Mode);
2633 end Check_Mode_Restriction_In_Function;
2641 -- Start of processing for Analyze_Global_List
2644 if Nkind (List) = N_Null then
2645 Set_Analyzed (List);
2647 -- Single global item declaration
2649 elsif Nkind_In (List, N_Expanded_Name,
2651 N_Selected_Component)
2653 Analyze_Global_Item (List, Global_Mode);
2655 -- Simple global list or moded global list declaration
2657 elsif Nkind (List) = N_Aggregate then
2658 Set_Analyzed (List);
2660 -- The declaration of a simple global list appear as a collection
2663 if Present (Expressions (List)) then
2664 if Present (Component_Associations (List)) then
2666 ("cannot mix moded and non-moded global lists", List);
2669 Item := First (Expressions (List));
2670 while Present (Item) loop
2671 Analyze_Global_Item (Item, Global_Mode);
2675 -- The declaration of a moded global list appears as a collection
2676 -- of component associations where individual choices denote
2679 elsif Present (Component_Associations (List)) then
2680 if Present (Expressions (List)) then
2682 ("cannot mix moded and non-moded global lists", List);
2685 Assoc := First (Component_Associations (List));
2686 while Present (Assoc) loop
2687 Mode := First (Choices (Assoc));
2689 if Nkind (Mode) = N_Identifier then
2690 if Chars (Mode) = Name_In_Out then
2691 Check_Duplicate_Mode (Mode, In_Out_Seen);
2692 Check_Mode_Restriction_In_Function (Mode);
2694 elsif Chars (Mode) = Name_Input then
2695 Check_Duplicate_Mode (Mode, Input_Seen);
2697 elsif Chars (Mode) = Name_Output then
2698 Check_Duplicate_Mode (Mode, Output_Seen);
2699 Check_Mode_Restriction_In_Function (Mode);
2701 elsif Chars (Mode) = Name_Proof_In then
2702 Check_Duplicate_Mode (Mode, Proof_Seen);
2705 SPARK_Msg_N ("invalid mode selector", Mode);
2709 SPARK_Msg_N ("invalid mode selector", Mode);
2712 -- Items in a moded list appear as a collection of
2713 -- expressions. Reuse the existing machinery to analyze
2717 (List => Expression (Assoc),
2718 Global_Mode => Chars (Mode));
2726 raise Program_Error;
2729 -- Any other attempt to declare a global item is illegal. This is a
2730 -- syntax error, always report.
2733 Error_Msg_N ("malformed global list", List);
2735 end Analyze_Global_List;
2739 Items : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
2741 Restore_Scope : Boolean := False;
2743 -- Start of processing for Analyze_Global_In_Decl_Part
2746 -- Do not analyze the pragma multiple times
2748 if Is_Analyzed_Pragma (N) then
2752 -- There is nothing to be done for a null global list
2754 if Nkind (Items) = N_Null then
2755 Set_Analyzed (Items);
2757 -- Analyze the various forms of global lists and items. Note that some
2758 -- of these may be malformed in which case the analysis emits error
2762 -- When pragma [Refined_]Global appears on a single concurrent type,
2763 -- it is relocated to the anonymous object.
2765 if Is_Single_Concurrent_Object (Spec_Id) then
2768 -- Ensure that the formal parameters are visible when processing an
2769 -- item. This falls out of the general rule of aspects pertaining to
2770 -- subprogram declarations.
2772 elsif not In_Open_Scopes (Spec_Id) then
2773 Restore_Scope := True;
2774 Push_Scope (Spec_Id);
2776 if Ekind (Spec_Id) = E_Task_Type then
2777 if Has_Discriminants (Spec_Id) then
2778 Install_Discriminants (Spec_Id);
2781 elsif Is_Generic_Subprogram (Spec_Id) then
2782 Install_Generic_Formals (Spec_Id);
2785 Install_Formals (Spec_Id);
2789 Analyze_Global_List (Items);
2791 if Restore_Scope then
2796 -- Ensure that a state and a corresponding constituent do not appear
2797 -- together in pragma [Refined_]Global.
2799 Check_State_And_Constituent_Use
2800 (States => States_Seen,
2801 Constits => Constits_Seen,
2804 Set_Is_Analyzed_Pragma (N);
2805 end Analyze_Global_In_Decl_Part;
2807 --------------------------------------------
2808 -- Analyze_Initial_Condition_In_Decl_Part --
2809 --------------------------------------------
2811 -- WARNING: This routine manages Ghost regions. Return statements must be
2812 -- replaced by gotos which jump to the end of the routine and restore the
2815 procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is
2816 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2817 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2818 Expr : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
2820 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
2821 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
2822 -- Save the Ghost-related attributes to restore on exit
2825 -- Do not analyze the pragma multiple times
2827 if Is_Analyzed_Pragma (N) then
2831 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2832 -- analysis of the pragma, the Ghost mode at point of declaration and
2833 -- point of analysis may not necessarily be the same. Use the mode in
2834 -- effect at the point of declaration.
2838 -- The expression is preanalyzed because it has not been moved to its
2839 -- final place yet. A direct analysis may generate side effects and this
2840 -- is not desired at this point.
2842 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
2843 Set_Is_Analyzed_Pragma (N);
2845 Restore_Ghost_Region (Saved_GM, Saved_IGR);
2846 end Analyze_Initial_Condition_In_Decl_Part;
2848 --------------------------------------
2849 -- Analyze_Initializes_In_Decl_Part --
2850 --------------------------------------
2852 procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is
2853 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2854 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2856 Constits_Seen : Elist_Id := No_Elist;
2857 -- A list containing the entities of all constituents processed so far.
2858 -- It aids in detecting illegal usage of a state and a corresponding
2859 -- constituent in pragma Initializes.
2861 Items_Seen : Elist_Id := No_Elist;
2862 -- A list of all initialization items processed so far. This list is
2863 -- used to detect duplicate items.
2865 States_And_Objs : Elist_Id := No_Elist;
2866 -- A list of all abstract states and objects declared in the visible
2867 -- declarations of the related package. This list is used to detect the
2868 -- legality of initialization items.
2870 States_Seen : Elist_Id := No_Elist;
2871 -- A list containing the entities of all states processed so far. It
2872 -- helps in detecting illegal usage of a state and a corresponding
2873 -- constituent in pragma Initializes.
2875 procedure Analyze_Initialization_Item (Item : Node_Id);
2876 -- Verify the legality of a single initialization item
2878 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id);
2879 -- Verify the legality of a single initialization item followed by a
2880 -- list of input items.
2882 procedure Collect_States_And_Objects;
2883 -- Inspect the visible declarations of the related package and gather
2884 -- the entities of all abstract states and objects in States_And_Objs.
2886 ---------------------------------
2887 -- Analyze_Initialization_Item --
2888 ---------------------------------
2890 procedure Analyze_Initialization_Item (Item : Node_Id) is
2891 Item_Id : Entity_Id;
2895 Resolve_State (Item);
2897 if Is_Entity_Name (Item) then
2898 Item_Id := Entity_Of (Item);
2900 if Present (Item_Id)
2901 and then Ekind_In (Item_Id, E_Abstract_State,
2905 -- When the initialization item is undefined, it appears as
2906 -- Any_Id. Do not continue with the analysis of the item.
2908 if Item_Id = Any_Id then
2911 -- The state or variable must be declared in the visible
2912 -- declarations of the package (SPARK RM 7.1.5(7)).
2914 elsif not Contains (States_And_Objs, Item_Id) then
2915 Error_Msg_Name_1 := Chars (Pack_Id);
2917 ("initialization item & must appear in the visible "
2918 & "declarations of package %", Item, Item_Id);
2920 -- Detect a duplicate use of the same initialization item
2921 -- (SPARK RM 7.1.5(5)).
2923 elsif Contains (Items_Seen, Item_Id) then
2924 SPARK_Msg_N ("duplicate initialization item", Item);
2926 -- The item is legal, add it to the list of processed states
2930 Append_New_Elmt (Item_Id, Items_Seen);
2932 if Ekind (Item_Id) = E_Abstract_State then
2933 Append_New_Elmt (Item_Id, States_Seen);
2936 if Present (Encapsulating_State (Item_Id)) then
2937 Append_New_Elmt (Item_Id, Constits_Seen);
2941 -- The item references something that is not a state or object
2942 -- (SPARK RM 7.1.5(3)).
2946 ("initialization item must denote object or state", Item);
2949 -- Some form of illegal construct masquerading as a name
2950 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2954 ("initialization item must denote object or state", Item);
2956 end Analyze_Initialization_Item;
2958 ---------------------------------------------
2959 -- Analyze_Initialization_Item_With_Inputs --
2960 ---------------------------------------------
2962 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is
2963 Inputs_Seen : Elist_Id := No_Elist;
2964 -- A list of all inputs processed so far. This list is used to detect
2965 -- duplicate uses of an input.
2967 Non_Null_Seen : Boolean := False;
2968 Null_Seen : Boolean := False;
2969 -- Flags used to check the legality of an input list
2971 procedure Analyze_Input_Item (Input : Node_Id);
2972 -- Verify the legality of a single input item
2974 ------------------------
2975 -- Analyze_Input_Item --
2976 ------------------------
2978 procedure Analyze_Input_Item (Input : Node_Id) is
2979 Input_Id : Entity_Id;
2984 if Nkind (Input) = N_Null then
2987 ("multiple null initializations not allowed", Item);
2989 elsif Non_Null_Seen then
2991 ("cannot mix null and non-null initialization item", Item);
2999 Non_Null_Seen := True;
3003 ("cannot mix null and non-null initialization item", Item);
3007 Resolve_State (Input);
3009 if Is_Entity_Name (Input) then
3010 Input_Id := Entity_Of (Input);
3012 if Present (Input_Id)
3013 and then Ekind_In (Input_Id, E_Abstract_State,
3015 E_Generic_In_Out_Parameter,
3016 E_Generic_In_Parameter,
3024 -- The input cannot denote states or objects declared
3025 -- within the related package (SPARK RM 7.1.5(4)).
3027 if Within_Scope (Input_Id, Current_Scope) then
3029 -- Do not consider generic formal parameters or their
3030 -- respective mappings to generic formals. Even though
3031 -- the formals appear within the scope of the package,
3032 -- it is allowed for an initialization item to depend
3033 -- on an input item.
3035 if Ekind_In (Input_Id, E_Generic_In_Out_Parameter,
3036 E_Generic_In_Parameter)
3040 elsif Ekind_In (Input_Id, E_Constant, E_Variable)
3041 and then Present (Corresponding_Generic_Association
3042 (Declaration_Node (Input_Id)))
3047 Error_Msg_Name_1 := Chars (Pack_Id);
3049 ("input item & cannot denote a visible object or "
3050 & "state of package %", Input, Input_Id);
3055 -- Detect a duplicate use of the same input item
3056 -- (SPARK RM 7.1.5(5)).
3058 if Contains (Inputs_Seen, Input_Id) then
3059 SPARK_Msg_N ("duplicate input item", Input);
3063 -- At this point it is known that the input is legal. Add
3064 -- it to the list of processed inputs.
3066 Append_New_Elmt (Input_Id, Inputs_Seen);
3068 if Ekind (Input_Id) = E_Abstract_State then
3069 Append_New_Elmt (Input_Id, States_Seen);
3072 if Ekind_In (Input_Id, E_Abstract_State,
3075 and then Present (Encapsulating_State (Input_Id))
3077 Append_New_Elmt (Input_Id, Constits_Seen);
3080 -- The input references something that is not a state or an
3081 -- object (SPARK RM 7.1.5(3)).
3085 ("input item must denote object or state", Input);
3088 -- Some form of illegal construct masquerading as a name
3089 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
3093 ("input item must denote object or state", Input);
3096 end Analyze_Input_Item;
3100 Inputs : constant Node_Id := Expression (Item);
3104 Name_Seen : Boolean := False;
3105 -- A flag used to detect multiple item names
3107 -- Start of processing for Analyze_Initialization_Item_With_Inputs
3110 -- Inspect the name of an item with inputs
3112 Elmt := First (Choices (Item));
3113 while Present (Elmt) loop
3115 SPARK_Msg_N ("only one item allowed in initialization", Elmt);
3118 Analyze_Initialization_Item (Elmt);
3124 -- Multiple input items appear as an aggregate
3126 if Nkind (Inputs) = N_Aggregate then
3127 if Present (Expressions (Inputs)) then
3128 Input := First (Expressions (Inputs));
3129 while Present (Input) loop
3130 Analyze_Input_Item (Input);
3135 if Present (Component_Associations (Inputs)) then
3137 ("inputs must appear in named association form", Inputs);
3140 -- Single input item
3143 Analyze_Input_Item (Inputs);
3145 end Analyze_Initialization_Item_With_Inputs;
3147 --------------------------------
3148 -- Collect_States_And_Objects --
3149 --------------------------------
3151 procedure Collect_States_And_Objects is
3152 Pack_Spec : constant Node_Id := Specification (Pack_Decl);
3156 -- Collect the abstract states defined in the package (if any)
3158 if Present (Abstract_States (Pack_Id)) then
3159 States_And_Objs := New_Copy_Elist (Abstract_States (Pack_Id));
3162 -- Collect all objects that appear in the visible declarations of the
3165 if Present (Visible_Declarations (Pack_Spec)) then
3166 Decl := First (Visible_Declarations (Pack_Spec));
3167 while Present (Decl) loop
3168 if Comes_From_Source (Decl)
3169 and then Nkind_In (Decl, N_Object_Declaration,
3170 N_Object_Renaming_Declaration)
3172 Append_New_Elmt (Defining_Entity (Decl), States_And_Objs);
3174 elsif Is_Single_Concurrent_Type_Declaration (Decl) then
3176 (Anonymous_Object (Defining_Entity (Decl)),
3183 end Collect_States_And_Objects;
3187 Inits : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
3190 -- Start of processing for Analyze_Initializes_In_Decl_Part
3193 -- Do not analyze the pragma multiple times
3195 if Is_Analyzed_Pragma (N) then
3199 -- Nothing to do when the initialization list is empty
3201 if Nkind (Inits) = N_Null then
3205 -- Single and multiple initialization clauses appear as an aggregate. If
3206 -- this is not the case, then either the parser or the analysis of the
3207 -- pragma failed to produce an aggregate.
3209 pragma Assert (Nkind (Inits) = N_Aggregate);
3211 -- Initialize the various lists used during analysis
3213 Collect_States_And_Objects;
3215 if Present (Expressions (Inits)) then
3216 Init := First (Expressions (Inits));
3217 while Present (Init) loop
3218 Analyze_Initialization_Item (Init);
3223 if Present (Component_Associations (Inits)) then
3224 Init := First (Component_Associations (Inits));
3225 while Present (Init) loop
3226 Analyze_Initialization_Item_With_Inputs (Init);
3231 -- Ensure that a state and a corresponding constituent do not appear
3232 -- together in pragma Initializes.
3234 Check_State_And_Constituent_Use
3235 (States => States_Seen,
3236 Constits => Constits_Seen,
3239 Set_Is_Analyzed_Pragma (N);
3240 end Analyze_Initializes_In_Decl_Part;
3242 ---------------------
3243 -- Analyze_Part_Of --
3244 ---------------------
3246 procedure Analyze_Part_Of
3248 Item_Id : Entity_Id;
3250 Encap_Id : out Entity_Id;
3251 Legal : out Boolean)
3253 procedure Check_Part_Of_Abstract_State;
3254 pragma Inline (Check_Part_Of_Abstract_State);
3255 -- Verify the legality of indicator Part_Of when the encapsulator is an
3258 procedure Check_Part_Of_Concurrent_Type;
3259 pragma Inline (Check_Part_Of_Concurrent_Type);
3260 -- Verify the legality of indicator Part_Of when the encapsulator is a
3261 -- single concurrent type.
3263 ----------------------------------
3264 -- Check_Part_Of_Abstract_State --
3265 ----------------------------------
3267 procedure Check_Part_Of_Abstract_State is
3268 Pack_Id : Entity_Id;
3269 Placement : State_Space_Kind;
3270 Parent_Unit : Entity_Id;
3273 -- Determine where the object, package instantiation or state lives
3274 -- with respect to the enclosing packages or package bodies.
3276 Find_Placement_In_State_Space
3277 (Item_Id => Item_Id,
3278 Placement => Placement,
3279 Pack_Id => Pack_Id);
3281 -- The item appears in a non-package construct with a declarative
3282 -- part (subprogram, block, etc). As such, the item is not allowed
3283 -- to be a part of an encapsulating state because the item is not
3286 if Placement = Not_In_Package then
3288 ("indicator Part_Of cannot appear in this context "
3289 & "(SPARK RM 7.2.6(5))", Indic);
3291 Error_Msg_Name_1 := Chars (Scope (Encap_Id));
3293 ("\& is not part of the hidden state of package %",
3297 -- The item appears in the visible state space of some package. In
3298 -- general this scenario does not warrant Part_Of except when the
3299 -- package is a nongeneric private child unit and the encapsulating
3300 -- state is declared in a parent unit or a public descendant of that
3303 elsif Placement = Visible_State_Space then
3304 if Is_Child_Unit (Pack_Id)
3305 and then not Is_Generic_Unit (Pack_Id)
3306 and then Is_Private_Descendant (Pack_Id)
3308 -- A variable or state abstraction which is part of the visible
3309 -- state of a nongeneric private child unit or its public
3310 -- descendants must have its Part_Of indicator specified. The
3311 -- Part_Of indicator must denote a state declared by either the
3312 -- parent unit of the private unit or by a public descendant of
3313 -- that parent unit.
3315 -- Find the nearest private ancestor (which can be the current
3318 Parent_Unit := Pack_Id;
3319 while Present (Parent_Unit) loop
3322 (Parent (Unit_Declaration_Node (Parent_Unit)));
3323 Parent_Unit := Scope (Parent_Unit);
3326 Parent_Unit := Scope (Parent_Unit);
3328 if not Is_Child_Or_Sibling (Pack_Id, Scope (Encap_Id)) then
3330 ("indicator Part_Of must denote abstract state of & or of "
3331 & "its public descendant (SPARK RM 7.2.6(3))",
3332 Indic, Parent_Unit);
3335 elsif Scope (Encap_Id) = Parent_Unit
3337 (Is_Ancestor_Package (Parent_Unit, Scope (Encap_Id))
3338 and then not Is_Private_Descendant (Scope (Encap_Id)))
3344 ("indicator Part_Of must denote abstract state of & or of "
3345 & "its public descendant (SPARK RM 7.2.6(3))",
3346 Indic, Parent_Unit);
3350 -- Indicator Part_Of is not needed when the related package is
3351 -- not a nongeneric private child unit or a public descendant
3356 ("indicator Part_Of cannot appear in this context "
3357 & "(SPARK RM 7.2.6(5))", Indic);
3359 Error_Msg_Name_1 := Chars (Pack_Id);
3361 ("\& is declared in the visible part of package %",
3366 -- When the item appears in the private state space of a package, the
3367 -- encapsulating state must be declared in the same package.
3369 elsif Placement = Private_State_Space then
3370 if Scope (Encap_Id) /= Pack_Id then
3372 ("indicator Part_Of must denote an abstract state of "
3373 & "package & (SPARK RM 7.2.6(2))", Indic, Pack_Id);
3375 Error_Msg_Name_1 := Chars (Pack_Id);
3377 ("\& is declared in the private part of package %",
3382 -- Items declared in the body state space of a package do not need
3383 -- Part_Of indicators as the refinement has already been seen.
3387 ("indicator Part_Of cannot appear in this context "
3388 & "(SPARK RM 7.2.6(5))", Indic);
3390 if Scope (Encap_Id) = Pack_Id then
3391 Error_Msg_Name_1 := Chars (Pack_Id);
3393 ("\& is declared in the body of package %", Indic, Item_Id);
3399 -- At this point it is known that the Part_Of indicator is legal
3402 end Check_Part_Of_Abstract_State;
3404 -----------------------------------
3405 -- Check_Part_Of_Concurrent_Type --
3406 -----------------------------------
3408 procedure Check_Part_Of_Concurrent_Type is
3409 function In_Proper_Order
3411 Second : Node_Id) return Boolean;
3412 pragma Inline (In_Proper_Order);
3413 -- Determine whether node First precedes node Second
3415 procedure Placement_Error;
3416 pragma Inline (Placement_Error);
3417 -- Emit an error concerning the illegal placement of the item with
3418 -- respect to the single concurrent type.
3420 ---------------------
3421 -- In_Proper_Order --
3422 ---------------------
3424 function In_Proper_Order
3426 Second : Node_Id) return Boolean
3431 if List_Containing (First) = List_Containing (Second) then
3433 while Present (N) loop
3443 end In_Proper_Order;
3445 ---------------------
3446 -- Placement_Error --
3447 ---------------------
3449 procedure Placement_Error is
3452 ("indicator Part_Of must denote a previously declared single "
3453 & "protected type or single task type", Encap);
3454 end Placement_Error;
3458 Conc_Typ : constant Entity_Id := Etype (Encap_Id);
3459 Encap_Decl : constant Node_Id := Declaration_Node (Encap_Id);
3460 Encap_Context : constant Node_Id := Parent (Encap_Decl);
3462 Item_Context : Node_Id;
3463 Item_Decl : Node_Id;
3464 Prv_Decls : List_Id;
3465 Vis_Decls : List_Id;
3467 -- Start of processing for Check_Part_Of_Concurrent_Type
3470 -- Only abstract states and variables can act as constituents of an
3471 -- encapsulating single concurrent type.
3473 if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
3476 -- The constituent is a constant
3478 elsif Ekind (Item_Id) = E_Constant then
3479 Error_Msg_Name_1 := Chars (Encap_Id);
3481 (Fix_Msg (Conc_Typ, "constant & cannot act as constituent of "
3482 & "single protected type %"), Indic, Item_Id);
3485 -- The constituent is a package instantiation
3488 Error_Msg_Name_1 := Chars (Encap_Id);
3490 (Fix_Msg (Conc_Typ, "package instantiation & cannot act as "
3491 & "constituent of single protected type %"), Indic, Item_Id);
3495 -- When the item denotes an abstract state of a nested package, use
3496 -- the declaration of the package to detect proper placement.
3501 -- with Abstract_State => (State with Part_Of => T)
3503 if Ekind (Item_Id) = E_Abstract_State then
3504 Item_Decl := Unit_Declaration_Node (Scope (Item_Id));
3506 Item_Decl := Declaration_Node (Item_Id);
3509 Item_Context := Parent (Item_Decl);
3511 -- The item and the single concurrent type must appear in the same
3512 -- declarative region, with the item following the declaration of
3513 -- the single concurrent type (SPARK RM 9(3)).
3515 if Item_Context = Encap_Context then
3516 if Nkind_In (Item_Context, N_Package_Specification,
3517 N_Protected_Definition,
3520 Prv_Decls := Private_Declarations (Item_Context);
3521 Vis_Decls := Visible_Declarations (Item_Context);
3523 -- The placement is OK when the single concurrent type appears
3524 -- within the visible declarations and the item in the private
3530 -- Constit : ... with Part_Of => PO;
3533 if List_Containing (Encap_Decl) = Vis_Decls
3534 and then List_Containing (Item_Decl) = Prv_Decls
3538 -- The placement is illegal when the item appears within the
3539 -- visible declarations and the single concurrent type is in
3540 -- the private declarations.
3543 -- Constit : ... with Part_Of => PO;
3548 elsif List_Containing (Item_Decl) = Vis_Decls
3549 and then List_Containing (Encap_Decl) = Prv_Decls
3554 -- Otherwise both the item and the single concurrent type are
3555 -- in the same list. Ensure that the declaration of the single
3556 -- concurrent type precedes that of the item.
3558 elsif not In_Proper_Order
3559 (First => Encap_Decl,
3560 Second => Item_Decl)
3566 -- Otherwise both the item and the single concurrent type are
3567 -- in the same list. Ensure that the declaration of the single
3568 -- concurrent type precedes that of the item.
3570 elsif not In_Proper_Order
3571 (First => Encap_Decl,
3572 Second => Item_Decl)
3578 -- Otherwise the item and the single concurrent type reside within
3579 -- unrelated regions.
3582 Error_Msg_Name_1 := Chars (Encap_Id);
3584 (Fix_Msg (Conc_Typ, "constituent & must be declared "
3585 & "immediately within the same region as single protected "
3586 & "type %"), Indic, Item_Id);
3590 -- At this point it is known that the Part_Of indicator is legal
3593 end Check_Part_Of_Concurrent_Type;
3595 -- Start of processing for Analyze_Part_Of
3598 -- Assume that the indicator is illegal
3603 if Nkind_In (Encap, N_Expanded_Name,
3605 N_Selected_Component)
3608 Resolve_State (Encap);
3610 Encap_Id := Entity (Encap);
3612 -- The encapsulator is an abstract state
3614 if Ekind (Encap_Id) = E_Abstract_State then
3617 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
3619 elsif Is_Single_Concurrent_Object (Encap_Id) then
3622 -- Otherwise the encapsulator is not a legal choice
3626 ("indicator Part_Of must denote abstract state, single "
3627 & "protected type or single task type", Encap);
3631 -- This is a syntax error, always report
3635 ("indicator Part_Of must denote abstract state, single protected "
3636 & "type or single task type", Encap);
3640 -- Catch a case where indicator Part_Of denotes the abstract view of a
3641 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3643 if From_Limited_With (Encap_Id)
3644 and then Present (Non_Limited_View (Encap_Id))
3645 and then Ekind (Non_Limited_View (Encap_Id)) = E_Variable
3647 SPARK_Msg_N ("indicator Part_Of must denote abstract state", Encap);
3648 SPARK_Msg_N ("\& denotes abstract view of object", Encap);
3652 -- The encapsulator is an abstract state
3654 if Ekind (Encap_Id) = E_Abstract_State then
3655 Check_Part_Of_Abstract_State;
3657 -- The encapsulator is a single concurrent type
3660 Check_Part_Of_Concurrent_Type;
3662 end Analyze_Part_Of;
3664 ----------------------------------
3665 -- Analyze_Part_Of_In_Decl_Part --
3666 ----------------------------------
3668 procedure Analyze_Part_Of_In_Decl_Part
3670 Freeze_Id : Entity_Id := Empty)
3672 Encap : constant Node_Id :=
3673 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
3674 Errors : constant Nat := Serious_Errors_Detected;
3675 Var_Decl : constant Node_Id := Find_Related_Context (N);
3676 Var_Id : constant Entity_Id := Defining_Entity (Var_Decl);
3677 Constits : Elist_Id;
3678 Encap_Id : Entity_Id;
3682 -- Detect any discrepancies between the placement of the variable with
3683 -- respect to general state space and the encapsulating state or single
3690 Encap_Id => Encap_Id,
3693 -- The Part_Of indicator turns the variable into a constituent of the
3694 -- encapsulating state or single concurrent type.
3697 pragma Assert (Present (Encap_Id));
3698 Constits := Part_Of_Constituents (Encap_Id);
3700 if No (Constits) then
3701 Constits := New_Elmt_List;
3702 Set_Part_Of_Constituents (Encap_Id, Constits);
3705 Append_Elmt (Var_Id, Constits);
3706 Set_Encapsulating_State (Var_Id, Encap_Id);
3708 -- A Part_Of constituent partially refines an abstract state. This
3709 -- property does not apply to protected or task units.
3711 if Ekind (Encap_Id) = E_Abstract_State then
3712 Set_Has_Partial_Visible_Refinement (Encap_Id);
3716 -- Emit a clarification message when the encapsulator is undefined,
3717 -- possibly due to contract freezing.
3719 if Errors /= Serious_Errors_Detected
3720 and then Present (Freeze_Id)
3721 and then Has_Undefined_Reference (Encap)
3723 Contract_Freeze_Error (Var_Id, Freeze_Id);
3725 end Analyze_Part_Of_In_Decl_Part;
3727 --------------------
3728 -- Analyze_Pragma --
3729 --------------------
3731 procedure Analyze_Pragma (N : Node_Id) is
3732 Loc : constant Source_Ptr := Sloc (N);
3734 Pname : Name_Id := Pragma_Name (N);
3735 -- Name of the source pragma, or name of the corresponding aspect for
3736 -- pragmas which originate in a source aspect. In the latter case, the
3737 -- name may be different from the pragma name.
3739 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
3741 Pragma_Exit : exception;
3742 -- This exception is used to exit pragma processing completely. It
3743 -- is used when an error is detected, and no further processing is
3744 -- required. It is also used if an earlier error has left the tree in
3745 -- a state where the pragma should not be processed.
3748 -- Number of pragma argument associations
3754 -- First four pragma arguments (pragma argument association nodes, or
3755 -- Empty if the corresponding argument does not exist).
3757 type Name_List is array (Natural range <>) of Name_Id;
3758 type Args_List is array (Natural range <>) of Node_Id;
3759 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3761 -----------------------
3762 -- Local Subprograms --
3763 -----------------------
3765 function Acc_First (N : Node_Id) return Node_Id;
3766 -- Helper function to iterate over arguments given to OpenAcc pragmas
3768 function Acc_Next (N : Node_Id) return Node_Id;
3769 -- Helper function to iterate over arguments given to OpenAcc pragmas
3771 procedure Ada_2005_Pragma;
3772 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3773 -- Ada 95 mode, these are implementation defined pragmas, so should be
3774 -- caught by the No_Implementation_Pragmas restriction.
3776 procedure Ada_2012_Pragma;
3777 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3778 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3779 -- should be caught by the No_Implementation_Pragmas restriction.
3781 procedure Analyze_Depends_Global
3782 (Spec_Id : out Entity_Id;
3783 Subp_Decl : out Node_Id;
3784 Legal : out Boolean);
3785 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3786 -- legality of the placement and related context of the pragma. Spec_Id
3787 -- is the entity of the related subprogram. Subp_Decl is the declaration
3788 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3790 procedure Analyze_If_Present (Id : Pragma_Id);
3791 -- Inspect the remainder of the list containing pragma N and look for
3792 -- a pragma that matches Id. If found, analyze the pragma.
3794 procedure Analyze_Pre_Post_Condition;
3795 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3797 procedure Analyze_Refined_Depends_Global_Post
3798 (Spec_Id : out Entity_Id;
3799 Body_Id : out Entity_Id;
3800 Legal : out Boolean);
3801 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3802 -- Refined_Global and Refined_Post. Verify the legality of the placement
3803 -- and related context of the pragma. Spec_Id is the entity of the
3804 -- related subprogram. Body_Id is the entity of the subprogram body.
3805 -- Flag Legal is set when the pragma is legal.
3807 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False);
3808 -- Perform full analysis of pragma Unmodified and the write aspect of
3809 -- pragma Unused. Flag Is_Unused should be set when verifying the
3810 -- semantics of pragma Unused.
3812 procedure Analyze_Unreferenced_Or_Unused (Is_Unused : Boolean := False);
3813 -- Perform full analysis of pragma Unreferenced and the read aspect of
3814 -- pragma Unused. Flag Is_Unused should be set when verifying the
3815 -- semantics of pragma Unused.
3817 procedure Check_Ada_83_Warning;
3818 -- Issues a warning message for the current pragma if operating in Ada
3819 -- 83 mode (used for language pragmas that are not a standard part of
3820 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3823 procedure Check_Arg_Count (Required : Nat);
3824 -- Check argument count for pragma is equal to given parameter. If not,
3825 -- then issue an error message and raise Pragma_Exit.
3827 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3828 -- Arg which can either be a pragma argument association, in which case
3829 -- the check is applied to the expression of the association or an
3830 -- expression directly.
3832 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
3833 -- Check that an argument has the right form for an EXTERNAL_NAME
3834 -- parameter of an extended import/export pragma. The rule is that the
3835 -- name must be an identifier or string literal (in Ada 83 mode) or a
3836 -- static string expression (in Ada 95 mode).
3838 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
3839 -- Check the specified argument Arg to make sure that it is an
3840 -- identifier. If not give error and raise Pragma_Exit.
3842 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
3843 -- Check the specified argument Arg to make sure that it is an integer
3844 -- literal. If not give error and raise Pragma_Exit.
3846 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
3847 -- Check the specified argument Arg to make sure that it has the proper
3848 -- syntactic form for a local name and meets the semantic requirements
3849 -- for a local name. The local name is analyzed as part of the
3850 -- processing for this call. In addition, the local name is required
3851 -- to represent an entity at the library level.
3853 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
3854 -- Check the specified argument Arg to make sure that it has the proper
3855 -- syntactic form for a local name and meets the semantic requirements
3856 -- for a local name. The local name is analyzed as part of the
3857 -- processing for this call.
3859 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
3860 -- Check the specified argument Arg to make sure that it is a valid
3861 -- locking policy name. If not give error and raise Pragma_Exit.
3863 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
3864 -- Check the specified argument Arg to make sure that it is a valid
3865 -- elaboration policy name. If not give error and raise Pragma_Exit.
3867 procedure Check_Arg_Is_One_Of
3870 procedure Check_Arg_Is_One_Of
3872 N1, N2, N3 : Name_Id);
3873 procedure Check_Arg_Is_One_Of
3875 N1, N2, N3, N4 : Name_Id);
3876 procedure Check_Arg_Is_One_Of
3878 N1, N2, N3, N4, N5 : Name_Id);
3879 -- Check the specified argument Arg to make sure that it is an
3880 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3881 -- present). If not then give error and raise Pragma_Exit.
3883 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
3884 -- Check the specified argument Arg to make sure that it is a valid
3885 -- queuing policy name. If not give error and raise Pragma_Exit.
3887 procedure Check_Arg_Is_OK_Static_Expression
3889 Typ : Entity_Id := Empty);
3890 -- Check the specified argument Arg to make sure that it is a static
3891 -- expression of the given type (i.e. it will be analyzed and resolved
3892 -- using this type, which can be any valid argument to Resolve, e.g.
3893 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3894 -- Typ is left Empty, then any static expression is allowed. Includes
3895 -- checking that the argument does not raise Constraint_Error.
3897 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
3898 -- Check the specified argument Arg to make sure that it is a valid task
3899 -- dispatching policy name. If not give error and raise Pragma_Exit.
3901 procedure Check_Arg_Order (Names : Name_List);
3902 -- Checks for an instance of two arguments with identifiers for the
3903 -- current pragma which are not in the sequence indicated by Names,
3904 -- and if so, generates a fatal message about bad order of arguments.
3906 procedure Check_At_Least_N_Arguments (N : Nat);
3907 -- Check there are at least N arguments present
3909 procedure Check_At_Most_N_Arguments (N : Nat);
3910 -- Check there are no more than N arguments present
3912 procedure Check_Component
3915 In_Variant_Part : Boolean := False);
3916 -- Examine an Unchecked_Union component for correct use of per-object
3917 -- constrained subtypes, and for restrictions on finalizable components.
3918 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3919 -- should be set when Comp comes from a record variant.
3921 procedure Check_Duplicate_Pragma (E : Entity_Id);
3922 -- Check if a rep item of the same name as the current pragma is already
3923 -- chained as a rep pragma to the given entity. If so give a message
3924 -- about the duplicate, and then raise Pragma_Exit so does not return.
3925 -- Note that if E is a type, then this routine avoids flagging a pragma
3926 -- which applies to a parent type from which E is derived.
3928 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
3929 -- Nam is an N_String_Literal node containing the external name set by
3930 -- an Import or Export pragma (or extended Import or Export pragma).
3931 -- This procedure checks for possible duplications if this is the export
3932 -- case, and if found, issues an appropriate error message.
3934 procedure Check_Expr_Is_OK_Static_Expression
3936 Typ : Entity_Id := Empty);
3937 -- Check the specified expression Expr to make sure that it is a static
3938 -- expression of the given type (i.e. it will be analyzed and resolved
3939 -- using this type, which can be any valid argument to Resolve, e.g.
3940 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3941 -- Typ is left Empty, then any static expression is allowed. Includes
3942 -- checking that the expression does not raise Constraint_Error.
3944 procedure Check_First_Subtype (Arg : Node_Id);
3945 -- Checks that Arg, whose expression is an entity name, references a
3948 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
3949 -- Checks that the given argument has an identifier, and if so, requires
3950 -- it to match the given identifier name. If there is no identifier, or
3951 -- a non-matching identifier, then an error message is given and
3952 -- Pragma_Exit is raised.
3954 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
3955 -- Checks that the given argument has an identifier, and if so, requires
3956 -- it to match one of the given identifier names. If there is no
3957 -- identifier, or a non-matching identifier, then an error message is
3958 -- given and Pragma_Exit is raised.
3960 procedure Check_In_Main_Program;
3961 -- Common checks for pragmas that appear within a main program
3962 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3964 procedure Check_Interrupt_Or_Attach_Handler;
3965 -- Common processing for first argument of pragma Interrupt_Handler or
3966 -- pragma Attach_Handler.
3968 procedure Check_Loop_Pragma_Placement;
3969 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3970 -- appear immediately within a construct restricted to loops, and that
3971 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
3973 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
3974 -- Check that pragma appears in a declarative part, or in a package
3975 -- specification, i.e. that it does not occur in a statement sequence
3978 procedure Check_No_Identifier (Arg : Node_Id);
3979 -- Checks that the given argument does not have an identifier. If
3980 -- an identifier is present, then an error message is issued, and
3981 -- Pragma_Exit is raised.
3983 procedure Check_No_Identifiers;
3984 -- Checks that none of the arguments to the pragma has an identifier.
3985 -- If any argument has an identifier, then an error message is issued,
3986 -- and Pragma_Exit is raised.
3988 procedure Check_No_Link_Name;
3989 -- Checks that no link name is specified
3991 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
3992 -- Checks if the given argument has an identifier, and if so, requires
3993 -- it to match the given identifier name. If there is a non-matching
3994 -- identifier, then an error message is given and Pragma_Exit is raised.
3996 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
3997 -- Checks if the given argument has an identifier, and if so, requires
3998 -- it to match the given identifier name. If there is a non-matching
3999 -- identifier, then an error message is given and Pragma_Exit is raised.
4000 -- In this version of the procedure, the identifier name is given as
4001 -- a string with lower case letters.
4003 procedure Check_Static_Boolean_Expression (Expr : Node_Id);
4004 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
4005 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
4006 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
4007 -- is an OK static boolean expression. Emit an error if this is not the
4010 procedure Check_Static_Constraint (Constr : Node_Id);
4011 -- Constr is a constraint from an N_Subtype_Indication node from a
4012 -- component constraint in an Unchecked_Union type. This routine checks
4013 -- that the constraint is static as required by the restrictions for
4016 procedure Check_Valid_Configuration_Pragma;
4017 -- Legality checks for placement of a configuration pragma
4019 procedure Check_Valid_Library_Unit_Pragma;
4020 -- Legality checks for library unit pragmas. A special case arises for
4021 -- pragmas in generic instances that come from copies of the original
4022 -- library unit pragmas in the generic templates. In the case of other
4023 -- than library level instantiations these can appear in contexts which
4024 -- would normally be invalid (they only apply to the original template
4025 -- and to library level instantiations), and they are simply ignored,
4026 -- which is implemented by rewriting them as null statements.
4028 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
4029 -- Check an Unchecked_Union variant for lack of nested variants and
4030 -- presence of at least one component. UU_Typ is the related Unchecked_
4033 procedure Ensure_Aggregate_Form (Arg : Node_Id);
4034 -- Subsidiary routine to the processing of pragmas Abstract_State,
4035 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
4036 -- Refined_Global and Refined_State. Transform argument Arg into
4037 -- an aggregate if not one already. N_Null is never transformed.
4038 -- Arg may denote an aspect specification or a pragma argument
4041 procedure Error_Pragma (Msg : String);
4042 pragma No_Return (Error_Pragma);
4043 -- Outputs error message for current pragma. The message contains a %
4044 -- that will be replaced with the pragma name, and the flag is placed
4045 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
4046 -- calls Fix_Error (see spec of that procedure for details).
4048 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
4049 pragma No_Return (Error_Pragma_Arg);
4050 -- Outputs error message for current pragma. The message may contain
4051 -- a % that will be replaced with the pragma name. The parameter Arg
4052 -- may either be a pragma argument association, in which case the flag
4053 -- is placed on the expression of this association, or an expression,
4054 -- in which case the flag is placed directly on the expression. The
4055 -- message is placed using Error_Msg_N, so the message may also contain
4056 -- an & insertion character which will reference the given Arg value.
4057 -- After placing the message, Pragma_Exit is raised. Note: this routine
4058 -- calls Fix_Error (see spec of that procedure for details).
4060 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
4061 pragma No_Return (Error_Pragma_Arg);
4062 -- Similar to above form of Error_Pragma_Arg except that two messages
4063 -- are provided, the second is a continuation comment starting with \.
4065 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
4066 pragma No_Return (Error_Pragma_Arg_Ident);
4067 -- Outputs error message for current pragma. The message may contain a %
4068 -- that will be replaced with the pragma name. The parameter Arg must be
4069 -- a pragma argument association with a non-empty identifier (i.e. its
4070 -- Chars field must be set), and the error message is placed on the
4071 -- identifier. The message is placed using Error_Msg_N so the message
4072 -- may also contain an & insertion character which will reference
4073 -- the identifier. After placing the message, Pragma_Exit is raised.
4074 -- Note: this routine calls Fix_Error (see spec of that procedure for
4077 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
4078 pragma No_Return (Error_Pragma_Ref);
4079 -- Outputs error message for current pragma. The message may contain
4080 -- a % that will be replaced with the pragma name. The parameter Ref
4081 -- must be an entity whose name can be referenced by & and sloc by #.
4082 -- After placing the message, Pragma_Exit is raised. Note: this routine
4083 -- calls Fix_Error (see spec of that procedure for details).
4085 function Find_Lib_Unit_Name return Entity_Id;
4086 -- Used for a library unit pragma to find the entity to which the
4087 -- library unit pragma applies, returns the entity found.
4089 procedure Find_Program_Unit_Name (Id : Node_Id);
4090 -- If the pragma is a compilation unit pragma, the id must denote the
4091 -- compilation unit in the same compilation, and the pragma must appear
4092 -- in the list of preceding or trailing pragmas. If it is a program
4093 -- unit pragma that is not a compilation unit pragma, then the
4094 -- identifier must be visible.
4096 function Find_Unique_Parameterless_Procedure
4098 Arg : Node_Id) return Entity_Id;
4099 -- Used for a procedure pragma to find the unique parameterless
4100 -- procedure identified by Name, returns it if it exists, otherwise
4101 -- errors out and uses Arg as the pragma argument for the message.
4103 function Fix_Error (Msg : String) return String;
4104 -- This is called prior to issuing an error message. Msg is the normal
4105 -- error message issued in the pragma case. This routine checks for the
4106 -- case of a pragma coming from an aspect in the source, and returns a
4107 -- message suitable for the aspect case as follows:
4109 -- Each substring "pragma" is replaced by "aspect"
4111 -- If "argument of" is at the start of the error message text, it is
4112 -- replaced by "entity for".
4114 -- If "argument" is at the start of the error message text, it is
4115 -- replaced by "entity".
4117 -- So for example, "argument of pragma X must be discrete type"
4118 -- returns "entity for aspect X must be a discrete type".
4120 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
4121 -- be different from the pragma name). If the current pragma results
4122 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
4123 -- original pragma name.
4125 procedure Gather_Associations
4127 Args : out Args_List);
4128 -- This procedure is used to gather the arguments for a pragma that
4129 -- permits arbitrary ordering of parameters using the normal rules
4130 -- for named and positional parameters. The Names argument is a list
4131 -- of Name_Id values that corresponds to the allowed pragma argument
4132 -- association identifiers in order. The result returned in Args is
4133 -- a list of corresponding expressions that are the pragma arguments.
4134 -- Note that this is a list of expressions, not of pragma argument
4135 -- associations (Gather_Associations has completely checked all the
4136 -- optional identifiers when it returns). An entry in Args is Empty
4137 -- on return if the corresponding argument is not present.
4139 procedure GNAT_Pragma;
4140 -- Called for all GNAT defined pragmas to check the relevant restriction
4141 -- (No_Implementation_Pragmas).
4143 function Is_Before_First_Decl
4144 (Pragma_Node : Node_Id;
4145 Decls : List_Id) return Boolean;
4146 -- Return True if Pragma_Node is before the first declarative item in
4147 -- Decls where Decls is the list of declarative items.
4149 function Is_Configuration_Pragma return Boolean;
4150 -- Determines if the placement of the current pragma is appropriate
4151 -- for a configuration pragma.
4153 function Is_In_Context_Clause return Boolean;
4154 -- Returns True if pragma appears within the context clause of a unit,
4155 -- and False for any other placement (does not generate any messages).
4157 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
4158 -- Analyzes the argument, and determines if it is a static string
4159 -- expression, returns True if so, False if non-static or not String.
4160 -- A special case is that a string literal returns True in Ada 83 mode
4161 -- (which has no such thing as static string expressions). Note that
4162 -- the call analyzes its argument, so this cannot be used for the case
4163 -- where an identifier might not be declared.
4165 procedure Pragma_Misplaced;
4166 pragma No_Return (Pragma_Misplaced);
4167 -- Issue fatal error message for misplaced pragma
4169 procedure Process_Atomic_Independent_Shared_Volatile;
4170 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
4171 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
4172 -- and treated as being identical in effect to pragma Atomic.
4174 procedure Process_Compile_Time_Warning_Or_Error;
4175 -- Common processing for Compile_Time_Error and Compile_Time_Warning
4177 procedure Process_Convention
4178 (C : out Convention_Id;
4179 Ent : out Entity_Id);
4180 -- Common processing for Convention, Interface, Import and Export.
4181 -- Checks first two arguments of pragma, and sets the appropriate
4182 -- convention value in the specified entity or entities. On return
4183 -- C is the convention, Ent is the referenced entity.
4185 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
4186 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
4187 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
4189 procedure Process_Extended_Import_Export_Object_Pragma
4190 (Arg_Internal : Node_Id;
4191 Arg_External : Node_Id;
4192 Arg_Size : Node_Id);
4193 -- Common processing for the pragmas Import/Export_Object. The three
4194 -- arguments correspond to the three named parameters of the pragmas. An
4195 -- argument is empty if the corresponding parameter is not present in
4198 procedure Process_Extended_Import_Export_Internal_Arg
4199 (Arg_Internal : Node_Id := Empty);
4200 -- Common processing for all extended Import and Export pragmas. The
4201 -- argument is the pragma parameter for the Internal argument. If
4202 -- Arg_Internal is empty or inappropriate, an error message is posted.
4203 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
4204 -- set to identify the referenced entity.
4206 procedure Process_Extended_Import_Export_Subprogram_Pragma
4207 (Arg_Internal : Node_Id;
4208 Arg_External : Node_Id;
4209 Arg_Parameter_Types : Node_Id;
4210 Arg_Result_Type : Node_Id := Empty;
4211 Arg_Mechanism : Node_Id;
4212 Arg_Result_Mechanism : Node_Id := Empty);
4213 -- Common processing for all extended Import and Export pragmas applying
4214 -- to subprograms. The caller omits any arguments that do not apply to
4215 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
4216 -- only in the Import_Function and Export_Function cases). The argument
4217 -- names correspond to the allowed pragma association identifiers.
4219 procedure Process_Generic_List;
4220 -- Common processing for Share_Generic and Inline_Generic
4222 procedure Process_Import_Or_Interface;
4223 -- Common processing for Import or Interface
4225 procedure Process_Import_Predefined_Type;
4226 -- Processing for completing a type with pragma Import. This is used
4227 -- to declare types that match predefined C types, especially for cases
4228 -- without corresponding Ada predefined type.
4230 type Inline_Status is (Suppressed, Disabled, Enabled);
4231 -- Inline status of a subprogram, indicated as follows:
4232 -- Suppressed: inlining is suppressed for the subprogram
4233 -- Disabled: no inlining is requested for the subprogram
4234 -- Enabled: inlining is requested/required for the subprogram
4236 procedure Process_Inline (Status : Inline_Status);
4237 -- Common processing for No_Inline, Inline and Inline_Always. Parameter
4238 -- indicates the inline status specified by the pragma.
4240 procedure Process_Interface_Name
4241 (Subprogram_Def : Entity_Id;
4245 -- Given the last two arguments of pragma Import, pragma Export, or
4246 -- pragma Interface_Name, performs validity checks and sets the
4247 -- Interface_Name field of the given subprogram entity to the
4248 -- appropriate external or link name, depending on the arguments given.
4249 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
4250 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
4251 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
4252 -- nor Link_Arg is present, the interface name is set to the default
4253 -- from the subprogram name. In addition, the pragma itself is passed
4254 -- to analyze any expressions in the case the pragma came from an aspect
4257 procedure Process_Interrupt_Or_Attach_Handler;
4258 -- Common processing for Interrupt and Attach_Handler pragmas
4260 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
4261 -- Common processing for Restrictions and Restriction_Warnings pragmas.
4262 -- Warn is True for Restriction_Warnings, or for Restrictions if the
4263 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
4264 -- is not set in the Restrictions case.
4266 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
4267 -- Common processing for Suppress and Unsuppress. The boolean parameter
4268 -- Suppress_Case is True for the Suppress case, and False for the
4271 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id);
4272 -- Subsidiary to the analysis of pragmas Independent[_Components].
4273 -- Record such a pragma N applied to entity E for future checks.
4275 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
4276 -- This procedure sets the Is_Exported flag for the given entity,
4277 -- checking that the entity was not previously imported. Arg is
4278 -- the argument that specified the entity. A check is also made
4279 -- for exporting inappropriate entities.
4281 procedure Set_Extended_Import_Export_External_Name
4282 (Internal_Ent : Entity_Id;
4283 Arg_External : Node_Id);
4284 -- Common processing for all extended import export pragmas. The first
4285 -- argument, Internal_Ent, is the internal entity, which has already
4286 -- been checked for validity by the caller. Arg_External is from the
4287 -- Import or Export pragma, and may be null if no External parameter
4288 -- was present. If Arg_External is present and is a non-null string
4289 -- (a null string is treated as the default), then the Interface_Name
4290 -- field of Internal_Ent is set appropriately.
4292 procedure Set_Imported (E : Entity_Id);
4293 -- This procedure sets the Is_Imported flag for the given entity,
4294 -- checking that it is not previously exported or imported.
4296 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
4297 -- Mech is a parameter passing mechanism (see Import_Function syntax
4298 -- for MECHANISM_NAME). This routine checks that the mechanism argument
4299 -- has the right form, and if not issues an error message. If the
4300 -- argument has the right form then the Mechanism field of Ent is
4301 -- set appropriately.
4303 procedure Set_Rational_Profile;
4304 -- Activate the set of configuration pragmas and permissions that make
4305 -- up the Rational profile.
4307 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id);
4308 -- Activate the set of configuration pragmas and restrictions that make
4309 -- up the Profile. Profile must be either GNAT_Extended_Ravenscar,
4310 -- GNAT_Ravenscar_EDF, or Ravenscar. N is the corresponding pragma node,
4311 -- which is used for error messages on any constructs violating the
4314 procedure Validate_Acc_Condition_Clause (Clause : Node_Id);
4315 -- Make sure the argument of a given Acc_If clause is a Boolean
4317 procedure Validate_Acc_Data_Clause (Clause : Node_Id);
4318 -- Make sure the argument of an OpenAcc data clause (e.g. Copy, Copyin,
4319 -- Copyout...) is an identifier or an aggregate of identifiers.
4321 procedure Validate_Acc_Int_Expr_Clause (Clause : Node_Id);
4322 -- Make sure the argument of an OpenAcc clause is an Integer expression
4324 procedure Validate_Acc_Int_Expr_List_Clause (Clause : Node_Id);
4325 -- Make sure the argument of an OpenAcc clause is an Integer expression
4326 -- or a list of Integer expressions.
4328 procedure Validate_Acc_Loop_Collapse (Clause : Node_Id);
4329 -- Make sure that the parent loop of the Acc_Loop(Collapse => N) pragma
4330 -- contains at least N-1 nested loops.
4332 procedure Validate_Acc_Loop_Gang (Clause : Node_Id);
4333 -- Make sure the argument of the Gang clause of a Loop directive is
4334 -- either an integer expression or a (Static => integer expressions)
4337 procedure Validate_Acc_Loop_Vector (Clause : Node_Id);
4338 -- When this procedure is called in a construct offloaded by an
4339 -- Acc_Kernels pragma, makes sure that a Vector_Length clause does
4340 -- not exist on said pragma. In all cases, make sure the argument
4341 -- is an Integer expression.
4343 procedure Validate_Acc_Loop_Worker (Clause : Node_Id);
4344 -- When this procedure is called in a construct offloaded by an
4345 -- Acc_Parallel pragma, makes sure that no argument has been given.
4346 -- When this procedure is called in a construct offloaded by an
4347 -- Acc_Kernels pragma and if Loop_Worker was given an argument,
4348 -- makes sure that the Num_Workers clause does not appear on the
4349 -- Acc_Kernels pragma and that the argument is an integer.
4351 procedure Validate_Acc_Name_Reduction (Clause : Node_Id);
4352 -- Make sure the reduction clause is an aggregate made of a string
4353 -- representing a supported reduction operation (i.e. "+", "*", "and",
4354 -- "or", "min" or "max") and either an identifier or aggregate of
4357 procedure Validate_Acc_Size_Expressions (Clause : Node_Id);
4358 -- Makes sure that Clause is either an integer expression or an
4359 -- association with a Static as name and a list of integer expressions
4360 -- or "*" strings on the right hand side.
4366 function Acc_First (N : Node_Id) return Node_Id is
4368 if Nkind (N) = N_Aggregate then
4369 if Present (Expressions (N)) then
4370 return First (Expressions (N));
4372 elsif Present (Component_Associations (N)) then
4373 return Expression (First (Component_Associations (N)));
4384 function Acc_Next (N : Node_Id) return Node_Id is
4386 if Nkind (Parent (N)) = N_Component_Association then
4387 return Expression (Next (Parent (N)));
4389 elsif Nkind (Parent (N)) = N_Aggregate then
4397 ---------------------
4398 -- Ada_2005_Pragma --
4399 ---------------------
4401 procedure Ada_2005_Pragma is
4403 if Ada_Version <= Ada_95 then
4404 Check_Restriction (No_Implementation_Pragmas, N);
4406 end Ada_2005_Pragma;
4408 ---------------------
4409 -- Ada_2012_Pragma --
4410 ---------------------
4412 procedure Ada_2012_Pragma is
4414 if Ada_Version <= Ada_2005 then
4415 Check_Restriction (No_Implementation_Pragmas, N);
4417 end Ada_2012_Pragma;
4419 ----------------------------
4420 -- Analyze_Depends_Global --
4421 ----------------------------
4423 procedure Analyze_Depends_Global
4424 (Spec_Id : out Entity_Id;
4425 Subp_Decl : out Node_Id;
4426 Legal : out Boolean)
4429 -- Assume that the pragma is illegal
4436 Check_Arg_Count (1);
4438 -- Ensure the proper placement of the pragma. Depends/Global must be
4439 -- associated with a subprogram declaration or a body that acts as a
4442 Subp_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4446 if Nkind (Subp_Decl) = N_Entry_Declaration then
4449 -- Generic subprogram
4451 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4454 -- Object declaration of a single concurrent type
4456 elsif Nkind (Subp_Decl) = N_Object_Declaration
4457 and then Is_Single_Concurrent_Object
4458 (Unique_Defining_Entity (Subp_Decl))
4464 elsif Nkind (Subp_Decl) = N_Single_Task_Declaration then
4467 -- Subprogram body acts as spec
4469 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4470 and then No (Corresponding_Spec (Subp_Decl))
4474 -- Subprogram body stub acts as spec
4476 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4477 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
4481 -- Subprogram declaration
4483 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4488 elsif Nkind (Subp_Decl) = N_Task_Type_Declaration then
4496 -- If we get here, then the pragma is legal
4499 Spec_Id := Unique_Defining_Entity (Subp_Decl);
4501 -- When the related context is an entry, the entry must belong to a
4502 -- protected unit (SPARK RM 6.1.4(6)).
4504 if Is_Entry_Declaration (Spec_Id)
4505 and then Ekind (Scope (Spec_Id)) /= E_Protected_Type
4510 -- When the related context is an anonymous object created for a
4511 -- simple concurrent type, the type must be a task
4512 -- (SPARK RM 6.1.4(6)).
4514 elsif Is_Single_Concurrent_Object (Spec_Id)
4515 and then Ekind (Etype (Spec_Id)) /= E_Task_Type
4521 -- A pragma that applies to a Ghost entity becomes Ghost for the
4522 -- purposes of legality checks and removal of ignored Ghost code.
4524 Mark_Ghost_Pragma (N, Spec_Id);
4525 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4526 end Analyze_Depends_Global;
4528 ------------------------
4529 -- Analyze_If_Present --
4530 ------------------------
4532 procedure Analyze_If_Present (Id : Pragma_Id) is
4536 pragma Assert (Is_List_Member (N));
4538 -- Inspect the declarations or statements following pragma N looking
4539 -- for another pragma whose Id matches the caller's request. If it is
4540 -- available, analyze it.
4543 while Present (Stmt) loop
4544 if Nkind (Stmt) = N_Pragma and then Get_Pragma_Id (Stmt) = Id then
4545 Analyze_Pragma (Stmt);
4548 -- The first source declaration or statement immediately following
4549 -- N ends the region where a pragma may appear.
4551 elsif Comes_From_Source (Stmt) then
4557 end Analyze_If_Present;
4559 --------------------------------
4560 -- Analyze_Pre_Post_Condition --
4561 --------------------------------
4563 procedure Analyze_Pre_Post_Condition is
4564 Prag_Iden : constant Node_Id := Pragma_Identifier (N);
4565 Subp_Decl : Node_Id;
4566 Subp_Id : Entity_Id;
4568 Duplicates_OK : Boolean := False;
4569 -- Flag set when a pre/postcondition allows multiple pragmas of the
4572 In_Body_OK : Boolean := False;
4573 -- Flag set when a pre/postcondition is allowed to appear on a body
4574 -- even though the subprogram may have a spec.
4576 Is_Pre_Post : Boolean := False;
4577 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4580 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean;
4581 -- Implement rules in AI12-0131: an overriding operation can have
4582 -- a class-wide precondition only if one of its ancestors has an
4583 -- explicit class-wide precondition.
4585 -----------------------------
4586 -- Inherits_Class_Wide_Pre --
4587 -----------------------------
4589 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean is
4590 Typ : constant Entity_Id := Find_Dispatching_Type (E);
4593 Prev : Entity_Id := Overridden_Operation (E);
4596 -- Check ancestors on the overriding operation to examine the
4597 -- preconditions that may apply to them.
4599 while Present (Prev) loop
4600 Cont := Contract (Prev);
4601 if Present (Cont) then
4602 Prag := Pre_Post_Conditions (Cont);
4603 while Present (Prag) loop
4604 if Pragma_Name (Prag) = Name_Precondition
4605 and then Class_Present (Prag)
4610 Prag := Next_Pragma (Prag);
4614 -- For a type derived from a generic formal type, the operation
4615 -- inheriting the condition is a renaming, not an overriding of
4616 -- the operation of the formal. Ditto for an inherited
4617 -- operation which has no explicit contracts.
4619 if Is_Generic_Type (Find_Dispatching_Type (Prev))
4620 or else not Comes_From_Source (Prev)
4622 Prev := Alias (Prev);
4624 Prev := Overridden_Operation (Prev);
4628 -- If the controlling type of the subprogram has progenitors, an
4629 -- interface operation implemented by the current operation may
4630 -- have a class-wide precondition.
4632 if Has_Interfaces (Typ) then
4637 Prim_Elmt : Elmt_Id;
4638 Prim_List : Elist_Id;
4641 Collect_Interfaces (Typ, Ints);
4642 Elmt := First_Elmt (Ints);
4644 -- Iterate over the primitive operations of each interface
4646 while Present (Elmt) loop
4647 Prim_List := Direct_Primitive_Operations (Node (Elmt));
4648 Prim_Elmt := First_Elmt (Prim_List);
4649 while Present (Prim_Elmt) loop
4650 Prim := Node (Prim_Elmt);
4651 if Chars (Prim) = Chars (E)
4652 and then Present (Contract (Prim))
4653 and then Class_Present
4654 (Pre_Post_Conditions (Contract (Prim)))
4659 Next_Elmt (Prim_Elmt);
4668 end Inherits_Class_Wide_Pre;
4670 -- Start of processing for Analyze_Pre_Post_Condition
4673 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4674 -- offer uniformity among the various kinds of pre/postconditions by
4675 -- rewriting the pragma identifier. This allows the retrieval of the
4676 -- original pragma name by routine Original_Aspect_Pragma_Name.
4678 if Comes_From_Source (N) then
4679 if Nam_In (Pname, Name_Pre, Name_Pre_Class) then
4680 Is_Pre_Post := True;
4681 Set_Class_Present (N, Pname = Name_Pre_Class);
4682 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Precondition));
4684 elsif Nam_In (Pname, Name_Post, Name_Post_Class) then
4685 Is_Pre_Post := True;
4686 Set_Class_Present (N, Pname = Name_Post_Class);
4687 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Postcondition));
4691 -- Determine the semantics with respect to duplicates and placement
4692 -- in a body. Pragmas Precondition and Postcondition were introduced
4693 -- before aspects and are not subject to the same aspect-like rules.
4695 if Nam_In (Pname, Name_Precondition, Name_Postcondition) then
4696 Duplicates_OK := True;
4702 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4703 -- argument without an identifier.
4706 Check_Arg_Count (1);
4707 Check_No_Identifiers;
4709 -- Pragmas Precondition and Postcondition have complex argument
4713 Check_At_Least_N_Arguments (1);
4714 Check_At_Most_N_Arguments (2);
4715 Check_Optional_Identifier (Arg1, Name_Check);
4717 if Present (Arg2) then
4718 Check_Optional_Identifier (Arg2, Name_Message);
4719 Preanalyze_Spec_Expression
4720 (Get_Pragma_Arg (Arg2), Standard_String);
4724 -- For a pragma PPC in the extended main source unit, record enabled
4726 -- ??? nothing checks that the pragma is in the main source unit
4728 if Is_Checked (N) and then not Split_PPC (N) then
4729 Set_SCO_Pragma_Enabled (Loc);
4732 -- Ensure the proper placement of the pragma
4735 Find_Related_Declaration_Or_Body
4736 (N, Do_Checks => not Duplicates_OK);
4738 -- When a pre/postcondition pragma applies to an abstract subprogram,
4739 -- its original form must be an aspect with 'Class.
4741 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
4742 if not From_Aspect_Specification (N) then
4744 ("pragma % cannot be applied to abstract subprogram");
4746 elsif not Class_Present (N) then
4748 ("aspect % requires ''Class for abstract subprogram");
4751 -- Entry declaration
4753 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
4756 -- Generic subprogram declaration
4758 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4763 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4764 and then (No (Corresponding_Spec (Subp_Decl)) or In_Body_OK)
4768 -- Subprogram body stub
4770 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4771 and then (No (Corresponding_Spec_Of_Stub (Subp_Decl)) or In_Body_OK)
4775 -- Subprogram declaration
4777 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4779 -- AI05-0230: When a pre/postcondition pragma applies to a null
4780 -- procedure, its original form must be an aspect with 'Class.
4782 if Nkind (Specification (Subp_Decl)) = N_Procedure_Specification
4783 and then Null_Present (Specification (Subp_Decl))
4784 and then From_Aspect_Specification (N)
4785 and then not Class_Present (N)
4787 Error_Pragma ("aspect % requires ''Class for null procedure");
4790 -- Implement the legality checks mandated by AI12-0131:
4791 -- Pre'Class shall not be specified for an overriding primitive
4792 -- subprogram of a tagged type T unless the Pre'Class aspect is
4793 -- specified for the corresponding primitive subprogram of some
4797 E : constant Entity_Id := Defining_Entity (Subp_Decl);
4800 if Class_Present (N)
4801 and then Pragma_Name (N) = Name_Precondition
4802 and then Present (Overridden_Operation (E))
4803 and then not Inherits_Class_Wide_Pre (E)
4806 ("illegal class-wide precondition on overriding operation",
4807 Corresponding_Aspect (N));
4811 -- A renaming declaration may inherit a generated pragma, its
4812 -- placement comes from expansion, not from source.
4814 elsif Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration
4815 and then not Comes_From_Source (N)
4819 -- Otherwise the placement is illegal
4826 Subp_Id := Defining_Entity (Subp_Decl);
4828 -- A pragma that applies to a Ghost entity becomes Ghost for the
4829 -- purposes of legality checks and removal of ignored Ghost code.
4831 Mark_Ghost_Pragma (N, Subp_Id);
4833 -- Chain the pragma on the contract for further processing by
4834 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4836 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
4838 -- Fully analyze the pragma when it appears inside an entry or
4839 -- subprogram body because it cannot benefit from forward references.
4841 if Nkind_In (Subp_Decl, N_Entry_Body,
4843 N_Subprogram_Body_Stub)
4845 -- The legality checks of pragmas Precondition and Postcondition
4846 -- are affected by the SPARK mode in effect and the volatility of
4847 -- the context. Analyze all pragmas in a specific order.
4849 Analyze_If_Present (Pragma_SPARK_Mode);
4850 Analyze_If_Present (Pragma_Volatile_Function);
4851 Analyze_Pre_Post_Condition_In_Decl_Part (N);
4853 end Analyze_Pre_Post_Condition;
4855 -----------------------------------------
4856 -- Analyze_Refined_Depends_Global_Post --
4857 -----------------------------------------
4859 procedure Analyze_Refined_Depends_Global_Post
4860 (Spec_Id : out Entity_Id;
4861 Body_Id : out Entity_Id;
4862 Legal : out Boolean)
4864 Body_Decl : Node_Id;
4865 Spec_Decl : Node_Id;
4868 -- Assume that the pragma is illegal
4875 Check_Arg_Count (1);
4876 Check_No_Identifiers;
4878 -- Verify the placement of the pragma and check for duplicates. The
4879 -- pragma must apply to a subprogram body [stub].
4881 Body_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4883 if not Nkind_In (Body_Decl, N_Entry_Body,
4885 N_Subprogram_Body_Stub,
4893 Body_Id := Defining_Entity (Body_Decl);
4894 Spec_Id := Unique_Defining_Entity (Body_Decl);
4896 -- The pragma must apply to the second declaration of a subprogram.
4897 -- In other words, the body [stub] cannot acts as a spec.
4899 if No (Spec_Id) then
4900 Error_Pragma ("pragma % cannot apply to a stand alone body");
4903 -- Catch the case where the subprogram body is a subunit and acts as
4904 -- the third declaration of the subprogram.
4906 elsif Nkind (Parent (Body_Decl)) = N_Subunit then
4907 Error_Pragma ("pragma % cannot apply to a subunit");
4911 -- A refined pragma can only apply to the body [stub] of a subprogram
4912 -- declared in the visible part of a package. Retrieve the context of
4913 -- the subprogram declaration.
4915 Spec_Decl := Unit_Declaration_Node (Spec_Id);
4917 -- When dealing with protected entries or protected subprograms, use
4918 -- the enclosing protected type as the proper context.
4920 if Ekind_In (Spec_Id, E_Entry,
4924 and then Ekind (Scope (Spec_Id)) = E_Protected_Type
4926 Spec_Decl := Declaration_Node (Scope (Spec_Id));
4929 if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then
4931 (Fix_Msg (Spec_Id, "pragma % must apply to the body of "
4932 & "subprogram declared in a package specification"));
4936 -- If we get here, then the pragma is legal
4940 -- A pragma that applies to a Ghost entity becomes Ghost for the
4941 -- purposes of legality checks and removal of ignored Ghost code.
4943 Mark_Ghost_Pragma (N, Spec_Id);
4945 if Nam_In (Pname, Name_Refined_Depends, Name_Refined_Global) then
4946 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4948 end Analyze_Refined_Depends_Global_Post;
4950 ----------------------------------
4951 -- Analyze_Unmodified_Or_Unused --
4952 ----------------------------------
4954 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False) is
4959 Ghost_Error_Posted : Boolean := False;
4960 -- Flag set when an error concerning the illegal mix of Ghost and
4961 -- non-Ghost variables is emitted.
4963 Ghost_Id : Entity_Id := Empty;
4964 -- The entity of the first Ghost variable encountered while
4965 -- processing the arguments of the pragma.
4969 Check_At_Least_N_Arguments (1);
4971 -- Loop through arguments
4974 while Present (Arg) loop
4975 Check_No_Identifier (Arg);
4977 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4978 -- in fact generate reference, so that the entity will have a
4979 -- reference, which will inhibit any warnings about it not
4980 -- being referenced, and also properly show up in the ali file
4981 -- as a reference. But this reference is recorded before the
4982 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4983 -- generated for this reference.
4985 Check_Arg_Is_Local_Name (Arg);
4986 Arg_Expr := Get_Pragma_Arg (Arg);
4988 if Is_Entity_Name (Arg_Expr) then
4989 Arg_Id := Entity (Arg_Expr);
4991 -- Skip processing the argument if already flagged
4993 if Is_Assignable (Arg_Id)
4994 and then not Has_Pragma_Unmodified (Arg_Id)
4995 and then not Has_Pragma_Unused (Arg_Id)
4997 Set_Has_Pragma_Unmodified (Arg_Id);
5000 Set_Has_Pragma_Unused (Arg_Id);
5003 -- A pragma that applies to a Ghost entity becomes Ghost for
5004 -- the purposes of legality checks and removal of ignored
5007 Mark_Ghost_Pragma (N, Arg_Id);
5009 -- Capture the entity of the first Ghost variable being
5010 -- processed for error detection purposes.
5012 if Is_Ghost_Entity (Arg_Id) then
5013 if No (Ghost_Id) then
5017 -- Otherwise the variable is non-Ghost. It is illegal to mix
5018 -- references to Ghost and non-Ghost entities
5021 elsif Present (Ghost_Id)
5022 and then not Ghost_Error_Posted
5024 Ghost_Error_Posted := True;
5026 Error_Msg_Name_1 := Pname;
5028 ("pragma % cannot mention ghost and non-ghost "
5031 Error_Msg_Sloc := Sloc (Ghost_Id);
5032 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
5034 Error_Msg_Sloc := Sloc (Arg_Id);
5035 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
5038 -- Warn if already flagged as Unused or Unmodified
5040 elsif Has_Pragma_Unmodified (Arg_Id) then
5041 if Has_Pragma_Unused (Arg_Id) then
5043 ("??pragma Unused already given for &!", Arg_Expr,
5047 ("??pragma Unmodified already given for &!", Arg_Expr,
5051 -- Otherwise the pragma referenced an illegal entity
5055 ("pragma% can only be applied to a variable", Arg_Expr);
5061 end Analyze_Unmodified_Or_Unused;
5063 ------------------------------------
5064 -- Analyze_Unreferenced_Or_Unused --
5065 ------------------------------------
5067 procedure Analyze_Unreferenced_Or_Unused
5068 (Is_Unused : Boolean := False)
5075 Ghost_Error_Posted : Boolean := False;
5076 -- Flag set when an error concerning the illegal mix of Ghost and
5077 -- non-Ghost names is emitted.
5079 Ghost_Id : Entity_Id := Empty;
5080 -- The entity of the first Ghost name encountered while processing
5081 -- the arguments of the pragma.
5085 Check_At_Least_N_Arguments (1);
5087 -- Check case of appearing within context clause
5089 if not Is_Unused and then Is_In_Context_Clause then
5091 -- The arguments must all be units mentioned in a with clause in
5092 -- the same context clause. Note that Par.Prag already checked
5093 -- that the arguments are either identifiers or selected
5097 while Present (Arg) loop
5098 Citem := First (List_Containing (N));
5099 while Citem /= N loop
5100 Arg_Expr := Get_Pragma_Arg (Arg);
5102 if Nkind (Citem) = N_With_Clause
5103 and then Same_Name (Name (Citem), Arg_Expr)
5105 Set_Has_Pragma_Unreferenced
5108 (Library_Unit (Citem))));
5109 Set_Elab_Unit_Name (Arg_Expr, Name (Citem));
5118 ("argument of pragma% is not withed unit", Arg);
5124 -- Case of not in list of context items
5128 while Present (Arg) loop
5129 Check_No_Identifier (Arg);
5131 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
5132 -- in fact generate reference, so that the entity will have a
5133 -- reference, which will inhibit any warnings about it not
5134 -- being referenced, and also properly show up in the ali file
5135 -- as a reference. But this reference is recorded before the
5136 -- Has_Pragma_Unreferenced flag is set, so that no warning is
5137 -- generated for this reference.
5139 Check_Arg_Is_Local_Name (Arg);
5140 Arg_Expr := Get_Pragma_Arg (Arg);
5142 if Is_Entity_Name (Arg_Expr) then
5143 Arg_Id := Entity (Arg_Expr);
5145 -- Warn if already flagged as Unused or Unreferenced and
5146 -- skip processing the argument.
5148 if Has_Pragma_Unreferenced (Arg_Id) then
5149 if Has_Pragma_Unused (Arg_Id) then
5151 ("??pragma Unused already given for &!", Arg_Expr,
5155 ("??pragma Unreferenced already given for &!",
5159 -- Apply Unreferenced to the entity
5162 -- If the entity is overloaded, the pragma applies to the
5163 -- most recent overloading, as documented. In this case,
5164 -- name resolution does not generate a reference, so it
5165 -- must be done here explicitly.
5167 if Is_Overloaded (Arg_Expr) then
5168 Generate_Reference (Arg_Id, N);
5171 Set_Has_Pragma_Unreferenced (Arg_Id);
5174 Set_Has_Pragma_Unused (Arg_Id);
5177 -- A pragma that applies to a Ghost entity becomes Ghost
5178 -- for the purposes of legality checks and removal of
5179 -- ignored Ghost code.
5181 Mark_Ghost_Pragma (N, Arg_Id);
5183 -- Capture the entity of the first Ghost name being
5184 -- processed for error detection purposes.
5186 if Is_Ghost_Entity (Arg_Id) then
5187 if No (Ghost_Id) then
5191 -- Otherwise the name is non-Ghost. It is illegal to mix
5192 -- references to Ghost and non-Ghost entities
5195 elsif Present (Ghost_Id)
5196 and then not Ghost_Error_Posted
5198 Ghost_Error_Posted := True;
5200 Error_Msg_Name_1 := Pname;
5202 ("pragma % cannot mention ghost and non-ghost "
5205 Error_Msg_Sloc := Sloc (Ghost_Id);
5207 ("\& # declared as ghost", N, Ghost_Id);
5209 Error_Msg_Sloc := Sloc (Arg_Id);
5211 ("\& # declared as non-ghost", N, Arg_Id);
5219 end Analyze_Unreferenced_Or_Unused;
5221 --------------------------
5222 -- Check_Ada_83_Warning --
5223 --------------------------
5225 procedure Check_Ada_83_Warning is
5227 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
5228 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
5230 end Check_Ada_83_Warning;
5232 ---------------------
5233 -- Check_Arg_Count --
5234 ---------------------
5236 procedure Check_Arg_Count (Required : Nat) is
5238 if Arg_Count /= Required then
5239 Error_Pragma ("wrong number of arguments for pragma%");
5241 end Check_Arg_Count;
5243 --------------------------------
5244 -- Check_Arg_Is_External_Name --
5245 --------------------------------
5247 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
5248 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5251 if Nkind (Argx) = N_Identifier then
5255 Analyze_And_Resolve (Argx, Standard_String);
5257 if Is_OK_Static_Expression (Argx) then
5260 elsif Etype (Argx) = Any_Type then
5263 -- An interesting special case, if we have a string literal and
5264 -- we are in Ada 83 mode, then we allow it even though it will
5265 -- not be flagged as static. This allows expected Ada 83 mode
5266 -- use of external names which are string literals, even though
5267 -- technically these are not static in Ada 83.
5269 elsif Ada_Version = Ada_83
5270 and then Nkind (Argx) = N_String_Literal
5274 -- Here we have a real error (non-static expression)
5277 Error_Msg_Name_1 := Pname;
5278 Flag_Non_Static_Expr
5279 (Fix_Error ("argument for pragma% must be a identifier or "
5280 & "static string expression!"), Argx);
5285 end Check_Arg_Is_External_Name;
5287 -----------------------------
5288 -- Check_Arg_Is_Identifier --
5289 -----------------------------
5291 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
5292 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5294 if Nkind (Argx) /= N_Identifier then
5295 Error_Pragma_Arg ("argument for pragma% must be identifier", Argx);
5297 end Check_Arg_Is_Identifier;
5299 ----------------------------------
5300 -- Check_Arg_Is_Integer_Literal --
5301 ----------------------------------
5303 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
5304 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5306 if Nkind (Argx) /= N_Integer_Literal then
5308 ("argument for pragma% must be integer literal", Argx);
5310 end Check_Arg_Is_Integer_Literal;
5312 -------------------------------------------
5313 -- Check_Arg_Is_Library_Level_Local_Name --
5314 -------------------------------------------
5318 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5319 -- | library_unit_NAME
5321 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
5323 Check_Arg_Is_Local_Name (Arg);
5325 -- If it came from an aspect, we want to give the error just as if it
5326 -- came from source.
5328 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
5329 and then (Comes_From_Source (N)
5330 or else Present (Corresponding_Aspect (Parent (Arg))))
5333 ("argument for pragma% must be library level entity", Arg);
5335 end Check_Arg_Is_Library_Level_Local_Name;
5337 -----------------------------
5338 -- Check_Arg_Is_Local_Name --
5339 -----------------------------
5343 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5344 -- | library_unit_NAME
5346 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
5347 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5350 -- If this pragma came from an aspect specification, we don't want to
5351 -- check for this error, because that would cause spurious errors, in
5352 -- case a type is frozen in a scope more nested than the type. The
5353 -- aspect itself of course can't be anywhere but on the declaration
5356 if Nkind (Arg) = N_Pragma_Argument_Association then
5357 if From_Aspect_Specification (Parent (Arg)) then
5361 -- Arg is the Expression of an N_Pragma_Argument_Association
5364 if From_Aspect_Specification (Parent (Parent (Arg))) then
5371 if Nkind (Argx) not in N_Direct_Name
5372 and then (Nkind (Argx) /= N_Attribute_Reference
5373 or else Present (Expressions (Argx))
5374 or else Nkind (Prefix (Argx)) /= N_Identifier)
5375 and then (not Is_Entity_Name (Argx)
5376 or else not Is_Compilation_Unit (Entity (Argx)))
5378 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
5381 -- No further check required if not an entity name
5383 if not Is_Entity_Name (Argx) then
5389 Ent : constant Entity_Id := Entity (Argx);
5390 Scop : constant Entity_Id := Scope (Ent);
5393 -- Case of a pragma applied to a compilation unit: pragma must
5394 -- occur immediately after the program unit in the compilation.
5396 if Is_Compilation_Unit (Ent) then
5398 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
5401 -- Case of pragma placed immediately after spec
5403 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
5406 -- Case of pragma placed immediately after body
5408 elsif Nkind (Decl) = N_Subprogram_Declaration
5409 and then Present (Corresponding_Body (Decl))
5413 (Parent (Unit_Declaration_Node
5414 (Corresponding_Body (Decl))));
5416 -- All other cases are illegal
5423 -- Special restricted placement rule from 10.2.1(11.8/2)
5425 elsif Is_Generic_Formal (Ent)
5426 and then Prag_Id = Pragma_Preelaborable_Initialization
5428 OK := List_Containing (N) =
5429 Generic_Formal_Declarations
5430 (Unit_Declaration_Node (Scop));
5432 -- If this is an aspect applied to a subprogram body, the
5433 -- pragma is inserted in its declarative part.
5435 elsif From_Aspect_Specification (N)
5436 and then Ent = Current_Scope
5438 Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body
5442 -- If the aspect is a predicate (possibly others ???) and the
5443 -- context is a record type, this is a discriminant expression
5444 -- within a type declaration, that freezes the predicated
5447 elsif From_Aspect_Specification (N)
5448 and then Prag_Id = Pragma_Predicate
5449 and then Ekind (Current_Scope) = E_Record_Type
5450 and then Scop = Scope (Current_Scope)
5454 -- Default case, just check that the pragma occurs in the scope
5455 -- of the entity denoted by the name.
5458 OK := Current_Scope = Scop;
5463 ("pragma% argument must be in same declarative part", Arg);
5467 end Check_Arg_Is_Local_Name;
5469 ---------------------------------
5470 -- Check_Arg_Is_Locking_Policy --
5471 ---------------------------------
5473 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
5474 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5477 Check_Arg_Is_Identifier (Argx);
5479 if not Is_Locking_Policy_Name (Chars (Argx)) then
5480 Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
5482 end Check_Arg_Is_Locking_Policy;
5484 -----------------------------------------------
5485 -- Check_Arg_Is_Partition_Elaboration_Policy --
5486 -----------------------------------------------
5488 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
5489 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5492 Check_Arg_Is_Identifier (Argx);
5494 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
5496 ("& is not a valid partition elaboration policy name", Argx);
5498 end Check_Arg_Is_Partition_Elaboration_Policy;
5500 -------------------------
5501 -- Check_Arg_Is_One_Of --
5502 -------------------------
5504 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5505 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5508 Check_Arg_Is_Identifier (Argx);
5510 if not Nam_In (Chars (Argx), N1, N2) then
5511 Error_Msg_Name_2 := N1;
5512 Error_Msg_Name_3 := N2;
5513 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
5515 end Check_Arg_Is_One_Of;
5517 procedure Check_Arg_Is_One_Of
5519 N1, N2, N3 : Name_Id)
5521 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5524 Check_Arg_Is_Identifier (Argx);
5526 if not Nam_In (Chars (Argx), N1, N2, N3) then
5527 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5529 end Check_Arg_Is_One_Of;
5531 procedure Check_Arg_Is_One_Of
5533 N1, N2, N3, N4 : Name_Id)
5535 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5538 Check_Arg_Is_Identifier (Argx);
5540 if not Nam_In (Chars (Argx), N1, N2, N3, N4) then
5541 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5543 end Check_Arg_Is_One_Of;
5545 procedure Check_Arg_Is_One_Of
5547 N1, N2, N3, N4, N5 : Name_Id)
5549 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5552 Check_Arg_Is_Identifier (Argx);
5554 if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then
5555 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5557 end Check_Arg_Is_One_Of;
5559 ---------------------------------
5560 -- Check_Arg_Is_Queuing_Policy --
5561 ---------------------------------
5563 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
5564 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5567 Check_Arg_Is_Identifier (Argx);
5569 if not Is_Queuing_Policy_Name (Chars (Argx)) then
5570 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
5572 end Check_Arg_Is_Queuing_Policy;
5574 ---------------------------------------
5575 -- Check_Arg_Is_OK_Static_Expression --
5576 ---------------------------------------
5578 procedure Check_Arg_Is_OK_Static_Expression
5580 Typ : Entity_Id := Empty)
5583 Check_Expr_Is_OK_Static_Expression (Get_Pragma_Arg (Arg), Typ);
5584 end Check_Arg_Is_OK_Static_Expression;
5586 ------------------------------------------
5587 -- Check_Arg_Is_Task_Dispatching_Policy --
5588 ------------------------------------------
5590 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
5591 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5594 Check_Arg_Is_Identifier (Argx);
5596 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
5598 ("& is not an allowed task dispatching policy name", Argx);
5600 end Check_Arg_Is_Task_Dispatching_Policy;
5602 ---------------------
5603 -- Check_Arg_Order --
5604 ---------------------
5606 procedure Check_Arg_Order (Names : Name_List) is
5609 Highest_So_Far : Natural := 0;
5610 -- Highest index in Names seen do far
5614 for J in 1 .. Arg_Count loop
5615 if Chars (Arg) /= No_Name then
5616 for K in Names'Range loop
5617 if Chars (Arg) = Names (K) then
5618 if K < Highest_So_Far then
5619 Error_Msg_Name_1 := Pname;
5621 ("parameters out of order for pragma%", Arg);
5622 Error_Msg_Name_1 := Names (K);
5623 Error_Msg_Name_2 := Names (Highest_So_Far);
5624 Error_Msg_N ("\% must appear before %", Arg);
5628 Highest_So_Far := K;
5636 end Check_Arg_Order;
5638 --------------------------------
5639 -- Check_At_Least_N_Arguments --
5640 --------------------------------
5642 procedure Check_At_Least_N_Arguments (N : Nat) is
5644 if Arg_Count < N then
5645 Error_Pragma ("too few arguments for pragma%");
5647 end Check_At_Least_N_Arguments;
5649 -------------------------------
5650 -- Check_At_Most_N_Arguments --
5651 -------------------------------
5653 procedure Check_At_Most_N_Arguments (N : Nat) is
5656 if Arg_Count > N then
5658 for J in 1 .. N loop
5660 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
5663 end Check_At_Most_N_Arguments;
5665 ---------------------
5666 -- Check_Component --
5667 ---------------------
5669 procedure Check_Component
5672 In_Variant_Part : Boolean := False)
5674 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
5675 Sindic : constant Node_Id :=
5676 Subtype_Indication (Component_Definition (Comp));
5677 Typ : constant Entity_Id := Etype (Comp_Id);
5680 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
5681 -- object constraint, then the component type shall be an Unchecked_
5684 if Nkind (Sindic) = N_Subtype_Indication
5685 and then Has_Per_Object_Constraint (Comp_Id)
5686 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
5689 ("component subtype subject to per-object constraint "
5690 & "must be an Unchecked_Union", Comp);
5692 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
5693 -- the body of a generic unit, or within the body of any of its
5694 -- descendant library units, no part of the type of a component
5695 -- declared in a variant_part of the unchecked union type shall be of
5696 -- a formal private type or formal private extension declared within
5697 -- the formal part of the generic unit.
5699 elsif Ada_Version >= Ada_2012
5700 and then In_Generic_Body (UU_Typ)
5701 and then In_Variant_Part
5702 and then Is_Private_Type (Typ)
5703 and then Is_Generic_Type (Typ)
5706 ("component of unchecked union cannot be of generic type", Comp);
5708 elsif Needs_Finalization (Typ) then
5710 ("component of unchecked union cannot be controlled", Comp);
5712 elsif Has_Task (Typ) then
5714 ("component of unchecked union cannot have tasks", Comp);
5716 end Check_Component;
5718 ----------------------------
5719 -- Check_Duplicate_Pragma --
5720 ----------------------------
5722 procedure Check_Duplicate_Pragma (E : Entity_Id) is
5723 Id : Entity_Id := E;
5727 -- Nothing to do if this pragma comes from an aspect specification,
5728 -- since we could not be duplicating a pragma, and we dealt with the
5729 -- case of duplicated aspects in Analyze_Aspect_Specifications.
5731 if From_Aspect_Specification (N) then
5735 -- Otherwise current pragma may duplicate previous pragma or a
5736 -- previously given aspect specification or attribute definition
5737 -- clause for the same pragma.
5739 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
5743 -- If the entity is a type, then we have to make sure that the
5744 -- ostensible duplicate is not for a parent type from which this
5748 if Nkind (P) = N_Pragma then
5750 Args : constant List_Id :=
5751 Pragma_Argument_Associations (P);
5754 and then Is_Entity_Name (Expression (First (Args)))
5755 and then Is_Type (Entity (Expression (First (Args))))
5756 and then Entity (Expression (First (Args))) /= E
5762 elsif Nkind (P) = N_Aspect_Specification
5763 and then Is_Type (Entity (P))
5764 and then Entity (P) /= E
5770 -- Here we have a definite duplicate
5772 Error_Msg_Name_1 := Pragma_Name (N);
5773 Error_Msg_Sloc := Sloc (P);
5775 -- For a single protected or a single task object, the error is
5776 -- issued on the original entity.
5778 if Ekind_In (Id, E_Task_Type, E_Protected_Type) then
5779 Id := Defining_Identifier (Original_Node (Parent (Id)));
5782 if Nkind (P) = N_Aspect_Specification
5783 or else From_Aspect_Specification (P)
5785 Error_Msg_NE ("aspect% for & previously given#", N, Id);
5787 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
5792 end Check_Duplicate_Pragma;
5794 ----------------------------------
5795 -- Check_Duplicated_Export_Name --
5796 ----------------------------------
5798 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
5799 String_Val : constant String_Id := Strval (Nam);
5802 -- We are only interested in the export case, and in the case of
5803 -- generics, it is the instance, not the template, that is the
5804 -- problem (the template will generate a warning in any case).
5806 if not Inside_A_Generic
5807 and then (Prag_Id = Pragma_Export
5809 Prag_Id = Pragma_Export_Procedure
5811 Prag_Id = Pragma_Export_Valued_Procedure
5813 Prag_Id = Pragma_Export_Function)
5815 for J in Externals.First .. Externals.Last loop
5816 if String_Equal (String_Val, Strval (Externals.Table (J))) then
5817 Error_Msg_Sloc := Sloc (Externals.Table (J));
5818 Error_Msg_N ("external name duplicates name given#", Nam);
5823 Externals.Append (Nam);
5825 end Check_Duplicated_Export_Name;
5827 ----------------------------------------
5828 -- Check_Expr_Is_OK_Static_Expression --
5829 ----------------------------------------
5831 procedure Check_Expr_Is_OK_Static_Expression
5833 Typ : Entity_Id := Empty)
5836 if Present (Typ) then
5837 Analyze_And_Resolve (Expr, Typ);
5839 Analyze_And_Resolve (Expr);
5842 -- An expression cannot be considered static if its resolution failed
5843 -- or if it's erroneous. Stop the analysis of the related pragma.
5845 if Etype (Expr) = Any_Type or else Error_Posted (Expr) then
5848 elsif Is_OK_Static_Expression (Expr) then
5851 -- An interesting special case, if we have a string literal and we
5852 -- are in Ada 83 mode, then we allow it even though it will not be
5853 -- flagged as static. This allows the use of Ada 95 pragmas like
5854 -- Import in Ada 83 mode. They will of course be flagged with
5855 -- warnings as usual, but will not cause errors.
5857 elsif Ada_Version = Ada_83
5858 and then Nkind (Expr) = N_String_Literal
5862 -- Finally, we have a real error
5865 Error_Msg_Name_1 := Pname;
5866 Flag_Non_Static_Expr
5867 (Fix_Error ("argument for pragma% must be a static expression!"),
5871 end Check_Expr_Is_OK_Static_Expression;
5873 -------------------------
5874 -- Check_First_Subtype --
5875 -------------------------
5877 procedure Check_First_Subtype (Arg : Node_Id) is
5878 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5879 Ent : constant Entity_Id := Entity (Argx);
5882 if Is_First_Subtype (Ent) then
5885 elsif Is_Type (Ent) then
5887 ("pragma% cannot apply to subtype", Argx);
5889 elsif Is_Object (Ent) then
5891 ("pragma% cannot apply to object, requires a type", Argx);
5895 ("pragma% cannot apply to&, requires a type", Argx);
5897 end Check_First_Subtype;
5899 ----------------------
5900 -- Check_Identifier --
5901 ----------------------
5903 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
5906 and then Nkind (Arg) = N_Pragma_Argument_Association
5908 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
5909 Error_Msg_Name_1 := Pname;
5910 Error_Msg_Name_2 := Id;
5911 Error_Msg_N ("pragma% argument expects identifier%", Arg);
5915 end Check_Identifier;
5917 --------------------------------
5918 -- Check_Identifier_Is_One_Of --
5919 --------------------------------
5921 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5924 and then Nkind (Arg) = N_Pragma_Argument_Association
5926 if Chars (Arg) = No_Name then
5927 Error_Msg_Name_1 := Pname;
5928 Error_Msg_N ("pragma% argument expects an identifier", Arg);
5931 elsif Chars (Arg) /= N1
5932 and then Chars (Arg) /= N2
5934 Error_Msg_Name_1 := Pname;
5935 Error_Msg_N ("invalid identifier for pragma% argument", Arg);
5939 end Check_Identifier_Is_One_Of;
5941 ---------------------------
5942 -- Check_In_Main_Program --
5943 ---------------------------
5945 procedure Check_In_Main_Program is
5946 P : constant Node_Id := Parent (N);
5949 -- Must be in subprogram body
5951 if Nkind (P) /= N_Subprogram_Body then
5952 Error_Pragma ("% pragma allowed only in subprogram");
5954 -- Otherwise warn if obviously not main program
5956 elsif Present (Parameter_Specifications (Specification (P)))
5957 or else not Is_Compilation_Unit (Defining_Entity (P))
5959 Error_Msg_Name_1 := Pname;
5961 ("??pragma% is only effective in main program", N);
5963 end Check_In_Main_Program;
5965 ---------------------------------------
5966 -- Check_Interrupt_Or_Attach_Handler --
5967 ---------------------------------------
5969 procedure Check_Interrupt_Or_Attach_Handler is
5970 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
5971 Handler_Proc, Proc_Scope : Entity_Id;
5976 if Prag_Id = Pragma_Interrupt_Handler then
5977 Check_Restriction (No_Dynamic_Attachment, N);
5980 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
5981 Proc_Scope := Scope (Handler_Proc);
5983 if Ekind (Proc_Scope) /= E_Protected_Type then
5985 ("argument of pragma% must be protected procedure", Arg1);
5988 -- For pragma case (as opposed to access case), check placement.
5989 -- We don't need to do that for aspects, because we have the
5990 -- check that they aspect applies an appropriate procedure.
5992 if not From_Aspect_Specification (N)
5993 and then Parent (N) /= Protected_Definition (Parent (Proc_Scope))
5995 Error_Pragma ("pragma% must be in protected definition");
5998 if not Is_Library_Level_Entity (Proc_Scope) then
6000 ("argument for pragma% must be library level entity", Arg1);
6003 -- AI05-0033: A pragma cannot appear within a generic body, because
6004 -- instance can be in a nested scope. The check that protected type
6005 -- is itself a library-level declaration is done elsewhere.
6007 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
6008 -- handle code prior to AI-0033. Analysis tools typically are not
6009 -- interested in this pragma in any case, so no need to worry too
6010 -- much about its placement.
6012 if Inside_A_Generic then
6013 if Ekind (Scope (Current_Scope)) = E_Generic_Package
6014 and then In_Package_Body (Scope (Current_Scope))
6015 and then not Relaxed_RM_Semantics
6017 Error_Pragma ("pragma% cannot be used inside a generic");
6020 end Check_Interrupt_Or_Attach_Handler;
6022 ---------------------------------
6023 -- Check_Loop_Pragma_Placement --
6024 ---------------------------------
6026 procedure Check_Loop_Pragma_Placement is
6027 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id);
6028 -- Verify whether the current pragma is properly grouped with other
6029 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
6030 -- related loop where the pragma appears.
6032 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean;
6033 -- Determine whether an arbitrary statement Stmt denotes pragma
6034 -- Loop_Invariant or Loop_Variant.
6036 procedure Placement_Error (Constr : Node_Id);
6037 pragma No_Return (Placement_Error);
6038 -- Node Constr denotes the last loop restricted construct before we
6039 -- encountered an illegal relation between enclosing constructs. Emit
6040 -- an error depending on what Constr was.
6042 --------------------------------
6043 -- Check_Loop_Pragma_Grouping --
6044 --------------------------------
6046 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is
6047 Stop_Search : exception;
6048 -- This exception is used to terminate the recursive descent of
6049 -- routine Check_Grouping.
6051 procedure Check_Grouping (L : List_Id);
6052 -- Find the first group of pragmas in list L and if successful,
6053 -- ensure that the current pragma is part of that group. The
6054 -- routine raises Stop_Search once such a check is performed to
6055 -- halt the recursive descent.
6057 procedure Grouping_Error (Prag : Node_Id);
6058 pragma No_Return (Grouping_Error);
6059 -- Emit an error concerning the current pragma indicating that it
6060 -- should be placed after pragma Prag.
6062 --------------------
6063 -- Check_Grouping --
6064 --------------------
6066 procedure Check_Grouping (L : List_Id) is
6069 Prag : Node_Id := Empty; -- init to avoid warning
6072 -- Inspect the list of declarations or statements looking for
6073 -- the first grouping of pragmas:
6076 -- pragma Loop_Invariant ...;
6077 -- pragma Loop_Variant ...;
6079 -- pragma Loop_Variant ...; -- current pragma
6081 -- If the current pragma is not in the grouping, then it must
6082 -- either appear in a different declarative or statement list
6083 -- or the construct at (1) is separating the pragma from the
6087 while Present (Stmt) loop
6089 -- First pragma of the first topmost grouping has been found
6091 if Is_Loop_Pragma (Stmt) then
6093 -- The group and the current pragma are not in the same
6094 -- declarative or statement list.
6096 if List_Containing (Stmt) /= List_Containing (N) then
6097 Grouping_Error (Stmt);
6099 -- Try to reach the current pragma from the first pragma
6100 -- of the grouping while skipping other members:
6102 -- pragma Loop_Invariant ...; -- first pragma
6103 -- pragma Loop_Variant ...; -- member
6105 -- pragma Loop_Variant ...; -- current pragma
6108 while Present (Stmt) loop
6109 -- The current pragma is either the first pragma
6110 -- of the group or is a member of the group.
6111 -- Stop the search as the placement is legal.
6116 -- Skip group members, but keep track of the
6117 -- last pragma in the group.
6119 elsif Is_Loop_Pragma (Stmt) then
6122 -- Skip declarations and statements generated by
6123 -- the compiler during expansion. Note that some
6124 -- source statements (e.g. pragma Assert) may have
6125 -- been transformed so that they do not appear as
6126 -- coming from source anymore, so we instead look
6127 -- at their Original_Node.
6129 elsif not Comes_From_Source (Original_Node (Stmt))
6133 -- A non-pragma is separating the group from the
6134 -- current pragma, the placement is illegal.
6137 Grouping_Error (Prag);
6143 -- If the traversal did not reach the current pragma,
6144 -- then the list must be malformed.
6146 raise Program_Error;
6149 -- Pragmas Loop_Invariant and Loop_Variant may only appear
6150 -- inside a loop or a block housed inside a loop. Inspect
6151 -- the declarations and statements of the block as they may
6152 -- contain the first grouping. This case follows the one for
6153 -- loop pragmas, as block statements which originate in a
6154 -- loop pragma (and so Is_Loop_Pragma will return True on
6155 -- that block statement) should be treated in the previous
6158 elsif Nkind (Stmt) = N_Block_Statement then
6159 HSS := Handled_Statement_Sequence (Stmt);
6161 Check_Grouping (Declarations (Stmt));
6163 if Present (HSS) then
6164 Check_Grouping (Statements (HSS));
6172 --------------------
6173 -- Grouping_Error --
6174 --------------------
6176 procedure Grouping_Error (Prag : Node_Id) is
6178 Error_Msg_Sloc := Sloc (Prag);
6179 Error_Pragma ("pragma% must appear next to pragma#");
6182 -- Start of processing for Check_Loop_Pragma_Grouping
6185 -- Inspect the statements of the loop or nested blocks housed
6186 -- within to determine whether the current pragma is part of the
6187 -- first topmost grouping of Loop_Invariant and Loop_Variant.
6189 Check_Grouping (Statements (Loop_Stmt));
6192 when Stop_Search => null;
6193 end Check_Loop_Pragma_Grouping;
6195 --------------------
6196 -- Is_Loop_Pragma --
6197 --------------------
6199 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean is
6201 -- Inspect the original node as Loop_Invariant and Loop_Variant
6202 -- pragmas are rewritten to null when assertions are disabled.
6204 if Nkind (Original_Node (Stmt)) = N_Pragma then
6206 Nam_In (Pragma_Name_Unmapped (Original_Node (Stmt)),
6207 Name_Loop_Invariant,
6214 ---------------------
6215 -- Placement_Error --
6216 ---------------------
6218 procedure Placement_Error (Constr : Node_Id) is
6219 LA : constant String := " with Loop_Entry";
6222 if Prag_Id = Pragma_Assert then
6223 Error_Msg_String (1 .. LA'Length) := LA;
6224 Error_Msg_Strlen := LA'Length;
6226 Error_Msg_Strlen := 0;
6229 if Nkind (Constr) = N_Pragma then
6231 ("pragma %~ must appear immediately within the statements "
6235 ("block containing pragma %~ must appear immediately within "
6236 & "the statements of a loop", Constr);
6238 end Placement_Error;
6240 -- Local declarations
6245 -- Start of processing for Check_Loop_Pragma_Placement
6248 -- Check that pragma appears immediately within a loop statement,
6249 -- ignoring intervening block statements.
6253 while Present (Stmt) loop
6255 -- The pragma or previous block must appear immediately within the
6256 -- current block's declarative or statement part.
6258 if Nkind (Stmt) = N_Block_Statement then
6259 if (No (Declarations (Stmt))
6260 or else List_Containing (Prev) /= Declarations (Stmt))
6262 List_Containing (Prev) /=
6263 Statements (Handled_Statement_Sequence (Stmt))
6265 Placement_Error (Prev);
6268 -- Keep inspecting the parents because we are now within a
6269 -- chain of nested blocks.
6273 Stmt := Parent (Stmt);
6276 -- The pragma or previous block must appear immediately within the
6277 -- statements of the loop.
6279 elsif Nkind (Stmt) = N_Loop_Statement then
6280 if List_Containing (Prev) /= Statements (Stmt) then
6281 Placement_Error (Prev);
6284 -- Stop the traversal because we reached the innermost loop
6285 -- regardless of whether we encountered an error or not.
6289 -- Ignore a handled statement sequence. Note that this node may
6290 -- be related to a subprogram body in which case we will emit an
6291 -- error on the next iteration of the search.
6293 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then
6294 Stmt := Parent (Stmt);
6296 -- Any other statement breaks the chain from the pragma to the
6300 Placement_Error (Prev);
6305 -- Check that the current pragma Loop_Invariant or Loop_Variant is
6306 -- grouped together with other such pragmas.
6308 if Is_Loop_Pragma (N) then
6310 -- The previous check should have located the related loop
6312 pragma Assert (Nkind (Stmt) = N_Loop_Statement);
6313 Check_Loop_Pragma_Grouping (Stmt);
6315 end Check_Loop_Pragma_Placement;
6317 -------------------------------------------
6318 -- Check_Is_In_Decl_Part_Or_Package_Spec --
6319 -------------------------------------------
6321 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
6330 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
6333 elsif Nkind_In (P, N_Package_Specification,
6338 -- Note: the following tests seem a little peculiar, because
6339 -- they test for bodies, but if we were in the statement part
6340 -- of the body, we would already have hit the handled statement
6341 -- sequence, so the only way we get here is by being in the
6342 -- declarative part of the body.
6344 elsif Nkind_In (P, N_Subprogram_Body,
6355 Error_Pragma ("pragma% is not in declarative part or package spec");
6356 end Check_Is_In_Decl_Part_Or_Package_Spec;
6358 -------------------------
6359 -- Check_No_Identifier --
6360 -------------------------
6362 procedure Check_No_Identifier (Arg : Node_Id) is
6364 if Nkind (Arg) = N_Pragma_Argument_Association
6365 and then Chars (Arg) /= No_Name
6367 Error_Pragma_Arg_Ident
6368 ("pragma% does not permit identifier& here", Arg);
6370 end Check_No_Identifier;
6372 --------------------------
6373 -- Check_No_Identifiers --
6374 --------------------------
6376 procedure Check_No_Identifiers is
6380 for J in 1 .. Arg_Count loop
6381 Check_No_Identifier (Arg_Node);
6384 end Check_No_Identifiers;
6386 ------------------------
6387 -- Check_No_Link_Name --
6388 ------------------------
6390 procedure Check_No_Link_Name is
6392 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then
6396 if Present (Arg4) then
6398 ("Link_Name argument not allowed for Import Intrinsic", Arg4);
6400 end Check_No_Link_Name;
6402 -------------------------------
6403 -- Check_Optional_Identifier --
6404 -------------------------------
6406 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
6409 and then Nkind (Arg) = N_Pragma_Argument_Association
6410 and then Chars (Arg) /= No_Name
6412 if Chars (Arg) /= Id then
6413 Error_Msg_Name_1 := Pname;
6414 Error_Msg_Name_2 := Id;
6415 Error_Msg_N ("pragma% argument expects identifier%", Arg);
6419 end Check_Optional_Identifier;
6421 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
6423 Check_Optional_Identifier (Arg, Name_Find (Id));
6424 end Check_Optional_Identifier;
6426 -------------------------------------
6427 -- Check_Static_Boolean_Expression --
6428 -------------------------------------
6430 procedure Check_Static_Boolean_Expression (Expr : Node_Id) is
6432 if Present (Expr) then
6433 Analyze_And_Resolve (Expr, Standard_Boolean);
6435 if not Is_OK_Static_Expression (Expr) then
6437 ("expression of pragma % must be static", Expr);
6440 end Check_Static_Boolean_Expression;
6442 -----------------------------
6443 -- Check_Static_Constraint --
6444 -----------------------------
6446 -- Note: for convenience in writing this procedure, in addition to
6447 -- the officially (i.e. by spec) allowed argument which is always a
6448 -- constraint, it also allows ranges and discriminant associations.
6449 -- Above is not clear ???
6451 procedure Check_Static_Constraint (Constr : Node_Id) is
6453 procedure Require_Static (E : Node_Id);
6454 -- Require given expression to be static expression
6456 --------------------
6457 -- Require_Static --
6458 --------------------
6460 procedure Require_Static (E : Node_Id) is
6462 if not Is_OK_Static_Expression (E) then
6463 Flag_Non_Static_Expr
6464 ("non-static constraint not allowed in Unchecked_Union!", E);
6469 -- Start of processing for Check_Static_Constraint
6472 case Nkind (Constr) is
6473 when N_Discriminant_Association =>
6474 Require_Static (Expression (Constr));
6477 Require_Static (Low_Bound (Constr));
6478 Require_Static (High_Bound (Constr));
6480 when N_Attribute_Reference =>
6481 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
6482 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
6484 when N_Range_Constraint =>
6485 Check_Static_Constraint (Range_Expression (Constr));
6487 when N_Index_Or_Discriminant_Constraint =>
6491 IDC := First (Constraints (Constr));
6492 while Present (IDC) loop
6493 Check_Static_Constraint (IDC);
6501 end Check_Static_Constraint;
6503 --------------------------------------
6504 -- Check_Valid_Configuration_Pragma --
6505 --------------------------------------
6507 -- A configuration pragma must appear in the context clause of a
6508 -- compilation unit, and only other pragmas may precede it. Note that
6509 -- the test also allows use in a configuration pragma file.
6511 procedure Check_Valid_Configuration_Pragma is
6513 if not Is_Configuration_Pragma then
6514 Error_Pragma ("incorrect placement for configuration pragma%");
6516 end Check_Valid_Configuration_Pragma;
6518 -------------------------------------
6519 -- Check_Valid_Library_Unit_Pragma --
6520 -------------------------------------
6522 procedure Check_Valid_Library_Unit_Pragma is
6524 Parent_Node : Node_Id;
6525 Unit_Name : Entity_Id;
6526 Unit_Kind : Node_Kind;
6527 Unit_Node : Node_Id;
6528 Sindex : Source_File_Index;
6531 if not Is_List_Member (N) then
6535 Plist := List_Containing (N);
6536 Parent_Node := Parent (Plist);
6538 if Parent_Node = Empty then
6541 -- Case of pragma appearing after a compilation unit. In this case
6542 -- it must have an argument with the corresponding name and must
6543 -- be part of the following pragmas of its parent.
6545 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
6546 if Plist /= Pragmas_After (Parent_Node) then
6549 elsif Arg_Count = 0 then
6551 ("argument required if outside compilation unit");
6554 Check_No_Identifiers;
6555 Check_Arg_Count (1);
6556 Unit_Node := Unit (Parent (Parent_Node));
6557 Unit_Kind := Nkind (Unit_Node);
6559 Analyze (Get_Pragma_Arg (Arg1));
6561 if Unit_Kind = N_Generic_Subprogram_Declaration
6562 or else Unit_Kind = N_Subprogram_Declaration
6564 Unit_Name := Defining_Entity (Unit_Node);
6566 elsif Unit_Kind in N_Generic_Instantiation then
6567 Unit_Name := Defining_Entity (Unit_Node);
6570 Unit_Name := Cunit_Entity (Current_Sem_Unit);
6573 if Chars (Unit_Name) /=
6574 Chars (Entity (Get_Pragma_Arg (Arg1)))
6577 ("pragma% argument is not current unit name", Arg1);
6580 if Ekind (Unit_Name) = E_Package
6581 and then Present (Renamed_Entity (Unit_Name))
6583 Error_Pragma ("pragma% not allowed for renamed package");
6587 -- Pragma appears other than after a compilation unit
6590 -- Here we check for the generic instantiation case and also
6591 -- for the case of processing a generic formal package. We
6592 -- detect these cases by noting that the Sloc on the node
6593 -- does not belong to the current compilation unit.
6595 Sindex := Source_Index (Current_Sem_Unit);
6597 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
6598 Rewrite (N, Make_Null_Statement (Loc));
6601 -- If before first declaration, the pragma applies to the
6602 -- enclosing unit, and the name if present must be this name.
6604 elsif Is_Before_First_Decl (N, Plist) then
6605 Unit_Node := Unit_Declaration_Node (Current_Scope);
6606 Unit_Kind := Nkind (Unit_Node);
6608 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
6611 elsif Unit_Kind = N_Subprogram_Body
6612 and then not Acts_As_Spec (Unit_Node)
6616 elsif Nkind (Parent_Node) = N_Package_Body then
6619 elsif Nkind (Parent_Node) = N_Package_Specification
6620 and then Plist = Private_Declarations (Parent_Node)
6624 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
6625 or else Nkind (Parent_Node) =
6626 N_Generic_Subprogram_Declaration)
6627 and then Plist = Generic_Formal_Declarations (Parent_Node)
6631 elsif Arg_Count > 0 then
6632 Analyze (Get_Pragma_Arg (Arg1));
6634 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
6636 ("name in pragma% must be enclosing unit", Arg1);
6639 -- It is legal to have no argument in this context
6645 -- Error if not before first declaration. This is because a
6646 -- library unit pragma argument must be the name of a library
6647 -- unit (RM 10.1.5(7)), but the only names permitted in this
6648 -- context are (RM 10.1.5(6)) names of subprogram declarations,
6649 -- generic subprogram declarations or generic instantiations.
6653 ("pragma% misplaced, must be before first declaration");
6657 end Check_Valid_Library_Unit_Pragma;
6663 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
6664 Clist : constant Node_Id := Component_List (Variant);
6668 Comp := First_Non_Pragma (Component_Items (Clist));
6669 while Present (Comp) loop
6670 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
6671 Next_Non_Pragma (Comp);
6675 ---------------------------
6676 -- Ensure_Aggregate_Form --
6677 ---------------------------
6679 procedure Ensure_Aggregate_Form (Arg : Node_Id) is
6680 CFSD : constant Boolean := Get_Comes_From_Source_Default;
6681 Expr : constant Node_Id := Expression (Arg);
6682 Loc : constant Source_Ptr := Sloc (Expr);
6683 Comps : List_Id := No_List;
6684 Exprs : List_Id := No_List;
6685 Nam : Name_Id := No_Name;
6686 Nam_Loc : Source_Ptr;
6689 -- The pragma argument is in positional form:
6691 -- pragma Depends (Nam => ...)
6695 -- Note that the Sloc of the Chars field is the Sloc of the pragma
6696 -- argument association.
6698 if Nkind (Arg) = N_Pragma_Argument_Association then
6700 Nam_Loc := Sloc (Arg);
6702 -- Remove the pragma argument name as this will be captured in the
6705 Set_Chars (Arg, No_Name);
6708 -- The argument is already in aggregate form, but the presence of a
6709 -- name causes this to be interpreted as named association which in
6710 -- turn must be converted into an aggregate.
6712 -- pragma Global (In_Out => (A, B, C))
6716 -- pragma Global ((In_Out => (A, B, C)))
6718 -- aggregate aggregate
6720 if Nkind (Expr) = N_Aggregate then
6721 if Nam = No_Name then
6725 -- Do not transform a null argument into an aggregate as N_Null has
6726 -- special meaning in formal verification pragmas.
6728 elsif Nkind (Expr) = N_Null then
6732 -- Everything comes from source if the original comes from source
6734 Set_Comes_From_Source_Default (Comes_From_Source (Arg));
6736 -- Positional argument is transformed into an aggregate with an
6737 -- Expressions list.
6739 if Nam = No_Name then
6740 Exprs := New_List (Relocate_Node (Expr));
6742 -- An associative argument is transformed into an aggregate with
6743 -- Component_Associations.
6747 Make_Component_Association (Loc,
6748 Choices => New_List (Make_Identifier (Nam_Loc, Nam)),
6749 Expression => Relocate_Node (Expr)));
6752 Set_Expression (Arg,
6753 Make_Aggregate (Loc,
6754 Component_Associations => Comps,
6755 Expressions => Exprs));
6757 -- Restore Comes_From_Source default
6759 Set_Comes_From_Source_Default (CFSD);
6760 end Ensure_Aggregate_Form;
6766 procedure Error_Pragma (Msg : String) is
6768 Error_Msg_Name_1 := Pname;
6769 Error_Msg_N (Fix_Error (Msg), N);
6773 ----------------------
6774 -- Error_Pragma_Arg --
6775 ----------------------
6777 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
6779 Error_Msg_Name_1 := Pname;
6780 Error_Msg_N (Fix_Error (Msg), Get_Pragma_Arg (Arg));
6782 end Error_Pragma_Arg;
6784 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
6786 Error_Msg_Name_1 := Pname;
6787 Error_Msg_N (Fix_Error (Msg1), Get_Pragma_Arg (Arg));
6788 Error_Pragma_Arg (Msg2, Arg);
6789 end Error_Pragma_Arg;
6791 ----------------------------
6792 -- Error_Pragma_Arg_Ident --
6793 ----------------------------
6795 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
6797 Error_Msg_Name_1 := Pname;
6798 Error_Msg_N (Fix_Error (Msg), Arg);
6800 end Error_Pragma_Arg_Ident;
6802 ----------------------
6803 -- Error_Pragma_Ref --
6804 ----------------------
6806 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
6808 Error_Msg_Name_1 := Pname;
6809 Error_Msg_Sloc := Sloc (Ref);
6810 Error_Msg_NE (Fix_Error (Msg), N, Ref);
6812 end Error_Pragma_Ref;
6814 ------------------------
6815 -- Find_Lib_Unit_Name --
6816 ------------------------
6818 function Find_Lib_Unit_Name return Entity_Id is
6820 -- Return inner compilation unit entity, for case of nested
6821 -- categorization pragmas. This happens in generic unit.
6823 if Nkind (Parent (N)) = N_Package_Specification
6824 and then Defining_Entity (Parent (N)) /= Current_Scope
6826 return Defining_Entity (Parent (N));
6828 return Current_Scope;
6830 end Find_Lib_Unit_Name;
6832 ----------------------------
6833 -- Find_Program_Unit_Name --
6834 ----------------------------
6836 procedure Find_Program_Unit_Name (Id : Node_Id) is
6837 Unit_Name : Entity_Id;
6838 Unit_Kind : Node_Kind;
6839 P : constant Node_Id := Parent (N);
6842 if Nkind (P) = N_Compilation_Unit then
6843 Unit_Kind := Nkind (Unit (P));
6845 if Nkind_In (Unit_Kind, N_Subprogram_Declaration,
6846 N_Package_Declaration)
6847 or else Unit_Kind in N_Generic_Declaration
6849 Unit_Name := Defining_Entity (Unit (P));
6851 if Chars (Id) = Chars (Unit_Name) then
6852 Set_Entity (Id, Unit_Name);
6853 Set_Etype (Id, Etype (Unit_Name));
6855 Set_Etype (Id, Any_Type);
6857 ("cannot find program unit referenced by pragma%");
6861 Set_Etype (Id, Any_Type);
6862 Error_Pragma ("pragma% inapplicable to this unit");
6868 end Find_Program_Unit_Name;
6870 -----------------------------------------
6871 -- Find_Unique_Parameterless_Procedure --
6872 -----------------------------------------
6874 function Find_Unique_Parameterless_Procedure
6876 Arg : Node_Id) return Entity_Id
6878 Proc : Entity_Id := Empty;
6881 -- The body of this procedure needs some comments ???
6883 if not Is_Entity_Name (Name) then
6885 ("argument of pragma% must be entity name", Arg);
6887 elsif not Is_Overloaded (Name) then
6888 Proc := Entity (Name);
6890 if Ekind (Proc) /= E_Procedure
6891 or else Present (First_Formal (Proc))
6894 ("argument of pragma% must be parameterless procedure", Arg);
6899 Found : Boolean := False;
6901 Index : Interp_Index;
6904 Get_First_Interp (Name, Index, It);
6905 while Present (It.Nam) loop
6908 if Ekind (Proc) = E_Procedure
6909 and then No (First_Formal (Proc))
6913 Set_Entity (Name, Proc);
6914 Set_Is_Overloaded (Name, False);
6917 ("ambiguous handler name for pragma% ", Arg);
6921 Get_Next_Interp (Index, It);
6926 ("argument of pragma% must be parameterless procedure",
6929 Proc := Entity (Name);
6935 end Find_Unique_Parameterless_Procedure;
6941 function Fix_Error (Msg : String) return String is
6942 Res : String (Msg'Range) := Msg;
6943 Res_Last : Natural := Msg'Last;
6947 -- If we have a rewriting of another pragma, go to that pragma
6949 if Is_Rewrite_Substitution (N)
6950 and then Nkind (Original_Node (N)) = N_Pragma
6952 Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
6955 -- Case where pragma comes from an aspect specification
6957 if From_Aspect_Specification (N) then
6959 -- Change appearence of "pragma" in message to "aspect"
6962 while J <= Res_Last - 5 loop
6963 if Res (J .. J + 5) = "pragma" then
6964 Res (J .. J + 5) := "aspect";
6972 -- Change "argument of" at start of message to "entity for"
6975 and then Res (Res'First .. Res'First + 10) = "argument of"
6977 Res (Res'First .. Res'First + 9) := "entity for";
6978 Res (Res'First + 10 .. Res_Last - 1) :=
6979 Res (Res'First + 11 .. Res_Last);
6980 Res_Last := Res_Last - 1;
6983 -- Change "argument" at start of message to "entity"
6986 and then Res (Res'First .. Res'First + 7) = "argument"
6988 Res (Res'First .. Res'First + 5) := "entity";
6989 Res (Res'First + 6 .. Res_Last - 2) :=
6990 Res (Res'First + 8 .. Res_Last);
6991 Res_Last := Res_Last - 2;
6994 -- Get name from corresponding aspect
6996 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
6999 -- Return possibly modified message
7001 return Res (Res'First .. Res_Last);
7004 -------------------------
7005 -- Gather_Associations --
7006 -------------------------
7008 procedure Gather_Associations
7010 Args : out Args_List)
7015 -- Initialize all parameters to Empty
7017 for J in Args'Range loop
7021 -- That's all we have to do if there are no argument associations
7023 if No (Pragma_Argument_Associations (N)) then
7027 -- Otherwise first deal with any positional parameters present
7029 Arg := First (Pragma_Argument_Associations (N));
7030 for Index in Args'Range loop
7031 exit when No (Arg) or else Chars (Arg) /= No_Name;
7032 Args (Index) := Get_Pragma_Arg (Arg);
7036 -- Positional parameters all processed, if any left, then we
7037 -- have too many positional parameters.
7039 if Present (Arg) and then Chars (Arg) = No_Name then
7041 ("too many positional associations for pragma%", Arg);
7044 -- Process named parameters if any are present
7046 while Present (Arg) loop
7047 if Chars (Arg) = No_Name then
7049 ("positional association cannot follow named association",
7053 for Index in Names'Range loop
7054 if Names (Index) = Chars (Arg) then
7055 if Present (Args (Index)) then
7057 ("duplicate argument association for pragma%", Arg);
7059 Args (Index) := Get_Pragma_Arg (Arg);
7064 if Index = Names'Last then
7065 Error_Msg_Name_1 := Pname;
7066 Error_Msg_N ("pragma% does not allow & argument", Arg);
7068 -- Check for possible misspelling
7070 for Index1 in Names'Range loop
7071 if Is_Bad_Spelling_Of
7072 (Chars (Arg), Names (Index1))
7074 Error_Msg_Name_1 := Names (Index1);
7075 Error_Msg_N -- CODEFIX
7076 ("\possible misspelling of%", Arg);
7088 end Gather_Associations;
7094 procedure GNAT_Pragma is
7096 -- We need to check the No_Implementation_Pragmas restriction for
7097 -- the case of a pragma from source. Note that the case of aspects
7098 -- generating corresponding pragmas marks these pragmas as not being
7099 -- from source, so this test also catches that case.
7101 if Comes_From_Source (N) then
7102 Check_Restriction (No_Implementation_Pragmas, N);
7106 --------------------------
7107 -- Is_Before_First_Decl --
7108 --------------------------
7110 function Is_Before_First_Decl
7111 (Pragma_Node : Node_Id;
7112 Decls : List_Id) return Boolean
7114 Item : Node_Id := First (Decls);
7117 -- Only other pragmas can come before this pragma, but they might
7118 -- have been rewritten so check the original node.
7121 if No (Item) or else Nkind (Original_Node (Item)) /= N_Pragma then
7124 elsif Item = Pragma_Node then
7130 end Is_Before_First_Decl;
7132 -----------------------------
7133 -- Is_Configuration_Pragma --
7134 -----------------------------
7136 -- A configuration pragma must appear in the context clause of a
7137 -- compilation unit, and only other pragmas may precede it. Note that
7138 -- the test below also permits use in a configuration pragma file.
7140 function Is_Configuration_Pragma return Boolean is
7141 Lis : constant List_Id := List_Containing (N);
7142 Par : constant Node_Id := Parent (N);
7146 -- If no parent, then we are in the configuration pragma file,
7147 -- so the placement is definitely appropriate.
7152 -- Otherwise we must be in the context clause of a compilation unit
7153 -- and the only thing allowed before us in the context list is more
7154 -- configuration pragmas.
7156 elsif Nkind (Par) = N_Compilation_Unit
7157 and then Context_Items (Par) = Lis
7164 elsif Nkind (Prg) /= N_Pragma then
7174 end Is_Configuration_Pragma;
7176 --------------------------
7177 -- Is_In_Context_Clause --
7178 --------------------------
7180 function Is_In_Context_Clause return Boolean is
7182 Parent_Node : Node_Id;
7185 if not Is_List_Member (N) then
7189 Plist := List_Containing (N);
7190 Parent_Node := Parent (Plist);
7192 if Parent_Node = Empty
7193 or else Nkind (Parent_Node) /= N_Compilation_Unit
7194 or else Context_Items (Parent_Node) /= Plist
7201 end Is_In_Context_Clause;
7203 ---------------------------------
7204 -- Is_Static_String_Expression --
7205 ---------------------------------
7207 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
7208 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
7209 Lit : constant Boolean := Nkind (Argx) = N_String_Literal;
7212 Analyze_And_Resolve (Argx);
7214 -- Special case Ada 83, where the expression will never be static,
7215 -- but we will return true if we had a string literal to start with.
7217 if Ada_Version = Ada_83 then
7220 -- Normal case, true only if we end up with a string literal that
7221 -- is marked as being the result of evaluating a static expression.
7224 return Is_OK_Static_Expression (Argx)
7225 and then Nkind (Argx) = N_String_Literal;
7228 end Is_Static_String_Expression;
7230 ----------------------
7231 -- Pragma_Misplaced --
7232 ----------------------
7234 procedure Pragma_Misplaced is
7236 Error_Pragma ("incorrect placement of pragma%");
7237 end Pragma_Misplaced;
7239 ------------------------------------------------
7240 -- Process_Atomic_Independent_Shared_Volatile --
7241 ------------------------------------------------
7243 procedure Process_Atomic_Independent_Shared_Volatile is
7244 procedure Check_VFA_Conflicts (Ent : Entity_Id);
7245 -- Apply additional checks for the GNAT pragma Volatile_Full_Access
7247 procedure Mark_Component_Or_Object (Ent : Entity_Id);
7248 -- Appropriately set flags on the given entity (either an array or
7249 -- record component, or an object declaration) according to the
7252 procedure Set_Atomic_VFA (Ent : Entity_Id);
7253 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
7254 -- no explicit alignment was given, set alignment to unknown, since
7255 -- back end knows what the alignment requirements are for atomic and
7256 -- full access arrays. Note: this is necessary for derived types.
7258 -------------------------
7259 -- Check_VFA_Conflicts --
7260 -------------------------
7262 procedure Check_VFA_Conflicts (Ent : Entity_Id) is
7266 VFA_And_Atomic : Boolean := False;
7267 -- Set True if atomic component present
7269 VFA_And_Aliased : Boolean := False;
7270 -- Set True if aliased component present
7273 -- Fetch the type in case we are dealing with an object or
7276 if Is_Type (Ent) then
7279 pragma Assert (Is_Object (Ent)
7281 Nkind (Declaration_Node (Ent)) = N_Component_Declaration);
7286 -- Check Atomic and VFA used together
7288 if Prag_Id = Pragma_Volatile_Full_Access
7289 or else Is_Volatile_Full_Access (Ent)
7291 if Prag_Id = Pragma_Atomic
7292 or else Prag_Id = Pragma_Shared
7293 or else Is_Atomic (Ent)
7295 VFA_And_Atomic := True;
7297 elsif Is_Array_Type (Typ) then
7298 VFA_And_Atomic := Has_Atomic_Components (Typ);
7300 -- Note: Has_Atomic_Components is not used below, as this flag
7301 -- represents the pragma of the same name, Atomic_Components,
7302 -- which only applies to arrays.
7304 elsif Is_Record_Type (Typ) then
7305 -- Attributes cannot be applied to discriminants, only
7306 -- regular record components.
7308 Comp := First_Component (Typ);
7309 while Present (Comp) loop
7311 or else Is_Atomic (Typ)
7313 VFA_And_Atomic := True;
7318 Next_Component (Comp);
7322 if VFA_And_Atomic then
7324 ("cannot have Volatile_Full_Access and Atomic for same "
7329 -- Check for the application of VFA to an entity that has aliased
7332 if Prag_Id = Pragma_Volatile_Full_Access then
7333 if Is_Array_Type (Typ)
7334 and then Has_Aliased_Components (Typ)
7336 VFA_And_Aliased := True;
7338 -- Note: Has_Aliased_Components, like Has_Atomic_Components,
7339 -- and Has_Independent_Components, applies only to arrays.
7340 -- However, this flag does not have a corresponding pragma, so
7341 -- perhaps it should be possible to apply it to record types as
7342 -- well. Should this be done ???
7344 elsif Is_Record_Type (Typ) then
7345 -- It is possible to have an aliased discriminant, so they
7346 -- must be checked along with normal components.
7348 Comp := First_Component_Or_Discriminant (Typ);
7349 while Present (Comp) loop
7350 if Is_Aliased (Comp)
7351 or else Is_Aliased (Etype (Comp))
7353 VFA_And_Aliased := True;
7354 Check_SPARK_05_Restriction
7355 ("aliased is not allowed", Comp);
7360 Next_Component_Or_Discriminant (Comp);
7364 if VFA_And_Aliased then
7366 ("cannot apply Volatile_Full_Access (aliased component "
7370 end Check_VFA_Conflicts;
7372 ------------------------------
7373 -- Mark_Component_Or_Object --
7374 ------------------------------
7376 procedure Mark_Component_Or_Object (Ent : Entity_Id) is
7378 if Prag_Id = Pragma_Atomic
7379 or else Prag_Id = Pragma_Shared
7380 or else Prag_Id = Pragma_Volatile_Full_Access
7382 if Prag_Id = Pragma_Volatile_Full_Access then
7383 Set_Is_Volatile_Full_Access (Ent);
7385 Set_Is_Atomic (Ent);
7388 -- If the object declaration has an explicit initialization, a
7389 -- temporary may have to be created to hold the expression, to
7390 -- ensure that access to the object remains atomic.
7392 if Nkind (Parent (Ent)) = N_Object_Declaration
7393 and then Present (Expression (Parent (Ent)))
7395 Set_Has_Delayed_Freeze (Ent);
7399 -- Atomic/Shared/Volatile_Full_Access imply Independent
7401 if Prag_Id /= Pragma_Volatile then
7402 Set_Is_Independent (Ent);
7404 if Prag_Id = Pragma_Independent then
7405 Record_Independence_Check (N, Ent);
7409 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7411 if Prag_Id /= Pragma_Independent then
7412 Set_Is_Volatile (Ent);
7413 Set_Treat_As_Volatile (Ent);
7415 end Mark_Component_Or_Object;
7417 --------------------
7418 -- Set_Atomic_VFA --
7419 --------------------
7421 procedure Set_Atomic_VFA (Ent : Entity_Id) is
7423 if Prag_Id = Pragma_Volatile_Full_Access then
7424 Set_Is_Volatile_Full_Access (Ent);
7426 Set_Is_Atomic (Ent);
7429 if not Has_Alignment_Clause (Ent) then
7430 Set_Alignment (Ent, Uint_0);
7440 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
7443 Check_Ada_83_Warning;
7444 Check_No_Identifiers;
7445 Check_Arg_Count (1);
7446 Check_Arg_Is_Local_Name (Arg1);
7447 E_Arg := Get_Pragma_Arg (Arg1);
7449 if Etype (E_Arg) = Any_Type then
7453 E := Entity (E_Arg);
7455 -- A pragma that applies to a Ghost entity becomes Ghost for the
7456 -- purposes of legality checks and removal of ignored Ghost code.
7458 Mark_Ghost_Pragma (N, E);
7460 -- Check duplicate before we chain ourselves
7462 Check_Duplicate_Pragma (E);
7464 -- Check appropriateness of the entity
7466 Decl := Declaration_Node (E);
7468 -- Deal with the case where the pragma/attribute is applied to a type
7471 if Rep_Item_Too_Early (E, N)
7472 or else Rep_Item_Too_Late (E, N)
7476 Check_First_Subtype (Arg1);
7479 -- Attribute belongs on the base type. If the view of the type is
7480 -- currently private, it also belongs on the underlying type.
7482 if Prag_Id = Pragma_Atomic
7483 or else Prag_Id = Pragma_Shared
7484 or else Prag_Id = Pragma_Volatile_Full_Access
7487 Set_Atomic_VFA (Base_Type (E));
7488 Set_Atomic_VFA (Underlying_Type (E));
7491 -- Atomic/Shared/Volatile_Full_Access imply Independent
7493 if Prag_Id /= Pragma_Volatile then
7494 Set_Is_Independent (E);
7495 Set_Is_Independent (Base_Type (E));
7496 Set_Is_Independent (Underlying_Type (E));
7498 if Prag_Id = Pragma_Independent then
7499 Record_Independence_Check (N, Base_Type (E));
7503 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7505 if Prag_Id /= Pragma_Independent then
7506 Set_Is_Volatile (E);
7507 Set_Is_Volatile (Base_Type (E));
7508 Set_Is_Volatile (Underlying_Type (E));
7510 Set_Treat_As_Volatile (E);
7511 Set_Treat_As_Volatile (Underlying_Type (E));
7514 -- Apply Volatile to the composite type's individual components,
7517 if Prag_Id = Pragma_Volatile
7518 and then Is_Record_Type (Etype (E))
7523 Comp := First_Component (E);
7524 while Present (Comp) loop
7525 Mark_Component_Or_Object (Comp);
7527 Next_Component (Comp);
7532 -- Deal with the case where the pragma/attribute applies to a
7533 -- component or object declaration.
7535 elsif Nkind (Decl) = N_Object_Declaration
7536 or else (Nkind (Decl) = N_Component_Declaration
7537 and then Original_Record_Component (E) = E)
7539 if Rep_Item_Too_Late (E, N) then
7543 Mark_Component_Or_Object (E);
7545 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
7548 -- Perform the checks needed to assure the proper use of the GNAT
7549 -- pragma Volatile_Full_Access.
7551 Check_VFA_Conflicts (E);
7553 -- The following check is only relevant when SPARK_Mode is on as
7554 -- this is not a standard Ada legality rule. Pragma Volatile can
7555 -- only apply to a full type declaration or an object declaration
7556 -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for
7557 -- untagged derived types that are rewritten as subtypes of their
7558 -- respective root types.
7561 and then Prag_Id = Pragma_Volatile
7562 and then not Nkind_In (Original_Node (Decl),
7563 N_Full_Type_Declaration,
7564 N_Object_Declaration,
7565 N_Single_Protected_Declaration,
7566 N_Single_Task_Declaration)
7569 ("argument of pragma % must denote a full type or object "
7570 & "declaration", Arg1);
7572 end Process_Atomic_Independent_Shared_Volatile;
7574 -------------------------------------------
7575 -- Process_Compile_Time_Warning_Or_Error --
7576 -------------------------------------------
7578 procedure Process_Compile_Time_Warning_Or_Error is
7579 P : Node_Id := Parent (N);
7580 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
7582 -- In GNATprove mode, pragmas Compile_Time_Error and
7583 -- Compile_Time_Warning are ignored, as the analyzer may not have the
7584 -- same information as the compiler (in particular regarding size of
7585 -- objects decided in gigi) so it makes no sense to issue an error or
7586 -- warning in GNATprove.
7588 if GNATprove_Mode then
7589 Rewrite (N, Make_Null_Statement (Loc));
7593 Check_Arg_Count (2);
7594 Check_No_Identifiers;
7595 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
7596 Analyze_And_Resolve (Arg1x, Standard_Boolean);
7598 -- If the condition is known at compile time (now), validate it now.
7599 -- Otherwise, register the expression for validation after the back
7600 -- end has been called, because it might be known at compile time
7601 -- then. For example, if the expression is "Record_Type'Size /= 32"
7602 -- it might be known after the back end has determined the size of
7603 -- Record_Type. We do not defer validation if we're inside a generic
7604 -- unit, because we will have more information in the instances.
7606 if Compile_Time_Known_Value (Arg1x) then
7607 Validate_Compile_Time_Warning_Or_Error (N, Sloc (Arg1));
7609 while Present (P) and then Nkind (P) not in N_Generic_Declaration
7611 if Nkind_In (P, N_Package_Body, N_Subprogram_Body) then
7612 P := Corresponding_Spec (P);
7619 Defer_Compile_Time_Warning_Error_To_BE (N);
7622 end Process_Compile_Time_Warning_Or_Error;
7624 ------------------------
7625 -- Process_Convention --
7626 ------------------------
7628 procedure Process_Convention
7629 (C : out Convention_Id;
7630 Ent : out Entity_Id)
7634 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
7635 -- Called if we have more than one Export/Import/Convention pragma.
7636 -- This is generally illegal, but we have a special case of allowing
7637 -- Import and Interface to coexist if they specify the convention in
7638 -- a consistent manner. We are allowed to do this, since Interface is
7639 -- an implementation defined pragma, and we choose to do it since we
7640 -- know Rational allows this combination. S is the entity id of the
7641 -- subprogram in question. This procedure also sets the special flag
7642 -- Import_Interface_Present in both pragmas in the case where we do
7643 -- have matching Import and Interface pragmas.
7645 procedure Set_Convention_From_Pragma (E : Entity_Id);
7646 -- Set convention in entity E, and also flag that the entity has a
7647 -- convention pragma. If entity is for a private or incomplete type,
7648 -- also set convention and flag on underlying type. This procedure
7649 -- also deals with the special case of C_Pass_By_Copy convention,
7650 -- and error checks for inappropriate convention specification.
7652 -------------------------------
7653 -- Diagnose_Multiple_Pragmas --
7654 -------------------------------
7656 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
7657 Pdec : constant Node_Id := Declaration_Node (S);
7661 function Same_Convention (Decl : Node_Id) return Boolean;
7662 -- Decl is a pragma node. This function returns True if this
7663 -- pragma has a first argument that is an identifier with a
7664 -- Chars field corresponding to the Convention_Id C.
7666 function Same_Name (Decl : Node_Id) return Boolean;
7667 -- Decl is a pragma node. This function returns True if this
7668 -- pragma has a second argument that is an identifier with a
7669 -- Chars field that matches the Chars of the current subprogram.
7671 ---------------------
7672 -- Same_Convention --
7673 ---------------------
7675 function Same_Convention (Decl : Node_Id) return Boolean is
7676 Arg1 : constant Node_Id :=
7677 First (Pragma_Argument_Associations (Decl));
7680 if Present (Arg1) then
7682 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
7684 if Nkind (Arg) = N_Identifier
7685 and then Is_Convention_Name (Chars (Arg))
7686 and then Get_Convention_Id (Chars (Arg)) = C
7694 end Same_Convention;
7700 function Same_Name (Decl : Node_Id) return Boolean is
7701 Arg1 : constant Node_Id :=
7702 First (Pragma_Argument_Associations (Decl));
7710 Arg2 := Next (Arg1);
7717 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
7719 if Nkind (Arg) = N_Identifier
7720 and then Chars (Arg) = Chars (S)
7729 -- Start of processing for Diagnose_Multiple_Pragmas
7734 -- Definitely give message if we have Convention/Export here
7736 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
7739 -- If we have an Import or Export, scan back from pragma to
7740 -- find any previous pragma applying to the same procedure.
7741 -- The scan will be terminated by the start of the list, or
7742 -- hitting the subprogram declaration. This won't allow one
7743 -- pragma to appear in the public part and one in the private
7744 -- part, but that seems very unlikely in practice.
7748 while Present (Decl) and then Decl /= Pdec loop
7750 -- Look for pragma with same name as us
7752 if Nkind (Decl) = N_Pragma
7753 and then Same_Name (Decl)
7755 -- Give error if same as our pragma or Export/Convention
7757 if Nam_In (Pragma_Name_Unmapped (Decl),
7760 Pragma_Name_Unmapped (N))
7764 -- Case of Import/Interface or the other way round
7766 elsif Nam_In (Pragma_Name_Unmapped (Decl),
7767 Name_Interface, Name_Import)
7769 -- Here we know that we have Import and Interface. It
7770 -- doesn't matter which way round they are. See if
7771 -- they specify the same convention. If so, all OK,
7772 -- and set special flags to stop other messages
7774 if Same_Convention (Decl) then
7775 Set_Import_Interface_Present (N);
7776 Set_Import_Interface_Present (Decl);
7779 -- If different conventions, special message
7782 Error_Msg_Sloc := Sloc (Decl);
7784 ("convention differs from that given#", Arg1);
7794 -- Give message if needed if we fall through those tests
7795 -- except on Relaxed_RM_Semantics where we let go: either this
7796 -- is a case accepted/ignored by other Ada compilers (e.g.
7797 -- a mix of Convention and Import), or another error will be
7798 -- generated later (e.g. using both Import and Export).
7800 if Err and not Relaxed_RM_Semantics then
7802 ("at most one Convention/Export/Import pragma is allowed",
7805 end Diagnose_Multiple_Pragmas;
7807 --------------------------------
7808 -- Set_Convention_From_Pragma --
7809 --------------------------------
7811 procedure Set_Convention_From_Pragma (E : Entity_Id) is
7813 -- Ada 2005 (AI-430): Check invalid attempt to change convention
7814 -- for an overridden dispatching operation. Technically this is
7815 -- an amendment and should only be done in Ada 2005 mode. However,
7816 -- this is clearly a mistake, since the problem that is addressed
7817 -- by this AI is that there is a clear gap in the RM.
7819 if Is_Dispatching_Operation (E)
7820 and then Present (Overridden_Operation (E))
7821 and then C /= Convention (Overridden_Operation (E))
7824 ("cannot change convention for overridden dispatching "
7825 & "operation", Arg1);
7828 -- Special checks for Convention_Stdcall
7830 if C = Convention_Stdcall then
7832 -- A dispatching call is not allowed. A dispatching subprogram
7833 -- cannot be used to interface to the Win32 API, so in fact
7834 -- this check does not impose any effective restriction.
7836 if Is_Dispatching_Operation (E) then
7837 Error_Msg_Sloc := Sloc (E);
7839 -- Note: make this unconditional so that if there is more
7840 -- than one call to which the pragma applies, we get a
7841 -- message for each call. Also don't use Error_Pragma,
7842 -- so that we get multiple messages.
7845 ("dispatching subprogram# cannot use Stdcall convention!",
7848 -- Several allowed cases
7850 elsif Is_Subprogram_Or_Generic_Subprogram (E)
7854 or else Ekind (E) = E_Variable
7856 -- A component as well. The entity does not have its Ekind
7857 -- set until the enclosing record declaration is fully
7860 or else Nkind (Parent (E)) = N_Component_Declaration
7862 -- An access to subprogram is also allowed
7866 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
7868 -- Allow internal call to set convention of subprogram type
7870 or else Ekind (E) = E_Subprogram_Type
7876 ("second argument of pragma% must be subprogram (type)",
7881 -- Set the convention
7883 Set_Convention (E, C);
7884 Set_Has_Convention_Pragma (E);
7886 -- For the case of a record base type, also set the convention of
7887 -- any anonymous access types declared in the record which do not
7888 -- currently have a specified convention.
7890 if Is_Record_Type (E) and then Is_Base_Type (E) then
7895 Comp := First_Component (E);
7896 while Present (Comp) loop
7897 if Present (Etype (Comp))
7898 and then Ekind_In (Etype (Comp),
7899 E_Anonymous_Access_Type,
7900 E_Anonymous_Access_Subprogram_Type)
7901 and then not Has_Convention_Pragma (Comp)
7903 Set_Convention (Comp, C);
7906 Next_Component (Comp);
7911 -- Deal with incomplete/private type case, where underlying type
7912 -- is available, so set convention of that underlying type.
7914 if Is_Incomplete_Or_Private_Type (E)
7915 and then Present (Underlying_Type (E))
7917 Set_Convention (Underlying_Type (E), C);
7918 Set_Has_Convention_Pragma (Underlying_Type (E), True);
7921 -- A class-wide type should inherit the convention of the specific
7922 -- root type (although this isn't specified clearly by the RM).
7924 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
7925 Set_Convention (Class_Wide_Type (E), C);
7928 -- If the entity is a record type, then check for special case of
7929 -- C_Pass_By_Copy, which is treated the same as C except that the
7930 -- special record flag is set. This convention is only permitted
7931 -- on record types (see AI95-00131).
7933 if Cname = Name_C_Pass_By_Copy then
7934 if Is_Record_Type (E) then
7935 Set_C_Pass_By_Copy (Base_Type (E));
7936 elsif Is_Incomplete_Or_Private_Type (E)
7937 and then Is_Record_Type (Underlying_Type (E))
7939 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
7942 ("C_Pass_By_Copy convention allowed only for record type",
7947 -- If the entity is a derived boolean type, check for the special
7948 -- case of convention C, C++, or Fortran, where we consider any
7949 -- nonzero value to represent true.
7951 if Is_Discrete_Type (E)
7952 and then Root_Type (Etype (E)) = Standard_Boolean
7958 C = Convention_Fortran)
7960 Set_Nonzero_Is_True (Base_Type (E));
7962 end Set_Convention_From_Pragma;
7966 Comp_Unit : Unit_Number_Type;
7971 -- Start of processing for Process_Convention
7974 Check_At_Least_N_Arguments (2);
7975 Check_Optional_Identifier (Arg1, Name_Convention);
7976 Check_Arg_Is_Identifier (Arg1);
7977 Cname := Chars (Get_Pragma_Arg (Arg1));
7979 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
7980 -- tested again below to set the critical flag).
7982 if Cname = Name_C_Pass_By_Copy then
7985 -- Otherwise we must have something in the standard convention list
7987 elsif Is_Convention_Name (Cname) then
7988 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
7990 -- Otherwise warn on unrecognized convention
7993 if Warn_On_Export_Import then
7995 ("??unrecognized convention name, C assumed",
7996 Get_Pragma_Arg (Arg1));
8002 Check_Optional_Identifier (Arg2, Name_Entity);
8003 Check_Arg_Is_Local_Name (Arg2);
8005 Id := Get_Pragma_Arg (Arg2);
8008 if not Is_Entity_Name (Id) then
8009 Error_Pragma_Arg ("entity name required", Arg2);
8014 -- Set entity to return
8018 -- Ada_Pass_By_Copy special checking
8020 if C = Convention_Ada_Pass_By_Copy then
8021 if not Is_First_Subtype (E) then
8023 ("convention `Ada_Pass_By_Copy` only allowed for types",
8027 if Is_By_Reference_Type (E) then
8029 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
8033 -- Ada_Pass_By_Reference special checking
8035 elsif C = Convention_Ada_Pass_By_Reference then
8036 if not Is_First_Subtype (E) then
8038 ("convention `Ada_Pass_By_Reference` only allowed for types",
8042 if Is_By_Copy_Type (E) then
8044 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
8049 -- Go to renamed subprogram if present, since convention applies to
8050 -- the actual renamed entity, not to the renaming entity. If the
8051 -- subprogram is inherited, go to parent subprogram.
8053 if Is_Subprogram (E)
8054 and then Present (Alias (E))
8056 if Nkind (Parent (Declaration_Node (E))) =
8057 N_Subprogram_Renaming_Declaration
8059 if Scope (E) /= Scope (Alias (E)) then
8061 ("cannot apply pragma% to non-local entity&#", E);
8066 elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
8067 N_Private_Extension_Declaration)
8068 and then Scope (E) = Scope (Alias (E))
8072 -- Return the parent subprogram the entity was inherited from
8078 -- Check that we are not applying this to a specless body. Relax this
8079 -- check if Relaxed_RM_Semantics to accommodate other Ada compilers.
8081 if Is_Subprogram (E)
8082 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
8083 and then not Relaxed_RM_Semantics
8086 ("pragma% requires separate spec and must come before body");
8089 -- Check that we are not applying this to a named constant
8091 if Ekind_In (E, E_Named_Integer, E_Named_Real) then
8092 Error_Msg_Name_1 := Pname;
8094 ("cannot apply pragma% to named constant!",
8095 Get_Pragma_Arg (Arg2));
8097 ("\supply appropriate type for&!", Arg2);
8100 if Ekind (E) = E_Enumeration_Literal then
8101 Error_Pragma ("enumeration literal not allowed for pragma%");
8104 -- Check for rep item appearing too early or too late
8106 if Etype (E) = Any_Type
8107 or else Rep_Item_Too_Early (E, N)
8111 elsif Present (Underlying_Type (E)) then
8112 E := Underlying_Type (E);
8115 if Rep_Item_Too_Late (E, N) then
8119 if Has_Convention_Pragma (E) then
8120 Diagnose_Multiple_Pragmas (E);
8122 elsif Convention (E) = Convention_Protected
8123 or else Ekind (Scope (E)) = E_Protected_Type
8126 ("a protected operation cannot be given a different convention",
8130 -- For Intrinsic, a subprogram is required
8132 if C = Convention_Intrinsic
8133 and then not Is_Subprogram_Or_Generic_Subprogram (E)
8135 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
8137 if not (Is_Type (E) and then Relaxed_RM_Semantics) then
8139 ("second argument of pragma% must be a subprogram", Arg2);
8143 -- Deal with non-subprogram cases
8145 if not Is_Subprogram_Or_Generic_Subprogram (E) then
8146 Set_Convention_From_Pragma (E);
8150 -- The pragma must apply to a first subtype, but it can also
8151 -- apply to a generic type in a generic formal part, in which
8152 -- case it will also appear in the corresponding instance.
8154 if Is_Generic_Type (E) or else In_Instance then
8157 Check_First_Subtype (Arg2);
8160 Set_Convention_From_Pragma (Base_Type (E));
8162 -- For access subprograms, we must set the convention on the
8163 -- internally generated directly designated type as well.
8165 if Ekind (E) = E_Access_Subprogram_Type then
8166 Set_Convention_From_Pragma (Directly_Designated_Type (E));
8170 -- For the subprogram case, set proper convention for all homonyms
8171 -- in same scope and the same declarative part, i.e. the same
8172 -- compilation unit.
8175 Comp_Unit := Get_Source_Unit (E);
8176 Set_Convention_From_Pragma (E);
8178 -- Treat a pragma Import as an implicit body, and pragma import
8179 -- as implicit reference (for navigation in GPS).
8181 if Prag_Id = Pragma_Import then
8182 Generate_Reference (E, Id, 'b');
8184 -- For exported entities we restrict the generation of references
8185 -- to entities exported to foreign languages since entities
8186 -- exported to Ada do not provide further information to GPS and
8187 -- add undesired references to the output of the gnatxref tool.
8189 elsif Prag_Id = Pragma_Export
8190 and then Convention (E) /= Convention_Ada
8192 Generate_Reference (E, Id, 'i');
8195 -- If the pragma comes from an aspect, it only applies to the
8196 -- given entity, not its homonyms.
8198 if From_Aspect_Specification (N) then
8199 if C = Convention_Intrinsic
8200 and then Nkind (Ent) = N_Defining_Operator_Symbol
8202 if Is_Fixed_Point_Type (Etype (Ent))
8203 or else Is_Fixed_Point_Type (Etype (First_Entity (Ent)))
8204 or else Is_Fixed_Point_Type (Etype (Last_Entity (Ent)))
8207 ("no intrinsic operator available for this fixed-point "
8210 ("\use expression functions with the desired "
8211 & "conversions made explicit", N);
8218 -- Otherwise Loop through the homonyms of the pragma argument's
8219 -- entity, an apply convention to those in the current scope.
8225 exit when No (E1) or else Scope (E1) /= Current_Scope;
8227 -- Ignore entry for which convention is already set
8229 if Has_Convention_Pragma (E1) then
8233 if Is_Subprogram (E1)
8234 and then Nkind (Parent (Declaration_Node (E1))) =
8236 and then not Relaxed_RM_Semantics
8238 Set_Has_Completion (E); -- to prevent cascaded error
8240 ("pragma% requires separate spec and must come before "
8244 -- Do not set the pragma on inherited operations or on formal
8247 if Comes_From_Source (E1)
8248 and then Comp_Unit = Get_Source_Unit (E1)
8249 and then not Is_Formal_Subprogram (E1)
8250 and then Nkind (Original_Node (Parent (E1))) /=
8251 N_Full_Type_Declaration
8253 if Present (Alias (E1))
8254 and then Scope (E1) /= Scope (Alias (E1))
8257 ("cannot apply pragma% to non-local entity& declared#",
8261 Set_Convention_From_Pragma (E1);
8263 if Prag_Id = Pragma_Import then
8264 Generate_Reference (E1, Id, 'b');
8272 end Process_Convention;
8274 ----------------------------------------
8275 -- Process_Disable_Enable_Atomic_Sync --
8276 ----------------------------------------
8278 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
8280 Check_No_Identifiers;
8281 Check_At_Most_N_Arguments (1);
8283 -- Modeled internally as
8284 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
8289 Pragma_Argument_Associations => New_List (
8290 Make_Pragma_Argument_Association (Loc,
8292 Make_Identifier (Loc, Name_Atomic_Synchronization)))));
8294 if Present (Arg1) then
8295 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
8299 end Process_Disable_Enable_Atomic_Sync;
8301 -------------------------------------------------
8302 -- Process_Extended_Import_Export_Internal_Arg --
8303 -------------------------------------------------
8305 procedure Process_Extended_Import_Export_Internal_Arg
8306 (Arg_Internal : Node_Id := Empty)
8309 if No (Arg_Internal) then
8310 Error_Pragma ("Internal parameter required for pragma%");
8313 if Nkind (Arg_Internal) = N_Identifier then
8316 elsif Nkind (Arg_Internal) = N_Operator_Symbol
8317 and then (Prag_Id = Pragma_Import_Function
8319 Prag_Id = Pragma_Export_Function)
8325 ("wrong form for Internal parameter for pragma%", Arg_Internal);
8328 Check_Arg_Is_Local_Name (Arg_Internal);
8329 end Process_Extended_Import_Export_Internal_Arg;
8331 --------------------------------------------------
8332 -- Process_Extended_Import_Export_Object_Pragma --
8333 --------------------------------------------------
8335 procedure Process_Extended_Import_Export_Object_Pragma
8336 (Arg_Internal : Node_Id;
8337 Arg_External : Node_Id;
8343 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
8344 Def_Id := Entity (Arg_Internal);
8346 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
8348 ("pragma% must designate an object", Arg_Internal);
8351 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
8353 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
8356 ("previous Common/Psect_Object applies, pragma % not permitted",
8360 if Rep_Item_Too_Late (Def_Id, N) then
8364 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
8366 if Present (Arg_Size) then
8367 Check_Arg_Is_External_Name (Arg_Size);
8370 -- Export_Object case
8372 if Prag_Id = Pragma_Export_Object then
8373 if not Is_Library_Level_Entity (Def_Id) then
8375 ("argument for pragma% must be library level entity",
8379 if Ekind (Current_Scope) = E_Generic_Package then
8380 Error_Pragma ("pragma& cannot appear in a generic unit");
8383 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
8385 ("exported object must have compile time known size",
8389 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
8390 Error_Msg_N ("??duplicate Export_Object pragma", N);
8392 Set_Exported (Def_Id, Arg_Internal);
8395 -- Import_Object case
8398 if Is_Concurrent_Type (Etype (Def_Id)) then
8400 ("cannot use pragma% for task/protected object",
8404 if Ekind (Def_Id) = E_Constant then
8406 ("cannot import a constant", Arg_Internal);
8409 if Warn_On_Export_Import
8410 and then Has_Discriminants (Etype (Def_Id))
8413 ("imported value must be initialized??", Arg_Internal);
8416 if Warn_On_Export_Import
8417 and then Is_Access_Type (Etype (Def_Id))
8420 ("cannot import object of an access type??", Arg_Internal);
8423 if Warn_On_Export_Import
8424 and then Is_Imported (Def_Id)
8426 Error_Msg_N ("??duplicate Import_Object pragma", N);
8428 -- Check for explicit initialization present. Note that an
8429 -- initialization generated by the code generator, e.g. for an
8430 -- access type, does not count here.
8432 elsif Present (Expression (Parent (Def_Id)))
8435 (Original_Node (Expression (Parent (Def_Id))))
8437 Error_Msg_Sloc := Sloc (Def_Id);
8439 ("imported entities cannot be initialized (RM B.1(24))",
8440 "\no initialization allowed for & declared#", Arg1);
8442 Set_Imported (Def_Id);
8443 Note_Possible_Modification (Arg_Internal, Sure => False);
8446 end Process_Extended_Import_Export_Object_Pragma;
8448 ------------------------------------------------------
8449 -- Process_Extended_Import_Export_Subprogram_Pragma --
8450 ------------------------------------------------------
8452 procedure Process_Extended_Import_Export_Subprogram_Pragma
8453 (Arg_Internal : Node_Id;
8454 Arg_External : Node_Id;
8455 Arg_Parameter_Types : Node_Id;
8456 Arg_Result_Type : Node_Id := Empty;
8457 Arg_Mechanism : Node_Id;
8458 Arg_Result_Mechanism : Node_Id := Empty)
8464 Ambiguous : Boolean;
8467 function Same_Base_Type
8469 Formal : Entity_Id) return Boolean;
8470 -- Determines if Ptype references the type of Formal. Note that only
8471 -- the base types need to match according to the spec. Ptype here is
8472 -- the argument from the pragma, which is either a type name, or an
8473 -- access attribute.
8475 --------------------
8476 -- Same_Base_Type --
8477 --------------------
8479 function Same_Base_Type
8481 Formal : Entity_Id) return Boolean
8483 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
8487 -- Case where pragma argument is typ'Access
8489 if Nkind (Ptype) = N_Attribute_Reference
8490 and then Attribute_Name (Ptype) = Name_Access
8492 Pref := Prefix (Ptype);
8495 if not Is_Entity_Name (Pref)
8496 or else Entity (Pref) = Any_Type
8501 -- We have a match if the corresponding argument is of an
8502 -- anonymous access type, and its designated type matches the
8503 -- type of the prefix of the access attribute
8505 return Ekind (Ftyp) = E_Anonymous_Access_Type
8506 and then Base_Type (Entity (Pref)) =
8507 Base_Type (Etype (Designated_Type (Ftyp)));
8509 -- Case where pragma argument is a type name
8514 if not Is_Entity_Name (Ptype)
8515 or else Entity (Ptype) = Any_Type
8520 -- We have a match if the corresponding argument is of the type
8521 -- given in the pragma (comparing base types)
8523 return Base_Type (Entity (Ptype)) = Ftyp;
8527 -- Start of processing for
8528 -- Process_Extended_Import_Export_Subprogram_Pragma
8531 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
8535 -- Loop through homonyms (overloadings) of the entity
8537 Hom_Id := Entity (Arg_Internal);
8538 while Present (Hom_Id) loop
8539 Def_Id := Get_Base_Subprogram (Hom_Id);
8541 -- We need a subprogram in the current scope
8543 if not Is_Subprogram (Def_Id)
8544 or else Scope (Def_Id) /= Current_Scope
8551 -- Pragma cannot apply to subprogram body
8553 if Is_Subprogram (Def_Id)
8554 and then Nkind (Parent (Declaration_Node (Def_Id))) =
8558 ("pragma% requires separate spec and must come before "
8562 -- Test result type if given, note that the result type
8563 -- parameter can only be present for the function cases.
8565 if Present (Arg_Result_Type)
8566 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
8570 elsif Etype (Def_Id) /= Standard_Void_Type
8571 and then Nam_In (Pname, Name_Export_Procedure,
8572 Name_Import_Procedure)
8576 -- Test parameter types if given. Note that this parameter has
8577 -- not been analyzed (and must not be, since it is semantic
8578 -- nonsense), so we get it as the parser left it.
8580 elsif Present (Arg_Parameter_Types) then
8581 Check_Matching_Types : declare
8586 Formal := First_Formal (Def_Id);
8588 if Nkind (Arg_Parameter_Types) = N_Null then
8589 if Present (Formal) then
8593 -- A list of one type, e.g. (List) is parsed as a
8594 -- parenthesized expression.
8596 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
8597 and then Paren_Count (Arg_Parameter_Types) = 1
8600 or else Present (Next_Formal (Formal))
8605 Same_Base_Type (Arg_Parameter_Types, Formal);
8608 -- A list of more than one type is parsed as a aggregate
8610 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
8611 and then Paren_Count (Arg_Parameter_Types) = 0
8613 Ptype := First (Expressions (Arg_Parameter_Types));
8614 while Present (Ptype) or else Present (Formal) loop
8617 or else not Same_Base_Type (Ptype, Formal)
8622 Next_Formal (Formal);
8627 -- Anything else is of the wrong form
8631 ("wrong form for Parameter_Types parameter",
8632 Arg_Parameter_Types);
8634 end Check_Matching_Types;
8637 -- Match is now False if the entry we found did not match
8638 -- either a supplied Parameter_Types or Result_Types argument
8644 -- Ambiguous case, the flag Ambiguous shows if we already
8645 -- detected this and output the initial messages.
8648 if not Ambiguous then
8650 Error_Msg_Name_1 := Pname;
8652 ("pragma% does not uniquely identify subprogram!",
8654 Error_Msg_Sloc := Sloc (Ent);
8655 Error_Msg_N ("matching subprogram #!", N);
8659 Error_Msg_Sloc := Sloc (Def_Id);
8660 Error_Msg_N ("matching subprogram #!", N);
8665 Hom_Id := Homonym (Hom_Id);
8668 -- See if we found an entry
8671 if not Ambiguous then
8672 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
8674 ("pragma% cannot be given for generic subprogram");
8677 ("pragma% does not identify local subprogram");
8684 -- Import pragmas must be for imported entities
8686 if Prag_Id = Pragma_Import_Function
8688 Prag_Id = Pragma_Import_Procedure
8690 Prag_Id = Pragma_Import_Valued_Procedure
8692 if not Is_Imported (Ent) then
8694 ("pragma Import or Interface must precede pragma%");
8697 -- Here we have the Export case which can set the entity as exported
8699 -- But does not do so if the specified external name is null, since
8700 -- that is taken as a signal in DEC Ada 83 (with which we want to be
8701 -- compatible) to request no external name.
8703 elsif Nkind (Arg_External) = N_String_Literal
8704 and then String_Length (Strval (Arg_External)) = 0
8708 -- In all other cases, set entity as exported
8711 Set_Exported (Ent, Arg_Internal);
8714 -- Special processing for Valued_Procedure cases
8716 if Prag_Id = Pragma_Import_Valued_Procedure
8718 Prag_Id = Pragma_Export_Valued_Procedure
8720 Formal := First_Formal (Ent);
8723 Error_Pragma ("at least one parameter required for pragma%");
8725 elsif Ekind (Formal) /= E_Out_Parameter then
8726 Error_Pragma ("first parameter must have mode out for pragma%");
8729 Set_Is_Valued_Procedure (Ent);
8733 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
8735 -- Process Result_Mechanism argument if present. We have already
8736 -- checked that this is only allowed for the function case.
8738 if Present (Arg_Result_Mechanism) then
8739 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
8742 -- Process Mechanism parameter if present. Note that this parameter
8743 -- is not analyzed, and must not be analyzed since it is semantic
8744 -- nonsense, so we get it in exactly as the parser left it.
8746 if Present (Arg_Mechanism) then
8754 -- A single mechanism association without a formal parameter
8755 -- name is parsed as a parenthesized expression. All other
8756 -- cases are parsed as aggregates, so we rewrite the single
8757 -- parameter case as an aggregate for consistency.
8759 if Nkind (Arg_Mechanism) /= N_Aggregate
8760 and then Paren_Count (Arg_Mechanism) = 1
8762 Rewrite (Arg_Mechanism,
8763 Make_Aggregate (Sloc (Arg_Mechanism),
8764 Expressions => New_List (
8765 Relocate_Node (Arg_Mechanism))));
8768 -- Case of only mechanism name given, applies to all formals
8770 if Nkind (Arg_Mechanism) /= N_Aggregate then
8771 Formal := First_Formal (Ent);
8772 while Present (Formal) loop
8773 Set_Mechanism_Value (Formal, Arg_Mechanism);
8774 Next_Formal (Formal);
8777 -- Case of list of mechanism associations given
8780 if Null_Record_Present (Arg_Mechanism) then
8782 ("inappropriate form for Mechanism parameter",
8786 -- Deal with positional ones first
8788 Formal := First_Formal (Ent);
8790 if Present (Expressions (Arg_Mechanism)) then
8791 Mname := First (Expressions (Arg_Mechanism));
8792 while Present (Mname) loop
8795 ("too many mechanism associations", Mname);
8798 Set_Mechanism_Value (Formal, Mname);
8799 Next_Formal (Formal);
8804 -- Deal with named entries
8806 if Present (Component_Associations (Arg_Mechanism)) then
8807 Massoc := First (Component_Associations (Arg_Mechanism));
8808 while Present (Massoc) loop
8809 Choice := First (Choices (Massoc));
8811 if Nkind (Choice) /= N_Identifier
8812 or else Present (Next (Choice))
8815 ("incorrect form for mechanism association",
8819 Formal := First_Formal (Ent);
8823 ("parameter name & not present", Choice);
8826 if Chars (Choice) = Chars (Formal) then
8828 (Formal, Expression (Massoc));
8830 -- Set entity on identifier (needed by ASIS)
8832 Set_Entity (Choice, Formal);
8837 Next_Formal (Formal);
8846 end Process_Extended_Import_Export_Subprogram_Pragma;
8848 --------------------------
8849 -- Process_Generic_List --
8850 --------------------------
8852 procedure Process_Generic_List is
8857 Check_No_Identifiers;
8858 Check_At_Least_N_Arguments (1);
8860 -- Check all arguments are names of generic units or instances
8863 while Present (Arg) loop
8864 Exp := Get_Pragma_Arg (Arg);
8867 if not Is_Entity_Name (Exp)
8869 (not Is_Generic_Instance (Entity (Exp))
8871 not Is_Generic_Unit (Entity (Exp)))
8874 ("pragma% argument must be name of generic unit/instance",
8880 end Process_Generic_List;
8882 ------------------------------------
8883 -- Process_Import_Predefined_Type --
8884 ------------------------------------
8886 procedure Process_Import_Predefined_Type is
8887 Loc : constant Source_Ptr := Sloc (N);
8889 Ftyp : Node_Id := Empty;
8895 Nam := String_To_Name (Strval (Expression (Arg3)));
8897 Elmt := First_Elmt (Predefined_Float_Types);
8898 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
8902 Ftyp := Node (Elmt);
8904 if Present (Ftyp) then
8906 -- Don't build a derived type declaration, because predefined C
8907 -- types have no declaration anywhere, so cannot really be named.
8908 -- Instead build a full type declaration, starting with an
8909 -- appropriate type definition is built
8911 if Is_Floating_Point_Type (Ftyp) then
8912 Def := Make_Floating_Point_Definition (Loc,
8913 Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
8914 Make_Real_Range_Specification (Loc,
8915 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
8916 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
8918 -- Should never have a predefined type we cannot handle
8921 raise Program_Error;
8924 -- Build and insert a Full_Type_Declaration, which will be
8925 -- analyzed as soon as this list entry has been analyzed.
8927 Decl := Make_Full_Type_Declaration (Loc,
8928 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
8929 Type_Definition => Def);
8931 Insert_After (N, Decl);
8932 Mark_Rewrite_Insertion (Decl);
8935 Error_Pragma_Arg ("no matching type found for pragma%", Arg2);
8937 end Process_Import_Predefined_Type;
8939 ---------------------------------
8940 -- Process_Import_Or_Interface --
8941 ---------------------------------
8943 procedure Process_Import_Or_Interface is
8949 -- In Relaxed_RM_Semantics, support old Ada 83 style:
8950 -- pragma Import (Entity, "external name");
8952 if Relaxed_RM_Semantics
8953 and then Arg_Count = 2
8954 and then Prag_Id = Pragma_Import
8955 and then Nkind (Expression (Arg2)) = N_String_Literal
8958 Def_Id := Get_Pragma_Arg (Arg1);
8961 if not Is_Entity_Name (Def_Id) then
8962 Error_Pragma_Arg ("entity name required", Arg1);
8965 Def_Id := Entity (Def_Id);
8966 Kill_Size_Check_Code (Def_Id);
8967 Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False);
8970 Process_Convention (C, Def_Id);
8972 -- A pragma that applies to a Ghost entity becomes Ghost for the
8973 -- purposes of legality checks and removal of ignored Ghost code.
8975 Mark_Ghost_Pragma (N, Def_Id);
8976 Kill_Size_Check_Code (Def_Id);
8977 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
8980 -- Various error checks
8982 if Ekind_In (Def_Id, E_Variable, E_Constant) then
8984 -- We do not permit Import to apply to a renaming declaration
8986 if Present (Renamed_Object (Def_Id)) then
8988 ("pragma% not allowed for object renaming", Arg2);
8990 -- User initialization is not allowed for imported object, but
8991 -- the object declaration may contain a default initialization,
8992 -- that will be discarded. Note that an explicit initialization
8993 -- only counts if it comes from source, otherwise it is simply
8994 -- the code generator making an implicit initialization explicit.
8996 elsif Present (Expression (Parent (Def_Id)))
8997 and then Comes_From_Source
8998 (Original_Node (Expression (Parent (Def_Id))))
9000 -- Set imported flag to prevent cascaded errors
9002 Set_Is_Imported (Def_Id);
9004 Error_Msg_Sloc := Sloc (Def_Id);
9006 ("no initialization allowed for declaration of& #",
9007 "\imported entities cannot be initialized (RM B.1(24))",
9011 -- If the pragma comes from an aspect specification the
9012 -- Is_Imported flag has already been set.
9014 if not From_Aspect_Specification (N) then
9015 Set_Imported (Def_Id);
9018 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
9020 -- Note that we do not set Is_Public here. That's because we
9021 -- only want to set it if there is no address clause, and we
9022 -- don't know that yet, so we delay that processing till
9025 -- pragma Import completes deferred constants
9027 if Ekind (Def_Id) = E_Constant then
9028 Set_Has_Completion (Def_Id);
9031 -- It is not possible to import a constant of an unconstrained
9032 -- array type (e.g. string) because there is no simple way to
9033 -- write a meaningful subtype for it.
9035 if Is_Array_Type (Etype (Def_Id))
9036 and then not Is_Constrained (Etype (Def_Id))
9039 ("imported constant& must have a constrained subtype",
9044 elsif Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
9046 -- If the name is overloaded, pragma applies to all of the denoted
9047 -- entities in the same declarative part, unless the pragma comes
9048 -- from an aspect specification or was generated by the compiler
9049 -- (such as for pragma Provide_Shift_Operators).
9052 while Present (Hom_Id) loop
9054 Def_Id := Get_Base_Subprogram (Hom_Id);
9056 -- Ignore inherited subprograms because the pragma will apply
9057 -- to the parent operation, which is the one called.
9059 if Is_Overloadable (Def_Id)
9060 and then Present (Alias (Def_Id))
9064 -- If it is not a subprogram, it must be in an outer scope and
9065 -- pragma does not apply.
9067 elsif not Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
9070 -- The pragma does not apply to primitives of interfaces
9072 elsif Is_Dispatching_Operation (Def_Id)
9073 and then Present (Find_Dispatching_Type (Def_Id))
9074 and then Is_Interface (Find_Dispatching_Type (Def_Id))
9078 -- Verify that the homonym is in the same declarative part (not
9079 -- just the same scope). If the pragma comes from an aspect
9080 -- specification we know that it is part of the declaration.
9082 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
9083 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
9084 and then not From_Aspect_Specification (N)
9089 -- If the pragma comes from an aspect specification the
9090 -- Is_Imported flag has already been set.
9092 if not From_Aspect_Specification (N) then
9093 Set_Imported (Def_Id);
9096 -- Reject an Import applied to an abstract subprogram
9098 if Is_Subprogram (Def_Id)
9099 and then Is_Abstract_Subprogram (Def_Id)
9101 Error_Msg_Sloc := Sloc (Def_Id);
9103 ("cannot import abstract subprogram& declared#",
9107 -- Special processing for Convention_Intrinsic
9109 if C = Convention_Intrinsic then
9111 -- Link_Name argument not allowed for intrinsic
9115 Set_Is_Intrinsic_Subprogram (Def_Id);
9117 -- If no external name is present, then check that this
9118 -- is a valid intrinsic subprogram. If an external name
9119 -- is present, then this is handled by the back end.
9122 Check_Intrinsic_Subprogram
9123 (Def_Id, Get_Pragma_Arg (Arg2));
9127 -- Verify that the subprogram does not have a completion
9128 -- through a renaming declaration. For other completions the
9129 -- pragma appears as a too late representation.
9132 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
9136 and then Nkind (Decl) = N_Subprogram_Declaration
9137 and then Present (Corresponding_Body (Decl))
9138 and then Nkind (Unit_Declaration_Node
9139 (Corresponding_Body (Decl))) =
9140 N_Subprogram_Renaming_Declaration
9142 Error_Msg_Sloc := Sloc (Def_Id);
9144 ("cannot import&, renaming already provided for "
9145 & "declaration #", N, Def_Id);
9149 -- If the pragma comes from an aspect specification, there
9150 -- must be an Import aspect specified as well. In the rare
9151 -- case where Import is set to False, the suprogram needs to
9152 -- have a local completion.
9155 Imp_Aspect : constant Node_Id :=
9156 Find_Aspect (Def_Id, Aspect_Import);
9160 if Present (Imp_Aspect)
9161 and then Present (Expression (Imp_Aspect))
9163 Expr := Expression (Imp_Aspect);
9164 Analyze_And_Resolve (Expr, Standard_Boolean);
9166 if Is_Entity_Name (Expr)
9167 and then Entity (Expr) = Standard_True
9169 Set_Has_Completion (Def_Id);
9172 -- If there is no expression, the default is True, as for
9173 -- all boolean aspects. Same for the older pragma.
9176 Set_Has_Completion (Def_Id);
9180 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
9183 if Is_Compilation_Unit (Hom_Id) then
9185 -- Its possible homonyms are not affected by the pragma.
9186 -- Such homonyms might be present in the context of other
9187 -- units being compiled.
9191 elsif From_Aspect_Specification (N) then
9194 -- If the pragma was created by the compiler, then we don't
9195 -- want it to apply to other homonyms. This kind of case can
9196 -- occur when using pragma Provide_Shift_Operators, which
9197 -- generates implicit shift and rotate operators with Import
9198 -- pragmas that might apply to earlier explicit or implicit
9199 -- declarations marked with Import (for example, coming from
9200 -- an earlier pragma Provide_Shift_Operators for another type),
9201 -- and we don't generally want other homonyms being treated
9202 -- as imported or the pragma flagged as an illegal duplicate.
9204 elsif not Comes_From_Source (N) then
9208 Hom_Id := Homonym (Hom_Id);
9212 -- Import a CPP class
9214 elsif C = Convention_CPP
9215 and then (Is_Record_Type (Def_Id)
9216 or else Ekind (Def_Id) = E_Incomplete_Type)
9218 if Ekind (Def_Id) = E_Incomplete_Type then
9219 if Present (Full_View (Def_Id)) then
9220 Def_Id := Full_View (Def_Id);
9224 ("cannot import 'C'P'P type before full declaration seen",
9225 Get_Pragma_Arg (Arg2));
9227 -- Although we have reported the error we decorate it as
9228 -- CPP_Class to avoid reporting spurious errors
9230 Set_Is_CPP_Class (Def_Id);
9235 -- Types treated as CPP classes must be declared limited (note:
9236 -- this used to be a warning but there is no real benefit to it
9237 -- since we did effectively intend to treat the type as limited
9240 if not Is_Limited_Type (Def_Id) then
9242 ("imported 'C'P'P type must be limited",
9243 Get_Pragma_Arg (Arg2));
9246 if Etype (Def_Id) /= Def_Id
9247 and then not Is_CPP_Class (Root_Type (Def_Id))
9249 Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
9252 Set_Is_CPP_Class (Def_Id);
9254 -- Imported CPP types must not have discriminants (because C++
9255 -- classes do not have discriminants).
9257 if Has_Discriminants (Def_Id) then
9259 ("imported 'C'P'P type cannot have discriminants",
9260 First (Discriminant_Specifications
9261 (Declaration_Node (Def_Id))));
9264 -- Check that components of imported CPP types do not have default
9265 -- expressions. For private types this check is performed when the
9266 -- full view is analyzed (see Process_Full_View).
9268 if not Is_Private_Type (Def_Id) then
9269 Check_CPP_Type_Has_No_Defaults (Def_Id);
9272 -- Import a CPP exception
9274 elsif C = Convention_CPP
9275 and then Ekind (Def_Id) = E_Exception
9279 ("'External_'Name arguments is required for 'Cpp exception",
9282 -- As only a string is allowed, Check_Arg_Is_External_Name
9285 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
9288 if Present (Arg4) then
9290 ("Link_Name argument not allowed for imported Cpp exception",
9294 -- Do not call Set_Interface_Name as the name of the exception
9295 -- shouldn't be modified (and in particular it shouldn't be
9296 -- the External_Name). For exceptions, the External_Name is the
9297 -- name of the RTTI structure.
9299 -- ??? Emit an error if pragma Import/Export_Exception is present
9301 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
9303 Check_Arg_Count (3);
9304 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
9306 Process_Import_Predefined_Type;
9310 ("second argument of pragma% must be object, subprogram "
9311 & "or incomplete type",
9315 -- If this pragma applies to a compilation unit, then the unit, which
9316 -- is a subprogram, does not require (or allow) a body. We also do
9317 -- not need to elaborate imported procedures.
9319 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
9321 Cunit : constant Node_Id := Parent (Parent (N));
9323 Set_Body_Required (Cunit, False);
9326 end Process_Import_Or_Interface;
9328 --------------------
9329 -- Process_Inline --
9330 --------------------
9332 procedure Process_Inline (Status : Inline_Status) is
9339 Ghost_Error_Posted : Boolean := False;
9340 -- Flag set when an error concerning the illegal mix of Ghost and
9341 -- non-Ghost subprograms is emitted.
9343 Ghost_Id : Entity_Id := Empty;
9344 -- The entity of the first Ghost subprogram encountered while
9345 -- processing the arguments of the pragma.
9347 procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id);
9348 -- Verify the placement of pragma Inline_Always with respect to the
9349 -- initial declaration of subprogram Spec_Id.
9351 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
9352 -- Returns True if it can be determined at this stage that inlining
9353 -- is not possible, for example if the body is available and contains
9354 -- exception handlers, we prevent inlining, since otherwise we can
9355 -- get undefined symbols at link time. This function also emits a
9356 -- warning if the pragma appears too late.
9358 -- ??? is business with link symbols still valid, or does it relate
9359 -- to front end ZCX which is being phased out ???
9361 procedure Make_Inline (Subp : Entity_Id);
9362 -- Subp is the defining unit name of the subprogram declaration. If
9363 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
9364 -- the corresponding body, if there is one present.
9366 procedure Set_Inline_Flags (Subp : Entity_Id);
9367 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
9368 -- Also set or clear Is_Inlined flag on Subp depending on Status.
9370 -----------------------------------
9371 -- Check_Inline_Always_Placement --
9372 -----------------------------------
9374 procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id) is
9375 Spec_Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
9377 function Compilation_Unit_OK return Boolean;
9378 pragma Inline (Compilation_Unit_OK);
9379 -- Determine whether pragma Inline_Always applies to a compatible
9380 -- compilation unit denoted by Spec_Id.
9382 function Declarative_List_OK return Boolean;
9383 pragma Inline (Declarative_List_OK);
9384 -- Determine whether the initial declaration of subprogram Spec_Id
9385 -- and the pragma appear in compatible declarative lists.
9387 function Subprogram_Body_OK return Boolean;
9388 pragma Inline (Subprogram_Body_OK);
9389 -- Determine whether pragma Inline_Always applies to a compatible
9390 -- subprogram body denoted by Spec_Id.
9392 -------------------------
9393 -- Compilation_Unit_OK --
9394 -------------------------
9396 function Compilation_Unit_OK return Boolean is
9397 Comp_Unit : constant Node_Id := Parent (Spec_Decl);
9400 -- The pragma appears after the initial declaration of a
9401 -- compilation unit.
9403 -- procedure Comp_Unit;
9404 -- pragma Inline_Always (Comp_Unit);
9406 -- Note that for compatibility reasons, the following case is
9409 -- procedure Stand_Alone_Body_Comp_Unit is
9411 -- end Stand_Alone_Body_Comp_Unit;
9412 -- pragma Inline_Always (Stand_Alone_Body_Comp_Unit);
9415 Nkind (Comp_Unit) = N_Compilation_Unit
9416 and then Present (Aux_Decls_Node (Comp_Unit))
9417 and then Is_List_Member (N)
9418 and then List_Containing (N) =
9419 Pragmas_After (Aux_Decls_Node (Comp_Unit));
9420 end Compilation_Unit_OK;
9422 -------------------------
9423 -- Declarative_List_OK --
9424 -------------------------
9426 function Declarative_List_OK return Boolean is
9427 Context : constant Node_Id := Parent (Spec_Decl);
9429 Init_Decl : Node_Id;
9430 Init_List : List_Id;
9431 Prag_List : List_Id;
9434 -- Determine the proper initial declaration. In general this is
9435 -- the declaration node of the subprogram except when the input
9436 -- denotes a generic instantiation.
9438 -- procedure Inst is new Gen;
9439 -- pragma Inline_Always (Inst);
9441 -- In this case the original subprogram is moved inside an
9442 -- anonymous package while pragma Inline_Always remains at the
9443 -- level of the anonymous package. Use the declaration of the
9444 -- package because it reflects the placement of the original
9447 -- package Anon_Pack is
9448 -- procedure Inst is ... end Inst; -- original
9451 -- procedure Inst renames Anon_Pack.Inst;
9452 -- pragma Inline_Always (Inst);
9454 if Is_Generic_Instance (Spec_Id) then
9455 Init_Decl := Parent (Parent (Spec_Decl));
9456 pragma Assert (Nkind (Init_Decl) = N_Package_Declaration);
9458 Init_Decl := Spec_Decl;
9461 if Is_List_Member (Init_Decl) and then Is_List_Member (N) then
9462 Init_List := List_Containing (Init_Decl);
9463 Prag_List := List_Containing (N);
9465 -- The pragma and then initial declaration appear within the
9466 -- same declarative list.
9468 if Init_List = Prag_List then
9471 -- A special case of the above is when both the pragma and
9472 -- the initial declaration appear in different lists of a
9473 -- package spec, protected definition, or a task definition.
9478 -- pragma Inline_Always (Proc);
9481 elsif Nkind_In (Context, N_Package_Specification,
9482 N_Protected_Definition,
9484 and then Init_List = Visible_Declarations (Context)
9485 and then Prag_List = Private_Declarations (Context)
9492 end Declarative_List_OK;
9494 ------------------------
9495 -- Subprogram_Body_OK --
9496 ------------------------
9498 function Subprogram_Body_OK return Boolean is
9499 Body_Decl : Node_Id;
9502 -- The pragma appears within the declarative list of a stand-
9503 -- alone subprogram body.
9505 -- procedure Stand_Alone_Body is
9506 -- pragma Inline_Always (Stand_Alone_Body);
9509 -- end Stand_Alone_Body;
9511 -- The compiler creates a dummy spec in this case, however the
9512 -- pragma remains within the declarative list of the body.
9514 if Nkind (Spec_Decl) = N_Subprogram_Declaration
9515 and then not Comes_From_Source (Spec_Decl)
9516 and then Present (Corresponding_Body (Spec_Decl))
9519 Unit_Declaration_Node (Corresponding_Body (Spec_Decl));
9521 if Present (Declarations (Body_Decl))
9522 and then Is_List_Member (N)
9523 and then List_Containing (N) = Declarations (Body_Decl)
9530 end Subprogram_Body_OK;
9532 -- Start of processing for Check_Inline_Always_Placement
9535 -- This check is relevant only for pragma Inline_Always
9537 if Pname /= Name_Inline_Always then
9540 -- Nothing to do when the pragma is internally generated on the
9541 -- assumption that it is properly placed.
9543 elsif not Comes_From_Source (N) then
9546 -- Nothing to do for internally generated subprograms that act
9547 -- as accidental homonyms of a source subprogram being inlined.
9549 elsif not Comes_From_Source (Spec_Id) then
9552 -- Nothing to do for generic formal subprograms that act as
9553 -- homonyms of another source subprogram being inlined.
9555 elsif Is_Formal_Subprogram (Spec_Id) then
9558 elsif Compilation_Unit_OK
9559 or else Declarative_List_OK
9560 or else Subprogram_Body_OK
9565 -- At this point it is known that the pragma applies to or appears
9566 -- within a completing body, a completing stub, or a subunit.
9568 Error_Msg_Name_1 := Pname;
9569 Error_Msg_Name_2 := Chars (Spec_Id);
9570 Error_Msg_Sloc := Sloc (Spec_Id);
9573 ("pragma % must appear on initial declaration of subprogram "
9574 & "% defined #", N);
9575 end Check_Inline_Always_Placement;
9577 ---------------------------
9578 -- Inlining_Not_Possible --
9579 ---------------------------
9581 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
9582 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
9586 if Nkind (Decl) = N_Subprogram_Body then
9587 Stats := Handled_Statement_Sequence (Decl);
9588 return Present (Exception_Handlers (Stats))
9589 or else Present (At_End_Proc (Stats));
9591 elsif Nkind (Decl) = N_Subprogram_Declaration
9592 and then Present (Corresponding_Body (Decl))
9594 if Analyzed (Corresponding_Body (Decl)) then
9595 Error_Msg_N ("pragma appears too late, ignored??", N);
9598 -- If the subprogram is a renaming as body, the body is just a
9599 -- call to the renamed subprogram, and inlining is trivially
9603 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
9604 N_Subprogram_Renaming_Declaration
9610 Handled_Statement_Sequence
9611 (Unit_Declaration_Node (Corresponding_Body (Decl)));
9614 Present (Exception_Handlers (Stats))
9615 or else Present (At_End_Proc (Stats));
9619 -- If body is not available, assume the best, the check is
9620 -- performed again when compiling enclosing package bodies.
9624 end Inlining_Not_Possible;
9630 procedure Make_Inline (Subp : Entity_Id) is
9631 Kind : constant Entity_Kind := Ekind (Subp);
9632 Inner_Subp : Entity_Id := Subp;
9635 -- Ignore if bad type, avoid cascaded error
9637 if Etype (Subp) = Any_Type then
9641 -- If inlining is not possible, for now do not treat as an error
9643 elsif Status /= Suppressed
9644 and then Front_End_Inlining
9645 and then Inlining_Not_Possible (Subp)
9650 -- Here we have a candidate for inlining, but we must exclude
9651 -- derived operations. Otherwise we would end up trying to inline
9652 -- a phantom declaration, and the result would be to drag in a
9653 -- body which has no direct inlining associated with it. That
9654 -- would not only be inefficient but would also result in the
9655 -- backend doing cross-unit inlining in cases where it was
9656 -- definitely inappropriate to do so.
9658 -- However, a simple Comes_From_Source test is insufficient, since
9659 -- we do want to allow inlining of generic instances which also do
9660 -- not come from source. We also need to recognize specs generated
9661 -- by the front-end for bodies that carry the pragma. Finally,
9662 -- predefined operators do not come from source but are not
9663 -- inlineable either.
9665 elsif Is_Generic_Instance (Subp)
9666 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
9670 elsif not Comes_From_Source (Subp)
9671 and then Scope (Subp) /= Standard_Standard
9677 -- The referenced entity must either be the enclosing entity, or
9678 -- an entity declared within the current open scope.
9680 if Present (Scope (Subp))
9681 and then Scope (Subp) /= Current_Scope
9682 and then Subp /= Current_Scope
9685 ("argument of% must be entity in current scope", Assoc);
9689 -- Processing for procedure, operator or function. If subprogram
9690 -- is aliased (as for an instance) indicate that the renamed
9691 -- entity (if declared in the same unit) is inlined.
9692 -- If this is the anonymous subprogram created for a subprogram
9693 -- instance, the inlining applies to it directly. Otherwise we
9694 -- retrieve it as the alias of the visible subprogram instance.
9696 if Is_Subprogram (Subp) then
9698 -- Ensure that pragma Inline_Always is associated with the
9699 -- initial declaration of the subprogram.
9701 Check_Inline_Always_Placement (Subp);
9703 if Is_Wrapper_Package (Scope (Subp)) then
9706 Inner_Subp := Ultimate_Alias (Inner_Subp);
9709 if In_Same_Source_Unit (Subp, Inner_Subp) then
9710 Set_Inline_Flags (Inner_Subp);
9712 Decl := Parent (Parent (Inner_Subp));
9714 if Nkind (Decl) = N_Subprogram_Declaration
9715 and then Present (Corresponding_Body (Decl))
9717 Set_Inline_Flags (Corresponding_Body (Decl));
9719 elsif Is_Generic_Instance (Subp)
9720 and then Comes_From_Source (Subp)
9722 -- Indicate that the body needs to be created for
9723 -- inlining subsequent calls. The instantiation node
9724 -- follows the declaration of the wrapper package
9725 -- created for it. The subprogram that requires the
9726 -- body is the anonymous one in the wrapper package.
9728 if Scope (Subp) /= Standard_Standard
9730 Need_Subprogram_Instance_Body
9731 (Next (Unit_Declaration_Node
9732 (Scope (Alias (Subp)))), Subp)
9737 -- Inline is a program unit pragma (RM 10.1.5) and cannot
9738 -- appear in a formal part to apply to a formal subprogram.
9739 -- Do not apply check within an instance or a formal package
9740 -- the test will have been applied to the original generic.
9742 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
9743 and then List_Containing (Decl) = List_Containing (N)
9744 and then not In_Instance
9747 ("Inline cannot apply to a formal subprogram", N);
9749 -- If Subp is a renaming, it is the renamed entity that
9750 -- will appear in any call, and be inlined. However, for
9751 -- ASIS uses it is convenient to indicate that the renaming
9752 -- itself is an inlined subprogram, so that some gnatcheck
9753 -- rules can be applied in the absence of expansion.
9755 elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then
9756 Set_Inline_Flags (Subp);
9762 -- For a generic subprogram set flag as well, for use at the point
9763 -- of instantiation, to determine whether the body should be
9766 elsif Is_Generic_Subprogram (Subp) then
9767 Set_Inline_Flags (Subp);
9770 -- Literals are by definition inlined
9772 elsif Kind = E_Enumeration_Literal then
9775 -- Anything else is an error
9779 ("expect subprogram name for pragma%", Assoc);
9783 ----------------------
9784 -- Set_Inline_Flags --
9785 ----------------------
9787 procedure Set_Inline_Flags (Subp : Entity_Id) is
9789 -- First set the Has_Pragma_XXX flags and issue the appropriate
9790 -- errors and warnings for suspicious combinations.
9792 if Prag_Id = Pragma_No_Inline then
9793 if Has_Pragma_Inline_Always (Subp) then
9795 ("Inline_Always and No_Inline are mutually exclusive", N);
9796 elsif Has_Pragma_Inline (Subp) then
9798 ("Inline and No_Inline both specified for& ??",
9799 N, Entity (Subp_Id));
9802 Set_Has_Pragma_No_Inline (Subp);
9804 if Prag_Id = Pragma_Inline_Always then
9805 if Has_Pragma_No_Inline (Subp) then
9807 ("Inline_Always and No_Inline are mutually exclusive",
9811 Set_Has_Pragma_Inline_Always (Subp);
9813 if Has_Pragma_No_Inline (Subp) then
9815 ("Inline and No_Inline both specified for& ??",
9816 N, Entity (Subp_Id));
9820 Set_Has_Pragma_Inline (Subp);
9823 -- Then adjust the Is_Inlined flag. It can never be set if the
9824 -- subprogram is subject to pragma No_Inline.
9828 Set_Is_Inlined (Subp, False);
9834 if not Has_Pragma_No_Inline (Subp) then
9835 Set_Is_Inlined (Subp, True);
9839 -- A pragma that applies to a Ghost entity becomes Ghost for the
9840 -- purposes of legality checks and removal of ignored Ghost code.
9842 Mark_Ghost_Pragma (N, Subp);
9844 -- Capture the entity of the first Ghost subprogram being
9845 -- processed for error detection purposes.
9847 if Is_Ghost_Entity (Subp) then
9848 if No (Ghost_Id) then
9852 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
9853 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
9855 elsif Present (Ghost_Id) and then not Ghost_Error_Posted then
9856 Ghost_Error_Posted := True;
9858 Error_Msg_Name_1 := Pname;
9860 ("pragma % cannot mention ghost and non-ghost subprograms",
9863 Error_Msg_Sloc := Sloc (Ghost_Id);
9864 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
9866 Error_Msg_Sloc := Sloc (Subp);
9867 Error_Msg_NE ("\& # declared as non-ghost", N, Subp);
9869 end Set_Inline_Flags;
9871 -- Start of processing for Process_Inline
9874 -- An inlined subprogram may grant access to its private enclosing
9875 -- context depending on the placement of its body. From elaboration
9876 -- point of view, the flow of execution may enter this private
9877 -- context, and then reach an external unit, thus producing a
9878 -- dependency on that external unit. For such a path to be properly
9879 -- discovered and encoded in the ALI file of the main unit, let the
9880 -- ABE mechanism process the body of the main unit, and encode all
9881 -- relevant invocation constructs and the relations between them.
9883 Mark_Save_Invocation_Graph_Of_Body;
9885 Check_No_Identifiers;
9886 Check_At_Least_N_Arguments (1);
9888 if Status = Enabled then
9889 Inline_Processing_Required := True;
9893 while Present (Assoc) loop
9894 Subp_Id := Get_Pragma_Arg (Assoc);
9898 if Is_Entity_Name (Subp_Id) then
9899 Subp := Entity (Subp_Id);
9901 if Subp = Any_Id then
9903 -- If previous error, avoid cascaded errors
9905 Check_Error_Detected;
9911 -- For the pragma case, climb homonym chain. This is
9912 -- what implements allowing the pragma in the renaming
9913 -- case, with the result applying to the ancestors, and
9914 -- also allows Inline to apply to all previous homonyms.
9916 if not From_Aspect_Specification (N) then
9917 while Present (Homonym (Subp))
9918 and then Scope (Homonym (Subp)) = Current_Scope
9920 Make_Inline (Homonym (Subp));
9921 Subp := Homonym (Subp);
9928 Error_Pragma_Arg ("inappropriate argument for pragma%", Assoc);
9934 -- If the context is a package declaration, the pragma indicates
9935 -- that inlining will require the presence of the corresponding
9936 -- body. (this may be further refined).
9939 and then Nkind (Unit (Cunit (Current_Sem_Unit))) =
9940 N_Package_Declaration
9942 Set_Body_Needed_For_Inlining (Cunit_Entity (Current_Sem_Unit));
9946 ----------------------------
9947 -- Process_Interface_Name --
9948 ----------------------------
9950 procedure Process_Interface_Name
9951 (Subprogram_Def : Entity_Id;
9958 String_Val : String_Id;
9960 procedure Check_Form_Of_Interface_Name (SN : Node_Id);
9961 -- SN is a string literal node for an interface name. This routine
9962 -- performs some minimal checks that the name is reasonable. In
9963 -- particular that no spaces or other obviously incorrect characters
9964 -- appear. This is only a warning, since any characters are allowed.
9966 ----------------------------------
9967 -- Check_Form_Of_Interface_Name --
9968 ----------------------------------
9970 procedure Check_Form_Of_Interface_Name (SN : Node_Id) is
9971 S : constant String_Id := Strval (Expr_Value_S (SN));
9972 SL : constant Nat := String_Length (S);
9977 Error_Msg_N ("interface name cannot be null string", SN);
9980 for J in 1 .. SL loop
9981 C := Get_String_Char (S, J);
9983 -- Look for dubious character and issue unconditional warning.
9984 -- Definitely dubious if not in character range.
9986 if not In_Character_Range (C)
9988 -- Commas, spaces and (back)slashes are dubious
9990 or else Get_Character (C) = ','
9991 or else Get_Character (C) = '\'
9992 or else Get_Character (C) = ' '
9993 or else Get_Character (C) = '/'
9996 ("??interface name contains illegal character",
9997 Sloc (SN) + Source_Ptr (J));
10000 end Check_Form_Of_Interface_Name;
10002 -- Start of processing for Process_Interface_Name
10005 -- If we are looking at a pragma that comes from an aspect then it
10006 -- needs to have its corresponding aspect argument expressions
10007 -- analyzed in addition to the generated pragma so that aspects
10008 -- within generic units get properly resolved.
10010 if Present (Prag) and then From_Aspect_Specification (Prag) then
10012 Asp : constant Node_Id := Corresponding_Aspect (Prag);
10020 -- Obtain all interfacing aspects used to construct the pragma
10022 Get_Interfacing_Aspects
10023 (Asp, Dummy_1, EN, Dummy_2, Dummy_3, LN);
10025 -- Analyze the expression of aspect External_Name
10027 if Present (EN) then
10028 Analyze (Expression (EN));
10031 -- Analyze the expressio of aspect Link_Name
10033 if Present (LN) then
10034 Analyze (Expression (LN));
10039 if No (Link_Arg) then
10040 if No (Ext_Arg) then
10043 elsif Chars (Ext_Arg) = Name_Link_Name then
10045 Link_Nam := Expression (Ext_Arg);
10048 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
10049 Ext_Nam := Expression (Ext_Arg);
10054 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
10055 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
10056 Ext_Nam := Expression (Ext_Arg);
10057 Link_Nam := Expression (Link_Arg);
10060 -- Check expressions for external name and link name are static
10062 if Present (Ext_Nam) then
10063 Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String);
10064 Check_Form_Of_Interface_Name (Ext_Nam);
10066 -- Verify that external name is not the name of a local entity,
10067 -- which would hide the imported one and could lead to run-time
10068 -- surprises. The problem can only arise for entities declared in
10069 -- a package body (otherwise the external name is fully qualified
10070 -- and will not conflict).
10078 if Prag_Id = Pragma_Import then
10079 Nam := String_To_Name (Strval (Expr_Value_S (Ext_Nam)));
10080 E := Entity_Id (Get_Name_Table_Int (Nam));
10082 if Nam /= Chars (Subprogram_Def)
10083 and then Present (E)
10084 and then not Is_Overloadable (E)
10085 and then Is_Immediately_Visible (E)
10086 and then not Is_Imported (E)
10087 and then Ekind (Scope (E)) = E_Package
10090 while Present (Par) loop
10091 if Nkind (Par) = N_Package_Body then
10092 Error_Msg_Sloc := Sloc (E);
10094 ("imported entity is hidden by & declared#",
10099 Par := Parent (Par);
10106 if Present (Link_Nam) then
10107 Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String);
10108 Check_Form_Of_Interface_Name (Link_Nam);
10111 -- If there is no link name, just set the external name
10113 if No (Link_Nam) then
10114 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
10116 -- For the Link_Name case, the given literal is preceded by an
10117 -- asterisk, which indicates to GCC that the given name should be
10118 -- taken literally, and in particular that no prepending of
10119 -- underlines should occur, even in systems where this is the
10124 Store_String_Char (Get_Char_Code ('*'));
10125 String_Val := Strval (Expr_Value_S (Link_Nam));
10126 Store_String_Chars (String_Val);
10128 Make_String_Literal (Sloc (Link_Nam),
10129 Strval => End_String);
10132 -- Set the interface name. If the entity is a generic instance, use
10133 -- its alias, which is the callable entity.
10135 if Is_Generic_Instance (Subprogram_Def) then
10136 Set_Encoded_Interface_Name
10137 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
10139 Set_Encoded_Interface_Name
10140 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
10143 Check_Duplicated_Export_Name (Link_Nam);
10144 end Process_Interface_Name;
10146 -----------------------------------------
10147 -- Process_Interrupt_Or_Attach_Handler --
10148 -----------------------------------------
10150 procedure Process_Interrupt_Or_Attach_Handler is
10151 Handler : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1));
10152 Prot_Typ : constant Entity_Id := Scope (Handler);
10155 -- A pragma that applies to a Ghost entity becomes Ghost for the
10156 -- purposes of legality checks and removal of ignored Ghost code.
10158 Mark_Ghost_Pragma (N, Handler);
10159 Set_Is_Interrupt_Handler (Handler);
10161 pragma Assert (Ekind (Prot_Typ) = E_Protected_Type);
10163 Record_Rep_Item (Prot_Typ, N);
10165 -- Chain the pragma on the contract for completeness
10167 Add_Contract_Item (N, Handler);
10168 end Process_Interrupt_Or_Attach_Handler;
10170 --------------------------------------------------
10171 -- Process_Restrictions_Or_Restriction_Warnings --
10172 --------------------------------------------------
10174 -- Note: some of the simple identifier cases were handled in par-prag,
10175 -- but it is harmless (and more straightforward) to simply handle all
10176 -- cases here, even if it means we repeat a bit of work in some cases.
10178 procedure Process_Restrictions_Or_Restriction_Warnings
10182 R_Id : Restriction_Id;
10188 -- Ignore all Restrictions pragmas in CodePeer mode
10190 if CodePeer_Mode then
10194 Check_Ada_83_Warning;
10195 Check_At_Least_N_Arguments (1);
10196 Check_Valid_Configuration_Pragma;
10199 while Present (Arg) loop
10201 Expr := Get_Pragma_Arg (Arg);
10203 -- Case of no restriction identifier present
10205 if Id = No_Name then
10206 if Nkind (Expr) /= N_Identifier then
10208 ("invalid form for restriction", Arg);
10213 (Process_Restriction_Synonyms (Expr));
10215 if R_Id not in All_Boolean_Restrictions then
10216 Error_Msg_Name_1 := Pname;
10218 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
10220 -- Check for possible misspelling
10222 for J in Restriction_Id loop
10224 Rnm : constant String := Restriction_Id'Image (J);
10227 Name_Buffer (1 .. Rnm'Length) := Rnm;
10228 Name_Len := Rnm'Length;
10229 Set_Casing (All_Lower_Case);
10231 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
10234 (Source_Index (Current_Sem_Unit)));
10235 Error_Msg_String (1 .. Rnm'Length) :=
10236 Name_Buffer (1 .. Name_Len);
10237 Error_Msg_Strlen := Rnm'Length;
10238 Error_Msg_N -- CODEFIX
10239 ("\possible misspelling of ""~""",
10240 Get_Pragma_Arg (Arg));
10249 if Implementation_Restriction (R_Id) then
10250 Check_Restriction (No_Implementation_Restrictions, Arg);
10253 -- Special processing for No_Elaboration_Code restriction
10255 if R_Id = No_Elaboration_Code then
10257 -- Restriction is only recognized within a configuration
10258 -- pragma file, or within a unit of the main extended
10259 -- program. Note: the test for Main_Unit is needed to
10260 -- properly include the case of configuration pragma files.
10262 if not (Current_Sem_Unit = Main_Unit
10263 or else In_Extended_Main_Source_Unit (N))
10267 -- Don't allow in a subunit unless already specified in
10270 elsif Nkind (Parent (N)) = N_Compilation_Unit
10271 and then Nkind (Unit (Parent (N))) = N_Subunit
10272 and then not Restriction_Active (No_Elaboration_Code)
10275 ("invalid specification of ""No_Elaboration_Code""",
10278 ("\restriction cannot be specified in a subunit", N);
10280 ("\unless also specified in body or spec", N);
10283 -- If we accept a No_Elaboration_Code restriction, then it
10284 -- needs to be added to the configuration restriction set so
10285 -- that we get proper application to other units in the main
10286 -- extended source as required.
10289 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
10293 -- If this is a warning, then set the warning unless we already
10294 -- have a real restriction active (we never want a warning to
10295 -- override a real restriction).
10298 if not Restriction_Active (R_Id) then
10299 Set_Restriction (R_Id, N);
10300 Restriction_Warnings (R_Id) := True;
10303 -- If real restriction case, then set it and make sure that the
10304 -- restriction warning flag is off, since a real restriction
10305 -- always overrides a warning.
10308 Set_Restriction (R_Id, N);
10309 Restriction_Warnings (R_Id) := False;
10312 -- Check for obsolescent restrictions in Ada 2005 mode
10315 and then Ada_Version >= Ada_2005
10316 and then (R_Id = No_Asynchronous_Control
10318 R_Id = No_Unchecked_Deallocation
10320 R_Id = No_Unchecked_Conversion)
10322 Check_Restriction (No_Obsolescent_Features, N);
10325 -- A very special case that must be processed here: pragma
10326 -- Restrictions (No_Exceptions) turns off all run-time
10327 -- checking. This is a bit dubious in terms of the formal
10328 -- language definition, but it is what is intended by RM
10329 -- H.4(12). Restriction_Warnings never affects generated code
10330 -- so this is done only in the real restriction case.
10332 -- Atomic_Synchronization is not a real check, so it is not
10333 -- affected by this processing).
10335 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
10336 -- run-time checks in CodePeer and GNATprove modes: we want to
10337 -- generate checks for analysis purposes, as set respectively
10338 -- by -gnatC and -gnatd.F
10341 and then not (CodePeer_Mode or GNATprove_Mode)
10342 and then R_Id = No_Exceptions
10344 for J in Scope_Suppress.Suppress'Range loop
10345 if J /= Atomic_Synchronization then
10346 Scope_Suppress.Suppress (J) := True;
10351 -- Case of No_Dependence => unit-name. Note that the parser
10352 -- already made the necessary entry in the No_Dependence table.
10354 elsif Id = Name_No_Dependence then
10355 if not OK_No_Dependence_Unit_Name (Expr) then
10359 -- Case of No_Specification_Of_Aspect => aspect-identifier
10361 elsif Id = Name_No_Specification_Of_Aspect then
10366 if Nkind (Expr) /= N_Identifier then
10369 A_Id := Get_Aspect_Id (Chars (Expr));
10372 if A_Id = No_Aspect then
10373 Error_Pragma_Arg ("invalid restriction name", Arg);
10375 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
10379 -- Case of No_Use_Of_Attribute => attribute-identifier
10381 elsif Id = Name_No_Use_Of_Attribute then
10382 if Nkind (Expr) /= N_Identifier
10383 or else not Is_Attribute_Name (Chars (Expr))
10385 Error_Msg_N ("unknown attribute name??", Expr);
10388 Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
10391 -- Case of No_Use_Of_Entity => fully-qualified-name
10393 elsif Id = Name_No_Use_Of_Entity then
10395 -- Restriction is only recognized within a configuration
10396 -- pragma file, or within a unit of the main extended
10397 -- program. Note: the test for Main_Unit is needed to
10398 -- properly include the case of configuration pragma files.
10400 if Current_Sem_Unit = Main_Unit
10401 or else In_Extended_Main_Source_Unit (N)
10403 if not OK_No_Dependence_Unit_Name (Expr) then
10404 Error_Msg_N ("wrong form for entity name", Expr);
10406 Set_Restriction_No_Use_Of_Entity
10407 (Expr, Warn, No_Profile);
10411 -- Case of No_Use_Of_Pragma => pragma-identifier
10413 elsif Id = Name_No_Use_Of_Pragma then
10414 if Nkind (Expr) /= N_Identifier
10415 or else not Is_Pragma_Name (Chars (Expr))
10417 Error_Msg_N ("unknown pragma name??", Expr);
10419 Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
10422 -- All other cases of restriction identifier present
10425 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
10426 Analyze_And_Resolve (Expr, Any_Integer);
10428 if R_Id not in All_Parameter_Restrictions then
10430 ("invalid restriction parameter identifier", Arg);
10432 elsif not Is_OK_Static_Expression (Expr) then
10433 Flag_Non_Static_Expr
10434 ("value must be static expression!", Expr);
10437 elsif not Is_Integer_Type (Etype (Expr))
10438 or else Expr_Value (Expr) < 0
10441 ("value must be non-negative integer", Arg);
10444 -- Restriction pragma is active
10446 Val := Expr_Value (Expr);
10448 if not UI_Is_In_Int_Range (Val) then
10450 ("pragma ignored, value too large??", Arg);
10453 -- Warning case. If the real restriction is active, then we
10454 -- ignore the request, since warning never overrides a real
10455 -- restriction. Otherwise we set the proper warning. Note that
10456 -- this circuit sets the warning again if it is already set,
10457 -- which is what we want, since the constant may have changed.
10460 if not Restriction_Active (R_Id) then
10462 (R_Id, N, Integer (UI_To_Int (Val)));
10463 Restriction_Warnings (R_Id) := True;
10466 -- Real restriction case, set restriction and make sure warning
10467 -- flag is off since real restriction always overrides warning.
10470 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
10471 Restriction_Warnings (R_Id) := False;
10477 end Process_Restrictions_Or_Restriction_Warnings;
10479 ---------------------------------
10480 -- Process_Suppress_Unsuppress --
10481 ---------------------------------
10483 -- Note: this procedure makes entries in the check suppress data
10484 -- structures managed by Sem. See spec of package Sem for full
10485 -- details on how we handle recording of check suppression.
10487 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
10492 In_Package_Spec : constant Boolean :=
10493 Is_Package_Or_Generic_Package (Current_Scope)
10494 and then not In_Package_Body (Current_Scope);
10496 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
10497 -- Used to suppress a single check on the given entity
10499 --------------------------------
10500 -- Suppress_Unsuppress_Echeck --
10501 --------------------------------
10503 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
10505 -- Check for error of trying to set atomic synchronization for
10506 -- a non-atomic variable.
10508 if C = Atomic_Synchronization
10509 and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
10512 ("pragma & requires atomic type or variable",
10513 Pragma_Identifier (Original_Node (N)));
10516 Set_Checks_May_Be_Suppressed (E);
10518 if In_Package_Spec then
10519 Push_Global_Suppress_Stack_Entry
10522 Suppress => Suppress_Case);
10524 Push_Local_Suppress_Stack_Entry
10527 Suppress => Suppress_Case);
10530 -- If this is a first subtype, and the base type is distinct,
10531 -- then also set the suppress flags on the base type.
10533 if Is_First_Subtype (E) and then Etype (E) /= E then
10534 Suppress_Unsuppress_Echeck (Etype (E), C);
10536 end Suppress_Unsuppress_Echeck;
10538 -- Start of processing for Process_Suppress_Unsuppress
10541 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
10542 -- on user code: we want to generate checks for analysis purposes, as
10543 -- set respectively by -gnatC and -gnatd.F
10545 if Comes_From_Source (N)
10546 and then (CodePeer_Mode or GNATprove_Mode)
10551 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
10552 -- declarative part or a package spec (RM 11.5(5)).
10554 if not Is_Configuration_Pragma then
10555 Check_Is_In_Decl_Part_Or_Package_Spec;
10558 Check_At_Least_N_Arguments (1);
10559 Check_At_Most_N_Arguments (2);
10560 Check_No_Identifier (Arg1);
10561 Check_Arg_Is_Identifier (Arg1);
10563 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
10565 if C = No_Check_Id then
10567 ("argument of pragma% is not valid check name", Arg1);
10570 -- Warn that suppress of Elaboration_Check has no effect in SPARK
10572 if C = Elaboration_Check and then SPARK_Mode = On then
10574 ("Suppress of Elaboration_Check ignored in SPARK??",
10575 "\elaboration checking rules are statically enforced "
10576 & "(SPARK RM 7.7)", Arg1);
10579 -- One-argument case
10581 if Arg_Count = 1 then
10583 -- Make an entry in the local scope suppress table. This is the
10584 -- table that directly shows the current value of the scope
10585 -- suppress check for any check id value.
10587 if C = All_Checks then
10589 -- For All_Checks, we set all specific predefined checks with
10590 -- the exception of Elaboration_Check, which is handled
10591 -- specially because of not wanting All_Checks to have the
10592 -- effect of deactivating static elaboration order processing.
10593 -- Atomic_Synchronization is also not affected, since this is
10594 -- not a real check.
10596 for J in Scope_Suppress.Suppress'Range loop
10597 if J /= Elaboration_Check
10599 J /= Atomic_Synchronization
10601 Scope_Suppress.Suppress (J) := Suppress_Case;
10605 -- If not All_Checks, and predefined check, then set appropriate
10606 -- scope entry. Note that we will set Elaboration_Check if this
10607 -- is explicitly specified. Atomic_Synchronization is allowed
10608 -- only if internally generated and entity is atomic.
10610 elsif C in Predefined_Check_Id
10611 and then (not Comes_From_Source (N)
10612 or else C /= Atomic_Synchronization)
10614 Scope_Suppress.Suppress (C) := Suppress_Case;
10617 -- Also make an entry in the Local_Entity_Suppress table
10619 Push_Local_Suppress_Stack_Entry
10622 Suppress => Suppress_Case);
10624 -- Case of two arguments present, where the check is suppressed for
10625 -- a specified entity (given as the second argument of the pragma)
10628 -- This is obsolescent in Ada 2005 mode
10630 if Ada_Version >= Ada_2005 then
10631 Check_Restriction (No_Obsolescent_Features, Arg2);
10634 Check_Optional_Identifier (Arg2, Name_On);
10635 E_Id := Get_Pragma_Arg (Arg2);
10638 if not Is_Entity_Name (E_Id) then
10640 ("second argument of pragma% must be entity name", Arg2);
10643 E := Entity (E_Id);
10649 -- A pragma that applies to a Ghost entity becomes Ghost for the
10650 -- purposes of legality checks and removal of ignored Ghost code.
10652 Mark_Ghost_Pragma (N, E);
10654 -- Enforce RM 11.5(7) which requires that for a pragma that
10655 -- appears within a package spec, the named entity must be
10656 -- within the package spec. We allow the package name itself
10657 -- to be mentioned since that makes sense, although it is not
10658 -- strictly allowed by 11.5(7).
10661 and then E /= Current_Scope
10662 and then Scope (E) /= Current_Scope
10665 ("entity in pragma% is not in package spec (RM 11.5(7))",
10669 -- Loop through homonyms. As noted below, in the case of a package
10670 -- spec, only homonyms within the package spec are considered.
10673 Suppress_Unsuppress_Echeck (E, C);
10675 if Is_Generic_Instance (E)
10676 and then Is_Subprogram (E)
10677 and then Present (Alias (E))
10679 Suppress_Unsuppress_Echeck (Alias (E), C);
10682 -- Move to next homonym if not aspect spec case
10684 exit when From_Aspect_Specification (N);
10688 -- If we are within a package specification, the pragma only
10689 -- applies to homonyms in the same scope.
10691 exit when In_Package_Spec
10692 and then Scope (E) /= Current_Scope;
10695 end Process_Suppress_Unsuppress;
10697 -------------------------------
10698 -- Record_Independence_Check --
10699 -------------------------------
10701 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id) is
10702 pragma Unreferenced (N, E);
10704 -- For GCC back ends the validation is done a priori
10705 -- ??? This code is dead, might be useful in the future
10707 -- if not AAMP_On_Target then
10711 -- Independence_Checks.Append ((N, E));
10714 end Record_Independence_Check;
10720 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
10722 if Is_Imported (E) then
10724 ("cannot export entity& that was previously imported", Arg);
10726 elsif Present (Address_Clause (E))
10727 and then not Relaxed_RM_Semantics
10730 ("cannot export entity& that has an address clause", Arg);
10733 Set_Is_Exported (E);
10735 -- Generate a reference for entity explicitly, because the
10736 -- identifier may be overloaded and name resolution will not
10739 Generate_Reference (E, Arg);
10741 -- Deal with exporting non-library level entity
10743 if not Is_Library_Level_Entity (E) then
10745 -- Not allowed at all for subprograms
10747 if Is_Subprogram (E) then
10748 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
10750 -- Otherwise set public and statically allocated
10754 Set_Is_Statically_Allocated (E);
10756 -- Warn if the corresponding W flag is set
10758 if Warn_On_Export_Import
10760 -- Only do this for something that was in the source. Not
10761 -- clear if this can be False now (there used for sure to be
10762 -- cases on some systems where it was False), but anyway the
10763 -- test is harmless if not needed, so it is retained.
10765 and then Comes_From_Source (Arg)
10768 ("?x?& has been made static as a result of Export",
10771 ("\?x?this usage is non-standard and non-portable",
10777 if Warn_On_Export_Import and then Is_Type (E) then
10778 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
10781 if Warn_On_Export_Import and Inside_A_Generic then
10783 ("all instances of& will have the same external name?x?",
10788 ----------------------------------------------
10789 -- Set_Extended_Import_Export_External_Name --
10790 ----------------------------------------------
10792 procedure Set_Extended_Import_Export_External_Name
10793 (Internal_Ent : Entity_Id;
10794 Arg_External : Node_Id)
10796 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
10797 New_Name : Node_Id;
10800 if No (Arg_External) then
10804 Check_Arg_Is_External_Name (Arg_External);
10806 if Nkind (Arg_External) = N_String_Literal then
10807 if String_Length (Strval (Arg_External)) = 0 then
10810 New_Name := Adjust_External_Name_Case (Arg_External);
10813 elsif Nkind (Arg_External) = N_Identifier then
10814 New_Name := Get_Default_External_Name (Arg_External);
10816 -- Check_Arg_Is_External_Name should let through only identifiers and
10817 -- string literals or static string expressions (which are folded to
10818 -- string literals).
10821 raise Program_Error;
10824 -- If we already have an external name set (by a prior normal Import
10825 -- or Export pragma), then the external names must match
10827 if Present (Interface_Name (Internal_Ent)) then
10829 -- Ignore mismatching names in CodePeer mode, to support some
10830 -- old compilers which would export the same procedure under
10831 -- different names, e.g:
10833 -- pragma Export_Procedure (P, "a");
10834 -- pragma Export_Procedure (P, "b");
10836 if CodePeer_Mode then
10840 Check_Matching_Internal_Names : declare
10841 S1 : constant String_Id := Strval (Old_Name);
10842 S2 : constant String_Id := Strval (New_Name);
10844 procedure Mismatch;
10845 pragma No_Return (Mismatch);
10846 -- Called if names do not match
10852 procedure Mismatch is
10854 Error_Msg_Sloc := Sloc (Old_Name);
10856 ("external name does not match that given #",
10860 -- Start of processing for Check_Matching_Internal_Names
10863 if String_Length (S1) /= String_Length (S2) then
10867 for J in 1 .. String_Length (S1) loop
10868 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
10873 end Check_Matching_Internal_Names;
10875 -- Otherwise set the given name
10878 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
10879 Check_Duplicated_Export_Name (New_Name);
10881 end Set_Extended_Import_Export_External_Name;
10887 procedure Set_Imported (E : Entity_Id) is
10889 -- Error message if already imported or exported
10891 if Is_Exported (E) or else Is_Imported (E) then
10893 -- Error if being set Exported twice
10895 if Is_Exported (E) then
10896 Error_Msg_NE ("entity& was previously exported", N, E);
10898 -- Ignore error in CodePeer mode where we treat all imported
10899 -- subprograms as unknown.
10901 elsif CodePeer_Mode then
10904 -- OK if Import/Interface case
10906 elsif Import_Interface_Present (N) then
10909 -- Error if being set Imported twice
10912 Error_Msg_NE ("entity& was previously imported", N, E);
10915 Error_Msg_Name_1 := Pname;
10917 ("\(pragma% applies to all previous entities)", N);
10919 Error_Msg_Sloc := Sloc (E);
10920 Error_Msg_NE ("\import not allowed for& declared#", N, E);
10922 -- Here if not previously imported or exported, OK to import
10925 Set_Is_Imported (E);
10927 -- For subprogram, set Import_Pragma field
10929 if Is_Subprogram (E) then
10930 Set_Import_Pragma (E, N);
10933 -- If the entity is an object that is not at the library level,
10934 -- then it is statically allocated. We do not worry about objects
10935 -- with address clauses in this context since they are not really
10936 -- imported in the linker sense.
10939 and then not Is_Library_Level_Entity (E)
10940 and then No (Address_Clause (E))
10942 Set_Is_Statically_Allocated (E);
10949 -------------------------
10950 -- Set_Mechanism_Value --
10951 -------------------------
10953 -- Note: the mechanism name has not been analyzed (and cannot indeed be
10954 -- analyzed, since it is semantic nonsense), so we get it in the exact
10955 -- form created by the parser.
10957 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
10958 procedure Bad_Mechanism;
10959 pragma No_Return (Bad_Mechanism);
10960 -- Signal bad mechanism name
10962 -------------------
10963 -- Bad_Mechanism --
10964 -------------------
10966 procedure Bad_Mechanism is
10968 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
10971 -- Start of processing for Set_Mechanism_Value
10974 if Mechanism (Ent) /= Default_Mechanism then
10976 ("mechanism for & has already been set", Mech_Name, Ent);
10979 -- MECHANISM_NAME ::= value | reference
10981 if Nkind (Mech_Name) = N_Identifier then
10982 if Chars (Mech_Name) = Name_Value then
10983 Set_Mechanism (Ent, By_Copy);
10986 elsif Chars (Mech_Name) = Name_Reference then
10987 Set_Mechanism (Ent, By_Reference);
10990 elsif Chars (Mech_Name) = Name_Copy then
10992 ("bad mechanism name, Value assumed", Mech_Name);
11001 end Set_Mechanism_Value;
11003 --------------------------
11004 -- Set_Rational_Profile --
11005 --------------------------
11007 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
11008 -- extension to the semantics of renaming declarations.
11010 procedure Set_Rational_Profile is
11012 Implicit_Packing := True;
11013 Overriding_Renamings := True;
11014 Use_VADS_Size := True;
11015 end Set_Rational_Profile;
11017 ---------------------------
11018 -- Set_Ravenscar_Profile --
11019 ---------------------------
11021 -- The tasks to be done here are
11023 -- Set required policies
11025 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11026 -- (For Ravenscar and GNAT_Extended_Ravenscar profiles)
11027 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11028 -- (For GNAT_Ravenscar_EDF profile)
11029 -- pragma Locking_Policy (Ceiling_Locking)
11031 -- Set Detect_Blocking mode
11033 -- Set required restrictions (see System.Rident for detailed list)
11035 -- Set the No_Dependence rules
11036 -- No_Dependence => Ada.Asynchronous_Task_Control
11037 -- No_Dependence => Ada.Calendar
11038 -- No_Dependence => Ada.Execution_Time.Group_Budget
11039 -- No_Dependence => Ada.Execution_Time.Timers
11040 -- No_Dependence => Ada.Task_Attributes
11041 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11043 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id) is
11044 procedure Set_Error_Msg_To_Profile_Name;
11045 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
11048 -----------------------------------
11049 -- Set_Error_Msg_To_Profile_Name --
11050 -----------------------------------
11052 procedure Set_Error_Msg_To_Profile_Name is
11053 Prof_Nam : constant Node_Id :=
11055 (First (Pragma_Argument_Associations (N)));
11058 Get_Name_String (Chars (Prof_Nam));
11059 Adjust_Name_Case (Global_Name_Buffer, Sloc (Prof_Nam));
11060 Error_Msg_Strlen := Name_Len;
11061 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
11062 end Set_Error_Msg_To_Profile_Name;
11071 Profile_Dispatching_Policy : Character;
11073 -- Start of processing for Set_Ravenscar_Profile
11076 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11078 if Profile = GNAT_Ravenscar_EDF then
11079 Profile_Dispatching_Policy := 'E';
11081 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11084 Profile_Dispatching_Policy := 'F';
11087 if Task_Dispatching_Policy /= ' '
11088 and then Task_Dispatching_Policy /= Profile_Dispatching_Policy
11090 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
11091 Set_Error_Msg_To_Profile_Name;
11092 Error_Pragma ("Profile (~) incompatible with policy#");
11094 -- Set the FIFO_Within_Priorities policy, but always preserve
11095 -- System_Location since we like the error message with the run time
11099 Task_Dispatching_Policy := Profile_Dispatching_Policy;
11101 if Task_Dispatching_Policy_Sloc /= System_Location then
11102 Task_Dispatching_Policy_Sloc := Loc;
11106 -- pragma Locking_Policy (Ceiling_Locking)
11108 if Locking_Policy /= ' '
11109 and then Locking_Policy /= 'C'
11111 Error_Msg_Sloc := Locking_Policy_Sloc;
11112 Set_Error_Msg_To_Profile_Name;
11113 Error_Pragma ("Profile (~) incompatible with policy#");
11115 -- Set the Ceiling_Locking policy, but preserve System_Location since
11116 -- we like the error message with the run time name.
11119 Locking_Policy := 'C';
11121 if Locking_Policy_Sloc /= System_Location then
11122 Locking_Policy_Sloc := Loc;
11126 -- pragma Detect_Blocking
11128 Detect_Blocking := True;
11130 -- Set the corresponding restrictions
11132 Set_Profile_Restrictions
11133 (Profile, N, Warn => Treat_Restrictions_As_Warnings);
11135 -- Set the No_Dependence restrictions
11137 -- The following No_Dependence restrictions:
11138 -- No_Dependence => Ada.Asynchronous_Task_Control
11139 -- No_Dependence => Ada.Calendar
11140 -- No_Dependence => Ada.Task_Attributes
11141 -- are already set by previous call to Set_Profile_Restrictions.
11143 -- Set the following restrictions which were added to Ada 2005:
11144 -- No_Dependence => Ada.Execution_Time.Group_Budget
11145 -- No_Dependence => Ada.Execution_Time.Timers
11147 if Ada_Version >= Ada_2005 then
11148 Pref_Id := Make_Identifier (Loc, Name_Find ("ada"));
11149 Sel_Id := Make_Identifier (Loc, Name_Find ("execution_time"));
11152 Make_Selected_Component
11155 Selector_Name => Sel_Id);
11157 Sel_Id := Make_Identifier (Loc, Name_Find ("group_budgets"));
11160 Make_Selected_Component
11163 Selector_Name => Sel_Id);
11165 Set_Restriction_No_Dependence
11167 Warn => Treat_Restrictions_As_Warnings,
11168 Profile => Ravenscar);
11170 Sel_Id := Make_Identifier (Loc, Name_Find ("timers"));
11173 Make_Selected_Component
11176 Selector_Name => Sel_Id);
11178 Set_Restriction_No_Dependence
11180 Warn => Treat_Restrictions_As_Warnings,
11181 Profile => Ravenscar);
11184 -- Set the following restriction which was added to Ada 2012 (see
11186 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11188 if Ada_Version >= Ada_2012 then
11189 Pref_Id := Make_Identifier (Loc, Name_Find ("system"));
11190 Sel_Id := Make_Identifier (Loc, Name_Find ("multiprocessors"));
11193 Make_Selected_Component
11196 Selector_Name => Sel_Id);
11198 Sel_Id := Make_Identifier (Loc, Name_Find ("dispatching_domains"));
11201 Make_Selected_Component
11204 Selector_Name => Sel_Id);
11206 Set_Restriction_No_Dependence
11208 Warn => Treat_Restrictions_As_Warnings,
11209 Profile => Ravenscar);
11211 end Set_Ravenscar_Profile;
11213 -----------------------------------
11214 -- Validate_Acc_Condition_Clause --
11215 -----------------------------------
11217 procedure Validate_Acc_Condition_Clause (Clause : Node_Id) is
11219 Analyze_And_Resolve (Clause);
11221 if not Is_Boolean_Type (Etype (Clause)) then
11222 Error_Pragma ("expected a boolean");
11224 end Validate_Acc_Condition_Clause;
11226 ------------------------------
11227 -- Validate_Acc_Data_Clause --
11228 ------------------------------
11230 procedure Validate_Acc_Data_Clause (Clause : Node_Id) is
11234 Expr := Acc_First (Clause);
11235 while Present (Expr) loop
11236 if Nkind (Expr) /= N_Identifier then
11237 Error_Pragma ("expected an identifer");
11240 Analyze_And_Resolve (Expr);
11242 Expr := Acc_Next (Expr);
11244 end Validate_Acc_Data_Clause;
11246 ----------------------------------
11247 -- Validate_Acc_Int_Expr_Clause --
11248 ----------------------------------
11250 procedure Validate_Acc_Int_Expr_Clause (Clause : Node_Id) is
11252 Analyze_And_Resolve (Clause);
11254 if not Is_Integer_Type (Etype (Clause)) then
11255 Error_Pragma_Arg ("expected an integer", Clause);
11257 end Validate_Acc_Int_Expr_Clause;
11259 ---------------------------------------
11260 -- Validate_Acc_Int_Expr_List_Clause --
11261 ---------------------------------------
11263 procedure Validate_Acc_Int_Expr_List_Clause (Clause : Node_Id) is
11267 Expr := Acc_First (Clause);
11268 while Present (Expr) loop
11269 Analyze_And_Resolve (Expr);
11271 if not Is_Integer_Type (Etype (Expr)) then
11272 Error_Pragma ("expected an integer");
11275 Expr := Acc_Next (Expr);
11277 end Validate_Acc_Int_Expr_List_Clause;
11279 --------------------------------
11280 -- Validate_Acc_Loop_Collapse --
11281 --------------------------------
11283 procedure Validate_Acc_Loop_Collapse (Clause : Node_Id) is
11285 Par_Loop : Node_Id;
11289 -- Make sure the argument is a positive integer
11291 Analyze_And_Resolve (Clause);
11293 Count := Static_Integer (Clause);
11294 if Count = No_Uint or else Count < 1 then
11295 Error_Pragma_Arg ("expected a positive integer", Clause);
11298 -- Then, make sure we have at least Count-1 tightly-nested loops
11299 -- (i.e. loops with no statements in between).
11301 Par_Loop := Parent (Parent (Parent (Clause)));
11302 Stmt := First (Statements (Par_Loop));
11304 -- Skip first pragmas in the parent loop
11306 while Present (Stmt) and then Nkind (Stmt) = N_Pragma loop
11310 if not Present (Next (Stmt)) then
11311 while Nkind (Stmt) = N_Loop_Statement and Count > 1 loop
11312 Stmt := First (Statements (Stmt));
11313 exit when Present (Next (Stmt));
11315 Count := Count - 1;
11321 ("Collapse argument too high or loops not tightly nested",
11324 end Validate_Acc_Loop_Collapse;
11326 ----------------------------
11327 -- Validate_Acc_Loop_Gang --
11328 ----------------------------
11330 procedure Validate_Acc_Loop_Gang (Clause : Node_Id) is
11332 Error_Pragma_Arg ("Loop_Gang not implemented", Clause);
11333 end Validate_Acc_Loop_Gang;
11335 ------------------------------
11336 -- Validate_Acc_Loop_Vector --
11337 ------------------------------
11339 procedure Validate_Acc_Loop_Vector (Clause : Node_Id) is
11341 Error_Pragma_Arg ("Loop_Vector not implemented", Clause);
11342 end Validate_Acc_Loop_Vector;
11344 -------------------------------
11345 -- Validate_Acc_Loop_Worker --
11346 -------------------------------
11348 procedure Validate_Acc_Loop_Worker (Clause : Node_Id) is
11350 Error_Pragma_Arg ("Loop_Worker not implemented", Clause);
11351 end Validate_Acc_Loop_Worker;
11353 ---------------------------------
11354 -- Validate_Acc_Name_Reduction --
11355 ---------------------------------
11357 procedure Validate_Acc_Name_Reduction (Clause : Node_Id) is
11359 -- ??? On top of the following operations, the OpenAcc spec adds the
11360 -- "bitwise and", "bitwise or" and modulo for C and ".eqv" and
11361 -- ".neqv" for Fortran. Can we, should we and how do we support them
11364 type Reduction_Op is (Add_Op, Mul_Op, Max_Op, Min_Op, And_Op, Or_Op);
11366 function To_Reduction_Op (Op : String) return Reduction_Op;
11367 -- Convert operator Op described by a String into its corresponding
11368 -- enumeration value.
11370 ---------------------
11371 -- To_Reduction_Op --
11372 ---------------------
11374 function To_Reduction_Op (Op : String) return Reduction_Op is
11379 elsif Op = "*" then
11382 elsif Op = "max" then
11385 elsif Op = "min" then
11388 elsif Op = "and" then
11391 elsif Op = "or" then
11395 Error_Pragma ("unsuported reduction operation");
11397 end To_Reduction_Op;
11401 Seen : constant Elist_Id := New_Elmt_List;
11404 Reduc_Op : Node_Id;
11405 Reduc_Var : Node_Id;
11407 -- Start of processing for Validate_Acc_Name_Reduction
11410 -- Reduction operations appear in the following form:
11411 -- ("+" => (a, b), "*" => c)
11413 Expr := First (Component_Associations (Clause));
11414 while Present (Expr) loop
11415 Reduc_Op := First (Choices (Expr));
11416 String_To_Name_Buffer (Strval (Reduc_Op));
11418 case To_Reduction_Op (Name_Buffer (1 .. Name_Len)) is
11424 Reduc_Var := Acc_First (Expression (Expr));
11425 while Present (Reduc_Var) loop
11426 Analyze_And_Resolve (Reduc_Var);
11428 if Contains (Seen, Entity (Reduc_Var)) then
11429 Error_Pragma ("variable used in multiple reductions");
11432 if Nkind (Reduc_Var) /= N_Identifier
11433 or not Is_Numeric_Type (Etype (Reduc_Var))
11436 ("expected an identifier for a Numeric");
11439 Append_Elmt (Entity (Reduc_Var), Seen);
11442 Reduc_Var := Acc_Next (Reduc_Var);
11448 Reduc_Var := Acc_First (Expression (Expr));
11449 while Present (Reduc_Var) loop
11450 Analyze_And_Resolve (Reduc_Var);
11452 if Contains (Seen, Entity (Reduc_Var)) then
11453 Error_Pragma ("variable used in multiple reductions");
11456 if Nkind (Reduc_Var) /= N_Identifier
11457 or not Is_Boolean_Type (Etype (Reduc_Var))
11460 ("expected a variable of type boolean");
11463 Append_Elmt (Entity (Reduc_Var), Seen);
11466 Reduc_Var := Acc_Next (Reduc_Var);
11472 end Validate_Acc_Name_Reduction;
11474 -----------------------------------
11475 -- Validate_Acc_Size_Expressions --
11476 -----------------------------------
11478 procedure Validate_Acc_Size_Expressions (Clause : Node_Id) is
11479 function Validate_Size_Expr (Expr : Node_Id) return Boolean;
11480 -- A size expr is either an integer expression or "*"
11482 ------------------------
11483 -- Validate_Size_Expr --
11484 ------------------------
11486 function Validate_Size_Expr (Expr : Node_Id) return Boolean is
11488 if Nkind (Expr) = N_Operator_Symbol then
11489 return Get_String_Char (Strval (Expr), 1) = Get_Char_Code ('*');
11492 Analyze_And_Resolve (Expr);
11494 return Is_Integer_Type (Etype (Expr));
11495 end Validate_Size_Expr;
11501 -- Start of processing for Validate_Acc_Size_Expressions
11504 Expr := Acc_First (Clause);
11505 while Present (Expr) loop
11506 if not Validate_Size_Expr (Expr) then
11508 ("Size expressions should be either integers or '*'");
11511 Expr := Acc_Next (Expr);
11513 end Validate_Acc_Size_Expressions;
11515 -- Start of processing for Analyze_Pragma
11518 -- The following code is a defense against recursion. Not clear that
11519 -- this can happen legitimately, but perhaps some error situations can
11520 -- cause it, and we did see this recursion during testing.
11522 if Analyzed (N) then
11528 Check_Restriction_No_Use_Of_Pragma (N);
11530 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
11531 -- Default_Scalar_Storage_Order if the -gnatI switch was given.
11533 if Should_Ignore_Pragma_Sem (N)
11534 or else (Prag_Id = Pragma_Default_Scalar_Storage_Order
11535 and then Ignore_Rep_Clauses)
11540 -- Deal with unrecognized pragma
11542 if not Is_Pragma_Name (Pname) then
11543 if Warn_On_Unrecognized_Pragma then
11544 Error_Msg_Name_1 := Pname;
11545 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
11547 for PN in First_Pragma_Name .. Last_Pragma_Name loop
11548 if Is_Bad_Spelling_Of (Pname, PN) then
11549 Error_Msg_Name_1 := PN;
11550 Error_Msg_N -- CODEFIX
11551 ("\?g?possible misspelling of %!", Pragma_Identifier (N));
11560 -- Here to start processing for recognized pragma
11562 Pname := Original_Aspect_Pragma_Name (N);
11564 -- Capture setting of Opt.Uneval_Old
11566 case Opt.Uneval_Old is
11568 Set_Uneval_Old_Accept (N);
11574 Set_Uneval_Old_Warn (N);
11577 raise Program_Error;
11580 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
11581 -- is already set, indicating that we have already checked the policy
11582 -- at the right point. This happens for example in the case of a pragma
11583 -- that is derived from an Aspect.
11585 if Is_Ignored (N) or else Is_Checked (N) then
11588 -- For a pragma that is a rewriting of another pragma, copy the
11589 -- Is_Checked/Is_Ignored status from the rewritten pragma.
11591 elsif Is_Rewrite_Substitution (N)
11592 and then Nkind (Original_Node (N)) = N_Pragma
11594 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
11595 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
11597 -- Otherwise query the applicable policy at this point
11600 Check_Applicable_Policy (N);
11602 -- If pragma is disabled, rewrite as NULL and skip analysis
11604 if Is_Disabled (N) then
11605 Rewrite (N, Make_Null_Statement (Loc));
11611 -- Preset arguments
11619 if Present (Pragma_Argument_Associations (N)) then
11620 Arg_Count := List_Length (Pragma_Argument_Associations (N));
11621 Arg1 := First (Pragma_Argument_Associations (N));
11623 if Present (Arg1) then
11624 Arg2 := Next (Arg1);
11626 if Present (Arg2) then
11627 Arg3 := Next (Arg2);
11629 if Present (Arg3) then
11630 Arg4 := Next (Arg3);
11636 -- An enumeration type defines the pragmas that are supported by the
11637 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
11638 -- into the corresponding enumeration value for the following case.
11646 -- pragma Abort_Defer;
11648 when Pragma_Abort_Defer =>
11650 Check_Arg_Count (0);
11652 -- The only required semantic processing is to check the
11653 -- placement. This pragma must appear at the start of the
11654 -- statement sequence of a handled sequence of statements.
11656 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
11657 or else N /= First (Statements (Parent (N)))
11662 --------------------
11663 -- Abstract_State --
11664 --------------------
11666 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
11668 -- ABSTRACT_STATE_LIST ::=
11670 -- | STATE_NAME_WITH_OPTIONS
11671 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
11673 -- STATE_NAME_WITH_OPTIONS ::=
11675 -- | (STATE_NAME with OPTION_LIST)
11677 -- OPTION_LIST ::= OPTION {, OPTION}
11681 -- | NAME_VALUE_OPTION
11683 -- SIMPLE_OPTION ::= Ghost | Synchronous
11685 -- NAME_VALUE_OPTION ::=
11686 -- Part_Of => ABSTRACT_STATE
11687 -- | External [=> EXTERNAL_PROPERTY_LIST]
11689 -- EXTERNAL_PROPERTY_LIST ::=
11690 -- EXTERNAL_PROPERTY
11691 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
11693 -- EXTERNAL_PROPERTY ::=
11694 -- Async_Readers [=> boolean_EXPRESSION]
11695 -- | Async_Writers [=> boolean_EXPRESSION]
11696 -- | Effective_Reads [=> boolean_EXPRESSION]
11697 -- | Effective_Writes [=> boolean_EXPRESSION]
11698 -- others => boolean_EXPRESSION
11700 -- STATE_NAME ::= defining_identifier
11702 -- ABSTRACT_STATE ::= name
11704 -- Characteristics:
11706 -- * Analysis - The annotation is fully analyzed immediately upon
11707 -- elaboration as it cannot forward reference entities.
11709 -- * Expansion - None.
11711 -- * Template - The annotation utilizes the generic template of the
11712 -- related package declaration.
11714 -- * Globals - The annotation cannot reference global entities.
11716 -- * Instance - The annotation is instantiated automatically when
11717 -- the related generic package is instantiated.
11719 when Pragma_Abstract_State => Abstract_State : declare
11720 Missing_Parentheses : Boolean := False;
11721 -- Flag set when a state declaration with options is not properly
11724 -- Flags used to verify the consistency of states
11726 Non_Null_Seen : Boolean := False;
11727 Null_Seen : Boolean := False;
11729 procedure Analyze_Abstract_State
11731 Pack_Id : Entity_Id);
11732 -- Verify the legality of a single state declaration. Create and
11733 -- decorate a state abstraction entity and introduce it into the
11734 -- visibility chain. Pack_Id denotes the entity or the related
11735 -- package where pragma Abstract_State appears.
11737 procedure Malformed_State_Error (State : Node_Id);
11738 -- Emit an error concerning the illegal declaration of abstract
11739 -- state State. This routine diagnoses syntax errors that lead to
11740 -- a different parse tree. The error is issued regardless of the
11741 -- SPARK mode in effect.
11743 ----------------------------
11744 -- Analyze_Abstract_State --
11745 ----------------------------
11747 procedure Analyze_Abstract_State
11749 Pack_Id : Entity_Id)
11751 -- Flags used to verify the consistency of options
11753 AR_Seen : Boolean := False;
11754 AW_Seen : Boolean := False;
11755 ER_Seen : Boolean := False;
11756 EW_Seen : Boolean := False;
11757 External_Seen : Boolean := False;
11758 Ghost_Seen : Boolean := False;
11759 Others_Seen : Boolean := False;
11760 Part_Of_Seen : Boolean := False;
11761 Synchronous_Seen : Boolean := False;
11763 -- Flags used to store the static value of all external states'
11766 AR_Val : Boolean := False;
11767 AW_Val : Boolean := False;
11768 ER_Val : Boolean := False;
11769 EW_Val : Boolean := False;
11771 State_Id : Entity_Id := Empty;
11772 -- The entity to be generated for the current state declaration
11774 procedure Analyze_External_Option (Opt : Node_Id);
11775 -- Verify the legality of option External
11777 procedure Analyze_External_Property
11779 Expr : Node_Id := Empty);
11780 -- Verify the legailty of a single external property. Prop
11781 -- denotes the external property. Expr is the expression used
11782 -- to set the property.
11784 procedure Analyze_Part_Of_Option (Opt : Node_Id);
11785 -- Verify the legality of option Part_Of
11787 procedure Check_Duplicate_Option
11789 Status : in out Boolean);
11790 -- Flag Status denotes whether a particular option has been
11791 -- seen while processing a state. This routine verifies that
11792 -- Opt is not a duplicate option and sets the flag Status
11793 -- (SPARK RM 7.1.4(1)).
11795 procedure Check_Duplicate_Property
11797 Status : in out Boolean);
11798 -- Flag Status denotes whether a particular property has been
11799 -- seen while processing option External. This routine verifies
11800 -- that Prop is not a duplicate property and sets flag Status.
11801 -- Opt is not a duplicate property and sets the flag Status.
11802 -- (SPARK RM 7.1.4(2))
11804 procedure Check_Ghost_Synchronous;
11805 -- Ensure that the abstract state is not subject to both Ghost
11806 -- and Synchronous simple options. Emit an error if this is the
11809 procedure Create_Abstract_State
11813 Is_Null : Boolean);
11814 -- Generate an abstract state entity with name Nam and enter it
11815 -- into visibility. Decl is the "declaration" of the state as
11816 -- it appears in pragma Abstract_State. Loc is the location of
11817 -- the related state "declaration". Flag Is_Null should be set
11818 -- when the associated Abstract_State pragma defines a null
11821 -----------------------------
11822 -- Analyze_External_Option --
11823 -----------------------------
11825 procedure Analyze_External_Option (Opt : Node_Id) is
11826 Errors : constant Nat := Serious_Errors_Detected;
11828 Props : Node_Id := Empty;
11831 if Nkind (Opt) = N_Component_Association then
11832 Props := Expression (Opt);
11835 -- External state with properties
11837 if Present (Props) then
11839 -- Multiple properties appear as an aggregate
11841 if Nkind (Props) = N_Aggregate then
11843 -- Simple property form
11845 Prop := First (Expressions (Props));
11846 while Present (Prop) loop
11847 Analyze_External_Property (Prop);
11851 -- Property with expression form
11853 Prop := First (Component_Associations (Props));
11854 while Present (Prop) loop
11855 Analyze_External_Property
11856 (Prop => First (Choices (Prop)),
11857 Expr => Expression (Prop));
11865 Analyze_External_Property (Props);
11868 -- An external state defined without any properties defaults
11869 -- all properties to True.
11878 -- Once all external properties have been processed, verify
11879 -- their mutual interaction. Do not perform the check when
11880 -- at least one of the properties is illegal as this will
11881 -- produce a bogus error.
11883 if Errors = Serious_Errors_Detected then
11884 Check_External_Properties
11885 (State, AR_Val, AW_Val, ER_Val, EW_Val);
11887 end Analyze_External_Option;
11889 -------------------------------
11890 -- Analyze_External_Property --
11891 -------------------------------
11893 procedure Analyze_External_Property
11895 Expr : Node_Id := Empty)
11897 Expr_Val : Boolean;
11900 -- Check the placement of "others" (if available)
11902 if Nkind (Prop) = N_Others_Choice then
11903 if Others_Seen then
11905 ("only one others choice allowed in option External",
11908 Others_Seen := True;
11911 elsif Others_Seen then
11913 ("others must be the last property in option External",
11916 -- The only remaining legal options are the four predefined
11917 -- external properties.
11919 elsif Nkind (Prop) = N_Identifier
11920 and then Nam_In (Chars (Prop), Name_Async_Readers,
11921 Name_Async_Writers,
11922 Name_Effective_Reads,
11923 Name_Effective_Writes)
11927 -- Otherwise the construct is not a valid property
11930 SPARK_Msg_N ("invalid external state property", Prop);
11934 -- Ensure that the expression of the external state property
11935 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
11937 if Present (Expr) then
11938 Analyze_And_Resolve (Expr, Standard_Boolean);
11940 if Is_OK_Static_Expression (Expr) then
11941 Expr_Val := Is_True (Expr_Value (Expr));
11944 ("expression of external state property must be "
11949 -- The lack of expression defaults the property to True
11955 -- Named properties
11957 if Nkind (Prop) = N_Identifier then
11958 if Chars (Prop) = Name_Async_Readers then
11959 Check_Duplicate_Property (Prop, AR_Seen);
11960 AR_Val := Expr_Val;
11962 elsif Chars (Prop) = Name_Async_Writers then
11963 Check_Duplicate_Property (Prop, AW_Seen);
11964 AW_Val := Expr_Val;
11966 elsif Chars (Prop) = Name_Effective_Reads then
11967 Check_Duplicate_Property (Prop, ER_Seen);
11968 ER_Val := Expr_Val;
11971 Check_Duplicate_Property (Prop, EW_Seen);
11972 EW_Val := Expr_Val;
11975 -- The handling of property "others" must take into account
11976 -- all other named properties that have been encountered so
11977 -- far. Only those that have not been seen are affected by
11981 if not AR_Seen then
11982 AR_Val := Expr_Val;
11985 if not AW_Seen then
11986 AW_Val := Expr_Val;
11989 if not ER_Seen then
11990 ER_Val := Expr_Val;
11993 if not EW_Seen then
11994 EW_Val := Expr_Val;
11997 end Analyze_External_Property;
11999 ----------------------------
12000 -- Analyze_Part_Of_Option --
12001 ----------------------------
12003 procedure Analyze_Part_Of_Option (Opt : Node_Id) is
12004 Encap : constant Node_Id := Expression (Opt);
12005 Constits : Elist_Id;
12006 Encap_Id : Entity_Id;
12010 Check_Duplicate_Option (Opt, Part_Of_Seen);
12013 (Indic => First (Choices (Opt)),
12014 Item_Id => State_Id,
12016 Encap_Id => Encap_Id,
12019 -- The Part_Of indicator transforms the abstract state into
12020 -- a constituent of the encapsulating state or single
12021 -- concurrent type.
12024 pragma Assert (Present (Encap_Id));
12025 Constits := Part_Of_Constituents (Encap_Id);
12027 if No (Constits) then
12028 Constits := New_Elmt_List;
12029 Set_Part_Of_Constituents (Encap_Id, Constits);
12032 Append_Elmt (State_Id, Constits);
12033 Set_Encapsulating_State (State_Id, Encap_Id);
12035 end Analyze_Part_Of_Option;
12037 ----------------------------
12038 -- Check_Duplicate_Option --
12039 ----------------------------
12041 procedure Check_Duplicate_Option
12043 Status : in out Boolean)
12047 SPARK_Msg_N ("duplicate state option", Opt);
12051 end Check_Duplicate_Option;
12053 ------------------------------
12054 -- Check_Duplicate_Property --
12055 ------------------------------
12057 procedure Check_Duplicate_Property
12059 Status : in out Boolean)
12063 SPARK_Msg_N ("duplicate external property", Prop);
12067 end Check_Duplicate_Property;
12069 -----------------------------
12070 -- Check_Ghost_Synchronous --
12071 -----------------------------
12073 procedure Check_Ghost_Synchronous is
12075 -- A synchronized abstract state cannot be Ghost and vice
12076 -- versa (SPARK RM 6.9(19)).
12078 if Ghost_Seen and Synchronous_Seen then
12079 SPARK_Msg_N ("synchronized state cannot be ghost", State);
12081 end Check_Ghost_Synchronous;
12083 ---------------------------
12084 -- Create_Abstract_State --
12085 ---------------------------
12087 procedure Create_Abstract_State
12094 -- The abstract state may be semi-declared when the related
12095 -- package was withed through a limited with clause. In that
12096 -- case reuse the entity to fully declare the state.
12098 if Present (Decl) and then Present (Entity (Decl)) then
12099 State_Id := Entity (Decl);
12101 -- Otherwise the elaboration of pragma Abstract_State
12102 -- declares the state.
12105 State_Id := Make_Defining_Identifier (Loc, Nam);
12107 if Present (Decl) then
12108 Set_Entity (Decl, State_Id);
12112 -- Null states never come from source
12114 Set_Comes_From_Source (State_Id, not Is_Null);
12115 Set_Parent (State_Id, State);
12116 Set_Ekind (State_Id, E_Abstract_State);
12117 Set_Etype (State_Id, Standard_Void_Type);
12118 Set_Encapsulating_State (State_Id, Empty);
12120 -- Set the SPARK mode from the current context
12122 Set_SPARK_Pragma (State_Id, SPARK_Mode_Pragma);
12123 Set_SPARK_Pragma_Inherited (State_Id);
12125 -- An abstract state declared within a Ghost region becomes
12126 -- Ghost (SPARK RM 6.9(2)).
12128 if Ghost_Mode > None or else Is_Ghost_Entity (Pack_Id) then
12129 Set_Is_Ghost_Entity (State_Id);
12132 -- Establish a link between the state declaration and the
12133 -- abstract state entity. Note that a null state remains as
12134 -- N_Null and does not carry any linkages.
12136 if not Is_Null then
12137 if Present (Decl) then
12138 Set_Entity (Decl, State_Id);
12139 Set_Etype (Decl, Standard_Void_Type);
12142 -- Every non-null state must be defined, nameable and
12145 Push_Scope (Pack_Id);
12146 Generate_Definition (State_Id);
12147 Enter_Name (State_Id);
12150 end Create_Abstract_State;
12157 -- Start of processing for Analyze_Abstract_State
12160 -- A package with a null abstract state is not allowed to
12161 -- declare additional states.
12165 ("package & has null abstract state", State, Pack_Id);
12167 -- Null states appear as internally generated entities
12169 elsif Nkind (State) = N_Null then
12170 Create_Abstract_State
12171 (Nam => New_Internal_Name ('S'),
12173 Loc => Sloc (State),
12177 -- Catch a case where a null state appears in a list of
12178 -- non-null states.
12180 if Non_Null_Seen then
12182 ("package & has non-null abstract state",
12186 -- Simple state declaration
12188 elsif Nkind (State) = N_Identifier then
12189 Create_Abstract_State
12190 (Nam => Chars (State),
12192 Loc => Sloc (State),
12194 Non_Null_Seen := True;
12196 -- State declaration with various options. This construct
12197 -- appears as an extension aggregate in the tree.
12199 elsif Nkind (State) = N_Extension_Aggregate then
12200 if Nkind (Ancestor_Part (State)) = N_Identifier then
12201 Create_Abstract_State
12202 (Nam => Chars (Ancestor_Part (State)),
12203 Decl => Ancestor_Part (State),
12204 Loc => Sloc (Ancestor_Part (State)),
12206 Non_Null_Seen := True;
12209 ("state name must be an identifier",
12210 Ancestor_Part (State));
12213 -- Options External, Ghost and Synchronous appear as
12216 Opt := First (Expressions (State));
12217 while Present (Opt) loop
12218 if Nkind (Opt) = N_Identifier then
12222 if Chars (Opt) = Name_External then
12223 Check_Duplicate_Option (Opt, External_Seen);
12224 Analyze_External_Option (Opt);
12228 elsif Chars (Opt) = Name_Ghost then
12229 Check_Duplicate_Option (Opt, Ghost_Seen);
12230 Check_Ghost_Synchronous;
12232 if Present (State_Id) then
12233 Set_Is_Ghost_Entity (State_Id);
12238 elsif Chars (Opt) = Name_Synchronous then
12239 Check_Duplicate_Option (Opt, Synchronous_Seen);
12240 Check_Ghost_Synchronous;
12242 -- Option Part_Of without an encapsulating state is
12243 -- illegal (SPARK RM 7.1.4(8)).
12245 elsif Chars (Opt) = Name_Part_Of then
12247 ("indicator Part_Of must denote abstract state, "
12248 & "single protected type or single task type",
12251 -- Do not emit an error message when a previous state
12252 -- declaration with options was not parenthesized as
12253 -- the option is actually another state declaration.
12255 -- with Abstract_State
12256 -- (State_1 with ..., -- missing parentheses
12257 -- (State_2 with ...),
12258 -- State_3) -- ok state declaration
12260 elsif Missing_Parentheses then
12263 -- Otherwise the option is not allowed. Note that it
12264 -- is not possible to distinguish between an option
12265 -- and a state declaration when a previous state with
12266 -- options not properly parentheses.
12268 -- with Abstract_State
12269 -- (State_1 with ..., -- missing parentheses
12270 -- State_2); -- could be an option
12274 ("simple option not allowed in state declaration",
12278 -- Catch a case where missing parentheses around a state
12279 -- declaration with options cause a subsequent state
12280 -- declaration with options to be treated as an option.
12282 -- with Abstract_State
12283 -- (State_1 with ..., -- missing parentheses
12284 -- (State_2 with ...))
12286 elsif Nkind (Opt) = N_Extension_Aggregate then
12287 Missing_Parentheses := True;
12289 ("state declaration must be parenthesized",
12290 Ancestor_Part (State));
12292 -- Otherwise the option is malformed
12295 SPARK_Msg_N ("malformed option", Opt);
12301 -- Options External and Part_Of appear as component
12304 Opt := First (Component_Associations (State));
12305 while Present (Opt) loop
12306 Opt_Nam := First (Choices (Opt));
12308 if Nkind (Opt_Nam) = N_Identifier then
12309 if Chars (Opt_Nam) = Name_External then
12310 Analyze_External_Option (Opt);
12312 elsif Chars (Opt_Nam) = Name_Part_Of then
12313 Analyze_Part_Of_Option (Opt);
12316 SPARK_Msg_N ("invalid state option", Opt);
12319 SPARK_Msg_N ("invalid state option", Opt);
12325 -- Any other attempt to declare a state is illegal
12328 Malformed_State_Error (State);
12332 -- Guard against a junk state. In such cases no entity is
12333 -- generated and the subsequent checks cannot be applied.
12335 if Present (State_Id) then
12337 -- Verify whether the state does not introduce an illegal
12338 -- hidden state within a package subject to a null abstract
12341 Check_No_Hidden_State (State_Id);
12343 -- Check whether the lack of option Part_Of agrees with the
12344 -- placement of the abstract state with respect to the state
12347 if not Part_Of_Seen then
12348 Check_Missing_Part_Of (State_Id);
12351 -- Associate the state with its related package
12353 if No (Abstract_States (Pack_Id)) then
12354 Set_Abstract_States (Pack_Id, New_Elmt_List);
12357 Append_Elmt (State_Id, Abstract_States (Pack_Id));
12359 end Analyze_Abstract_State;
12361 ---------------------------
12362 -- Malformed_State_Error --
12363 ---------------------------
12365 procedure Malformed_State_Error (State : Node_Id) is
12367 Error_Msg_N ("malformed abstract state declaration", State);
12369 -- An abstract state with a simple option is being declared
12370 -- with "=>" rather than the legal "with". The state appears
12371 -- as a component association.
12373 if Nkind (State) = N_Component_Association then
12374 Error_Msg_N ("\use WITH to specify simple option", State);
12376 end Malformed_State_Error;
12380 Pack_Decl : Node_Id;
12381 Pack_Id : Entity_Id;
12385 -- Start of processing for Abstract_State
12389 Check_No_Identifiers;
12390 Check_Arg_Count (1);
12392 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
12394 if not Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
12395 N_Package_Declaration)
12401 Pack_Id := Defining_Entity (Pack_Decl);
12403 -- A pragma that applies to a Ghost entity becomes Ghost for the
12404 -- purposes of legality checks and removal of ignored Ghost code.
12406 Mark_Ghost_Pragma (N, Pack_Id);
12407 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
12409 -- Chain the pragma on the contract for completeness
12411 Add_Contract_Item (N, Pack_Id);
12413 -- The legality checks of pragmas Abstract_State, Initializes, and
12414 -- Initial_Condition are affected by the SPARK mode in effect. In
12415 -- addition, these three pragmas are subject to an inherent order:
12417 -- 1) Abstract_State
12419 -- 3) Initial_Condition
12421 -- Analyze all these pragmas in the order outlined above
12423 Analyze_If_Present (Pragma_SPARK_Mode);
12424 States := Expression (Get_Argument (N, Pack_Id));
12426 -- Multiple non-null abstract states appear as an aggregate
12428 if Nkind (States) = N_Aggregate then
12429 State := First (Expressions (States));
12430 while Present (State) loop
12431 Analyze_Abstract_State (State, Pack_Id);
12435 -- An abstract state with a simple option is being illegaly
12436 -- declared with "=>" rather than "with". In this case the
12437 -- state declaration appears as a component association.
12439 if Present (Component_Associations (States)) then
12440 State := First (Component_Associations (States));
12441 while Present (State) loop
12442 Malformed_State_Error (State);
12447 -- Various forms of a single abstract state. Note that these may
12448 -- include malformed state declarations.
12451 Analyze_Abstract_State (States, Pack_Id);
12454 Analyze_If_Present (Pragma_Initializes);
12455 Analyze_If_Present (Pragma_Initial_Condition);
12456 end Abstract_State;
12462 when Pragma_Acc_Data => Acc_Data : declare
12463 Clause_Names : constant Name_List :=
12476 Clauses : Args_List (Clause_Names'Range);
12479 if not OpenAcc_Enabled then
12485 if Nkind (Parent (N)) /= N_Loop_Statement then
12487 ("Acc_Data pragma should be placed in loop or block "
12491 Gather_Associations (Clause_Names, Clauses);
12493 for Id in Clause_Names'First .. Clause_Names'Last loop
12494 Clause := Clauses (Id);
12496 if Present (Clause) then
12497 case Clause_Names (Id) is
12505 Validate_Acc_Data_Clause (Clause);
12512 Error_Pragma ("unsupported pragma clause");
12515 raise Program_Error;
12520 Set_Is_OpenAcc_Environment (Parent (N));
12527 when Pragma_Acc_Loop => Acc_Loop : declare
12528 Clause_Names : constant Name_List :=
12541 Clauses : Args_List (Clause_Names'Range);
12545 if not OpenAcc_Enabled then
12551 -- Make sure the pragma is in an openacc construct
12553 Check_Loop_Pragma_Placement;
12556 while Present (Par)
12557 and then (Nkind (Par) /= N_Loop_Statement
12558 or else not Is_OpenAcc_Environment (Par))
12560 Par := Parent (Par);
12563 if not Is_OpenAcc_Environment (Par) then
12565 ("Acc_Loop directive must be associated with an OpenAcc "
12566 & "construct region");
12569 Gather_Associations (Clause_Names, Clauses);
12571 for Id in Clause_Names'First .. Clause_Names'Last loop
12572 Clause := Clauses (Id);
12574 if Present (Clause) then
12575 case Clause_Names (Id) is
12582 when Name_Collapse =>
12583 Validate_Acc_Loop_Collapse (Clause);
12586 Validate_Acc_Loop_Gang (Clause);
12588 when Name_Acc_Private =>
12589 Validate_Acc_Data_Clause (Clause);
12591 when Name_Reduction =>
12592 Validate_Acc_Name_Reduction (Clause);
12595 Validate_Acc_Size_Expressions (Clause);
12597 when Name_Vector =>
12598 Validate_Acc_Loop_Vector (Clause);
12600 when Name_Worker =>
12601 Validate_Acc_Loop_Worker (Clause);
12604 raise Program_Error;
12609 Set_Is_OpenAcc_Loop (Parent (N));
12612 ----------------------------------
12613 -- Acc_Parallel and Acc_Kernels --
12614 ----------------------------------
12616 when Pragma_Acc_Parallel
12617 | Pragma_Acc_Kernels
12619 Acc_Kernels_Or_Parallel : declare
12620 Clause_Names : constant Name_List :=
12633 Name_Vector_Length,
12639 Name_First_Private,
12648 Clauses : Args_List (Clause_Names'Range);
12651 if not OpenAcc_Enabled then
12656 Check_Loop_Pragma_Placement;
12658 if Nkind (Parent (N)) /= N_Loop_Statement then
12660 ("pragma should be placed in loop or block statements");
12663 Gather_Associations (Clause_Names, Clauses);
12665 for Id in Clause_Names'First .. Clause_Names'Last loop
12666 Clause := Clauses (Id);
12668 if Present (Clause) then
12669 if Chars (Parent (Clause)) = No_Name then
12670 Error_Pragma ("all arguments should be associations");
12672 case Clause_Names (Id) is
12674 -- Note: According to the OpenAcc Standard v2.6,
12675 -- Async's argument should be optional. Because this
12676 -- complicates parsing the clause, the argument is
12677 -- made mandatory. The standard defines two negative
12678 -- values, acc_async_noval and acc_async_sync. When
12679 -- given acc_async_noval as value, the clause should
12680 -- behave as if no argument was given. According to
12681 -- the standard, acc_async_noval is defined in header
12682 -- files for C and Fortran, thus this value should
12683 -- probably be defined in the OpenAcc Ada library once
12684 -- it is implemented.
12689 | Name_Vector_Length
12691 Validate_Acc_Int_Expr_Clause (Clause);
12693 when Name_Acc_If =>
12694 Validate_Acc_Condition_Clause (Clause);
12696 -- Unsupported by GCC
12701 Error_Pragma ("unsupported clause");
12703 when Name_Acc_Private
12704 | Name_First_Private
12706 if Prag_Id /= Pragma_Acc_Parallel then
12708 ("argument is only available for 'Parallel' "
12711 Validate_Acc_Data_Clause (Clause);
12721 Validate_Acc_Data_Clause (Clause);
12723 when Name_Reduction =>
12724 if Prag_Id /= Pragma_Acc_Parallel then
12726 ("argument is only available for 'Parallel' "
12729 Validate_Acc_Name_Reduction (Clause);
12732 when Name_Default =>
12733 if Chars (Clause) /= Name_None then
12734 Error_Pragma ("expected none");
12737 when Name_Device_Type =>
12738 Error_Pragma ("unsupported pragma clause");
12740 -- Similar to Name_Async, Name_Wait's arguments should
12741 -- be optional. However, this can be simulated using
12742 -- acc_async_noval, hence, we do not bother making the
12743 -- argument optional for now.
12746 Validate_Acc_Int_Expr_List_Clause (Clause);
12749 raise Program_Error;
12755 Set_Is_OpenAcc_Environment (Parent (N));
12756 end Acc_Kernels_Or_Parallel;
12764 -- Note: this pragma also has some specific processing in Par.Prag
12765 -- because we want to set the Ada version mode during parsing.
12767 when Pragma_Ada_83 =>
12769 Check_Arg_Count (0);
12771 -- We really should check unconditionally for proper configuration
12772 -- pragma placement, since we really don't want mixed Ada modes
12773 -- within a single unit, and the GNAT reference manual has always
12774 -- said this was a configuration pragma, but we did not check and
12775 -- are hesitant to add the check now.
12777 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
12778 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
12779 -- or Ada 2012 mode.
12781 if Ada_Version >= Ada_2005 then
12782 Check_Valid_Configuration_Pragma;
12785 -- Now set Ada 83 mode
12787 if Latest_Ada_Only then
12788 Error_Pragma ("??pragma% ignored");
12790 Ada_Version := Ada_83;
12791 Ada_Version_Explicit := Ada_83;
12792 Ada_Version_Pragma := N;
12801 -- Note: this pragma also has some specific processing in Par.Prag
12802 -- because we want to set the Ada 83 version mode during parsing.
12804 when Pragma_Ada_95 =>
12806 Check_Arg_Count (0);
12808 -- We really should check unconditionally for proper configuration
12809 -- pragma placement, since we really don't want mixed Ada modes
12810 -- within a single unit, and the GNAT reference manual has always
12811 -- said this was a configuration pragma, but we did not check and
12812 -- are hesitant to add the check now.
12814 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
12815 -- or Ada 95, so we must check if we are in Ada 2005 mode.
12817 if Ada_Version >= Ada_2005 then
12818 Check_Valid_Configuration_Pragma;
12821 -- Now set Ada 95 mode
12823 if Latest_Ada_Only then
12824 Error_Pragma ("??pragma% ignored");
12826 Ada_Version := Ada_95;
12827 Ada_Version_Explicit := Ada_95;
12828 Ada_Version_Pragma := N;
12831 ---------------------
12832 -- Ada_05/Ada_2005 --
12833 ---------------------
12836 -- pragma Ada_05 (LOCAL_NAME);
12838 -- pragma Ada_2005;
12839 -- pragma Ada_2005 (LOCAL_NAME):
12841 -- Note: these pragmas also have some specific processing in Par.Prag
12842 -- because we want to set the Ada 2005 version mode during parsing.
12844 -- The one argument form is used for managing the transition from
12845 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
12846 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
12847 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
12848 -- mode, a preference rule is established which does not choose
12849 -- such an entity unless it is unambiguously specified. This avoids
12850 -- extra subprograms marked this way from generating ambiguities in
12851 -- otherwise legal pre-Ada_2005 programs. The one argument form is
12852 -- intended for exclusive use in the GNAT run-time library.
12863 if Arg_Count = 1 then
12864 Check_Arg_Is_Local_Name (Arg1);
12865 E_Id := Get_Pragma_Arg (Arg1);
12867 if Etype (E_Id) = Any_Type then
12871 Set_Is_Ada_2005_Only (Entity (E_Id));
12872 Record_Rep_Item (Entity (E_Id), N);
12875 Check_Arg_Count (0);
12877 -- For Ada_2005 we unconditionally enforce the documented
12878 -- configuration pragma placement, since we do not want to
12879 -- tolerate mixed modes in a unit involving Ada 2005. That
12880 -- would cause real difficulties for those cases where there
12881 -- are incompatibilities between Ada 95 and Ada 2005.
12883 Check_Valid_Configuration_Pragma;
12885 -- Now set appropriate Ada mode
12887 if Latest_Ada_Only then
12888 Error_Pragma ("??pragma% ignored");
12890 Ada_Version := Ada_2005;
12891 Ada_Version_Explicit := Ada_2005;
12892 Ada_Version_Pragma := N;
12897 ---------------------
12898 -- Ada_12/Ada_2012 --
12899 ---------------------
12902 -- pragma Ada_12 (LOCAL_NAME);
12904 -- pragma Ada_2012;
12905 -- pragma Ada_2012 (LOCAL_NAME):
12907 -- Note: these pragmas also have some specific processing in Par.Prag
12908 -- because we want to set the Ada 2012 version mode during parsing.
12910 -- The one argument form is used for managing the transition from Ada
12911 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
12912 -- as Ada_2012 only, then referencing the entity in any pre-Ada_2012
12913 -- mode will generate a warning. In addition, in any pre-Ada_2012
12914 -- mode, a preference rule is established which does not choose
12915 -- such an entity unless it is unambiguously specified. This avoids
12916 -- extra subprograms marked this way from generating ambiguities in
12917 -- otherwise legal pre-Ada_2012 programs. The one argument form is
12918 -- intended for exclusive use in the GNAT run-time library.
12929 if Arg_Count = 1 then
12930 Check_Arg_Is_Local_Name (Arg1);
12931 E_Id := Get_Pragma_Arg (Arg1);
12933 if Etype (E_Id) = Any_Type then
12937 Set_Is_Ada_2012_Only (Entity (E_Id));
12938 Record_Rep_Item (Entity (E_Id), N);
12941 Check_Arg_Count (0);
12943 -- For Ada_2012 we unconditionally enforce the documented
12944 -- configuration pragma placement, since we do not want to
12945 -- tolerate mixed modes in a unit involving Ada 2012. That
12946 -- would cause real difficulties for those cases where there
12947 -- are incompatibilities between Ada 95 and Ada 2012. We could
12948 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
12950 Check_Valid_Configuration_Pragma;
12952 -- Now set appropriate Ada mode
12954 Ada_Version := Ada_2012;
12955 Ada_Version_Explicit := Ada_2012;
12956 Ada_Version_Pragma := N;
12964 -- pragma Ada_2020;
12966 -- Note: this pragma also has some specific processing in Par.Prag
12967 -- because we want to set the Ada 2020 version mode during parsing.
12969 when Pragma_Ada_2020 =>
12972 Check_Arg_Count (0);
12974 Check_Valid_Configuration_Pragma;
12976 -- Now set appropriate Ada mode
12978 Ada_Version := Ada_2020;
12979 Ada_Version_Explicit := Ada_2020;
12980 Ada_Version_Pragma := N;
12982 -------------------------------------
12983 -- Aggregate_Individually_Assign --
12984 -------------------------------------
12986 -- pragma Aggregate_Individually_Assign;
12988 when Pragma_Aggregate_Individually_Assign =>
12990 Check_Arg_Count (0);
12991 Check_Valid_Configuration_Pragma;
12992 Aggregate_Individually_Assign := True;
12994 ----------------------
12995 -- All_Calls_Remote --
12996 ----------------------
12998 -- pragma All_Calls_Remote [(library_package_NAME)];
13000 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
13001 Lib_Entity : Entity_Id;
13004 Check_Ada_83_Warning;
13005 Check_Valid_Library_Unit_Pragma;
13007 if Nkind (N) = N_Null_Statement then
13011 Lib_Entity := Find_Lib_Unit_Name;
13013 -- A pragma that applies to a Ghost entity becomes Ghost for the
13014 -- purposes of legality checks and removal of ignored Ghost code.
13016 Mark_Ghost_Pragma (N, Lib_Entity);
13018 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
13020 if Present (Lib_Entity) and then not Debug_Flag_U then
13021 if not Is_Remote_Call_Interface (Lib_Entity) then
13022 Error_Pragma ("pragma% only apply to rci unit");
13024 -- Set flag for entity of the library unit
13027 Set_Has_All_Calls_Remote (Lib_Entity);
13030 end All_Calls_Remote;
13032 ---------------------------
13033 -- Allow_Integer_Address --
13034 ---------------------------
13036 -- pragma Allow_Integer_Address;
13038 when Pragma_Allow_Integer_Address =>
13040 Check_Valid_Configuration_Pragma;
13041 Check_Arg_Count (0);
13043 -- If Address is a private type, then set the flag to allow
13044 -- integer address values. If Address is not private, then this
13045 -- pragma has no purpose, so it is simply ignored. Not clear if
13046 -- there are any such targets now.
13048 if Opt.Address_Is_Private then
13049 Opt.Allow_Integer_Address := True;
13057 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
13058 -- ARG ::= NAME | EXPRESSION
13060 -- The first two arguments are by convention intended to refer to an
13061 -- external tool and a tool-specific function. These arguments are
13064 when Pragma_Annotate => Annotate : declare
13071 Check_At_Least_N_Arguments (1);
13073 Nam_Arg := Last (Pragma_Argument_Associations (N));
13075 -- Determine whether the last argument is "Entity => local_NAME"
13076 -- and if it is, perform the required semantic checks. Remove the
13077 -- argument from further processing.
13079 if Nkind (Nam_Arg) = N_Pragma_Argument_Association
13080 and then Chars (Nam_Arg) = Name_Entity
13082 Check_Arg_Is_Local_Name (Nam_Arg);
13083 Arg_Count := Arg_Count - 1;
13085 -- A pragma that applies to a Ghost entity becomes Ghost for
13086 -- the purposes of legality checks and removal of ignored Ghost
13089 if Is_Entity_Name (Get_Pragma_Arg (Nam_Arg))
13090 and then Present (Entity (Get_Pragma_Arg (Nam_Arg)))
13092 Mark_Ghost_Pragma (N, Entity (Get_Pragma_Arg (Nam_Arg)));
13095 -- Not allowed in compiler units (bootstrap issues)
13097 Check_Compiler_Unit ("Entity for pragma Annotate", N);
13100 -- Continue the processing with last argument removed for now
13102 Check_Arg_Is_Identifier (Arg1);
13103 Check_No_Identifiers;
13106 -- The second parameter is optional, it is never analyzed
13111 -- Otherwise there is a second parameter
13114 -- The second parameter must be an identifier
13116 Check_Arg_Is_Identifier (Arg2);
13118 -- Process the remaining parameters (if any)
13120 Arg := Next (Arg2);
13121 while Present (Arg) loop
13122 Expr := Get_Pragma_Arg (Arg);
13125 if Is_Entity_Name (Expr) then
13128 -- For string literals, we assume Standard_String as the
13129 -- type, unless the string contains wide or wide_wide
13132 elsif Nkind (Expr) = N_String_Literal then
13133 if Has_Wide_Wide_Character (Expr) then
13134 Resolve (Expr, Standard_Wide_Wide_String);
13135 elsif Has_Wide_Character (Expr) then
13136 Resolve (Expr, Standard_Wide_String);
13138 Resolve (Expr, Standard_String);
13141 elsif Is_Overloaded (Expr) then
13142 Error_Pragma_Arg ("ambiguous argument for pragma%", Expr);
13153 -------------------------------------------------
13154 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
13155 -------------------------------------------------
13158 -- ( [Check => ] Boolean_EXPRESSION
13159 -- [, [Message =>] Static_String_EXPRESSION]);
13161 -- pragma Assert_And_Cut
13162 -- ( [Check => ] Boolean_EXPRESSION
13163 -- [, [Message =>] Static_String_EXPRESSION]);
13166 -- ( [Check => ] Boolean_EXPRESSION
13167 -- [, [Message =>] Static_String_EXPRESSION]);
13169 -- pragma Loop_Invariant
13170 -- ( [Check => ] Boolean_EXPRESSION
13171 -- [, [Message =>] Static_String_EXPRESSION]);
13174 | Pragma_Assert_And_Cut
13176 | Pragma_Loop_Invariant
13179 function Contains_Loop_Entry (Expr : Node_Id) return Boolean;
13180 -- Determine whether expression Expr contains a Loop_Entry
13181 -- attribute reference.
13183 -------------------------
13184 -- Contains_Loop_Entry --
13185 -------------------------
13187 function Contains_Loop_Entry (Expr : Node_Id) return Boolean is
13188 Has_Loop_Entry : Boolean := False;
13190 function Process (N : Node_Id) return Traverse_Result;
13191 -- Process function for traversal to look for Loop_Entry
13197 function Process (N : Node_Id) return Traverse_Result is
13199 if Nkind (N) = N_Attribute_Reference
13200 and then Attribute_Name (N) = Name_Loop_Entry
13202 Has_Loop_Entry := True;
13209 procedure Traverse is new Traverse_Proc (Process);
13211 -- Start of processing for Contains_Loop_Entry
13215 return Has_Loop_Entry;
13216 end Contains_Loop_Entry;
13221 New_Args : List_Id;
13223 -- Start of processing for Assert
13226 -- Assert is an Ada 2005 RM-defined pragma
13228 if Prag_Id = Pragma_Assert then
13231 -- The remaining ones are GNAT pragmas
13237 Check_At_Least_N_Arguments (1);
13238 Check_At_Most_N_Arguments (2);
13239 Check_Arg_Order ((Name_Check, Name_Message));
13240 Check_Optional_Identifier (Arg1, Name_Check);
13241 Expr := Get_Pragma_Arg (Arg1);
13243 -- Special processing for Loop_Invariant, Loop_Variant or for
13244 -- other cases where a Loop_Entry attribute is present. If the
13245 -- assertion pragma contains attribute Loop_Entry, ensure that
13246 -- the related pragma is within a loop.
13248 if Prag_Id = Pragma_Loop_Invariant
13249 or else Prag_Id = Pragma_Loop_Variant
13250 or else Contains_Loop_Entry (Expr)
13252 Check_Loop_Pragma_Placement;
13254 -- Perform preanalysis to deal with embedded Loop_Entry
13257 Preanalyze_Assert_Expression (Expr, Any_Boolean);
13260 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
13261 -- a corresponding Check pragma:
13263 -- pragma Check (name, condition [, msg]);
13265 -- Where name is the identifier matching the pragma name. So
13266 -- rewrite pragma in this manner, transfer the message argument
13267 -- if present, and analyze the result
13269 -- Note: When dealing with a semantically analyzed tree, the
13270 -- information that a Check node N corresponds to a source Assert,
13271 -- Assume, or Assert_And_Cut pragma can be retrieved from the
13272 -- pragma kind of Original_Node(N).
13274 New_Args := New_List (
13275 Make_Pragma_Argument_Association (Loc,
13276 Expression => Make_Identifier (Loc, Pname)),
13277 Make_Pragma_Argument_Association (Sloc (Expr),
13278 Expression => Expr));
13280 if Arg_Count > 1 then
13281 Check_Optional_Identifier (Arg2, Name_Message);
13283 -- Provide semantic annnotations for optional argument, for
13284 -- ASIS use, before rewriting.
13286 Preanalyze_And_Resolve (Expression (Arg2), Standard_String);
13287 Append_To (New_Args, New_Copy_Tree (Arg2));
13290 -- Rewrite as Check pragma
13294 Chars => Name_Check,
13295 Pragma_Argument_Associations => New_Args));
13300 ----------------------
13301 -- Assertion_Policy --
13302 ----------------------
13304 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
13306 -- The following form is Ada 2012 only, but we allow it in all modes
13308 -- Pragma Assertion_Policy (
13309 -- ASSERTION_KIND => POLICY_IDENTIFIER
13310 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
13312 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
13314 -- RM_ASSERTION_KIND ::= Assert |
13315 -- Static_Predicate |
13316 -- Dynamic_Predicate |
13321 -- Type_Invariant |
13322 -- Type_Invariant'Class
13324 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
13326 -- Contract_Cases |
13328 -- Default_Initial_Condition |
13330 -- Initial_Condition |
13331 -- Loop_Invariant |
13337 -- Statement_Assertions
13339 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
13340 -- ID_ASSERTION_KIND list contains implementation-defined additions
13341 -- recognized by GNAT. The effect is to control the behavior of
13342 -- identically named aspects and pragmas, depending on the specified
13343 -- policy identifier:
13345 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
13347 -- Note: Check and Ignore are language-defined. Disable is a GNAT
13348 -- implementation-defined addition that results in totally ignoring
13349 -- the corresponding assertion. If Disable is specified, then the
13350 -- argument of the assertion is not even analyzed. This is useful
13351 -- when the aspect/pragma argument references entities in a with'ed
13352 -- package that is replaced by a dummy package in the final build.
13354 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
13355 -- and Type_Invariant'Class were recognized by the parser and
13356 -- transformed into references to the special internal identifiers
13357 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
13358 -- processing is required here.
13360 when Pragma_Assertion_Policy => Assertion_Policy : declare
13361 procedure Resolve_Suppressible (Policy : Node_Id);
13362 -- Converts the assertion policy 'Suppressible' to either Check or
13363 -- Ignore based on whether checks are suppressed via -gnatp.
13365 --------------------------
13366 -- Resolve_Suppressible --
13367 --------------------------
13369 procedure Resolve_Suppressible (Policy : Node_Id) is
13370 Arg : constant Node_Id := Get_Pragma_Arg (Policy);
13374 -- Transform policy argument Suppressible into either Ignore or
13375 -- Check depending on whether checks are enabled or suppressed.
13377 if Chars (Arg) = Name_Suppressible then
13378 if Suppress_Checks then
13379 Nam := Name_Ignore;
13384 Rewrite (Arg, Make_Identifier (Sloc (Arg), Nam));
13386 end Resolve_Suppressible;
13398 -- This can always appear as a configuration pragma
13400 if Is_Configuration_Pragma then
13403 -- It can also appear in a declarative part or package spec in Ada
13404 -- 2012 mode. We allow this in other modes, but in that case we
13405 -- consider that we have an Ada 2012 pragma on our hands.
13408 Check_Is_In_Decl_Part_Or_Package_Spec;
13412 -- One argument case with no identifier (first form above)
13415 and then (Nkind (Arg1) /= N_Pragma_Argument_Association
13416 or else Chars (Arg1) = No_Name)
13418 Check_Arg_Is_One_Of (Arg1,
13419 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
13421 Resolve_Suppressible (Arg1);
13423 -- Treat one argument Assertion_Policy as equivalent to:
13425 -- pragma Check_Policy (Assertion, policy)
13427 -- So rewrite pragma in that manner and link on to the chain
13428 -- of Check_Policy pragmas, marking the pragma as analyzed.
13430 Policy := Get_Pragma_Arg (Arg1);
13434 Chars => Name_Check_Policy,
13435 Pragma_Argument_Associations => New_List (
13436 Make_Pragma_Argument_Association (Loc,
13437 Expression => Make_Identifier (Loc, Name_Assertion)),
13439 Make_Pragma_Argument_Association (Loc,
13441 Make_Identifier (Sloc (Policy), Chars (Policy))))));
13444 -- Here if we have two or more arguments
13447 Check_At_Least_N_Arguments (1);
13450 -- Loop through arguments
13453 while Present (Arg) loop
13454 LocP := Sloc (Arg);
13456 -- Kind must be specified
13458 if Nkind (Arg) /= N_Pragma_Argument_Association
13459 or else Chars (Arg) = No_Name
13462 ("missing assertion kind for pragma%", Arg);
13465 -- Check Kind and Policy have allowed forms
13467 Kind := Chars (Arg);
13468 Policy := Get_Pragma_Arg (Arg);
13470 if not Is_Valid_Assertion_Kind (Kind) then
13472 ("invalid assertion kind for pragma%", Arg);
13475 Check_Arg_Is_One_Of (Arg,
13476 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
13478 Resolve_Suppressible (Arg);
13480 if Kind = Name_Ghost then
13482 -- The Ghost policy must be either Check or Ignore
13483 -- (SPARK RM 6.9(6)).
13485 if not Nam_In (Chars (Policy), Name_Check,
13489 ("argument of pragma % Ghost must be Check or "
13490 & "Ignore", Policy);
13493 -- Pragma Assertion_Policy specifying a Ghost policy
13494 -- cannot occur within a Ghost subprogram or package
13495 -- (SPARK RM 6.9(14)).
13497 if Ghost_Mode > None then
13499 ("pragma % cannot appear within ghost subprogram or "
13504 -- Rewrite the Assertion_Policy pragma as a series of
13505 -- Check_Policy pragmas of the form:
13507 -- Check_Policy (Kind, Policy);
13509 -- Note: the insertion of the pragmas cannot be done with
13510 -- Insert_Action because in the configuration case, there
13511 -- are no scopes on the scope stack and the mechanism will
13514 Insert_Before_And_Analyze (N,
13516 Chars => Name_Check_Policy,
13517 Pragma_Argument_Associations => New_List (
13518 Make_Pragma_Argument_Association (LocP,
13519 Expression => Make_Identifier (LocP, Kind)),
13520 Make_Pragma_Argument_Association (LocP,
13521 Expression => Policy))));
13526 -- Rewrite the Assertion_Policy pragma as null since we have
13527 -- now inserted all the equivalent Check pragmas.
13529 Rewrite (N, Make_Null_Statement (Loc));
13532 end Assertion_Policy;
13534 ------------------------------
13535 -- Assume_No_Invalid_Values --
13536 ------------------------------
13538 -- pragma Assume_No_Invalid_Values (On | Off);
13540 when Pragma_Assume_No_Invalid_Values =>
13542 Check_Valid_Configuration_Pragma;
13543 Check_Arg_Count (1);
13544 Check_No_Identifiers;
13545 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
13547 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
13548 Assume_No_Invalid_Values := True;
13550 Assume_No_Invalid_Values := False;
13553 --------------------------
13554 -- Attribute_Definition --
13555 --------------------------
13557 -- pragma Attribute_Definition
13558 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
13559 -- [Entity =>] LOCAL_NAME,
13560 -- [Expression =>] EXPRESSION | NAME);
13562 when Pragma_Attribute_Definition => Attribute_Definition : declare
13563 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
13568 Check_Arg_Count (3);
13569 Check_Optional_Identifier (Arg1, "attribute");
13570 Check_Optional_Identifier (Arg2, "entity");
13571 Check_Optional_Identifier (Arg3, "expression");
13573 if Nkind (Attribute_Designator) /= N_Identifier then
13574 Error_Msg_N ("attribute name expected", Attribute_Designator);
13578 Check_Arg_Is_Local_Name (Arg2);
13580 -- If the attribute is not recognized, then issue a warning (not
13581 -- an error), and ignore the pragma.
13583 Aname := Chars (Attribute_Designator);
13585 if not Is_Attribute_Name (Aname) then
13586 Bad_Attribute (Attribute_Designator, Aname, Warn => True);
13590 -- Otherwise, rewrite the pragma as an attribute definition clause
13593 Make_Attribute_Definition_Clause (Loc,
13594 Name => Get_Pragma_Arg (Arg2),
13596 Expression => Get_Pragma_Arg (Arg3)));
13598 end Attribute_Definition;
13600 ------------------------------------------------------------------
13601 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
13603 ------------------------------------------------------------------
13605 -- pragma Async_Readers [ (boolean_EXPRESSION) ];
13606 -- pragma Async_Writers [ (boolean_EXPRESSION) ];
13607 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
13608 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
13609 -- pragma No_Caching [ (boolean_EXPRESSION) ];
13611 when Pragma_Async_Readers
13612 | Pragma_Async_Writers
13613 | Pragma_Effective_Reads
13614 | Pragma_Effective_Writes
13615 | Pragma_No_Caching
13617 Async_Effective : declare
13618 Obj_Decl : Node_Id;
13619 Obj_Id : Entity_Id;
13623 Check_No_Identifiers;
13624 Check_At_Most_N_Arguments (1);
13626 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
13628 -- Object declaration
13630 if Nkind (Obj_Decl) /= N_Object_Declaration then
13635 Obj_Id := Defining_Entity (Obj_Decl);
13637 -- Perform minimal verification to ensure that the argument is at
13638 -- least a variable. Subsequent finer grained checks will be done
13639 -- at the end of the declarative region the contains the pragma.
13641 if Ekind (Obj_Id) = E_Variable then
13643 -- A pragma that applies to a Ghost entity becomes Ghost for
13644 -- the purposes of legality checks and removal of ignored Ghost
13647 Mark_Ghost_Pragma (N, Obj_Id);
13649 -- Chain the pragma on the contract for further processing by
13650 -- Analyze_External_Property_In_Decl_Part.
13652 Add_Contract_Item (N, Obj_Id);
13654 -- Analyze the Boolean expression (if any)
13656 if Present (Arg1) then
13657 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
13660 -- Otherwise the external property applies to a constant
13663 Error_Pragma ("pragma % must apply to a volatile object");
13665 end Async_Effective;
13671 -- pragma Asynchronous (LOCAL_NAME);
13673 when Pragma_Asynchronous => Asynchronous : declare
13676 Formal : Entity_Id;
13681 procedure Process_Async_Pragma;
13682 -- Common processing for procedure and access-to-procedure case
13684 --------------------------
13685 -- Process_Async_Pragma --
13686 --------------------------
13688 procedure Process_Async_Pragma is
13691 Set_Is_Asynchronous (Nm);
13695 -- The formals should be of mode IN (RM E.4.1(6))
13698 while Present (S) loop
13699 Formal := Defining_Identifier (S);
13701 if Nkind (Formal) = N_Defining_Identifier
13702 and then Ekind (Formal) /= E_In_Parameter
13705 ("pragma% procedure can only have IN parameter",
13712 Set_Is_Asynchronous (Nm);
13713 end Process_Async_Pragma;
13715 -- Start of processing for pragma Asynchronous
13718 Check_Ada_83_Warning;
13719 Check_No_Identifiers;
13720 Check_Arg_Count (1);
13721 Check_Arg_Is_Local_Name (Arg1);
13723 if Debug_Flag_U then
13727 C_Ent := Cunit_Entity (Current_Sem_Unit);
13728 Analyze (Get_Pragma_Arg (Arg1));
13729 Nm := Entity (Get_Pragma_Arg (Arg1));
13731 -- A pragma that applies to a Ghost entity becomes Ghost for the
13732 -- purposes of legality checks and removal of ignored Ghost code.
13734 Mark_Ghost_Pragma (N, Nm);
13736 if not Is_Remote_Call_Interface (C_Ent)
13737 and then not Is_Remote_Types (C_Ent)
13739 -- This pragma should only appear in an RCI or Remote Types
13740 -- unit (RM E.4.1(4)).
13743 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
13746 if Ekind (Nm) = E_Procedure
13747 and then Nkind (Parent (Nm)) = N_Procedure_Specification
13749 if not Is_Remote_Call_Interface (Nm) then
13751 ("pragma% cannot be applied on non-remote procedure",
13755 L := Parameter_Specifications (Parent (Nm));
13756 Process_Async_Pragma;
13759 elsif Ekind (Nm) = E_Function then
13761 ("pragma% cannot be applied to function", Arg1);
13763 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
13764 if Is_Record_Type (Nm) then
13766 -- A record type that is the Equivalent_Type for a remote
13767 -- access-to-subprogram type.
13769 Decl := Declaration_Node (Corresponding_Remote_Type (Nm));
13772 -- A non-expanded RAS type (distribution is not enabled)
13774 Decl := Declaration_Node (Nm);
13777 if Nkind (Decl) = N_Full_Type_Declaration
13778 and then Nkind (Type_Definition (Decl)) =
13779 N_Access_Procedure_Definition
13781 L := Parameter_Specifications (Type_Definition (Decl));
13782 Process_Async_Pragma;
13784 if Is_Asynchronous (Nm)
13785 and then Expander_Active
13786 and then Get_PCS_Name /= Name_No_DSA
13788 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
13793 ("pragma% cannot reference access-to-function type",
13797 -- Only other possibility is Access-to-class-wide type
13799 elsif Is_Access_Type (Nm)
13800 and then Is_Class_Wide_Type (Designated_Type (Nm))
13802 Check_First_Subtype (Arg1);
13803 Set_Is_Asynchronous (Nm);
13804 if Expander_Active then
13805 RACW_Type_Is_Asynchronous (Nm);
13809 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
13817 -- pragma Atomic (LOCAL_NAME);
13819 when Pragma_Atomic =>
13820 Process_Atomic_Independent_Shared_Volatile;
13822 -----------------------
13823 -- Atomic_Components --
13824 -----------------------
13826 -- pragma Atomic_Components (array_LOCAL_NAME);
13828 -- This processing is shared by Volatile_Components
13830 when Pragma_Atomic_Components
13831 | Pragma_Volatile_Components
13833 Atomic_Components : declare
13840 Check_Ada_83_Warning;
13841 Check_No_Identifiers;
13842 Check_Arg_Count (1);
13843 Check_Arg_Is_Local_Name (Arg1);
13844 E_Id := Get_Pragma_Arg (Arg1);
13846 if Etype (E_Id) = Any_Type then
13850 E := Entity (E_Id);
13852 -- A pragma that applies to a Ghost entity becomes Ghost for the
13853 -- purposes of legality checks and removal of ignored Ghost code.
13855 Mark_Ghost_Pragma (N, E);
13856 Check_Duplicate_Pragma (E);
13858 if Rep_Item_Too_Early (E, N)
13860 Rep_Item_Too_Late (E, N)
13865 D := Declaration_Node (E);
13868 if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
13870 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
13871 and then Nkind (D) = N_Object_Declaration
13872 and then Nkind (Object_Definition (D)) =
13873 N_Constrained_Array_Definition)
13875 -- The flag is set on the object, or on the base type
13877 if Nkind (D) /= N_Object_Declaration then
13878 E := Base_Type (E);
13881 -- Atomic implies both Independent and Volatile
13883 if Prag_Id = Pragma_Atomic_Components then
13884 Set_Has_Atomic_Components (E);
13885 Set_Has_Independent_Components (E);
13888 Set_Has_Volatile_Components (E);
13891 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
13893 end Atomic_Components;
13895 --------------------
13896 -- Attach_Handler --
13897 --------------------
13899 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
13901 when Pragma_Attach_Handler =>
13902 Check_Ada_83_Warning;
13903 Check_No_Identifiers;
13904 Check_Arg_Count (2);
13906 if No_Run_Time_Mode then
13907 Error_Msg_CRT ("Attach_Handler pragma", N);
13909 Check_Interrupt_Or_Attach_Handler;
13911 -- The expression that designates the attribute may depend on a
13912 -- discriminant, and is therefore a per-object expression, to
13913 -- be expanded in the init proc. If expansion is enabled, then
13914 -- perform semantic checks on a copy only.
13919 Parg2 : constant Node_Id := Get_Pragma_Arg (Arg2);
13922 -- In Relaxed_RM_Semantics mode, we allow any static
13923 -- integer value, for compatibility with other compilers.
13925 if Relaxed_RM_Semantics
13926 and then Nkind (Parg2) = N_Integer_Literal
13928 Typ := Standard_Integer;
13930 Typ := RTE (RE_Interrupt_ID);
13933 if Expander_Active then
13934 Temp := New_Copy_Tree (Parg2);
13935 Set_Parent (Temp, N);
13936 Preanalyze_And_Resolve (Temp, Typ);
13939 Resolve (Parg2, Typ);
13943 Process_Interrupt_Or_Attach_Handler;
13946 --------------------
13947 -- C_Pass_By_Copy --
13948 --------------------
13950 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
13952 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
13958 Check_Valid_Configuration_Pragma;
13959 Check_Arg_Count (1);
13960 Check_Optional_Identifier (Arg1, "max_size");
13962 Arg := Get_Pragma_Arg (Arg1);
13963 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
13965 Val := Expr_Value (Arg);
13969 ("maximum size for pragma% must be positive", Arg1);
13971 elsif UI_Is_In_Int_Range (Val) then
13972 Default_C_Record_Mechanism := UI_To_Int (Val);
13974 -- If a giant value is given, Int'Last will do well enough.
13975 -- If sometime someone complains that a record larger than
13976 -- two gigabytes is not copied, we will worry about it then.
13979 Default_C_Record_Mechanism := Mechanism_Type'Last;
13981 end C_Pass_By_Copy;
13987 -- pragma Check ([Name =>] CHECK_KIND,
13988 -- [Check =>] Boolean_EXPRESSION
13989 -- [,[Message =>] String_EXPRESSION]);
13991 -- CHECK_KIND ::= IDENTIFIER |
13994 -- Invariant'Class |
13995 -- Type_Invariant'Class
13997 -- The identifiers Assertions and Statement_Assertions are not
13998 -- allowed, since they have special meaning for Check_Policy.
14000 -- WARNING: The code below manages Ghost regions. Return statements
14001 -- must be replaced by gotos which jump to the end of the code and
14002 -- restore the Ghost mode.
14004 when Pragma_Check => Check : declare
14005 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
14006 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
14007 -- Save the Ghost-related attributes to restore on exit
14013 pragma Warnings (Off, Str);
14016 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
14017 -- the mode now to ensure that any nodes generated during analysis
14018 -- and expansion are marked as Ghost.
14020 Set_Ghost_Mode (N);
14023 Check_At_Least_N_Arguments (2);
14024 Check_At_Most_N_Arguments (3);
14025 Check_Optional_Identifier (Arg1, Name_Name);
14026 Check_Optional_Identifier (Arg2, Name_Check);
14028 if Arg_Count = 3 then
14029 Check_Optional_Identifier (Arg3, Name_Message);
14030 Str := Get_Pragma_Arg (Arg3);
14033 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
14034 Check_Arg_Is_Identifier (Arg1);
14035 Cname := Chars (Get_Pragma_Arg (Arg1));
14037 -- Check forbidden name Assertions or Statement_Assertions
14040 when Name_Assertions =>
14042 ("""Assertions"" is not allowed as a check kind for "
14043 & "pragma%", Arg1);
14045 when Name_Statement_Assertions =>
14047 ("""Statement_Assertions"" is not allowed as a check kind "
14048 & "for pragma%", Arg1);
14054 -- Check applicable policy. We skip this if Checked/Ignored status
14055 -- is already set (e.g. in the case of a pragma from an aspect).
14057 if Is_Checked (N) or else Is_Ignored (N) then
14060 -- For a non-source pragma that is a rewriting of another pragma,
14061 -- copy the Is_Checked/Ignored status from the rewritten pragma.
14063 elsif Is_Rewrite_Substitution (N)
14064 and then Nkind (Original_Node (N)) = N_Pragma
14066 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
14067 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
14069 -- Otherwise query the applicable policy at this point
14072 case Check_Kind (Cname) is
14073 when Name_Ignore =>
14074 Set_Is_Ignored (N, True);
14075 Set_Is_Checked (N, False);
14078 Set_Is_Ignored (N, False);
14079 Set_Is_Checked (N, True);
14081 -- For disable, rewrite pragma as null statement and skip
14082 -- rest of the analysis of the pragma.
14084 when Name_Disable =>
14085 Rewrite (N, Make_Null_Statement (Loc));
14089 -- No other possibilities
14092 raise Program_Error;
14096 -- If check kind was not Disable, then continue pragma analysis
14098 Expr := Get_Pragma_Arg (Arg2);
14100 -- Mark the pragma (or, if rewritten from an aspect, the original
14101 -- aspect) as enabled. Nothing to do for an internally generated
14102 -- check for a dynamic predicate.
14105 and then not Split_PPC (N)
14106 and then Cname /= Name_Dynamic_Predicate
14108 Set_SCO_Pragma_Enabled (Loc);
14111 -- Deal with analyzing the string argument. If checks are not
14112 -- on we don't want any expansion (since such expansion would
14113 -- not get properly deleted) but we do want to analyze (to get
14114 -- proper references). The Preanalyze_And_Resolve routine does
14115 -- just what we want. Ditto if pragma is active, because it will
14116 -- be rewritten as an if-statement whose analysis will complete
14117 -- analysis and expansion of the string message. This makes a
14118 -- difference in the unusual case where the expression for the
14119 -- string may have a side effect, such as raising an exception.
14120 -- This is mandated by RM 11.4.2, which specifies that the string
14121 -- expression is only evaluated if the check fails and
14122 -- Assertion_Error is to be raised.
14124 if Arg_Count = 3 then
14125 Preanalyze_And_Resolve (Str, Standard_String);
14128 -- Now you might think we could just do the same with the Boolean
14129 -- expression if checks are off (and expansion is on) and then
14130 -- rewrite the check as a null statement. This would work but we
14131 -- would lose the useful warnings about an assertion being bound
14132 -- to fail even if assertions are turned off.
14134 -- So instead we wrap the boolean expression in an if statement
14135 -- that looks like:
14137 -- if False and then condition then
14141 -- The reason we do this rewriting during semantic analysis rather
14142 -- than as part of normal expansion is that we cannot analyze and
14143 -- expand the code for the boolean expression directly, or it may
14144 -- cause insertion of actions that would escape the attempt to
14145 -- suppress the check code.
14147 -- Note that the Sloc for the if statement corresponds to the
14148 -- argument condition, not the pragma itself. The reason for
14149 -- this is that we may generate a warning if the condition is
14150 -- False at compile time, and we do not want to delete this
14151 -- warning when we delete the if statement.
14153 if Expander_Active and Is_Ignored (N) then
14154 Eloc := Sloc (Expr);
14157 Make_If_Statement (Eloc,
14159 Make_And_Then (Eloc,
14160 Left_Opnd => Make_Identifier (Eloc, Name_False),
14161 Right_Opnd => Expr),
14162 Then_Statements => New_List (
14163 Make_Null_Statement (Eloc))));
14165 -- Now go ahead and analyze the if statement
14167 In_Assertion_Expr := In_Assertion_Expr + 1;
14169 -- One rather special treatment. If we are now in Eliminated
14170 -- overflow mode, then suppress overflow checking since we do
14171 -- not want to drag in the bignum stuff if we are in Ignore
14172 -- mode anyway. This is particularly important if we are using
14173 -- a configurable run time that does not support bignum ops.
14175 if Scope_Suppress.Overflow_Mode_Assertions = Eliminated then
14177 Svo : constant Boolean :=
14178 Scope_Suppress.Suppress (Overflow_Check);
14180 Scope_Suppress.Overflow_Mode_Assertions := Strict;
14181 Scope_Suppress.Suppress (Overflow_Check) := True;
14183 Scope_Suppress.Suppress (Overflow_Check) := Svo;
14184 Scope_Suppress.Overflow_Mode_Assertions := Eliminated;
14187 -- Not that special case
14193 -- All done with this check
14195 In_Assertion_Expr := In_Assertion_Expr - 1;
14197 -- Check is active or expansion not active. In these cases we can
14198 -- just go ahead and analyze the boolean with no worries.
14201 In_Assertion_Expr := In_Assertion_Expr + 1;
14202 Analyze_And_Resolve (Expr, Any_Boolean);
14203 In_Assertion_Expr := In_Assertion_Expr - 1;
14206 Restore_Ghost_Region (Saved_GM, Saved_IGR);
14209 --------------------------
14210 -- Check_Float_Overflow --
14211 --------------------------
14213 -- pragma Check_Float_Overflow;
14215 when Pragma_Check_Float_Overflow =>
14217 Check_Valid_Configuration_Pragma;
14218 Check_Arg_Count (0);
14219 Check_Float_Overflow := not Machine_Overflows_On_Target;
14225 -- pragma Check_Name (check_IDENTIFIER);
14227 when Pragma_Check_Name =>
14229 Check_No_Identifiers;
14230 Check_Valid_Configuration_Pragma;
14231 Check_Arg_Count (1);
14232 Check_Arg_Is_Identifier (Arg1);
14235 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
14238 for J in Check_Names.First .. Check_Names.Last loop
14239 if Check_Names.Table (J) = Nam then
14244 Check_Names.Append (Nam);
14251 -- This is the old style syntax, which is still allowed in all modes:
14253 -- pragma Check_Policy ([Name =>] CHECK_KIND
14254 -- [Policy =>] POLICY_IDENTIFIER);
14256 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
14258 -- CHECK_KIND ::= IDENTIFIER |
14261 -- Type_Invariant'Class |
14264 -- This is the new style syntax, compatible with Assertion_Policy
14265 -- and also allowed in all modes.
14267 -- Pragma Check_Policy (
14268 -- CHECK_KIND => POLICY_IDENTIFIER
14269 -- {, CHECK_KIND => POLICY_IDENTIFIER});
14271 -- Note: the identifiers Name and Policy are not allowed as
14272 -- Check_Kind values. This avoids ambiguities between the old and
14273 -- new form syntax.
14275 when Pragma_Check_Policy => Check_Policy : declare
14280 Check_At_Least_N_Arguments (1);
14282 -- A Check_Policy pragma can appear either as a configuration
14283 -- pragma, or in a declarative part or a package spec (see RM
14284 -- 11.5(5) for rules for Suppress/Unsuppress which are also
14285 -- followed for Check_Policy).
14287 if not Is_Configuration_Pragma then
14288 Check_Is_In_Decl_Part_Or_Package_Spec;
14291 -- Figure out if we have the old or new syntax. We have the
14292 -- old syntax if the first argument has no identifier, or the
14293 -- identifier is Name.
14295 if Nkind (Arg1) /= N_Pragma_Argument_Association
14296 or else Nam_In (Chars (Arg1), No_Name, Name_Name)
14300 Check_Arg_Count (2);
14301 Check_Optional_Identifier (Arg1, Name_Name);
14302 Kind := Get_Pragma_Arg (Arg1);
14303 Rewrite_Assertion_Kind (Kind,
14304 From_Policy => Comes_From_Source (N));
14305 Check_Arg_Is_Identifier (Arg1);
14307 -- Check forbidden check kind
14309 if Nam_In (Chars (Kind), Name_Name, Name_Policy) then
14310 Error_Msg_Name_2 := Chars (Kind);
14312 ("pragma% does not allow% as check name", Arg1);
14317 Check_Optional_Identifier (Arg2, Name_Policy);
14318 Check_Arg_Is_One_Of
14320 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
14322 -- And chain pragma on the Check_Policy_List for search
14324 Set_Next_Pragma (N, Opt.Check_Policy_List);
14325 Opt.Check_Policy_List := N;
14327 -- For the new syntax, what we do is to convert each argument to
14328 -- an old syntax equivalent. We do that because we want to chain
14329 -- old style Check_Policy pragmas for the search (we don't want
14330 -- to have to deal with multiple arguments in the search).
14341 while Present (Arg) loop
14342 LocP := Sloc (Arg);
14343 Argx := Get_Pragma_Arg (Arg);
14345 -- Kind must be specified
14347 if Nkind (Arg) /= N_Pragma_Argument_Association
14348 or else Chars (Arg) = No_Name
14351 ("missing assertion kind for pragma%", Arg);
14354 -- Construct equivalent old form syntax Check_Policy
14355 -- pragma and insert it to get remaining checks.
14359 Chars => Name_Check_Policy,
14360 Pragma_Argument_Associations => New_List (
14361 Make_Pragma_Argument_Association (LocP,
14363 Make_Identifier (LocP, Chars (Arg))),
14364 Make_Pragma_Argument_Association (Sloc (Argx),
14365 Expression => Argx)));
14369 -- For a configuration pragma, insert old form in
14370 -- the corresponding file.
14372 if Is_Configuration_Pragma then
14373 Insert_After (N, New_P);
14377 Insert_Action (N, New_P);
14381 -- Rewrite original Check_Policy pragma to null, since we
14382 -- have converted it into a series of old syntax pragmas.
14384 Rewrite (N, Make_Null_Statement (Loc));
14394 -- pragma Comment (static_string_EXPRESSION)
14396 -- Processing for pragma Comment shares the circuitry for pragma
14397 -- Ident. The only differences are that Ident enforces a limit of 31
14398 -- characters on its argument, and also enforces limitations on
14399 -- placement for DEC compatibility. Pragma Comment shares neither of
14400 -- these restrictions.
14402 -------------------
14403 -- Common_Object --
14404 -------------------
14406 -- pragma Common_Object (
14407 -- [Internal =>] LOCAL_NAME
14408 -- [, [External =>] EXTERNAL_SYMBOL]
14409 -- [, [Size =>] EXTERNAL_SYMBOL]);
14411 -- Processing for this pragma is shared with Psect_Object
14413 ----------------------------------------------
14414 -- Compile_Time_Error, Compile_Time_Warning --
14415 ----------------------------------------------
14417 -- pragma Compile_Time_Error
14418 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14420 -- pragma Compile_Time_Warning
14421 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14423 when Pragma_Compile_Time_Error | Pragma_Compile_Time_Warning =>
14425 Process_Compile_Time_Warning_Or_Error;
14427 ---------------------------
14428 -- Compiler_Unit_Warning --
14429 ---------------------------
14431 -- pragma Compiler_Unit_Warning;
14435 -- Originally, we had only pragma Compiler_Unit, and it resulted in
14436 -- errors not warnings. This means that we had introduced a big extra
14437 -- inertia to compiler changes, since even if we implemented a new
14438 -- feature, and even if all versions to be used for bootstrapping
14439 -- implemented this new feature, we could not use it, since old
14440 -- compilers would give errors for using this feature in units
14441 -- having Compiler_Unit pragmas.
14443 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
14444 -- problem. We no longer have any units mentioning Compiler_Unit,
14445 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
14446 -- and thus generates a warning which can be ignored. So that deals
14447 -- with the problem of old compilers not implementing the newer form
14450 -- Newer compilers recognize the new pragma, but generate warning
14451 -- messages instead of errors, which again can be ignored in the
14452 -- case of an old compiler which implements a wanted new feature
14453 -- but at the time felt like warning about it for older compilers.
14455 -- We retain Compiler_Unit so that new compilers can be used to build
14456 -- older run-times that use this pragma. That's an unusual case, but
14457 -- it's easy enough to handle, so why not?
14459 when Pragma_Compiler_Unit
14460 | Pragma_Compiler_Unit_Warning
14463 Check_Arg_Count (0);
14465 -- Only recognized in main unit
14467 if Current_Sem_Unit = Main_Unit then
14468 Compiler_Unit := True;
14471 -----------------------------
14472 -- Complete_Representation --
14473 -----------------------------
14475 -- pragma Complete_Representation;
14477 when Pragma_Complete_Representation =>
14479 Check_Arg_Count (0);
14481 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
14483 ("pragma & must appear within record representation clause");
14486 ----------------------------
14487 -- Complex_Representation --
14488 ----------------------------
14490 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
14492 when Pragma_Complex_Representation => Complex_Representation : declare
14499 Check_Arg_Count (1);
14500 Check_Optional_Identifier (Arg1, Name_Entity);
14501 Check_Arg_Is_Local_Name (Arg1);
14502 E_Id := Get_Pragma_Arg (Arg1);
14504 if Etype (E_Id) = Any_Type then
14508 E := Entity (E_Id);
14510 if not Is_Record_Type (E) then
14512 ("argument for pragma% must be record type", Arg1);
14515 Ent := First_Entity (E);
14518 or else No (Next_Entity (Ent))
14519 or else Present (Next_Entity (Next_Entity (Ent)))
14520 or else not Is_Floating_Point_Type (Etype (Ent))
14521 or else Etype (Ent) /= Etype (Next_Entity (Ent))
14524 ("record for pragma% must have two fields of the same "
14525 & "floating-point type", Arg1);
14528 Set_Has_Complex_Representation (Base_Type (E));
14530 -- We need to treat the type has having a non-standard
14531 -- representation, for back-end purposes, even though in
14532 -- general a complex will have the default representation
14533 -- of a record with two real components.
14535 Set_Has_Non_Standard_Rep (Base_Type (E));
14537 end Complex_Representation;
14539 -------------------------
14540 -- Component_Alignment --
14541 -------------------------
14543 -- pragma Component_Alignment (
14544 -- [Form =>] ALIGNMENT_CHOICE
14545 -- [, [Name =>] type_LOCAL_NAME]);
14547 -- ALIGNMENT_CHOICE ::=
14549 -- | Component_Size_4
14553 when Pragma_Component_Alignment => Component_AlignmentP : declare
14554 Args : Args_List (1 .. 2);
14555 Names : constant Name_List (1 .. 2) := (
14559 Form : Node_Id renames Args (1);
14560 Name : Node_Id renames Args (2);
14562 Atype : Component_Alignment_Kind;
14567 Gather_Associations (Names, Args);
14570 Error_Pragma ("missing Form argument for pragma%");
14573 Check_Arg_Is_Identifier (Form);
14575 -- Get proper alignment, note that Default = Component_Size on all
14576 -- machines we have so far, and we want to set this value rather
14577 -- than the default value to indicate that it has been explicitly
14578 -- set (and thus will not get overridden by the default component
14579 -- alignment for the current scope)
14581 if Chars (Form) = Name_Component_Size then
14582 Atype := Calign_Component_Size;
14584 elsif Chars (Form) = Name_Component_Size_4 then
14585 Atype := Calign_Component_Size_4;
14587 elsif Chars (Form) = Name_Default then
14588 Atype := Calign_Component_Size;
14590 elsif Chars (Form) = Name_Storage_Unit then
14591 Atype := Calign_Storage_Unit;
14595 ("invalid Form parameter for pragma%", Form);
14598 -- The pragma appears in a configuration file
14600 if No (Parent (N)) then
14601 Check_Valid_Configuration_Pragma;
14603 -- Capture the component alignment in a global variable when
14604 -- the pragma appears in a configuration file. Note that the
14605 -- scope stack is empty at this point and cannot be used to
14606 -- store the alignment value.
14608 Configuration_Component_Alignment := Atype;
14610 -- Case with no name, supplied, affects scope table entry
14612 elsif No (Name) then
14614 (Scope_Stack.Last).Component_Alignment_Default := Atype;
14616 -- Case of name supplied
14619 Check_Arg_Is_Local_Name (Name);
14621 Typ := Entity (Name);
14624 or else Rep_Item_Too_Early (Typ, N)
14628 Typ := Underlying_Type (Typ);
14631 if not Is_Record_Type (Typ)
14632 and then not Is_Array_Type (Typ)
14635 ("Name parameter of pragma% must identify record or "
14636 & "array type", Name);
14639 -- An explicit Component_Alignment pragma overrides an
14640 -- implicit pragma Pack, but not an explicit one.
14642 if not Has_Pragma_Pack (Base_Type (Typ)) then
14643 Set_Is_Packed (Base_Type (Typ), False);
14644 Set_Component_Alignment (Base_Type (Typ), Atype);
14647 end Component_AlignmentP;
14649 --------------------------------
14650 -- Constant_After_Elaboration --
14651 --------------------------------
14653 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
14655 when Pragma_Constant_After_Elaboration => Constant_After_Elaboration :
14657 Obj_Decl : Node_Id;
14658 Obj_Id : Entity_Id;
14662 Check_No_Identifiers;
14663 Check_At_Most_N_Arguments (1);
14665 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
14667 if Nkind (Obj_Decl) /= N_Object_Declaration then
14672 Obj_Id := Defining_Entity (Obj_Decl);
14674 -- The object declaration must be a library-level variable which
14675 -- is either explicitly initialized or obtains a value during the
14676 -- elaboration of a package body (SPARK RM 3.3.1).
14678 if Ekind (Obj_Id) = E_Variable then
14679 if not Is_Library_Level_Entity (Obj_Id) then
14681 ("pragma % must apply to a library level variable");
14685 -- Otherwise the pragma applies to a constant, which is illegal
14688 Error_Pragma ("pragma % must apply to a variable declaration");
14692 -- A pragma that applies to a Ghost entity becomes Ghost for the
14693 -- purposes of legality checks and removal of ignored Ghost code.
14695 Mark_Ghost_Pragma (N, Obj_Id);
14697 -- Chain the pragma on the contract for completeness
14699 Add_Contract_Item (N, Obj_Id);
14701 -- Analyze the Boolean expression (if any)
14703 if Present (Arg1) then
14704 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
14706 end Constant_After_Elaboration;
14708 --------------------
14709 -- Contract_Cases --
14710 --------------------
14712 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
14714 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
14716 -- CASE_GUARD ::= boolean_EXPRESSION | others
14718 -- CONSEQUENCE ::= boolean_EXPRESSION
14720 -- Characteristics:
14722 -- * Analysis - The annotation undergoes initial checks to verify
14723 -- the legal placement and context. Secondary checks preanalyze the
14726 -- Analyze_Contract_Cases_In_Decl_Part
14728 -- * Expansion - The annotation is expanded during the expansion of
14729 -- the related subprogram [body] contract as performed in:
14731 -- Expand_Subprogram_Contract
14733 -- * Template - The annotation utilizes the generic template of the
14734 -- related subprogram [body] when it is:
14736 -- aspect on subprogram declaration
14737 -- aspect on stand-alone subprogram body
14738 -- pragma on stand-alone subprogram body
14740 -- The annotation must prepare its own template when it is:
14742 -- pragma on subprogram declaration
14744 -- * Globals - Capture of global references must occur after full
14747 -- * Instance - The annotation is instantiated automatically when
14748 -- the related generic subprogram [body] is instantiated except for
14749 -- the "pragma on subprogram declaration" case. In that scenario
14750 -- the annotation must instantiate itself.
14752 when Pragma_Contract_Cases => Contract_Cases : declare
14753 Spec_Id : Entity_Id;
14754 Subp_Decl : Node_Id;
14755 Subp_Spec : Node_Id;
14759 Check_No_Identifiers;
14760 Check_Arg_Count (1);
14762 -- Ensure the proper placement of the pragma. Contract_Cases must
14763 -- be associated with a subprogram declaration or a body that acts
14767 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
14771 if Nkind (Subp_Decl) = N_Entry_Declaration then
14774 -- Generic subprogram
14776 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
14779 -- Body acts as spec
14781 elsif Nkind (Subp_Decl) = N_Subprogram_Body
14782 and then No (Corresponding_Spec (Subp_Decl))
14786 -- Body stub acts as spec
14788 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
14789 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
14795 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
14796 Subp_Spec := Specification (Subp_Decl);
14798 -- Pragma Contract_Cases is forbidden on null procedures, as
14799 -- this may lead to potential ambiguities in behavior when
14800 -- interface null procedures are involved.
14802 if Nkind (Subp_Spec) = N_Procedure_Specification
14803 and then Null_Present (Subp_Spec)
14805 Error_Msg_N (Fix_Error
14806 ("pragma % cannot apply to null procedure"), N);
14815 Spec_Id := Unique_Defining_Entity (Subp_Decl);
14817 -- A pragma that applies to a Ghost entity becomes Ghost for the
14818 -- purposes of legality checks and removal of ignored Ghost code.
14820 Mark_Ghost_Pragma (N, Spec_Id);
14821 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
14823 -- Chain the pragma on the contract for further processing by
14824 -- Analyze_Contract_Cases_In_Decl_Part.
14826 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
14828 -- Fully analyze the pragma when it appears inside an entry
14829 -- or subprogram body because it cannot benefit from forward
14832 if Nkind_In (Subp_Decl, N_Entry_Body,
14834 N_Subprogram_Body_Stub)
14836 -- The legality checks of pragma Contract_Cases are affected by
14837 -- the SPARK mode in effect and the volatility of the context.
14838 -- Analyze all pragmas in a specific order.
14840 Analyze_If_Present (Pragma_SPARK_Mode);
14841 Analyze_If_Present (Pragma_Volatile_Function);
14842 Analyze_Contract_Cases_In_Decl_Part (N);
14844 end Contract_Cases;
14850 -- pragma Controlled (first_subtype_LOCAL_NAME);
14852 when Pragma_Controlled => Controlled : declare
14856 Check_No_Identifiers;
14857 Check_Arg_Count (1);
14858 Check_Arg_Is_Local_Name (Arg1);
14859 Arg := Get_Pragma_Arg (Arg1);
14861 if not Is_Entity_Name (Arg)
14862 or else not Is_Access_Type (Entity (Arg))
14864 Error_Pragma_Arg ("pragma% requires access type", Arg1);
14866 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
14874 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
14875 -- [Entity =>] LOCAL_NAME);
14877 when Pragma_Convention => Convention : declare
14880 pragma Warnings (Off, C);
14881 pragma Warnings (Off, E);
14884 Check_Arg_Order ((Name_Convention, Name_Entity));
14885 Check_Ada_83_Warning;
14886 Check_Arg_Count (2);
14887 Process_Convention (C, E);
14889 -- A pragma that applies to a Ghost entity becomes Ghost for the
14890 -- purposes of legality checks and removal of ignored Ghost code.
14892 Mark_Ghost_Pragma (N, E);
14895 ---------------------------
14896 -- Convention_Identifier --
14897 ---------------------------
14899 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
14900 -- [Convention =>] convention_IDENTIFIER);
14902 when Pragma_Convention_Identifier => Convention_Identifier : declare
14908 Check_Arg_Order ((Name_Name, Name_Convention));
14909 Check_Arg_Count (2);
14910 Check_Optional_Identifier (Arg1, Name_Name);
14911 Check_Optional_Identifier (Arg2, Name_Convention);
14912 Check_Arg_Is_Identifier (Arg1);
14913 Check_Arg_Is_Identifier (Arg2);
14914 Idnam := Chars (Get_Pragma_Arg (Arg1));
14915 Cname := Chars (Get_Pragma_Arg (Arg2));
14917 if Is_Convention_Name (Cname) then
14918 Record_Convention_Identifier
14919 (Idnam, Get_Convention_Id (Cname));
14922 ("second arg for % pragma must be convention", Arg2);
14924 end Convention_Identifier;
14930 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
14932 when Pragma_CPP_Class =>
14935 if Warn_On_Obsolescent_Feature then
14937 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
14938 & "effect; replace it by pragma import?j?", N);
14941 Check_Arg_Count (1);
14945 Chars => Name_Import,
14946 Pragma_Argument_Associations => New_List (
14947 Make_Pragma_Argument_Association (Loc,
14948 Expression => Make_Identifier (Loc, Name_CPP)),
14949 New_Copy (First (Pragma_Argument_Associations (N))))));
14952 ---------------------
14953 -- CPP_Constructor --
14954 ---------------------
14956 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
14957 -- [, [External_Name =>] static_string_EXPRESSION ]
14958 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14960 when Pragma_CPP_Constructor => CPP_Constructor : declare
14963 Def_Id : Entity_Id;
14964 Tag_Typ : Entity_Id;
14968 Check_At_Least_N_Arguments (1);
14969 Check_At_Most_N_Arguments (3);
14970 Check_Optional_Identifier (Arg1, Name_Entity);
14971 Check_Arg_Is_Local_Name (Arg1);
14973 Id := Get_Pragma_Arg (Arg1);
14974 Find_Program_Unit_Name (Id);
14976 -- If we did not find the name, we are done
14978 if Etype (Id) = Any_Type then
14982 Def_Id := Entity (Id);
14984 -- Check if already defined as constructor
14986 if Is_Constructor (Def_Id) then
14988 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
14992 if Ekind (Def_Id) = E_Function
14993 and then (Is_CPP_Class (Etype (Def_Id))
14994 or else (Is_Class_Wide_Type (Etype (Def_Id))
14996 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
14998 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
15000 ("'C'P'P constructor must be defined in the scope of "
15001 & "its returned type", Arg1);
15004 if Arg_Count >= 2 then
15005 Set_Imported (Def_Id);
15006 Set_Is_Public (Def_Id);
15007 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
15010 Set_Has_Completion (Def_Id);
15011 Set_Is_Constructor (Def_Id);
15012 Set_Convention (Def_Id, Convention_CPP);
15014 -- Imported C++ constructors are not dispatching primitives
15015 -- because in C++ they don't have a dispatch table slot.
15016 -- However, in Ada the constructor has the profile of a
15017 -- function that returns a tagged type and therefore it has
15018 -- been treated as a primitive operation during semantic
15019 -- analysis. We now remove it from the list of primitive
15020 -- operations of the type.
15022 if Is_Tagged_Type (Etype (Def_Id))
15023 and then not Is_Class_Wide_Type (Etype (Def_Id))
15024 and then Is_Dispatching_Operation (Def_Id)
15026 Tag_Typ := Etype (Def_Id);
15028 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
15029 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
15033 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
15034 Set_Is_Dispatching_Operation (Def_Id, False);
15037 -- For backward compatibility, if the constructor returns a
15038 -- class wide type, and we internally change the return type to
15039 -- the corresponding root type.
15041 if Is_Class_Wide_Type (Etype (Def_Id)) then
15042 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
15046 ("pragma% requires function returning a 'C'P'P_Class type",
15049 end CPP_Constructor;
15055 when Pragma_CPP_Virtual =>
15058 if Warn_On_Obsolescent_Feature then
15060 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
15068 when Pragma_CPP_Vtable =>
15071 if Warn_On_Obsolescent_Feature then
15073 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
15081 -- pragma CPU (EXPRESSION);
15083 when Pragma_CPU => CPU : declare
15084 P : constant Node_Id := Parent (N);
15090 Check_No_Identifiers;
15091 Check_Arg_Count (1);
15095 if Nkind (P) = N_Subprogram_Body then
15096 Check_In_Main_Program;
15098 Arg := Get_Pragma_Arg (Arg1);
15099 Analyze_And_Resolve (Arg, Any_Integer);
15101 Ent := Defining_Unit_Name (Specification (P));
15103 if Nkind (Ent) = N_Defining_Program_Unit_Name then
15104 Ent := Defining_Identifier (Ent);
15109 if not Is_OK_Static_Expression (Arg) then
15110 Flag_Non_Static_Expr
15111 ("main subprogram affinity is not static!", Arg);
15114 -- If constraint error, then we already signalled an error
15116 elsif Raises_Constraint_Error (Arg) then
15119 -- Otherwise check in range
15123 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
15124 -- This is the entity System.Multiprocessors.CPU_Range;
15126 Val : constant Uint := Expr_Value (Arg);
15129 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
15131 Val > Expr_Value (Type_High_Bound (CPU_Id))
15134 ("main subprogram CPU is out of range", Arg1);
15140 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
15144 elsif Nkind (P) = N_Task_Definition then
15145 Arg := Get_Pragma_Arg (Arg1);
15146 Ent := Defining_Identifier (Parent (P));
15148 -- The expression must be analyzed in the special manner
15149 -- described in "Handling of Default and Per-Object
15150 -- Expressions" in sem.ads.
15152 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
15154 -- Anything else is incorrect
15160 -- Check duplicate pragma before we chain the pragma in the Rep
15161 -- Item chain of Ent.
15163 Check_Duplicate_Pragma (Ent);
15164 Record_Rep_Item (Ent, N);
15167 --------------------
15168 -- Deadline_Floor --
15169 --------------------
15171 -- pragma Deadline_Floor (time_span_EXPRESSION);
15173 when Pragma_Deadline_Floor => Deadline_Floor : declare
15174 P : constant Node_Id := Parent (N);
15180 Check_No_Identifiers;
15181 Check_Arg_Count (1);
15183 Arg := Get_Pragma_Arg (Arg1);
15185 -- The expression must be analyzed in the special manner described
15186 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
15188 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
15190 -- Only protected types allowed
15192 if Nkind (P) /= N_Protected_Definition then
15196 Ent := Defining_Identifier (Parent (P));
15198 -- Check duplicate pragma before we chain the pragma in the Rep
15199 -- Item chain of Ent.
15201 Check_Duplicate_Pragma (Ent);
15202 Record_Rep_Item (Ent, N);
15204 end Deadline_Floor;
15210 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
15212 when Pragma_Debug => Debug : declare
15219 -- The condition for executing the call is that the expander
15220 -- is active and that we are not ignoring this debug pragma.
15225 (Expander_Active and then not Is_Ignored (N)),
15228 if not Is_Ignored (N) then
15229 Set_SCO_Pragma_Enabled (Loc);
15232 if Arg_Count = 2 then
15234 Make_And_Then (Loc,
15235 Left_Opnd => Relocate_Node (Cond),
15236 Right_Opnd => Get_Pragma_Arg (Arg1));
15237 Call := Get_Pragma_Arg (Arg2);
15239 Call := Get_Pragma_Arg (Arg1);
15242 if Nkind_In (Call, N_Expanded_Name,
15245 N_Indexed_Component,
15246 N_Selected_Component)
15248 -- If this pragma Debug comes from source, its argument was
15249 -- parsed as a name form (which is syntactically identical).
15250 -- In a generic context a parameterless call will be left as
15251 -- an expanded name (if global) or selected_component if local.
15252 -- Change it to a procedure call statement now.
15254 Change_Name_To_Procedure_Call_Statement (Call);
15256 elsif Nkind (Call) = N_Procedure_Call_Statement then
15258 -- Already in the form of a procedure call statement: nothing
15259 -- to do (could happen in case of an internally generated
15265 -- All other cases: diagnose error
15268 ("argument of pragma ""Debug"" is not procedure call",
15273 -- Rewrite into a conditional with an appropriate condition. We
15274 -- wrap the procedure call in a block so that overhead from e.g.
15275 -- use of the secondary stack does not generate execution overhead
15276 -- for suppressed conditions.
15278 -- Normally the analysis that follows will freeze the subprogram
15279 -- being called. However, if the call is to a null procedure,
15280 -- we want to freeze it before creating the block, because the
15281 -- analysis that follows may be done with expansion disabled, in
15282 -- which case the body will not be generated, leading to spurious
15285 if Nkind (Call) = N_Procedure_Call_Statement
15286 and then Is_Entity_Name (Name (Call))
15288 Analyze (Name (Call));
15289 Freeze_Before (N, Entity (Name (Call)));
15293 Make_Implicit_If_Statement (N,
15295 Then_Statements => New_List (
15296 Make_Block_Statement (Loc,
15297 Handled_Statement_Sequence =>
15298 Make_Handled_Sequence_Of_Statements (Loc,
15299 Statements => New_List (Relocate_Node (Call)))))));
15302 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
15303 -- after analysis of the normally rewritten node, to capture all
15304 -- references to entities, which avoids issuing wrong warnings
15305 -- about unused entities.
15307 if GNATprove_Mode then
15308 Rewrite (N, Make_Null_Statement (Loc));
15316 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
15318 when Pragma_Debug_Policy =>
15320 Check_Arg_Count (1);
15321 Check_No_Identifiers;
15322 Check_Arg_Is_Identifier (Arg1);
15324 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
15325 -- rewrite it that way, and let the rest of the checking come
15326 -- from analyzing the rewritten pragma.
15330 Chars => Name_Check_Policy,
15331 Pragma_Argument_Associations => New_List (
15332 Make_Pragma_Argument_Association (Loc,
15333 Expression => Make_Identifier (Loc, Name_Debug)),
15335 Make_Pragma_Argument_Association (Loc,
15336 Expression => Get_Pragma_Arg (Arg1)))));
15339 -------------------------------
15340 -- Default_Initial_Condition --
15341 -------------------------------
15343 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
15345 when Pragma_Default_Initial_Condition => DIC : declare
15352 Check_No_Identifiers;
15353 Check_At_Most_N_Arguments (1);
15357 while Present (Stmt) loop
15359 -- Skip prior pragmas, but check for duplicates
15361 if Nkind (Stmt) = N_Pragma then
15362 if Pragma_Name (Stmt) = Pname then
15369 -- Skip internally generated code. Note that derived type
15370 -- declarations of untagged types with discriminants are
15371 -- rewritten as private type declarations.
15373 elsif not Comes_From_Source (Stmt)
15374 and then Nkind (Stmt) /= N_Private_Type_Declaration
15378 -- The associated private type [extension] has been found, stop
15381 elsif Nkind_In (Stmt, N_Private_Extension_Declaration,
15382 N_Private_Type_Declaration)
15384 Typ := Defining_Entity (Stmt);
15387 -- The pragma does not apply to a legal construct, issue an
15388 -- error and stop the analysis.
15395 Stmt := Prev (Stmt);
15398 -- The pragma does not apply to a legal construct, issue an error
15399 -- and stop the analysis.
15406 -- A pragma that applies to a Ghost entity becomes Ghost for the
15407 -- purposes of legality checks and removal of ignored Ghost code.
15409 Mark_Ghost_Pragma (N, Typ);
15411 -- The pragma signals that the type defines its own DIC assertion
15414 Set_Has_Own_DIC (Typ);
15416 -- Chain the pragma on the rep item chain for further processing
15418 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
15420 -- Create the declaration of the procedure which verifies the
15421 -- assertion expression of pragma DIC at runtime.
15423 Build_DIC_Procedure_Declaration (Typ);
15426 ----------------------------------
15427 -- Default_Scalar_Storage_Order --
15428 ----------------------------------
15430 -- pragma Default_Scalar_Storage_Order
15431 -- (High_Order_First | Low_Order_First);
15433 when Pragma_Default_Scalar_Storage_Order => DSSO : declare
15434 Default : Character;
15438 Check_Arg_Count (1);
15440 -- Default_Scalar_Storage_Order can appear as a configuration
15441 -- pragma, or in a declarative part of a package spec.
15443 if not Is_Configuration_Pragma then
15444 Check_Is_In_Decl_Part_Or_Package_Spec;
15447 Check_No_Identifiers;
15448 Check_Arg_Is_One_Of
15449 (Arg1, Name_High_Order_First, Name_Low_Order_First);
15450 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
15451 Default := Fold_Upper (Name_Buffer (1));
15453 if not Support_Nondefault_SSO_On_Target
15454 and then (Ttypes.Bytes_Big_Endian /= (Default = 'H'))
15456 if Warn_On_Unrecognized_Pragma then
15458 ("non-default Scalar_Storage_Order not supported "
15459 & "on target?g?", N);
15461 ("\pragma Default_Scalar_Storage_Order ignored?g?", N);
15464 -- Here set the specified default
15467 Opt.Default_SSO := Default;
15471 --------------------------
15472 -- Default_Storage_Pool --
15473 --------------------------
15475 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
15477 when Pragma_Default_Storage_Pool => Default_Storage_Pool : declare
15482 Check_Arg_Count (1);
15484 -- Default_Storage_Pool can appear as a configuration pragma, or
15485 -- in a declarative part of a package spec.
15487 if not Is_Configuration_Pragma then
15488 Check_Is_In_Decl_Part_Or_Package_Spec;
15491 if From_Aspect_Specification (N) then
15493 E : constant Entity_Id := Entity (Corresponding_Aspect (N));
15495 if not In_Open_Scopes (E) then
15497 ("aspect must apply to package or subprogram", N);
15502 if Present (Arg1) then
15503 Pool := Get_Pragma_Arg (Arg1);
15505 -- Case of Default_Storage_Pool (null);
15507 if Nkind (Pool) = N_Null then
15510 -- This is an odd case, this is not really an expression,
15511 -- so we don't have a type for it. So just set the type to
15514 Set_Etype (Pool, Empty);
15516 -- Case of Default_Storage_Pool (storage_pool_NAME);
15519 -- If it's a configuration pragma, then the only allowed
15520 -- argument is "null".
15522 if Is_Configuration_Pragma then
15523 Error_Pragma_Arg ("NULL expected", Arg1);
15526 -- The expected type for a non-"null" argument is
15527 -- Root_Storage_Pool'Class, and the pool must be a variable.
15529 Analyze_And_Resolve
15530 (Pool, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
15532 if Is_Variable (Pool) then
15534 -- A pragma that applies to a Ghost entity becomes Ghost
15535 -- for the purposes of legality checks and removal of
15536 -- ignored Ghost code.
15538 Mark_Ghost_Pragma (N, Entity (Pool));
15542 ("default storage pool must be a variable", Arg1);
15546 -- Record the pool name (or null). Freeze.Freeze_Entity for an
15547 -- access type will use this information to set the appropriate
15548 -- attributes of the access type. If the pragma appears in a
15549 -- generic unit it is ignored, given that it may refer to a
15552 if not Inside_A_Generic then
15553 Default_Pool := Pool;
15556 end Default_Storage_Pool;
15562 -- pragma Depends (DEPENDENCY_RELATION);
15564 -- DEPENDENCY_RELATION ::=
15566 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
15568 -- DEPENDENCY_CLAUSE ::=
15569 -- OUTPUT_LIST =>[+] INPUT_LIST
15570 -- | NULL_DEPENDENCY_CLAUSE
15572 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
15574 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
15576 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
15578 -- OUTPUT ::= NAME | FUNCTION_RESULT
15581 -- where FUNCTION_RESULT is a function Result attribute_reference
15583 -- Characteristics:
15585 -- * Analysis - The annotation undergoes initial checks to verify
15586 -- the legal placement and context. Secondary checks fully analyze
15587 -- the dependency clauses in:
15589 -- Analyze_Depends_In_Decl_Part
15591 -- * Expansion - None.
15593 -- * Template - The annotation utilizes the generic template of the
15594 -- related subprogram [body] when it is:
15596 -- aspect on subprogram declaration
15597 -- aspect on stand-alone subprogram body
15598 -- pragma on stand-alone subprogram body
15600 -- The annotation must prepare its own template when it is:
15602 -- pragma on subprogram declaration
15604 -- * Globals - Capture of global references must occur after full
15607 -- * Instance - The annotation is instantiated automatically when
15608 -- the related generic subprogram [body] is instantiated except for
15609 -- the "pragma on subprogram declaration" case. In that scenario
15610 -- the annotation must instantiate itself.
15612 when Pragma_Depends => Depends : declare
15614 Spec_Id : Entity_Id;
15615 Subp_Decl : Node_Id;
15618 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
15622 -- Chain the pragma on the contract for further processing by
15623 -- Analyze_Depends_In_Decl_Part.
15625 Add_Contract_Item (N, Spec_Id);
15627 -- Fully analyze the pragma when it appears inside an entry
15628 -- or subprogram body because it cannot benefit from forward
15631 if Nkind_In (Subp_Decl, N_Entry_Body,
15633 N_Subprogram_Body_Stub)
15635 -- The legality checks of pragmas Depends and Global are
15636 -- affected by the SPARK mode in effect and the volatility
15637 -- of the context. In addition these two pragmas are subject
15638 -- to an inherent order:
15643 -- Analyze all these pragmas in the order outlined above
15645 Analyze_If_Present (Pragma_SPARK_Mode);
15646 Analyze_If_Present (Pragma_Volatile_Function);
15647 Analyze_If_Present (Pragma_Global);
15648 Analyze_Depends_In_Decl_Part (N);
15653 ---------------------
15654 -- Detect_Blocking --
15655 ---------------------
15657 -- pragma Detect_Blocking;
15659 when Pragma_Detect_Blocking =>
15661 Check_Arg_Count (0);
15662 Check_Valid_Configuration_Pragma;
15663 Detect_Blocking := True;
15665 ------------------------------------
15666 -- Disable_Atomic_Synchronization --
15667 ------------------------------------
15669 -- pragma Disable_Atomic_Synchronization [(Entity)];
15671 when Pragma_Disable_Atomic_Synchronization =>
15673 Process_Disable_Enable_Atomic_Sync (Name_Suppress);
15675 -------------------
15676 -- Discard_Names --
15677 -------------------
15679 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
15681 when Pragma_Discard_Names => Discard_Names : declare
15686 Check_Ada_83_Warning;
15688 -- Deal with configuration pragma case
15690 if Arg_Count = 0 and then Is_Configuration_Pragma then
15691 Global_Discard_Names := True;
15694 -- Otherwise, check correct appropriate context
15697 Check_Is_In_Decl_Part_Or_Package_Spec;
15699 if Arg_Count = 0 then
15701 -- If there is no parameter, then from now on this pragma
15702 -- applies to any enumeration, exception or tagged type
15703 -- defined in the current declarative part, and recursively
15704 -- to any nested scope.
15706 Set_Discard_Names (Current_Scope);
15710 Check_Arg_Count (1);
15711 Check_Optional_Identifier (Arg1, Name_On);
15712 Check_Arg_Is_Local_Name (Arg1);
15714 E_Id := Get_Pragma_Arg (Arg1);
15716 if Etype (E_Id) = Any_Type then
15720 E := Entity (E_Id);
15722 -- A pragma that applies to a Ghost entity becomes Ghost for
15723 -- the purposes of legality checks and removal of ignored
15726 Mark_Ghost_Pragma (N, E);
15728 if (Is_First_Subtype (E)
15730 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
15731 or else Ekind (E) = E_Exception
15733 Set_Discard_Names (E);
15734 Record_Rep_Item (E, N);
15738 ("inappropriate entity for pragma%", Arg1);
15744 ------------------------
15745 -- Dispatching_Domain --
15746 ------------------------
15748 -- pragma Dispatching_Domain (EXPRESSION);
15750 when Pragma_Dispatching_Domain => Dispatching_Domain : declare
15751 P : constant Node_Id := Parent (N);
15757 Check_No_Identifiers;
15758 Check_Arg_Count (1);
15760 -- This pragma is born obsolete, but not the aspect
15762 if not From_Aspect_Specification (N) then
15764 (No_Obsolescent_Features, Pragma_Identifier (N));
15767 if Nkind (P) = N_Task_Definition then
15768 Arg := Get_Pragma_Arg (Arg1);
15769 Ent := Defining_Identifier (Parent (P));
15771 -- A pragma that applies to a Ghost entity becomes Ghost for
15772 -- the purposes of legality checks and removal of ignored Ghost
15775 Mark_Ghost_Pragma (N, Ent);
15777 -- The expression must be analyzed in the special manner
15778 -- described in "Handling of Default and Per-Object
15779 -- Expressions" in sem.ads.
15781 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
15783 -- Check duplicate pragma before we chain the pragma in the Rep
15784 -- Item chain of Ent.
15786 Check_Duplicate_Pragma (Ent);
15787 Record_Rep_Item (Ent, N);
15789 -- Anything else is incorrect
15794 end Dispatching_Domain;
15800 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
15802 when Pragma_Elaborate => Elaborate : declare
15807 -- Pragma must be in context items list of a compilation unit
15809 if not Is_In_Context_Clause then
15813 -- Must be at least one argument
15815 if Arg_Count = 0 then
15816 Error_Pragma ("pragma% requires at least one argument");
15819 -- In Ada 83 mode, there can be no items following it in the
15820 -- context list except other pragmas and implicit with clauses
15821 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
15822 -- placement rule does not apply.
15824 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
15826 while Present (Citem) loop
15827 if Nkind (Citem) = N_Pragma
15828 or else (Nkind (Citem) = N_With_Clause
15829 and then Implicit_With (Citem))
15834 ("(Ada 83) pragma% must be at end of context clause");
15841 -- Finally, the arguments must all be units mentioned in a with
15842 -- clause in the same context clause. Note we already checked (in
15843 -- Par.Prag) that the arguments are all identifiers or selected
15847 Outer : while Present (Arg) loop
15848 Citem := First (List_Containing (N));
15849 Inner : while Citem /= N loop
15850 if Nkind (Citem) = N_With_Clause
15851 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
15853 Set_Elaborate_Present (Citem, True);
15854 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
15856 -- With the pragma present, elaboration calls on
15857 -- subprograms from the named unit need no further
15858 -- checks, as long as the pragma appears in the current
15859 -- compilation unit. If the pragma appears in some unit
15860 -- in the context, there might still be a need for an
15861 -- Elaborate_All_Desirable from the current compilation
15862 -- to the named unit, so we keep the check enabled. This
15863 -- does not apply in SPARK mode, where we allow pragma
15864 -- Elaborate, but we don't trust it to be right so we
15865 -- will still insist on the Elaborate_All.
15867 if Legacy_Elaboration_Checks
15868 and then In_Extended_Main_Source_Unit (N)
15869 and then SPARK_Mode /= On
15871 Set_Suppress_Elaboration_Warnings
15872 (Entity (Name (Citem)));
15883 ("argument of pragma% is not withed unit", Arg);
15890 -------------------
15891 -- Elaborate_All --
15892 -------------------
15894 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
15896 when Pragma_Elaborate_All => Elaborate_All : declare
15901 Check_Ada_83_Warning;
15903 -- Pragma must be in context items list of a compilation unit
15905 if not Is_In_Context_Clause then
15909 -- Must be at least one argument
15911 if Arg_Count = 0 then
15912 Error_Pragma ("pragma% requires at least one argument");
15915 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
15916 -- have to appear at the end of the context clause, but may
15917 -- appear mixed in with other items, even in Ada 83 mode.
15919 -- Final check: the arguments must all be units mentioned in
15920 -- a with clause in the same context clause. Note that we
15921 -- already checked (in Par.Prag) that all the arguments are
15922 -- either identifiers or selected components.
15925 Outr : while Present (Arg) loop
15926 Citem := First (List_Containing (N));
15927 Innr : while Citem /= N loop
15928 if Nkind (Citem) = N_With_Clause
15929 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
15931 Set_Elaborate_All_Present (Citem, True);
15932 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
15934 -- Suppress warnings and elaboration checks on the named
15935 -- unit if the pragma is in the current compilation, as
15936 -- for pragma Elaborate.
15938 if Legacy_Elaboration_Checks
15939 and then In_Extended_Main_Source_Unit (N)
15941 Set_Suppress_Elaboration_Warnings
15942 (Entity (Name (Citem)));
15952 Set_Error_Posted (N);
15954 ("argument of pragma% is not withed unit", Arg);
15961 --------------------
15962 -- Elaborate_Body --
15963 --------------------
15965 -- pragma Elaborate_Body [( library_unit_NAME )];
15967 when Pragma_Elaborate_Body => Elaborate_Body : declare
15968 Cunit_Node : Node_Id;
15969 Cunit_Ent : Entity_Id;
15972 Check_Ada_83_Warning;
15973 Check_Valid_Library_Unit_Pragma;
15975 if Nkind (N) = N_Null_Statement then
15979 Cunit_Node := Cunit (Current_Sem_Unit);
15980 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
15982 -- A pragma that applies to a Ghost entity becomes Ghost for the
15983 -- purposes of legality checks and removal of ignored Ghost code.
15985 Mark_Ghost_Pragma (N, Cunit_Ent);
15987 if Nkind_In (Unit (Cunit_Node), N_Package_Body,
15990 Error_Pragma ("pragma% must refer to a spec, not a body");
15992 Set_Body_Required (Cunit_Node);
15993 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
15995 -- If we are in dynamic elaboration mode, then we suppress
15996 -- elaboration warnings for the unit, since it is definitely
15997 -- fine NOT to do dynamic checks at the first level (and such
15998 -- checks will be suppressed because no elaboration boolean
15999 -- is created for Elaborate_Body packages).
16001 -- But in the static model of elaboration, Elaborate_Body is
16002 -- definitely NOT good enough to ensure elaboration safety on
16003 -- its own, since the body may WITH other units that are not
16004 -- safe from an elaboration point of view, so a client must
16005 -- still do an Elaborate_All on such units.
16007 -- Debug flag -gnatdD restores the old behavior of 3.13, where
16008 -- Elaborate_Body always suppressed elab warnings.
16010 if Legacy_Elaboration_Checks
16011 and then (Dynamic_Elaboration_Checks or Debug_Flag_DD)
16013 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
16016 end Elaborate_Body;
16018 ------------------------
16019 -- Elaboration_Checks --
16020 ------------------------
16022 -- pragma Elaboration_Checks (Static | Dynamic);
16024 when Pragma_Elaboration_Checks => Elaboration_Checks : declare
16025 procedure Check_Duplicate_Elaboration_Checks_Pragma;
16026 -- Emit an error if the current context list already contains
16027 -- a previous Elaboration_Checks pragma. This routine raises
16028 -- Pragma_Exit if a duplicate is found.
16030 procedure Ignore_Elaboration_Checks_Pragma;
16031 -- Warn that the effects of the pragma are ignored. This routine
16032 -- raises Pragma_Exit.
16034 -----------------------------------------------
16035 -- Check_Duplicate_Elaboration_Checks_Pragma --
16036 -----------------------------------------------
16038 procedure Check_Duplicate_Elaboration_Checks_Pragma is
16043 while Present (Item) loop
16044 if Nkind (Item) = N_Pragma
16045 and then Pragma_Name (Item) = Name_Elaboration_Checks
16055 end Check_Duplicate_Elaboration_Checks_Pragma;
16057 --------------------------------------
16058 -- Ignore_Elaboration_Checks_Pragma --
16059 --------------------------------------
16061 procedure Ignore_Elaboration_Checks_Pragma is
16063 Error_Msg_Name_1 := Pname;
16064 Error_Msg_N ("??effects of pragma % are ignored", N);
16066 ("\place pragma on initial declaration of library unit", N);
16069 end Ignore_Elaboration_Checks_Pragma;
16073 Context : constant Node_Id := Parent (N);
16076 -- Start of processing for Elaboration_Checks
16080 Check_Arg_Count (1);
16081 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
16083 -- The pragma appears in a configuration file
16085 if No (Context) then
16086 Check_Valid_Configuration_Pragma;
16087 Check_Duplicate_Elaboration_Checks_Pragma;
16089 -- The pragma acts as a configuration pragma in a compilation unit
16091 -- pragma Elaboration_Checks (...);
16092 -- package Pack is ...;
16094 elsif Nkind (Context) = N_Compilation_Unit
16095 and then List_Containing (N) = Context_Items (Context)
16097 Check_Valid_Configuration_Pragma;
16098 Check_Duplicate_Elaboration_Checks_Pragma;
16100 Unt := Unit (Context);
16102 -- The pragma must appear on the initial declaration of a unit.
16103 -- If this is not the case, warn that the effects of the pragma
16106 if Nkind (Unt) = N_Package_Body then
16107 Ignore_Elaboration_Checks_Pragma;
16109 -- Check the Acts_As_Spec flag of the compilation units itself
16110 -- to determine whether the subprogram body completes since it
16111 -- has not been analyzed yet. This is safe because compilation
16112 -- units are not overloadable.
16114 elsif Nkind (Unt) = N_Subprogram_Body
16115 and then not Acts_As_Spec (Context)
16117 Ignore_Elaboration_Checks_Pragma;
16119 elsif Nkind (Unt) = N_Subunit then
16120 Ignore_Elaboration_Checks_Pragma;
16123 -- Otherwise the pragma does not appear at the configuration level
16130 -- At this point the pragma is not a duplicate, and appears in the
16131 -- proper context. Set the elaboration model in effect.
16133 Dynamic_Elaboration_Checks :=
16134 Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic;
16135 end Elaboration_Checks;
16141 -- pragma Eliminate (
16142 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
16143 -- [Entity =>] IDENTIFIER |
16144 -- SELECTED_COMPONENT |
16146 -- [, Source_Location => SOURCE_TRACE]);
16148 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
16149 -- SOURCE_TRACE ::= STRING_LITERAL
16151 when Pragma_Eliminate => Eliminate : declare
16152 Args : Args_List (1 .. 5);
16153 Names : constant Name_List (1 .. 5) := (
16156 Name_Parameter_Types,
16158 Name_Source_Location);
16160 -- Note : Parameter_Types and Result_Type are leftovers from
16161 -- prior implementations of the pragma. They are not generated
16162 -- by the gnatelim tool, and play no role in selecting which
16163 -- of a set of overloaded names is chosen for elimination.
16165 Unit_Name : Node_Id renames Args (1);
16166 Entity : Node_Id renames Args (2);
16167 Parameter_Types : Node_Id renames Args (3);
16168 Result_Type : Node_Id renames Args (4);
16169 Source_Location : Node_Id renames Args (5);
16173 Check_Valid_Configuration_Pragma;
16174 Gather_Associations (Names, Args);
16176 if No (Unit_Name) then
16177 Error_Pragma ("missing Unit_Name argument for pragma%");
16181 and then (Present (Parameter_Types)
16183 Present (Result_Type)
16185 Present (Source_Location))
16187 Error_Pragma ("missing Entity argument for pragma%");
16190 if (Present (Parameter_Types)
16192 Present (Result_Type))
16194 Present (Source_Location)
16197 ("parameter profile and source location cannot be used "
16198 & "together in pragma%");
16201 Process_Eliminate_Pragma
16210 -----------------------------------
16211 -- Enable_Atomic_Synchronization --
16212 -----------------------------------
16214 -- pragma Enable_Atomic_Synchronization [(Entity)];
16216 when Pragma_Enable_Atomic_Synchronization =>
16218 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
16225 -- [ Convention =>] convention_IDENTIFIER,
16226 -- [ Entity =>] LOCAL_NAME
16227 -- [, [External_Name =>] static_string_EXPRESSION ]
16228 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16230 when Pragma_Export => Export : declare
16232 Def_Id : Entity_Id;
16234 pragma Warnings (Off, C);
16237 Check_Ada_83_Warning;
16241 Name_External_Name,
16244 Check_At_Least_N_Arguments (2);
16245 Check_At_Most_N_Arguments (4);
16247 -- In Relaxed_RM_Semantics, support old Ada 83 style:
16248 -- pragma Export (Entity, "external name");
16250 if Relaxed_RM_Semantics
16251 and then Arg_Count = 2
16252 and then Nkind (Expression (Arg2)) = N_String_Literal
16255 Def_Id := Get_Pragma_Arg (Arg1);
16258 if not Is_Entity_Name (Def_Id) then
16259 Error_Pragma_Arg ("entity name required", Arg1);
16262 Def_Id := Entity (Def_Id);
16263 Set_Exported (Def_Id, Arg1);
16266 Process_Convention (C, Def_Id);
16268 -- A pragma that applies to a Ghost entity becomes Ghost for
16269 -- the purposes of legality checks and removal of ignored Ghost
16272 Mark_Ghost_Pragma (N, Def_Id);
16274 if Ekind (Def_Id) /= E_Constant then
16275 Note_Possible_Modification
16276 (Get_Pragma_Arg (Arg2), Sure => False);
16279 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
16280 Set_Exported (Def_Id, Arg2);
16283 -- If the entity is a deferred constant, propagate the information
16284 -- to the full view, because gigi elaborates the full view only.
16286 if Ekind (Def_Id) = E_Constant
16287 and then Present (Full_View (Def_Id))
16290 Id2 : constant Entity_Id := Full_View (Def_Id);
16292 Set_Is_Exported (Id2, Is_Exported (Def_Id));
16293 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
16294 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
16299 ---------------------
16300 -- Export_Function --
16301 ---------------------
16303 -- pragma Export_Function (
16304 -- [Internal =>] LOCAL_NAME
16305 -- [, [External =>] EXTERNAL_SYMBOL]
16306 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16307 -- [, [Result_Type =>] TYPE_DESIGNATOR]
16308 -- [, [Mechanism =>] MECHANISM]
16309 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
16311 -- EXTERNAL_SYMBOL ::=
16313 -- | static_string_EXPRESSION
16315 -- PARAMETER_TYPES ::=
16317 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16319 -- TYPE_DESIGNATOR ::=
16321 -- | subtype_Name ' Access
16325 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16327 -- MECHANISM_ASSOCIATION ::=
16328 -- [formal_parameter_NAME =>] MECHANISM_NAME
16330 -- MECHANISM_NAME ::=
16334 when Pragma_Export_Function => Export_Function : declare
16335 Args : Args_List (1 .. 6);
16336 Names : constant Name_List (1 .. 6) := (
16339 Name_Parameter_Types,
16342 Name_Result_Mechanism);
16344 Internal : Node_Id renames Args (1);
16345 External : Node_Id renames Args (2);
16346 Parameter_Types : Node_Id renames Args (3);
16347 Result_Type : Node_Id renames Args (4);
16348 Mechanism : Node_Id renames Args (5);
16349 Result_Mechanism : Node_Id renames Args (6);
16353 Gather_Associations (Names, Args);
16354 Process_Extended_Import_Export_Subprogram_Pragma (
16355 Arg_Internal => Internal,
16356 Arg_External => External,
16357 Arg_Parameter_Types => Parameter_Types,
16358 Arg_Result_Type => Result_Type,
16359 Arg_Mechanism => Mechanism,
16360 Arg_Result_Mechanism => Result_Mechanism);
16361 end Export_Function;
16363 -------------------
16364 -- Export_Object --
16365 -------------------
16367 -- pragma Export_Object (
16368 -- [Internal =>] LOCAL_NAME
16369 -- [, [External =>] EXTERNAL_SYMBOL]
16370 -- [, [Size =>] EXTERNAL_SYMBOL]);
16372 -- EXTERNAL_SYMBOL ::=
16374 -- | static_string_EXPRESSION
16376 -- PARAMETER_TYPES ::=
16378 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16380 -- TYPE_DESIGNATOR ::=
16382 -- | subtype_Name ' Access
16386 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16388 -- MECHANISM_ASSOCIATION ::=
16389 -- [formal_parameter_NAME =>] MECHANISM_NAME
16391 -- MECHANISM_NAME ::=
16395 when Pragma_Export_Object => Export_Object : declare
16396 Args : Args_List (1 .. 3);
16397 Names : constant Name_List (1 .. 3) := (
16402 Internal : Node_Id renames Args (1);
16403 External : Node_Id renames Args (2);
16404 Size : Node_Id renames Args (3);
16408 Gather_Associations (Names, Args);
16409 Process_Extended_Import_Export_Object_Pragma (
16410 Arg_Internal => Internal,
16411 Arg_External => External,
16415 ----------------------
16416 -- Export_Procedure --
16417 ----------------------
16419 -- pragma Export_Procedure (
16420 -- [Internal =>] LOCAL_NAME
16421 -- [, [External =>] EXTERNAL_SYMBOL]
16422 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16423 -- [, [Mechanism =>] MECHANISM]);
16425 -- EXTERNAL_SYMBOL ::=
16427 -- | static_string_EXPRESSION
16429 -- PARAMETER_TYPES ::=
16431 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16433 -- TYPE_DESIGNATOR ::=
16435 -- | subtype_Name ' Access
16439 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16441 -- MECHANISM_ASSOCIATION ::=
16442 -- [formal_parameter_NAME =>] MECHANISM_NAME
16444 -- MECHANISM_NAME ::=
16448 when Pragma_Export_Procedure => Export_Procedure : declare
16449 Args : Args_List (1 .. 4);
16450 Names : constant Name_List (1 .. 4) := (
16453 Name_Parameter_Types,
16456 Internal : Node_Id renames Args (1);
16457 External : Node_Id renames Args (2);
16458 Parameter_Types : Node_Id renames Args (3);
16459 Mechanism : Node_Id renames Args (4);
16463 Gather_Associations (Names, Args);
16464 Process_Extended_Import_Export_Subprogram_Pragma (
16465 Arg_Internal => Internal,
16466 Arg_External => External,
16467 Arg_Parameter_Types => Parameter_Types,
16468 Arg_Mechanism => Mechanism);
16469 end Export_Procedure;
16475 -- pragma Export_Value (
16476 -- [Value =>] static_integer_EXPRESSION,
16477 -- [Link_Name =>] static_string_EXPRESSION);
16479 when Pragma_Export_Value =>
16481 Check_Arg_Order ((Name_Value, Name_Link_Name));
16482 Check_Arg_Count (2);
16484 Check_Optional_Identifier (Arg1, Name_Value);
16485 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
16487 Check_Optional_Identifier (Arg2, Name_Link_Name);
16488 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
16490 -----------------------------
16491 -- Export_Valued_Procedure --
16492 -----------------------------
16494 -- pragma Export_Valued_Procedure (
16495 -- [Internal =>] LOCAL_NAME
16496 -- [, [External =>] EXTERNAL_SYMBOL,]
16497 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16498 -- [, [Mechanism =>] MECHANISM]);
16500 -- EXTERNAL_SYMBOL ::=
16502 -- | static_string_EXPRESSION
16504 -- PARAMETER_TYPES ::=
16506 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16508 -- TYPE_DESIGNATOR ::=
16510 -- | subtype_Name ' Access
16514 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16516 -- MECHANISM_ASSOCIATION ::=
16517 -- [formal_parameter_NAME =>] MECHANISM_NAME
16519 -- MECHANISM_NAME ::=
16523 when Pragma_Export_Valued_Procedure =>
16524 Export_Valued_Procedure : declare
16525 Args : Args_List (1 .. 4);
16526 Names : constant Name_List (1 .. 4) := (
16529 Name_Parameter_Types,
16532 Internal : Node_Id renames Args (1);
16533 External : Node_Id renames Args (2);
16534 Parameter_Types : Node_Id renames Args (3);
16535 Mechanism : Node_Id renames Args (4);
16539 Gather_Associations (Names, Args);
16540 Process_Extended_Import_Export_Subprogram_Pragma (
16541 Arg_Internal => Internal,
16542 Arg_External => External,
16543 Arg_Parameter_Types => Parameter_Types,
16544 Arg_Mechanism => Mechanism);
16545 end Export_Valued_Procedure;
16547 -------------------
16548 -- Extend_System --
16549 -------------------
16551 -- pragma Extend_System ([Name =>] Identifier);
16553 when Pragma_Extend_System =>
16555 Check_Valid_Configuration_Pragma;
16556 Check_Arg_Count (1);
16557 Check_Optional_Identifier (Arg1, Name_Name);
16558 Check_Arg_Is_Identifier (Arg1);
16560 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
16563 and then Name_Buffer (1 .. 4) = "aux_"
16565 if Present (System_Extend_Pragma_Arg) then
16566 if Chars (Get_Pragma_Arg (Arg1)) =
16567 Chars (Expression (System_Extend_Pragma_Arg))
16571 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
16572 Error_Pragma ("pragma% conflicts with that #");
16576 System_Extend_Pragma_Arg := Arg1;
16578 if not GNAT_Mode then
16579 System_Extend_Unit := Arg1;
16583 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
16586 ------------------------
16587 -- Extensions_Allowed --
16588 ------------------------
16590 -- pragma Extensions_Allowed (ON | OFF);
16592 when Pragma_Extensions_Allowed =>
16594 Check_Arg_Count (1);
16595 Check_No_Identifiers;
16596 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
16598 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
16599 Extensions_Allowed := True;
16600 Ada_Version := Ada_Version_Type'Last;
16603 Extensions_Allowed := False;
16604 Ada_Version := Ada_Version_Explicit;
16605 Ada_Version_Pragma := Empty;
16608 ------------------------
16609 -- Extensions_Visible --
16610 ------------------------
16612 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
16614 -- Characteristics:
16616 -- * Analysis - The annotation is fully analyzed immediately upon
16617 -- elaboration as its expression must be static.
16619 -- * Expansion - None.
16621 -- * Template - The annotation utilizes the generic template of the
16622 -- related subprogram [body] when it is:
16624 -- aspect on subprogram declaration
16625 -- aspect on stand-alone subprogram body
16626 -- pragma on stand-alone subprogram body
16628 -- The annotation must prepare its own template when it is:
16630 -- pragma on subprogram declaration
16632 -- * Globals - Capture of global references must occur after full
16635 -- * Instance - The annotation is instantiated automatically when
16636 -- the related generic subprogram [body] is instantiated except for
16637 -- the "pragma on subprogram declaration" case. In that scenario
16638 -- the annotation must instantiate itself.
16640 when Pragma_Extensions_Visible => Extensions_Visible : declare
16641 Formal : Entity_Id;
16642 Has_OK_Formal : Boolean := False;
16643 Spec_Id : Entity_Id;
16644 Subp_Decl : Node_Id;
16648 Check_No_Identifiers;
16649 Check_At_Most_N_Arguments (1);
16652 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
16654 -- Abstract subprogram declaration
16656 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
16659 -- Generic subprogram declaration
16661 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
16664 -- Body acts as spec
16666 elsif Nkind (Subp_Decl) = N_Subprogram_Body
16667 and then No (Corresponding_Spec (Subp_Decl))
16671 -- Body stub acts as spec
16673 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
16674 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
16678 -- Subprogram declaration
16680 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
16683 -- Otherwise the pragma is associated with an illegal construct
16686 Error_Pragma ("pragma % must apply to a subprogram");
16690 -- Mark the pragma as Ghost if the related subprogram is also
16691 -- Ghost. This also ensures that any expansion performed further
16692 -- below will produce Ghost nodes.
16694 Spec_Id := Unique_Defining_Entity (Subp_Decl);
16695 Mark_Ghost_Pragma (N, Spec_Id);
16697 -- Chain the pragma on the contract for completeness
16699 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
16701 -- The legality checks of pragma Extension_Visible are affected
16702 -- by the SPARK mode in effect. Analyze all pragmas in specific
16705 Analyze_If_Present (Pragma_SPARK_Mode);
16707 -- Examine the formals of the related subprogram
16709 Formal := First_Formal (Spec_Id);
16710 while Present (Formal) loop
16712 -- At least one of the formals is of a specific tagged type,
16713 -- the pragma is legal.
16715 if Is_Specific_Tagged_Type (Etype (Formal)) then
16716 Has_OK_Formal := True;
16719 -- A generic subprogram with at least one formal of a private
16720 -- type ensures the legality of the pragma because the actual
16721 -- may be specifically tagged. Note that this is verified by
16722 -- the check above at instantiation time.
16724 elsif Is_Private_Type (Etype (Formal))
16725 and then Is_Generic_Type (Etype (Formal))
16727 Has_OK_Formal := True;
16731 Next_Formal (Formal);
16734 if not Has_OK_Formal then
16735 Error_Msg_Name_1 := Pname;
16736 Error_Msg_N (Fix_Error ("incorrect placement of pragma %"), N);
16738 ("\subprogram & lacks parameter of specific tagged or "
16739 & "generic private type", N, Spec_Id);
16744 -- Analyze the Boolean expression (if any)
16746 if Present (Arg1) then
16747 Check_Static_Boolean_Expression
16748 (Expression (Get_Argument (N, Spec_Id)));
16750 end Extensions_Visible;
16756 -- pragma External (
16757 -- [ Convention =>] convention_IDENTIFIER,
16758 -- [ Entity =>] LOCAL_NAME
16759 -- [, [External_Name =>] static_string_EXPRESSION ]
16760 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16762 when Pragma_External => External : declare
16765 pragma Warnings (Off, C);
16772 Name_External_Name,
16774 Check_At_Least_N_Arguments (2);
16775 Check_At_Most_N_Arguments (4);
16776 Process_Convention (C, E);
16778 -- A pragma that applies to a Ghost entity becomes Ghost for the
16779 -- purposes of legality checks and removal of ignored Ghost code.
16781 Mark_Ghost_Pragma (N, E);
16783 Note_Possible_Modification
16784 (Get_Pragma_Arg (Arg2), Sure => False);
16785 Process_Interface_Name (E, Arg3, Arg4, N);
16786 Set_Exported (E, Arg2);
16789 --------------------------
16790 -- External_Name_Casing --
16791 --------------------------
16793 -- pragma External_Name_Casing (
16794 -- UPPERCASE | LOWERCASE
16795 -- [, AS_IS | UPPERCASE | LOWERCASE]);
16797 when Pragma_External_Name_Casing =>
16799 Check_No_Identifiers;
16801 if Arg_Count = 2 then
16802 Check_Arg_Is_One_Of
16803 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
16805 case Chars (Get_Pragma_Arg (Arg2)) is
16807 Opt.External_Name_Exp_Casing := As_Is;
16809 when Name_Uppercase =>
16810 Opt.External_Name_Exp_Casing := Uppercase;
16812 when Name_Lowercase =>
16813 Opt.External_Name_Exp_Casing := Lowercase;
16820 Check_Arg_Count (1);
16823 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
16825 case Chars (Get_Pragma_Arg (Arg1)) is
16826 when Name_Uppercase =>
16827 Opt.External_Name_Imp_Casing := Uppercase;
16829 when Name_Lowercase =>
16830 Opt.External_Name_Imp_Casing := Lowercase;
16840 -- pragma Fast_Math;
16842 when Pragma_Fast_Math =>
16844 Check_No_Identifiers;
16845 Check_Valid_Configuration_Pragma;
16848 --------------------------
16849 -- Favor_Top_Level --
16850 --------------------------
16852 -- pragma Favor_Top_Level (type_NAME);
16854 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
16859 Check_No_Identifiers;
16860 Check_Arg_Count (1);
16861 Check_Arg_Is_Local_Name (Arg1);
16862 Typ := Entity (Get_Pragma_Arg (Arg1));
16864 -- A pragma that applies to a Ghost entity becomes Ghost for the
16865 -- purposes of legality checks and removal of ignored Ghost code.
16867 Mark_Ghost_Pragma (N, Typ);
16869 -- If it's an access-to-subprogram type (in particular, not a
16870 -- subtype), set the flag on that type.
16872 if Is_Access_Subprogram_Type (Typ) then
16873 Set_Can_Use_Internal_Rep (Typ, False);
16875 -- Otherwise it's an error (name denotes the wrong sort of entity)
16879 ("access-to-subprogram type expected",
16880 Get_Pragma_Arg (Arg1));
16882 end Favor_Top_Level;
16884 ---------------------------
16885 -- Finalize_Storage_Only --
16886 ---------------------------
16888 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
16890 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
16891 Assoc : constant Node_Id := Arg1;
16892 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
16897 Check_No_Identifiers;
16898 Check_Arg_Count (1);
16899 Check_Arg_Is_Local_Name (Arg1);
16901 Find_Type (Type_Id);
16902 Typ := Entity (Type_Id);
16905 or else Rep_Item_Too_Early (Typ, N)
16909 Typ := Underlying_Type (Typ);
16912 if not Is_Controlled (Typ) then
16913 Error_Pragma ("pragma% must specify controlled type");
16916 Check_First_Subtype (Arg1);
16918 if Finalize_Storage_Only (Typ) then
16919 Error_Pragma ("duplicate pragma%, only one allowed");
16921 elsif not Rep_Item_Too_Late (Typ, N) then
16922 Set_Finalize_Storage_Only (Base_Type (Typ), True);
16924 end Finalize_Storage;
16930 -- pragma Ghost [ (boolean_EXPRESSION) ];
16932 when Pragma_Ghost => Ghost : declare
16936 Orig_Stmt : Node_Id;
16937 Prev_Id : Entity_Id;
16942 Check_No_Identifiers;
16943 Check_At_Most_N_Arguments (1);
16947 while Present (Stmt) loop
16949 -- Skip prior pragmas, but check for duplicates
16951 if Nkind (Stmt) = N_Pragma then
16952 if Pragma_Name (Stmt) = Pname then
16959 -- Task unit declared without a definition cannot be subject to
16960 -- pragma Ghost (SPARK RM 6.9(19)).
16962 elsif Nkind_In (Stmt, N_Single_Task_Declaration,
16963 N_Task_Type_Declaration)
16965 Error_Pragma ("pragma % cannot apply to a task type");
16968 -- Skip internally generated code
16970 elsif not Comes_From_Source (Stmt) then
16971 Orig_Stmt := Original_Node (Stmt);
16973 -- When pragma Ghost applies to an untagged derivation, the
16974 -- derivation is transformed into a [sub]type declaration.
16976 if Nkind_In (Stmt, N_Full_Type_Declaration,
16977 N_Subtype_Declaration)
16978 and then Comes_From_Source (Orig_Stmt)
16979 and then Nkind (Orig_Stmt) = N_Full_Type_Declaration
16980 and then Nkind (Type_Definition (Orig_Stmt)) =
16981 N_Derived_Type_Definition
16983 Id := Defining_Entity (Stmt);
16986 -- When pragma Ghost applies to an object declaration which
16987 -- is initialized by means of a function call that returns
16988 -- on the secondary stack, the object declaration becomes a
16991 elsif Nkind (Stmt) = N_Object_Renaming_Declaration
16992 and then Comes_From_Source (Orig_Stmt)
16993 and then Nkind (Orig_Stmt) = N_Object_Declaration
16995 Id := Defining_Entity (Stmt);
16998 -- When pragma Ghost applies to an expression function, the
16999 -- expression function is transformed into a subprogram.
17001 elsif Nkind (Stmt) = N_Subprogram_Declaration
17002 and then Comes_From_Source (Orig_Stmt)
17003 and then Nkind (Orig_Stmt) = N_Expression_Function
17005 Id := Defining_Entity (Stmt);
17009 -- The pragma applies to a legal construct, stop the traversal
17011 elsif Nkind_In (Stmt, N_Abstract_Subprogram_Declaration,
17012 N_Full_Type_Declaration,
17013 N_Generic_Subprogram_Declaration,
17014 N_Object_Declaration,
17015 N_Private_Extension_Declaration,
17016 N_Private_Type_Declaration,
17017 N_Subprogram_Declaration,
17018 N_Subtype_Declaration)
17020 Id := Defining_Entity (Stmt);
17023 -- The pragma does not apply to a legal construct, issue an
17024 -- error and stop the analysis.
17028 ("pragma % must apply to an object, package, subprogram "
17033 Stmt := Prev (Stmt);
17036 Context := Parent (N);
17038 -- Handle compilation units
17040 if Nkind (Context) = N_Compilation_Unit_Aux then
17041 Context := Unit (Parent (Context));
17044 -- Protected and task types cannot be subject to pragma Ghost
17045 -- (SPARK RM 6.9(19)).
17047 if Nkind_In (Context, N_Protected_Body, N_Protected_Definition)
17049 Error_Pragma ("pragma % cannot apply to a protected type");
17052 elsif Nkind_In (Context, N_Task_Body, N_Task_Definition) then
17053 Error_Pragma ("pragma % cannot apply to a task type");
17059 -- When pragma Ghost is associated with a [generic] package, it
17060 -- appears in the visible declarations.
17062 if Nkind (Context) = N_Package_Specification
17063 and then Present (Visible_Declarations (Context))
17064 and then List_Containing (N) = Visible_Declarations (Context)
17066 Id := Defining_Entity (Context);
17068 -- Pragma Ghost applies to a stand-alone subprogram body
17070 elsif Nkind (Context) = N_Subprogram_Body
17071 and then No (Corresponding_Spec (Context))
17073 Id := Defining_Entity (Context);
17075 -- Pragma Ghost applies to a subprogram declaration that acts
17076 -- as a compilation unit.
17078 elsif Nkind (Context) = N_Subprogram_Declaration then
17079 Id := Defining_Entity (Context);
17081 -- Pragma Ghost applies to a generic subprogram
17083 elsif Nkind (Context) = N_Generic_Subprogram_Declaration then
17084 Id := Defining_Entity (Specification (Context));
17090 ("pragma % must apply to an object, package, subprogram or "
17095 -- Handle completions of types and constants that are subject to
17098 if Is_Record_Type (Id) or else Ekind (Id) = E_Constant then
17099 Prev_Id := Incomplete_Or_Partial_View (Id);
17101 if Present (Prev_Id) and then not Is_Ghost_Entity (Prev_Id) then
17102 Error_Msg_Name_1 := Pname;
17104 -- The full declaration of a deferred constant cannot be
17105 -- subject to pragma Ghost unless the deferred declaration
17106 -- is also Ghost (SPARK RM 6.9(9)).
17108 if Ekind (Prev_Id) = E_Constant then
17109 Error_Msg_Name_1 := Pname;
17110 Error_Msg_NE (Fix_Error
17111 ("pragma % must apply to declaration of deferred "
17112 & "constant &"), N, Id);
17115 -- Pragma Ghost may appear on the full view of an incomplete
17116 -- type because the incomplete declaration lacks aspects and
17117 -- cannot be subject to pragma Ghost.
17119 elsif Ekind (Prev_Id) = E_Incomplete_Type then
17122 -- The full declaration of a type cannot be subject to
17123 -- pragma Ghost unless the partial view is also Ghost
17124 -- (SPARK RM 6.9(9)).
17127 Error_Msg_NE (Fix_Error
17128 ("pragma % must apply to partial view of type &"),
17134 -- A synchronized object cannot be subject to pragma Ghost
17135 -- (SPARK RM 6.9(19)).
17137 elsif Ekind (Id) = E_Variable then
17138 if Is_Protected_Type (Etype (Id)) then
17139 Error_Pragma ("pragma % cannot apply to a protected object");
17142 elsif Is_Task_Type (Etype (Id)) then
17143 Error_Pragma ("pragma % cannot apply to a task object");
17148 -- Analyze the Boolean expression (if any)
17150 if Present (Arg1) then
17151 Expr := Get_Pragma_Arg (Arg1);
17153 Analyze_And_Resolve (Expr, Standard_Boolean);
17155 if Is_OK_Static_Expression (Expr) then
17157 -- "Ghostness" cannot be turned off once enabled within a
17158 -- region (SPARK RM 6.9(6)).
17160 if Is_False (Expr_Value (Expr))
17161 and then Ghost_Mode > None
17164 ("pragma % with value False cannot appear in enabled "
17169 -- Otherwie the expression is not static
17173 ("expression of pragma % must be static", Expr);
17178 Set_Is_Ghost_Entity (Id);
17185 -- pragma Global (GLOBAL_SPECIFICATION);
17187 -- GLOBAL_SPECIFICATION ::=
17190 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
17192 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
17194 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
17195 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
17196 -- GLOBAL_ITEM ::= NAME
17198 -- Characteristics:
17200 -- * Analysis - The annotation undergoes initial checks to verify
17201 -- the legal placement and context. Secondary checks fully analyze
17202 -- the dependency clauses in:
17204 -- Analyze_Global_In_Decl_Part
17206 -- * Expansion - None.
17208 -- * Template - The annotation utilizes the generic template of the
17209 -- related subprogram [body] when it is:
17211 -- aspect on subprogram declaration
17212 -- aspect on stand-alone subprogram body
17213 -- pragma on stand-alone subprogram body
17215 -- The annotation must prepare its own template when it is:
17217 -- pragma on subprogram declaration
17219 -- * Globals - Capture of global references must occur after full
17222 -- * Instance - The annotation is instantiated automatically when
17223 -- the related generic subprogram [body] is instantiated except for
17224 -- the "pragma on subprogram declaration" case. In that scenario
17225 -- the annotation must instantiate itself.
17227 when Pragma_Global => Global : declare
17229 Spec_Id : Entity_Id;
17230 Subp_Decl : Node_Id;
17233 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
17237 -- Chain the pragma on the contract for further processing by
17238 -- Analyze_Global_In_Decl_Part.
17240 Add_Contract_Item (N, Spec_Id);
17242 -- Fully analyze the pragma when it appears inside an entry
17243 -- or subprogram body because it cannot benefit from forward
17246 if Nkind_In (Subp_Decl, N_Entry_Body,
17248 N_Subprogram_Body_Stub)
17250 -- The legality checks of pragmas Depends and Global are
17251 -- affected by the SPARK mode in effect and the volatility
17252 -- of the context. In addition these two pragmas are subject
17253 -- to an inherent order:
17258 -- Analyze all these pragmas in the order outlined above
17260 Analyze_If_Present (Pragma_SPARK_Mode);
17261 Analyze_If_Present (Pragma_Volatile_Function);
17262 Analyze_Global_In_Decl_Part (N);
17263 Analyze_If_Present (Pragma_Depends);
17272 -- pragma Ident (static_string_EXPRESSION)
17274 -- Note: pragma Comment shares this processing. Pragma Ident is
17275 -- identical in effect to pragma Commment.
17277 when Pragma_Comment
17285 Check_Arg_Count (1);
17286 Check_No_Identifiers;
17287 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
17290 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
17297 GP := Parent (Parent (N));
17299 if Nkind_In (GP, N_Package_Declaration,
17300 N_Generic_Package_Declaration)
17305 -- If we have a compilation unit, then record the ident value,
17306 -- checking for improper duplication.
17308 if Nkind (GP) = N_Compilation_Unit then
17309 CS := Ident_String (Current_Sem_Unit);
17311 if Present (CS) then
17313 -- If we have multiple instances, concatenate them, but
17314 -- not in ASIS, where we want the original tree.
17316 if not ASIS_Mode then
17317 Start_String (Strval (CS));
17318 Store_String_Char (' ');
17319 Store_String_Chars (Strval (Str));
17320 Set_Strval (CS, End_String);
17324 Set_Ident_String (Current_Sem_Unit, Str);
17327 -- For subunits, we just ignore the Ident, since in GNAT these
17328 -- are not separate object files, and hence not separate units
17329 -- in the unit table.
17331 elsif Nkind (GP) = N_Subunit then
17337 -------------------
17338 -- Ignore_Pragma --
17339 -------------------
17341 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
17343 -- Entirely handled in the parser, nothing to do here
17345 when Pragma_Ignore_Pragma =>
17348 ----------------------------
17349 -- Implementation_Defined --
17350 ----------------------------
17352 -- pragma Implementation_Defined (LOCAL_NAME);
17354 -- Marks previously declared entity as implementation defined. For
17355 -- an overloaded entity, applies to the most recent homonym.
17357 -- pragma Implementation_Defined;
17359 -- The form with no arguments appears anywhere within a scope, most
17360 -- typically a package spec, and indicates that all entities that are
17361 -- defined within the package spec are Implementation_Defined.
17363 when Pragma_Implementation_Defined => Implementation_Defined : declare
17368 Check_No_Identifiers;
17370 -- Form with no arguments
17372 if Arg_Count = 0 then
17373 Set_Is_Implementation_Defined (Current_Scope);
17375 -- Form with one argument
17378 Check_Arg_Count (1);
17379 Check_Arg_Is_Local_Name (Arg1);
17380 Ent := Entity (Get_Pragma_Arg (Arg1));
17381 Set_Is_Implementation_Defined (Ent);
17383 end Implementation_Defined;
17389 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
17391 -- IMPLEMENTATION_KIND ::=
17392 -- By_Entry | By_Protected_Procedure | By_Any | Optional
17394 -- "By_Any" and "Optional" are treated as synonyms in order to
17395 -- support Ada 2012 aspect Synchronization.
17397 when Pragma_Implemented => Implemented : declare
17398 Proc_Id : Entity_Id;
17403 Check_Arg_Count (2);
17404 Check_No_Identifiers;
17405 Check_Arg_Is_Identifier (Arg1);
17406 Check_Arg_Is_Local_Name (Arg1);
17407 Check_Arg_Is_One_Of (Arg2,
17410 Name_By_Protected_Procedure,
17413 -- Extract the name of the local procedure
17415 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
17417 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
17418 -- primitive procedure of a synchronized tagged type.
17420 if Ekind (Proc_Id) = E_Procedure
17421 and then Is_Primitive (Proc_Id)
17422 and then Present (First_Formal (Proc_Id))
17424 Typ := Etype (First_Formal (Proc_Id));
17426 if Is_Tagged_Type (Typ)
17429 -- Check for a protected, a synchronized or a task interface
17431 ((Is_Interface (Typ)
17432 and then Is_Synchronized_Interface (Typ))
17434 -- Check for a protected type or a task type that implements
17438 (Is_Concurrent_Record_Type (Typ)
17439 and then Present (Interfaces (Typ)))
17441 -- In analysis-only mode, examine original protected type
17444 (Nkind (Parent (Typ)) = N_Protected_Type_Declaration
17445 and then Present (Interface_List (Parent (Typ))))
17447 -- Check for a private record extension with keyword
17451 (Ekind_In (Typ, E_Record_Type_With_Private,
17452 E_Record_Subtype_With_Private)
17453 and then Synchronized_Present (Parent (Typ))))
17458 ("controlling formal must be of synchronized tagged type",
17463 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
17464 -- By_Protected_Procedure to the primitive procedure of a task
17467 if Chars (Arg2) = Name_By_Protected_Procedure
17468 and then Is_Interface (Typ)
17469 and then Is_Task_Interface (Typ)
17472 ("implementation kind By_Protected_Procedure cannot be "
17473 & "applied to a task interface primitive", Arg2);
17477 -- Procedures declared inside a protected type must be accepted
17479 elsif Ekind (Proc_Id) = E_Procedure
17480 and then Is_Protected_Type (Scope (Proc_Id))
17484 -- The first argument is not a primitive procedure
17488 ("pragma % must be applied to a primitive procedure", Arg1);
17492 Record_Rep_Item (Proc_Id, N);
17495 ----------------------
17496 -- Implicit_Packing --
17497 ----------------------
17499 -- pragma Implicit_Packing;
17501 when Pragma_Implicit_Packing =>
17503 Check_Arg_Count (0);
17504 Implicit_Packing := True;
17511 -- [Convention =>] convention_IDENTIFIER,
17512 -- [Entity =>] LOCAL_NAME
17513 -- [, [External_Name =>] static_string_EXPRESSION ]
17514 -- [, [Link_Name =>] static_string_EXPRESSION ]);
17516 when Pragma_Import =>
17517 Check_Ada_83_Warning;
17521 Name_External_Name,
17524 Check_At_Least_N_Arguments (2);
17525 Check_At_Most_N_Arguments (4);
17526 Process_Import_Or_Interface;
17528 ---------------------
17529 -- Import_Function --
17530 ---------------------
17532 -- pragma Import_Function (
17533 -- [Internal =>] LOCAL_NAME,
17534 -- [, [External =>] EXTERNAL_SYMBOL]
17535 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17536 -- [, [Result_Type =>] SUBTYPE_MARK]
17537 -- [, [Mechanism =>] MECHANISM]
17538 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
17540 -- EXTERNAL_SYMBOL ::=
17542 -- | static_string_EXPRESSION
17544 -- PARAMETER_TYPES ::=
17546 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17548 -- TYPE_DESIGNATOR ::=
17550 -- | subtype_Name ' Access
17554 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17556 -- MECHANISM_ASSOCIATION ::=
17557 -- [formal_parameter_NAME =>] MECHANISM_NAME
17559 -- MECHANISM_NAME ::=
17563 when Pragma_Import_Function => Import_Function : declare
17564 Args : Args_List (1 .. 6);
17565 Names : constant Name_List (1 .. 6) := (
17568 Name_Parameter_Types,
17571 Name_Result_Mechanism);
17573 Internal : Node_Id renames Args (1);
17574 External : Node_Id renames Args (2);
17575 Parameter_Types : Node_Id renames Args (3);
17576 Result_Type : Node_Id renames Args (4);
17577 Mechanism : Node_Id renames Args (5);
17578 Result_Mechanism : Node_Id renames Args (6);
17582 Gather_Associations (Names, Args);
17583 Process_Extended_Import_Export_Subprogram_Pragma (
17584 Arg_Internal => Internal,
17585 Arg_External => External,
17586 Arg_Parameter_Types => Parameter_Types,
17587 Arg_Result_Type => Result_Type,
17588 Arg_Mechanism => Mechanism,
17589 Arg_Result_Mechanism => Result_Mechanism);
17590 end Import_Function;
17592 -------------------
17593 -- Import_Object --
17594 -------------------
17596 -- pragma Import_Object (
17597 -- [Internal =>] LOCAL_NAME
17598 -- [, [External =>] EXTERNAL_SYMBOL]
17599 -- [, [Size =>] EXTERNAL_SYMBOL]);
17601 -- EXTERNAL_SYMBOL ::=
17603 -- | static_string_EXPRESSION
17605 when Pragma_Import_Object => Import_Object : declare
17606 Args : Args_List (1 .. 3);
17607 Names : constant Name_List (1 .. 3) := (
17612 Internal : Node_Id renames Args (1);
17613 External : Node_Id renames Args (2);
17614 Size : Node_Id renames Args (3);
17618 Gather_Associations (Names, Args);
17619 Process_Extended_Import_Export_Object_Pragma (
17620 Arg_Internal => Internal,
17621 Arg_External => External,
17625 ----------------------
17626 -- Import_Procedure --
17627 ----------------------
17629 -- pragma Import_Procedure (
17630 -- [Internal =>] LOCAL_NAME
17631 -- [, [External =>] EXTERNAL_SYMBOL]
17632 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17633 -- [, [Mechanism =>] MECHANISM]);
17635 -- EXTERNAL_SYMBOL ::=
17637 -- | static_string_EXPRESSION
17639 -- PARAMETER_TYPES ::=
17641 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17643 -- TYPE_DESIGNATOR ::=
17645 -- | subtype_Name ' Access
17649 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17651 -- MECHANISM_ASSOCIATION ::=
17652 -- [formal_parameter_NAME =>] MECHANISM_NAME
17654 -- MECHANISM_NAME ::=
17658 when Pragma_Import_Procedure => Import_Procedure : declare
17659 Args : Args_List (1 .. 4);
17660 Names : constant Name_List (1 .. 4) := (
17663 Name_Parameter_Types,
17666 Internal : Node_Id renames Args (1);
17667 External : Node_Id renames Args (2);
17668 Parameter_Types : Node_Id renames Args (3);
17669 Mechanism : Node_Id renames Args (4);
17673 Gather_Associations (Names, Args);
17674 Process_Extended_Import_Export_Subprogram_Pragma (
17675 Arg_Internal => Internal,
17676 Arg_External => External,
17677 Arg_Parameter_Types => Parameter_Types,
17678 Arg_Mechanism => Mechanism);
17679 end Import_Procedure;
17681 -----------------------------
17682 -- Import_Valued_Procedure --
17683 -----------------------------
17685 -- pragma Import_Valued_Procedure (
17686 -- [Internal =>] LOCAL_NAME
17687 -- [, [External =>] EXTERNAL_SYMBOL]
17688 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17689 -- [, [Mechanism =>] MECHANISM]);
17691 -- EXTERNAL_SYMBOL ::=
17693 -- | static_string_EXPRESSION
17695 -- PARAMETER_TYPES ::=
17697 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17699 -- TYPE_DESIGNATOR ::=
17701 -- | subtype_Name ' Access
17705 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17707 -- MECHANISM_ASSOCIATION ::=
17708 -- [formal_parameter_NAME =>] MECHANISM_NAME
17710 -- MECHANISM_NAME ::=
17714 when Pragma_Import_Valued_Procedure =>
17715 Import_Valued_Procedure : declare
17716 Args : Args_List (1 .. 4);
17717 Names : constant Name_List (1 .. 4) := (
17720 Name_Parameter_Types,
17723 Internal : Node_Id renames Args (1);
17724 External : Node_Id renames Args (2);
17725 Parameter_Types : Node_Id renames Args (3);
17726 Mechanism : Node_Id renames Args (4);
17730 Gather_Associations (Names, Args);
17731 Process_Extended_Import_Export_Subprogram_Pragma (
17732 Arg_Internal => Internal,
17733 Arg_External => External,
17734 Arg_Parameter_Types => Parameter_Types,
17735 Arg_Mechanism => Mechanism);
17736 end Import_Valued_Procedure;
17742 -- pragma Independent (LOCAL_NAME);
17744 when Pragma_Independent =>
17745 Process_Atomic_Independent_Shared_Volatile;
17747 ----------------------------
17748 -- Independent_Components --
17749 ----------------------------
17751 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
17753 when Pragma_Independent_Components => Independent_Components : declare
17761 Check_Ada_83_Warning;
17763 Check_No_Identifiers;
17764 Check_Arg_Count (1);
17765 Check_Arg_Is_Local_Name (Arg1);
17766 E_Id := Get_Pragma_Arg (Arg1);
17768 if Etype (E_Id) = Any_Type then
17772 E := Entity (E_Id);
17774 -- A record type with a self-referential component of anonymous
17775 -- access type is given an incomplete view in order to handle the
17778 -- type Rec is record
17779 -- Self : access Rec;
17785 -- type Ptr is access Rec;
17786 -- type Rec is record
17790 -- Since the incomplete view is now the initial view of the type,
17791 -- the argument of the pragma will reference the incomplete view,
17792 -- but this view is illegal according to the semantics of the
17795 -- Obtain the full view of an internally-generated incomplete type
17796 -- only. This way an attempt to associate the pragma with a source
17797 -- incomplete type is still caught.
17799 if Ekind (E) = E_Incomplete_Type
17800 and then not Comes_From_Source (E)
17801 and then Present (Full_View (E))
17803 E := Full_View (E);
17806 -- A pragma that applies to a Ghost entity becomes Ghost for the
17807 -- purposes of legality checks and removal of ignored Ghost code.
17809 Mark_Ghost_Pragma (N, E);
17811 -- Check duplicate before we chain ourselves
17813 Check_Duplicate_Pragma (E);
17815 -- Check appropriate entity
17817 if Rep_Item_Too_Early (E, N)
17819 Rep_Item_Too_Late (E, N)
17824 D := Declaration_Node (E);
17827 -- The flag is set on the base type, or on the object
17829 if K = N_Full_Type_Declaration
17830 and then (Is_Array_Type (E) or else Is_Record_Type (E))
17832 Set_Has_Independent_Components (Base_Type (E));
17833 Record_Independence_Check (N, Base_Type (E));
17835 -- For record type, set all components independent
17837 if Is_Record_Type (E) then
17838 C := First_Component (E);
17839 while Present (C) loop
17840 Set_Is_Independent (C);
17841 Next_Component (C);
17845 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
17846 and then Nkind (D) = N_Object_Declaration
17847 and then Nkind (Object_Definition (D)) =
17848 N_Constrained_Array_Definition
17850 Set_Has_Independent_Components (E);
17851 Record_Independence_Check (N, E);
17854 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
17856 end Independent_Components;
17858 -----------------------
17859 -- Initial_Condition --
17860 -----------------------
17862 -- pragma Initial_Condition (boolean_EXPRESSION);
17864 -- Characteristics:
17866 -- * Analysis - The annotation undergoes initial checks to verify
17867 -- the legal placement and context. Secondary checks preanalyze the
17870 -- Analyze_Initial_Condition_In_Decl_Part
17872 -- * Expansion - The annotation is expanded during the expansion of
17873 -- the package body whose declaration is subject to the annotation
17876 -- Expand_Pragma_Initial_Condition
17878 -- * Template - The annotation utilizes the generic template of the
17879 -- related package declaration.
17881 -- * Globals - Capture of global references must occur after full
17884 -- * Instance - The annotation is instantiated automatically when
17885 -- the related generic package is instantiated.
17887 when Pragma_Initial_Condition => Initial_Condition : declare
17888 Pack_Decl : Node_Id;
17889 Pack_Id : Entity_Id;
17893 Check_No_Identifiers;
17894 Check_Arg_Count (1);
17896 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
17898 if not Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
17899 N_Package_Declaration)
17905 Pack_Id := Defining_Entity (Pack_Decl);
17907 -- A pragma that applies to a Ghost entity becomes Ghost for the
17908 -- purposes of legality checks and removal of ignored Ghost code.
17910 Mark_Ghost_Pragma (N, Pack_Id);
17912 -- Chain the pragma on the contract for further processing by
17913 -- Analyze_Initial_Condition_In_Decl_Part.
17915 Add_Contract_Item (N, Pack_Id);
17917 -- The legality checks of pragmas Abstract_State, Initializes, and
17918 -- Initial_Condition are affected by the SPARK mode in effect. In
17919 -- addition, these three pragmas are subject to an inherent order:
17921 -- 1) Abstract_State
17923 -- 3) Initial_Condition
17925 -- Analyze all these pragmas in the order outlined above
17927 Analyze_If_Present (Pragma_SPARK_Mode);
17928 Analyze_If_Present (Pragma_Abstract_State);
17929 Analyze_If_Present (Pragma_Initializes);
17930 end Initial_Condition;
17932 ------------------------
17933 -- Initialize_Scalars --
17934 ------------------------
17936 -- pragma Initialize_Scalars
17937 -- [ ( TYPE_VALUE_PAIR {, TYPE_VALUE_PAIR} ) ];
17939 -- TYPE_VALUE_PAIR ::=
17940 -- SCALAR_TYPE => static_EXPRESSION
17946 -- | Long_Long_Flat
17956 when Pragma_Initialize_Scalars => Do_Initialize_Scalars : declare
17957 Seen : array (Scalar_Id) of Node_Id := (others => Empty);
17958 -- This collection holds the individual pairs which specify the
17959 -- invalid values of their respective scalar types.
17961 procedure Analyze_Float_Value
17962 (Scal_Typ : Float_Scalar_Id;
17963 Val_Expr : Node_Id);
17964 -- Analyze a type value pair associated with float type Scal_Typ
17965 -- and expression Val_Expr.
17967 procedure Analyze_Integer_Value
17968 (Scal_Typ : Integer_Scalar_Id;
17969 Val_Expr : Node_Id);
17970 -- Analyze a type value pair associated with integer type Scal_Typ
17971 -- and expression Val_Expr.
17973 procedure Analyze_Type_Value_Pair (Pair : Node_Id);
17974 -- Analyze type value pair Pair
17976 -------------------------
17977 -- Analyze_Float_Value --
17978 -------------------------
17980 procedure Analyze_Float_Value
17981 (Scal_Typ : Float_Scalar_Id;
17982 Val_Expr : Node_Id)
17985 Analyze_And_Resolve (Val_Expr, Any_Real);
17987 if Is_OK_Static_Expression (Val_Expr) then
17988 Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value_R (Val_Expr));
17991 Error_Msg_Name_1 := Scal_Typ;
17992 Error_Msg_N ("value for type % must be static", Val_Expr);
17994 end Analyze_Float_Value;
17996 ---------------------------
17997 -- Analyze_Integer_Value --
17998 ---------------------------
18000 procedure Analyze_Integer_Value
18001 (Scal_Typ : Integer_Scalar_Id;
18002 Val_Expr : Node_Id)
18005 Analyze_And_Resolve (Val_Expr, Any_Integer);
18007 if Is_OK_Static_Expression (Val_Expr) then
18008 Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value (Val_Expr));
18011 Error_Msg_Name_1 := Scal_Typ;
18012 Error_Msg_N ("value for type % must be static", Val_Expr);
18014 end Analyze_Integer_Value;
18016 -----------------------------
18017 -- Analyze_Type_Value_Pair --
18018 -----------------------------
18020 procedure Analyze_Type_Value_Pair (Pair : Node_Id) is
18021 Scal_Typ : constant Name_Id := Chars (Pair);
18022 Val_Expr : constant Node_Id := Expression (Pair);
18023 Prev_Pair : Node_Id;
18026 if Scal_Typ in Scalar_Id then
18027 Prev_Pair := Seen (Scal_Typ);
18029 -- Prevent multiple attempts to set a value for a scalar
18032 if Present (Prev_Pair) then
18033 Error_Msg_Name_1 := Scal_Typ;
18035 ("cannot specify multiple invalid values for type %",
18038 Error_Msg_Sloc := Sloc (Prev_Pair);
18039 Error_Msg_N ("previous value set #", Pair);
18041 -- Ignore the effects of the pair, but do not halt the
18042 -- analysis of the pragma altogether.
18046 -- Otherwise capture the first pair for this scalar type
18049 Seen (Scal_Typ) := Pair;
18052 if Scal_Typ in Float_Scalar_Id then
18053 Analyze_Float_Value (Scal_Typ, Val_Expr);
18055 else pragma Assert (Scal_Typ in Integer_Scalar_Id);
18056 Analyze_Integer_Value (Scal_Typ, Val_Expr);
18059 -- Otherwise the scalar family is illegal
18062 Error_Msg_Name_1 := Pname;
18064 ("argument of pragma % must denote valid scalar family",
18067 end Analyze_Type_Value_Pair;
18071 Pairs : constant List_Id := Pragma_Argument_Associations (N);
18074 -- Start of processing for Do_Initialize_Scalars
18078 Check_Valid_Configuration_Pragma;
18079 Check_Restriction (No_Initialize_Scalars, N);
18081 -- Ignore the effects of the pragma when No_Initialize_Scalars is
18084 if Restriction_Active (No_Initialize_Scalars) then
18087 -- Initialize_Scalars creates false positives in CodePeer, and
18088 -- incorrect negative results in GNATprove mode, so ignore this
18089 -- pragma in these modes.
18091 elsif CodePeer_Mode or GNATprove_Mode then
18094 -- Otherwise analyze the pragma
18097 if Present (Pairs) then
18099 -- Install Standard in order to provide access to primitive
18100 -- types in case the expressions contain attributes such as
18103 Push_Scope (Standard_Standard);
18105 Pair := First (Pairs);
18106 while Present (Pair) loop
18107 Analyze_Type_Value_Pair (Pair);
18116 Init_Or_Norm_Scalars := True;
18117 Initialize_Scalars := True;
18119 end Do_Initialize_Scalars;
18125 -- pragma Initializes (INITIALIZATION_LIST);
18127 -- INITIALIZATION_LIST ::=
18129 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
18131 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
18136 -- | (INPUT {, INPUT})
18140 -- Characteristics:
18142 -- * Analysis - The annotation undergoes initial checks to verify
18143 -- the legal placement and context. Secondary checks preanalyze the
18146 -- Analyze_Initializes_In_Decl_Part
18148 -- * Expansion - None.
18150 -- * Template - The annotation utilizes the generic template of the
18151 -- related package declaration.
18153 -- * Globals - Capture of global references must occur after full
18156 -- * Instance - The annotation is instantiated automatically when
18157 -- the related generic package is instantiated.
18159 when Pragma_Initializes => Initializes : declare
18160 Pack_Decl : Node_Id;
18161 Pack_Id : Entity_Id;
18165 Check_No_Identifiers;
18166 Check_Arg_Count (1);
18168 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
18170 if not Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
18171 N_Package_Declaration)
18177 Pack_Id := Defining_Entity (Pack_Decl);
18179 -- A pragma that applies to a Ghost entity becomes Ghost for the
18180 -- purposes of legality checks and removal of ignored Ghost code.
18182 Mark_Ghost_Pragma (N, Pack_Id);
18183 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
18185 -- Chain the pragma on the contract for further processing by
18186 -- Analyze_Initializes_In_Decl_Part.
18188 Add_Contract_Item (N, Pack_Id);
18190 -- The legality checks of pragmas Abstract_State, Initializes, and
18191 -- Initial_Condition are affected by the SPARK mode in effect. In
18192 -- addition, these three pragmas are subject to an inherent order:
18194 -- 1) Abstract_State
18196 -- 3) Initial_Condition
18198 -- Analyze all these pragmas in the order outlined above
18200 Analyze_If_Present (Pragma_SPARK_Mode);
18201 Analyze_If_Present (Pragma_Abstract_State);
18202 Analyze_If_Present (Pragma_Initial_Condition);
18209 -- pragma Inline ( NAME {, NAME} );
18211 when Pragma_Inline =>
18213 -- Pragma always active unless in GNATprove mode. It is disabled
18214 -- in GNATprove mode because frontend inlining is applied
18215 -- independently of pragmas Inline and Inline_Always for
18216 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
18219 if not GNATprove_Mode then
18221 -- Inline status is Enabled if option -gnatn is specified.
18222 -- However this status determines only the value of the
18223 -- Is_Inlined flag on the subprogram and does not prevent
18224 -- the pragma itself from being recorded for later use,
18225 -- in particular for a later modification of Is_Inlined
18226 -- independently of the -gnatn option.
18228 -- In other words, if -gnatn is specified for a unit, then
18229 -- all Inline pragmas processed for the compilation of this
18230 -- unit, including those in the spec of other units, are
18231 -- activated, so subprograms will be inlined across units.
18233 -- If -gnatn is not specified, no Inline pragma is activated
18234 -- here, which means that subprograms will not be inlined
18235 -- across units. The Is_Inlined flag will nevertheless be
18236 -- set later when bodies are analyzed, so subprograms will
18237 -- be inlined within the unit.
18239 if Inline_Active then
18240 Process_Inline (Enabled);
18242 Process_Inline (Disabled);
18246 -------------------
18247 -- Inline_Always --
18248 -------------------
18250 -- pragma Inline_Always ( NAME {, NAME} );
18252 when Pragma_Inline_Always =>
18255 -- Pragma always active unless in CodePeer mode or GNATprove
18256 -- mode. It is disabled in CodePeer mode because inlining is
18257 -- not helpful, and enabling it caused walk order issues. It
18258 -- is disabled in GNATprove mode because frontend inlining is
18259 -- applied independently of pragmas Inline and Inline_Always for
18260 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
18263 if not CodePeer_Mode and not GNATprove_Mode then
18264 Process_Inline (Enabled);
18267 --------------------
18268 -- Inline_Generic --
18269 --------------------
18271 -- pragma Inline_Generic (NAME {, NAME});
18273 when Pragma_Inline_Generic =>
18275 Process_Generic_List;
18277 ----------------------
18278 -- Inspection_Point --
18279 ----------------------
18281 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
18283 when Pragma_Inspection_Point => Inspection_Point : declare
18290 if Arg_Count > 0 then
18293 Exp := Get_Pragma_Arg (Arg);
18296 if not Is_Entity_Name (Exp)
18297 or else not Is_Object (Entity (Exp))
18299 Error_Pragma_Arg ("object name required", Arg);
18303 exit when No (Arg);
18306 end Inspection_Point;
18312 -- pragma Interface (
18313 -- [ Convention =>] convention_IDENTIFIER,
18314 -- [ Entity =>] LOCAL_NAME
18315 -- [, [External_Name =>] static_string_EXPRESSION ]
18316 -- [, [Link_Name =>] static_string_EXPRESSION ]);
18318 when Pragma_Interface =>
18323 Name_External_Name,
18325 Check_At_Least_N_Arguments (2);
18326 Check_At_Most_N_Arguments (4);
18327 Process_Import_Or_Interface;
18329 -- In Ada 2005, the permission to use Interface (a reserved word)
18330 -- as a pragma name is considered an obsolescent feature, and this
18331 -- pragma was already obsolescent in Ada 95.
18333 if Ada_Version >= Ada_95 then
18335 (No_Obsolescent_Features, Pragma_Identifier (N));
18337 if Warn_On_Obsolescent_Feature then
18339 ("pragma Interface is an obsolescent feature?j?", N);
18341 ("|use pragma Import instead?j?", N);
18345 --------------------
18346 -- Interface_Name --
18347 --------------------
18349 -- pragma Interface_Name (
18350 -- [ Entity =>] LOCAL_NAME
18351 -- [,[External_Name =>] static_string_EXPRESSION ]
18352 -- [,[Link_Name =>] static_string_EXPRESSION ]);
18354 when Pragma_Interface_Name => Interface_Name : declare
18356 Def_Id : Entity_Id;
18357 Hom_Id : Entity_Id;
18363 ((Name_Entity, Name_External_Name, Name_Link_Name));
18364 Check_At_Least_N_Arguments (2);
18365 Check_At_Most_N_Arguments (3);
18366 Id := Get_Pragma_Arg (Arg1);
18369 -- This is obsolete from Ada 95 on, but it is an implementation
18370 -- defined pragma, so we do not consider that it violates the
18371 -- restriction (No_Obsolescent_Features).
18373 if Ada_Version >= Ada_95 then
18374 if Warn_On_Obsolescent_Feature then
18376 ("pragma Interface_Name is an obsolescent feature?j?", N);
18378 ("|use pragma Import instead?j?", N);
18382 if not Is_Entity_Name (Id) then
18384 ("first argument for pragma% must be entity name", Arg1);
18385 elsif Etype (Id) = Any_Type then
18388 Def_Id := Entity (Id);
18391 -- Special DEC-compatible processing for the object case, forces
18392 -- object to be imported.
18394 if Ekind (Def_Id) = E_Variable then
18395 Kill_Size_Check_Code (Def_Id);
18396 Note_Possible_Modification (Id, Sure => False);
18398 -- Initialization is not allowed for imported variable
18400 if Present (Expression (Parent (Def_Id)))
18401 and then Comes_From_Source (Expression (Parent (Def_Id)))
18403 Error_Msg_Sloc := Sloc (Def_Id);
18405 ("no initialization allowed for declaration of& #",
18409 -- For compatibility, support VADS usage of providing both
18410 -- pragmas Interface and Interface_Name to obtain the effect
18411 -- of a single Import pragma.
18413 if Is_Imported (Def_Id)
18414 and then Present (First_Rep_Item (Def_Id))
18415 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
18416 and then Pragma_Name (First_Rep_Item (Def_Id)) =
18421 Set_Imported (Def_Id);
18424 Set_Is_Public (Def_Id);
18425 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
18428 -- Otherwise must be subprogram
18430 elsif not Is_Subprogram (Def_Id) then
18432 ("argument of pragma% is not subprogram", Arg1);
18435 Check_At_Most_N_Arguments (3);
18439 -- Loop through homonyms
18442 Def_Id := Get_Base_Subprogram (Hom_Id);
18444 if Is_Imported (Def_Id) then
18445 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
18449 exit when From_Aspect_Specification (N);
18450 Hom_Id := Homonym (Hom_Id);
18452 exit when No (Hom_Id)
18453 or else Scope (Hom_Id) /= Current_Scope;
18458 ("argument of pragma% is not imported subprogram",
18462 end Interface_Name;
18464 -----------------------
18465 -- Interrupt_Handler --
18466 -----------------------
18468 -- pragma Interrupt_Handler (handler_NAME);
18470 when Pragma_Interrupt_Handler =>
18471 Check_Ada_83_Warning;
18472 Check_Arg_Count (1);
18473 Check_No_Identifiers;
18475 if No_Run_Time_Mode then
18476 Error_Msg_CRT ("Interrupt_Handler pragma", N);
18478 Check_Interrupt_Or_Attach_Handler;
18479 Process_Interrupt_Or_Attach_Handler;
18482 ------------------------
18483 -- Interrupt_Priority --
18484 ------------------------
18486 -- pragma Interrupt_Priority [(EXPRESSION)];
18488 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
18489 P : constant Node_Id := Parent (N);
18494 Check_Ada_83_Warning;
18496 if Arg_Count /= 0 then
18497 Arg := Get_Pragma_Arg (Arg1);
18498 Check_Arg_Count (1);
18499 Check_No_Identifiers;
18501 -- The expression must be analyzed in the special manner
18502 -- described in "Handling of Default and Per-Object
18503 -- Expressions" in sem.ads.
18505 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
18508 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
18513 Ent := Defining_Identifier (Parent (P));
18515 -- Check duplicate pragma before we chain the pragma in the Rep
18516 -- Item chain of Ent.
18518 Check_Duplicate_Pragma (Ent);
18519 Record_Rep_Item (Ent, N);
18521 -- Check the No_Task_At_Interrupt_Priority restriction
18523 if Nkind (P) = N_Task_Definition then
18524 Check_Restriction (No_Task_At_Interrupt_Priority, N);
18527 end Interrupt_Priority;
18529 ---------------------
18530 -- Interrupt_State --
18531 ---------------------
18533 -- pragma Interrupt_State (
18534 -- [Name =>] INTERRUPT_ID,
18535 -- [State =>] INTERRUPT_STATE);
18537 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
18538 -- INTERRUPT_STATE => System | Runtime | User
18540 -- Note: if the interrupt id is given as an identifier, then it must
18541 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
18542 -- given as a static integer expression which must be in the range of
18543 -- Ada.Interrupts.Interrupt_ID.
18545 when Pragma_Interrupt_State => Interrupt_State : declare
18546 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
18547 -- This is the entity Ada.Interrupts.Interrupt_ID;
18549 State_Type : Character;
18550 -- Set to 's'/'r'/'u' for System/Runtime/User
18553 -- Index to entry in Interrupt_States table
18556 -- Value of interrupt
18558 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
18559 -- The first argument to the pragma
18561 Int_Ent : Entity_Id;
18562 -- Interrupt entity in Ada.Interrupts.Names
18566 Check_Arg_Order ((Name_Name, Name_State));
18567 Check_Arg_Count (2);
18569 Check_Optional_Identifier (Arg1, Name_Name);
18570 Check_Optional_Identifier (Arg2, Name_State);
18571 Check_Arg_Is_Identifier (Arg2);
18573 -- First argument is identifier
18575 if Nkind (Arg1X) = N_Identifier then
18577 -- Search list of names in Ada.Interrupts.Names
18579 Int_Ent := First_Entity (RTE (RE_Names));
18581 if No (Int_Ent) then
18582 Error_Pragma_Arg ("invalid interrupt name", Arg1);
18584 elsif Chars (Int_Ent) = Chars (Arg1X) then
18585 Int_Val := Expr_Value (Constant_Value (Int_Ent));
18589 Next_Entity (Int_Ent);
18592 -- First argument is not an identifier, so it must be a static
18593 -- expression of type Ada.Interrupts.Interrupt_ID.
18596 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
18597 Int_Val := Expr_Value (Arg1X);
18599 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
18601 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
18604 ("value not in range of type "
18605 & """Ada.Interrupts.Interrupt_'I'D""", Arg1);
18611 case Chars (Get_Pragma_Arg (Arg2)) is
18612 when Name_Runtime => State_Type := 'r';
18613 when Name_System => State_Type := 's';
18614 when Name_User => State_Type := 'u';
18617 Error_Pragma_Arg ("invalid interrupt state", Arg2);
18620 -- Check if entry is already stored
18622 IST_Num := Interrupt_States.First;
18624 -- If entry not found, add it
18626 if IST_Num > Interrupt_States.Last then
18627 Interrupt_States.Append
18628 ((Interrupt_Number => UI_To_Int (Int_Val),
18629 Interrupt_State => State_Type,
18630 Pragma_Loc => Loc));
18633 -- Case of entry for the same entry
18635 elsif Int_Val = Interrupt_States.Table (IST_Num).
18638 -- If state matches, done, no need to make redundant entry
18641 State_Type = Interrupt_States.Table (IST_Num).
18644 -- Otherwise if state does not match, error
18647 Interrupt_States.Table (IST_Num).Pragma_Loc;
18649 ("state conflicts with that given #", Arg2);
18653 IST_Num := IST_Num + 1;
18655 end Interrupt_State;
18661 -- pragma Invariant
18662 -- ([Entity =>] type_LOCAL_NAME,
18663 -- [Check =>] EXPRESSION
18664 -- [,[Message =>] String_Expression]);
18666 when Pragma_Invariant => Invariant : declare
18673 Check_At_Least_N_Arguments (2);
18674 Check_At_Most_N_Arguments (3);
18675 Check_Optional_Identifier (Arg1, Name_Entity);
18676 Check_Optional_Identifier (Arg2, Name_Check);
18678 if Arg_Count = 3 then
18679 Check_Optional_Identifier (Arg3, Name_Message);
18680 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
18683 Check_Arg_Is_Local_Name (Arg1);
18685 Typ_Arg := Get_Pragma_Arg (Arg1);
18686 Find_Type (Typ_Arg);
18687 Typ := Entity (Typ_Arg);
18689 -- Nothing to do of the related type is erroneous in some way
18691 if Typ = Any_Type then
18694 -- AI12-0041: Invariants are allowed in interface types
18696 elsif Is_Interface (Typ) then
18699 -- An invariant must apply to a private type, or appear in the
18700 -- private part of a package spec and apply to a completion.
18701 -- a class-wide invariant can only appear on a private declaration
18702 -- or private extension, not a completion.
18704 -- A [class-wide] invariant may be associated a [limited] private
18705 -- type or a private extension.
18707 elsif Ekind_In (Typ, E_Limited_Private_Type,
18709 E_Record_Type_With_Private)
18713 -- A non-class-wide invariant may be associated with the full view
18714 -- of a [limited] private type or a private extension.
18716 elsif Has_Private_Declaration (Typ)
18717 and then not Class_Present (N)
18721 -- A class-wide invariant may appear on the partial view only
18723 elsif Class_Present (N) then
18725 ("pragma % only allowed for private type", Arg1);
18728 -- A regular invariant may appear on both views
18732 ("pragma % only allowed for private type or corresponding "
18733 & "full view", Arg1);
18737 -- An invariant associated with an abstract type (this includes
18738 -- interfaces) must be class-wide.
18740 if Is_Abstract_Type (Typ) and then not Class_Present (N) then
18742 ("pragma % not allowed for abstract type", Arg1);
18746 -- A pragma that applies to a Ghost entity becomes Ghost for the
18747 -- purposes of legality checks and removal of ignored Ghost code.
18749 Mark_Ghost_Pragma (N, Typ);
18751 -- The pragma defines a type-specific invariant, the type is said
18752 -- to have invariants of its "own".
18754 Set_Has_Own_Invariants (Typ);
18756 -- If the invariant is class-wide, then it can be inherited by
18757 -- derived or interface implementing types. The type is said to
18758 -- have "inheritable" invariants.
18760 if Class_Present (N) then
18761 Set_Has_Inheritable_Invariants (Typ);
18764 -- Chain the pragma on to the rep item chain, for processing when
18765 -- the type is frozen.
18767 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
18769 -- Create the declaration of the invariant procedure that will
18770 -- verify the invariant at run time. Interfaces are treated as the
18771 -- partial view of a private type in order to achieve uniformity
18772 -- with the general case. As a result, an interface receives only
18773 -- a "partial" invariant procedure, which is never called.
18775 Build_Invariant_Procedure_Declaration
18777 Partial_Invariant => Is_Interface (Typ));
18784 -- pragma Keep_Names ([On => ] LOCAL_NAME);
18786 when Pragma_Keep_Names => Keep_Names : declare
18791 Check_Arg_Count (1);
18792 Check_Optional_Identifier (Arg1, Name_On);
18793 Check_Arg_Is_Local_Name (Arg1);
18795 Arg := Get_Pragma_Arg (Arg1);
18798 if Etype (Arg) = Any_Type then
18802 if not Is_Entity_Name (Arg)
18803 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
18806 ("pragma% requires a local enumeration type", Arg1);
18809 Set_Discard_Names (Entity (Arg), False);
18816 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
18818 when Pragma_License =>
18821 -- Do not analyze pragma any further in CodePeer mode, to avoid
18822 -- extraneous errors in this implementation-dependent pragma,
18823 -- which has a different profile on other compilers.
18825 if CodePeer_Mode then
18829 Check_Arg_Count (1);
18830 Check_No_Identifiers;
18831 Check_Valid_Configuration_Pragma;
18832 Check_Arg_Is_Identifier (Arg1);
18835 Sind : constant Source_File_Index :=
18836 Source_Index (Current_Sem_Unit);
18839 case Chars (Get_Pragma_Arg (Arg1)) is
18841 Set_License (Sind, GPL);
18843 when Name_Modified_GPL =>
18844 Set_License (Sind, Modified_GPL);
18846 when Name_Restricted =>
18847 Set_License (Sind, Restricted);
18849 when Name_Unrestricted =>
18850 Set_License (Sind, Unrestricted);
18853 Error_Pragma_Arg ("invalid license name", Arg1);
18861 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
18863 when Pragma_Link_With => Link_With : declare
18869 if Operating_Mode = Generate_Code
18870 and then In_Extended_Main_Source_Unit (N)
18872 Check_At_Least_N_Arguments (1);
18873 Check_No_Identifiers;
18874 Check_Is_In_Decl_Part_Or_Package_Spec;
18875 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
18879 while Present (Arg) loop
18880 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
18882 -- Store argument, converting sequences of spaces to a
18883 -- single null character (this is one of the differences
18884 -- in processing between Link_With and Linker_Options).
18886 Arg_Store : declare
18887 C : constant Char_Code := Get_Char_Code (' ');
18888 S : constant String_Id :=
18889 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
18890 L : constant Nat := String_Length (S);
18893 procedure Skip_Spaces;
18894 -- Advance F past any spaces
18900 procedure Skip_Spaces is
18902 while F <= L and then Get_String_Char (S, F) = C loop
18907 -- Start of processing for Arg_Store
18910 Skip_Spaces; -- skip leading spaces
18912 -- Loop through characters, changing any embedded
18913 -- sequence of spaces to a single null character (this
18914 -- is how Link_With/Linker_Options differ)
18917 if Get_String_Char (S, F) = C then
18920 Store_String_Char (ASCII.NUL);
18923 Store_String_Char (Get_String_Char (S, F));
18931 if Present (Arg) then
18932 Store_String_Char (ASCII.NUL);
18936 Store_Linker_Option_String (End_String);
18944 -- pragma Linker_Alias (
18945 -- [Entity =>] LOCAL_NAME
18946 -- [Target =>] static_string_EXPRESSION);
18948 when Pragma_Linker_Alias =>
18950 Check_Arg_Order ((Name_Entity, Name_Target));
18951 Check_Arg_Count (2);
18952 Check_Optional_Identifier (Arg1, Name_Entity);
18953 Check_Optional_Identifier (Arg2, Name_Target);
18954 Check_Arg_Is_Library_Level_Local_Name (Arg1);
18955 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
18957 -- The only processing required is to link this item on to the
18958 -- list of rep items for the given entity. This is accomplished
18959 -- by the call to Rep_Item_Too_Late (when no error is detected
18960 -- and False is returned).
18962 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
18965 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
18968 ------------------------
18969 -- Linker_Constructor --
18970 ------------------------
18972 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
18974 -- Code is shared with Linker_Destructor
18976 -----------------------
18977 -- Linker_Destructor --
18978 -----------------------
18980 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
18982 when Pragma_Linker_Constructor
18983 | Pragma_Linker_Destructor
18985 Linker_Constructor : declare
18991 Check_Arg_Count (1);
18992 Check_No_Identifiers;
18993 Check_Arg_Is_Local_Name (Arg1);
18994 Arg1_X := Get_Pragma_Arg (Arg1);
18996 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
18998 if not Is_Library_Level_Entity (Proc) then
19000 ("argument for pragma% must be library level entity", Arg1);
19003 -- The only processing required is to link this item on to the
19004 -- list of rep items for the given entity. This is accomplished
19005 -- by the call to Rep_Item_Too_Late (when no error is detected
19006 -- and False is returned).
19008 if Rep_Item_Too_Late (Proc, N) then
19011 Set_Has_Gigi_Rep_Item (Proc);
19013 end Linker_Constructor;
19015 --------------------
19016 -- Linker_Options --
19017 --------------------
19019 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
19021 when Pragma_Linker_Options => Linker_Options : declare
19025 Check_Ada_83_Warning;
19026 Check_No_Identifiers;
19027 Check_Arg_Count (1);
19028 Check_Is_In_Decl_Part_Or_Package_Spec;
19029 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
19030 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
19033 while Present (Arg) loop
19034 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
19035 Store_String_Char (ASCII.NUL);
19037 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
19041 if Operating_Mode = Generate_Code
19042 and then In_Extended_Main_Source_Unit (N)
19044 Store_Linker_Option_String (End_String);
19046 end Linker_Options;
19048 --------------------
19049 -- Linker_Section --
19050 --------------------
19052 -- pragma Linker_Section (
19053 -- [Entity =>] LOCAL_NAME
19054 -- [Section =>] static_string_EXPRESSION);
19056 when Pragma_Linker_Section => Linker_Section : declare
19061 Ghost_Error_Posted : Boolean := False;
19062 -- Flag set when an error concerning the illegal mix of Ghost and
19063 -- non-Ghost subprograms is emitted.
19065 Ghost_Id : Entity_Id := Empty;
19066 -- The entity of the first Ghost subprogram encountered while
19067 -- processing the arguments of the pragma.
19071 Check_Arg_Order ((Name_Entity, Name_Section));
19072 Check_Arg_Count (2);
19073 Check_Optional_Identifier (Arg1, Name_Entity);
19074 Check_Optional_Identifier (Arg2, Name_Section);
19075 Check_Arg_Is_Library_Level_Local_Name (Arg1);
19076 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
19078 -- Check kind of entity
19080 Arg := Get_Pragma_Arg (Arg1);
19081 Ent := Entity (Arg);
19083 case Ekind (Ent) is
19085 -- Objects (constants and variables) and types. For these cases
19086 -- all we need to do is to set the Linker_Section_pragma field,
19087 -- checking that we do not have a duplicate.
19093 LPE := Linker_Section_Pragma (Ent);
19095 if Present (LPE) then
19096 Error_Msg_Sloc := Sloc (LPE);
19098 ("Linker_Section already specified for &#", Arg1, Ent);
19101 Set_Linker_Section_Pragma (Ent, N);
19103 -- A pragma that applies to a Ghost entity becomes Ghost for
19104 -- the purposes of legality checks and removal of ignored
19107 Mark_Ghost_Pragma (N, Ent);
19111 when Subprogram_Kind =>
19113 -- Aspect case, entity already set
19115 if From_Aspect_Specification (N) then
19116 Set_Linker_Section_Pragma
19117 (Entity (Corresponding_Aspect (N)), N);
19119 -- Pragma case, we must climb the homonym chain, but skip
19120 -- any for which the linker section is already set.
19124 if No (Linker_Section_Pragma (Ent)) then
19125 Set_Linker_Section_Pragma (Ent, N);
19127 -- A pragma that applies to a Ghost entity becomes
19128 -- Ghost for the purposes of legality checks and
19129 -- removal of ignored Ghost code.
19131 Mark_Ghost_Pragma (N, Ent);
19133 -- Capture the entity of the first Ghost subprogram
19134 -- being processed for error detection purposes.
19136 if Is_Ghost_Entity (Ent) then
19137 if No (Ghost_Id) then
19141 -- Otherwise the subprogram is non-Ghost. It is
19142 -- illegal to mix references to Ghost and non-Ghost
19143 -- entities (SPARK RM 6.9).
19145 elsif Present (Ghost_Id)
19146 and then not Ghost_Error_Posted
19148 Ghost_Error_Posted := True;
19150 Error_Msg_Name_1 := Pname;
19152 ("pragma % cannot mention ghost and "
19153 & "non-ghost subprograms", N);
19155 Error_Msg_Sloc := Sloc (Ghost_Id);
19157 ("\& # declared as ghost", N, Ghost_Id);
19159 Error_Msg_Sloc := Sloc (Ent);
19161 ("\& # declared as non-ghost", N, Ent);
19165 Ent := Homonym (Ent);
19167 or else Scope (Ent) /= Current_Scope;
19171 -- All other cases are illegal
19175 ("pragma% applies only to objects, subprograms, and types",
19178 end Linker_Section;
19184 -- pragma List (On | Off)
19186 -- There is nothing to do here, since we did all the processing for
19187 -- this pragma in Par.Prag (so that it works properly even in syntax
19190 when Pragma_List =>
19197 -- pragma Lock_Free [(Boolean_EXPRESSION)];
19199 when Pragma_Lock_Free => Lock_Free : declare
19200 P : constant Node_Id := Parent (N);
19206 Check_No_Identifiers;
19207 Check_At_Most_N_Arguments (1);
19209 -- Protected definition case
19211 if Nkind (P) = N_Protected_Definition then
19212 Ent := Defining_Identifier (Parent (P));
19216 if Arg_Count = 1 then
19217 Arg := Get_Pragma_Arg (Arg1);
19218 Val := Is_True (Static_Boolean (Arg));
19220 -- No arguments (expression is considered to be True)
19226 -- Check duplicate pragma before we chain the pragma in the Rep
19227 -- Item chain of Ent.
19229 Check_Duplicate_Pragma (Ent);
19230 Record_Rep_Item (Ent, N);
19231 Set_Uses_Lock_Free (Ent, Val);
19233 -- Anything else is incorrect placement
19240 --------------------
19241 -- Locking_Policy --
19242 --------------------
19244 -- pragma Locking_Policy (policy_IDENTIFIER);
19246 when Pragma_Locking_Policy => declare
19247 subtype LP_Range is Name_Id
19248 range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
19253 Check_Ada_83_Warning;
19254 Check_Arg_Count (1);
19255 Check_No_Identifiers;
19256 Check_Arg_Is_Locking_Policy (Arg1);
19257 Check_Valid_Configuration_Pragma;
19258 LP_Val := Chars (Get_Pragma_Arg (Arg1));
19261 when Name_Ceiling_Locking => LP := 'C';
19262 when Name_Concurrent_Readers_Locking => LP := 'R';
19263 when Name_Inheritance_Locking => LP := 'I';
19266 if Locking_Policy /= ' '
19267 and then Locking_Policy /= LP
19269 Error_Msg_Sloc := Locking_Policy_Sloc;
19270 Error_Pragma ("locking policy incompatible with policy#");
19272 -- Set new policy, but always preserve System_Location since we
19273 -- like the error message with the run time name.
19276 Locking_Policy := LP;
19278 if Locking_Policy_Sloc /= System_Location then
19279 Locking_Policy_Sloc := Loc;
19284 -------------------
19285 -- Loop_Optimize --
19286 -------------------
19288 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
19290 -- OPTIMIZATION_HINT ::=
19291 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
19293 when Pragma_Loop_Optimize => Loop_Optimize : declare
19298 Check_At_Least_N_Arguments (1);
19299 Check_No_Identifiers;
19301 Hint := First (Pragma_Argument_Associations (N));
19302 while Present (Hint) loop
19303 Check_Arg_Is_One_Of (Hint, Name_Ivdep,
19311 Check_Loop_Pragma_Placement;
19318 -- pragma Loop_Variant
19319 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
19321 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
19323 -- CHANGE_DIRECTION ::= Increases | Decreases
19325 when Pragma_Loop_Variant => Loop_Variant : declare
19330 Check_At_Least_N_Arguments (1);
19331 Check_Loop_Pragma_Placement;
19333 -- Process all increasing / decreasing expressions
19335 Variant := First (Pragma_Argument_Associations (N));
19336 while Present (Variant) loop
19337 if Chars (Variant) = No_Name then
19338 Error_Pragma_Arg_Ident ("expect name `Increases`", Variant);
19340 elsif not Nam_In (Chars (Variant), Name_Decreases,
19344 Name : String := Get_Name_String (Chars (Variant));
19347 -- It is a common mistake to write "Increasing" for
19348 -- "Increases" or "Decreasing" for "Decreases". Recognize
19349 -- specially names starting with "incr" or "decr" to
19350 -- suggest the corresponding name.
19352 System.Case_Util.To_Lower (Name);
19354 if Name'Length >= 4
19355 and then Name (1 .. 4) = "incr"
19357 Error_Pragma_Arg_Ident
19358 ("expect name `Increases`", Variant);
19360 elsif Name'Length >= 4
19361 and then Name (1 .. 4) = "decr"
19363 Error_Pragma_Arg_Ident
19364 ("expect name `Decreases`", Variant);
19367 Error_Pragma_Arg_Ident
19368 ("expect name `Increases` or `Decreases`", Variant);
19373 Preanalyze_Assert_Expression
19374 (Expression (Variant), Any_Discrete);
19380 -----------------------
19381 -- Machine_Attribute --
19382 -----------------------
19384 -- pragma Machine_Attribute (
19385 -- [Entity =>] LOCAL_NAME,
19386 -- [Attribute_Name =>] static_string_EXPRESSION
19387 -- [, [Info =>] static_EXPRESSION {, static_EXPRESSION}] );
19389 when Pragma_Machine_Attribute => Machine_Attribute : declare
19391 Def_Id : Entity_Id;
19395 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
19397 if Arg_Count >= 3 then
19398 Check_Optional_Identifier (Arg3, Name_Info);
19400 while Present (Arg) loop
19401 Check_Arg_Is_OK_Static_Expression (Arg);
19405 Check_Arg_Count (2);
19408 Check_Optional_Identifier (Arg1, Name_Entity);
19409 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
19410 Check_Arg_Is_Local_Name (Arg1);
19411 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
19412 Def_Id := Entity (Get_Pragma_Arg (Arg1));
19414 if Is_Access_Type (Def_Id) then
19415 Def_Id := Designated_Type (Def_Id);
19418 if Rep_Item_Too_Early (Def_Id, N) then
19422 Def_Id := Underlying_Type (Def_Id);
19424 -- The only processing required is to link this item on to the
19425 -- list of rep items for the given entity. This is accomplished
19426 -- by the call to Rep_Item_Too_Late (when no error is detected
19427 -- and False is returned).
19429 if Rep_Item_Too_Late (Def_Id, N) then
19432 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
19434 end Machine_Attribute;
19441 -- (MAIN_OPTION [, MAIN_OPTION]);
19444 -- [STACK_SIZE =>] static_integer_EXPRESSION
19445 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
19446 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
19448 when Pragma_Main => Main : declare
19449 Args : Args_List (1 .. 3);
19450 Names : constant Name_List (1 .. 3) := (
19452 Name_Task_Stack_Size_Default,
19453 Name_Time_Slicing_Enabled);
19459 Gather_Associations (Names, Args);
19461 for J in 1 .. 2 loop
19462 if Present (Args (J)) then
19463 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
19467 if Present (Args (3)) then
19468 Check_Arg_Is_OK_Static_Expression (Args (3), Standard_Boolean);
19472 while Present (Nod) loop
19473 if Nkind (Nod) = N_Pragma
19474 and then Pragma_Name (Nod) = Name_Main
19476 Error_Msg_Name_1 := Pname;
19477 Error_Msg_N ("duplicate pragma% not permitted", Nod);
19488 -- pragma Main_Storage
19489 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
19491 -- MAIN_STORAGE_OPTION ::=
19492 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
19493 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
19495 when Pragma_Main_Storage => Main_Storage : declare
19496 Args : Args_List (1 .. 2);
19497 Names : constant Name_List (1 .. 2) := (
19498 Name_Working_Storage,
19505 Gather_Associations (Names, Args);
19507 for J in 1 .. 2 loop
19508 if Present (Args (J)) then
19509 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
19513 Check_In_Main_Program;
19516 while Present (Nod) loop
19517 if Nkind (Nod) = N_Pragma
19518 and then Pragma_Name (Nod) = Name_Main_Storage
19520 Error_Msg_Name_1 := Pname;
19521 Error_Msg_N ("duplicate pragma% not permitted", Nod);
19528 ----------------------------
19529 -- Max_Entry_Queue_Length --
19530 ----------------------------
19532 -- pragma Max_Entry_Queue_Length (static_integer_EXPRESSION);
19534 -- This processing is shared by Pragma_Max_Entry_Queue_Depth and
19535 -- Pragma_Max_Queue_Length.
19537 when Pragma_Max_Entry_Queue_Length
19538 | Pragma_Max_Entry_Queue_Depth
19539 | Pragma_Max_Queue_Length
19541 Max_Entry_Queue_Length : declare
19543 Entry_Decl : Node_Id;
19544 Entry_Id : Entity_Id;
19548 if Prag_Id = Pragma_Max_Entry_Queue_Depth
19549 or else Prag_Id = Pragma_Max_Queue_Length
19554 Check_Arg_Count (1);
19557 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
19559 -- Entry declaration
19561 if Nkind (Entry_Decl) = N_Entry_Declaration then
19563 -- Entry illegally within a task
19565 if Nkind (Parent (N)) = N_Task_Definition then
19566 Error_Pragma ("pragma % cannot apply to task entries");
19570 Entry_Id := Defining_Entity (Entry_Decl);
19572 -- Otherwise the pragma is associated with an illegal construct
19575 Error_Pragma ("pragma % must apply to a protected entry");
19579 -- Mark the pragma as Ghost if the related subprogram is also
19580 -- Ghost. This also ensures that any expansion performed further
19581 -- below will produce Ghost nodes.
19583 Mark_Ghost_Pragma (N, Entry_Id);
19585 -- Analyze the Integer expression
19587 Arg := Get_Pragma_Arg (Arg1);
19588 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
19590 Val := Expr_Value (Arg);
19594 ("argument for pragma% cannot be less than -1", Arg1);
19596 elsif not UI_Is_In_Int_Range (Val) then
19598 ("argument for pragma% out of range of Integer", Arg1);
19602 Record_Rep_Item (Entry_Id, N);
19603 end Max_Entry_Queue_Length;
19609 -- pragma Memory_Size (NUMERIC_LITERAL)
19611 when Pragma_Memory_Size =>
19614 -- Memory size is simply ignored
19616 Check_No_Identifiers;
19617 Check_Arg_Count (1);
19618 Check_Arg_Is_Integer_Literal (Arg1);
19626 -- The only correct use of this pragma is on its own in a file, in
19627 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
19628 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
19629 -- check for a file containing nothing but a No_Body pragma). If we
19630 -- attempt to process it during normal semantics processing, it means
19631 -- it was misplaced.
19633 when Pragma_No_Body =>
19637 -----------------------------
19638 -- No_Elaboration_Code_All --
19639 -----------------------------
19641 -- pragma No_Elaboration_Code_All;
19643 when Pragma_No_Elaboration_Code_All =>
19645 Check_Valid_Library_Unit_Pragma;
19647 if Nkind (N) = N_Null_Statement then
19651 -- Must appear for a spec or generic spec
19653 if not Nkind_In (Unit (Cunit (Current_Sem_Unit)),
19654 N_Generic_Package_Declaration,
19655 N_Generic_Subprogram_Declaration,
19656 N_Package_Declaration,
19657 N_Subprogram_Declaration)
19661 ("pragma% can only occur for package "
19662 & "or subprogram spec"));
19665 -- Set flag in unit table
19667 Set_No_Elab_Code_All (Current_Sem_Unit);
19669 -- Set restriction No_Elaboration_Code if this is the main unit
19671 if Current_Sem_Unit = Main_Unit then
19672 Set_Restriction (No_Elaboration_Code, N);
19675 -- If we are in the main unit or in an extended main source unit,
19676 -- then we also add it to the configuration restrictions so that
19677 -- it will apply to all units in the extended main source.
19679 if Current_Sem_Unit = Main_Unit
19680 or else In_Extended_Main_Source_Unit (N)
19682 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
19685 -- If in main extended unit, activate transitive with test
19687 if In_Extended_Main_Source_Unit (N) then
19688 Opt.No_Elab_Code_All_Pragma := N;
19691 -----------------------------
19692 -- No_Component_Reordering --
19693 -----------------------------
19695 -- pragma No_Component_Reordering [([Entity =>] type_LOCAL_NAME)];
19697 when Pragma_No_Component_Reordering => No_Comp_Reordering : declare
19703 Check_At_Most_N_Arguments (1);
19705 if Arg_Count = 0 then
19706 Check_Valid_Configuration_Pragma;
19707 Opt.No_Component_Reordering := True;
19710 Check_Optional_Identifier (Arg2, Name_Entity);
19711 Check_Arg_Is_Local_Name (Arg1);
19712 E_Id := Get_Pragma_Arg (Arg1);
19714 if Etype (E_Id) = Any_Type then
19718 E := Entity (E_Id);
19720 if not Is_Record_Type (E) then
19721 Error_Pragma_Arg ("pragma% requires record type", Arg1);
19724 Set_No_Reordering (Base_Type (E));
19726 end No_Comp_Reordering;
19728 --------------------------
19729 -- No_Heap_Finalization --
19730 --------------------------
19732 -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];
19734 when Pragma_No_Heap_Finalization => No_Heap_Finalization : declare
19735 Context : constant Node_Id := Parent (N);
19736 Typ_Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
19742 Check_No_Identifiers;
19744 -- The pragma appears in a configuration file
19746 if No (Context) then
19747 Check_Arg_Count (0);
19748 Check_Valid_Configuration_Pragma;
19750 -- Detect a duplicate pragma
19752 if Present (No_Heap_Finalization_Pragma) then
19755 Prev => No_Heap_Finalization_Pragma);
19759 No_Heap_Finalization_Pragma := N;
19761 -- Otherwise the pragma should be associated with a library-level
19762 -- named access-to-object type.
19765 Check_Arg_Count (1);
19766 Check_Arg_Is_Local_Name (Arg1);
19768 Find_Type (Typ_Arg);
19769 Typ := Entity (Typ_Arg);
19771 -- The type being subjected to the pragma is erroneous
19773 if Typ = Any_Type then
19774 Error_Pragma ("cannot find type referenced by pragma %");
19776 -- The pragma is applied to an incomplete or generic formal
19777 -- type way too early.
19779 elsif Rep_Item_Too_Early (Typ, N) then
19783 Typ := Underlying_Type (Typ);
19786 -- The pragma must apply to an access-to-object type
19788 if Ekind_In (Typ, E_Access_Type, E_General_Access_Type) then
19791 -- Give a detailed error message on all other access type kinds
19793 elsif Ekind (Typ) = E_Access_Protected_Subprogram_Type then
19795 ("pragma % cannot apply to access protected subprogram "
19798 elsif Ekind (Typ) = E_Access_Subprogram_Type then
19800 ("pragma % cannot apply to access subprogram type");
19802 elsif Is_Anonymous_Access_Type (Typ) then
19804 ("pragma % cannot apply to anonymous access type");
19806 -- Give a general error message in case the pragma applies to a
19807 -- non-access type.
19811 ("pragma % must apply to library level access type");
19814 -- At this point the argument denotes an access-to-object type.
19815 -- Ensure that the type is declared at the library level.
19817 if Is_Library_Level_Entity (Typ) then
19820 -- Quietly ignore an access-to-object type originally declared
19821 -- at the library level within a generic, but instantiated at
19822 -- a non-library level. As a result the access-to-object type
19823 -- "loses" its No_Heap_Finalization property.
19825 elsif In_Instance then
19830 ("pragma % must apply to library level access type");
19833 -- Detect a duplicate pragma
19835 if Present (No_Heap_Finalization_Pragma) then
19838 Prev => No_Heap_Finalization_Pragma);
19842 Prev := Get_Pragma (Typ, Pragma_No_Heap_Finalization);
19844 if Present (Prev) then
19852 Record_Rep_Item (Typ, N);
19854 end No_Heap_Finalization;
19860 -- pragma No_Inline ( NAME {, NAME} );
19862 when Pragma_No_Inline =>
19864 Process_Inline (Suppressed);
19870 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
19872 when Pragma_No_Return => No_Return : declare
19878 Ghost_Error_Posted : Boolean := False;
19879 -- Flag set when an error concerning the illegal mix of Ghost and
19880 -- non-Ghost subprograms is emitted.
19882 Ghost_Id : Entity_Id := Empty;
19883 -- The entity of the first Ghost procedure encountered while
19884 -- processing the arguments of the pragma.
19888 Check_At_Least_N_Arguments (1);
19890 -- Loop through arguments of pragma
19893 while Present (Arg) loop
19894 Check_Arg_Is_Local_Name (Arg);
19895 Id := Get_Pragma_Arg (Arg);
19898 if not Is_Entity_Name (Id) then
19899 Error_Pragma_Arg ("entity name required", Arg);
19902 if Etype (Id) = Any_Type then
19906 -- Loop to find matching procedures
19912 and then Scope (E) = Current_Scope
19914 if Ekind_In (E, E_Generic_Procedure, E_Procedure) then
19916 -- Check that the pragma is not applied to a body.
19917 -- First check the specless body case, to give a
19918 -- different error message. These checks do not apply
19919 -- if Relaxed_RM_Semantics, to accommodate other Ada
19920 -- compilers. Disable these checks under -gnatd.J.
19922 if not Debug_Flag_Dot_JJ then
19923 if Nkind (Parent (Declaration_Node (E))) =
19925 and then not Relaxed_RM_Semantics
19928 ("pragma% requires separate spec and must come "
19932 -- Now the "specful" body case
19934 if Rep_Item_Too_Late (E, N) then
19941 -- A pragma that applies to a Ghost entity becomes Ghost
19942 -- for the purposes of legality checks and removal of
19943 -- ignored Ghost code.
19945 Mark_Ghost_Pragma (N, E);
19947 -- Capture the entity of the first Ghost procedure being
19948 -- processed for error detection purposes.
19950 if Is_Ghost_Entity (E) then
19951 if No (Ghost_Id) then
19955 -- Otherwise the subprogram is non-Ghost. It is illegal
19956 -- to mix references to Ghost and non-Ghost entities
19959 elsif Present (Ghost_Id)
19960 and then not Ghost_Error_Posted
19962 Ghost_Error_Posted := True;
19964 Error_Msg_Name_1 := Pname;
19966 ("pragma % cannot mention ghost and non-ghost "
19967 & "procedures", N);
19969 Error_Msg_Sloc := Sloc (Ghost_Id);
19970 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
19972 Error_Msg_Sloc := Sloc (E);
19973 Error_Msg_NE ("\& # declared as non-ghost", N, E);
19976 -- Set flag on any alias as well
19978 if Is_Overloadable (E) and then Present (Alias (E)) then
19979 Set_No_Return (Alias (E));
19985 exit when From_Aspect_Specification (N);
19989 -- If entity in not in current scope it may be the enclosing
19990 -- suprogram body to which the aspect applies.
19993 if Entity (Id) = Current_Scope
19994 and then From_Aspect_Specification (N)
19996 Set_No_Return (Entity (Id));
19998 Error_Pragma_Arg ("no procedure& found for pragma%", Arg);
20010 -- pragma No_Run_Time;
20012 -- Note: this pragma is retained for backwards compatibility. See
20013 -- body of Rtsfind for full details on its handling.
20015 when Pragma_No_Run_Time =>
20017 Check_Valid_Configuration_Pragma;
20018 Check_Arg_Count (0);
20020 -- Remove backward compatibility if Build_Type is FSF or GPL and
20021 -- generate a warning.
20024 Ignore : constant Boolean := Build_Type in FSF .. GPL;
20027 Error_Pragma ("pragma% is ignored, has no effect??");
20029 No_Run_Time_Mode := True;
20030 Configurable_Run_Time_Mode := True;
20032 -- Set Duration to 32 bits if word size is 32
20034 if Ttypes.System_Word_Size = 32 then
20035 Duration_32_Bits_On_Target := True;
20038 -- Set appropriate restrictions
20040 Set_Restriction (No_Finalization, N);
20041 Set_Restriction (No_Exception_Handlers, N);
20042 Set_Restriction (Max_Tasks, N, 0);
20043 Set_Restriction (No_Tasking, N);
20047 -----------------------
20048 -- No_Tagged_Streams --
20049 -----------------------
20051 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
20053 when Pragma_No_Tagged_Streams => No_Tagged_Strms : declare
20059 Check_At_Most_N_Arguments (1);
20061 -- One argument case
20063 if Arg_Count = 1 then
20064 Check_Optional_Identifier (Arg1, Name_Entity);
20065 Check_Arg_Is_Local_Name (Arg1);
20066 E_Id := Get_Pragma_Arg (Arg1);
20068 if Etype (E_Id) = Any_Type then
20072 E := Entity (E_Id);
20074 Check_Duplicate_Pragma (E);
20076 if not Is_Tagged_Type (E) or else Is_Derived_Type (E) then
20078 ("argument for pragma% must be root tagged type", Arg1);
20081 if Rep_Item_Too_Early (E, N)
20083 Rep_Item_Too_Late (E, N)
20087 Set_No_Tagged_Streams_Pragma (E, N);
20090 -- Zero argument case
20093 Check_Is_In_Decl_Part_Or_Package_Spec;
20094 No_Tagged_Streams := N;
20096 end No_Tagged_Strms;
20098 ------------------------
20099 -- No_Strict_Aliasing --
20100 ------------------------
20102 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
20104 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
20110 Check_At_Most_N_Arguments (1);
20112 if Arg_Count = 0 then
20113 Check_Valid_Configuration_Pragma;
20114 Opt.No_Strict_Aliasing := True;
20117 Check_Optional_Identifier (Arg2, Name_Entity);
20118 Check_Arg_Is_Local_Name (Arg1);
20119 E_Id := Get_Pragma_Arg (Arg1);
20121 if Etype (E_Id) = Any_Type then
20125 E := Entity (E_Id);
20127 if not Is_Access_Type (E) then
20128 Error_Pragma_Arg ("pragma% requires access type", Arg1);
20131 Set_No_Strict_Aliasing (Base_Type (E));
20133 end No_Strict_Aliasing;
20135 -----------------------
20136 -- Normalize_Scalars --
20137 -----------------------
20139 -- pragma Normalize_Scalars;
20141 when Pragma_Normalize_Scalars =>
20142 Check_Ada_83_Warning;
20143 Check_Arg_Count (0);
20144 Check_Valid_Configuration_Pragma;
20146 -- Normalize_Scalars creates false positives in CodePeer, and
20147 -- incorrect negative results in GNATprove mode, so ignore this
20148 -- pragma in these modes.
20150 if not (CodePeer_Mode or GNATprove_Mode) then
20151 Normalize_Scalars := True;
20152 Init_Or_Norm_Scalars := True;
20159 -- pragma Obsolescent;
20161 -- pragma Obsolescent (
20162 -- [Message =>] static_string_EXPRESSION
20163 -- [,[Version =>] Ada_05]]);
20165 -- pragma Obsolescent (
20166 -- [Entity =>] NAME
20167 -- [,[Message =>] static_string_EXPRESSION
20168 -- [,[Version =>] Ada_05]] );
20170 when Pragma_Obsolescent => Obsolescent : declare
20174 procedure Set_Obsolescent (E : Entity_Id);
20175 -- Given an entity Ent, mark it as obsolescent if appropriate
20177 ---------------------
20178 -- Set_Obsolescent --
20179 ---------------------
20181 procedure Set_Obsolescent (E : Entity_Id) is
20190 -- A pragma that applies to a Ghost entity becomes Ghost for
20191 -- the purposes of legality checks and removal of ignored Ghost
20194 Mark_Ghost_Pragma (N, E);
20196 -- Entity name was given
20198 if Present (Ename) then
20200 -- If entity name matches, we are fine. Save entity in
20201 -- pragma argument, for ASIS use.
20203 if Chars (Ename) = Chars (Ent) then
20204 Set_Entity (Ename, Ent);
20205 Generate_Reference (Ent, Ename);
20207 -- If entity name does not match, only possibility is an
20208 -- enumeration literal from an enumeration type declaration.
20210 elsif Ekind (Ent) /= E_Enumeration_Type then
20212 ("pragma % entity name does not match declaration");
20215 Ent := First_Literal (E);
20219 ("pragma % entity name does not match any "
20220 & "enumeration literal");
20222 elsif Chars (Ent) = Chars (Ename) then
20223 Set_Entity (Ename, Ent);
20224 Generate_Reference (Ent, Ename);
20228 Ent := Next_Literal (Ent);
20234 -- Ent points to entity to be marked
20236 if Arg_Count >= 1 then
20238 -- Deal with static string argument
20240 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
20241 S := Strval (Get_Pragma_Arg (Arg1));
20243 for J in 1 .. String_Length (S) loop
20244 if not In_Character_Range (Get_String_Char (S, J)) then
20246 ("pragma% argument does not allow wide characters",
20251 Obsolescent_Warnings.Append
20252 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
20254 -- Check for Ada_05 parameter
20256 if Arg_Count /= 1 then
20257 Check_Arg_Count (2);
20260 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
20263 Check_Arg_Is_Identifier (Argx);
20265 if Chars (Argx) /= Name_Ada_05 then
20266 Error_Msg_Name_2 := Name_Ada_05;
20268 ("only allowed argument for pragma% is %", Argx);
20271 if Ada_Version_Explicit < Ada_2005
20272 or else not Warn_On_Ada_2005_Compatibility
20280 -- Set flag if pragma active
20283 Set_Is_Obsolescent (Ent);
20287 end Set_Obsolescent;
20289 -- Start of processing for pragma Obsolescent
20294 Check_At_Most_N_Arguments (3);
20296 -- See if first argument specifies an entity name
20300 (Chars (Arg1) = Name_Entity
20302 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
20304 N_Operator_Symbol))
20306 Ename := Get_Pragma_Arg (Arg1);
20308 -- Eliminate first argument, so we can share processing
20312 Arg_Count := Arg_Count - 1;
20314 -- No Entity name argument given
20320 if Arg_Count >= 1 then
20321 Check_Optional_Identifier (Arg1, Name_Message);
20323 if Arg_Count = 2 then
20324 Check_Optional_Identifier (Arg2, Name_Version);
20328 -- Get immediately preceding declaration
20331 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
20335 -- Cases where we do not follow anything other than another pragma
20339 -- First case: library level compilation unit declaration with
20340 -- the pragma immediately following the declaration.
20342 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
20344 (Defining_Entity (Unit (Parent (Parent (N)))));
20347 -- Case 2: library unit placement for package
20351 Ent : constant Entity_Id := Find_Lib_Unit_Name;
20353 if Is_Package_Or_Generic_Package (Ent) then
20354 Set_Obsolescent (Ent);
20360 -- Cases where we must follow a declaration, including an
20361 -- abstract subprogram declaration, which is not in the
20362 -- other node subtypes.
20365 if Nkind (Decl) not in N_Declaration
20366 and then Nkind (Decl) not in N_Later_Decl_Item
20367 and then Nkind (Decl) not in N_Generic_Declaration
20368 and then Nkind (Decl) not in N_Renaming_Declaration
20369 and then Nkind (Decl) /= N_Abstract_Subprogram_Declaration
20372 ("pragma% misplaced, "
20373 & "must immediately follow a declaration");
20376 Set_Obsolescent (Defining_Entity (Decl));
20386 -- pragma Optimize (Time | Space | Off);
20388 -- The actual check for optimize is done in Gigi. Note that this
20389 -- pragma does not actually change the optimization setting, it
20390 -- simply checks that it is consistent with the pragma.
20392 when Pragma_Optimize =>
20393 Check_No_Identifiers;
20394 Check_Arg_Count (1);
20395 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
20397 ------------------------
20398 -- Optimize_Alignment --
20399 ------------------------
20401 -- pragma Optimize_Alignment (Time | Space | Off);
20403 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
20405 Check_No_Identifiers;
20406 Check_Arg_Count (1);
20407 Check_Valid_Configuration_Pragma;
20410 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
20413 when Name_Off => Opt.Optimize_Alignment := 'O';
20414 when Name_Space => Opt.Optimize_Alignment := 'S';
20415 when Name_Time => Opt.Optimize_Alignment := 'T';
20418 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
20422 -- Set indication that mode is set locally. If we are in fact in a
20423 -- configuration pragma file, this setting is harmless since the
20424 -- switch will get reset anyway at the start of each unit.
20426 Optimize_Alignment_Local := True;
20427 end Optimize_Alignment;
20433 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
20435 when Pragma_Ordered => Ordered : declare
20436 Assoc : constant Node_Id := Arg1;
20442 Check_No_Identifiers;
20443 Check_Arg_Count (1);
20444 Check_Arg_Is_Local_Name (Arg1);
20446 Type_Id := Get_Pragma_Arg (Assoc);
20447 Find_Type (Type_Id);
20448 Typ := Entity (Type_Id);
20450 if Typ = Any_Type then
20453 Typ := Underlying_Type (Typ);
20456 if not Is_Enumeration_Type (Typ) then
20457 Error_Pragma ("pragma% must specify enumeration type");
20460 Check_First_Subtype (Arg1);
20461 Set_Has_Pragma_Ordered (Base_Type (Typ));
20464 -------------------
20465 -- Overflow_Mode --
20466 -------------------
20468 -- pragma Overflow_Mode
20469 -- ([General => ] MODE [, [Assertions => ] MODE]);
20471 -- MODE := STRICT | MINIMIZED | ELIMINATED
20473 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
20474 -- since System.Bignums makes this assumption. This is true of nearly
20475 -- all (all?) targets.
20477 when Pragma_Overflow_Mode => Overflow_Mode : declare
20478 function Get_Overflow_Mode
20480 Arg : Node_Id) return Overflow_Mode_Type;
20481 -- Function to process one pragma argument, Arg. If an identifier
20482 -- is present, it must be Name. Mode type is returned if a valid
20483 -- argument exists, otherwise an error is signalled.
20485 -----------------------
20486 -- Get_Overflow_Mode --
20487 -----------------------
20489 function Get_Overflow_Mode
20491 Arg : Node_Id) return Overflow_Mode_Type
20493 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
20496 Check_Optional_Identifier (Arg, Name);
20497 Check_Arg_Is_Identifier (Argx);
20499 if Chars (Argx) = Name_Strict then
20502 elsif Chars (Argx) = Name_Minimized then
20505 elsif Chars (Argx) = Name_Eliminated then
20506 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then
20508 ("Eliminated not implemented on this target", Argx);
20514 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
20516 end Get_Overflow_Mode;
20518 -- Start of processing for Overflow_Mode
20522 Check_At_Least_N_Arguments (1);
20523 Check_At_Most_N_Arguments (2);
20525 -- Process first argument
20527 Scope_Suppress.Overflow_Mode_General :=
20528 Get_Overflow_Mode (Name_General, Arg1);
20530 -- Case of only one argument
20532 if Arg_Count = 1 then
20533 Scope_Suppress.Overflow_Mode_Assertions :=
20534 Scope_Suppress.Overflow_Mode_General;
20536 -- Case of two arguments present
20539 Scope_Suppress.Overflow_Mode_Assertions :=
20540 Get_Overflow_Mode (Name_Assertions, Arg2);
20544 --------------------------
20545 -- Overriding Renamings --
20546 --------------------------
20548 -- pragma Overriding_Renamings;
20550 when Pragma_Overriding_Renamings =>
20552 Check_Arg_Count (0);
20553 Check_Valid_Configuration_Pragma;
20554 Overriding_Renamings := True;
20560 -- pragma Pack (first_subtype_LOCAL_NAME);
20562 when Pragma_Pack => Pack : declare
20563 Assoc : constant Node_Id := Arg1;
20565 Ignore : Boolean := False;
20570 Check_No_Identifiers;
20571 Check_Arg_Count (1);
20572 Check_Arg_Is_Local_Name (Arg1);
20573 Type_Id := Get_Pragma_Arg (Assoc);
20575 if not Is_Entity_Name (Type_Id)
20576 or else not Is_Type (Entity (Type_Id))
20579 ("argument for pragma% must be type or subtype", Arg1);
20582 Find_Type (Type_Id);
20583 Typ := Entity (Type_Id);
20586 or else Rep_Item_Too_Early (Typ, N)
20590 Typ := Underlying_Type (Typ);
20593 -- A pragma that applies to a Ghost entity becomes Ghost for the
20594 -- purposes of legality checks and removal of ignored Ghost code.
20596 Mark_Ghost_Pragma (N, Typ);
20598 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
20599 Error_Pragma ("pragma% must specify array or record type");
20602 Check_First_Subtype (Arg1);
20603 Check_Duplicate_Pragma (Typ);
20607 if Is_Array_Type (Typ) then
20608 Ctyp := Component_Type (Typ);
20610 -- Ignore pack that does nothing
20612 if Known_Static_Esize (Ctyp)
20613 and then Known_Static_RM_Size (Ctyp)
20614 and then Esize (Ctyp) = RM_Size (Ctyp)
20615 and then Addressable (Esize (Ctyp))
20620 -- Process OK pragma Pack. Note that if there is a separate
20621 -- component clause present, the Pack will be cancelled. This
20622 -- processing is in Freeze.
20624 if not Rep_Item_Too_Late (Typ, N) then
20626 -- In CodePeer mode, we do not need complex front-end
20627 -- expansions related to pragma Pack, so disable handling
20630 if CodePeer_Mode then
20633 -- Normal case where we do the pack action
20637 Set_Is_Packed (Base_Type (Typ));
20638 Set_Has_Non_Standard_Rep (Base_Type (Typ));
20641 Set_Has_Pragma_Pack (Base_Type (Typ));
20645 -- For record types, the pack is always effective
20647 else pragma Assert (Is_Record_Type (Typ));
20648 if not Rep_Item_Too_Late (Typ, N) then
20649 Set_Is_Packed (Base_Type (Typ));
20650 Set_Has_Pragma_Pack (Base_Type (Typ));
20651 Set_Has_Non_Standard_Rep (Base_Type (Typ));
20662 -- There is nothing to do here, since we did all the processing for
20663 -- this pragma in Par.Prag (so that it works properly even in syntax
20666 when Pragma_Page =>
20673 -- pragma Part_Of (ABSTRACT_STATE);
20675 -- ABSTRACT_STATE ::= NAME
20677 when Pragma_Part_Of => Part_Of : declare
20678 procedure Propagate_Part_Of
20679 (Pack_Id : Entity_Id;
20680 State_Id : Entity_Id;
20681 Instance : Node_Id);
20682 -- Propagate the Part_Of indicator to all abstract states and
20683 -- objects declared in the visible state space of a package
20684 -- denoted by Pack_Id. State_Id is the encapsulating state.
20685 -- Instance is the package instantiation node.
20687 -----------------------
20688 -- Propagate_Part_Of --
20689 -----------------------
20691 procedure Propagate_Part_Of
20692 (Pack_Id : Entity_Id;
20693 State_Id : Entity_Id;
20694 Instance : Node_Id)
20696 Has_Item : Boolean := False;
20697 -- Flag set when the visible state space contains at least one
20698 -- abstract state or variable.
20700 procedure Propagate_Part_Of (Pack_Id : Entity_Id);
20701 -- Propagate the Part_Of indicator to all abstract states and
20702 -- objects declared in the visible state space of a package
20703 -- denoted by Pack_Id.
20705 -----------------------
20706 -- Propagate_Part_Of --
20707 -----------------------
20709 procedure Propagate_Part_Of (Pack_Id : Entity_Id) is
20710 Constits : Elist_Id;
20711 Item_Id : Entity_Id;
20714 -- Traverse the entity chain of the package and set relevant
20715 -- attributes of abstract states and objects declared in the
20716 -- visible state space of the package.
20718 Item_Id := First_Entity (Pack_Id);
20719 while Present (Item_Id)
20720 and then not In_Private_Part (Item_Id)
20722 -- Do not consider internally generated items
20724 if not Comes_From_Source (Item_Id) then
20727 -- Do not consider generic formals or their corresponding
20728 -- actuals because they are not part of a visible state.
20729 -- Note that both entities are marked as hidden.
20731 elsif Is_Hidden (Item_Id) then
20734 -- The Part_Of indicator turns an abstract state or an
20735 -- object into a constituent of the encapsulating state.
20736 -- Note that constants are considered here even though
20737 -- they may not depend on variable input. This check is
20738 -- left to the SPARK prover.
20740 elsif Ekind_In (Item_Id, E_Abstract_State,
20745 Constits := Part_Of_Constituents (State_Id);
20747 if No (Constits) then
20748 Constits := New_Elmt_List;
20749 Set_Part_Of_Constituents (State_Id, Constits);
20752 Append_Elmt (Item_Id, Constits);
20753 Set_Encapsulating_State (Item_Id, State_Id);
20755 -- Recursively handle nested packages and instantiations
20757 elsif Ekind (Item_Id) = E_Package then
20758 Propagate_Part_Of (Item_Id);
20761 Next_Entity (Item_Id);
20763 end Propagate_Part_Of;
20765 -- Start of processing for Propagate_Part_Of
20768 Propagate_Part_Of (Pack_Id);
20770 -- Detect a package instantiation that is subject to a Part_Of
20771 -- indicator, but has no visible state.
20773 if not Has_Item then
20775 ("package instantiation & has Part_Of indicator but "
20776 & "lacks visible state", Instance, Pack_Id);
20778 end Propagate_Part_Of;
20782 Constits : Elist_Id;
20784 Encap_Id : Entity_Id;
20785 Item_Id : Entity_Id;
20789 -- Start of processing for Part_Of
20793 Check_No_Identifiers;
20794 Check_Arg_Count (1);
20796 Stmt := Find_Related_Context (N, Do_Checks => True);
20798 -- Object declaration
20800 if Nkind (Stmt) = N_Object_Declaration then
20803 -- Package instantiation
20805 elsif Nkind (Stmt) = N_Package_Instantiation then
20808 -- Single concurrent type declaration
20810 elsif Is_Single_Concurrent_Type_Declaration (Stmt) then
20813 -- Otherwise the pragma is associated with an illegal construct
20820 -- Extract the entity of the related object declaration or package
20821 -- instantiation. In the case of the instantiation, use the entity
20822 -- of the instance spec.
20824 if Nkind (Stmt) = N_Package_Instantiation then
20825 Stmt := Instance_Spec (Stmt);
20828 Item_Id := Defining_Entity (Stmt);
20830 -- A pragma that applies to a Ghost entity becomes Ghost for the
20831 -- purposes of legality checks and removal of ignored Ghost code.
20833 Mark_Ghost_Pragma (N, Item_Id);
20835 -- Chain the pragma on the contract for further processing by
20836 -- Analyze_Part_Of_In_Decl_Part or for completeness.
20838 Add_Contract_Item (N, Item_Id);
20840 -- A variable may act as constituent of a single concurrent type
20841 -- which in turn could be declared after the variable. Due to this
20842 -- discrepancy, the full analysis of indicator Part_Of is delayed
20843 -- until the end of the enclosing declarative region (see routine
20844 -- Analyze_Part_Of_In_Decl_Part).
20846 if Ekind (Item_Id) = E_Variable then
20849 -- Otherwise indicator Part_Of applies to a constant or a package
20853 Encap := Get_Pragma_Arg (Arg1);
20855 -- Detect any discrepancies between the placement of the
20856 -- constant or package instantiation with respect to state
20857 -- space and the encapsulating state.
20861 Item_Id => Item_Id,
20863 Encap_Id => Encap_Id,
20867 pragma Assert (Present (Encap_Id));
20869 if Ekind (Item_Id) = E_Constant then
20870 Constits := Part_Of_Constituents (Encap_Id);
20872 if No (Constits) then
20873 Constits := New_Elmt_List;
20874 Set_Part_Of_Constituents (Encap_Id, Constits);
20877 Append_Elmt (Item_Id, Constits);
20878 Set_Encapsulating_State (Item_Id, Encap_Id);
20880 -- Propagate the Part_Of indicator to the visible state
20881 -- space of the package instantiation.
20885 (Pack_Id => Item_Id,
20886 State_Id => Encap_Id,
20893 ----------------------------------
20894 -- Partition_Elaboration_Policy --
20895 ----------------------------------
20897 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
20899 when Pragma_Partition_Elaboration_Policy => PEP : declare
20900 subtype PEP_Range is Name_Id
20901 range First_Partition_Elaboration_Policy_Name
20902 .. Last_Partition_Elaboration_Policy_Name;
20903 PEP_Val : PEP_Range;
20908 Check_Arg_Count (1);
20909 Check_No_Identifiers;
20910 Check_Arg_Is_Partition_Elaboration_Policy (Arg1);
20911 Check_Valid_Configuration_Pragma;
20912 PEP_Val := Chars (Get_Pragma_Arg (Arg1));
20915 when Name_Concurrent => PEP := 'C';
20916 when Name_Sequential => PEP := 'S';
20919 if Partition_Elaboration_Policy /= ' '
20920 and then Partition_Elaboration_Policy /= PEP
20922 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc;
20924 ("partition elaboration policy incompatible with policy#");
20926 -- Set new policy, but always preserve System_Location since we
20927 -- like the error message with the run time name.
20930 Partition_Elaboration_Policy := PEP;
20932 if Partition_Elaboration_Policy_Sloc /= System_Location then
20933 Partition_Elaboration_Policy_Sloc := Loc;
20942 -- pragma Passive [(PASSIVE_FORM)];
20944 -- PASSIVE_FORM ::= Semaphore | No
20946 when Pragma_Passive =>
20949 if Nkind (Parent (N)) /= N_Task_Definition then
20950 Error_Pragma ("pragma% must be within task definition");
20953 if Arg_Count /= 0 then
20954 Check_Arg_Count (1);
20955 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
20958 ----------------------------------
20959 -- Preelaborable_Initialization --
20960 ----------------------------------
20962 -- pragma Preelaborable_Initialization (DIRECT_NAME);
20964 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
20969 Check_Arg_Count (1);
20970 Check_No_Identifiers;
20971 Check_Arg_Is_Identifier (Arg1);
20972 Check_Arg_Is_Local_Name (Arg1);
20973 Check_First_Subtype (Arg1);
20974 Ent := Entity (Get_Pragma_Arg (Arg1));
20976 -- A pragma that applies to a Ghost entity becomes Ghost for the
20977 -- purposes of legality checks and removal of ignored Ghost code.
20979 Mark_Ghost_Pragma (N, Ent);
20981 -- The pragma may come from an aspect on a private declaration,
20982 -- even if the freeze point at which this is analyzed in the
20983 -- private part after the full view.
20985 if Has_Private_Declaration (Ent)
20986 and then From_Aspect_Specification (N)
20990 -- Check appropriate type argument
20992 elsif Is_Private_Type (Ent)
20993 or else Is_Protected_Type (Ent)
20994 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))
20996 -- AI05-0028: The pragma applies to all composite types. Note
20997 -- that we apply this binding interpretation to earlier versions
20998 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
20999 -- choice since there are other compilers that do the same.
21001 or else Is_Composite_Type (Ent)
21007 ("pragma % can only be applied to private, formal derived, "
21008 & "protected, or composite type", Arg1);
21011 -- Give an error if the pragma is applied to a protected type that
21012 -- does not qualify (due to having entries, or due to components
21013 -- that do not qualify).
21015 if Is_Protected_Type (Ent)
21016 and then not Has_Preelaborable_Initialization (Ent)
21019 ("protected type & does not have preelaborable "
21020 & "initialization", Ent);
21022 -- Otherwise mark the type as definitely having preelaborable
21026 Set_Known_To_Have_Preelab_Init (Ent);
21029 if Has_Pragma_Preelab_Init (Ent)
21030 and then Warn_On_Redundant_Constructs
21032 Error_Pragma ("?r?duplicate pragma%!");
21034 Set_Has_Pragma_Preelab_Init (Ent);
21038 --------------------
21039 -- Persistent_BSS --
21040 --------------------
21042 -- pragma Persistent_BSS [(object_NAME)];
21044 when Pragma_Persistent_BSS => Persistent_BSS : declare
21051 Check_At_Most_N_Arguments (1);
21053 -- Case of application to specific object (one argument)
21055 if Arg_Count = 1 then
21056 Check_Arg_Is_Library_Level_Local_Name (Arg1);
21058 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
21060 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
21063 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
21066 Ent := Entity (Get_Pragma_Arg (Arg1));
21068 -- A pragma that applies to a Ghost entity becomes Ghost for
21069 -- the purposes of legality checks and removal of ignored Ghost
21072 Mark_Ghost_Pragma (N, Ent);
21074 -- Check for duplication before inserting in list of
21075 -- representation items.
21077 Check_Duplicate_Pragma (Ent);
21079 if Rep_Item_Too_Late (Ent, N) then
21083 Decl := Parent (Ent);
21085 if Present (Expression (Decl)) then
21086 -- Variables in Persistent_BSS cannot be initialized, so
21087 -- turn off any initialization that might be caused by
21088 -- pragmas Initialize_Scalars or Normalize_Scalars.
21090 if Kill_Range_Check (Expression (Decl)) then
21093 Name_Suppress_Initialization,
21094 Pragma_Argument_Associations => New_List (
21095 Make_Pragma_Argument_Association (Loc,
21096 Expression => New_Occurrence_Of (Ent, Loc))));
21097 Insert_Before (N, Prag);
21102 ("object for pragma% cannot have initialization", Arg1);
21106 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
21108 ("object type for pragma% is not potentially persistent",
21113 Make_Linker_Section_Pragma
21114 (Ent, Loc, ".persistent.bss");
21115 Insert_After (N, Prag);
21118 -- Case of use as configuration pragma with no arguments
21121 Check_Valid_Configuration_Pragma;
21122 Persistent_BSS_Mode := True;
21124 end Persistent_BSS;
21126 --------------------
21127 -- Rename_Pragma --
21128 --------------------
21130 -- pragma Rename_Pragma (
21131 -- [New_Name =>] IDENTIFIER,
21132 -- [Renamed =>] pragma_IDENTIFIER);
21134 when Pragma_Rename_Pragma => Rename_Pragma : declare
21135 New_Name : constant Node_Id := Get_Pragma_Arg (Arg1);
21136 Old_Name : constant Node_Id := Get_Pragma_Arg (Arg2);
21140 Check_Valid_Configuration_Pragma;
21141 Check_Arg_Count (2);
21142 Check_Optional_Identifier (Arg1, Name_New_Name);
21143 Check_Optional_Identifier (Arg2, Name_Renamed);
21145 if Nkind (New_Name) /= N_Identifier then
21146 Error_Pragma_Arg ("identifier expected", Arg1);
21149 if Nkind (Old_Name) /= N_Identifier then
21150 Error_Pragma_Arg ("identifier expected", Arg2);
21153 -- The New_Name arg should not be an existing pragma (but we allow
21154 -- it; it's just a warning). The Old_Name arg must be an existing
21157 if Is_Pragma_Name (Chars (New_Name)) then
21158 Error_Pragma_Arg ("??pragma is already defined", Arg1);
21161 if not Is_Pragma_Name (Chars (Old_Name)) then
21162 Error_Pragma_Arg ("existing pragma name expected", Arg1);
21165 Map_Pragma_Name (From => Chars (New_Name), To => Chars (Old_Name));
21172 -- pragma Polling (ON | OFF);
21174 when Pragma_Polling =>
21176 Check_Arg_Count (1);
21177 Check_No_Identifiers;
21178 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
21179 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
21181 -----------------------------------
21182 -- Post/Post_Class/Postcondition --
21183 -----------------------------------
21185 -- pragma Post (Boolean_EXPRESSION);
21186 -- pragma Post_Class (Boolean_EXPRESSION);
21187 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
21188 -- [,[Message =>] String_EXPRESSION]);
21190 -- Characteristics:
21192 -- * Analysis - The annotation undergoes initial checks to verify
21193 -- the legal placement and context. Secondary checks preanalyze the
21196 -- Analyze_Pre_Post_Condition_In_Decl_Part
21198 -- * Expansion - The annotation is expanded during the expansion of
21199 -- the related subprogram [body] contract as performed in:
21201 -- Expand_Subprogram_Contract
21203 -- * Template - The annotation utilizes the generic template of the
21204 -- related subprogram [body] when it is:
21206 -- aspect on subprogram declaration
21207 -- aspect on stand-alone subprogram body
21208 -- pragma on stand-alone subprogram body
21210 -- The annotation must prepare its own template when it is:
21212 -- pragma on subprogram declaration
21214 -- * Globals - Capture of global references must occur after full
21217 -- * Instance - The annotation is instantiated automatically when
21218 -- the related generic subprogram [body] is instantiated except for
21219 -- the "pragma on subprogram declaration" case. In that scenario
21220 -- the annotation must instantiate itself.
21223 | Pragma_Post_Class
21224 | Pragma_Postcondition
21226 Analyze_Pre_Post_Condition;
21228 --------------------------------
21229 -- Pre/Pre_Class/Precondition --
21230 --------------------------------
21232 -- pragma Pre (Boolean_EXPRESSION);
21233 -- pragma Pre_Class (Boolean_EXPRESSION);
21234 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
21235 -- [,[Message =>] String_EXPRESSION]);
21237 -- Characteristics:
21239 -- * Analysis - The annotation undergoes initial checks to verify
21240 -- the legal placement and context. Secondary checks preanalyze the
21243 -- Analyze_Pre_Post_Condition_In_Decl_Part
21245 -- * Expansion - The annotation is expanded during the expansion of
21246 -- the related subprogram [body] contract as performed in:
21248 -- Expand_Subprogram_Contract
21250 -- * Template - The annotation utilizes the generic template of the
21251 -- related subprogram [body] when it is:
21253 -- aspect on subprogram declaration
21254 -- aspect on stand-alone subprogram body
21255 -- pragma on stand-alone subprogram body
21257 -- The annotation must prepare its own template when it is:
21259 -- pragma on subprogram declaration
21261 -- * Globals - Capture of global references must occur after full
21264 -- * Instance - The annotation is instantiated automatically when
21265 -- the related generic subprogram [body] is instantiated except for
21266 -- the "pragma on subprogram declaration" case. In that scenario
21267 -- the annotation must instantiate itself.
21271 | Pragma_Precondition
21273 Analyze_Pre_Post_Condition;
21279 -- pragma Predicate
21280 -- ([Entity =>] type_LOCAL_NAME,
21281 -- [Check =>] boolean_EXPRESSION);
21283 when Pragma_Predicate => Predicate : declare
21290 Check_Arg_Count (2);
21291 Check_Optional_Identifier (Arg1, Name_Entity);
21292 Check_Optional_Identifier (Arg2, Name_Check);
21294 Check_Arg_Is_Local_Name (Arg1);
21296 Type_Id := Get_Pragma_Arg (Arg1);
21297 Find_Type (Type_Id);
21298 Typ := Entity (Type_Id);
21300 if Typ = Any_Type then
21304 -- A pragma that applies to a Ghost entity becomes Ghost for the
21305 -- purposes of legality checks and removal of ignored Ghost code.
21307 Mark_Ghost_Pragma (N, Typ);
21309 -- The remaining processing is simply to link the pragma on to
21310 -- the rep item chain, for processing when the type is frozen.
21311 -- This is accomplished by a call to Rep_Item_Too_Late. We also
21312 -- mark the type as having predicates.
21314 -- If the current policy for predicate checking is Ignore mark the
21315 -- subtype accordingly. In the case of predicates we consider them
21316 -- enabled unless Ignore is specified (either directly or with a
21317 -- general Assertion_Policy pragma) to preserve existing warnings.
21319 Set_Has_Predicates (Typ);
21321 -- Indicate that the pragma must be processed at the point the
21322 -- type is frozen, as is done for the corresponding aspect.
21324 Set_Has_Delayed_Aspects (Typ);
21325 Set_Has_Delayed_Freeze (Typ);
21327 Set_Predicates_Ignored (Typ,
21328 Present (Check_Policy_List)
21330 Policy_In_Effect (Name_Dynamic_Predicate) = Name_Ignore);
21331 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
21334 -----------------------
21335 -- Predicate_Failure --
21336 -----------------------
21338 -- pragma Predicate_Failure
21339 -- ([Entity =>] type_LOCAL_NAME,
21340 -- [Message =>] string_EXPRESSION);
21342 when Pragma_Predicate_Failure => Predicate_Failure : declare
21349 Check_Arg_Count (2);
21350 Check_Optional_Identifier (Arg1, Name_Entity);
21351 Check_Optional_Identifier (Arg2, Name_Message);
21353 Check_Arg_Is_Local_Name (Arg1);
21355 Type_Id := Get_Pragma_Arg (Arg1);
21356 Find_Type (Type_Id);
21357 Typ := Entity (Type_Id);
21359 if Typ = Any_Type then
21363 -- A pragma that applies to a Ghost entity becomes Ghost for the
21364 -- purposes of legality checks and removal of ignored Ghost code.
21366 Mark_Ghost_Pragma (N, Typ);
21368 -- The remaining processing is simply to link the pragma on to
21369 -- the rep item chain, for processing when the type is frozen.
21370 -- This is accomplished by a call to Rep_Item_Too_Late.
21372 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
21373 end Predicate_Failure;
21379 -- pragma Preelaborate [(library_unit_NAME)];
21381 -- Set the flag Is_Preelaborated of program unit name entity
21383 when Pragma_Preelaborate => Preelaborate : declare
21384 Pa : constant Node_Id := Parent (N);
21385 Pk : constant Node_Kind := Nkind (Pa);
21389 Check_Ada_83_Warning;
21390 Check_Valid_Library_Unit_Pragma;
21392 if Nkind (N) = N_Null_Statement then
21396 Ent := Find_Lib_Unit_Name;
21398 -- A pragma that applies to a Ghost entity becomes Ghost for the
21399 -- purposes of legality checks and removal of ignored Ghost code.
21401 Mark_Ghost_Pragma (N, Ent);
21402 Check_Duplicate_Pragma (Ent);
21404 -- This filters out pragmas inside generic parents that show up
21405 -- inside instantiations. Pragmas that come from aspects in the
21406 -- unit are not ignored.
21408 if Present (Ent) then
21409 if Pk = N_Package_Specification
21410 and then Present (Generic_Parent (Pa))
21411 and then not From_Aspect_Specification (N)
21416 if not Debug_Flag_U then
21417 Set_Is_Preelaborated (Ent);
21419 if Legacy_Elaboration_Checks then
21420 Set_Suppress_Elaboration_Warnings (Ent);
21427 -------------------------------
21428 -- Prefix_Exception_Messages --
21429 -------------------------------
21431 -- pragma Prefix_Exception_Messages;
21433 when Pragma_Prefix_Exception_Messages =>
21435 Check_Valid_Configuration_Pragma;
21436 Check_Arg_Count (0);
21437 Prefix_Exception_Messages := True;
21443 -- pragma Priority (EXPRESSION);
21445 when Pragma_Priority => Priority : declare
21446 P : constant Node_Id := Parent (N);
21451 Check_No_Identifiers;
21452 Check_Arg_Count (1);
21456 if Nkind (P) = N_Subprogram_Body then
21457 Check_In_Main_Program;
21459 Ent := Defining_Unit_Name (Specification (P));
21461 if Nkind (Ent) = N_Defining_Program_Unit_Name then
21462 Ent := Defining_Identifier (Ent);
21465 Arg := Get_Pragma_Arg (Arg1);
21466 Analyze_And_Resolve (Arg, Standard_Integer);
21470 if not Is_OK_Static_Expression (Arg) then
21471 Flag_Non_Static_Expr
21472 ("main subprogram priority is not static!", Arg);
21475 -- If constraint error, then we already signalled an error
21477 elsif Raises_Constraint_Error (Arg) then
21480 -- Otherwise check in range except if Relaxed_RM_Semantics
21481 -- where we ignore the value if out of range.
21484 if not Relaxed_RM_Semantics
21485 and then not Is_In_Range (Arg, RTE (RE_Priority))
21488 ("main subprogram priority is out of range", Arg1);
21491 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
21495 -- Load an arbitrary entity from System.Tasking.Stages or
21496 -- System.Tasking.Restricted.Stages (depending on the
21497 -- supported profile) to make sure that one of these packages
21498 -- is implicitly with'ed, since we need to have the tasking
21499 -- run time active for the pragma Priority to have any effect.
21500 -- Previously we with'ed the package System.Tasking, but this
21501 -- package does not trigger the required initialization of the
21502 -- run-time library.
21505 Discard : Entity_Id;
21506 pragma Warnings (Off, Discard);
21508 if Restricted_Profile then
21509 Discard := RTE (RE_Activate_Restricted_Tasks);
21511 Discard := RTE (RE_Activate_Tasks);
21515 -- Task or Protected, must be of type Integer
21517 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
21518 Arg := Get_Pragma_Arg (Arg1);
21519 Ent := Defining_Identifier (Parent (P));
21521 -- The expression must be analyzed in the special manner
21522 -- described in "Handling of Default and Per-Object
21523 -- Expressions" in sem.ads.
21525 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority));
21527 if not Is_OK_Static_Expression (Arg) then
21528 Check_Restriction (Static_Priorities, Arg);
21531 -- Anything else is incorrect
21537 -- Check duplicate pragma before we chain the pragma in the Rep
21538 -- Item chain of Ent.
21540 Check_Duplicate_Pragma (Ent);
21541 Record_Rep_Item (Ent, N);
21544 -----------------------------------
21545 -- Priority_Specific_Dispatching --
21546 -----------------------------------
21548 -- pragma Priority_Specific_Dispatching (
21549 -- policy_IDENTIFIER,
21550 -- first_priority_EXPRESSION,
21551 -- last_priority_EXPRESSION);
21553 when Pragma_Priority_Specific_Dispatching =>
21554 Priority_Specific_Dispatching : declare
21555 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
21556 -- This is the entity System.Any_Priority;
21559 Lower_Bound : Node_Id;
21560 Upper_Bound : Node_Id;
21566 Check_Arg_Count (3);
21567 Check_No_Identifiers;
21568 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
21569 Check_Valid_Configuration_Pragma;
21570 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
21571 DP := Fold_Upper (Name_Buffer (1));
21573 Lower_Bound := Get_Pragma_Arg (Arg2);
21574 Check_Arg_Is_OK_Static_Expression (Lower_Bound, Standard_Integer);
21575 Lower_Val := Expr_Value (Lower_Bound);
21577 Upper_Bound := Get_Pragma_Arg (Arg3);
21578 Check_Arg_Is_OK_Static_Expression (Upper_Bound, Standard_Integer);
21579 Upper_Val := Expr_Value (Upper_Bound);
21581 -- It is not allowed to use Task_Dispatching_Policy and
21582 -- Priority_Specific_Dispatching in the same partition.
21584 if Task_Dispatching_Policy /= ' ' then
21585 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
21587 ("pragma% incompatible with Task_Dispatching_Policy#");
21589 -- Check lower bound in range
21591 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
21593 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
21596 ("first_priority is out of range", Arg2);
21598 -- Check upper bound in range
21600 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
21602 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
21605 ("last_priority is out of range", Arg3);
21607 -- Check that the priority range is valid
21609 elsif Lower_Val > Upper_Val then
21611 ("last_priority_expression must be greater than or equal to "
21612 & "first_priority_expression");
21614 -- Store the new policy, but always preserve System_Location since
21615 -- we like the error message with the run-time name.
21618 -- Check overlapping in the priority ranges specified in other
21619 -- Priority_Specific_Dispatching pragmas within the same
21620 -- partition. We can only check those we know about.
21623 Specific_Dispatching.First .. Specific_Dispatching.Last
21625 if Specific_Dispatching.Table (J).First_Priority in
21626 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
21627 or else Specific_Dispatching.Table (J).Last_Priority in
21628 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
21631 Specific_Dispatching.Table (J).Pragma_Loc;
21633 ("priority range overlaps with "
21634 & "Priority_Specific_Dispatching#");
21638 -- The use of Priority_Specific_Dispatching is incompatible
21639 -- with Task_Dispatching_Policy.
21641 if Task_Dispatching_Policy /= ' ' then
21642 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
21644 ("Priority_Specific_Dispatching incompatible "
21645 & "with Task_Dispatching_Policy#");
21648 -- The use of Priority_Specific_Dispatching forces ceiling
21651 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
21652 Error_Msg_Sloc := Locking_Policy_Sloc;
21654 ("Priority_Specific_Dispatching incompatible "
21655 & "with Locking_Policy#");
21657 -- Set the Ceiling_Locking policy, but preserve System_Location
21658 -- since we like the error message with the run time name.
21661 Locking_Policy := 'C';
21663 if Locking_Policy_Sloc /= System_Location then
21664 Locking_Policy_Sloc := Loc;
21668 -- Add entry in the table
21670 Specific_Dispatching.Append
21671 ((Dispatching_Policy => DP,
21672 First_Priority => UI_To_Int (Lower_Val),
21673 Last_Priority => UI_To_Int (Upper_Val),
21674 Pragma_Loc => Loc));
21676 end Priority_Specific_Dispatching;
21682 -- pragma Profile (profile_IDENTIFIER);
21684 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
21686 when Pragma_Profile =>
21688 Check_Arg_Count (1);
21689 Check_Valid_Configuration_Pragma;
21690 Check_No_Identifiers;
21693 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21696 if Chars (Argx) = Name_Ravenscar then
21697 Set_Ravenscar_Profile (Ravenscar, N);
21699 elsif Chars (Argx) = Name_Gnat_Extended_Ravenscar then
21700 Set_Ravenscar_Profile (GNAT_Extended_Ravenscar, N);
21702 elsif Chars (Argx) = Name_Gnat_Ravenscar_EDF then
21703 Set_Ravenscar_Profile (GNAT_Ravenscar_EDF, N);
21705 elsif Chars (Argx) = Name_Restricted then
21706 Set_Profile_Restrictions
21708 N, Warn => Treat_Restrictions_As_Warnings);
21710 elsif Chars (Argx) = Name_Rational then
21711 Set_Rational_Profile;
21713 elsif Chars (Argx) = Name_No_Implementation_Extensions then
21714 Set_Profile_Restrictions
21715 (No_Implementation_Extensions,
21716 N, Warn => Treat_Restrictions_As_Warnings);
21719 Error_Pragma_Arg ("& is not a valid profile", Argx);
21723 ----------------------
21724 -- Profile_Warnings --
21725 ----------------------
21727 -- pragma Profile_Warnings (profile_IDENTIFIER);
21729 -- profile_IDENTIFIER => Restricted | Ravenscar
21731 when Pragma_Profile_Warnings =>
21733 Check_Arg_Count (1);
21734 Check_Valid_Configuration_Pragma;
21735 Check_No_Identifiers;
21738 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21741 if Chars (Argx) = Name_Ravenscar then
21742 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
21744 elsif Chars (Argx) = Name_Restricted then
21745 Set_Profile_Restrictions (Restricted, N, Warn => True);
21747 elsif Chars (Argx) = Name_No_Implementation_Extensions then
21748 Set_Profile_Restrictions
21749 (No_Implementation_Extensions, N, Warn => True);
21752 Error_Pragma_Arg ("& is not a valid profile", Argx);
21756 --------------------------
21757 -- Propagate_Exceptions --
21758 --------------------------
21760 -- pragma Propagate_Exceptions;
21762 -- Note: this pragma is obsolete and has no effect
21764 when Pragma_Propagate_Exceptions =>
21766 Check_Arg_Count (0);
21768 if Warn_On_Obsolescent_Feature then
21770 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
21771 "and has no effect?j?", N);
21774 -----------------------------
21775 -- Provide_Shift_Operators --
21776 -----------------------------
21778 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
21780 when Pragma_Provide_Shift_Operators =>
21781 Provide_Shift_Operators : declare
21784 procedure Declare_Shift_Operator (Nam : Name_Id);
21785 -- Insert declaration and pragma Instrinsic for named shift op
21787 ----------------------------
21788 -- Declare_Shift_Operator --
21789 ----------------------------
21791 procedure Declare_Shift_Operator (Nam : Name_Id) is
21797 Make_Subprogram_Declaration (Loc,
21798 Make_Function_Specification (Loc,
21799 Defining_Unit_Name =>
21800 Make_Defining_Identifier (Loc, Chars => Nam),
21802 Result_Definition =>
21803 Make_Identifier (Loc, Chars => Chars (Ent)),
21805 Parameter_Specifications => New_List (
21806 Make_Parameter_Specification (Loc,
21807 Defining_Identifier =>
21808 Make_Defining_Identifier (Loc, Name_Value),
21810 Make_Identifier (Loc, Chars => Chars (Ent))),
21812 Make_Parameter_Specification (Loc,
21813 Defining_Identifier =>
21814 Make_Defining_Identifier (Loc, Name_Amount),
21816 New_Occurrence_Of (Standard_Natural, Loc)))));
21820 Chars => Name_Import,
21821 Pragma_Argument_Associations => New_List (
21822 Make_Pragma_Argument_Association (Loc,
21823 Expression => Make_Identifier (Loc, Name_Intrinsic)),
21824 Make_Pragma_Argument_Association (Loc,
21825 Expression => Make_Identifier (Loc, Nam))));
21827 Insert_After (N, Import);
21828 Insert_After (N, Func);
21829 end Declare_Shift_Operator;
21831 -- Start of processing for Provide_Shift_Operators
21835 Check_Arg_Count (1);
21836 Check_Arg_Is_Local_Name (Arg1);
21838 Arg1 := Get_Pragma_Arg (Arg1);
21840 -- We must have an entity name
21842 if not Is_Entity_Name (Arg1) then
21844 ("pragma % must apply to integer first subtype", Arg1);
21847 -- If no Entity, means there was a prior error so ignore
21849 if Present (Entity (Arg1)) then
21850 Ent := Entity (Arg1);
21852 -- Apply error checks
21854 if not Is_First_Subtype (Ent) then
21856 ("cannot apply pragma %",
21857 "\& is not a first subtype",
21860 elsif not Is_Integer_Type (Ent) then
21862 ("cannot apply pragma %",
21863 "\& is not an integer type",
21866 elsif Has_Shift_Operator (Ent) then
21868 ("cannot apply pragma %",
21869 "\& already has declared shift operators",
21872 elsif Is_Frozen (Ent) then
21874 ("pragma % appears too late",
21875 "\& is already frozen",
21879 -- Now declare the operators. We do this during analysis rather
21880 -- than expansion, since we want the operators available if we
21881 -- are operating in -gnatc or ASIS mode.
21883 Declare_Shift_Operator (Name_Rotate_Left);
21884 Declare_Shift_Operator (Name_Rotate_Right);
21885 Declare_Shift_Operator (Name_Shift_Left);
21886 Declare_Shift_Operator (Name_Shift_Right);
21887 Declare_Shift_Operator (Name_Shift_Right_Arithmetic);
21889 end Provide_Shift_Operators;
21895 -- pragma Psect_Object (
21896 -- [Internal =>] LOCAL_NAME,
21897 -- [, [External =>] EXTERNAL_SYMBOL]
21898 -- [, [Size =>] EXTERNAL_SYMBOL]);
21900 when Pragma_Common_Object
21901 | Pragma_Psect_Object
21903 Psect_Object : declare
21904 Args : Args_List (1 .. 3);
21905 Names : constant Name_List (1 .. 3) := (
21910 Internal : Node_Id renames Args (1);
21911 External : Node_Id renames Args (2);
21912 Size : Node_Id renames Args (3);
21914 Def_Id : Entity_Id;
21916 procedure Check_Arg (Arg : Node_Id);
21917 -- Checks that argument is either a string literal or an
21918 -- identifier, and posts error message if not.
21924 procedure Check_Arg (Arg : Node_Id) is
21926 if not Nkind_In (Original_Node (Arg),
21931 ("inappropriate argument for pragma %", Arg);
21935 -- Start of processing for Common_Object/Psect_Object
21939 Gather_Associations (Names, Args);
21940 Process_Extended_Import_Export_Internal_Arg (Internal);
21942 Def_Id := Entity (Internal);
21944 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
21946 ("pragma% must designate an object", Internal);
21949 Check_Arg (Internal);
21951 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
21953 ("cannot use pragma% for imported/exported object",
21957 if Is_Concurrent_Type (Etype (Internal)) then
21959 ("cannot specify pragma % for task/protected object",
21963 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
21965 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
21967 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N);
21970 if Ekind (Def_Id) = E_Constant then
21972 ("cannot specify pragma % for a constant", Internal);
21975 if Is_Record_Type (Etype (Internal)) then
21981 Ent := First_Entity (Etype (Internal));
21982 while Present (Ent) loop
21983 Decl := Declaration_Node (Ent);
21985 if Ekind (Ent) = E_Component
21986 and then Nkind (Decl) = N_Component_Declaration
21987 and then Present (Expression (Decl))
21988 and then Warn_On_Export_Import
21991 ("?x?object for pragma % has defaults", Internal);
22001 if Present (Size) then
22005 if Present (External) then
22006 Check_Arg_Is_External_Name (External);
22009 -- If all error tests pass, link pragma on to the rep item chain
22011 Record_Rep_Item (Def_Id, N);
22018 -- pragma Pure [(library_unit_NAME)];
22020 when Pragma_Pure => Pure : declare
22024 Check_Ada_83_Warning;
22026 -- If the pragma comes from a subprogram instantiation, nothing to
22027 -- check, this can happen at any level of nesting.
22029 if Is_Wrapper_Package (Current_Scope) then
22032 Check_Valid_Library_Unit_Pragma;
22035 if Nkind (N) = N_Null_Statement then
22039 Ent := Find_Lib_Unit_Name;
22041 -- A pragma that applies to a Ghost entity becomes Ghost for the
22042 -- purposes of legality checks and removal of ignored Ghost code.
22044 Mark_Ghost_Pragma (N, Ent);
22046 if not Debug_Flag_U then
22048 Set_Has_Pragma_Pure (Ent);
22050 if Legacy_Elaboration_Checks then
22051 Set_Suppress_Elaboration_Warnings (Ent);
22056 -------------------
22057 -- Pure_Function --
22058 -------------------
22060 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
22062 when Pragma_Pure_Function => Pure_Function : declare
22063 Def_Id : Entity_Id;
22066 Effective : Boolean := False;
22067 Orig_Def : Entity_Id;
22068 Same_Decl : Boolean := False;
22072 Check_Arg_Count (1);
22073 Check_Optional_Identifier (Arg1, Name_Entity);
22074 Check_Arg_Is_Local_Name (Arg1);
22075 E_Id := Get_Pragma_Arg (Arg1);
22077 if Etype (E_Id) = Any_Type then
22081 -- Loop through homonyms (overloadings) of referenced entity
22083 E := Entity (E_Id);
22085 -- A pragma that applies to a Ghost entity becomes Ghost for the
22086 -- purposes of legality checks and removal of ignored Ghost code.
22088 Mark_Ghost_Pragma (N, E);
22090 if Present (E) then
22092 Def_Id := Get_Base_Subprogram (E);
22094 if not Ekind_In (Def_Id, E_Function,
22095 E_Generic_Function,
22099 ("pragma% requires a function name", Arg1);
22102 -- When we have a generic function we must jump up a level
22103 -- to the declaration of the wrapper package itself.
22105 Orig_Def := Def_Id;
22107 if Is_Generic_Instance (Def_Id) then
22108 while Nkind (Orig_Def) /= N_Package_Declaration loop
22109 Orig_Def := Parent (Orig_Def);
22113 if In_Same_Declarative_Part (Parent (N), Orig_Def) then
22115 Set_Is_Pure (Def_Id);
22117 if not Has_Pragma_Pure_Function (Def_Id) then
22118 Set_Has_Pragma_Pure_Function (Def_Id);
22123 exit when From_Aspect_Specification (N);
22125 exit when No (E) or else Scope (E) /= Current_Scope;
22129 and then Warn_On_Redundant_Constructs
22132 ("pragma Pure_Function on& is redundant?r?",
22135 elsif not Same_Decl then
22137 ("pragma% argument must be in same declarative part",
22143 --------------------
22144 -- Queuing_Policy --
22145 --------------------
22147 -- pragma Queuing_Policy (policy_IDENTIFIER);
22149 when Pragma_Queuing_Policy => declare
22153 Check_Ada_83_Warning;
22154 Check_Arg_Count (1);
22155 Check_No_Identifiers;
22156 Check_Arg_Is_Queuing_Policy (Arg1);
22157 Check_Valid_Configuration_Pragma;
22158 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
22159 QP := Fold_Upper (Name_Buffer (1));
22161 if Queuing_Policy /= ' '
22162 and then Queuing_Policy /= QP
22164 Error_Msg_Sloc := Queuing_Policy_Sloc;
22165 Error_Pragma ("queuing policy incompatible with policy#");
22167 -- Set new policy, but always preserve System_Location since we
22168 -- like the error message with the run time name.
22171 Queuing_Policy := QP;
22173 if Queuing_Policy_Sloc /= System_Location then
22174 Queuing_Policy_Sloc := Loc;
22183 -- pragma Rational, for compatibility with foreign compiler
22185 when Pragma_Rational =>
22186 Set_Rational_Profile;
22188 ---------------------
22189 -- Refined_Depends --
22190 ---------------------
22192 -- pragma Refined_Depends (DEPENDENCY_RELATION);
22194 -- DEPENDENCY_RELATION ::=
22196 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
22198 -- DEPENDENCY_CLAUSE ::=
22199 -- OUTPUT_LIST =>[+] INPUT_LIST
22200 -- | NULL_DEPENDENCY_CLAUSE
22202 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
22204 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
22206 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
22208 -- OUTPUT ::= NAME | FUNCTION_RESULT
22211 -- where FUNCTION_RESULT is a function Result attribute_reference
22213 -- Characteristics:
22215 -- * Analysis - The annotation undergoes initial checks to verify
22216 -- the legal placement and context. Secondary checks fully analyze
22217 -- the dependency clauses/global list in:
22219 -- Analyze_Refined_Depends_In_Decl_Part
22221 -- * Expansion - None.
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_Depends => Refined_Depends : declare
22233 Body_Id : Entity_Id;
22235 Spec_Id : Entity_Id;
22238 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
22242 -- Chain the pragma on the contract for further processing by
22243 -- Analyze_Refined_Depends_In_Decl_Part.
22245 Add_Contract_Item (N, Body_Id);
22247 -- The legality checks of pragmas Refined_Depends and
22248 -- Refined_Global are affected by the SPARK mode in effect and
22249 -- the volatility of the context. In addition these two pragmas
22250 -- are subject to an inherent order:
22252 -- 1) Refined_Global
22253 -- 2) Refined_Depends
22255 -- Analyze all these pragmas in the order outlined above
22257 Analyze_If_Present (Pragma_SPARK_Mode);
22258 Analyze_If_Present (Pragma_Volatile_Function);
22259 Analyze_If_Present (Pragma_Refined_Global);
22260 Analyze_Refined_Depends_In_Decl_Part (N);
22262 end Refined_Depends;
22264 --------------------
22265 -- Refined_Global --
22266 --------------------
22268 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
22270 -- GLOBAL_SPECIFICATION ::=
22273 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
22275 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
22277 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
22278 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
22279 -- GLOBAL_ITEM ::= NAME
22281 -- Characteristics:
22283 -- * Analysis - The annotation undergoes initial checks to verify
22284 -- the legal placement and context. Secondary checks fully analyze
22285 -- the dependency clauses/global list in:
22287 -- Analyze_Refined_Global_In_Decl_Part
22289 -- * Expansion - None.
22291 -- * Template - The annotation utilizes the generic template of the
22292 -- related subprogram body.
22294 -- * Globals - Capture of global references must occur after full
22297 -- * Instance - The annotation is instantiated automatically when
22298 -- the related generic subprogram body is instantiated.
22300 when Pragma_Refined_Global => Refined_Global : declare
22301 Body_Id : Entity_Id;
22303 Spec_Id : Entity_Id;
22306 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
22310 -- Chain the pragma on the contract for further processing by
22311 -- Analyze_Refined_Global_In_Decl_Part.
22313 Add_Contract_Item (N, Body_Id);
22315 -- The legality checks of pragmas Refined_Depends and
22316 -- Refined_Global are affected by the SPARK mode in effect and
22317 -- the volatility of the context. In addition these two pragmas
22318 -- are subject to an inherent order:
22320 -- 1) Refined_Global
22321 -- 2) Refined_Depends
22323 -- Analyze all these pragmas in the order outlined above
22325 Analyze_If_Present (Pragma_SPARK_Mode);
22326 Analyze_If_Present (Pragma_Volatile_Function);
22327 Analyze_Refined_Global_In_Decl_Part (N);
22328 Analyze_If_Present (Pragma_Refined_Depends);
22330 end Refined_Global;
22336 -- pragma Refined_Post (boolean_EXPRESSION);
22338 -- Characteristics:
22340 -- * Analysis - The annotation is fully analyzed immediately upon
22341 -- elaboration as it cannot forward reference entities.
22343 -- * Expansion - The annotation is expanded during the expansion of
22344 -- the related subprogram body contract as performed in:
22346 -- Expand_Subprogram_Contract
22348 -- * Template - The annotation utilizes the generic template of the
22349 -- related subprogram body.
22351 -- * Globals - Capture of global references must occur after full
22354 -- * Instance - The annotation is instantiated automatically when
22355 -- the related generic subprogram body is instantiated.
22357 when Pragma_Refined_Post => Refined_Post : declare
22358 Body_Id : Entity_Id;
22360 Spec_Id : Entity_Id;
22363 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
22365 -- Fully analyze the pragma when it appears inside a subprogram
22366 -- body because it cannot benefit from forward references.
22370 -- Chain the pragma on the contract for completeness
22372 Add_Contract_Item (N, Body_Id);
22374 -- The legality checks of pragma Refined_Post are affected by
22375 -- the SPARK mode in effect and the volatility of the context.
22376 -- Analyze all pragmas in a specific order.
22378 Analyze_If_Present (Pragma_SPARK_Mode);
22379 Analyze_If_Present (Pragma_Volatile_Function);
22380 Analyze_Pre_Post_Condition_In_Decl_Part (N);
22382 -- Currently it is not possible to inline pre/postconditions on
22383 -- a subprogram subject to pragma Inline_Always.
22385 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
22389 -------------------
22390 -- Refined_State --
22391 -------------------
22393 -- pragma Refined_State (REFINEMENT_LIST);
22395 -- REFINEMENT_LIST ::=
22396 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
22398 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
22400 -- CONSTITUENT_LIST ::=
22403 -- | (CONSTITUENT {, CONSTITUENT})
22405 -- CONSTITUENT ::= object_NAME | state_NAME
22407 -- Characteristics:
22409 -- * Analysis - The annotation undergoes initial checks to verify
22410 -- the legal placement and context. Secondary checks preanalyze the
22411 -- refinement clauses in:
22413 -- Analyze_Refined_State_In_Decl_Part
22415 -- * Expansion - None.
22417 -- * Template - The annotation utilizes the template of the related
22420 -- * Globals - Capture of global references must occur after full
22423 -- * Instance - The annotation is instantiated automatically when
22424 -- the related generic package body is instantiated.
22426 when Pragma_Refined_State => Refined_State : declare
22427 Pack_Decl : Node_Id;
22428 Spec_Id : Entity_Id;
22432 Check_No_Identifiers;
22433 Check_Arg_Count (1);
22435 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
22437 if Nkind (Pack_Decl) /= N_Package_Body then
22442 Spec_Id := Corresponding_Spec (Pack_Decl);
22444 -- A pragma that applies to a Ghost entity becomes Ghost for the
22445 -- purposes of legality checks and removal of ignored Ghost code.
22447 Mark_Ghost_Pragma (N, Spec_Id);
22449 -- Chain the pragma on the contract for further processing by
22450 -- Analyze_Refined_State_In_Decl_Part.
22452 Add_Contract_Item (N, Defining_Entity (Pack_Decl));
22454 -- The legality checks of pragma Refined_State are affected by the
22455 -- SPARK mode in effect. Analyze all pragmas in a specific order.
22457 Analyze_If_Present (Pragma_SPARK_Mode);
22459 -- State refinement is allowed only when the corresponding package
22460 -- declaration has non-null pragma Abstract_State. Refinement not
22461 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
22463 if SPARK_Mode /= Off
22465 (No (Abstract_States (Spec_Id))
22466 or else Has_Null_Abstract_State (Spec_Id))
22469 ("useless refinement, package & does not define abstract "
22470 & "states", N, Spec_Id);
22475 -----------------------
22476 -- Relative_Deadline --
22477 -----------------------
22479 -- pragma Relative_Deadline (time_span_EXPRESSION);
22481 when Pragma_Relative_Deadline => Relative_Deadline : declare
22482 P : constant Node_Id := Parent (N);
22487 Check_No_Identifiers;
22488 Check_Arg_Count (1);
22490 Arg := Get_Pragma_Arg (Arg1);
22492 -- The expression must be analyzed in the special manner described
22493 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
22495 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
22499 if Nkind (P) = N_Subprogram_Body then
22500 Check_In_Main_Program;
22502 -- Only Task and subprogram cases allowed
22504 elsif Nkind (P) /= N_Task_Definition then
22508 -- Check duplicate pragma before we set the corresponding flag
22510 if Has_Relative_Deadline_Pragma (P) then
22511 Error_Pragma ("duplicate pragma% not allowed");
22514 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
22515 -- Relative_Deadline pragma node cannot be inserted in the Rep
22516 -- Item chain of Ent since it is rewritten by the expander as a
22517 -- procedure call statement that will break the chain.
22519 Set_Has_Relative_Deadline_Pragma (P);
22520 end Relative_Deadline;
22522 ------------------------
22523 -- Remote_Access_Type --
22524 ------------------------
22526 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
22528 when Pragma_Remote_Access_Type => Remote_Access_Type : declare
22533 Check_Arg_Count (1);
22534 Check_Optional_Identifier (Arg1, Name_Entity);
22535 Check_Arg_Is_Local_Name (Arg1);
22537 E := Entity (Get_Pragma_Arg (Arg1));
22539 -- A pragma that applies to a Ghost entity becomes Ghost for the
22540 -- purposes of legality checks and removal of ignored Ghost code.
22542 Mark_Ghost_Pragma (N, E);
22544 if Nkind (Parent (E)) = N_Formal_Type_Declaration
22545 and then Ekind (E) = E_General_Access_Type
22546 and then Is_Class_Wide_Type (Directly_Designated_Type (E))
22547 and then Scope (Root_Type (Directly_Designated_Type (E)))
22549 and then Is_Valid_Remote_Object_Type
22550 (Root_Type (Directly_Designated_Type (E)))
22552 Set_Is_Remote_Types (E);
22556 ("pragma% applies only to formal access-to-class-wide types",
22559 end Remote_Access_Type;
22561 ---------------------------
22562 -- Remote_Call_Interface --
22563 ---------------------------
22565 -- pragma Remote_Call_Interface [(library_unit_NAME)];
22567 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
22568 Cunit_Node : Node_Id;
22569 Cunit_Ent : Entity_Id;
22573 Check_Ada_83_Warning;
22574 Check_Valid_Library_Unit_Pragma;
22576 if Nkind (N) = N_Null_Statement then
22580 Cunit_Node := Cunit (Current_Sem_Unit);
22581 K := Nkind (Unit (Cunit_Node));
22582 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22584 -- A pragma that applies to a Ghost entity becomes Ghost for the
22585 -- purposes of legality checks and removal of ignored Ghost code.
22587 Mark_Ghost_Pragma (N, Cunit_Ent);
22589 if K = N_Package_Declaration
22590 or else K = N_Generic_Package_Declaration
22591 or else K = N_Subprogram_Declaration
22592 or else K = N_Generic_Subprogram_Declaration
22593 or else (K = N_Subprogram_Body
22594 and then Acts_As_Spec (Unit (Cunit_Node)))
22599 "pragma% must apply to package or subprogram declaration");
22602 Set_Is_Remote_Call_Interface (Cunit_Ent);
22603 end Remote_Call_Interface;
22609 -- pragma Remote_Types [(library_unit_NAME)];
22611 when Pragma_Remote_Types => Remote_Types : declare
22612 Cunit_Node : Node_Id;
22613 Cunit_Ent : Entity_Id;
22616 Check_Ada_83_Warning;
22617 Check_Valid_Library_Unit_Pragma;
22619 if Nkind (N) = N_Null_Statement then
22623 Cunit_Node := Cunit (Current_Sem_Unit);
22624 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22626 -- A pragma that applies to a Ghost entity becomes Ghost for the
22627 -- purposes of legality checks and removal of ignored Ghost code.
22629 Mark_Ghost_Pragma (N, Cunit_Ent);
22631 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
22632 N_Generic_Package_Declaration)
22635 ("pragma% can only apply to a package declaration");
22638 Set_Is_Remote_Types (Cunit_Ent);
22645 -- pragma Ravenscar;
22647 when Pragma_Ravenscar =>
22649 Check_Arg_Count (0);
22650 Check_Valid_Configuration_Pragma;
22651 Set_Ravenscar_Profile (Ravenscar, N);
22653 if Warn_On_Obsolescent_Feature then
22655 ("pragma Ravenscar is an obsolescent feature?j?", N);
22657 ("|use pragma Profile (Ravenscar) instead?j?", N);
22660 -------------------------
22661 -- Restricted_Run_Time --
22662 -------------------------
22664 -- pragma Restricted_Run_Time;
22666 when Pragma_Restricted_Run_Time =>
22668 Check_Arg_Count (0);
22669 Check_Valid_Configuration_Pragma;
22670 Set_Profile_Restrictions
22671 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
22673 if Warn_On_Obsolescent_Feature then
22675 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
22678 ("|use pragma Profile (Restricted) instead?j?", N);
22685 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
22688 -- restriction_IDENTIFIER
22689 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22691 when Pragma_Restrictions =>
22692 Process_Restrictions_Or_Restriction_Warnings
22693 (Warn => Treat_Restrictions_As_Warnings);
22695 --------------------------
22696 -- Restriction_Warnings --
22697 --------------------------
22699 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
22702 -- restriction_IDENTIFIER
22703 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22705 when Pragma_Restriction_Warnings =>
22707 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
22713 -- pragma Reviewable;
22715 when Pragma_Reviewable =>
22716 Check_Ada_83_Warning;
22717 Check_Arg_Count (0);
22719 -- Call dummy debugging function rv. This is done to assist front
22720 -- end debugging. By placing a Reviewable pragma in the source
22721 -- program, a breakpoint on rv catches this place in the source,
22722 -- allowing convenient stepping to the point of interest.
22726 --------------------------
22727 -- Secondary_Stack_Size --
22728 --------------------------
22730 -- pragma Secondary_Stack_Size (EXPRESSION);
22732 when Pragma_Secondary_Stack_Size => Secondary_Stack_Size : declare
22733 P : constant Node_Id := Parent (N);
22739 Check_No_Identifiers;
22740 Check_Arg_Count (1);
22742 if Nkind (P) = N_Task_Definition then
22743 Arg := Get_Pragma_Arg (Arg1);
22744 Ent := Defining_Identifier (Parent (P));
22746 -- The expression must be analyzed in the special manner
22747 -- described in "Handling of Default Expressions" in sem.ads.
22749 Preanalyze_Spec_Expression (Arg, Any_Integer);
22751 -- The pragma cannot appear if the No_Secondary_Stack
22752 -- restriction is in effect.
22754 Check_Restriction (No_Secondary_Stack, Arg);
22756 -- Anything else is incorrect
22762 -- Check duplicate pragma before we chain the pragma in the Rep
22763 -- Item chain of Ent.
22765 Check_Duplicate_Pragma (Ent);
22766 Record_Rep_Item (Ent, N);
22767 end Secondary_Stack_Size;
22769 --------------------------
22770 -- Short_Circuit_And_Or --
22771 --------------------------
22773 -- pragma Short_Circuit_And_Or;
22775 when Pragma_Short_Circuit_And_Or =>
22777 Check_Arg_Count (0);
22778 Check_Valid_Configuration_Pragma;
22779 Short_Circuit_And_Or := True;
22781 -------------------
22782 -- Share_Generic --
22783 -------------------
22785 -- pragma Share_Generic (GNAME {, GNAME});
22787 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
22789 when Pragma_Share_Generic =>
22791 Process_Generic_List;
22797 -- pragma Shared (LOCAL_NAME);
22799 when Pragma_Shared =>
22801 Process_Atomic_Independent_Shared_Volatile;
22803 --------------------
22804 -- Shared_Passive --
22805 --------------------
22807 -- pragma Shared_Passive [(library_unit_NAME)];
22809 -- Set the flag Is_Shared_Passive of program unit name entity
22811 when Pragma_Shared_Passive => Shared_Passive : declare
22812 Cunit_Node : Node_Id;
22813 Cunit_Ent : Entity_Id;
22816 Check_Ada_83_Warning;
22817 Check_Valid_Library_Unit_Pragma;
22819 if Nkind (N) = N_Null_Statement then
22823 Cunit_Node := Cunit (Current_Sem_Unit);
22824 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22826 -- A pragma that applies to a Ghost entity becomes Ghost for the
22827 -- purposes of legality checks and removal of ignored Ghost code.
22829 Mark_Ghost_Pragma (N, Cunit_Ent);
22831 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
22832 N_Generic_Package_Declaration)
22835 ("pragma% can only apply to a package declaration");
22838 Set_Is_Shared_Passive (Cunit_Ent);
22839 end Shared_Passive;
22841 -----------------------
22842 -- Short_Descriptors --
22843 -----------------------
22845 -- pragma Short_Descriptors;
22847 -- Recognize and validate, but otherwise ignore
22849 when Pragma_Short_Descriptors =>
22851 Check_Arg_Count (0);
22852 Check_Valid_Configuration_Pragma;
22854 ------------------------------
22855 -- Simple_Storage_Pool_Type --
22856 ------------------------------
22858 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
22860 when Pragma_Simple_Storage_Pool_Type =>
22861 Simple_Storage_Pool_Type : declare
22867 Check_Arg_Count (1);
22868 Check_Arg_Is_Library_Level_Local_Name (Arg1);
22870 Type_Id := Get_Pragma_Arg (Arg1);
22871 Find_Type (Type_Id);
22872 Typ := Entity (Type_Id);
22874 if Typ = Any_Type then
22878 -- A pragma that applies to a Ghost entity becomes Ghost for the
22879 -- purposes of legality checks and removal of ignored Ghost code.
22881 Mark_Ghost_Pragma (N, Typ);
22883 -- We require the pragma to apply to a type declared in a package
22884 -- declaration, but not (immediately) within a package body.
22886 if Ekind (Current_Scope) /= E_Package
22887 or else In_Package_Body (Current_Scope)
22890 ("pragma% can only apply to type declared immediately "
22891 & "within a package declaration");
22894 -- A simple storage pool type must be an immutably limited record
22895 -- or private type. If the pragma is given for a private type,
22896 -- the full type is similarly restricted (which is checked later
22897 -- in Freeze_Entity).
22899 if Is_Record_Type (Typ)
22900 and then not Is_Limited_View (Typ)
22903 ("pragma% can only apply to explicitly limited record type");
22905 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
22907 ("pragma% can only apply to a private type that is limited");
22909 elsif not Is_Record_Type (Typ)
22910 and then not Is_Private_Type (Typ)
22913 ("pragma% can only apply to limited record or private type");
22916 Record_Rep_Item (Typ, N);
22917 end Simple_Storage_Pool_Type;
22919 ----------------------
22920 -- Source_File_Name --
22921 ----------------------
22923 -- There are five forms for this pragma:
22925 -- pragma Source_File_Name (
22926 -- [UNIT_NAME =>] unit_NAME,
22927 -- BODY_FILE_NAME => STRING_LITERAL
22928 -- [, [INDEX =>] INTEGER_LITERAL]);
22930 -- pragma Source_File_Name (
22931 -- [UNIT_NAME =>] unit_NAME,
22932 -- SPEC_FILE_NAME => STRING_LITERAL
22933 -- [, [INDEX =>] INTEGER_LITERAL]);
22935 -- pragma Source_File_Name (
22936 -- BODY_FILE_NAME => STRING_LITERAL
22937 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22938 -- [, CASING => CASING_SPEC]);
22940 -- pragma Source_File_Name (
22941 -- SPEC_FILE_NAME => STRING_LITERAL
22942 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22943 -- [, CASING => CASING_SPEC]);
22945 -- pragma Source_File_Name (
22946 -- SUBUNIT_FILE_NAME => STRING_LITERAL
22947 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22948 -- [, CASING => CASING_SPEC]);
22950 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
22952 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
22953 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
22954 -- only be used when no project file is used, while SFNP can only be
22955 -- used when a project file is used.
22957 -- No processing here. Processing was completed during parsing, since
22958 -- we need to have file names set as early as possible. Units are
22959 -- loaded well before semantic processing starts.
22961 -- The only processing we defer to this point is the check for
22962 -- correct placement.
22964 when Pragma_Source_File_Name =>
22966 Check_Valid_Configuration_Pragma;
22968 ------------------------------
22969 -- Source_File_Name_Project --
22970 ------------------------------
22972 -- See Source_File_Name for syntax
22974 -- No processing here. Processing was completed during parsing, since
22975 -- we need to have file names set as early as possible. Units are
22976 -- loaded well before semantic processing starts.
22978 -- The only processing we defer to this point is the check for
22979 -- correct placement.
22981 when Pragma_Source_File_Name_Project =>
22983 Check_Valid_Configuration_Pragma;
22985 -- Check that a pragma Source_File_Name_Project is used only in a
22986 -- configuration pragmas file.
22988 -- Pragmas Source_File_Name_Project should only be generated by
22989 -- the Project Manager in configuration pragmas files.
22991 -- This is really an ugly test. It seems to depend on some
22992 -- accidental and undocumented property. At the very least it
22993 -- needs to be documented, but it would be better to have a
22994 -- clean way of testing if we are in a configuration file???
22996 if Present (Parent (N)) then
22998 ("pragma% can only appear in a configuration pragmas file");
23001 ----------------------
23002 -- Source_Reference --
23003 ----------------------
23005 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
23007 -- Nothing to do, all processing completed in Par.Prag, since we need
23008 -- the information for possible parser messages that are output.
23010 when Pragma_Source_Reference =>
23017 -- pragma SPARK_Mode [(On | Off)];
23019 when Pragma_SPARK_Mode => Do_SPARK_Mode : declare
23020 Mode_Id : SPARK_Mode_Type;
23022 procedure Check_Pragma_Conformance
23023 (Context_Pragma : Node_Id;
23024 Entity : Entity_Id;
23025 Entity_Pragma : Node_Id);
23026 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
23027 -- conformance of pragma N depending the following scenarios:
23029 -- If pragma Context_Pragma is not Empty, verify that pragma N is
23030 -- compatible with the pragma Context_Pragma that was inherited
23031 -- from the context:
23032 -- * If the mode of Context_Pragma is ON, then the new mode can
23034 -- * If the mode of Context_Pragma is OFF, then the only allowed
23035 -- new mode is also OFF. Emit error if this is not the case.
23037 -- If Entity is not Empty, verify that pragma N is compatible with
23038 -- pragma Entity_Pragma that belongs to Entity.
23039 -- * If Entity_Pragma is Empty, always issue an error as this
23040 -- corresponds to the case where a previous section of Entity
23041 -- has no SPARK_Mode set.
23042 -- * If the mode of Entity_Pragma is ON, then the new mode can
23044 -- * If the mode of Entity_Pragma is OFF, then the only allowed
23045 -- new mode is also OFF. Emit error if this is not the case.
23047 procedure Check_Library_Level_Entity (E : Entity_Id);
23048 -- Subsidiary to routines Process_xxx. Verify that the related
23049 -- entity E subject to pragma SPARK_Mode is library-level.
23051 procedure Process_Body (Decl : Node_Id);
23052 -- Verify the legality of pragma SPARK_Mode when it appears as the
23053 -- top of the body declarations of entry, package, protected unit,
23054 -- subprogram or task unit body denoted by Decl.
23056 procedure Process_Overloadable (Decl : Node_Id);
23057 -- Verify the legality of pragma SPARK_Mode when it applies to an
23058 -- entry or [generic] subprogram declaration denoted by Decl.
23060 procedure Process_Private_Part (Decl : Node_Id);
23061 -- Verify the legality of pragma SPARK_Mode when it appears at the
23062 -- top of the private declarations of a package spec, protected or
23063 -- task unit declaration denoted by Decl.
23065 procedure Process_Statement_Part (Decl : Node_Id);
23066 -- Verify the legality of pragma SPARK_Mode when it appears at the
23067 -- top of the statement sequence of a package body denoted by node
23070 procedure Process_Visible_Part (Decl : Node_Id);
23071 -- Verify the legality of pragma SPARK_Mode when it appears at the
23072 -- top of the visible declarations of a package spec, protected or
23073 -- task unit declaration denoted by Decl. The routine is also used
23074 -- on protected or task units declared without a definition.
23076 procedure Set_SPARK_Context;
23077 -- Subsidiary to routines Process_xxx. Set the global variables
23078 -- which represent the mode of the context from pragma N. Ensure
23079 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
23081 ------------------------------
23082 -- Check_Pragma_Conformance --
23083 ------------------------------
23085 procedure Check_Pragma_Conformance
23086 (Context_Pragma : Node_Id;
23087 Entity : Entity_Id;
23088 Entity_Pragma : Node_Id)
23090 Err_Id : Entity_Id;
23094 -- The current pragma may appear without an argument. If this
23095 -- is the case, associate all error messages with the pragma
23098 if Present (Arg1) then
23104 -- The mode of the current pragma is compared against that of
23105 -- an enclosing context.
23107 if Present (Context_Pragma) then
23108 pragma Assert (Nkind (Context_Pragma) = N_Pragma);
23110 -- Issue an error if the new mode is less restrictive than
23111 -- that of the context.
23113 if Get_SPARK_Mode_From_Annotation (Context_Pragma) = Off
23114 and then Get_SPARK_Mode_From_Annotation (N) = On
23117 ("cannot change SPARK_Mode from Off to On", Err_N);
23118 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
23119 Error_Msg_N ("\SPARK_Mode was set to Off#", Err_N);
23124 -- The mode of the current pragma is compared against that of
23125 -- an initial package, protected type, subprogram or task type
23128 if Present (Entity) then
23130 -- A simple protected or task type is transformed into an
23131 -- anonymous type whose name cannot be used to issue error
23132 -- messages. Recover the original entity of the type.
23134 if Ekind_In (Entity, E_Protected_Type, E_Task_Type) then
23137 (Original_Node (Unit_Declaration_Node (Entity)));
23142 -- Both the initial declaration and the completion carry
23143 -- SPARK_Mode pragmas.
23145 if Present (Entity_Pragma) then
23146 pragma Assert (Nkind (Entity_Pragma) = N_Pragma);
23148 -- Issue an error if the new mode is less restrictive
23149 -- than that of the initial declaration.
23151 if Get_SPARK_Mode_From_Annotation (Entity_Pragma) = Off
23152 and then Get_SPARK_Mode_From_Annotation (N) = On
23154 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
23155 Error_Msg_Sloc := Sloc (Entity_Pragma);
23157 ("\value Off was set for SPARK_Mode on&#",
23162 -- Otherwise the initial declaration lacks a SPARK_Mode
23163 -- pragma in which case the current pragma is illegal as
23164 -- it cannot "complete".
23167 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
23168 Error_Msg_Sloc := Sloc (Err_Id);
23170 ("\no value was set for SPARK_Mode on&#",
23175 end Check_Pragma_Conformance;
23177 --------------------------------
23178 -- Check_Library_Level_Entity --
23179 --------------------------------
23181 procedure Check_Library_Level_Entity (E : Entity_Id) is
23182 procedure Add_Entity_To_Name_Buffer;
23183 -- Add the E_Kind of entity E to the name buffer
23185 -------------------------------
23186 -- Add_Entity_To_Name_Buffer --
23187 -------------------------------
23189 procedure Add_Entity_To_Name_Buffer is
23191 if Ekind_In (E, E_Entry, E_Entry_Family) then
23192 Add_Str_To_Name_Buffer ("entry");
23194 elsif Ekind_In (E, E_Generic_Package,
23198 Add_Str_To_Name_Buffer ("package");
23200 elsif Ekind_In (E, E_Protected_Body, E_Protected_Type) then
23201 Add_Str_To_Name_Buffer ("protected type");
23203 elsif Ekind_In (E, E_Function,
23204 E_Generic_Function,
23205 E_Generic_Procedure,
23209 Add_Str_To_Name_Buffer ("subprogram");
23212 pragma Assert (Ekind_In (E, E_Task_Body, E_Task_Type));
23213 Add_Str_To_Name_Buffer ("task type");
23215 end Add_Entity_To_Name_Buffer;
23219 Msg_1 : constant String := "incorrect placement of pragma%";
23222 -- Start of processing for Check_Library_Level_Entity
23225 -- A SPARK_Mode of On shall only apply to library-level
23226 -- entities, except for those in generic instances, which are
23227 -- ignored (even if the entity gets SPARK_Mode pragma attached
23228 -- in the AST, its effect is not taken into account unless the
23229 -- context already provides SPARK_Mode of On in GNATprove).
23231 if Get_SPARK_Mode_From_Annotation (N) = On
23232 and then not Is_Library_Level_Entity (E)
23233 and then Instantiation_Location (Sloc (N)) = No_Location
23235 Error_Msg_Name_1 := Pname;
23236 Error_Msg_N (Fix_Error (Msg_1), N);
23239 Add_Str_To_Name_Buffer ("\& is not a library-level ");
23240 Add_Entity_To_Name_Buffer;
23242 Msg_2 := Name_Find;
23243 Error_Msg_NE (Get_Name_String (Msg_2), N, E);
23247 end Check_Library_Level_Entity;
23253 procedure Process_Body (Decl : Node_Id) is
23254 Body_Id : constant Entity_Id := Defining_Entity (Decl);
23255 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl);
23258 -- Ignore pragma when applied to the special body created for
23259 -- inlining, recognized by its internal name _Parent.
23261 if Chars (Body_Id) = Name_uParent then
23265 Check_Library_Level_Entity (Body_Id);
23267 -- For entry bodies, verify the legality against:
23268 -- * The mode of the context
23269 -- * The mode of the spec (if any)
23271 if Nkind_In (Decl, N_Entry_Body, N_Subprogram_Body) then
23273 -- A stand-alone subprogram body
23275 if Body_Id = Spec_Id then
23276 Check_Pragma_Conformance
23277 (Context_Pragma => SPARK_Pragma (Body_Id),
23279 Entity_Pragma => Empty);
23281 -- An entry or subprogram body that completes a previous
23285 Check_Pragma_Conformance
23286 (Context_Pragma => SPARK_Pragma (Body_Id),
23288 Entity_Pragma => SPARK_Pragma (Spec_Id));
23292 Set_SPARK_Pragma (Body_Id, N);
23293 Set_SPARK_Pragma_Inherited (Body_Id, False);
23295 -- For package bodies, verify the legality against:
23296 -- * The mode of the context
23297 -- * The mode of the private part
23299 -- This case is separated from protected and task bodies
23300 -- because the statement part of the package body inherits
23301 -- the mode of the body declarations.
23303 elsif Nkind (Decl) = N_Package_Body then
23304 Check_Pragma_Conformance
23305 (Context_Pragma => SPARK_Pragma (Body_Id),
23307 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
23310 Set_SPARK_Pragma (Body_Id, N);
23311 Set_SPARK_Pragma_Inherited (Body_Id, False);
23312 Set_SPARK_Aux_Pragma (Body_Id, N);
23313 Set_SPARK_Aux_Pragma_Inherited (Body_Id, True);
23315 -- For protected and task bodies, verify the legality against:
23316 -- * The mode of the context
23317 -- * The mode of the private part
23321 (Nkind_In (Decl, N_Protected_Body, N_Task_Body));
23323 Check_Pragma_Conformance
23324 (Context_Pragma => SPARK_Pragma (Body_Id),
23326 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
23329 Set_SPARK_Pragma (Body_Id, N);
23330 Set_SPARK_Pragma_Inherited (Body_Id, False);
23334 --------------------------
23335 -- Process_Overloadable --
23336 --------------------------
23338 procedure Process_Overloadable (Decl : Node_Id) is
23339 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
23340 Spec_Typ : constant Entity_Id := Etype (Spec_Id);
23343 Check_Library_Level_Entity (Spec_Id);
23345 -- Verify the legality against:
23346 -- * The mode of the context
23348 Check_Pragma_Conformance
23349 (Context_Pragma => SPARK_Pragma (Spec_Id),
23351 Entity_Pragma => Empty);
23353 Set_SPARK_Pragma (Spec_Id, N);
23354 Set_SPARK_Pragma_Inherited (Spec_Id, False);
23356 -- When the pragma applies to the anonymous object created for
23357 -- a single task type, decorate the type as well. This scenario
23358 -- arises when the single task type lacks a task definition,
23359 -- therefore there is no issue with respect to a potential
23360 -- pragma SPARK_Mode in the private part.
23362 -- task type Anon_Task_Typ;
23363 -- Obj : Anon_Task_Typ;
23364 -- pragma SPARK_Mode ...;
23366 if Is_Single_Task_Object (Spec_Id) then
23367 Set_SPARK_Pragma (Spec_Typ, N);
23368 Set_SPARK_Pragma_Inherited (Spec_Typ, False);
23369 Set_SPARK_Aux_Pragma (Spec_Typ, N);
23370 Set_SPARK_Aux_Pragma_Inherited (Spec_Typ, True);
23372 end Process_Overloadable;
23374 --------------------------
23375 -- Process_Private_Part --
23376 --------------------------
23378 procedure Process_Private_Part (Decl : Node_Id) is
23379 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
23382 Check_Library_Level_Entity (Spec_Id);
23384 -- Verify the legality against:
23385 -- * The mode of the visible declarations
23387 Check_Pragma_Conformance
23388 (Context_Pragma => Empty,
23390 Entity_Pragma => SPARK_Pragma (Spec_Id));
23393 Set_SPARK_Aux_Pragma (Spec_Id, N);
23394 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False);
23395 end Process_Private_Part;
23397 ----------------------------
23398 -- Process_Statement_Part --
23399 ----------------------------
23401 procedure Process_Statement_Part (Decl : Node_Id) is
23402 Body_Id : constant Entity_Id := Defining_Entity (Decl);
23405 Check_Library_Level_Entity (Body_Id);
23407 -- Verify the legality against:
23408 -- * The mode of the body declarations
23410 Check_Pragma_Conformance
23411 (Context_Pragma => Empty,
23413 Entity_Pragma => SPARK_Pragma (Body_Id));
23416 Set_SPARK_Aux_Pragma (Body_Id, N);
23417 Set_SPARK_Aux_Pragma_Inherited (Body_Id, False);
23418 end Process_Statement_Part;
23420 --------------------------
23421 -- Process_Visible_Part --
23422 --------------------------
23424 procedure Process_Visible_Part (Decl : Node_Id) is
23425 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
23426 Obj_Id : Entity_Id;
23429 Check_Library_Level_Entity (Spec_Id);
23431 -- Verify the legality against:
23432 -- * The mode of the context
23434 Check_Pragma_Conformance
23435 (Context_Pragma => SPARK_Pragma (Spec_Id),
23437 Entity_Pragma => Empty);
23439 -- A task unit declared without a definition does not set the
23440 -- SPARK_Mode of the context because the task does not have any
23441 -- entries that could inherit the mode.
23443 if not Nkind_In (Decl, N_Single_Task_Declaration,
23444 N_Task_Type_Declaration)
23449 Set_SPARK_Pragma (Spec_Id, N);
23450 Set_SPARK_Pragma_Inherited (Spec_Id, False);
23451 Set_SPARK_Aux_Pragma (Spec_Id, N);
23452 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True);
23454 -- When the pragma applies to a single protected or task type,
23455 -- decorate the corresponding anonymous object as well.
23457 -- protected Anon_Prot_Typ is
23458 -- pragma SPARK_Mode ...;
23460 -- end Anon_Prot_Typ;
23462 -- Obj : Anon_Prot_Typ;
23464 if Is_Single_Concurrent_Type (Spec_Id) then
23465 Obj_Id := Anonymous_Object (Spec_Id);
23467 Set_SPARK_Pragma (Obj_Id, N);
23468 Set_SPARK_Pragma_Inherited (Obj_Id, False);
23470 end Process_Visible_Part;
23472 -----------------------
23473 -- Set_SPARK_Context --
23474 -----------------------
23476 procedure Set_SPARK_Context is
23478 SPARK_Mode := Mode_Id;
23479 SPARK_Mode_Pragma := N;
23480 end Set_SPARK_Context;
23488 -- Start of processing for Do_SPARK_Mode
23491 -- When a SPARK_Mode pragma appears inside an instantiation whose
23492 -- enclosing context has SPARK_Mode set to "off", the pragma has
23493 -- no semantic effect.
23495 if Ignore_SPARK_Mode_Pragmas_In_Instance then
23496 Rewrite (N, Make_Null_Statement (Loc));
23502 Check_No_Identifiers;
23503 Check_At_Most_N_Arguments (1);
23505 -- Check the legality of the mode (no argument = ON)
23507 if Arg_Count = 1 then
23508 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23509 Mode := Chars (Get_Pragma_Arg (Arg1));
23514 Mode_Id := Get_SPARK_Mode_Type (Mode);
23515 Context := Parent (N);
23517 -- The pragma appears in a configuration file
23519 if No (Context) then
23520 Check_Valid_Configuration_Pragma;
23522 if Present (SPARK_Mode_Pragma) then
23525 Prev => SPARK_Mode_Pragma);
23531 -- The pragma acts as a configuration pragma in a compilation unit
23533 -- pragma SPARK_Mode ...;
23534 -- package Pack is ...;
23536 elsif Nkind (Context) = N_Compilation_Unit
23537 and then List_Containing (N) = Context_Items (Context)
23539 Check_Valid_Configuration_Pragma;
23542 -- Otherwise the placement of the pragma within the tree dictates
23543 -- its associated construct. Inspect the declarative list where
23544 -- the pragma resides to find a potential construct.
23548 while Present (Stmt) loop
23550 -- Skip prior pragmas, but check for duplicates. Note that
23551 -- this also takes care of pragmas generated for aspects.
23553 if Nkind (Stmt) = N_Pragma then
23554 if Pragma_Name (Stmt) = Pname then
23561 -- The pragma applies to an expression function that has
23562 -- already been rewritten into a subprogram declaration.
23564 -- function Expr_Func return ... is (...);
23565 -- pragma SPARK_Mode ...;
23567 elsif Nkind (Stmt) = N_Subprogram_Declaration
23568 and then Nkind (Original_Node (Stmt)) =
23569 N_Expression_Function
23571 Process_Overloadable (Stmt);
23574 -- The pragma applies to the anonymous object created for a
23575 -- single concurrent type.
23577 -- protected type Anon_Prot_Typ ...;
23578 -- Obj : Anon_Prot_Typ;
23579 -- pragma SPARK_Mode ...;
23581 elsif Nkind (Stmt) = N_Object_Declaration
23582 and then Is_Single_Concurrent_Object
23583 (Defining_Entity (Stmt))
23585 Process_Overloadable (Stmt);
23588 -- Skip internally generated code
23590 elsif not Comes_From_Source (Stmt) then
23593 -- The pragma applies to an entry or [generic] subprogram
23597 -- pragma SPARK_Mode ...;
23600 -- procedure Proc ...;
23601 -- pragma SPARK_Mode ...;
23603 elsif Nkind_In (Stmt, N_Generic_Subprogram_Declaration,
23604 N_Subprogram_Declaration)
23605 or else (Nkind (Stmt) = N_Entry_Declaration
23606 and then Is_Protected_Type
23607 (Scope (Defining_Entity (Stmt))))
23609 Process_Overloadable (Stmt);
23612 -- Otherwise the pragma does not apply to a legal construct
23613 -- or it does not appear at the top of a declarative or a
23614 -- statement list. Issue an error and stop the analysis.
23624 -- The pragma applies to a package or a subprogram that acts as
23625 -- a compilation unit.
23627 -- procedure Proc ...;
23628 -- pragma SPARK_Mode ...;
23630 if Nkind (Context) = N_Compilation_Unit_Aux then
23631 Context := Unit (Parent (Context));
23634 -- The pragma appears at the top of entry, package, protected
23635 -- unit, subprogram or task unit body declarations.
23637 -- entry Ent when ... is
23638 -- pragma SPARK_Mode ...;
23640 -- package body Pack is
23641 -- pragma SPARK_Mode ...;
23643 -- procedure Proc ... is
23644 -- pragma SPARK_Mode;
23646 -- protected body Prot is
23647 -- pragma SPARK_Mode ...;
23649 if Nkind_In (Context, N_Entry_Body,
23655 Process_Body (Context);
23657 -- The pragma appears at the top of the visible or private
23658 -- declaration of a package spec, protected or task unit.
23661 -- pragma SPARK_Mode ...;
23663 -- pragma SPARK_Mode ...;
23665 -- protected [type] Prot is
23666 -- pragma SPARK_Mode ...;
23668 -- pragma SPARK_Mode ...;
23670 elsif Nkind_In (Context, N_Package_Specification,
23671 N_Protected_Definition,
23674 if List_Containing (N) = Visible_Declarations (Context) then
23675 Process_Visible_Part (Parent (Context));
23677 Process_Private_Part (Parent (Context));
23680 -- The pragma appears at the top of package body statements
23682 -- package body Pack is
23684 -- pragma SPARK_Mode;
23686 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
23687 and then Nkind (Parent (Context)) = N_Package_Body
23689 Process_Statement_Part (Parent (Context));
23691 -- The pragma appeared as an aspect of a [generic] subprogram
23692 -- declaration that acts as a compilation unit.
23695 -- procedure Proc ...;
23696 -- pragma SPARK_Mode ...;
23698 elsif Nkind_In (Context, N_Generic_Subprogram_Declaration,
23699 N_Subprogram_Declaration)
23701 Process_Overloadable (Context);
23703 -- The pragma does not apply to a legal construct, issue error
23711 --------------------------------
23712 -- Static_Elaboration_Desired --
23713 --------------------------------
23715 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
23717 when Pragma_Static_Elaboration_Desired =>
23719 Check_At_Most_N_Arguments (1);
23721 if Is_Compilation_Unit (Current_Scope)
23722 and then Ekind (Current_Scope) = E_Package
23724 Set_Static_Elaboration_Desired (Current_Scope, True);
23726 Error_Pragma ("pragma% must apply to a library-level package");
23733 -- pragma Storage_Size (EXPRESSION);
23735 when Pragma_Storage_Size => Storage_Size : declare
23736 P : constant Node_Id := Parent (N);
23740 Check_No_Identifiers;
23741 Check_Arg_Count (1);
23743 -- The expression must be analyzed in the special manner described
23744 -- in "Handling of Default Expressions" in sem.ads.
23746 Arg := Get_Pragma_Arg (Arg1);
23747 Preanalyze_Spec_Expression (Arg, Any_Integer);
23749 if not Is_OK_Static_Expression (Arg) then
23750 Check_Restriction (Static_Storage_Size, Arg);
23753 if Nkind (P) /= N_Task_Definition then
23758 if Has_Storage_Size_Pragma (P) then
23759 Error_Pragma ("duplicate pragma% not allowed");
23761 Set_Has_Storage_Size_Pragma (P, True);
23764 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
23772 -- pragma Storage_Unit (NUMERIC_LITERAL);
23774 -- Only permitted argument is System'Storage_Unit value
23776 when Pragma_Storage_Unit =>
23777 Check_No_Identifiers;
23778 Check_Arg_Count (1);
23779 Check_Arg_Is_Integer_Literal (Arg1);
23781 if Intval (Get_Pragma_Arg (Arg1)) /=
23782 UI_From_Int (Ttypes.System_Storage_Unit)
23784 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
23786 ("the only allowed argument for pragma% is ^", Arg1);
23789 --------------------
23790 -- Stream_Convert --
23791 --------------------
23793 -- pragma Stream_Convert (
23794 -- [Entity =>] type_LOCAL_NAME,
23795 -- [Read =>] function_NAME,
23796 -- [Write =>] function NAME);
23798 when Pragma_Stream_Convert => Stream_Convert : declare
23799 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
23800 -- Check that the given argument is the name of a local function
23801 -- of one argument that is not overloaded earlier in the current
23802 -- local scope. A check is also made that the argument is a
23803 -- function with one parameter.
23805 --------------------------------------
23806 -- Check_OK_Stream_Convert_Function --
23807 --------------------------------------
23809 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
23813 Check_Arg_Is_Local_Name (Arg);
23814 Ent := Entity (Get_Pragma_Arg (Arg));
23816 if Has_Homonym (Ent) then
23818 ("argument for pragma% may not be overloaded", Arg);
23821 if Ekind (Ent) /= E_Function
23822 or else No (First_Formal (Ent))
23823 or else Present (Next_Formal (First_Formal (Ent)))
23826 ("argument for pragma% must be function of one argument",
23829 end Check_OK_Stream_Convert_Function;
23831 -- Start of processing for Stream_Convert
23835 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
23836 Check_Arg_Count (3);
23837 Check_Optional_Identifier (Arg1, Name_Entity);
23838 Check_Optional_Identifier (Arg2, Name_Read);
23839 Check_Optional_Identifier (Arg3, Name_Write);
23840 Check_Arg_Is_Local_Name (Arg1);
23841 Check_OK_Stream_Convert_Function (Arg2);
23842 Check_OK_Stream_Convert_Function (Arg3);
23845 Typ : constant Entity_Id :=
23846 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
23847 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
23848 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
23851 Check_First_Subtype (Arg1);
23853 -- Check for too early or too late. Note that we don't enforce
23854 -- the rule about primitive operations in this case, since, as
23855 -- is the case for explicit stream attributes themselves, these
23856 -- restrictions are not appropriate. Note that the chaining of
23857 -- the pragma by Rep_Item_Too_Late is actually the critical
23858 -- processing done for this pragma.
23860 if Rep_Item_Too_Early (Typ, N)
23862 Rep_Item_Too_Late (Typ, N, FOnly => True)
23867 -- Return if previous error
23869 if Etype (Typ) = Any_Type
23871 Etype (Read) = Any_Type
23873 Etype (Write) = Any_Type
23880 if Underlying_Type (Etype (Read)) /= Typ then
23882 ("incorrect return type for function&", Arg2);
23885 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
23887 ("incorrect parameter type for function&", Arg3);
23890 if Underlying_Type (Etype (First_Formal (Read))) /=
23891 Underlying_Type (Etype (Write))
23894 ("result type of & does not match Read parameter type",
23898 end Stream_Convert;
23904 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
23906 -- This is processed by the parser since some of the style checks
23907 -- take place during source scanning and parsing. This means that
23908 -- we don't need to issue error messages here.
23910 when Pragma_Style_Checks => Style_Checks : declare
23911 A : constant Node_Id := Get_Pragma_Arg (Arg1);
23917 Check_No_Identifiers;
23919 -- Two argument form
23921 if Arg_Count = 2 then
23922 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23929 E_Id := Get_Pragma_Arg (Arg2);
23932 if not Is_Entity_Name (E_Id) then
23934 ("second argument of pragma% must be entity name",
23938 E := Entity (E_Id);
23940 if not Ignore_Style_Checks_Pragmas then
23945 Set_Suppress_Style_Checks
23946 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off);
23947 exit when No (Homonym (E));
23954 -- One argument form
23957 Check_Arg_Count (1);
23959 if Nkind (A) = N_String_Literal then
23963 Slen : constant Natural := Natural (String_Length (S));
23964 Options : String (1 .. Slen);
23970 C := Get_String_Char (S, Pos (J));
23971 exit when not In_Character_Range (C);
23972 Options (J) := Get_Character (C);
23974 -- If at end of string, set options. As per discussion
23975 -- above, no need to check for errors, since we issued
23976 -- them in the parser.
23979 if not Ignore_Style_Checks_Pragmas then
23980 Set_Style_Check_Options (Options);
23990 elsif Nkind (A) = N_Identifier then
23991 if Chars (A) = Name_All_Checks then
23992 if not Ignore_Style_Checks_Pragmas then
23994 Set_GNAT_Style_Check_Options;
23996 Set_Default_Style_Check_Options;
24000 elsif Chars (A) = Name_On then
24001 if not Ignore_Style_Checks_Pragmas then
24002 Style_Check := True;
24005 elsif Chars (A) = Name_Off then
24006 if not Ignore_Style_Checks_Pragmas then
24007 Style_Check := False;
24018 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
24020 when Pragma_Subtitle =>
24022 Check_Arg_Count (1);
24023 Check_Optional_Identifier (Arg1, Name_Subtitle);
24024 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
24031 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
24033 when Pragma_Suppress =>
24034 Process_Suppress_Unsuppress (Suppress_Case => True);
24040 -- pragma Suppress_All;
24042 -- The only check made here is that the pragma has no arguments.
24043 -- There are no placement rules, and the processing required (setting
24044 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
24045 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
24046 -- then creates and inserts a pragma Suppress (All_Checks).
24048 when Pragma_Suppress_All =>
24050 Check_Arg_Count (0);
24052 -------------------------
24053 -- Suppress_Debug_Info --
24054 -------------------------
24056 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
24058 when Pragma_Suppress_Debug_Info => Suppress_Debug_Info : declare
24059 Nam_Id : Entity_Id;
24063 Check_Arg_Count (1);
24064 Check_Optional_Identifier (Arg1, Name_Entity);
24065 Check_Arg_Is_Local_Name (Arg1);
24067 Nam_Id := Entity (Get_Pragma_Arg (Arg1));
24069 -- A pragma that applies to a Ghost entity becomes Ghost for the
24070 -- purposes of legality checks and removal of ignored Ghost code.
24072 Mark_Ghost_Pragma (N, Nam_Id);
24073 Set_Debug_Info_Off (Nam_Id);
24074 end Suppress_Debug_Info;
24076 ----------------------------------
24077 -- Suppress_Exception_Locations --
24078 ----------------------------------
24080 -- pragma Suppress_Exception_Locations;
24082 when Pragma_Suppress_Exception_Locations =>
24084 Check_Arg_Count (0);
24085 Check_Valid_Configuration_Pragma;
24086 Exception_Locations_Suppressed := True;
24088 -----------------------------
24089 -- Suppress_Initialization --
24090 -----------------------------
24092 -- pragma Suppress_Initialization ([Entity =>] type_Name);
24094 when Pragma_Suppress_Initialization => Suppress_Init : declare
24100 Check_Arg_Count (1);
24101 Check_Optional_Identifier (Arg1, Name_Entity);
24102 Check_Arg_Is_Local_Name (Arg1);
24104 E_Id := Get_Pragma_Arg (Arg1);
24106 if Etype (E_Id) = Any_Type then
24110 E := Entity (E_Id);
24112 -- A pragma that applies to a Ghost entity becomes Ghost for the
24113 -- purposes of legality checks and removal of ignored Ghost code.
24115 Mark_Ghost_Pragma (N, E);
24117 if not Is_Type (E) and then Ekind (E) /= E_Variable then
24119 ("pragma% requires variable, type or subtype", Arg1);
24122 if Rep_Item_Too_Early (E, N)
24124 Rep_Item_Too_Late (E, N, FOnly => True)
24129 -- For incomplete/private type, set flag on full view
24131 if Is_Incomplete_Or_Private_Type (E) then
24132 if No (Full_View (Base_Type (E))) then
24134 ("argument of pragma% cannot be an incomplete type", Arg1);
24136 Set_Suppress_Initialization (Full_View (E));
24139 -- For first subtype, set flag on base type
24141 elsif Is_First_Subtype (E) then
24142 Set_Suppress_Initialization (Base_Type (E));
24144 -- For other than first subtype, set flag on subtype or variable
24147 Set_Suppress_Initialization (E);
24155 -- pragma System_Name (DIRECT_NAME);
24157 -- Syntax check: one argument, which must be the identifier GNAT or
24158 -- the identifier GCC, no other identifiers are acceptable.
24160 when Pragma_System_Name =>
24162 Check_No_Identifiers;
24163 Check_Arg_Count (1);
24164 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
24166 -----------------------------
24167 -- Task_Dispatching_Policy --
24168 -----------------------------
24170 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
24172 when Pragma_Task_Dispatching_Policy => declare
24176 Check_Ada_83_Warning;
24177 Check_Arg_Count (1);
24178 Check_No_Identifiers;
24179 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
24180 Check_Valid_Configuration_Pragma;
24181 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
24182 DP := Fold_Upper (Name_Buffer (1));
24184 if Task_Dispatching_Policy /= ' '
24185 and then Task_Dispatching_Policy /= DP
24187 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
24189 ("task dispatching policy incompatible with policy#");
24191 -- Set new policy, but always preserve System_Location since we
24192 -- like the error message with the run time name.
24195 Task_Dispatching_Policy := DP;
24197 if Task_Dispatching_Policy_Sloc /= System_Location then
24198 Task_Dispatching_Policy_Sloc := Loc;
24207 -- pragma Task_Info (EXPRESSION);
24209 when Pragma_Task_Info => Task_Info : declare
24210 P : constant Node_Id := Parent (N);
24216 if Warn_On_Obsolescent_Feature then
24218 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
24219 & "instead?j?", N);
24222 if Nkind (P) /= N_Task_Definition then
24223 Error_Pragma ("pragma% must appear in task definition");
24226 Check_No_Identifiers;
24227 Check_Arg_Count (1);
24229 Analyze_And_Resolve
24230 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
24232 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
24236 Ent := Defining_Identifier (Parent (P));
24238 -- Check duplicate pragma before we chain the pragma in the Rep
24239 -- Item chain of Ent.
24242 (Ent, Name_Task_Info, Check_Parents => False)
24244 Error_Pragma ("duplicate pragma% not allowed");
24247 Record_Rep_Item (Ent, N);
24254 -- pragma Task_Name (string_EXPRESSION);
24256 when Pragma_Task_Name => Task_Name : declare
24257 P : constant Node_Id := Parent (N);
24262 Check_No_Identifiers;
24263 Check_Arg_Count (1);
24265 Arg := Get_Pragma_Arg (Arg1);
24267 -- The expression is used in the call to Create_Task, and must be
24268 -- expanded there, not in the context of the current spec. It must
24269 -- however be analyzed to capture global references, in case it
24270 -- appears in a generic context.
24272 Preanalyze_And_Resolve (Arg, Standard_String);
24274 if Nkind (P) /= N_Task_Definition then
24278 Ent := Defining_Identifier (Parent (P));
24280 -- Check duplicate pragma before we chain the pragma in the Rep
24281 -- Item chain of Ent.
24284 (Ent, Name_Task_Name, Check_Parents => False)
24286 Error_Pragma ("duplicate pragma% not allowed");
24289 Record_Rep_Item (Ent, N);
24296 -- pragma Task_Storage (
24297 -- [Task_Type =>] LOCAL_NAME,
24298 -- [Top_Guard =>] static_integer_EXPRESSION);
24300 when Pragma_Task_Storage => Task_Storage : declare
24301 Args : Args_List (1 .. 2);
24302 Names : constant Name_List (1 .. 2) := (
24306 Task_Type : Node_Id renames Args (1);
24307 Top_Guard : Node_Id renames Args (2);
24313 Gather_Associations (Names, Args);
24315 if No (Task_Type) then
24317 ("missing task_type argument for pragma%");
24320 Check_Arg_Is_Local_Name (Task_Type);
24322 Ent := Entity (Task_Type);
24324 if not Is_Task_Type (Ent) then
24326 ("argument for pragma% must be task type", Task_Type);
24329 if No (Top_Guard) then
24331 ("pragma% takes two arguments", Task_Type);
24333 Check_Arg_Is_OK_Static_Expression (Top_Guard, Any_Integer);
24336 Check_First_Subtype (Task_Type);
24338 if Rep_Item_Too_Late (Ent, N) then
24347 -- pragma Test_Case
24348 -- ([Name =>] Static_String_EXPRESSION
24349 -- ,[Mode =>] MODE_TYPE
24350 -- [, Requires => Boolean_EXPRESSION]
24351 -- [, Ensures => Boolean_EXPRESSION]);
24353 -- MODE_TYPE ::= Nominal | Robustness
24355 -- Characteristics:
24357 -- * Analysis - The annotation undergoes initial checks to verify
24358 -- the legal placement and context. Secondary checks preanalyze the
24361 -- Analyze_Test_Case_In_Decl_Part
24363 -- * Expansion - None.
24365 -- * Template - The annotation utilizes the generic template of the
24366 -- related subprogram when it is:
24368 -- aspect on subprogram declaration
24370 -- The annotation must prepare its own template when it is:
24372 -- pragma on subprogram declaration
24374 -- * Globals - Capture of global references must occur after full
24377 -- * Instance - The annotation is instantiated automatically when
24378 -- the related generic subprogram is instantiated except for the
24379 -- "pragma on subprogram declaration" case. In that scenario the
24380 -- annotation must instantiate itself.
24382 when Pragma_Test_Case => Test_Case : declare
24383 procedure Check_Distinct_Name (Subp_Id : Entity_Id);
24384 -- Ensure that the contract of subprogram Subp_Id does not contain
24385 -- another Test_Case pragma with the same Name as the current one.
24387 -------------------------
24388 -- Check_Distinct_Name --
24389 -------------------------
24391 procedure Check_Distinct_Name (Subp_Id : Entity_Id) is
24392 Items : constant Node_Id := Contract (Subp_Id);
24393 Name : constant String_Id := Get_Name_From_CTC_Pragma (N);
24397 -- Inspect all Test_Case pragma of the related subprogram
24398 -- looking for one with a duplicate "Name" argument.
24400 if Present (Items) then
24401 Prag := Contract_Test_Cases (Items);
24402 while Present (Prag) loop
24403 if Pragma_Name (Prag) = Name_Test_Case
24405 and then String_Equal
24406 (Name, Get_Name_From_CTC_Pragma (Prag))
24408 Error_Msg_Sloc := Sloc (Prag);
24409 Error_Pragma ("name for pragma % is already used #");
24412 Prag := Next_Pragma (Prag);
24415 end Check_Distinct_Name;
24419 Pack_Decl : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
24422 Subp_Decl : Node_Id;
24423 Subp_Id : Entity_Id;
24425 -- Start of processing for Test_Case
24429 Check_At_Least_N_Arguments (2);
24430 Check_At_Most_N_Arguments (4);
24432 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
24436 Check_Optional_Identifier (Arg1, Name_Name);
24437 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
24441 Check_Optional_Identifier (Arg2, Name_Mode);
24442 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
24444 -- Arguments "Requires" and "Ensures"
24446 if Present (Arg3) then
24447 if Present (Arg4) then
24448 Check_Identifier (Arg3, Name_Requires);
24449 Check_Identifier (Arg4, Name_Ensures);
24451 Check_Identifier_Is_One_Of
24452 (Arg3, Name_Requires, Name_Ensures);
24456 -- Pragma Test_Case must be associated with a subprogram declared
24457 -- in a library-level package. First determine whether the current
24458 -- compilation unit is a legal context.
24460 if Nkind_In (Pack_Decl, N_Package_Declaration,
24461 N_Generic_Package_Declaration)
24465 -- Otherwise the placement is illegal
24469 ("pragma % must be specified within a package declaration");
24473 Subp_Decl := Find_Related_Declaration_Or_Body (N);
24475 -- Find the enclosing context
24477 Context := Parent (Subp_Decl);
24479 if Present (Context) then
24480 Context := Parent (Context);
24483 -- Verify the placement of the pragma
24485 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
24487 ("pragma % cannot be applied to abstract subprogram");
24490 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
24491 Error_Pragma ("pragma % cannot be applied to entry");
24494 -- The context is a [generic] subprogram declared at the top level
24495 -- of the [generic] package unit.
24497 elsif Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration,
24498 N_Subprogram_Declaration)
24499 and then Present (Context)
24500 and then Nkind_In (Context, N_Generic_Package_Declaration,
24501 N_Package_Declaration)
24505 -- Otherwise the placement is illegal
24509 ("pragma % must be applied to a library-level subprogram "
24514 Subp_Id := Defining_Entity (Subp_Decl);
24516 -- A pragma that applies to a Ghost entity becomes Ghost for the
24517 -- purposes of legality checks and removal of ignored Ghost code.
24519 Mark_Ghost_Pragma (N, Subp_Id);
24521 -- Chain the pragma on the contract for further processing by
24522 -- Analyze_Test_Case_In_Decl_Part.
24524 Add_Contract_Item (N, Subp_Id);
24526 -- Preanalyze the original aspect argument "Name" for ASIS or for
24527 -- a generic subprogram to properly capture global references.
24529 if ASIS_Mode or else Is_Generic_Subprogram (Subp_Id) then
24530 Asp_Arg := Test_Case_Arg (N, Name_Name, From_Aspect => True);
24532 if Present (Asp_Arg) then
24534 -- The argument appears with an identifier in association
24537 if Nkind (Asp_Arg) = N_Component_Association then
24538 Asp_Arg := Expression (Asp_Arg);
24541 Check_Expr_Is_OK_Static_Expression
24542 (Asp_Arg, Standard_String);
24546 -- Ensure that the all Test_Case pragmas of the related subprogram
24547 -- have distinct names.
24549 Check_Distinct_Name (Subp_Id);
24551 -- Fully analyze the pragma when it appears inside an entry
24552 -- or subprogram body because it cannot benefit from forward
24555 if Nkind_In (Subp_Decl, N_Entry_Body,
24557 N_Subprogram_Body_Stub)
24559 -- The legality checks of pragma Test_Case are affected by the
24560 -- SPARK mode in effect and the volatility of the context.
24561 -- Analyze all pragmas in a specific order.
24563 Analyze_If_Present (Pragma_SPARK_Mode);
24564 Analyze_If_Present (Pragma_Volatile_Function);
24565 Analyze_Test_Case_In_Decl_Part (N);
24569 --------------------------
24570 -- Thread_Local_Storage --
24571 --------------------------
24573 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
24575 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
24581 Check_Arg_Count (1);
24582 Check_Optional_Identifier (Arg1, Name_Entity);
24583 Check_Arg_Is_Library_Level_Local_Name (Arg1);
24585 Id := Get_Pragma_Arg (Arg1);
24588 if not Is_Entity_Name (Id)
24589 or else Ekind (Entity (Id)) /= E_Variable
24591 Error_Pragma_Arg ("local variable name required", Arg1);
24596 -- A pragma that applies to a Ghost entity becomes Ghost for the
24597 -- purposes of legality checks and removal of ignored Ghost code.
24599 Mark_Ghost_Pragma (N, E);
24601 if Rep_Item_Too_Early (E, N)
24603 Rep_Item_Too_Late (E, N)
24608 Set_Has_Pragma_Thread_Local_Storage (E);
24609 Set_Has_Gigi_Rep_Item (E);
24610 end Thread_Local_Storage;
24616 -- pragma Time_Slice (static_duration_EXPRESSION);
24618 when Pragma_Time_Slice => Time_Slice : declare
24624 Check_Arg_Count (1);
24625 Check_No_Identifiers;
24626 Check_In_Main_Program;
24627 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_Duration);
24629 if not Error_Posted (Arg1) then
24631 while Present (Nod) loop
24632 if Nkind (Nod) = N_Pragma
24633 and then Pragma_Name (Nod) = Name_Time_Slice
24635 Error_Msg_Name_1 := Pname;
24636 Error_Msg_N ("duplicate pragma% not permitted", Nod);
24643 -- Process only if in main unit
24645 if Get_Source_Unit (Loc) = Main_Unit then
24646 Opt.Time_Slice_Set := True;
24647 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
24649 if Val <= Ureal_0 then
24650 Opt.Time_Slice_Value := 0;
24652 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
24653 Opt.Time_Slice_Value := 1_000_000_000;
24656 Opt.Time_Slice_Value :=
24657 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
24666 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
24668 -- TITLING_OPTION ::=
24669 -- [Title =>] STRING_LITERAL
24670 -- | [Subtitle =>] STRING_LITERAL
24672 when Pragma_Title => Title : declare
24673 Args : Args_List (1 .. 2);
24674 Names : constant Name_List (1 .. 2) := (
24680 Gather_Associations (Names, Args);
24683 for J in 1 .. 2 loop
24684 if Present (Args (J)) then
24685 Check_Arg_Is_OK_Static_Expression
24686 (Args (J), Standard_String);
24691 ----------------------------
24692 -- Type_Invariant[_Class] --
24693 ----------------------------
24695 -- pragma Type_Invariant[_Class]
24696 -- ([Entity =>] type_LOCAL_NAME,
24697 -- [Check =>] EXPRESSION);
24699 when Pragma_Type_Invariant
24700 | Pragma_Type_Invariant_Class
24702 Type_Invariant : declare
24703 I_Pragma : Node_Id;
24706 Check_Arg_Count (2);
24708 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
24709 -- setting Class_Present for the Type_Invariant_Class case.
24711 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class);
24712 I_Pragma := New_Copy (N);
24713 Set_Pragma_Identifier
24714 (I_Pragma, Make_Identifier (Loc, Name_Invariant));
24715 Rewrite (N, I_Pragma);
24716 Set_Analyzed (N, False);
24718 end Type_Invariant;
24720 ---------------------
24721 -- Unchecked_Union --
24722 ---------------------
24724 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
24726 when Pragma_Unchecked_Union => Unchecked_Union : declare
24727 Assoc : constant Node_Id := Arg1;
24728 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
24738 Check_No_Identifiers;
24739 Check_Arg_Count (1);
24740 Check_Arg_Is_Local_Name (Arg1);
24742 Find_Type (Type_Id);
24744 Typ := Entity (Type_Id);
24746 -- A pragma that applies to a Ghost entity becomes Ghost for the
24747 -- purposes of legality checks and removal of ignored Ghost code.
24749 Mark_Ghost_Pragma (N, Typ);
24752 or else Rep_Item_Too_Early (Typ, N)
24756 Typ := Underlying_Type (Typ);
24759 if Rep_Item_Too_Late (Typ, N) then
24763 Check_First_Subtype (Arg1);
24765 -- Note remaining cases are references to a type in the current
24766 -- declarative part. If we find an error, we post the error on
24767 -- the relevant type declaration at an appropriate point.
24769 if not Is_Record_Type (Typ) then
24770 Error_Msg_N ("unchecked union must be record type", Typ);
24773 elsif Is_Tagged_Type (Typ) then
24774 Error_Msg_N ("unchecked union must not be tagged", Typ);
24777 elsif not Has_Discriminants (Typ) then
24779 ("unchecked union must have one discriminant", Typ);
24782 -- Note: in previous versions of GNAT we used to check for limited
24783 -- types and give an error, but in fact the standard does allow
24784 -- Unchecked_Union on limited types, so this check was removed.
24786 -- Similarly, GNAT used to require that all discriminants have
24787 -- default values, but this is not mandated by the RM.
24789 -- Proceed with basic error checks completed
24792 Tdef := Type_Definition (Declaration_Node (Typ));
24793 Clist := Component_List (Tdef);
24795 -- Check presence of component list and variant part
24797 if No (Clist) or else No (Variant_Part (Clist)) then
24799 ("unchecked union must have variant part", Tdef);
24803 -- Check components
24805 Comp := First_Non_Pragma (Component_Items (Clist));
24806 while Present (Comp) loop
24807 Check_Component (Comp, Typ);
24808 Next_Non_Pragma (Comp);
24811 -- Check variant part
24813 Vpart := Variant_Part (Clist);
24815 Variant := First_Non_Pragma (Variants (Vpart));
24816 while Present (Variant) loop
24817 Check_Variant (Variant, Typ);
24818 Next_Non_Pragma (Variant);
24822 Set_Is_Unchecked_Union (Typ);
24823 Set_Convention (Typ, Convention_C);
24824 Set_Has_Unchecked_Union (Base_Type (Typ));
24825 Set_Is_Unchecked_Union (Base_Type (Typ));
24826 end Unchecked_Union;
24828 ----------------------------
24829 -- Unevaluated_Use_Of_Old --
24830 ----------------------------
24832 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
24834 when Pragma_Unevaluated_Use_Of_Old =>
24836 Check_Arg_Count (1);
24837 Check_No_Identifiers;
24838 Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow);
24840 -- Suppress/Unsuppress can appear as a configuration pragma, or in
24841 -- a declarative part or a package spec.
24843 if not Is_Configuration_Pragma then
24844 Check_Is_In_Decl_Part_Or_Package_Spec;
24847 -- Store proper setting of Uneval_Old
24849 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
24850 Uneval_Old := Fold_Upper (Name_Buffer (1));
24852 ------------------------
24853 -- Unimplemented_Unit --
24854 ------------------------
24856 -- pragma Unimplemented_Unit;
24858 -- Note: this only gives an error if we are generating code, or if
24859 -- we are in a generic library unit (where the pragma appears in the
24860 -- body, not in the spec).
24862 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
24863 Cunitent : constant Entity_Id :=
24864 Cunit_Entity (Get_Source_Unit (Loc));
24865 Ent_Kind : constant Entity_Kind := Ekind (Cunitent);
24869 Check_Arg_Count (0);
24871 if Operating_Mode = Generate_Code
24872 or else Ent_Kind = E_Generic_Function
24873 or else Ent_Kind = E_Generic_Procedure
24874 or else Ent_Kind = E_Generic_Package
24876 Get_Name_String (Chars (Cunitent));
24877 Set_Casing (Mixed_Case);
24878 Write_Str (Name_Buffer (1 .. Name_Len));
24879 Write_Str (" is not supported in this configuration");
24881 raise Unrecoverable_Error;
24883 end Unimplemented_Unit;
24885 ------------------------
24886 -- Universal_Aliasing --
24887 ------------------------
24889 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
24891 when Pragma_Universal_Aliasing => Universal_Alias : declare
24897 Check_Arg_Count (1);
24898 Check_Optional_Identifier (Arg2, Name_Entity);
24899 Check_Arg_Is_Local_Name (Arg1);
24900 E_Id := Get_Pragma_Arg (Arg1);
24902 if Etype (E_Id) = Any_Type then
24906 E := Entity (E_Id);
24908 if not Is_Type (E) then
24909 Error_Pragma_Arg ("pragma% requires type", Arg1);
24912 -- A pragma that applies to a Ghost entity becomes Ghost for the
24913 -- purposes of legality checks and removal of ignored Ghost code.
24915 Mark_Ghost_Pragma (N, E);
24916 Set_Universal_Aliasing (Base_Type (E));
24917 Record_Rep_Item (E, N);
24918 end Universal_Alias;
24920 --------------------
24921 -- Universal_Data --
24922 --------------------
24924 -- pragma Universal_Data [(library_unit_NAME)];
24926 when Pragma_Universal_Data =>
24928 Error_Pragma ("??pragma% ignored (applies only to AAMP)");
24934 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
24936 when Pragma_Unmodified =>
24937 Analyze_Unmodified_Or_Unused;
24943 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
24945 -- or when used in a context clause:
24947 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
24949 when Pragma_Unreferenced =>
24950 Analyze_Unreferenced_Or_Unused;
24952 --------------------------
24953 -- Unreferenced_Objects --
24954 --------------------------
24956 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
24958 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
24960 Arg_Expr : Node_Id;
24961 Arg_Id : Entity_Id;
24963 Ghost_Error_Posted : Boolean := False;
24964 -- Flag set when an error concerning the illegal mix of Ghost and
24965 -- non-Ghost types is emitted.
24967 Ghost_Id : Entity_Id := Empty;
24968 -- The entity of the first Ghost type encountered while processing
24969 -- the arguments of the pragma.
24973 Check_At_Least_N_Arguments (1);
24976 while Present (Arg) loop
24977 Check_No_Identifier (Arg);
24978 Check_Arg_Is_Local_Name (Arg);
24979 Arg_Expr := Get_Pragma_Arg (Arg);
24981 if Is_Entity_Name (Arg_Expr) then
24982 Arg_Id := Entity (Arg_Expr);
24984 if Is_Type (Arg_Id) then
24985 Set_Has_Pragma_Unreferenced_Objects (Arg_Id);
24987 -- A pragma that applies to a Ghost entity becomes Ghost
24988 -- for the purposes of legality checks and removal of
24989 -- ignored Ghost code.
24991 Mark_Ghost_Pragma (N, Arg_Id);
24993 -- Capture the entity of the first Ghost type being
24994 -- processed for error detection purposes.
24996 if Is_Ghost_Entity (Arg_Id) then
24997 if No (Ghost_Id) then
24998 Ghost_Id := Arg_Id;
25001 -- Otherwise the type is non-Ghost. It is illegal to mix
25002 -- references to Ghost and non-Ghost entities
25005 elsif Present (Ghost_Id)
25006 and then not Ghost_Error_Posted
25008 Ghost_Error_Posted := True;
25010 Error_Msg_Name_1 := Pname;
25012 ("pragma % cannot mention ghost and non-ghost types",
25015 Error_Msg_Sloc := Sloc (Ghost_Id);
25016 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
25018 Error_Msg_Sloc := Sloc (Arg_Id);
25019 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
25023 ("argument for pragma% must be type or subtype", Arg);
25027 ("argument for pragma% must be type or subtype", Arg);
25032 end Unreferenced_Objects;
25034 ------------------------------
25035 -- Unreserve_All_Interrupts --
25036 ------------------------------
25038 -- pragma Unreserve_All_Interrupts;
25040 when Pragma_Unreserve_All_Interrupts =>
25042 Check_Arg_Count (0);
25044 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
25045 Unreserve_All_Interrupts := True;
25052 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
25054 when Pragma_Unsuppress =>
25056 Process_Suppress_Unsuppress (Suppress_Case => False);
25062 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
25064 when Pragma_Unused =>
25065 Analyze_Unmodified_Or_Unused (Is_Unused => True);
25066 Analyze_Unreferenced_Or_Unused (Is_Unused => True);
25068 -------------------
25069 -- Use_VADS_Size --
25070 -------------------
25072 -- pragma Use_VADS_Size;
25074 when Pragma_Use_VADS_Size =>
25076 Check_Arg_Count (0);
25077 Check_Valid_Configuration_Pragma;
25078 Use_VADS_Size := True;
25080 ---------------------
25081 -- Validity_Checks --
25082 ---------------------
25084 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
25086 when Pragma_Validity_Checks => Validity_Checks : declare
25087 A : constant Node_Id := Get_Pragma_Arg (Arg1);
25093 Check_Arg_Count (1);
25094 Check_No_Identifiers;
25096 -- Pragma always active unless in CodePeer or GNATprove modes,
25097 -- which use a fixed configuration of validity checks.
25099 if not (CodePeer_Mode or GNATprove_Mode) then
25100 if Nkind (A) = N_String_Literal then
25104 Slen : constant Natural := Natural (String_Length (S));
25105 Options : String (1 .. Slen);
25109 -- Couldn't we use a for loop here over Options'Range???
25113 C := Get_String_Char (S, Pos (J));
25115 -- This is a weird test, it skips setting validity
25116 -- checks entirely if any element of S is out of
25117 -- range of Character, what is that about ???
25119 exit when not In_Character_Range (C);
25120 Options (J) := Get_Character (C);
25123 Set_Validity_Check_Options (Options);
25131 elsif Nkind (A) = N_Identifier then
25132 if Chars (A) = Name_All_Checks then
25133 Set_Validity_Check_Options ("a");
25134 elsif Chars (A) = Name_On then
25135 Validity_Checks_On := True;
25136 elsif Chars (A) = Name_Off then
25137 Validity_Checks_On := False;
25141 end Validity_Checks;
25147 -- pragma Volatile (LOCAL_NAME);
25149 when Pragma_Volatile =>
25150 Process_Atomic_Independent_Shared_Volatile;
25152 -------------------------
25153 -- Volatile_Components --
25154 -------------------------
25156 -- pragma Volatile_Components (array_LOCAL_NAME);
25158 -- Volatile is handled by the same circuit as Atomic_Components
25160 --------------------------
25161 -- Volatile_Full_Access --
25162 --------------------------
25164 -- pragma Volatile_Full_Access (LOCAL_NAME);
25166 when Pragma_Volatile_Full_Access =>
25168 Process_Atomic_Independent_Shared_Volatile;
25170 -----------------------
25171 -- Volatile_Function --
25172 -----------------------
25174 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
25176 when Pragma_Volatile_Function => Volatile_Function : declare
25177 Over_Id : Entity_Id;
25178 Spec_Id : Entity_Id;
25179 Subp_Decl : Node_Id;
25183 Check_No_Identifiers;
25184 Check_At_Most_N_Arguments (1);
25187 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
25189 -- Generic subprogram
25191 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
25194 -- Body acts as spec
25196 elsif Nkind (Subp_Decl) = N_Subprogram_Body
25197 and then No (Corresponding_Spec (Subp_Decl))
25201 -- Body stub acts as spec
25203 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
25204 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
25210 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
25218 Spec_Id := Unique_Defining_Entity (Subp_Decl);
25220 if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
25225 -- A pragma that applies to a Ghost entity becomes Ghost for the
25226 -- purposes of legality checks and removal of ignored Ghost code.
25228 Mark_Ghost_Pragma (N, Spec_Id);
25230 -- Chain the pragma on the contract for completeness
25232 Add_Contract_Item (N, Spec_Id);
25234 -- The legality checks of pragma Volatile_Function are affected by
25235 -- the SPARK mode in effect. Analyze all pragmas in a specific
25238 Analyze_If_Present (Pragma_SPARK_Mode);
25240 -- A volatile function cannot override a non-volatile function
25241 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
25242 -- in New_Overloaded_Entity, however at that point the pragma has
25243 -- not been processed yet.
25245 Over_Id := Overridden_Operation (Spec_Id);
25247 if Present (Over_Id)
25248 and then not Is_Volatile_Function (Over_Id)
25251 ("incompatible volatile function values in effect", Spec_Id);
25253 Error_Msg_Sloc := Sloc (Over_Id);
25255 ("\& declared # with Volatile_Function value False",
25258 Error_Msg_Sloc := Sloc (Spec_Id);
25260 ("\overridden # with Volatile_Function value True",
25264 -- Analyze the Boolean expression (if any)
25266 if Present (Arg1) then
25267 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
25269 end Volatile_Function;
25271 ----------------------
25272 -- Warning_As_Error --
25273 ----------------------
25275 -- pragma Warning_As_Error (static_string_EXPRESSION);
25277 when Pragma_Warning_As_Error =>
25279 Check_Arg_Count (1);
25280 Check_No_Identifiers;
25281 Check_Valid_Configuration_Pragma;
25283 if not Is_Static_String_Expression (Arg1) then
25285 ("argument of pragma% must be static string expression",
25288 -- OK static string expression
25291 Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1;
25292 Warnings_As_Errors (Warnings_As_Errors_Count) :=
25293 new String'(Acquire_Warning_Match_String
25294 (Expr_Value_S (Get_Pragma_Arg (Arg1))));
25301 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
25303 -- DETAILS ::= On | Off
25304 -- DETAILS ::= On | Off, local_NAME
25305 -- DETAILS ::= static_string_EXPRESSION
25306 -- DETAILS ::= On | Off, static_string_EXPRESSION
25308 -- TOOL_NAME ::= GNAT | GNATProve
25310 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
25312 -- Note: If the first argument matches an allowed tool name, it is
25313 -- always considered to be a tool name, even if there is a string
25314 -- variable of that name.
25316 -- Note if the second argument of DETAILS is a local_NAME then the
25317 -- second form is always understood. If the intention is to use
25318 -- the fourth form, then you can write NAME & "" to force the
25319 -- intepretation as a static_string_EXPRESSION.
25321 when Pragma_Warnings => Warnings : declare
25322 Reason : String_Id;
25326 Check_At_Least_N_Arguments (1);
25328 -- See if last argument is labeled Reason. If so, make sure we
25329 -- have a string literal or a concatenation of string literals,
25330 -- and acquire the REASON string. Then remove the REASON argument
25331 -- by decreasing Num_Args by one; Remaining processing looks only
25332 -- at first Num_Args arguments).
25335 Last_Arg : constant Node_Id :=
25336 Last (Pragma_Argument_Associations (N));
25339 if Nkind (Last_Arg) = N_Pragma_Argument_Association
25340 and then Chars (Last_Arg) = Name_Reason
25343 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
25344 Reason := End_String;
25345 Arg_Count := Arg_Count - 1;
25347 -- Not allowed in compiler units (bootstrap issues)
25349 Check_Compiler_Unit ("Reason for pragma Warnings", N);
25351 -- No REASON string, set null string as reason
25354 Reason := Null_String_Id;
25358 -- Now proceed with REASON taken care of and eliminated
25360 Check_No_Identifiers;
25362 -- If debug flag -gnatd.i is set, pragma is ignored
25364 if Debug_Flag_Dot_I then
25368 -- Process various forms of the pragma
25371 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
25372 Shifted_Args : List_Id;
25375 -- See if first argument is a tool name, currently either
25376 -- GNAT or GNATprove. If so, either ignore the pragma if the
25377 -- tool used does not match, or continue as if no tool name
25378 -- was given otherwise, by shifting the arguments.
25380 if Nkind (Argx) = N_Identifier
25381 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
25383 if Chars (Argx) = Name_Gnat then
25384 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
25385 Rewrite (N, Make_Null_Statement (Loc));
25390 elsif Chars (Argx) = Name_Gnatprove then
25391 if not GNATprove_Mode then
25392 Rewrite (N, Make_Null_Statement (Loc));
25398 raise Program_Error;
25401 -- At this point, the pragma Warnings applies to the tool,
25402 -- so continue with shifted arguments.
25404 Arg_Count := Arg_Count - 1;
25406 if Arg_Count = 1 then
25407 Shifted_Args := New_List (New_Copy (Arg2));
25408 elsif Arg_Count = 2 then
25409 Shifted_Args := New_List (New_Copy (Arg2),
25411 elsif Arg_Count = 3 then
25412 Shifted_Args := New_List (New_Copy (Arg2),
25416 raise Program_Error;
25421 Chars => Name_Warnings,
25422 Pragma_Argument_Associations => Shifted_Args));
25427 -- One argument case
25429 if Arg_Count = 1 then
25431 -- On/Off one argument case was processed by parser
25433 if Nkind (Argx) = N_Identifier
25434 and then Nam_In (Chars (Argx), Name_On, Name_Off)
25438 -- One argument case must be ON/OFF or static string expr
25440 elsif not Is_Static_String_Expression (Arg1) then
25442 ("argument of pragma% must be On/Off or static string "
25443 & "expression", Arg1);
25445 -- One argument string expression case
25449 Lit : constant Node_Id := Expr_Value_S (Argx);
25450 Str : constant String_Id := Strval (Lit);
25451 Len : constant Nat := String_Length (Str);
25459 while J <= Len loop
25460 C := Get_String_Char (Str, J);
25461 OK := In_Character_Range (C);
25464 Chr := Get_Character (C);
25466 -- Dash case: only -Wxxx is accepted
25473 C := Get_String_Char (Str, J);
25474 Chr := Get_Character (C);
25475 exit when Chr = 'W';
25480 elsif J < Len and then Chr = '.' then
25482 C := Get_String_Char (Str, J);
25483 Chr := Get_Character (C);
25485 if not Set_Dot_Warning_Switch (Chr) then
25487 ("invalid warning switch character "
25488 & '.' & Chr, Arg1);
25494 OK := Set_Warning_Switch (Chr);
25499 ("invalid warning switch character " & Chr,
25505 ("invalid wide character in warning switch ",
25514 -- Two or more arguments (must be two)
25517 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
25518 Check_Arg_Count (2);
25526 E_Id := Get_Pragma_Arg (Arg2);
25529 -- In the expansion of an inlined body, a reference to
25530 -- the formal may be wrapped in a conversion if the
25531 -- actual is a conversion. Retrieve the real entity name.
25533 if (In_Instance_Body or In_Inlined_Body)
25534 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
25536 E_Id := Expression (E_Id);
25539 -- Entity name case
25541 if Is_Entity_Name (E_Id) then
25542 E := Entity (E_Id);
25549 (E, (Chars (Get_Pragma_Arg (Arg1)) =
25552 -- Suppress elaboration warnings if the entity
25553 -- denotes an elaboration target.
25555 if Is_Elaboration_Target (E) then
25556 Set_Is_Elaboration_Warnings_OK_Id (E, False);
25559 -- For OFF case, make entry in warnings off
25560 -- pragma table for later processing. But we do
25561 -- not do that within an instance, since these
25562 -- warnings are about what is needed in the
25563 -- template, not an instance of it.
25565 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
25566 and then Warn_On_Warnings_Off
25567 and then not In_Instance
25569 Warnings_Off_Pragmas.Append ((N, E, Reason));
25572 if Is_Enumeration_Type (E) then
25576 Lit := First_Literal (E);
25577 while Present (Lit) loop
25578 Set_Warnings_Off (Lit);
25579 Next_Literal (Lit);
25584 exit when No (Homonym (E));
25589 -- Error if not entity or static string expression case
25591 elsif not Is_Static_String_Expression (Arg2) then
25593 ("second argument of pragma% must be entity name "
25594 & "or static string expression", Arg2);
25596 -- Static string expression case
25599 -- Note on configuration pragma case: If this is a
25600 -- configuration pragma, then for an OFF pragma, we
25601 -- just set Config True in the call, which is all
25602 -- that needs to be done. For the case of ON, this
25603 -- is normally an error, unless it is canceling the
25604 -- effect of a previous OFF pragma in the same file.
25605 -- In any other case, an error will be signalled (ON
25606 -- with no matching OFF).
25608 -- Note: We set Used if we are inside a generic to
25609 -- disable the test that the non-config case actually
25610 -- cancels a warning. That's because we can't be sure
25611 -- there isn't an instantiation in some other unit
25612 -- where a warning is suppressed.
25614 -- We could do a little better here by checking if the
25615 -- generic unit we are inside is public, but for now
25616 -- we don't bother with that refinement.
25619 Message : constant String :=
25620 Acquire_Warning_Match_String
25621 (Expr_Value_S (Get_Pragma_Arg (Arg2)));
25623 if Chars (Argx) = Name_Off then
25624 Set_Specific_Warning_Off
25625 (Loc, Message, Reason,
25626 Config => Is_Configuration_Pragma,
25627 Used => Inside_A_Generic or else In_Instance);
25629 elsif Chars (Argx) = Name_On then
25630 Set_Specific_Warning_On (Loc, Message, Err);
25634 ("??pragma Warnings On with no matching "
25635 & "Warnings Off", Loc);
25645 -------------------
25646 -- Weak_External --
25647 -------------------
25649 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
25651 when Pragma_Weak_External => Weak_External : declare
25656 Check_Arg_Count (1);
25657 Check_Optional_Identifier (Arg1, Name_Entity);
25658 Check_Arg_Is_Library_Level_Local_Name (Arg1);
25659 Ent := Entity (Get_Pragma_Arg (Arg1));
25661 if Rep_Item_Too_Early (Ent, N) then
25664 Ent := Underlying_Type (Ent);
25667 -- The pragma applies to entities with addresses
25669 if Is_Type (Ent) then
25670 Error_Pragma ("pragma applies to objects and subprograms");
25673 -- The only processing required is to link this item on to the
25674 -- list of rep items for the given entity. This is accomplished
25675 -- by the call to Rep_Item_Too_Late (when no error is detected
25676 -- and False is returned).
25678 if Rep_Item_Too_Late (Ent, N) then
25681 Set_Has_Gigi_Rep_Item (Ent);
25685 -----------------------------
25686 -- Wide_Character_Encoding --
25687 -----------------------------
25689 -- pragma Wide_Character_Encoding (IDENTIFIER);
25691 when Pragma_Wide_Character_Encoding =>
25694 -- Nothing to do, handled in parser. Note that we do not enforce
25695 -- configuration pragma placement, this pragma can appear at any
25696 -- place in the source, allowing mixed encodings within a single
25701 --------------------
25702 -- Unknown_Pragma --
25703 --------------------
25705 -- Should be impossible, since the case of an unknown pragma is
25706 -- separately processed before the case statement is entered.
25708 when Unknown_Pragma =>
25709 raise Program_Error;
25712 -- AI05-0144: detect dangerous order dependence. Disabled for now,
25713 -- until AI is formally approved.
25715 -- Check_Order_Dependence;
25718 when Pragma_Exit => null;
25719 end Analyze_Pragma;
25721 ---------------------------------------------
25722 -- Analyze_Pre_Post_Condition_In_Decl_Part --
25723 ---------------------------------------------
25725 -- WARNING: This routine manages Ghost regions. Return statements must be
25726 -- replaced by gotos which jump to the end of the routine and restore the
25729 procedure Analyze_Pre_Post_Condition_In_Decl_Part
25731 Freeze_Id : Entity_Id := Empty)
25733 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
25734 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
25736 Disp_Typ : Entity_Id;
25737 -- The dispatching type of the subprogram subject to the pre- or
25740 function Check_References (Nod : Node_Id) return Traverse_Result;
25741 -- Check that expression Nod does not mention non-primitives of the
25742 -- type, global objects of the type, or other illegalities described
25743 -- and implied by AI12-0113.
25745 ----------------------
25746 -- Check_References --
25747 ----------------------
25749 function Check_References (Nod : Node_Id) return Traverse_Result is
25751 if Nkind (Nod) = N_Function_Call
25752 and then Is_Entity_Name (Name (Nod))
25755 Func : constant Entity_Id := Entity (Name (Nod));
25759 -- An operation of the type must be a primitive
25761 if No (Find_Dispatching_Type (Func)) then
25762 Form := First_Formal (Func);
25763 while Present (Form) loop
25764 if Etype (Form) = Disp_Typ then
25766 ("operation in class-wide condition must be "
25767 & "primitive of &", Nod, Disp_Typ);
25770 Next_Formal (Form);
25773 -- A return object of the type is illegal as well
25775 if Etype (Func) = Disp_Typ
25776 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
25779 ("operation in class-wide condition must be primitive "
25780 & "of &", Nod, Disp_Typ);
25783 -- Otherwise we have a call to an overridden primitive, and we
25784 -- will create a common class-wide clone for the body of
25785 -- original operation and its eventual inherited versions. If
25786 -- the original operation dispatches on result it is never
25787 -- inherited and there is no need for a clone. There is not
25788 -- need for a clone either in GNATprove mode, as cases that
25789 -- would require it are rejected (when an inherited primitive
25790 -- calls an overridden operation in a class-wide contract), and
25791 -- the clone would make proof impossible in some cases.
25793 elsif not Is_Abstract_Subprogram (Spec_Id)
25794 and then No (Class_Wide_Clone (Spec_Id))
25795 and then not Has_Controlling_Result (Spec_Id)
25796 and then not GNATprove_Mode
25798 Build_Class_Wide_Clone_Decl (Spec_Id);
25802 elsif Is_Entity_Name (Nod)
25804 (Etype (Nod) = Disp_Typ
25805 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
25806 and then Ekind_In (Entity (Nod), E_Constant, E_Variable)
25809 ("object in class-wide condition must be formal of type &",
25812 elsif Nkind (Nod) = N_Explicit_Dereference
25813 and then (Etype (Nod) = Disp_Typ
25814 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
25815 and then (not Is_Entity_Name (Prefix (Nod))
25816 or else not Is_Formal (Entity (Prefix (Nod))))
25819 ("operation in class-wide condition must be primitive of &",
25824 end Check_References;
25826 procedure Check_Class_Wide_Condition is
25827 new Traverse_Proc (Check_References);
25831 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
25833 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
25834 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
25835 -- Save the Ghost-related attributes to restore on exit
25838 Restore_Scope : Boolean := False;
25840 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
25843 -- Do not analyze the pragma multiple times
25845 if Is_Analyzed_Pragma (N) then
25849 -- Set the Ghost mode in effect from the pragma. Due to the delayed
25850 -- analysis of the pragma, the Ghost mode at point of declaration and
25851 -- point of analysis may not necessarily be the same. Use the mode in
25852 -- effect at the point of declaration.
25854 Set_Ghost_Mode (N);
25856 -- Ensure that the subprogram and its formals are visible when analyzing
25857 -- the expression of the pragma.
25859 if not In_Open_Scopes (Spec_Id) then
25860 Restore_Scope := True;
25861 Push_Scope (Spec_Id);
25863 if Is_Generic_Subprogram (Spec_Id) then
25864 Install_Generic_Formals (Spec_Id);
25866 Install_Formals (Spec_Id);
25870 Errors := Serious_Errors_Detected;
25871 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
25873 -- Emit a clarification message when the expression contains at least
25874 -- one undefined reference, possibly due to contract freezing.
25876 if Errors /= Serious_Errors_Detected
25877 and then Present (Freeze_Id)
25878 and then Has_Undefined_Reference (Expr)
25880 Contract_Freeze_Error (Spec_Id, Freeze_Id);
25883 if Class_Present (N) then
25885 -- Verify that a class-wide condition is legal, i.e. the operation is
25886 -- a primitive of a tagged type. Note that a generic subprogram is
25887 -- not a primitive operation.
25889 Disp_Typ := Find_Dispatching_Type (Spec_Id);
25891 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
25892 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
25894 if From_Aspect_Specification (N) then
25896 ("aspect % can only be specified for a primitive operation "
25897 & "of a tagged type", Corresponding_Aspect (N));
25899 -- The pragma is a source construct
25903 ("pragma % can only be specified for a primitive operation "
25904 & "of a tagged type", N);
25907 -- Remaining semantic checks require a full tree traversal
25910 Check_Class_Wide_Condition (Expr);
25915 if Restore_Scope then
25919 -- If analysis of the condition indicates that a class-wide clone
25920 -- has been created, build and analyze its declaration.
25922 if Is_Subprogram (Spec_Id)
25923 and then Present (Class_Wide_Clone (Spec_Id))
25925 Analyze (Unit_Declaration_Node (Class_Wide_Clone (Spec_Id)));
25928 -- Currently it is not possible to inline pre/postconditions on a
25929 -- subprogram subject to pragma Inline_Always.
25931 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
25932 Set_Is_Analyzed_Pragma (N);
25934 Restore_Ghost_Region (Saved_GM, Saved_IGR);
25935 end Analyze_Pre_Post_Condition_In_Decl_Part;
25937 ------------------------------------------
25938 -- Analyze_Refined_Depends_In_Decl_Part --
25939 ------------------------------------------
25941 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
25942 procedure Check_Dependency_Clause
25943 (Spec_Id : Entity_Id;
25944 Dep_Clause : Node_Id;
25945 Dep_States : Elist_Id;
25946 Refinements : List_Id;
25947 Matched_Items : in out Elist_Id);
25948 -- Try to match a single dependency clause Dep_Clause against one or
25949 -- more refinement clauses found in list Refinements. Each successful
25950 -- match eliminates at least one refinement clause from Refinements.
25951 -- Spec_Id denotes the entity of the related subprogram. Dep_States
25952 -- denotes the entities of all abstract states which appear in pragma
25953 -- Depends. Matched_Items contains the entities of all successfully
25954 -- matched items found in pragma Depends.
25956 procedure Check_Output_States
25957 (Spec_Id : Entity_Id;
25958 Spec_Inputs : Elist_Id;
25959 Spec_Outputs : Elist_Id;
25960 Body_Inputs : Elist_Id;
25961 Body_Outputs : Elist_Id);
25962 -- Determine whether pragma Depends contains an output state with a
25963 -- visible refinement and if so, ensure that pragma Refined_Depends
25964 -- mentions all its constituents as outputs. Spec_Id is the entity of
25965 -- the related subprograms. Spec_Inputs and Spec_Outputs denote the
25966 -- inputs and outputs of the subprogram spec synthesized from pragma
25967 -- Depends. Body_Inputs and Body_Outputs denote the inputs and outputs
25968 -- of the subprogram body synthesized from pragma Refined_Depends.
25970 function Collect_States (Clauses : List_Id) return Elist_Id;
25971 -- Given a normalized list of dependencies obtained from calling
25972 -- Normalize_Clauses, return a list containing the entities of all
25973 -- states appearing in dependencies. It helps in checking refinements
25974 -- involving a state and a corresponding constituent which is not a
25975 -- direct constituent of the state.
25977 procedure Normalize_Clauses (Clauses : List_Id);
25978 -- Given a list of dependence or refinement clauses Clauses, normalize
25979 -- each clause by creating multiple dependencies with exactly one input
25982 procedure Remove_Extra_Clauses
25983 (Clauses : List_Id;
25984 Matched_Items : Elist_Id);
25985 -- Given a list of refinement clauses Clauses, remove all clauses whose
25986 -- inputs and/or outputs have been previously matched. See the body for
25987 -- all special cases. Matched_Items contains the entities of all matched
25988 -- items found in pragma Depends.
25990 procedure Report_Extra_Clauses
25991 (Spec_Id : Entity_Id;
25992 Clauses : List_Id);
25993 -- Emit an error for each extra clause found in list Clauses. Spec_Id
25994 -- denotes the entity of the related subprogram.
25996 -----------------------------
25997 -- Check_Dependency_Clause --
25998 -----------------------------
26000 procedure Check_Dependency_Clause
26001 (Spec_Id : Entity_Id;
26002 Dep_Clause : Node_Id;
26003 Dep_States : Elist_Id;
26004 Refinements : List_Id;
26005 Matched_Items : in out Elist_Id)
26007 Dep_Input : constant Node_Id := Expression (Dep_Clause);
26008 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
26010 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
26011 -- Determine whether dependency item Dep_Item has been matched in a
26012 -- previous clause.
26014 function Is_In_Out_State_Clause return Boolean;
26015 -- Determine whether dependence clause Dep_Clause denotes an abstract
26016 -- state that depends on itself (State => State).
26018 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
26019 -- Determine whether item Item denotes an abstract state with visible
26020 -- null refinement.
26022 procedure Match_Items
26023 (Dep_Item : Node_Id;
26024 Ref_Item : Node_Id;
26025 Matched : out Boolean);
26026 -- Try to match dependence item Dep_Item against refinement item
26027 -- Ref_Item. To match against a possible null refinement (see 2, 9),
26028 -- set Ref_Item to Empty. Flag Matched is set to True when one of
26029 -- the following conformance scenarios is in effect:
26030 -- 1) Both items denote null
26031 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
26032 -- 3) Both items denote attribute 'Result
26033 -- 4) Both items denote the same object
26034 -- 5) Both items denote the same formal parameter
26035 -- 6) Both items denote the same current instance of a type
26036 -- 7) Both items denote the same discriminant
26037 -- 8) Dep_Item is an abstract state with visible null refinement
26038 -- and Ref_Item denotes null.
26039 -- 9) Dep_Item is an abstract state with visible null refinement
26040 -- and Ref_Item is Empty (special case).
26041 -- 10) Dep_Item is an abstract state with full or partial visible
26042 -- non-null refinement and Ref_Item denotes one of its
26044 -- 11) Dep_Item is an abstract state without a full visible
26045 -- refinement and Ref_Item denotes the same state.
26046 -- When scenario 10 is in effect, the entity of the abstract state
26047 -- denoted by Dep_Item is added to list Refined_States.
26049 procedure Record_Item (Item_Id : Entity_Id);
26050 -- Store the entity of an item denoted by Item_Id in Matched_Items
26052 ------------------------
26053 -- Is_Already_Matched --
26054 ------------------------
26056 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean is
26057 Item_Id : Entity_Id := Empty;
26060 -- When the dependency item denotes attribute 'Result, check for
26061 -- the entity of the related subprogram.
26063 if Is_Attribute_Result (Dep_Item) then
26064 Item_Id := Spec_Id;
26066 elsif Is_Entity_Name (Dep_Item) then
26067 Item_Id := Available_View (Entity_Of (Dep_Item));
26071 Present (Item_Id) and then Contains (Matched_Items, Item_Id);
26072 end Is_Already_Matched;
26074 ----------------------------
26075 -- Is_In_Out_State_Clause --
26076 ----------------------------
26078 function Is_In_Out_State_Clause return Boolean is
26079 Dep_Input_Id : Entity_Id;
26080 Dep_Output_Id : Entity_Id;
26083 -- Detect the following clause:
26086 if Is_Entity_Name (Dep_Input)
26087 and then Is_Entity_Name (Dep_Output)
26089 -- Handle abstract views generated for limited with clauses
26091 Dep_Input_Id := Available_View (Entity_Of (Dep_Input));
26092 Dep_Output_Id := Available_View (Entity_Of (Dep_Output));
26095 Ekind (Dep_Input_Id) = E_Abstract_State
26096 and then Dep_Input_Id = Dep_Output_Id;
26100 end Is_In_Out_State_Clause;
26102 ---------------------------
26103 -- Is_Null_Refined_State --
26104 ---------------------------
26106 function Is_Null_Refined_State (Item : Node_Id) return Boolean is
26107 Item_Id : Entity_Id;
26110 if Is_Entity_Name (Item) then
26112 -- Handle abstract views generated for limited with clauses
26114 Item_Id := Available_View (Entity_Of (Item));
26117 Ekind (Item_Id) = E_Abstract_State
26118 and then Has_Null_Visible_Refinement (Item_Id);
26122 end Is_Null_Refined_State;
26128 procedure Match_Items
26129 (Dep_Item : Node_Id;
26130 Ref_Item : Node_Id;
26131 Matched : out Boolean)
26133 Dep_Item_Id : Entity_Id;
26134 Ref_Item_Id : Entity_Id;
26137 -- Assume that the two items do not match
26141 -- A null matches null or Empty (special case)
26143 if Nkind (Dep_Item) = N_Null
26144 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
26148 -- Attribute 'Result matches attribute 'Result
26150 elsif Is_Attribute_Result (Dep_Item)
26151 and then Is_Attribute_Result (Ref_Item)
26153 -- Put the entity of the related function on the list of
26154 -- matched items because attribute 'Result does not carry
26155 -- an entity similar to states and constituents.
26157 Record_Item (Spec_Id);
26160 -- Abstract states, current instances of concurrent types,
26161 -- discriminants, formal parameters and objects.
26163 elsif Is_Entity_Name (Dep_Item) then
26165 -- Handle abstract views generated for limited with clauses
26167 Dep_Item_Id := Available_View (Entity_Of (Dep_Item));
26169 if Ekind (Dep_Item_Id) = E_Abstract_State then
26171 -- An abstract state with visible null refinement matches
26172 -- null or Empty (special case).
26174 if Has_Null_Visible_Refinement (Dep_Item_Id)
26175 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
26177 Record_Item (Dep_Item_Id);
26180 -- An abstract state with visible non-null refinement
26181 -- matches one of its constituents, or itself for an
26182 -- abstract state with partial visible refinement.
26184 elsif Has_Non_Null_Visible_Refinement (Dep_Item_Id) then
26185 if Is_Entity_Name (Ref_Item) then
26186 Ref_Item_Id := Entity_Of (Ref_Item);
26188 if Ekind_In (Ref_Item_Id, E_Abstract_State,
26191 and then Present (Encapsulating_State (Ref_Item_Id))
26192 and then Find_Encapsulating_State
26193 (Dep_States, Ref_Item_Id) = Dep_Item_Id
26195 Record_Item (Dep_Item_Id);
26198 elsif not Has_Visible_Refinement (Dep_Item_Id)
26199 and then Ref_Item_Id = Dep_Item_Id
26201 Record_Item (Dep_Item_Id);
26206 -- An abstract state without a visible refinement matches
26209 elsif Is_Entity_Name (Ref_Item)
26210 and then Entity_Of (Ref_Item) = Dep_Item_Id
26212 Record_Item (Dep_Item_Id);
26216 -- A current instance of a concurrent type, discriminant,
26217 -- formal parameter or an object matches itself.
26219 elsif Is_Entity_Name (Ref_Item)
26220 and then Entity_Of (Ref_Item) = Dep_Item_Id
26222 Record_Item (Dep_Item_Id);
26232 procedure Record_Item (Item_Id : Entity_Id) is
26234 if No (Matched_Items) then
26235 Matched_Items := New_Elmt_List;
26238 Append_Unique_Elmt (Item_Id, Matched_Items);
26243 Clause_Matched : Boolean := False;
26244 Dummy : Boolean := False;
26245 Inputs_Match : Boolean;
26246 Next_Ref_Clause : Node_Id;
26247 Outputs_Match : Boolean;
26248 Ref_Clause : Node_Id;
26249 Ref_Input : Node_Id;
26250 Ref_Output : Node_Id;
26252 -- Start of processing for Check_Dependency_Clause
26255 -- Do not perform this check in an instance because it was already
26256 -- performed successfully in the generic template.
26258 if Is_Generic_Instance (Spec_Id) then
26262 -- Examine all refinement clauses and compare them against the
26263 -- dependence clause.
26265 Ref_Clause := First (Refinements);
26266 while Present (Ref_Clause) loop
26267 Next_Ref_Clause := Next (Ref_Clause);
26269 -- Obtain the attributes of the current refinement clause
26271 Ref_Input := Expression (Ref_Clause);
26272 Ref_Output := First (Choices (Ref_Clause));
26274 -- The current refinement clause matches the dependence clause
26275 -- when both outputs match and both inputs match. See routine
26276 -- Match_Items for all possible conformance scenarios.
26278 -- Depends Dep_Output => Dep_Input
26282 -- Refined_Depends Ref_Output => Ref_Input
26285 (Dep_Item => Dep_Input,
26286 Ref_Item => Ref_Input,
26287 Matched => Inputs_Match);
26290 (Dep_Item => Dep_Output,
26291 Ref_Item => Ref_Output,
26292 Matched => Outputs_Match);
26294 -- An In_Out state clause may be matched against a refinement with
26295 -- a null input or null output as long as the non-null side of the
26296 -- relation contains a valid constituent of the In_Out_State.
26298 if Is_In_Out_State_Clause then
26300 -- Depends => (State => State)
26301 -- Refined_Depends => (null => Constit) -- OK
26304 and then not Outputs_Match
26305 and then Nkind (Ref_Output) = N_Null
26307 Outputs_Match := True;
26310 -- Depends => (State => State)
26311 -- Refined_Depends => (Constit => null) -- OK
26313 if not Inputs_Match
26314 and then Outputs_Match
26315 and then Nkind (Ref_Input) = N_Null
26317 Inputs_Match := True;
26321 -- The current refinement clause is legally constructed following
26322 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
26323 -- the pool of candidates. The seach continues because a single
26324 -- dependence clause may have multiple matching refinements.
26326 if Inputs_Match and Outputs_Match then
26327 Clause_Matched := True;
26328 Remove (Ref_Clause);
26331 Ref_Clause := Next_Ref_Clause;
26334 -- Depending on the order or composition of refinement clauses, an
26335 -- In_Out state clause may not be directly refinable.
26337 -- Refined_State => (State => (Constit_1, Constit_2))
26338 -- Depends => ((Output, State) => (Input, State))
26339 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
26341 -- Matching normalized clause (State => State) fails because there is
26342 -- no direct refinement capable of satisfying this relation. Another
26343 -- similar case arises when clauses (Constit_1 => Input) and (Output
26344 -- => Constit_2) are matched first, leaving no candidates for clause
26345 -- (State => State). Both scenarios are legal as long as one of the
26346 -- previous clauses mentioned a valid constituent of State.
26348 if not Clause_Matched
26349 and then Is_In_Out_State_Clause
26350 and then Is_Already_Matched (Dep_Input)
26352 Clause_Matched := True;
26355 -- A clause where the input is an abstract state with visible null
26356 -- refinement or a 'Result attribute is implicitly matched when the
26357 -- output has already been matched in a previous clause.
26359 -- Refined_State => (State => null)
26360 -- Depends => (Output => State) -- implicitly OK
26361 -- Refined_Depends => (Output => ...)
26362 -- Depends => (...'Result => State) -- implicitly OK
26363 -- Refined_Depends => (...'Result => ...)
26365 if not Clause_Matched
26366 and then Is_Null_Refined_State (Dep_Input)
26367 and then Is_Already_Matched (Dep_Output)
26369 Clause_Matched := True;
26372 -- A clause where the output is an abstract state with visible null
26373 -- refinement is implicitly matched when the input has already been
26374 -- matched in a previous clause.
26376 -- Refined_State => (State => null)
26377 -- Depends => (State => Input) -- implicitly OK
26378 -- Refined_Depends => (... => Input)
26380 if not Clause_Matched
26381 and then Is_Null_Refined_State (Dep_Output)
26382 and then Is_Already_Matched (Dep_Input)
26384 Clause_Matched := True;
26387 -- At this point either all refinement clauses have been examined or
26388 -- pragma Refined_Depends contains a solitary null. Only an abstract
26389 -- state with null refinement can possibly match these cases.
26391 -- Refined_State => (State => null)
26392 -- Depends => (State => null)
26393 -- Refined_Depends => null -- OK
26395 if not Clause_Matched then
26397 (Dep_Item => Dep_Input,
26399 Matched => Inputs_Match);
26402 (Dep_Item => Dep_Output,
26404 Matched => Outputs_Match);
26406 Clause_Matched := Inputs_Match and Outputs_Match;
26409 -- If the contents of Refined_Depends are legal, then the current
26410 -- dependence clause should be satisfied either by an explicit match
26411 -- or by one of the special cases.
26413 if not Clause_Matched then
26415 (Fix_Msg (Spec_Id, "dependence clause of subprogram & has no "
26416 & "matching refinement in body"), Dep_Clause, Spec_Id);
26418 end Check_Dependency_Clause;
26420 -------------------------
26421 -- Check_Output_States --
26422 -------------------------
26424 procedure Check_Output_States
26425 (Spec_Id : Entity_Id;
26426 Spec_Inputs : Elist_Id;
26427 Spec_Outputs : Elist_Id;
26428 Body_Inputs : Elist_Id;
26429 Body_Outputs : Elist_Id)
26431 procedure Check_Constituent_Usage (State_Id : Entity_Id);
26432 -- Determine whether all constituents of state State_Id with full
26433 -- visible refinement are used as outputs in pragma Refined_Depends.
26434 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
26436 -----------------------------
26437 -- Check_Constituent_Usage --
26438 -----------------------------
26440 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
26441 Constits : constant Elist_Id :=
26442 Partial_Refinement_Constituents (State_Id);
26443 Constit_Elmt : Elmt_Id;
26444 Constit_Id : Entity_Id;
26445 Only_Partial : constant Boolean :=
26446 not Has_Visible_Refinement (State_Id);
26447 Posted : Boolean := False;
26450 if Present (Constits) then
26451 Constit_Elmt := First_Elmt (Constits);
26452 while Present (Constit_Elmt) loop
26453 Constit_Id := Node (Constit_Elmt);
26455 -- Issue an error when a constituent of State_Id is used,
26456 -- and State_Id has only partial visible refinement
26457 -- (SPARK RM 7.2.4(3d)).
26459 if Only_Partial then
26460 if (Present (Body_Inputs)
26461 and then Appears_In (Body_Inputs, Constit_Id))
26463 (Present (Body_Outputs)
26464 and then Appears_In (Body_Outputs, Constit_Id))
26466 Error_Msg_Name_1 := Chars (State_Id);
26468 ("constituent & of state % cannot be used in "
26469 & "dependence refinement", N, Constit_Id);
26470 Error_Msg_Name_1 := Chars (State_Id);
26471 SPARK_Msg_N ("\use state % instead", N);
26474 -- The constituent acts as an input (SPARK RM 7.2.5(3))
26476 elsif Present (Body_Inputs)
26477 and then Appears_In (Body_Inputs, Constit_Id)
26479 Error_Msg_Name_1 := Chars (State_Id);
26481 ("constituent & of state % must act as output in "
26482 & "dependence refinement", N, Constit_Id);
26484 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
26486 elsif No (Body_Outputs)
26487 or else not Appears_In (Body_Outputs, Constit_Id)
26492 ("output state & must be replaced by all its "
26493 & "constituents in dependence refinement",
26498 ("\constituent & is missing in output list",
26502 Next_Elmt (Constit_Elmt);
26505 end Check_Constituent_Usage;
26510 Item_Elmt : Elmt_Id;
26511 Item_Id : Entity_Id;
26513 -- Start of processing for Check_Output_States
26516 -- Do not perform this check in an instance because it was already
26517 -- performed successfully in the generic template.
26519 if Is_Generic_Instance (Spec_Id) then
26522 -- Inspect the outputs of pragma Depends looking for a state with a
26523 -- visible refinement.
26525 elsif Present (Spec_Outputs) then
26526 Item_Elmt := First_Elmt (Spec_Outputs);
26527 while Present (Item_Elmt) loop
26528 Item := Node (Item_Elmt);
26530 -- Deal with the mixed nature of the input and output lists
26532 if Nkind (Item) = N_Defining_Identifier then
26535 Item_Id := Available_View (Entity_Of (Item));
26538 if Ekind (Item_Id) = E_Abstract_State then
26540 -- The state acts as an input-output, skip it
26542 if Present (Spec_Inputs)
26543 and then Appears_In (Spec_Inputs, Item_Id)
26547 -- Ensure that all of the constituents are utilized as
26548 -- outputs in pragma Refined_Depends.
26550 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
26551 Check_Constituent_Usage (Item_Id);
26555 Next_Elmt (Item_Elmt);
26558 end Check_Output_States;
26560 --------------------
26561 -- Collect_States --
26562 --------------------
26564 function Collect_States (Clauses : List_Id) return Elist_Id is
26565 procedure Collect_State
26567 States : in out Elist_Id);
26568 -- Add the entity of Item to list States when it denotes to a state
26570 -------------------
26571 -- Collect_State --
26572 -------------------
26574 procedure Collect_State
26576 States : in out Elist_Id)
26581 if Is_Entity_Name (Item) then
26582 Id := Entity_Of (Item);
26584 if Ekind (Id) = E_Abstract_State then
26585 if No (States) then
26586 States := New_Elmt_List;
26589 Append_Unique_Elmt (Id, States);
26599 States : Elist_Id := No_Elist;
26601 -- Start of processing for Collect_States
26604 Clause := First (Clauses);
26605 while Present (Clause) loop
26606 Input := Expression (Clause);
26607 Output := First (Choices (Clause));
26609 Collect_State (Input, States);
26610 Collect_State (Output, States);
26616 end Collect_States;
26618 -----------------------
26619 -- Normalize_Clauses --
26620 -----------------------
26622 procedure Normalize_Clauses (Clauses : List_Id) is
26623 procedure Normalize_Inputs (Clause : Node_Id);
26624 -- Normalize clause Clause by creating multiple clauses for each
26625 -- input item of Clause. It is assumed that Clause has exactly one
26626 -- output. The transformation is as follows:
26628 -- Output => (Input_1, Input_2) -- original
26630 -- Output => Input_1 -- normalizations
26631 -- Output => Input_2
26633 procedure Normalize_Outputs (Clause : Node_Id);
26634 -- Normalize clause Clause by creating multiple clause for each
26635 -- output item of Clause. The transformation is as follows:
26637 -- (Output_1, Output_2) => Input -- original
26639 -- Output_1 => Input -- normalization
26640 -- Output_2 => Input
26642 ----------------------
26643 -- Normalize_Inputs --
26644 ----------------------
26646 procedure Normalize_Inputs (Clause : Node_Id) is
26647 Inputs : constant Node_Id := Expression (Clause);
26648 Loc : constant Source_Ptr := Sloc (Clause);
26649 Output : constant List_Id := Choices (Clause);
26650 Last_Input : Node_Id;
26652 New_Clause : Node_Id;
26653 Next_Input : Node_Id;
26656 -- Normalization is performed only when the original clause has
26657 -- more than one input. Multiple inputs appear as an aggregate.
26659 if Nkind (Inputs) = N_Aggregate then
26660 Last_Input := Last (Expressions (Inputs));
26662 -- Create a new clause for each input
26664 Input := First (Expressions (Inputs));
26665 while Present (Input) loop
26666 Next_Input := Next (Input);
26668 -- Unhook the current input from the original input list
26669 -- because it will be relocated to a new clause.
26673 -- Special processing for the last input. At this point the
26674 -- original aggregate has been stripped down to one element.
26675 -- Replace the aggregate by the element itself.
26677 if Input = Last_Input then
26678 Rewrite (Inputs, Input);
26680 -- Generate a clause of the form:
26685 Make_Component_Association (Loc,
26686 Choices => New_Copy_List_Tree (Output),
26687 Expression => Input);
26689 -- The new clause contains replicated content that has
26690 -- already been analyzed, mark the clause as analyzed.
26692 Set_Analyzed (New_Clause);
26693 Insert_After (Clause, New_Clause);
26696 Input := Next_Input;
26699 end Normalize_Inputs;
26701 -----------------------
26702 -- Normalize_Outputs --
26703 -----------------------
26705 procedure Normalize_Outputs (Clause : Node_Id) is
26706 Inputs : constant Node_Id := Expression (Clause);
26707 Loc : constant Source_Ptr := Sloc (Clause);
26708 Outputs : constant Node_Id := First (Choices (Clause));
26709 Last_Output : Node_Id;
26710 New_Clause : Node_Id;
26711 Next_Output : Node_Id;
26715 -- Multiple outputs appear as an aggregate. Nothing to do when
26716 -- the clause has exactly one output.
26718 if Nkind (Outputs) = N_Aggregate then
26719 Last_Output := Last (Expressions (Outputs));
26721 -- Create a clause for each output. Note that each time a new
26722 -- clause is created, the original output list slowly shrinks
26723 -- until there is one item left.
26725 Output := First (Expressions (Outputs));
26726 while Present (Output) loop
26727 Next_Output := Next (Output);
26729 -- Unhook the output from the original output list as it
26730 -- will be relocated to a new clause.
26734 -- Special processing for the last output. At this point
26735 -- the original aggregate has been stripped down to one
26736 -- element. Replace the aggregate by the element itself.
26738 if Output = Last_Output then
26739 Rewrite (Outputs, Output);
26742 -- Generate a clause of the form:
26743 -- (Output => Inputs)
26746 Make_Component_Association (Loc,
26747 Choices => New_List (Output),
26748 Expression => New_Copy_Tree (Inputs));
26750 -- The new clause contains replicated content that has
26751 -- already been analyzed. There is not need to reanalyze
26754 Set_Analyzed (New_Clause);
26755 Insert_After (Clause, New_Clause);
26758 Output := Next_Output;
26761 end Normalize_Outputs;
26767 -- Start of processing for Normalize_Clauses
26770 Clause := First (Clauses);
26771 while Present (Clause) loop
26772 Normalize_Outputs (Clause);
26776 Clause := First (Clauses);
26777 while Present (Clause) loop
26778 Normalize_Inputs (Clause);
26781 end Normalize_Clauses;
26783 --------------------------
26784 -- Remove_Extra_Clauses --
26785 --------------------------
26787 procedure Remove_Extra_Clauses
26788 (Clauses : List_Id;
26789 Matched_Items : Elist_Id)
26793 Input_Id : Entity_Id;
26794 Next_Clause : Node_Id;
26796 State_Id : Entity_Id;
26799 Clause := First (Clauses);
26800 while Present (Clause) loop
26801 Next_Clause := Next (Clause);
26803 Input := Expression (Clause);
26804 Output := First (Choices (Clause));
26806 -- Recognize a clause of the form
26810 -- where Input is a constituent of a state which was already
26811 -- successfully matched. This clause must be removed because it
26812 -- simply indicates that some of the constituents of the state
26815 -- Refined_State => (State => (Constit_1, Constit_2))
26816 -- Depends => (Output => State)
26817 -- Refined_Depends => ((Output => Constit_1), -- State matched
26818 -- (null => Constit_2)) -- OK
26820 if Nkind (Output) = N_Null and then Is_Entity_Name (Input) then
26822 -- Handle abstract views generated for limited with clauses
26824 Input_Id := Available_View (Entity_Of (Input));
26826 -- The input must be a constituent of a state
26828 if Ekind_In (Input_Id, E_Abstract_State,
26831 and then Present (Encapsulating_State (Input_Id))
26833 State_Id := Encapsulating_State (Input_Id);
26835 -- The state must have a non-null visible refinement and be
26836 -- matched in a previous clause.
26838 if Has_Non_Null_Visible_Refinement (State_Id)
26839 and then Contains (Matched_Items, State_Id)
26845 -- Recognize a clause of the form
26849 -- where Output is an arbitrary item. This clause must be removed
26850 -- because a null input legitimately matches anything.
26852 elsif Nkind (Input) = N_Null then
26856 Clause := Next_Clause;
26858 end Remove_Extra_Clauses;
26860 --------------------------
26861 -- Report_Extra_Clauses --
26862 --------------------------
26864 procedure Report_Extra_Clauses
26865 (Spec_Id : Entity_Id;
26871 -- Do not perform this check in an instance because it was already
26872 -- performed successfully in the generic template.
26874 if Is_Generic_Instance (Spec_Id) then
26877 elsif Present (Clauses) then
26878 Clause := First (Clauses);
26879 while Present (Clause) loop
26881 ("unmatched or extra clause in dependence refinement",
26887 end Report_Extra_Clauses;
26891 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
26892 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
26893 Errors : constant Nat := Serious_Errors_Detected;
26900 Body_Inputs : Elist_Id := No_Elist;
26901 Body_Outputs : Elist_Id := No_Elist;
26902 -- The inputs and outputs of the subprogram body synthesized from pragma
26903 -- Refined_Depends.
26905 Dependencies : List_Id := No_List;
26907 -- The corresponding Depends pragma along with its clauses
26909 Matched_Items : Elist_Id := No_Elist;
26910 -- A list containing the entities of all successfully matched items
26911 -- found in pragma Depends.
26913 Refinements : List_Id := No_List;
26914 -- The clauses of pragma Refined_Depends
26916 Spec_Id : Entity_Id;
26917 -- The entity of the subprogram subject to pragma Refined_Depends
26919 Spec_Inputs : Elist_Id := No_Elist;
26920 Spec_Outputs : Elist_Id := No_Elist;
26921 -- The inputs and outputs of the subprogram spec synthesized from pragma
26924 States : Elist_Id := No_Elist;
26925 -- A list containing the entities of all states whose constituents
26926 -- appear in pragma Depends.
26928 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
26931 -- Do not analyze the pragma multiple times
26933 if Is_Analyzed_Pragma (N) then
26937 Spec_Id := Unique_Defining_Entity (Body_Decl);
26939 -- Use the anonymous object as the proper spec when Refined_Depends
26940 -- applies to the body of a single task type. The object carries the
26941 -- proper Chars as well as all non-refined versions of pragmas.
26943 if Is_Single_Concurrent_Type (Spec_Id) then
26944 Spec_Id := Anonymous_Object (Spec_Id);
26947 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
26949 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
26950 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
26952 if No (Depends) then
26954 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
26955 & "& lacks aspect or pragma Depends"), N, Spec_Id);
26959 Deps := Expression (Get_Argument (Depends, Spec_Id));
26961 -- A null dependency relation renders the refinement useless because it
26962 -- cannot possibly mention abstract states with visible refinement. Note
26963 -- that the inverse is not true as states may be refined to null
26964 -- (SPARK RM 7.2.5(2)).
26966 if Nkind (Deps) = N_Null then
26968 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
26969 & "depend on abstract state with visible refinement"), N, Spec_Id);
26973 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
26974 -- This ensures that the categorization of all refined dependency items
26975 -- is consistent with their role.
26977 Analyze_Depends_In_Decl_Part (N);
26979 -- Do not match dependencies against refinements if Refined_Depends is
26980 -- illegal to avoid emitting misleading error.
26982 if Serious_Errors_Detected = Errors then
26984 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
26985 -- the inputs and outputs of the subprogram spec and body to verify
26986 -- the use of states with visible refinement and their constituents.
26988 if No (Get_Pragma (Spec_Id, Pragma_Global))
26989 or else No (Get_Pragma (Body_Id, Pragma_Refined_Global))
26991 Collect_Subprogram_Inputs_Outputs
26992 (Subp_Id => Spec_Id,
26993 Synthesize => True,
26994 Subp_Inputs => Spec_Inputs,
26995 Subp_Outputs => Spec_Outputs,
26996 Global_Seen => Dummy);
26998 Collect_Subprogram_Inputs_Outputs
26999 (Subp_Id => Body_Id,
27000 Synthesize => True,
27001 Subp_Inputs => Body_Inputs,
27002 Subp_Outputs => Body_Outputs,
27003 Global_Seen => Dummy);
27005 -- For an output state with a visible refinement, ensure that all
27006 -- constituents appear as outputs in the dependency refinement.
27008 Check_Output_States
27009 (Spec_Id => Spec_Id,
27010 Spec_Inputs => Spec_Inputs,
27011 Spec_Outputs => Spec_Outputs,
27012 Body_Inputs => Body_Inputs,
27013 Body_Outputs => Body_Outputs);
27016 -- Matching is disabled in ASIS because clauses are not normalized as
27017 -- this is a tree altering activity similar to expansion.
27023 -- Multiple dependency clauses appear as component associations of an
27024 -- aggregate. Note that the clauses are copied because the algorithm
27025 -- modifies them and this should not be visible in Depends.
27027 pragma Assert (Nkind (Deps) = N_Aggregate);
27028 Dependencies := New_Copy_List_Tree (Component_Associations (Deps));
27029 Normalize_Clauses (Dependencies);
27031 -- Gather all states which appear in Depends
27033 States := Collect_States (Dependencies);
27035 Refs := Expression (Get_Argument (N, Spec_Id));
27037 if Nkind (Refs) = N_Null then
27038 Refinements := No_List;
27040 -- Multiple dependency clauses appear as component associations of an
27041 -- aggregate. Note that the clauses are copied because the algorithm
27042 -- modifies them and this should not be visible in Refined_Depends.
27044 else pragma Assert (Nkind (Refs) = N_Aggregate);
27045 Refinements := New_Copy_List_Tree (Component_Associations (Refs));
27046 Normalize_Clauses (Refinements);
27049 -- At this point the clauses of pragmas Depends and Refined_Depends
27050 -- have been normalized into simple dependencies between one output
27051 -- and one input. Examine all clauses of pragma Depends looking for
27052 -- matching clauses in pragma Refined_Depends.
27054 Clause := First (Dependencies);
27055 while Present (Clause) loop
27056 Check_Dependency_Clause
27057 (Spec_Id => Spec_Id,
27058 Dep_Clause => Clause,
27059 Dep_States => States,
27060 Refinements => Refinements,
27061 Matched_Items => Matched_Items);
27066 -- Pragma Refined_Depends may contain multiple clarification clauses
27067 -- which indicate that certain constituents do not influence the data
27068 -- flow in any way. Such clauses must be removed as long as the state
27069 -- has been matched, otherwise they will be incorrectly flagged as
27072 -- Refined_State => (State => (Constit_1, Constit_2))
27073 -- Depends => (Output => State)
27074 -- Refined_Depends => ((Output => Constit_1), -- State matched
27075 -- (null => Constit_2)) -- must be removed
27077 Remove_Extra_Clauses (Refinements, Matched_Items);
27079 if Serious_Errors_Detected = Errors then
27080 Report_Extra_Clauses (Spec_Id, Refinements);
27085 Set_Is_Analyzed_Pragma (N);
27086 end Analyze_Refined_Depends_In_Decl_Part;
27088 -----------------------------------------
27089 -- Analyze_Refined_Global_In_Decl_Part --
27090 -----------------------------------------
27092 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is
27094 -- The corresponding Global pragma
27096 Has_In_State : Boolean := False;
27097 Has_In_Out_State : Boolean := False;
27098 Has_Out_State : Boolean := False;
27099 Has_Proof_In_State : Boolean := False;
27100 -- These flags are set when the corresponding Global pragma has a state
27101 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
27104 Has_Null_State : Boolean := False;
27105 -- This flag is set when the corresponding Global pragma has at least
27106 -- one state with a null refinement.
27108 In_Constits : Elist_Id := No_Elist;
27109 In_Out_Constits : Elist_Id := No_Elist;
27110 Out_Constits : Elist_Id := No_Elist;
27111 Proof_In_Constits : Elist_Id := No_Elist;
27112 -- These lists contain the entities of all Input, In_Out, Output and
27113 -- Proof_In constituents that appear in Refined_Global and participate
27114 -- in state refinement.
27116 In_Items : Elist_Id := No_Elist;
27117 In_Out_Items : Elist_Id := No_Elist;
27118 Out_Items : Elist_Id := No_Elist;
27119 Proof_In_Items : Elist_Id := No_Elist;
27120 -- These lists contain the entities of all Input, In_Out, Output and
27121 -- Proof_In items defined in the corresponding Global pragma.
27123 Repeat_Items : Elist_Id := No_Elist;
27124 -- A list of all global items without full visible refinement found
27125 -- in pragma Global. These states should be repeated in the global
27126 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
27127 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
27129 Spec_Id : Entity_Id;
27130 -- The entity of the subprogram subject to pragma Refined_Global
27132 States : Elist_Id := No_Elist;
27133 -- A list of all states with full or partial visible refinement found in
27136 procedure Check_In_Out_States;
27137 -- Determine whether the corresponding Global pragma mentions In_Out
27138 -- states with visible refinement and if so, ensure that one of the
27139 -- following completions apply to the constituents of the state:
27140 -- 1) there is at least one constituent of mode In_Out
27141 -- 2) there is at least one Input and one Output constituent
27142 -- 3) not all constituents are present and one of them is of mode
27144 -- This routine may remove elements from In_Constits, In_Out_Constits,
27145 -- Out_Constits and Proof_In_Constits.
27147 procedure Check_Input_States;
27148 -- Determine whether the corresponding Global pragma mentions Input
27149 -- states with visible refinement and if so, ensure that at least one of
27150 -- its constituents appears as an Input item in Refined_Global.
27151 -- This routine may remove elements from In_Constits, In_Out_Constits,
27152 -- Out_Constits and Proof_In_Constits.
27154 procedure Check_Output_States;
27155 -- Determine whether the corresponding Global pragma mentions Output
27156 -- states with visible refinement and if so, ensure that all of its
27157 -- constituents appear as Output items in Refined_Global.
27158 -- This routine may remove elements from In_Constits, In_Out_Constits,
27159 -- Out_Constits and Proof_In_Constits.
27161 procedure Check_Proof_In_States;
27162 -- Determine whether the corresponding Global pragma mentions Proof_In
27163 -- states with visible refinement and if so, ensure that at least one of
27164 -- its constituents appears as a Proof_In item in Refined_Global.
27165 -- This routine may remove elements from In_Constits, In_Out_Constits,
27166 -- Out_Constits and Proof_In_Constits.
27168 procedure Check_Refined_Global_List
27170 Global_Mode : Name_Id := Name_Input);
27171 -- Verify the legality of a single global list declaration. Global_Mode
27172 -- denotes the current mode in effect.
27174 procedure Collect_Global_Items
27176 Mode : Name_Id := Name_Input);
27177 -- Gather all Input, In_Out, Output and Proof_In items from node List
27178 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
27179 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
27180 -- and Has_Proof_In_State are set when there is at least one abstract
27181 -- state with full or partial visible refinement available in the
27182 -- corresponding mode. Flag Has_Null_State is set when at least state
27183 -- has a null refinement. Mode denotes the current global mode in
27186 function Present_Then_Remove
27188 Item : Entity_Id) return Boolean;
27189 -- Search List for a particular entity Item. If Item has been found,
27190 -- remove it from List. This routine is used to strip lists In_Constits,
27191 -- In_Out_Constits and Out_Constits of valid constituents.
27193 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id);
27194 -- Same as function Present_Then_Remove, but do not report the presence
27195 -- of Item in List.
27197 procedure Report_Extra_Constituents;
27198 -- Emit an error for each constituent found in lists In_Constits,
27199 -- In_Out_Constits and Out_Constits.
27201 procedure Report_Missing_Items;
27202 -- Emit an error for each global item not repeated found in list
27205 -------------------------
27206 -- Check_In_Out_States --
27207 -------------------------
27209 procedure Check_In_Out_States is
27210 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27211 -- Determine whether one of the following coverage scenarios is in
27213 -- 1) there is at least one constituent of mode In_Out or Output
27214 -- 2) there is at least one pair of constituents with modes Input
27215 -- and Output, or Proof_In and Output.
27216 -- 3) there is at least one constituent of mode Output and not all
27217 -- constituents are present.
27218 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
27220 -----------------------------
27221 -- Check_Constituent_Usage --
27222 -----------------------------
27224 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27225 Constits : constant Elist_Id :=
27226 Partial_Refinement_Constituents (State_Id);
27227 Constit_Elmt : Elmt_Id;
27228 Constit_Id : Entity_Id;
27229 Has_Missing : Boolean := False;
27230 In_Out_Seen : Boolean := False;
27231 Input_Seen : Boolean := False;
27232 Output_Seen : Boolean := False;
27233 Proof_In_Seen : Boolean := False;
27236 -- Process all the constituents of the state and note their modes
27237 -- within the global refinement.
27239 if Present (Constits) then
27240 Constit_Elmt := First_Elmt (Constits);
27241 while Present (Constit_Elmt) loop
27242 Constit_Id := Node (Constit_Elmt);
27244 if Present_Then_Remove (In_Constits, Constit_Id) then
27245 Input_Seen := True;
27247 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then
27248 In_Out_Seen := True;
27250 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
27251 Output_Seen := True;
27253 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
27255 Proof_In_Seen := True;
27258 Has_Missing := True;
27261 Next_Elmt (Constit_Elmt);
27265 -- An In_Out constituent is a valid completion
27267 if In_Out_Seen then
27270 -- A pair of one Input/Proof_In and one Output constituent is a
27271 -- valid completion.
27273 elsif (Input_Seen or Proof_In_Seen) and Output_Seen then
27276 elsif Output_Seen then
27278 -- A single Output constituent is a valid completion only when
27279 -- some of the other constituents are missing.
27281 if Has_Missing then
27284 -- Otherwise all constituents are of mode Output
27288 ("global refinement of state & must include at least one "
27289 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
27293 -- The state lacks a completion. When full refinement is visible,
27294 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
27295 -- refinement is visible, emit an error if the abstract state
27296 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
27297 -- both are utilized, Check_State_And_Constituent_Use. will issue
27300 elsif not Input_Seen
27301 and then not In_Out_Seen
27302 and then not Output_Seen
27303 and then not Proof_In_Seen
27305 if Has_Visible_Refinement (State_Id)
27306 or else Contains (Repeat_Items, State_Id)
27309 ("missing global refinement of state &", N, State_Id);
27312 -- Otherwise the state has a malformed completion where at least
27313 -- one of the constituents has a different mode.
27317 ("global refinement of state & redefines the mode of its "
27318 & "constituents", N, State_Id);
27320 end Check_Constituent_Usage;
27324 Item_Elmt : Elmt_Id;
27325 Item_Id : Entity_Id;
27327 -- Start of processing for Check_In_Out_States
27330 -- Do not perform this check in an instance because it was already
27331 -- performed successfully in the generic template.
27333 if Is_Generic_Instance (Spec_Id) then
27336 -- Inspect the In_Out items of the corresponding Global pragma
27337 -- looking for a state with a visible refinement.
27339 elsif Has_In_Out_State and then Present (In_Out_Items) then
27340 Item_Elmt := First_Elmt (In_Out_Items);
27341 while Present (Item_Elmt) loop
27342 Item_Id := Node (Item_Elmt);
27344 -- Ensure that one of the three coverage variants is satisfied
27346 if Ekind (Item_Id) = E_Abstract_State
27347 and then Has_Non_Null_Visible_Refinement (Item_Id)
27349 Check_Constituent_Usage (Item_Id);
27352 Next_Elmt (Item_Elmt);
27355 end Check_In_Out_States;
27357 ------------------------
27358 -- Check_Input_States --
27359 ------------------------
27361 procedure Check_Input_States is
27362 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27363 -- Determine whether at least one constituent of state State_Id with
27364 -- full or partial visible refinement is used and has mode Input.
27365 -- Ensure that the remaining constituents do not have In_Out or
27366 -- Output modes. Emit an error if this is not the case
27367 -- (SPARK RM 7.2.4(5)).
27369 -----------------------------
27370 -- Check_Constituent_Usage --
27371 -----------------------------
27373 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27374 Constits : constant Elist_Id :=
27375 Partial_Refinement_Constituents (State_Id);
27376 Constit_Elmt : Elmt_Id;
27377 Constit_Id : Entity_Id;
27378 In_Seen : Boolean := False;
27381 if Present (Constits) then
27382 Constit_Elmt := First_Elmt (Constits);
27383 while Present (Constit_Elmt) loop
27384 Constit_Id := Node (Constit_Elmt);
27386 -- At least one of the constituents appears as an Input
27388 if Present_Then_Remove (In_Constits, Constit_Id) then
27391 -- A Proof_In constituent can refine an Input state as long
27392 -- as there is at least one Input constituent present.
27394 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
27398 -- The constituent appears in the global refinement, but has
27399 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
27401 elsif Present_Then_Remove (In_Out_Constits, Constit_Id)
27402 or else Present_Then_Remove (Out_Constits, Constit_Id)
27404 Error_Msg_Name_1 := Chars (State_Id);
27406 ("constituent & of state % must have mode `Input` in "
27407 & "global refinement", N, Constit_Id);
27410 Next_Elmt (Constit_Elmt);
27414 -- Not one of the constituents appeared as Input. Always emit an
27415 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
27416 -- When only partial refinement is visible, emit an error if the
27417 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27418 -- the case where both are utilized, an error will be issued in
27419 -- Check_State_And_Constituent_Use.
27422 and then (Has_Visible_Refinement (State_Id)
27423 or else Contains (Repeat_Items, State_Id))
27426 ("global refinement of state & must include at least one "
27427 & "constituent of mode `Input`", N, State_Id);
27429 end Check_Constituent_Usage;
27433 Item_Elmt : Elmt_Id;
27434 Item_Id : Entity_Id;
27436 -- Start of processing for Check_Input_States
27439 -- Do not perform this check in an instance because it was already
27440 -- performed successfully in the generic template.
27442 if Is_Generic_Instance (Spec_Id) then
27445 -- Inspect the Input items of the corresponding Global pragma looking
27446 -- for a state with a visible refinement.
27448 elsif Has_In_State and then Present (In_Items) then
27449 Item_Elmt := First_Elmt (In_Items);
27450 while Present (Item_Elmt) loop
27451 Item_Id := Node (Item_Elmt);
27453 -- When full refinement is visible, ensure that at least one of
27454 -- the constituents is utilized and is of mode Input. When only
27455 -- partial refinement is visible, ensure that either one of
27456 -- the constituents is utilized and is of mode Input, or the
27457 -- abstract state is repeated and no constituent is utilized.
27459 if Ekind (Item_Id) = E_Abstract_State
27460 and then Has_Non_Null_Visible_Refinement (Item_Id)
27462 Check_Constituent_Usage (Item_Id);
27465 Next_Elmt (Item_Elmt);
27468 end Check_Input_States;
27470 -------------------------
27471 -- Check_Output_States --
27472 -------------------------
27474 procedure Check_Output_States is
27475 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27476 -- Determine whether all constituents of state State_Id with full
27477 -- visible refinement are used and have mode Output. Emit an error
27478 -- if this is not the case (SPARK RM 7.2.4(5)).
27480 -----------------------------
27481 -- Check_Constituent_Usage --
27482 -----------------------------
27484 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27485 Constits : constant Elist_Id :=
27486 Partial_Refinement_Constituents (State_Id);
27487 Only_Partial : constant Boolean :=
27488 not Has_Visible_Refinement (State_Id);
27489 Constit_Elmt : Elmt_Id;
27490 Constit_Id : Entity_Id;
27491 Posted : Boolean := False;
27494 if Present (Constits) then
27495 Constit_Elmt := First_Elmt (Constits);
27496 while Present (Constit_Elmt) loop
27497 Constit_Id := Node (Constit_Elmt);
27499 -- Issue an error when a constituent of State_Id is utilized
27500 -- and State_Id has only partial visible refinement
27501 -- (SPARK RM 7.2.4(3d)).
27503 if Only_Partial then
27504 if Present_Then_Remove (Out_Constits, Constit_Id)
27505 or else Present_Then_Remove (In_Constits, Constit_Id)
27507 Present_Then_Remove (In_Out_Constits, Constit_Id)
27509 Present_Then_Remove (Proof_In_Constits, Constit_Id)
27511 Error_Msg_Name_1 := Chars (State_Id);
27513 ("constituent & of state % cannot be used in global "
27514 & "refinement", N, Constit_Id);
27515 Error_Msg_Name_1 := Chars (State_Id);
27516 SPARK_Msg_N ("\use state % instead", N);
27519 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
27522 -- The constituent appears in the global refinement, but has
27523 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
27525 elsif Present_Then_Remove (In_Constits, Constit_Id)
27526 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
27527 or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
27529 Error_Msg_Name_1 := Chars (State_Id);
27531 ("constituent & of state % must have mode `Output` in "
27532 & "global refinement", N, Constit_Id);
27534 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
27540 ("`Output` state & must be replaced by all its "
27541 & "constituents in global refinement", N, State_Id);
27545 ("\constituent & is missing in output list",
27549 Next_Elmt (Constit_Elmt);
27552 end Check_Constituent_Usage;
27556 Item_Elmt : Elmt_Id;
27557 Item_Id : Entity_Id;
27559 -- Start of processing for Check_Output_States
27562 -- Do not perform this check in an instance because it was already
27563 -- performed successfully in the generic template.
27565 if Is_Generic_Instance (Spec_Id) then
27568 -- Inspect the Output items of the corresponding Global pragma
27569 -- looking for a state with a visible refinement.
27571 elsif Has_Out_State and then Present (Out_Items) then
27572 Item_Elmt := First_Elmt (Out_Items);
27573 while Present (Item_Elmt) loop
27574 Item_Id := Node (Item_Elmt);
27576 -- When full refinement is visible, ensure that all of the
27577 -- constituents are utilized and they have mode Output. When
27578 -- only partial refinement is visible, ensure that no
27579 -- constituent is utilized.
27581 if Ekind (Item_Id) = E_Abstract_State
27582 and then Has_Non_Null_Visible_Refinement (Item_Id)
27584 Check_Constituent_Usage (Item_Id);
27587 Next_Elmt (Item_Elmt);
27590 end Check_Output_States;
27592 ---------------------------
27593 -- Check_Proof_In_States --
27594 ---------------------------
27596 procedure Check_Proof_In_States is
27597 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27598 -- Determine whether at least one constituent of state State_Id with
27599 -- full or partial visible refinement is used and has mode Proof_In.
27600 -- Ensure that the remaining constituents do not have Input, In_Out,
27601 -- or Output modes. Emit an error if this is not the case
27602 -- (SPARK RM 7.2.4(5)).
27604 -----------------------------
27605 -- Check_Constituent_Usage --
27606 -----------------------------
27608 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27609 Constits : constant Elist_Id :=
27610 Partial_Refinement_Constituents (State_Id);
27611 Constit_Elmt : Elmt_Id;
27612 Constit_Id : Entity_Id;
27613 Proof_In_Seen : Boolean := False;
27616 if Present (Constits) then
27617 Constit_Elmt := First_Elmt (Constits);
27618 while Present (Constit_Elmt) loop
27619 Constit_Id := Node (Constit_Elmt);
27621 -- At least one of the constituents appears as Proof_In
27623 if Present_Then_Remove (Proof_In_Constits, Constit_Id) then
27624 Proof_In_Seen := True;
27626 -- The constituent appears in the global refinement, but has
27627 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
27629 elsif Present_Then_Remove (In_Constits, Constit_Id)
27630 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
27631 or else Present_Then_Remove (Out_Constits, Constit_Id)
27633 Error_Msg_Name_1 := Chars (State_Id);
27635 ("constituent & of state % must have mode `Proof_In` "
27636 & "in global refinement", N, Constit_Id);
27639 Next_Elmt (Constit_Elmt);
27643 -- Not one of the constituents appeared as Proof_In. Always emit
27644 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
27645 -- When only partial refinement is visible, emit an error if the
27646 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27647 -- the case where both are utilized, an error will be issued by
27648 -- Check_State_And_Constituent_Use.
27650 if not Proof_In_Seen
27651 and then (Has_Visible_Refinement (State_Id)
27652 or else Contains (Repeat_Items, State_Id))
27655 ("global refinement of state & must include at least one "
27656 & "constituent of mode `Proof_In`", N, State_Id);
27658 end Check_Constituent_Usage;
27662 Item_Elmt : Elmt_Id;
27663 Item_Id : Entity_Id;
27665 -- Start of processing for Check_Proof_In_States
27668 -- Do not perform this check in an instance because it was already
27669 -- performed successfully in the generic template.
27671 if Is_Generic_Instance (Spec_Id) then
27674 -- Inspect the Proof_In items of the corresponding Global pragma
27675 -- looking for a state with a visible refinement.
27677 elsif Has_Proof_In_State and then Present (Proof_In_Items) then
27678 Item_Elmt := First_Elmt (Proof_In_Items);
27679 while Present (Item_Elmt) loop
27680 Item_Id := Node (Item_Elmt);
27682 -- Ensure that at least one of the constituents is utilized
27683 -- and is of mode Proof_In. When only partial refinement is
27684 -- visible, ensure that either one of the constituents is
27685 -- utilized and is of mode Proof_In, or the abstract state
27686 -- is repeated and no constituent is utilized.
27688 if Ekind (Item_Id) = E_Abstract_State
27689 and then Has_Non_Null_Visible_Refinement (Item_Id)
27691 Check_Constituent_Usage (Item_Id);
27694 Next_Elmt (Item_Elmt);
27697 end Check_Proof_In_States;
27699 -------------------------------
27700 -- Check_Refined_Global_List --
27701 -------------------------------
27703 procedure Check_Refined_Global_List
27705 Global_Mode : Name_Id := Name_Input)
27707 procedure Check_Refined_Global_Item
27709 Global_Mode : Name_Id);
27710 -- Verify the legality of a single global item declaration. Parameter
27711 -- Global_Mode denotes the current mode in effect.
27713 -------------------------------
27714 -- Check_Refined_Global_Item --
27715 -------------------------------
27717 procedure Check_Refined_Global_Item
27719 Global_Mode : Name_Id)
27721 Item_Id : constant Entity_Id := Entity_Of (Item);
27723 procedure Inconsistent_Mode_Error (Expect : Name_Id);
27724 -- Issue a common error message for all mode mismatches. Expect
27725 -- denotes the expected mode.
27727 -----------------------------
27728 -- Inconsistent_Mode_Error --
27729 -----------------------------
27731 procedure Inconsistent_Mode_Error (Expect : Name_Id) is
27734 ("global item & has inconsistent modes", Item, Item_Id);
27736 Error_Msg_Name_1 := Global_Mode;
27737 Error_Msg_Name_2 := Expect;
27738 SPARK_Msg_N ("\expected mode %, found mode %", Item);
27739 end Inconsistent_Mode_Error;
27743 Enc_State : Entity_Id := Empty;
27744 -- Encapsulating state for constituent, Empty otherwise
27746 -- Start of processing for Check_Refined_Global_Item
27749 if Ekind_In (Item_Id, E_Abstract_State,
27753 Enc_State := Find_Encapsulating_State (States, Item_Id);
27756 -- When the state or object acts as a constituent of another
27757 -- state with a visible refinement, collect it for the state
27758 -- completeness checks performed later on. Note that the item
27759 -- acts as a constituent only when the encapsulating state is
27760 -- present in pragma Global.
27762 if Present (Enc_State)
27763 and then (Has_Visible_Refinement (Enc_State)
27764 or else Has_Partial_Visible_Refinement (Enc_State))
27765 and then Contains (States, Enc_State)
27767 -- If the state has only partial visible refinement, remove it
27768 -- from the list of items that should be repeated from pragma
27771 if not Has_Visible_Refinement (Enc_State) then
27772 Present_Then_Remove (Repeat_Items, Enc_State);
27775 if Global_Mode = Name_Input then
27776 Append_New_Elmt (Item_Id, In_Constits);
27778 elsif Global_Mode = Name_In_Out then
27779 Append_New_Elmt (Item_Id, In_Out_Constits);
27781 elsif Global_Mode = Name_Output then
27782 Append_New_Elmt (Item_Id, Out_Constits);
27784 elsif Global_Mode = Name_Proof_In then
27785 Append_New_Elmt (Item_Id, Proof_In_Constits);
27788 -- When not a constituent, ensure that both occurrences of the
27789 -- item in pragmas Global and Refined_Global match. Also remove
27790 -- it when present from the list of items that should be repeated
27791 -- from pragma Global.
27794 Present_Then_Remove (Repeat_Items, Item_Id);
27796 if Contains (In_Items, Item_Id) then
27797 if Global_Mode /= Name_Input then
27798 Inconsistent_Mode_Error (Name_Input);
27801 elsif Contains (In_Out_Items, Item_Id) then
27802 if Global_Mode /= Name_In_Out then
27803 Inconsistent_Mode_Error (Name_In_Out);
27806 elsif Contains (Out_Items, Item_Id) then
27807 if Global_Mode /= Name_Output then
27808 Inconsistent_Mode_Error (Name_Output);
27811 elsif Contains (Proof_In_Items, Item_Id) then
27814 -- The item does not appear in the corresponding Global pragma,
27815 -- it must be an extra (SPARK RM 7.2.4(3)).
27818 pragma Assert (Present (Global));
27819 Error_Msg_Sloc := Sloc (Global);
27821 ("extra global item & does not refine or repeat any "
27822 & "global item #", Item, Item_Id);
27825 end Check_Refined_Global_Item;
27831 -- Start of processing for Check_Refined_Global_List
27834 -- Do not perform this check in an instance because it was already
27835 -- performed successfully in the generic template.
27837 if Is_Generic_Instance (Spec_Id) then
27840 elsif Nkind (List) = N_Null then
27843 -- Single global item declaration
27845 elsif Nkind_In (List, N_Expanded_Name,
27847 N_Selected_Component)
27849 Check_Refined_Global_Item (List, Global_Mode);
27851 -- Simple global list or moded global list declaration
27853 elsif Nkind (List) = N_Aggregate then
27855 -- The declaration of a simple global list appear as a collection
27858 if Present (Expressions (List)) then
27859 Item := First (Expressions (List));
27860 while Present (Item) loop
27861 Check_Refined_Global_Item (Item, Global_Mode);
27865 -- The declaration of a moded global list appears as a collection
27866 -- of component associations where individual choices denote
27869 elsif Present (Component_Associations (List)) then
27870 Item := First (Component_Associations (List));
27871 while Present (Item) loop
27872 Check_Refined_Global_List
27873 (List => Expression (Item),
27874 Global_Mode => Chars (First (Choices (Item))));
27882 raise Program_Error;
27888 raise Program_Error;
27890 end Check_Refined_Global_List;
27892 --------------------------
27893 -- Collect_Global_Items --
27894 --------------------------
27896 procedure Collect_Global_Items
27898 Mode : Name_Id := Name_Input)
27900 procedure Collect_Global_Item
27902 Item_Mode : Name_Id);
27903 -- Add a single item to the appropriate list. Item_Mode denotes the
27904 -- current mode in effect.
27906 -------------------------
27907 -- Collect_Global_Item --
27908 -------------------------
27910 procedure Collect_Global_Item
27912 Item_Mode : Name_Id)
27914 Item_Id : constant Entity_Id := Available_View (Entity_Of (Item));
27915 -- The above handles abstract views of variables and states built
27916 -- for limited with clauses.
27919 -- Signal that the global list contains at least one abstract
27920 -- state with a visible refinement. Note that the refinement may
27921 -- be null in which case there are no constituents.
27923 if Ekind (Item_Id) = E_Abstract_State then
27924 if Has_Null_Visible_Refinement (Item_Id) then
27925 Has_Null_State := True;
27927 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
27928 Append_New_Elmt (Item_Id, States);
27930 if Item_Mode = Name_Input then
27931 Has_In_State := True;
27932 elsif Item_Mode = Name_In_Out then
27933 Has_In_Out_State := True;
27934 elsif Item_Mode = Name_Output then
27935 Has_Out_State := True;
27936 elsif Item_Mode = Name_Proof_In then
27937 Has_Proof_In_State := True;
27942 -- Record global items without full visible refinement found in
27943 -- pragma Global which should be repeated in the global refinement
27944 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
27946 if Ekind (Item_Id) /= E_Abstract_State
27947 or else not Has_Visible_Refinement (Item_Id)
27949 Append_New_Elmt (Item_Id, Repeat_Items);
27952 -- Add the item to the proper list
27954 if Item_Mode = Name_Input then
27955 Append_New_Elmt (Item_Id, In_Items);
27956 elsif Item_Mode = Name_In_Out then
27957 Append_New_Elmt (Item_Id, In_Out_Items);
27958 elsif Item_Mode = Name_Output then
27959 Append_New_Elmt (Item_Id, Out_Items);
27960 elsif Item_Mode = Name_Proof_In then
27961 Append_New_Elmt (Item_Id, Proof_In_Items);
27963 end Collect_Global_Item;
27969 -- Start of processing for Collect_Global_Items
27972 if Nkind (List) = N_Null then
27975 -- Single global item declaration
27977 elsif Nkind_In (List, N_Expanded_Name,
27979 N_Selected_Component)
27981 Collect_Global_Item (List, Mode);
27983 -- Single global list or moded global list declaration
27985 elsif Nkind (List) = N_Aggregate then
27987 -- The declaration of a simple global list appear as a collection
27990 if Present (Expressions (List)) then
27991 Item := First (Expressions (List));
27992 while Present (Item) loop
27993 Collect_Global_Item (Item, Mode);
27997 -- The declaration of a moded global list appears as a collection
27998 -- of component associations where individual choices denote mode.
28000 elsif Present (Component_Associations (List)) then
28001 Item := First (Component_Associations (List));
28002 while Present (Item) loop
28003 Collect_Global_Items
28004 (List => Expression (Item),
28005 Mode => Chars (First (Choices (Item))));
28013 raise Program_Error;
28016 -- To accommodate partial decoration of disabled SPARK features, this
28017 -- routine may be called with illegal input. If this is the case, do
28018 -- not raise Program_Error.
28023 end Collect_Global_Items;
28025 -------------------------
28026 -- Present_Then_Remove --
28027 -------------------------
28029 function Present_Then_Remove
28031 Item : Entity_Id) return Boolean
28036 if Present (List) then
28037 Elmt := First_Elmt (List);
28038 while Present (Elmt) loop
28039 if Node (Elmt) = Item then
28040 Remove_Elmt (List, Elmt);
28049 end Present_Then_Remove;
28051 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id) is
28054 Ignore := Present_Then_Remove (List, Item);
28055 end Present_Then_Remove;
28057 -------------------------------
28058 -- Report_Extra_Constituents --
28059 -------------------------------
28061 procedure Report_Extra_Constituents is
28062 procedure Report_Extra_Constituents_In_List (List : Elist_Id);
28063 -- Emit an error for every element of List
28065 ---------------------------------------
28066 -- Report_Extra_Constituents_In_List --
28067 ---------------------------------------
28069 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is
28070 Constit_Elmt : Elmt_Id;
28073 if Present (List) then
28074 Constit_Elmt := First_Elmt (List);
28075 while Present (Constit_Elmt) loop
28076 SPARK_Msg_NE ("extra constituent &", N, Node (Constit_Elmt));
28077 Next_Elmt (Constit_Elmt);
28080 end Report_Extra_Constituents_In_List;
28082 -- Start of processing for Report_Extra_Constituents
28085 -- Do not perform this check in an instance because it was already
28086 -- performed successfully in the generic template.
28088 if Is_Generic_Instance (Spec_Id) then
28092 Report_Extra_Constituents_In_List (In_Constits);
28093 Report_Extra_Constituents_In_List (In_Out_Constits);
28094 Report_Extra_Constituents_In_List (Out_Constits);
28095 Report_Extra_Constituents_In_List (Proof_In_Constits);
28097 end Report_Extra_Constituents;
28099 --------------------------
28100 -- Report_Missing_Items --
28101 --------------------------
28103 procedure Report_Missing_Items is
28104 Item_Elmt : Elmt_Id;
28105 Item_Id : Entity_Id;
28108 -- Do not perform this check in an instance because it was already
28109 -- performed successfully in the generic template.
28111 if Is_Generic_Instance (Spec_Id) then
28115 if Present (Repeat_Items) then
28116 Item_Elmt := First_Elmt (Repeat_Items);
28117 while Present (Item_Elmt) loop
28118 Item_Id := Node (Item_Elmt);
28119 SPARK_Msg_NE ("missing global item &", N, Item_Id);
28120 Next_Elmt (Item_Elmt);
28124 end Report_Missing_Items;
28128 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
28129 Errors : constant Nat := Serious_Errors_Detected;
28131 No_Constit : Boolean;
28133 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
28136 -- Do not analyze the pragma multiple times
28138 if Is_Analyzed_Pragma (N) then
28142 Spec_Id := Unique_Defining_Entity (Body_Decl);
28144 -- Use the anonymous object as the proper spec when Refined_Global
28145 -- applies to the body of a single task type. The object carries the
28146 -- proper Chars as well as all non-refined versions of pragmas.
28148 if Is_Single_Concurrent_Type (Spec_Id) then
28149 Spec_Id := Anonymous_Object (Spec_Id);
28152 Global := Get_Pragma (Spec_Id, Pragma_Global);
28153 Items := Expression (Get_Argument (N, Spec_Id));
28155 -- The subprogram declaration lacks pragma Global. This renders
28156 -- Refined_Global useless as there is nothing to refine.
28158 if No (Global) then
28160 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
28161 & "& lacks aspect or pragma Global"), N, Spec_Id);
28165 -- Extract all relevant items from the corresponding Global pragma
28167 Collect_Global_Items (Expression (Get_Argument (Global, Spec_Id)));
28169 -- Package and subprogram bodies are instantiated individually in
28170 -- a separate compiler pass. Due to this mode of instantiation, the
28171 -- refinement of a state may no longer be visible when a subprogram
28172 -- body contract is instantiated. Since the generic template is legal,
28173 -- do not perform this check in the instance to circumvent this oddity.
28175 if Is_Generic_Instance (Spec_Id) then
28178 -- Non-instance case
28181 -- The corresponding Global pragma must mention at least one
28182 -- state with a visible refinement at the point Refined_Global
28183 -- is processed. States with null refinements need Refined_Global
28184 -- pragma (SPARK RM 7.2.4(2)).
28186 if not Has_In_State
28187 and then not Has_In_Out_State
28188 and then not Has_Out_State
28189 and then not Has_Proof_In_State
28190 and then not Has_Null_State
28193 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
28194 & "depend on abstract state with visible refinement"),
28198 -- The global refinement of inputs and outputs cannot be null when
28199 -- the corresponding Global pragma contains at least one item except
28200 -- in the case where we have states with null refinements.
28202 elsif Nkind (Items) = N_Null
28204 (Present (In_Items)
28205 or else Present (In_Out_Items)
28206 or else Present (Out_Items)
28207 or else Present (Proof_In_Items))
28208 and then not Has_Null_State
28211 (Fix_Msg (Spec_Id, "refinement cannot be null, subprogram & has "
28212 & "global items"), N, Spec_Id);
28217 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
28218 -- This ensures that the categorization of all refined global items is
28219 -- consistent with their role.
28221 Analyze_Global_In_Decl_Part (N);
28223 -- Perform all refinement checks with respect to completeness and mode
28226 if Serious_Errors_Detected = Errors then
28227 Check_Refined_Global_List (Items);
28230 -- Store the information that no constituent is used in the global
28231 -- refinement, prior to calling checking procedures which remove items
28232 -- from the list of constituents.
28236 and then No (In_Out_Constits)
28237 and then No (Out_Constits)
28238 and then No (Proof_In_Constits);
28240 -- For Input states with visible refinement, at least one constituent
28241 -- must be used as an Input in the global refinement.
28243 if Serious_Errors_Detected = Errors then
28244 Check_Input_States;
28247 -- Verify all possible completion variants for In_Out states with
28248 -- visible refinement.
28250 if Serious_Errors_Detected = Errors then
28251 Check_In_Out_States;
28254 -- For Output states with visible refinement, all constituents must be
28255 -- used as Outputs in the global refinement.
28257 if Serious_Errors_Detected = Errors then
28258 Check_Output_States;
28261 -- For Proof_In states with visible refinement, at least one constituent
28262 -- must be used as Proof_In in the global refinement.
28264 if Serious_Errors_Detected = Errors then
28265 Check_Proof_In_States;
28268 -- Emit errors for all constituents that belong to other states with
28269 -- visible refinement that do not appear in Global.
28271 if Serious_Errors_Detected = Errors then
28272 Report_Extra_Constituents;
28275 -- Emit errors for all items in Global that are not repeated in the
28276 -- global refinement and for which there is no full visible refinement
28277 -- and, in the case of states with partial visible refinement, no
28278 -- constituent is mentioned in the global refinement.
28280 if Serious_Errors_Detected = Errors then
28281 Report_Missing_Items;
28284 -- Emit an error if no constituent is used in the global refinement
28285 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
28286 -- one may be issued by the checking procedures. Do not perform this
28287 -- check in an instance because it was already performed successfully
28288 -- in the generic template.
28290 if Serious_Errors_Detected = Errors
28291 and then not Is_Generic_Instance (Spec_Id)
28292 and then not Has_Null_State
28293 and then No_Constit
28295 SPARK_Msg_N ("missing refinement", N);
28299 Set_Is_Analyzed_Pragma (N);
28300 end Analyze_Refined_Global_In_Decl_Part;
28302 ----------------------------------------
28303 -- Analyze_Refined_State_In_Decl_Part --
28304 ----------------------------------------
28306 procedure Analyze_Refined_State_In_Decl_Part
28308 Freeze_Id : Entity_Id := Empty)
28310 Body_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
28311 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
28312 Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl);
28314 Available_States : Elist_Id := No_Elist;
28315 -- A list of all abstract states defined in the package declaration that
28316 -- are available for refinement. The list is used to report unrefined
28319 Body_States : Elist_Id := No_Elist;
28320 -- A list of all hidden states that appear in the body of the related
28321 -- package. The list is used to report unused hidden states.
28323 Constituents_Seen : Elist_Id := No_Elist;
28324 -- A list that contains all constituents processed so far. The list is
28325 -- used to detect multiple uses of the same constituent.
28327 Freeze_Posted : Boolean := False;
28328 -- A flag that controls the output of a freezing-related error (see use
28331 Refined_States_Seen : Elist_Id := No_Elist;
28332 -- A list that contains all refined states processed so far. The list is
28333 -- used to detect duplicate refinements.
28335 procedure Analyze_Refinement_Clause (Clause : Node_Id);
28336 -- Perform full analysis of a single refinement clause
28338 procedure Report_Unrefined_States (States : Elist_Id);
28339 -- Emit errors for all unrefined abstract states found in list States
28341 -------------------------------
28342 -- Analyze_Refinement_Clause --
28343 -------------------------------
28345 procedure Analyze_Refinement_Clause (Clause : Node_Id) is
28346 AR_Constit : Entity_Id := Empty;
28347 AW_Constit : Entity_Id := Empty;
28348 ER_Constit : Entity_Id := Empty;
28349 EW_Constit : Entity_Id := Empty;
28350 -- The entities of external constituents that contain one of the
28351 -- following enabled properties: Async_Readers, Async_Writers,
28352 -- Effective_Reads and Effective_Writes.
28354 External_Constit_Seen : Boolean := False;
28355 -- Flag used to mark when at least one external constituent is part
28356 -- of the state refinement.
28358 Non_Null_Seen : Boolean := False;
28359 Null_Seen : Boolean := False;
28360 -- Flags used to detect multiple uses of null in a single clause or a
28361 -- mixture of null and non-null constituents.
28363 Part_Of_Constits : Elist_Id := No_Elist;
28364 -- A list of all candidate constituents subject to indicator Part_Of
28365 -- where the encapsulating state is the current state.
28368 State_Id : Entity_Id;
28369 -- The current state being refined
28371 procedure Analyze_Constituent (Constit : Node_Id);
28372 -- Perform full analysis of a single constituent
28374 procedure Check_External_Property
28375 (Prop_Nam : Name_Id;
28377 Constit : Entity_Id);
28378 -- Determine whether a property denoted by name Prop_Nam is present
28379 -- in the refined state. Emit an error if this is not the case. Flag
28380 -- Enabled should be set when the property applies to the refined
28381 -- state. Constit denotes the constituent (if any) which introduces
28382 -- the property in the refinement.
28384 procedure Match_State;
28385 -- Determine whether the state being refined appears in list
28386 -- Available_States. Emit an error when attempting to re-refine the
28387 -- state or when the state is not defined in the package declaration,
28388 -- otherwise remove the state from Available_States.
28390 procedure Report_Unused_Constituents (Constits : Elist_Id);
28391 -- Emit errors for all unused Part_Of constituents in list Constits
28393 -------------------------
28394 -- Analyze_Constituent --
28395 -------------------------
28397 procedure Analyze_Constituent (Constit : Node_Id) is
28398 procedure Match_Constituent (Constit_Id : Entity_Id);
28399 -- Determine whether constituent Constit denoted by its entity
28400 -- Constit_Id appears in Body_States. Emit an error when the
28401 -- constituent is not a valid hidden state of the related package
28402 -- or when it is used more than once. Otherwise remove the
28403 -- constituent from Body_States.
28405 -----------------------
28406 -- Match_Constituent --
28407 -----------------------
28409 procedure Match_Constituent (Constit_Id : Entity_Id) is
28410 procedure Collect_Constituent;
28411 -- Verify the legality of constituent Constit_Id and add it to
28412 -- the refinements of State_Id.
28414 -------------------------
28415 -- Collect_Constituent --
28416 -------------------------
28418 procedure Collect_Constituent is
28419 Constits : Elist_Id;
28422 -- The Ghost policy in effect at the point of abstract state
28423 -- declaration and constituent must match (SPARK RM 6.9(15))
28425 Check_Ghost_Refinement
28426 (State, State_Id, Constit, Constit_Id);
28428 -- A synchronized state must be refined by a synchronized
28429 -- object or another synchronized state (SPARK RM 9.6).
28431 if Is_Synchronized_State (State_Id)
28432 and then not Is_Synchronized_Object (Constit_Id)
28433 and then not Is_Synchronized_State (Constit_Id)
28436 ("constituent of synchronized state & must be "
28437 & "synchronized", Constit, State_Id);
28440 -- Add the constituent to the list of processed items to aid
28441 -- with the detection of duplicates.
28443 Append_New_Elmt (Constit_Id, Constituents_Seen);
28445 -- Collect the constituent in the list of refinement items
28446 -- and establish a relation between the refined state and
28449 Constits := Refinement_Constituents (State_Id);
28451 if No (Constits) then
28452 Constits := New_Elmt_List;
28453 Set_Refinement_Constituents (State_Id, Constits);
28456 Append_Elmt (Constit_Id, Constits);
28457 Set_Encapsulating_State (Constit_Id, State_Id);
28459 -- The state has at least one legal constituent, mark the
28460 -- start of the refinement region. The region ends when the
28461 -- body declarations end (see routine Analyze_Declarations).
28463 Set_Has_Visible_Refinement (State_Id);
28465 -- When the constituent is external, save its relevant
28466 -- property for further checks.
28468 if Async_Readers_Enabled (Constit_Id) then
28469 AR_Constit := Constit_Id;
28470 External_Constit_Seen := True;
28473 if Async_Writers_Enabled (Constit_Id) then
28474 AW_Constit := Constit_Id;
28475 External_Constit_Seen := True;
28478 if Effective_Reads_Enabled (Constit_Id) then
28479 ER_Constit := Constit_Id;
28480 External_Constit_Seen := True;
28483 if Effective_Writes_Enabled (Constit_Id) then
28484 EW_Constit := Constit_Id;
28485 External_Constit_Seen := True;
28487 end Collect_Constituent;
28491 State_Elmt : Elmt_Id;
28493 -- Start of processing for Match_Constituent
28496 -- Detect a duplicate use of a constituent
28498 if Contains (Constituents_Seen, Constit_Id) then
28500 ("duplicate use of constituent &", Constit, Constit_Id);
28504 -- The constituent is subject to a Part_Of indicator
28506 if Present (Encapsulating_State (Constit_Id)) then
28507 if Encapsulating_State (Constit_Id) = State_Id then
28508 Remove (Part_Of_Constits, Constit_Id);
28509 Collect_Constituent;
28511 -- The constituent is part of another state and is used
28512 -- incorrectly in the refinement of the current state.
28515 Error_Msg_Name_1 := Chars (State_Id);
28517 ("& cannot act as constituent of state %",
28518 Constit, Constit_Id);
28520 ("\Part_Of indicator specifies encapsulator &",
28521 Constit, Encapsulating_State (Constit_Id));
28524 -- The only other source of legal constituents is the body
28525 -- state space of the related package.
28528 if Present (Body_States) then
28529 State_Elmt := First_Elmt (Body_States);
28530 while Present (State_Elmt) loop
28532 -- Consume a valid constituent to signal that it has
28533 -- been encountered.
28535 if Node (State_Elmt) = Constit_Id then
28536 Remove_Elmt (Body_States, State_Elmt);
28537 Collect_Constituent;
28541 Next_Elmt (State_Elmt);
28545 -- At this point it is known that the constituent is not
28546 -- part of the package hidden state and cannot be used in
28547 -- a refinement (SPARK RM 7.2.2(9)).
28549 Error_Msg_Name_1 := Chars (Spec_Id);
28551 ("cannot use & in refinement, constituent is not a hidden "
28552 & "state of package %", Constit, Constit_Id);
28554 end Match_Constituent;
28558 Constit_Id : Entity_Id;
28559 Constits : Elist_Id;
28561 -- Start of processing for Analyze_Constituent
28564 -- Detect multiple uses of null in a single refinement clause or a
28565 -- mixture of null and non-null constituents.
28567 if Nkind (Constit) = N_Null then
28570 ("multiple null constituents not allowed", Constit);
28572 elsif Non_Null_Seen then
28574 ("cannot mix null and non-null constituents", Constit);
28579 -- Collect the constituent in the list of refinement items
28581 Constits := Refinement_Constituents (State_Id);
28583 if No (Constits) then
28584 Constits := New_Elmt_List;
28585 Set_Refinement_Constituents (State_Id, Constits);
28588 Append_Elmt (Constit, Constits);
28590 -- The state has at least one legal constituent, mark the
28591 -- start of the refinement region. The region ends when the
28592 -- body declarations end (see Analyze_Declarations).
28594 Set_Has_Visible_Refinement (State_Id);
28597 -- Non-null constituents
28600 Non_Null_Seen := True;
28604 ("cannot mix null and non-null constituents", Constit);
28608 Resolve_State (Constit);
28610 -- Ensure that the constituent denotes a valid state or a
28611 -- whole object (SPARK RM 7.2.2(5)).
28613 if Is_Entity_Name (Constit) then
28614 Constit_Id := Entity_Of (Constit);
28616 -- When a constituent is declared after a subprogram body
28617 -- that caused freezing of the related contract where
28618 -- pragma Refined_State resides, the constituent appears
28619 -- undefined and carries Any_Id as its entity.
28621 -- package body Pack
28622 -- with Refined_State => (State => Constit)
28625 -- with Refined_Global => (Input => Constit)
28633 if Constit_Id = Any_Id then
28634 SPARK_Msg_NE ("& is undefined", Constit, Constit_Id);
28636 -- Emit a specialized info message when the contract of
28637 -- the related package body was "frozen" by another body.
28638 -- Note that it is not possible to precisely identify why
28639 -- the constituent is undefined because it is not visible
28640 -- when pragma Refined_State is analyzed. This message is
28641 -- a reasonable approximation.
28643 if Present (Freeze_Id) and then not Freeze_Posted then
28644 Freeze_Posted := True;
28646 Error_Msg_Name_1 := Chars (Body_Id);
28647 Error_Msg_Sloc := Sloc (Freeze_Id);
28649 ("body & declared # freezes the contract of %",
28652 ("\all constituents must be declared before body #",
28655 -- A misplaced constituent is a critical error because
28656 -- pragma Refined_Depends or Refined_Global depends on
28657 -- the proper link between a state and a constituent.
28658 -- Stop the compilation, as this leads to a multitude
28659 -- of misleading cascaded errors.
28661 raise Unrecoverable_Error;
28664 -- The constituent is a valid state or object
28666 elsif Ekind_In (Constit_Id, E_Abstract_State,
28670 Match_Constituent (Constit_Id);
28672 -- The variable may eventually become a constituent of a
28673 -- single protected/task type. Record the reference now
28674 -- and verify its legality when analyzing the contract of
28675 -- the variable (SPARK RM 9.3).
28677 if Ekind (Constit_Id) = E_Variable then
28678 Record_Possible_Part_Of_Reference
28679 (Var_Id => Constit_Id,
28683 -- Otherwise the constituent is illegal
28687 ("constituent & must denote object or state",
28688 Constit, Constit_Id);
28691 -- The constituent is illegal
28694 SPARK_Msg_N ("malformed constituent", Constit);
28697 end Analyze_Constituent;
28699 -----------------------------
28700 -- Check_External_Property --
28701 -----------------------------
28703 procedure Check_External_Property
28704 (Prop_Nam : Name_Id;
28706 Constit : Entity_Id)
28709 -- The property is missing in the declaration of the state, but
28710 -- a constituent is introducing it in the state refinement
28711 -- (SPARK RM 7.2.8(2)).
28713 if not Enabled and then Present (Constit) then
28714 Error_Msg_Name_1 := Prop_Nam;
28715 Error_Msg_Name_2 := Chars (State_Id);
28717 ("constituent & introduces external property % in refinement "
28718 & "of state %", State, Constit);
28720 Error_Msg_Sloc := Sloc (State_Id);
28722 ("\property is missing in abstract state declaration #",
28725 end Check_External_Property;
28731 procedure Match_State is
28732 State_Elmt : Elmt_Id;
28735 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
28737 if Contains (Refined_States_Seen, State_Id) then
28739 ("duplicate refinement of state &", State, State_Id);
28743 -- Inspect the abstract states defined in the package declaration
28744 -- looking for a match.
28746 State_Elmt := First_Elmt (Available_States);
28747 while Present (State_Elmt) loop
28749 -- A valid abstract state is being refined in the body. Add
28750 -- the state to the list of processed refined states to aid
28751 -- with the detection of duplicate refinements. Remove the
28752 -- state from Available_States to signal that it has already
28755 if Node (State_Elmt) = State_Id then
28756 Append_New_Elmt (State_Id, Refined_States_Seen);
28757 Remove_Elmt (Available_States, State_Elmt);
28761 Next_Elmt (State_Elmt);
28764 -- If we get here, we are refining a state that is not defined in
28765 -- the package declaration.
28767 Error_Msg_Name_1 := Chars (Spec_Id);
28769 ("cannot refine state, & is not defined in package %",
28773 --------------------------------
28774 -- Report_Unused_Constituents --
28775 --------------------------------
28777 procedure Report_Unused_Constituents (Constits : Elist_Id) is
28778 Constit_Elmt : Elmt_Id;
28779 Constit_Id : Entity_Id;
28780 Posted : Boolean := False;
28783 if Present (Constits) then
28784 Constit_Elmt := First_Elmt (Constits);
28785 while Present (Constit_Elmt) loop
28786 Constit_Id := Node (Constit_Elmt);
28788 -- Generate an error message of the form:
28790 -- state ... has unused Part_Of constituents
28791 -- abstract state ... defined at ...
28792 -- constant ... defined at ...
28793 -- variable ... defined at ...
28798 ("state & has unused Part_Of constituents",
28802 Error_Msg_Sloc := Sloc (Constit_Id);
28804 if Ekind (Constit_Id) = E_Abstract_State then
28806 ("\abstract state & defined #", State, Constit_Id);
28808 elsif Ekind (Constit_Id) = E_Constant then
28810 ("\constant & defined #", State, Constit_Id);
28813 pragma Assert (Ekind (Constit_Id) = E_Variable);
28814 SPARK_Msg_NE ("\variable & defined #", State, Constit_Id);
28817 Next_Elmt (Constit_Elmt);
28820 end Report_Unused_Constituents;
28822 -- Local declarations
28824 Body_Ref : Node_Id;
28825 Body_Ref_Elmt : Elmt_Id;
28827 Extra_State : Node_Id;
28829 -- Start of processing for Analyze_Refinement_Clause
28832 -- A refinement clause appears as a component association where the
28833 -- sole choice is the state and the expressions are the constituents.
28834 -- This is a syntax error, always report.
28836 if Nkind (Clause) /= N_Component_Association then
28837 Error_Msg_N ("malformed state refinement clause", Clause);
28841 -- Analyze the state name of a refinement clause
28843 State := First (Choices (Clause));
28846 Resolve_State (State);
28848 -- Ensure that the state name denotes a valid abstract state that is
28849 -- defined in the spec of the related package.
28851 if Is_Entity_Name (State) then
28852 State_Id := Entity_Of (State);
28854 -- When the abstract state is undefined, it appears as Any_Id. Do
28855 -- not continue with the analysis of the clause.
28857 if State_Id = Any_Id then
28860 -- Catch any attempts to re-refine a state or refine a state that
28861 -- is not defined in the package declaration.
28863 elsif Ekind (State_Id) = E_Abstract_State then
28867 SPARK_Msg_NE ("& must denote abstract state", State, State_Id);
28871 -- References to a state with visible refinement are illegal.
28872 -- When nested packages are involved, detecting such references is
28873 -- tricky because pragma Refined_State is analyzed later than the
28874 -- offending pragma Depends or Global. References that occur in
28875 -- such nested context are stored in a list. Emit errors for all
28876 -- references found in Body_References (SPARK RM 6.1.4(8)).
28878 if Present (Body_References (State_Id)) then
28879 Body_Ref_Elmt := First_Elmt (Body_References (State_Id));
28880 while Present (Body_Ref_Elmt) loop
28881 Body_Ref := Node (Body_Ref_Elmt);
28883 SPARK_Msg_N ("reference to & not allowed", Body_Ref);
28884 Error_Msg_Sloc := Sloc (State);
28885 SPARK_Msg_N ("\refinement of & is visible#", Body_Ref);
28887 Next_Elmt (Body_Ref_Elmt);
28891 -- The state name is illegal. This is a syntax error, always report.
28894 Error_Msg_N ("malformed state name in refinement clause", State);
28898 -- A refinement clause may only refine one state at a time
28900 Extra_State := Next (State);
28902 if Present (Extra_State) then
28904 ("refinement clause cannot cover multiple states", Extra_State);
28907 -- Replicate the Part_Of constituents of the refined state because
28908 -- the algorithm will consume items.
28910 Part_Of_Constits := New_Copy_Elist (Part_Of_Constituents (State_Id));
28912 -- Analyze all constituents of the refinement. Multiple constituents
28913 -- appear as an aggregate.
28915 Constit := Expression (Clause);
28917 if Nkind (Constit) = N_Aggregate then
28918 if Present (Component_Associations (Constit)) then
28920 ("constituents of refinement clause must appear in "
28921 & "positional form", Constit);
28923 else pragma Assert (Present (Expressions (Constit)));
28924 Constit := First (Expressions (Constit));
28925 while Present (Constit) loop
28926 Analyze_Constituent (Constit);
28931 -- Various forms of a single constituent. Note that these may include
28932 -- malformed constituents.
28935 Analyze_Constituent (Constit);
28938 -- Verify that external constituents do not introduce new external
28939 -- property in the state refinement (SPARK RM 7.2.8(2)).
28941 if Is_External_State (State_Id) then
28942 Check_External_Property
28943 (Prop_Nam => Name_Async_Readers,
28944 Enabled => Async_Readers_Enabled (State_Id),
28945 Constit => AR_Constit);
28947 Check_External_Property
28948 (Prop_Nam => Name_Async_Writers,
28949 Enabled => Async_Writers_Enabled (State_Id),
28950 Constit => AW_Constit);
28952 Check_External_Property
28953 (Prop_Nam => Name_Effective_Reads,
28954 Enabled => Effective_Reads_Enabled (State_Id),
28955 Constit => ER_Constit);
28957 Check_External_Property
28958 (Prop_Nam => Name_Effective_Writes,
28959 Enabled => Effective_Writes_Enabled (State_Id),
28960 Constit => EW_Constit);
28962 -- When a refined state is not external, it should not have external
28963 -- constituents (SPARK RM 7.2.8(1)).
28965 elsif External_Constit_Seen then
28967 ("non-external state & cannot contain external constituents in "
28968 & "refinement", State, State_Id);
28971 -- Ensure that all Part_Of candidate constituents have been mentioned
28972 -- in the refinement clause.
28974 Report_Unused_Constituents (Part_Of_Constits);
28975 end Analyze_Refinement_Clause;
28977 -----------------------------
28978 -- Report_Unrefined_States --
28979 -----------------------------
28981 procedure Report_Unrefined_States (States : Elist_Id) is
28982 State_Elmt : Elmt_Id;
28985 if Present (States) then
28986 State_Elmt := First_Elmt (States);
28987 while Present (State_Elmt) loop
28989 ("abstract state & must be refined", Node (State_Elmt));
28991 Next_Elmt (State_Elmt);
28994 end Report_Unrefined_States;
28996 -- Local declarations
28998 Clauses : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
29001 -- Start of processing for Analyze_Refined_State_In_Decl_Part
29004 -- Do not analyze the pragma multiple times
29006 if Is_Analyzed_Pragma (N) then
29010 -- Save the scenario for examination by the ABE Processing phase
29012 Record_Elaboration_Scenario (N);
29014 -- Replicate the abstract states declared by the package because the
29015 -- matching algorithm will consume states.
29017 Available_States := New_Copy_Elist (Abstract_States (Spec_Id));
29019 -- Gather all abstract states and objects declared in the visible
29020 -- state space of the package body. These items must be utilized as
29021 -- constituents in a state refinement.
29023 Body_States := Collect_Body_States (Body_Id);
29025 -- Multiple non-null state refinements appear as an aggregate
29027 if Nkind (Clauses) = N_Aggregate then
29028 if Present (Expressions (Clauses)) then
29030 ("state refinements must appear as component associations",
29033 else pragma Assert (Present (Component_Associations (Clauses)));
29034 Clause := First (Component_Associations (Clauses));
29035 while Present (Clause) loop
29036 Analyze_Refinement_Clause (Clause);
29041 -- Various forms of a single state refinement. Note that these may
29042 -- include malformed refinements.
29045 Analyze_Refinement_Clause (Clauses);
29048 -- List all abstract states that were left unrefined
29050 Report_Unrefined_States (Available_States);
29052 Set_Is_Analyzed_Pragma (N);
29053 end Analyze_Refined_State_In_Decl_Part;
29055 ------------------------------------
29056 -- Analyze_Test_Case_In_Decl_Part --
29057 ------------------------------------
29059 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id) is
29060 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
29061 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
29063 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id);
29064 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
29065 -- denoted by Arg_Nam.
29067 ------------------------------
29068 -- Preanalyze_Test_Case_Arg --
29069 ------------------------------
29071 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id) is
29075 -- Preanalyze the original aspect argument for ASIS or for a generic
29076 -- subprogram to properly capture global references.
29078 if ASIS_Mode or else Is_Generic_Subprogram (Spec_Id) then
29082 Arg_Nam => Arg_Nam,
29083 From_Aspect => True);
29085 if Present (Arg) then
29086 Preanalyze_Assert_Expression
29087 (Expression (Arg), Standard_Boolean);
29091 Arg := Test_Case_Arg (N, Arg_Nam);
29093 if Present (Arg) then
29094 Preanalyze_Assert_Expression (Expression (Arg), Standard_Boolean);
29096 end Preanalyze_Test_Case_Arg;
29100 Restore_Scope : Boolean := False;
29102 -- Start of processing for Analyze_Test_Case_In_Decl_Part
29105 -- Do not analyze the pragma multiple times
29107 if Is_Analyzed_Pragma (N) then
29111 -- Ensure that the formal parameters are visible when analyzing all
29112 -- clauses. This falls out of the general rule of aspects pertaining
29113 -- to subprogram declarations.
29115 if not In_Open_Scopes (Spec_Id) then
29116 Restore_Scope := True;
29117 Push_Scope (Spec_Id);
29119 if Is_Generic_Subprogram (Spec_Id) then
29120 Install_Generic_Formals (Spec_Id);
29122 Install_Formals (Spec_Id);
29126 Preanalyze_Test_Case_Arg (Name_Requires);
29127 Preanalyze_Test_Case_Arg (Name_Ensures);
29129 if Restore_Scope then
29133 -- Currently it is not possible to inline pre/postconditions on a
29134 -- subprogram subject to pragma Inline_Always.
29136 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
29138 Set_Is_Analyzed_Pragma (N);
29139 end Analyze_Test_Case_In_Decl_Part;
29145 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is
29150 if Present (List) then
29151 Elmt := First_Elmt (List);
29152 while Present (Elmt) loop
29153 if Nkind (Node (Elmt)) = N_Defining_Identifier then
29156 Id := Entity_Of (Node (Elmt));
29159 if Id = Item_Id then
29170 -----------------------------------
29171 -- Build_Pragma_Check_Equivalent --
29172 -----------------------------------
29174 function Build_Pragma_Check_Equivalent
29176 Subp_Id : Entity_Id := Empty;
29177 Inher_Id : Entity_Id := Empty;
29178 Keep_Pragma_Id : Boolean := False) return Node_Id
29180 function Suppress_Reference (N : Node_Id) return Traverse_Result;
29181 -- Detect whether node N references a formal parameter subject to
29182 -- pragma Unreferenced. If this is the case, set Comes_From_Source
29183 -- to False to suppress the generation of a reference when analyzing
29186 ------------------------
29187 -- Suppress_Reference --
29188 ------------------------
29190 function Suppress_Reference (N : Node_Id) return Traverse_Result is
29191 Formal : Entity_Id;
29194 if Is_Entity_Name (N) and then Present (Entity (N)) then
29195 Formal := Entity (N);
29197 -- The formal parameter is subject to pragma Unreferenced. Prevent
29198 -- the generation of references by resetting the Comes_From_Source
29201 if Is_Formal (Formal)
29202 and then Has_Pragma_Unreferenced (Formal)
29204 Set_Comes_From_Source (N, False);
29209 end Suppress_Reference;
29211 procedure Suppress_References is
29212 new Traverse_Proc (Suppress_Reference);
29216 Loc : constant Source_Ptr := Sloc (Prag);
29217 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
29218 Check_Prag : Node_Id;
29222 Needs_Wrapper : Boolean;
29223 pragma Unreferenced (Needs_Wrapper);
29225 -- Start of processing for Build_Pragma_Check_Equivalent
29228 -- When the pre- or postcondition is inherited, map the formals of the
29229 -- inherited subprogram to those of the current subprogram. In addition,
29230 -- map primitive operations of the parent type into the corresponding
29231 -- primitive operations of the descendant.
29233 if Present (Inher_Id) then
29234 pragma Assert (Present (Subp_Id));
29236 Update_Primitives_Mapping (Inher_Id, Subp_Id);
29238 -- Use generic machinery to copy inherited pragma, as if it were an
29239 -- instantiation, resetting source locations appropriately, so that
29240 -- expressions inside the inherited pragma use chained locations.
29241 -- This is used in particular in GNATprove to locate precisely
29242 -- messages on a given inherited pragma.
29244 Set_Copied_Sloc_For_Inherited_Pragma
29245 (Unit_Declaration_Node (Subp_Id), Inher_Id);
29246 Check_Prag := New_Copy_Tree (Source => Prag);
29248 -- Build the inherited class-wide condition
29250 Build_Class_Wide_Expression
29251 (Prag => Check_Prag,
29253 Par_Subp => Inher_Id,
29254 Adjust_Sloc => True,
29255 Needs_Wrapper => Needs_Wrapper);
29257 -- If not an inherited condition simply copy the original pragma
29260 Check_Prag := New_Copy_Tree (Source => Prag);
29263 -- Mark the pragma as being internally generated and reset the Analyzed
29266 Set_Analyzed (Check_Prag, False);
29267 Set_Comes_From_Source (Check_Prag, False);
29269 -- The tree of the original pragma may contain references to the
29270 -- formal parameters of the related subprogram. At the same time
29271 -- the corresponding body may mark the formals as unreferenced:
29273 -- procedure Proc (Formal : ...)
29274 -- with Pre => Formal ...;
29276 -- procedure Proc (Formal : ...) is
29277 -- pragma Unreferenced (Formal);
29280 -- This creates problems because all pragma Check equivalents are
29281 -- analyzed at the end of the body declarations. Since all source
29282 -- references have already been accounted for, reset any references
29283 -- to such formals in the generated pragma Check equivalent.
29285 Suppress_References (Check_Prag);
29287 if Present (Corresponding_Aspect (Prag)) then
29288 Nam := Chars (Identifier (Corresponding_Aspect (Prag)));
29293 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
29294 -- the copied pragma in the newly created pragma, convert the copy into
29295 -- pragma Check by correcting the name and adding a check_kind argument.
29297 if not Keep_Pragma_Id then
29298 Set_Class_Present (Check_Prag, False);
29300 Set_Pragma_Identifier
29301 (Check_Prag, Make_Identifier (Loc, Name_Check));
29303 Prepend_To (Pragma_Argument_Associations (Check_Prag),
29304 Make_Pragma_Argument_Association (Loc,
29305 Expression => Make_Identifier (Loc, Nam)));
29308 -- Update the error message when the pragma is inherited
29310 if Present (Inher_Id) then
29311 Msg_Arg := Last (Pragma_Argument_Associations (Check_Prag));
29313 if Chars (Msg_Arg) = Name_Message then
29314 String_To_Name_Buffer (Strval (Expression (Msg_Arg)));
29316 -- Insert "inherited" to improve the error message
29318 if Name_Buffer (1 .. 8) = "failed p" then
29319 Insert_Str_In_Name_Buffer ("inherited ", 8);
29320 Set_Strval (Expression (Msg_Arg), String_From_Name_Buffer);
29326 end Build_Pragma_Check_Equivalent;
29328 -----------------------------
29329 -- Check_Applicable_Policy --
29330 -----------------------------
29332 procedure Check_Applicable_Policy (N : Node_Id) is
29336 Ename : constant Name_Id := Original_Aspect_Pragma_Name (N);
29339 -- No effect if not valid assertion kind name
29341 if not Is_Valid_Assertion_Kind (Ename) then
29345 -- Loop through entries in check policy list
29347 PP := Opt.Check_Policy_List;
29348 while Present (PP) loop
29350 PPA : constant List_Id := Pragma_Argument_Associations (PP);
29351 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
29355 or else Pnm = Name_Assertion
29356 or else (Pnm = Name_Statement_Assertions
29357 and then Nam_In (Ename, Name_Assert,
29358 Name_Assert_And_Cut,
29360 Name_Loop_Invariant,
29361 Name_Loop_Variant))
29363 Policy := Chars (Get_Pragma_Arg (Last (PPA)));
29369 -- In CodePeer mode and GNATprove mode, we need to
29370 -- consider all assertions, unless they are disabled.
29371 -- Force Is_Checked on ignored assertions, in particular
29372 -- because transformations of the AST may depend on
29373 -- assertions being checked (e.g. the translation of
29374 -- attribute 'Loop_Entry).
29376 if CodePeer_Mode or GNATprove_Mode then
29377 Set_Is_Checked (N, True);
29378 Set_Is_Ignored (N, False);
29380 Set_Is_Checked (N, False);
29381 Set_Is_Ignored (N, True);
29387 Set_Is_Checked (N, True);
29388 Set_Is_Ignored (N, False);
29390 when Name_Disable =>
29391 Set_Is_Ignored (N, True);
29392 Set_Is_Checked (N, False);
29393 Set_Is_Disabled (N, True);
29395 -- That should be exhaustive, the null here is a defence
29396 -- against a malformed tree from previous errors.
29405 PP := Next_Pragma (PP);
29409 -- If there are no specific entries that matched, then we let the
29410 -- setting of assertions govern. Note that this provides the needed
29411 -- compatibility with the RM for the cases of assertion, invariant,
29412 -- precondition, predicate, and postcondition. Note also that
29413 -- Assertions_Enabled is forced in CodePeer mode and GNATprove mode.
29415 if Assertions_Enabled then
29416 Set_Is_Checked (N, True);
29417 Set_Is_Ignored (N, False);
29419 Set_Is_Checked (N, False);
29420 Set_Is_Ignored (N, True);
29422 end Check_Applicable_Policy;
29424 -------------------------------
29425 -- Check_External_Properties --
29426 -------------------------------
29428 procedure Check_External_Properties
29436 -- All properties enabled
29438 if AR and AW and ER and EW then
29441 -- Async_Readers + Effective_Writes
29442 -- Async_Readers + Async_Writers + Effective_Writes
29444 elsif AR and EW and not ER then
29447 -- Async_Writers + Effective_Reads
29448 -- Async_Readers + Async_Writers + Effective_Reads
29450 elsif AW and ER and not EW then
29453 -- Async_Readers + Async_Writers
29455 elsif AR and AW and not ER and not EW then
29460 elsif AR and not AW and not ER and not EW then
29465 elsif AW and not AR and not ER and not EW then
29470 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
29473 end Check_External_Properties;
29479 function Check_Kind (Nam : Name_Id) return Name_Id is
29483 -- Loop through entries in check policy list
29485 PP := Opt.Check_Policy_List;
29486 while Present (PP) loop
29488 PPA : constant List_Id := Pragma_Argument_Associations (PP);
29489 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
29493 or else (Pnm = Name_Assertion
29494 and then Is_Valid_Assertion_Kind (Nam))
29495 or else (Pnm = Name_Statement_Assertions
29496 and then Nam_In (Nam, Name_Assert,
29497 Name_Assert_And_Cut,
29499 Name_Loop_Invariant,
29500 Name_Loop_Variant))
29502 case (Chars (Get_Pragma_Arg (Last (PPA)))) is
29511 return Name_Ignore;
29513 when Name_Disable =>
29514 return Name_Disable;
29517 raise Program_Error;
29521 PP := Next_Pragma (PP);
29526 -- If there are no specific entries that matched, then we let the
29527 -- setting of assertions govern. Note that this provides the needed
29528 -- compatibility with the RM for the cases of assertion, invariant,
29529 -- precondition, predicate, and postcondition.
29531 if Assertions_Enabled then
29534 return Name_Ignore;
29538 ---------------------------
29539 -- Check_Missing_Part_Of --
29540 ---------------------------
29542 procedure Check_Missing_Part_Of (Item_Id : Entity_Id) is
29543 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean;
29544 -- Determine whether a package denoted by Pack_Id declares at least one
29547 -----------------------
29548 -- Has_Visible_State --
29549 -----------------------
29551 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean is
29552 Item_Id : Entity_Id;
29555 -- Traverse the entity chain of the package trying to find at least
29556 -- one visible abstract state, variable or a package [instantiation]
29557 -- that declares a visible state.
29559 Item_Id := First_Entity (Pack_Id);
29560 while Present (Item_Id)
29561 and then not In_Private_Part (Item_Id)
29563 -- Do not consider internally generated items
29565 if not Comes_From_Source (Item_Id) then
29568 -- Do not consider generic formals or their corresponding actuals
29569 -- because they are not part of a visible state. Note that both
29570 -- entities are marked as hidden.
29572 elsif Is_Hidden (Item_Id) then
29575 -- A visible state has been found. Note that constants are not
29576 -- considered here because it is not possible to determine whether
29577 -- they depend on variable input. This check is left to the SPARK
29580 elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
29583 -- Recursively peek into nested packages and instantiations
29585 elsif Ekind (Item_Id) = E_Package
29586 and then Has_Visible_State (Item_Id)
29591 Next_Entity (Item_Id);
29595 end Has_Visible_State;
29599 Pack_Id : Entity_Id;
29600 Placement : State_Space_Kind;
29602 -- Start of processing for Check_Missing_Part_Of
29605 -- Do not consider abstract states, variables or package instantiations
29606 -- coming from an instance as those always inherit the Part_Of indicator
29607 -- of the instance itself.
29609 if In_Instance then
29612 -- Do not consider internally generated entities as these can never
29613 -- have a Part_Of indicator.
29615 elsif not Comes_From_Source (Item_Id) then
29618 -- Perform these checks only when SPARK_Mode is enabled as they will
29619 -- interfere with standard Ada rules and produce false positives.
29621 elsif SPARK_Mode /= On then
29624 -- Do not consider constants, because the compiler cannot accurately
29625 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
29626 -- act as a hidden state of a package.
29628 elsif Ekind (Item_Id) = E_Constant then
29632 -- Find where the abstract state, variable or package instantiation
29633 -- lives with respect to the state space.
29635 Find_Placement_In_State_Space
29636 (Item_Id => Item_Id,
29637 Placement => Placement,
29638 Pack_Id => Pack_Id);
29640 -- Items that appear in a non-package construct (subprogram, block, etc)
29641 -- do not require a Part_Of indicator because they can never act as a
29644 if Placement = Not_In_Package then
29647 -- An item declared in the body state space of a package always act as a
29648 -- constituent and does not need explicit Part_Of indicator.
29650 elsif Placement = Body_State_Space then
29653 -- In general an item declared in the visible state space of a package
29654 -- does not require a Part_Of indicator. The only exception is when the
29655 -- related package is a nongeneric private child unit, in which case
29656 -- Part_Of must denote a state in the parent unit or in one of its
29659 elsif Placement = Visible_State_Space then
29660 if Is_Child_Unit (Pack_Id)
29661 and then not Is_Generic_Unit (Pack_Id)
29662 and then Is_Private_Descendant (Pack_Id)
29664 -- A package instantiation does not need a Part_Of indicator when
29665 -- the related generic template has no visible state.
29667 if Ekind (Item_Id) = E_Package
29668 and then Is_Generic_Instance (Item_Id)
29669 and then not Has_Visible_State (Item_Id)
29673 -- All other cases require Part_Of
29677 ("indicator Part_Of is required in this context "
29678 & "(SPARK RM 7.2.6(3))", Item_Id);
29679 Error_Msg_Name_1 := Chars (Pack_Id);
29681 ("\& is declared in the visible part of private child "
29682 & "unit %", Item_Id);
29686 -- When the item appears in the private state space of a package, it
29687 -- must be a part of some state declared by the said package.
29689 else pragma Assert (Placement = Private_State_Space);
29691 -- The related package does not declare a state, the item cannot act
29692 -- as a Part_Of constituent.
29694 if No (Get_Pragma (Pack_Id, Pragma_Abstract_State)) then
29697 -- A package instantiation does not need a Part_Of indicator when the
29698 -- related generic template has no visible state.
29700 elsif Ekind (Item_Id) = E_Package
29701 and then Is_Generic_Instance (Item_Id)
29702 and then not Has_Visible_State (Item_Id)
29706 -- All other cases require Part_Of
29710 ("indicator Part_Of is required in this context "
29711 & "(SPARK RM 7.2.6(2))", Item_Id);
29712 Error_Msg_Name_1 := Chars (Pack_Id);
29714 ("\& is declared in the private part of package %", Item_Id);
29717 end Check_Missing_Part_Of;
29719 ---------------------------------------------------
29720 -- Check_Postcondition_Use_In_Inlined_Subprogram --
29721 ---------------------------------------------------
29723 procedure Check_Postcondition_Use_In_Inlined_Subprogram
29725 Spec_Id : Entity_Id)
29728 if Warn_On_Redundant_Constructs
29729 and then Has_Pragma_Inline_Always (Spec_Id)
29730 and then Assertions_Enabled
29732 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
29734 if From_Aspect_Specification (Prag) then
29736 ("aspect % not enforced on inlined subprogram &?r?",
29737 Corresponding_Aspect (Prag), Spec_Id);
29740 ("pragma % not enforced on inlined subprogram &?r?",
29744 end Check_Postcondition_Use_In_Inlined_Subprogram;
29746 -------------------------------------
29747 -- Check_State_And_Constituent_Use --
29748 -------------------------------------
29750 procedure Check_State_And_Constituent_Use
29751 (States : Elist_Id;
29752 Constits : Elist_Id;
29755 Constit_Elmt : Elmt_Id;
29756 Constit_Id : Entity_Id;
29757 State_Id : Entity_Id;
29760 -- Nothing to do if there are no states or constituents
29762 if No (States) or else No (Constits) then
29766 -- Inspect the list of constituents and try to determine whether its
29767 -- encapsulating state is in list States.
29769 Constit_Elmt := First_Elmt (Constits);
29770 while Present (Constit_Elmt) loop
29771 Constit_Id := Node (Constit_Elmt);
29773 -- Determine whether the constituent is part of an encapsulating
29774 -- state that appears in the same context and if this is the case,
29775 -- emit an error (SPARK RM 7.2.6(7)).
29777 State_Id := Find_Encapsulating_State (States, Constit_Id);
29779 if Present (State_Id) then
29780 Error_Msg_Name_1 := Chars (Constit_Id);
29782 ("cannot mention state & and its constituent % in the same "
29783 & "context", Context, State_Id);
29787 Next_Elmt (Constit_Elmt);
29789 end Check_State_And_Constituent_Use;
29791 ---------------------------------------------
29792 -- Collect_Inherited_Class_Wide_Conditions --
29793 ---------------------------------------------
29795 procedure Collect_Inherited_Class_Wide_Conditions (Subp : Entity_Id) is
29796 Parent_Subp : constant Entity_Id :=
29797 Ultimate_Alias (Overridden_Operation (Subp));
29798 -- The Overridden_Operation may itself be inherited and as such have no
29799 -- explicit contract.
29801 Prags : constant Node_Id := Contract (Parent_Subp);
29802 In_Spec_Expr : Boolean;
29803 Installed : Boolean;
29805 New_Prag : Node_Id;
29808 Installed := False;
29810 -- Iterate over the contract of the overridden subprogram to find all
29811 -- inherited class-wide pre- and postconditions.
29813 if Present (Prags) then
29814 Prag := Pre_Post_Conditions (Prags);
29816 while Present (Prag) loop
29817 if Nam_In (Pragma_Name_Unmapped (Prag),
29818 Name_Precondition, Name_Postcondition)
29819 and then Class_Present (Prag)
29821 -- The generated pragma must be analyzed in the context of
29822 -- the subprogram, to make its formals visible. In addition,
29823 -- we must inhibit freezing and full analysis because the
29824 -- controlling type of the subprogram is not frozen yet, and
29825 -- may have further primitives.
29827 if not Installed then
29830 Install_Formals (Subp);
29831 In_Spec_Expr := In_Spec_Expression;
29832 In_Spec_Expression := True;
29836 Build_Pragma_Check_Equivalent
29837 (Prag, Subp, Parent_Subp, Keep_Pragma_Id => True);
29839 Insert_After (Unit_Declaration_Node (Subp), New_Prag);
29840 Preanalyze (New_Prag);
29842 -- Prevent further analysis in subsequent processing of the
29843 -- current list of declarations
29845 Set_Analyzed (New_Prag);
29848 Prag := Next_Pragma (Prag);
29852 In_Spec_Expression := In_Spec_Expr;
29856 end Collect_Inherited_Class_Wide_Conditions;
29858 ---------------------------------------
29859 -- Collect_Subprogram_Inputs_Outputs --
29860 ---------------------------------------
29862 procedure Collect_Subprogram_Inputs_Outputs
29863 (Subp_Id : Entity_Id;
29864 Synthesize : Boolean := False;
29865 Subp_Inputs : in out Elist_Id;
29866 Subp_Outputs : in out Elist_Id;
29867 Global_Seen : out Boolean)
29869 procedure Collect_Dependency_Clause (Clause : Node_Id);
29870 -- Collect all relevant items from a dependency clause
29872 procedure Collect_Global_List
29874 Mode : Name_Id := Name_Input);
29875 -- Collect all relevant items from a global list
29877 -------------------------------
29878 -- Collect_Dependency_Clause --
29879 -------------------------------
29881 procedure Collect_Dependency_Clause (Clause : Node_Id) is
29882 procedure Collect_Dependency_Item
29884 Is_Input : Boolean);
29885 -- Add an item to the proper subprogram input or output collection
29887 -----------------------------
29888 -- Collect_Dependency_Item --
29889 -----------------------------
29891 procedure Collect_Dependency_Item
29893 Is_Input : Boolean)
29898 -- Nothing to collect when the item is null
29900 if Nkind (Item) = N_Null then
29903 -- Ditto for attribute 'Result
29905 elsif Is_Attribute_Result (Item) then
29908 -- Multiple items appear as an aggregate
29910 elsif Nkind (Item) = N_Aggregate then
29911 Extra := First (Expressions (Item));
29912 while Present (Extra) loop
29913 Collect_Dependency_Item (Extra, Is_Input);
29917 -- Otherwise this is a solitary item
29921 Append_New_Elmt (Item, Subp_Inputs);
29923 Append_New_Elmt (Item, Subp_Outputs);
29926 end Collect_Dependency_Item;
29928 -- Start of processing for Collect_Dependency_Clause
29931 if Nkind (Clause) = N_Null then
29934 -- A dependency clause appears as component association
29936 elsif Nkind (Clause) = N_Component_Association then
29937 Collect_Dependency_Item
29938 (Item => Expression (Clause),
29941 Collect_Dependency_Item
29942 (Item => First (Choices (Clause)),
29943 Is_Input => False);
29945 -- To accommodate partial decoration of disabled SPARK features, this
29946 -- routine may be called with illegal input. If this is the case, do
29947 -- not raise Program_Error.
29952 end Collect_Dependency_Clause;
29954 -------------------------
29955 -- Collect_Global_List --
29956 -------------------------
29958 procedure Collect_Global_List
29960 Mode : Name_Id := Name_Input)
29962 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id);
29963 -- Add an item to the proper subprogram input or output collection
29965 -------------------------
29966 -- Collect_Global_Item --
29967 -------------------------
29969 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is
29971 if Nam_In (Mode, Name_In_Out, Name_Input) then
29972 Append_New_Elmt (Item, Subp_Inputs);
29975 if Nam_In (Mode, Name_In_Out, Name_Output) then
29976 Append_New_Elmt (Item, Subp_Outputs);
29978 end Collect_Global_Item;
29985 -- Start of processing for Collect_Global_List
29988 if Nkind (List) = N_Null then
29991 -- Single global item declaration
29993 elsif Nkind_In (List, N_Expanded_Name,
29995 N_Selected_Component)
29997 Collect_Global_Item (List, Mode);
29999 -- Simple global list or moded global list declaration
30001 elsif Nkind (List) = N_Aggregate then
30002 if Present (Expressions (List)) then
30003 Item := First (Expressions (List));
30004 while Present (Item) loop
30005 Collect_Global_Item (Item, Mode);
30010 Assoc := First (Component_Associations (List));
30011 while Present (Assoc) loop
30012 Collect_Global_List
30013 (List => Expression (Assoc),
30014 Mode => Chars (First (Choices (Assoc))));
30019 -- To accommodate partial decoration of disabled SPARK features, this
30020 -- routine may be called with illegal input. If this is the case, do
30021 -- not raise Program_Error.
30026 end Collect_Global_List;
30033 Formal : Entity_Id;
30035 Spec_Id : Entity_Id := Empty;
30036 Subp_Decl : Node_Id;
30039 -- Start of processing for Collect_Subprogram_Inputs_Outputs
30042 Global_Seen := False;
30044 -- Process all formal parameters of entries, [generic] subprograms, and
30047 if Ekind_In (Subp_Id, E_Entry,
30050 E_Generic_Function,
30051 E_Generic_Procedure,
30055 Subp_Decl := Unit_Declaration_Node (Subp_Id);
30056 Spec_Id := Unique_Defining_Entity (Subp_Decl);
30058 -- Process all formal parameters
30060 Formal := First_Entity (Spec_Id);
30061 while Present (Formal) loop
30062 if Ekind_In (Formal, E_In_Out_Parameter, E_In_Parameter) then
30063 Append_New_Elmt (Formal, Subp_Inputs);
30066 if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then
30067 Append_New_Elmt (Formal, Subp_Outputs);
30069 -- Out parameters can act as inputs when the related type is
30070 -- tagged, unconstrained array, unconstrained record, or record
30071 -- with unconstrained components.
30073 if Ekind (Formal) = E_Out_Parameter
30074 and then Is_Unconstrained_Or_Tagged_Item (Formal)
30076 Append_New_Elmt (Formal, Subp_Inputs);
30080 Next_Entity (Formal);
30083 -- Otherwise the input denotes a task type, a task body, or the
30084 -- anonymous object created for a single task type.
30086 elsif Ekind_In (Subp_Id, E_Task_Type, E_Task_Body)
30087 or else Is_Single_Task_Object (Subp_Id)
30089 Subp_Decl := Declaration_Node (Subp_Id);
30090 Spec_Id := Unique_Defining_Entity (Subp_Decl);
30093 -- When processing an entry, subprogram or task body, look for pragmas
30094 -- Refined_Depends and Refined_Global as they specify the inputs and
30097 if Is_Entry_Body (Subp_Id)
30098 or else Ekind_In (Subp_Id, E_Subprogram_Body, E_Task_Body)
30100 Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends);
30101 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global);
30103 -- Subprogram declaration or stand-alone body case, look for pragmas
30104 -- Depends and Global
30107 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
30108 Global := Get_Pragma (Spec_Id, Pragma_Global);
30111 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
30112 -- because it provides finer granularity of inputs and outputs.
30114 if Present (Global) then
30115 Global_Seen := True;
30116 Collect_Global_List (Expression (Get_Argument (Global, Spec_Id)));
30118 -- When the related subprogram lacks pragma [Refined_]Global, fall back
30119 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
30120 -- the inputs and outputs from [Refined_]Depends.
30122 elsif Synthesize and then Present (Depends) then
30123 Clauses := Expression (Get_Argument (Depends, Spec_Id));
30125 -- Multiple dependency clauses appear as an aggregate
30127 if Nkind (Clauses) = N_Aggregate then
30128 Clause := First (Component_Associations (Clauses));
30129 while Present (Clause) loop
30130 Collect_Dependency_Clause (Clause);
30134 -- Otherwise this is a single dependency clause
30137 Collect_Dependency_Clause (Clauses);
30141 -- The current instance of a protected type acts as a formal parameter
30142 -- of mode IN for functions and IN OUT for entries and procedures
30143 -- (SPARK RM 6.1.4).
30145 if Ekind (Scope (Spec_Id)) = E_Protected_Type then
30146 Typ := Scope (Spec_Id);
30148 -- Use the anonymous object when the type is single protected
30150 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
30151 Typ := Anonymous_Object (Typ);
30154 Append_New_Elmt (Typ, Subp_Inputs);
30156 if Ekind_In (Spec_Id, E_Entry, E_Entry_Family, E_Procedure) then
30157 Append_New_Elmt (Typ, Subp_Outputs);
30160 -- The current instance of a task type acts as a formal parameter of
30161 -- mode IN OUT (SPARK RM 6.1.4).
30163 elsif Ekind (Spec_Id) = E_Task_Type then
30166 -- Use the anonymous object when the type is single task
30168 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
30169 Typ := Anonymous_Object (Typ);
30172 Append_New_Elmt (Typ, Subp_Inputs);
30173 Append_New_Elmt (Typ, Subp_Outputs);
30175 elsif Is_Single_Task_Object (Spec_Id) then
30176 Append_New_Elmt (Spec_Id, Subp_Inputs);
30177 Append_New_Elmt (Spec_Id, Subp_Outputs);
30179 end Collect_Subprogram_Inputs_Outputs;
30181 ---------------------------
30182 -- Contract_Freeze_Error --
30183 ---------------------------
30185 procedure Contract_Freeze_Error
30186 (Contract_Id : Entity_Id;
30187 Freeze_Id : Entity_Id)
30190 Error_Msg_Name_1 := Chars (Contract_Id);
30191 Error_Msg_Sloc := Sloc (Freeze_Id);
30194 ("body & declared # freezes the contract of%", Contract_Id, Freeze_Id);
30196 ("\all contractual items must be declared before body #", Contract_Id);
30197 end Contract_Freeze_Error;
30199 ---------------------------------
30200 -- Delay_Config_Pragma_Analyze --
30201 ---------------------------------
30203 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
30205 return Nam_In (Pragma_Name_Unmapped (N),
30206 Name_Interrupt_State, Name_Priority_Specific_Dispatching);
30207 end Delay_Config_Pragma_Analyze;
30209 -----------------------
30210 -- Duplication_Error --
30211 -----------------------
30213 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id) is
30214 Prag_From_Asp : constant Boolean := From_Aspect_Specification (Prag);
30215 Prev_From_Asp : constant Boolean := From_Aspect_Specification (Prev);
30218 Error_Msg_Sloc := Sloc (Prev);
30219 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
30221 -- Emit a precise message to distinguish between source pragmas and
30222 -- pragmas generated from aspects. The ordering of the two pragmas is
30226 -- Prag -- duplicate
30228 -- No error is emitted when both pragmas come from aspects because this
30229 -- is already detected by the general aspect analysis mechanism.
30231 if Prag_From_Asp and Prev_From_Asp then
30233 elsif Prag_From_Asp then
30234 Error_Msg_N ("aspect % duplicates pragma declared #", Prag);
30235 elsif Prev_From_Asp then
30236 Error_Msg_N ("pragma % duplicates aspect declared #", Prag);
30238 Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
30240 end Duplication_Error;
30242 ------------------------------
30243 -- Find_Encapsulating_State --
30244 ------------------------------
30246 function Find_Encapsulating_State
30247 (States : Elist_Id;
30248 Constit_Id : Entity_Id) return Entity_Id
30250 State_Id : Entity_Id;
30253 -- Since a constituent may be part of a larger constituent set, climb
30254 -- the encapsulating state chain looking for a state that appears in
30257 State_Id := Encapsulating_State (Constit_Id);
30258 while Present (State_Id) loop
30259 if Contains (States, State_Id) then
30263 State_Id := Encapsulating_State (State_Id);
30267 end Find_Encapsulating_State;
30269 --------------------------
30270 -- Find_Related_Context --
30271 --------------------------
30273 function Find_Related_Context
30275 Do_Checks : Boolean := False) return Node_Id
30280 Stmt := Prev (Prag);
30281 while Present (Stmt) loop
30283 -- Skip prior pragmas, but check for duplicates
30285 if Nkind (Stmt) = N_Pragma then
30287 and then Pragma_Name (Stmt) = Pragma_Name (Prag)
30294 -- Skip internally generated code
30296 elsif not Comes_From_Source (Stmt) then
30298 -- The anonymous object created for a single concurrent type is a
30299 -- suitable context.
30301 if Nkind (Stmt) = N_Object_Declaration
30302 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
30307 -- Return the current source construct
30317 end Find_Related_Context;
30319 --------------------------------------
30320 -- Find_Related_Declaration_Or_Body --
30321 --------------------------------------
30323 function Find_Related_Declaration_Or_Body
30325 Do_Checks : Boolean := False) return Node_Id
30327 Prag_Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
30329 procedure Expression_Function_Error;
30330 -- Emit an error concerning pragma Prag that illegaly applies to an
30331 -- expression function.
30333 -------------------------------
30334 -- Expression_Function_Error --
30335 -------------------------------
30337 procedure Expression_Function_Error is
30339 Error_Msg_Name_1 := Prag_Nam;
30341 -- Emit a precise message to distinguish between source pragmas and
30342 -- pragmas generated from aspects.
30344 if From_Aspect_Specification (Prag) then
30346 ("aspect % cannot apply to a stand alone expression function",
30350 ("pragma % cannot apply to a stand alone expression function",
30353 end Expression_Function_Error;
30357 Context : constant Node_Id := Parent (Prag);
30360 Look_For_Body : constant Boolean :=
30361 Nam_In (Prag_Nam, Name_Refined_Depends,
30362 Name_Refined_Global,
30364 Name_Refined_State);
30365 -- Refinement pragmas must be associated with a subprogram body [stub]
30367 -- Start of processing for Find_Related_Declaration_Or_Body
30370 Stmt := Prev (Prag);
30371 while Present (Stmt) loop
30373 -- Skip prior pragmas, but check for duplicates. Pragmas produced
30374 -- by splitting a complex pre/postcondition are not considered to
30377 if Nkind (Stmt) = N_Pragma then
30379 and then not Split_PPC (Stmt)
30380 and then Original_Aspect_Pragma_Name (Stmt) = Prag_Nam
30387 -- Emit an error when a refinement pragma appears on an expression
30388 -- function without a completion.
30391 and then Look_For_Body
30392 and then Nkind (Stmt) = N_Subprogram_Declaration
30393 and then Nkind (Original_Node (Stmt)) = N_Expression_Function
30394 and then not Has_Completion (Defining_Entity (Stmt))
30396 Expression_Function_Error;
30399 -- The refinement pragma applies to a subprogram body stub
30401 elsif Look_For_Body
30402 and then Nkind (Stmt) = N_Subprogram_Body_Stub
30406 -- Skip internally generated code
30408 elsif not Comes_From_Source (Stmt) then
30410 -- The anonymous object created for a single concurrent type is a
30411 -- suitable context.
30413 if Nkind (Stmt) = N_Object_Declaration
30414 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
30418 elsif Nkind (Stmt) = N_Subprogram_Declaration then
30420 -- The subprogram declaration is an internally generated spec
30421 -- for an expression function.
30423 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
30426 -- The subprogram declaration is an internally generated spec
30427 -- for a stand-alone subrogram body declared inside a protected
30430 elsif Present (Corresponding_Body (Stmt))
30431 and then Comes_From_Source (Corresponding_Body (Stmt))
30432 and then Is_Protected_Type (Current_Scope)
30436 -- The subprogram is actually an instance housed within an
30437 -- anonymous wrapper package.
30439 elsif Present (Generic_Parent (Specification (Stmt))) then
30444 -- Return the current construct which is either a subprogram body,
30445 -- a subprogram declaration or is illegal.
30454 -- If we fall through, then the pragma was either the first declaration
30455 -- or it was preceded by other pragmas and no source constructs.
30457 -- The pragma is associated with a library-level subprogram
30459 if Nkind (Context) = N_Compilation_Unit_Aux then
30460 return Unit (Parent (Context));
30462 -- The pragma appears inside the declarations of an entry body
30464 elsif Nkind (Context) = N_Entry_Body then
30467 -- The pragma appears inside the statements of a subprogram body. This
30468 -- placement is the result of subprogram contract expansion.
30470 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then
30471 return Parent (Context);
30473 -- The pragma appears inside the declarative part of a package body
30475 elsif Nkind (Context) = N_Package_Body then
30478 -- The pragma appears inside the declarative part of a subprogram body
30480 elsif Nkind (Context) = N_Subprogram_Body then
30483 -- The pragma appears inside the declarative part of a task body
30485 elsif Nkind (Context) = N_Task_Body then
30488 -- The pragma appears inside the visible part of a package specification
30490 elsif Nkind (Context) = N_Package_Specification then
30491 return Parent (Context);
30493 -- The pragma is a byproduct of aspect expansion, return the related
30494 -- context of the original aspect. This case has a lower priority as
30495 -- the above circuitry pinpoints precisely the related context.
30497 elsif Present (Corresponding_Aspect (Prag)) then
30498 return Parent (Corresponding_Aspect (Prag));
30500 -- No candidate subprogram [body] found
30505 end Find_Related_Declaration_Or_Body;
30507 ----------------------------------
30508 -- Find_Related_Package_Or_Body --
30509 ----------------------------------
30511 function Find_Related_Package_Or_Body
30513 Do_Checks : Boolean := False) return Node_Id
30515 Context : constant Node_Id := Parent (Prag);
30516 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
30520 Stmt := Prev (Prag);
30521 while Present (Stmt) loop
30523 -- Skip prior pragmas, but check for duplicates
30525 if Nkind (Stmt) = N_Pragma then
30526 if Do_Checks and then Pragma_Name (Stmt) = Prag_Nam then
30532 -- Skip internally generated code
30534 elsif not Comes_From_Source (Stmt) then
30535 if Nkind (Stmt) = N_Subprogram_Declaration then
30537 -- The subprogram declaration is an internally generated spec
30538 -- for an expression function.
30540 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
30543 -- The subprogram is actually an instance housed within an
30544 -- anonymous wrapper package.
30546 elsif Present (Generic_Parent (Specification (Stmt))) then
30551 -- Return the current source construct which is illegal
30560 -- If we fall through, then the pragma was either the first declaration
30561 -- or it was preceded by other pragmas and no source constructs.
30563 -- The pragma is associated with a package. The immediate context in
30564 -- this case is the specification of the package.
30566 if Nkind (Context) = N_Package_Specification then
30567 return Parent (Context);
30569 -- The pragma appears in the declarations of a package body
30571 elsif Nkind (Context) = N_Package_Body then
30574 -- The pragma appears in the statements of a package body
30576 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
30577 and then Nkind (Parent (Context)) = N_Package_Body
30579 return Parent (Context);
30581 -- The pragma is a byproduct of aspect expansion, return the related
30582 -- context of the original aspect. This case has a lower priority as
30583 -- the above circuitry pinpoints precisely the related context.
30585 elsif Present (Corresponding_Aspect (Prag)) then
30586 return Parent (Corresponding_Aspect (Prag));
30588 -- No candidate package [body] found
30593 end Find_Related_Package_Or_Body;
30599 function Get_Argument
30601 Context_Id : Entity_Id := Empty) return Node_Id
30603 Args : constant List_Id := Pragma_Argument_Associations (Prag);
30606 -- Use the expression of the original aspect when compiling for ASIS or
30607 -- when analyzing the template of a generic unit. In both cases the
30608 -- aspect's tree must be decorated to allow for ASIS queries or to save
30609 -- the global references in the generic context.
30611 if From_Aspect_Specification (Prag)
30612 and then (ASIS_Mode or else (Present (Context_Id)
30613 and then Is_Generic_Unit (Context_Id)))
30615 return Corresponding_Aspect (Prag);
30617 -- Otherwise use the expression of the pragma
30619 elsif Present (Args) then
30620 return First (Args);
30627 -------------------------
30628 -- Get_Base_Subprogram --
30629 -------------------------
30631 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
30633 -- Follow subprogram renaming chain
30635 if Is_Subprogram (Def_Id)
30636 and then Nkind (Parent (Declaration_Node (Def_Id))) =
30637 N_Subprogram_Renaming_Declaration
30638 and then Present (Alias (Def_Id))
30640 return Alias (Def_Id);
30644 end Get_Base_Subprogram;
30646 -----------------------
30647 -- Get_SPARK_Mode_Type --
30648 -----------------------
30650 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is
30652 if N = Name_On then
30654 elsif N = Name_Off then
30657 -- Any other argument is illegal. Assume that no SPARK mode applies to
30658 -- avoid potential cascaded errors.
30663 end Get_SPARK_Mode_Type;
30665 ------------------------------------
30666 -- Get_SPARK_Mode_From_Annotation --
30667 ------------------------------------
30669 function Get_SPARK_Mode_From_Annotation
30670 (N : Node_Id) return SPARK_Mode_Type
30675 if Nkind (N) = N_Aspect_Specification then
30676 Mode := Expression (N);
30678 else pragma Assert (Nkind (N) = N_Pragma);
30679 Mode := First (Pragma_Argument_Associations (N));
30681 if Present (Mode) then
30682 Mode := Get_Pragma_Arg (Mode);
30686 -- Aspect or pragma SPARK_Mode specifies an explicit mode
30688 if Present (Mode) then
30689 if Nkind (Mode) = N_Identifier then
30690 return Get_SPARK_Mode_Type (Chars (Mode));
30692 -- In case of a malformed aspect or pragma, return the default None
30698 -- Otherwise the lack of an expression defaults SPARK_Mode to On
30703 end Get_SPARK_Mode_From_Annotation;
30705 ---------------------------
30706 -- Has_Extra_Parentheses --
30707 ---------------------------
30709 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean is
30713 -- The aggregate should not have an expression list because a clause
30714 -- is always interpreted as a component association. The only way an
30715 -- expression list can sneak in is by adding extra parentheses around
30716 -- the individual clauses:
30718 -- Depends (Output => Input) -- proper form
30719 -- Depends ((Output => Input)) -- extra parentheses
30721 -- Since the extra parentheses are not allowed by the syntax of the
30722 -- pragma, flag them now to avoid emitting misleading errors down the
30725 if Nkind (Clause) = N_Aggregate
30726 and then Present (Expressions (Clause))
30728 Expr := First (Expressions (Clause));
30729 while Present (Expr) loop
30731 -- A dependency clause surrounded by extra parentheses appears
30732 -- as an aggregate of component associations with an optional
30733 -- Paren_Count set.
30735 if Nkind (Expr) = N_Aggregate
30736 and then Present (Component_Associations (Expr))
30739 ("dependency clause contains extra parentheses", Expr);
30741 -- Otherwise the expression is a malformed construct
30744 SPARK_Msg_N ("malformed dependency clause", Expr);
30754 end Has_Extra_Parentheses;
30760 procedure Initialize is
30763 Compile_Time_Warnings_Errors.Init;
30772 Dummy := Dummy + 1;
30775 -----------------------------
30776 -- Is_Config_Static_String --
30777 -----------------------------
30779 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
30781 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
30782 -- This is an internal recursive function that is just like the outer
30783 -- function except that it adds the string to the name buffer rather
30784 -- than placing the string in the name buffer.
30786 ------------------------------
30787 -- Add_Config_Static_String --
30788 ------------------------------
30790 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
30797 if Nkind (N) = N_Op_Concat then
30798 if Add_Config_Static_String (Left_Opnd (N)) then
30799 N := Right_Opnd (N);
30805 if Nkind (N) /= N_String_Literal then
30806 Error_Msg_N ("string literal expected for pragma argument", N);
30810 for J in 1 .. String_Length (Strval (N)) loop
30811 C := Get_String_Char (Strval (N), J);
30813 if not In_Character_Range (C) then
30815 ("string literal contains invalid wide character",
30816 Sloc (N) + 1 + Source_Ptr (J));
30820 Add_Char_To_Name_Buffer (Get_Character (C));
30825 end Add_Config_Static_String;
30827 -- Start of processing for Is_Config_Static_String
30832 return Add_Config_Static_String (Arg);
30833 end Is_Config_Static_String;
30835 -------------------------------
30836 -- Is_Elaboration_SPARK_Mode --
30837 -------------------------------
30839 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is
30842 (Nkind (N) = N_Pragma
30843 and then Pragma_Name (N) = Name_SPARK_Mode
30844 and then Is_List_Member (N));
30846 -- Pragma SPARK_Mode affects the elaboration of a package body when it
30847 -- appears in the statement part of the body.
30850 Present (Parent (N))
30851 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
30852 and then List_Containing (N) = Statements (Parent (N))
30853 and then Present (Parent (Parent (N)))
30854 and then Nkind (Parent (Parent (N))) = N_Package_Body;
30855 end Is_Elaboration_SPARK_Mode;
30857 -----------------------
30858 -- Is_Enabled_Pragma --
30859 -----------------------
30861 function Is_Enabled_Pragma (Prag : Node_Id) return Boolean is
30865 if Present (Prag) then
30866 Arg := First (Pragma_Argument_Associations (Prag));
30868 if Present (Arg) then
30869 return Is_True (Expr_Value (Get_Pragma_Arg (Arg)));
30871 -- The lack of a Boolean argument automatically enables the pragma
30877 -- The pragma is missing, therefore it is not enabled
30882 end Is_Enabled_Pragma;
30884 -----------------------------------------
30885 -- Is_Non_Significant_Pragma_Reference --
30886 -----------------------------------------
30888 -- This function makes use of the following static table which indicates
30889 -- whether appearance of some name in a given pragma is to be considered
30890 -- as a reference for the purposes of warnings about unreferenced objects.
30892 -- -1 indicates that appearence in any argument is significant
30893 -- 0 indicates that appearance in any argument is not significant
30894 -- +n indicates that appearance as argument n is significant, but all
30895 -- other arguments are not significant
30896 -- 9n arguments from n on are significant, before n insignificant
30898 Sig_Flags : constant array (Pragma_Id) of Int :=
30899 (Pragma_Abort_Defer => -1,
30900 Pragma_Abstract_State => -1,
30901 Pragma_Acc_Data => 0,
30902 Pragma_Acc_Kernels => 0,
30903 Pragma_Acc_Loop => 0,
30904 Pragma_Acc_Parallel => 0,
30905 Pragma_Ada_83 => -1,
30906 Pragma_Ada_95 => -1,
30907 Pragma_Ada_05 => -1,
30908 Pragma_Ada_2005 => -1,
30909 Pragma_Ada_12 => -1,
30910 Pragma_Ada_2012 => -1,
30911 Pragma_Ada_2020 => -1,
30912 Pragma_Aggregate_Individually_Assign => 0,
30913 Pragma_All_Calls_Remote => -1,
30914 Pragma_Allow_Integer_Address => -1,
30915 Pragma_Annotate => 93,
30916 Pragma_Assert => -1,
30917 Pragma_Assert_And_Cut => -1,
30918 Pragma_Assertion_Policy => 0,
30919 Pragma_Assume => -1,
30920 Pragma_Assume_No_Invalid_Values => 0,
30921 Pragma_Async_Readers => 0,
30922 Pragma_Async_Writers => 0,
30923 Pragma_Asynchronous => 0,
30924 Pragma_Atomic => 0,
30925 Pragma_Atomic_Components => 0,
30926 Pragma_Attach_Handler => -1,
30927 Pragma_Attribute_Definition => 92,
30928 Pragma_Check => -1,
30929 Pragma_Check_Float_Overflow => 0,
30930 Pragma_Check_Name => 0,
30931 Pragma_Check_Policy => 0,
30932 Pragma_CPP_Class => 0,
30933 Pragma_CPP_Constructor => 0,
30934 Pragma_CPP_Virtual => 0,
30935 Pragma_CPP_Vtable => 0,
30937 Pragma_C_Pass_By_Copy => 0,
30938 Pragma_Comment => -1,
30939 Pragma_Common_Object => 0,
30940 Pragma_Compile_Time_Error => -1,
30941 Pragma_Compile_Time_Warning => -1,
30942 Pragma_Compiler_Unit => -1,
30943 Pragma_Compiler_Unit_Warning => -1,
30944 Pragma_Complete_Representation => 0,
30945 Pragma_Complex_Representation => 0,
30946 Pragma_Component_Alignment => 0,
30947 Pragma_Constant_After_Elaboration => 0,
30948 Pragma_Contract_Cases => -1,
30949 Pragma_Controlled => 0,
30950 Pragma_Convention => 0,
30951 Pragma_Convention_Identifier => 0,
30952 Pragma_Deadline_Floor => -1,
30953 Pragma_Debug => -1,
30954 Pragma_Debug_Policy => 0,
30955 Pragma_Detect_Blocking => 0,
30956 Pragma_Default_Initial_Condition => -1,
30957 Pragma_Default_Scalar_Storage_Order => 0,
30958 Pragma_Default_Storage_Pool => 0,
30959 Pragma_Depends => -1,
30960 Pragma_Disable_Atomic_Synchronization => 0,
30961 Pragma_Discard_Names => 0,
30962 Pragma_Dispatching_Domain => -1,
30963 Pragma_Effective_Reads => 0,
30964 Pragma_Effective_Writes => 0,
30965 Pragma_Elaborate => 0,
30966 Pragma_Elaborate_All => 0,
30967 Pragma_Elaborate_Body => 0,
30968 Pragma_Elaboration_Checks => 0,
30969 Pragma_Eliminate => 0,
30970 Pragma_Enable_Atomic_Synchronization => 0,
30971 Pragma_Export => -1,
30972 Pragma_Export_Function => -1,
30973 Pragma_Export_Object => -1,
30974 Pragma_Export_Procedure => -1,
30975 Pragma_Export_Value => -1,
30976 Pragma_Export_Valued_Procedure => -1,
30977 Pragma_Extend_System => -1,
30978 Pragma_Extensions_Allowed => 0,
30979 Pragma_Extensions_Visible => 0,
30980 Pragma_External => -1,
30981 Pragma_Favor_Top_Level => 0,
30982 Pragma_External_Name_Casing => 0,
30983 Pragma_Fast_Math => 0,
30984 Pragma_Finalize_Storage_Only => 0,
30986 Pragma_Global => -1,
30987 Pragma_Ident => -1,
30988 Pragma_Ignore_Pragma => 0,
30989 Pragma_Implementation_Defined => -1,
30990 Pragma_Implemented => -1,
30991 Pragma_Implicit_Packing => 0,
30992 Pragma_Import => 93,
30993 Pragma_Import_Function => 0,
30994 Pragma_Import_Object => 0,
30995 Pragma_Import_Procedure => 0,
30996 Pragma_Import_Valued_Procedure => 0,
30997 Pragma_Independent => 0,
30998 Pragma_Independent_Components => 0,
30999 Pragma_Initial_Condition => -1,
31000 Pragma_Initialize_Scalars => 0,
31001 Pragma_Initializes => -1,
31002 Pragma_Inline => 0,
31003 Pragma_Inline_Always => 0,
31004 Pragma_Inline_Generic => 0,
31005 Pragma_Inspection_Point => -1,
31006 Pragma_Interface => 92,
31007 Pragma_Interface_Name => 0,
31008 Pragma_Interrupt_Handler => -1,
31009 Pragma_Interrupt_Priority => -1,
31010 Pragma_Interrupt_State => -1,
31011 Pragma_Invariant => -1,
31012 Pragma_Keep_Names => 0,
31013 Pragma_License => 0,
31014 Pragma_Link_With => -1,
31015 Pragma_Linker_Alias => -1,
31016 Pragma_Linker_Constructor => -1,
31017 Pragma_Linker_Destructor => -1,
31018 Pragma_Linker_Options => -1,
31019 Pragma_Linker_Section => -1,
31021 Pragma_Lock_Free => 0,
31022 Pragma_Locking_Policy => 0,
31023 Pragma_Loop_Invariant => -1,
31024 Pragma_Loop_Optimize => 0,
31025 Pragma_Loop_Variant => -1,
31026 Pragma_Machine_Attribute => -1,
31028 Pragma_Main_Storage => -1,
31029 Pragma_Max_Entry_Queue_Depth => 0,
31030 Pragma_Max_Entry_Queue_Length => 0,
31031 Pragma_Max_Queue_Length => 0,
31032 Pragma_Memory_Size => 0,
31033 Pragma_No_Body => 0,
31034 Pragma_No_Caching => 0,
31035 Pragma_No_Component_Reordering => -1,
31036 Pragma_No_Elaboration_Code_All => 0,
31037 Pragma_No_Heap_Finalization => 0,
31038 Pragma_No_Inline => 0,
31039 Pragma_No_Return => 0,
31040 Pragma_No_Run_Time => -1,
31041 Pragma_No_Strict_Aliasing => -1,
31042 Pragma_No_Tagged_Streams => 0,
31043 Pragma_Normalize_Scalars => 0,
31044 Pragma_Obsolescent => 0,
31045 Pragma_Optimize => 0,
31046 Pragma_Optimize_Alignment => 0,
31047 Pragma_Overflow_Mode => 0,
31048 Pragma_Overriding_Renamings => 0,
31049 Pragma_Ordered => 0,
31052 Pragma_Part_Of => 0,
31053 Pragma_Partition_Elaboration_Policy => 0,
31054 Pragma_Passive => 0,
31055 Pragma_Persistent_BSS => 0,
31056 Pragma_Polling => 0,
31057 Pragma_Prefix_Exception_Messages => 0,
31059 Pragma_Postcondition => -1,
31060 Pragma_Post_Class => -1,
31062 Pragma_Precondition => -1,
31063 Pragma_Predicate => -1,
31064 Pragma_Predicate_Failure => -1,
31065 Pragma_Preelaborable_Initialization => -1,
31066 Pragma_Preelaborate => 0,
31067 Pragma_Pre_Class => -1,
31068 Pragma_Priority => -1,
31069 Pragma_Priority_Specific_Dispatching => 0,
31070 Pragma_Profile => 0,
31071 Pragma_Profile_Warnings => 0,
31072 Pragma_Propagate_Exceptions => 0,
31073 Pragma_Provide_Shift_Operators => 0,
31074 Pragma_Psect_Object => 0,
31076 Pragma_Pure_Function => 0,
31077 Pragma_Queuing_Policy => 0,
31078 Pragma_Rational => 0,
31079 Pragma_Ravenscar => 0,
31080 Pragma_Refined_Depends => -1,
31081 Pragma_Refined_Global => -1,
31082 Pragma_Refined_Post => -1,
31083 Pragma_Refined_State => -1,
31084 Pragma_Relative_Deadline => 0,
31085 Pragma_Rename_Pragma => 0,
31086 Pragma_Remote_Access_Type => -1,
31087 Pragma_Remote_Call_Interface => -1,
31088 Pragma_Remote_Types => -1,
31089 Pragma_Restricted_Run_Time => 0,
31090 Pragma_Restriction_Warnings => 0,
31091 Pragma_Restrictions => 0,
31092 Pragma_Reviewable => -1,
31093 Pragma_Secondary_Stack_Size => -1,
31094 Pragma_Short_Circuit_And_Or => 0,
31095 Pragma_Share_Generic => 0,
31096 Pragma_Shared => 0,
31097 Pragma_Shared_Passive => 0,
31098 Pragma_Short_Descriptors => 0,
31099 Pragma_Simple_Storage_Pool_Type => 0,
31100 Pragma_Source_File_Name => 0,
31101 Pragma_Source_File_Name_Project => 0,
31102 Pragma_Source_Reference => 0,
31103 Pragma_SPARK_Mode => 0,
31104 Pragma_Storage_Size => -1,
31105 Pragma_Storage_Unit => 0,
31106 Pragma_Static_Elaboration_Desired => 0,
31107 Pragma_Stream_Convert => 0,
31108 Pragma_Style_Checks => 0,
31109 Pragma_Subtitle => 0,
31110 Pragma_Suppress => 0,
31111 Pragma_Suppress_Exception_Locations => 0,
31112 Pragma_Suppress_All => 0,
31113 Pragma_Suppress_Debug_Info => 0,
31114 Pragma_Suppress_Initialization => 0,
31115 Pragma_System_Name => 0,
31116 Pragma_Task_Dispatching_Policy => 0,
31117 Pragma_Task_Info => -1,
31118 Pragma_Task_Name => -1,
31119 Pragma_Task_Storage => -1,
31120 Pragma_Test_Case => -1,
31121 Pragma_Thread_Local_Storage => -1,
31122 Pragma_Time_Slice => -1,
31124 Pragma_Type_Invariant => -1,
31125 Pragma_Type_Invariant_Class => -1,
31126 Pragma_Unchecked_Union => 0,
31127 Pragma_Unevaluated_Use_Of_Old => 0,
31128 Pragma_Unimplemented_Unit => 0,
31129 Pragma_Universal_Aliasing => 0,
31130 Pragma_Universal_Data => 0,
31131 Pragma_Unmodified => 0,
31132 Pragma_Unreferenced => 0,
31133 Pragma_Unreferenced_Objects => 0,
31134 Pragma_Unreserve_All_Interrupts => 0,
31135 Pragma_Unsuppress => 0,
31136 Pragma_Unused => 0,
31137 Pragma_Use_VADS_Size => 0,
31138 Pragma_Validity_Checks => 0,
31139 Pragma_Volatile => 0,
31140 Pragma_Volatile_Components => 0,
31141 Pragma_Volatile_Full_Access => 0,
31142 Pragma_Volatile_Function => 0,
31143 Pragma_Warning_As_Error => 0,
31144 Pragma_Warnings => 0,
31145 Pragma_Weak_External => 0,
31146 Pragma_Wide_Character_Encoding => 0,
31147 Unknown_Pragma => 0);
31149 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
31155 function Arg_No return Nat;
31156 -- Returns an integer showing what argument we are in. A value of
31157 -- zero means we are not in any of the arguments.
31163 function Arg_No return Nat is
31168 A := First (Pragma_Argument_Associations (Parent (P)));
31182 -- Start of processing for Non_Significant_Pragma_Reference
31187 if Nkind (P) /= N_Pragma_Argument_Association then
31191 Id := Get_Pragma_Id (Parent (P));
31192 C := Sig_Flags (Id);
31207 return AN < (C - 90);
31213 end Is_Non_Significant_Pragma_Reference;
31215 ------------------------------
31216 -- Is_Pragma_String_Literal --
31217 ------------------------------
31219 -- This function returns true if the corresponding pragma argument is a
31220 -- static string expression. These are the only cases in which string
31221 -- literals can appear as pragma arguments. We also allow a string literal
31222 -- as the first argument to pragma Assert (although it will of course
31223 -- always generate a type error).
31225 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
31226 Pragn : constant Node_Id := Parent (Par);
31227 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
31228 Pname : constant Name_Id := Pragma_Name (Pragn);
31234 N := First (Assoc);
31241 if Pname = Name_Assert then
31244 elsif Pname = Name_Export then
31247 elsif Pname = Name_Ident then
31250 elsif Pname = Name_Import then
31253 elsif Pname = Name_Interface_Name then
31256 elsif Pname = Name_Linker_Alias then
31259 elsif Pname = Name_Linker_Section then
31262 elsif Pname = Name_Machine_Attribute then
31265 elsif Pname = Name_Source_File_Name then
31268 elsif Pname = Name_Source_Reference then
31271 elsif Pname = Name_Title then
31274 elsif Pname = Name_Subtitle then
31280 end Is_Pragma_String_Literal;
31282 ---------------------------
31283 -- Is_Private_SPARK_Mode --
31284 ---------------------------
31286 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is
31289 (Nkind (N) = N_Pragma
31290 and then Pragma_Name (N) = Name_SPARK_Mode
31291 and then Is_List_Member (N));
31293 -- For pragma SPARK_Mode to be private, it has to appear in the private
31294 -- declarations of a package.
31297 Present (Parent (N))
31298 and then Nkind (Parent (N)) = N_Package_Specification
31299 and then List_Containing (N) = Private_Declarations (Parent (N));
31300 end Is_Private_SPARK_Mode;
31302 -------------------------------------
31303 -- Is_Unconstrained_Or_Tagged_Item --
31304 -------------------------------------
31306 function Is_Unconstrained_Or_Tagged_Item
31307 (Item : Entity_Id) return Boolean
31309 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean;
31310 -- Determine whether record type Typ has at least one unconstrained
31313 ---------------------------------
31314 -- Has_Unconstrained_Component --
31315 ---------------------------------
31317 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is
31321 Comp := First_Component (Typ);
31322 while Present (Comp) loop
31323 if Is_Unconstrained_Or_Tagged_Item (Comp) then
31327 Next_Component (Comp);
31331 end Has_Unconstrained_Component;
31335 Typ : constant Entity_Id := Etype (Item);
31337 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
31340 if Is_Tagged_Type (Typ) then
31343 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
31346 elsif Is_Record_Type (Typ) then
31347 if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then
31350 return Has_Unconstrained_Component (Typ);
31353 elsif Is_Private_Type (Typ) and then Has_Discriminants (Typ) then
31359 end Is_Unconstrained_Or_Tagged_Item;
31361 -----------------------------
31362 -- Is_Valid_Assertion_Kind --
31363 -----------------------------
31365 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is
31372 | Name_Assertion_Policy
31373 | Name_Static_Predicate
31374 | Name_Dynamic_Predicate
31379 | Name_Type_Invariant
31380 | Name_uType_Invariant
31384 | Name_Assert_And_Cut
31386 | Name_Contract_Cases
31388 | Name_Default_Initial_Condition
31390 | Name_Initial_Condition
31393 | Name_Loop_Invariant
31394 | Name_Loop_Variant
31395 | Name_Postcondition
31396 | Name_Precondition
31398 | Name_Refined_Post
31399 | Name_Statement_Assertions
31406 end Is_Valid_Assertion_Kind;
31408 --------------------------------------
31409 -- Process_Compilation_Unit_Pragmas --
31410 --------------------------------------
31412 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
31414 -- A special check for pragma Suppress_All, a very strange DEC pragma,
31415 -- strange because it comes at the end of the unit. Rational has the
31416 -- same name for a pragma, but treats it as a program unit pragma, In
31417 -- GNAT we just decide to allow it anywhere at all. If it appeared then
31418 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
31419 -- node, and we insert a pragma Suppress (All_Checks) at the start of
31420 -- the context clause to ensure the correct processing.
31422 if Has_Pragma_Suppress_All (N) then
31423 Prepend_To (Context_Items (N),
31424 Make_Pragma (Sloc (N),
31425 Chars => Name_Suppress,
31426 Pragma_Argument_Associations => New_List (
31427 Make_Pragma_Argument_Association (Sloc (N),
31428 Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
31431 -- Nothing else to do at the current time
31433 end Process_Compilation_Unit_Pragmas;
31435 --------------------------------------------
31436 -- Validate_Compile_Time_Warning_Or_Error --
31437 --------------------------------------------
31439 procedure Validate_Compile_Time_Warning_Or_Error
31443 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
31444 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
31445 Arg2 : constant Node_Id := Next (Arg1);
31448 Analyze_And_Resolve (Arg1x, Standard_Boolean);
31450 if Compile_Time_Known_Value (Arg1x) then
31451 if Is_True (Expr_Value (Arg1x)) then
31453 -- We have already verified that the second argument is a static
31454 -- string expression. Its string value must be retrieved
31455 -- explicitly if it is a declared constant, otherwise it has
31456 -- been constant-folded previously.
31459 Cent : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
31460 Pname : constant Name_Id := Pragma_Name_Unmapped (N);
31461 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
31462 Str : constant String_Id :=
31463 Strval (Expr_Value_S (Get_Pragma_Arg (Arg2)));
31464 Str_Len : constant Nat := String_Length (Str);
31466 Force : constant Boolean :=
31467 Prag_Id = Pragma_Compile_Time_Warning
31468 and then Is_Spec_Name (Unit_Name (Current_Sem_Unit))
31469 and then (Ekind (Cent) /= E_Package
31470 or else not In_Private_Part (Cent));
31471 -- Set True if this is the warning case, and we are in the
31472 -- visible part of a package spec, or in a subprogram spec,
31473 -- in which case we want to force the client to see the
31474 -- warning, even though it is not in the main unit.
31482 -- Loop through segments of message separated by line feeds.
31483 -- We output these segments as separate messages with
31484 -- continuation marks for all but the first.
31489 Error_Msg_Strlen := 0;
31491 -- Loop to copy characters from argument to error message
31495 exit when Ptr > Str_Len;
31496 CC := Get_String_Char (Str, Ptr);
31499 -- Ignore wide chars ??? else store character
31501 if In_Character_Range (CC) then
31502 C := Get_Character (CC);
31503 exit when C = ASCII.LF;
31504 Error_Msg_Strlen := Error_Msg_Strlen + 1;
31505 Error_Msg_String (Error_Msg_Strlen) := C;
31509 -- Here with one line ready to go
31511 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
31513 -- If this is a warning in a spec, then we want clients
31514 -- to see the warning, so mark the message with the
31515 -- special sequence !! to force the warning. In the case
31516 -- of a package spec, we do not force this if we are in
31517 -- the private part of the spec.
31520 if Cont = False then
31521 Error_Msg ("<<~!!", Eloc);
31524 Error_Msg ("\<<~!!", Eloc);
31527 -- Error, rather than warning, or in a body, so we do not
31528 -- need to force visibility for client (error will be
31529 -- output in any case, and this is the situation in which
31530 -- we do not want a client to get a warning, since the
31531 -- warning is in the body or the spec private part).
31534 if Cont = False then
31535 Error_Msg ("<<~", Eloc);
31538 Error_Msg ("\<<~", Eloc);
31542 exit when Ptr > Str_Len;
31547 -- Arg1x is not known at compile time, so issue a warning. This can
31548 -- happen only if the pragma's processing was deferred until after the
31549 -- back end is run (see Process_Compile_Time_Warning_Or_Error).
31550 -- Note that the warning control switch applies to both pragmas.
31552 elsif Warn_On_Unknown_Compile_Time_Warning then
31553 Error_Msg_N ("?condition is not known at compile time", Arg1x);
31555 end Validate_Compile_Time_Warning_Or_Error;
31557 ------------------------------------
31558 -- Record_Possible_Body_Reference --
31559 ------------------------------------
31561 procedure Record_Possible_Body_Reference
31562 (State_Id : Entity_Id;
31566 Spec_Id : Entity_Id;
31569 -- Ensure that we are dealing with a reference to a state
31571 pragma Assert (Ekind (State_Id) = E_Abstract_State);
31573 -- Climb the tree starting from the reference looking for a package body
31574 -- whose spec declares the referenced state. This criteria automatically
31575 -- excludes references in package specs which are legal. Note that it is
31576 -- not wise to emit an error now as the package body may lack pragma
31577 -- Refined_State or the referenced state may not be mentioned in the
31578 -- refinement. This approach avoids the generation of misleading errors.
31581 while Present (Context) loop
31582 if Nkind (Context) = N_Package_Body then
31583 Spec_Id := Corresponding_Spec (Context);
31585 if Present (Abstract_States (Spec_Id))
31586 and then Contains (Abstract_States (Spec_Id), State_Id)
31588 if No (Body_References (State_Id)) then
31589 Set_Body_References (State_Id, New_Elmt_List);
31592 Append_Elmt (Ref, To => Body_References (State_Id));
31597 Context := Parent (Context);
31599 end Record_Possible_Body_Reference;
31601 ------------------------------------------
31602 -- Relocate_Pragmas_To_Anonymous_Object --
31603 ------------------------------------------
31605 procedure Relocate_Pragmas_To_Anonymous_Object
31606 (Typ_Decl : Node_Id;
31607 Obj_Decl : Node_Id)
31611 Next_Decl : Node_Id;
31614 if Nkind (Typ_Decl) = N_Protected_Type_Declaration then
31615 Def := Protected_Definition (Typ_Decl);
31617 pragma Assert (Nkind (Typ_Decl) = N_Task_Type_Declaration);
31618 Def := Task_Definition (Typ_Decl);
31621 -- The concurrent definition has a visible declaration list. Inspect it
31622 -- and relocate all canidate pragmas.
31624 if Present (Def) and then Present (Visible_Declarations (Def)) then
31625 Decl := First (Visible_Declarations (Def));
31626 while Present (Decl) loop
31628 -- Preserve the following declaration for iteration purposes due
31629 -- to possible relocation of a pragma.
31631 Next_Decl := Next (Decl);
31633 if Nkind (Decl) = N_Pragma
31634 and then Pragma_On_Anonymous_Object_OK (Get_Pragma_Id (Decl))
31637 Insert_After (Obj_Decl, Decl);
31639 -- Skip internally generated code
31641 elsif not Comes_From_Source (Decl) then
31644 -- No candidate pragmas are available for relocation
31653 end Relocate_Pragmas_To_Anonymous_Object;
31655 ------------------------------
31656 -- Relocate_Pragmas_To_Body --
31657 ------------------------------
31659 procedure Relocate_Pragmas_To_Body
31660 (Subp_Body : Node_Id;
31661 Target_Body : Node_Id := Empty)
31663 procedure Relocate_Pragma (Prag : Node_Id);
31664 -- Remove a single pragma from its current list and add it to the
31665 -- declarations of the proper body (either Subp_Body or Target_Body).
31667 ---------------------
31668 -- Relocate_Pragma --
31669 ---------------------
31671 procedure Relocate_Pragma (Prag : Node_Id) is
31676 -- When subprogram stubs or expression functions are involves, the
31677 -- destination declaration list belongs to the proper body.
31679 if Present (Target_Body) then
31680 Target := Target_Body;
31682 Target := Subp_Body;
31685 Decls := Declarations (Target);
31689 Set_Declarations (Target, Decls);
31692 -- Unhook the pragma from its current list
31695 Prepend (Prag, Decls);
31696 end Relocate_Pragma;
31700 Body_Id : constant Entity_Id :=
31701 Defining_Unit_Name (Specification (Subp_Body));
31702 Next_Stmt : Node_Id;
31705 -- Start of processing for Relocate_Pragmas_To_Body
31708 -- Do not process a body that comes from a separate unit as no construct
31709 -- can possibly follow it.
31711 if not Is_List_Member (Subp_Body) then
31714 -- Do not relocate pragmas that follow a stub if the stub does not have
31717 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub
31718 and then No (Target_Body)
31722 -- Do not process internally generated routine _Postconditions
31724 elsif Ekind (Body_Id) = E_Procedure
31725 and then Chars (Body_Id) = Name_uPostconditions
31730 -- Look at what is following the body. We are interested in certain kind
31731 -- of pragmas (either from source or byproducts of expansion) that can
31732 -- apply to a body [stub].
31734 Stmt := Next (Subp_Body);
31735 while Present (Stmt) loop
31737 -- Preserve the following statement for iteration purposes due to a
31738 -- possible relocation of a pragma.
31740 Next_Stmt := Next (Stmt);
31742 -- Move a candidate pragma following the body to the declarations of
31745 if Nkind (Stmt) = N_Pragma
31746 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt))
31749 -- If a source pragma Warnings follows the body, it applies to
31750 -- following statements and does not belong in the body.
31752 if Get_Pragma_Id (Stmt) = Pragma_Warnings
31753 and then Comes_From_Source (Stmt)
31757 Relocate_Pragma (Stmt);
31760 -- Skip internally generated code
31762 elsif not Comes_From_Source (Stmt) then
31765 -- No candidate pragmas are available for relocation
31773 end Relocate_Pragmas_To_Body;
31775 -------------------
31776 -- Resolve_State --
31777 -------------------
31779 procedure Resolve_State (N : Node_Id) is
31784 if Is_Entity_Name (N) and then Present (Entity (N)) then
31785 Func := Entity (N);
31787 -- Handle overloading of state names by functions. Traverse the
31788 -- homonym chain looking for an abstract state.
31790 if Ekind (Func) = E_Function and then Has_Homonym (Func) then
31791 pragma Assert (Is_Overloaded (N));
31793 State := Homonym (Func);
31794 while Present (State) loop
31795 if Ekind (State) = E_Abstract_State then
31797 -- Resolve the overloading by setting the proper entity of
31798 -- the reference to that of the state.
31800 Set_Etype (N, Standard_Void_Type);
31801 Set_Entity (N, State);
31802 Set_Is_Overloaded (N, False);
31804 Generate_Reference (State, N);
31808 State := Homonym (State);
31811 -- A function can never act as a state. If the homonym chain does
31812 -- not contain a corresponding state, then something went wrong in
31813 -- the overloading mechanism.
31815 raise Program_Error;
31820 ----------------------------
31821 -- Rewrite_Assertion_Kind --
31822 ----------------------------
31824 procedure Rewrite_Assertion_Kind
31826 From_Policy : Boolean := False)
31832 if Nkind (N) = N_Attribute_Reference
31833 and then Attribute_Name (N) = Name_Class
31834 and then Nkind (Prefix (N)) = N_Identifier
31836 case Chars (Prefix (N)) is
31843 when Name_Type_Invariant =>
31844 Nam := Name_uType_Invariant;
31846 when Name_Invariant =>
31847 Nam := Name_uInvariant;
31853 -- Recommend standard use of aspect names Pre/Post
31855 elsif Nkind (N) = N_Identifier
31856 and then From_Policy
31857 and then Serious_Errors_Detected = 0
31858 and then not ASIS_Mode
31860 if Chars (N) = Name_Precondition
31861 or else Chars (N) = Name_Postcondition
31863 Error_Msg_N ("Check_Policy is a non-standard pragma??", N);
31865 ("\use Assertion_Policy and aspect names Pre/Post for "
31866 & "Ada2012 conformance?", N);
31872 if Nam /= No_Name then
31873 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam));
31875 end Rewrite_Assertion_Kind;
31883 Dummy := Dummy + 1;
31886 --------------------------------
31887 -- Set_Encoded_Interface_Name --
31888 --------------------------------
31890 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
31891 Str : constant String_Id := Strval (S);
31892 Len : constant Nat := String_Length (Str);
31897 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
31900 -- Stores encoded value of character code CC. The encoding we use an
31901 -- underscore followed by four lower case hex digits.
31907 procedure Encode is
31909 Store_String_Char (Get_Char_Code ('_'));
31911 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
31913 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
31915 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
31917 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
31920 -- Start of processing for Set_Encoded_Interface_Name
31923 -- If first character is asterisk, this is a link name, and we leave it
31924 -- completely unmodified. We also ignore null strings (the latter case
31925 -- happens only in error cases).
31928 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
31930 Set_Interface_Name (E, S);
31935 CC := Get_String_Char (Str, J);
31937 exit when not In_Character_Range (CC);
31939 C := Get_Character (CC);
31941 exit when C /= '_' and then C /= '$'
31942 and then C not in '0' .. '9'
31943 and then C not in 'a' .. 'z'
31944 and then C not in 'A' .. 'Z';
31947 Set_Interface_Name (E, S);
31955 -- Here we need to encode. The encoding we use as follows:
31956 -- three underscores + four hex digits (lower case)
31960 for J in 1 .. String_Length (Str) loop
31961 CC := Get_String_Char (Str, J);
31963 if not In_Character_Range (CC) then
31966 C := Get_Character (CC);
31968 if C = '_' or else C = '$'
31969 or else C in '0' .. '9'
31970 or else C in 'a' .. 'z'
31971 or else C in 'A' .. 'Z'
31973 Store_String_Char (CC);
31980 Set_Interface_Name (E,
31981 Make_String_Literal (Sloc (S),
31982 Strval => End_String));
31984 end Set_Encoded_Interface_Name;
31986 ------------------------
31987 -- Set_Elab_Unit_Name --
31988 ------------------------
31990 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id) is
31995 if Nkind (N) = N_Identifier
31996 and then Nkind (With_Item) = N_Identifier
31998 Set_Entity (N, Entity (With_Item));
32000 elsif Nkind (N) = N_Selected_Component then
32001 Change_Selected_Component_To_Expanded_Name (N);
32002 Set_Entity (N, Entity (With_Item));
32003 Set_Entity (Selector_Name (N), Entity (N));
32005 Pref := Prefix (N);
32006 Scop := Scope (Entity (N));
32007 while Nkind (Pref) = N_Selected_Component loop
32008 Change_Selected_Component_To_Expanded_Name (Pref);
32009 Set_Entity (Selector_Name (Pref), Scop);
32010 Set_Entity (Pref, Scop);
32011 Pref := Prefix (Pref);
32012 Scop := Scope (Scop);
32015 Set_Entity (Pref, Scop);
32018 Generate_Reference (Entity (With_Item), N, Set_Ref => False);
32019 end Set_Elab_Unit_Name;
32021 -------------------
32022 -- Test_Case_Arg --
32023 -------------------
32025 function Test_Case_Arg
32028 From_Aspect : Boolean := False) return Node_Id
32030 Aspect : constant Node_Id := Corresponding_Aspect (Prag);
32035 pragma Assert (Nam_In (Arg_Nam, Name_Ensures,
32040 -- The caller requests the aspect argument
32042 if From_Aspect then
32043 if Present (Aspect)
32044 and then Nkind (Expression (Aspect)) = N_Aggregate
32046 Args := Expression (Aspect);
32048 -- "Name" and "Mode" may appear without an identifier as a
32049 -- positional association.
32051 if Present (Expressions (Args)) then
32052 Arg := First (Expressions (Args));
32054 if Present (Arg) and then Arg_Nam = Name_Name then
32062 if Present (Arg) and then Arg_Nam = Name_Mode then
32067 -- Some or all arguments may appear as component associatons
32069 if Present (Component_Associations (Args)) then
32070 Arg := First (Component_Associations (Args));
32071 while Present (Arg) loop
32072 if Chars (First (Choices (Arg))) = Arg_Nam then
32081 -- Otherwise retrieve the argument directly from the pragma
32084 Arg := First (Pragma_Argument_Associations (Prag));
32086 if Present (Arg) and then Arg_Nam = Name_Name then
32090 -- Skip argument "Name"
32094 if Present (Arg) and then Arg_Nam = Name_Mode then
32098 -- Skip argument "Mode"
32102 -- Arguments "Requires" and "Ensures" are optional and may not be
32105 while Present (Arg) loop
32106 if Chars (Arg) = Arg_Nam then
32117 -----------------------------------------
32118 -- Defer_Compile_Time_Warning_Error_To_BE --
32119 -----------------------------------------
32121 procedure Defer_Compile_Time_Warning_Error_To_BE (N : Node_Id) is
32122 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
32124 Compile_Time_Warnings_Errors.Append
32125 (New_Val => CTWE_Entry'(Eloc => Sloc (Arg1),
32126 Scope => Current_Scope,
32128 end Defer_Compile_Time_Warning_Error_To_BE;
32130 ------------------------------------------
32131 -- Validate_Compile_Time_Warning_Errors --
32132 ------------------------------------------
32134 procedure Validate_Compile_Time_Warning_Errors is
32135 procedure Set_Scope (S : Entity_Id);
32136 -- Install all enclosing scopes of S along with S itself
32138 procedure Unset_Scope (S : Entity_Id);
32139 -- Uninstall all enclosing scopes of S along with S itself
32145 procedure Set_Scope (S : Entity_Id) is
32147 if S /= Standard_Standard then
32148 Set_Scope (Scope (S));
32158 procedure Unset_Scope (S : Entity_Id) is
32160 if S /= Standard_Standard then
32161 Unset_Scope (Scope (S));
32167 -- Start of processing for Validate_Compile_Time_Warning_Errors
32170 Expander_Mode_Save_And_Set (False);
32171 In_Compile_Time_Warning_Or_Error := True;
32173 for N in Compile_Time_Warnings_Errors.First ..
32174 Compile_Time_Warnings_Errors.Last
32177 T : CTWE_Entry renames Compile_Time_Warnings_Errors.Table (N);
32180 Set_Scope (T.Scope);
32181 Reset_Analyzed_Flags (T.Prag);
32182 Validate_Compile_Time_Warning_Or_Error (T.Prag, T.Eloc);
32183 Unset_Scope (T.Scope);
32187 In_Compile_Time_Warning_Or_Error := False;
32188 Expander_Mode_Restore;
32189 end Validate_Compile_Time_Warning_Errors;